From 52e914b335272a1ee84cffa450da6aa645fd3452 Mon Sep 17 00:00:00 2001 From: fresheed Date: Tue, 3 Jun 2025 16:27:00 +0200 Subject: [PATCH 01/17] left only "trillium" dir and bumped to coq 9.0 --- .gitmodules | 9 - Makefile | 13 +- external/iris | 1 - external/paco | 1 - external/stdpp | 1 - fairis/fair_termination.v | 104 - fairis/fairness.v | 170 -- fairis/fairness_finiteness.v | 431 ---- fairis/fuel.v | 1261 ---------- fairis/fuel_termination.v | 60 - fairis/heap_lang/adequacy.v | 479 ---- .../examples/choose_nat/choose_nat.v | 297 --- .../examples/choose_nat/choose_nat_adequacy.v | 90 - fairis/heap_lang/examples/even_odd/even_odd.v | 348 --- .../examples/even_odd/even_odd_adequacy.v | 648 ----- fairis/heap_lang/examples/yesno/yesno.v | 466 ---- .../heap_lang/examples/yesno/yesno_adequacy.v | 250 -- fairis/heap_lang/lang.v | 750 ------ fairis/heap_lang/lifting.v | 594 ----- fairis/heap_lang/locations.v | 48 - fairis/heap_lang/notation.v | 159 -- fairis/heap_lang/proofmode.v | 1030 -------- fairis/heap_lang/tactics.v | 49 - fairis/inftraces.v | 596 ----- fairis/map_included_utils.v | 485 ---- fairis/resources.v | 2094 ----------------- fairis/trace_utils.v | 347 --- trillium/program_logic/adequacy.v | 4 +- trillium/program_logic/weakestpre.v | 2 +- 29 files changed, 6 insertions(+), 10781 deletions(-) delete mode 160000 external/iris delete mode 160000 external/paco delete mode 160000 external/stdpp delete mode 100644 fairis/fair_termination.v delete mode 100644 fairis/fairness.v delete mode 100644 fairis/fairness_finiteness.v delete mode 100644 fairis/fuel.v delete mode 100644 fairis/fuel_termination.v delete mode 100644 fairis/heap_lang/adequacy.v delete mode 100644 fairis/heap_lang/examples/choose_nat/choose_nat.v delete mode 100644 fairis/heap_lang/examples/choose_nat/choose_nat_adequacy.v delete mode 100644 fairis/heap_lang/examples/even_odd/even_odd.v delete mode 100644 fairis/heap_lang/examples/even_odd/even_odd_adequacy.v delete mode 100644 fairis/heap_lang/examples/yesno/yesno.v delete mode 100644 fairis/heap_lang/examples/yesno/yesno_adequacy.v delete mode 100644 fairis/heap_lang/lang.v delete mode 100644 fairis/heap_lang/lifting.v delete mode 100644 fairis/heap_lang/locations.v delete mode 100644 fairis/heap_lang/notation.v delete mode 100644 fairis/heap_lang/proofmode.v delete mode 100644 fairis/heap_lang/tactics.v delete mode 100644 fairis/inftraces.v delete mode 100644 fairis/map_included_utils.v delete mode 100644 fairis/resources.v delete mode 100644 fairis/trace_utils.v diff --git a/.gitmodules b/.gitmodules index 5defec0..e69de29 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,9 +0,0 @@ -[submodule "external/stdpp"] - path = external/stdpp - url = https://gitlab.mpi-sws.org/iris/stdpp.git -[submodule "external/iris"] - path = external/iris - url = https://gitlab.mpi-sws.org/iris/iris.git -[submodule "external/paco"] - path = external/paco - url = https://github.com/snu-sf/paco.git diff --git a/Makefile b/Makefile index a0f3c39..91d00ec 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,6 @@ TRILLIUM_DIR := 'trillium' -FAIRIS_DIR := 'fairis' -LOCAL_SRC_DIRS := $(TRILLIUM_DIR) $(FAIRIS_DIR) -SRC_DIRS := $(LOCAL_SRC_DIRS) 'external' +LOCAL_SRC_DIRS := $(TRILLIUM_DIR) +SRC_DIRS := $(LOCAL_SRC_DIRS) ALL_VFILES := $(shell find $(SRC_DIRS) -name "*.v") VFILES := $(shell find $(LOCAL_SRC_DIRS) -name "*.v") @@ -43,16 +42,13 @@ clean: rm -f .coqdeps.d # project-specific targets -.PHONY: build clean-trillium clean-fairis trillium fairis +.PHONY: build clean-trillium trillium VPATH= $(TRILLIUM_DIR) $(FAIRIS_DIR) VPATH_FILES := $(shell find $(VPATH) -name "*.v") build: $(VPATH_FILES:.v=.vo) -fairis : - @$(MAKE) build VPATH=$(FAIRIS_DIR) - trillium : @$(MAKE) build VPATH=$(TRILLIUM_DIR) @@ -63,6 +59,3 @@ clean-local: clean-trillium: @$(MAKE) clean-local LOCAL_SRC_DIRS=$(TRILLIUM_DIR) - -clean-fairis: - @$(MAKE) clean-local LOCAL_SRC_DIRS=$(FAIRIS_DIR) diff --git a/external/iris b/external/iris deleted file mode 160000 index 1bba489..0000000 --- a/external/iris +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 1bba4893b4d34539f6751ad50f1ec9ea8cefbdc3 diff --git a/external/paco b/external/paco deleted file mode 160000 index 5c5693f..0000000 --- a/external/paco +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 5c5693f46c8957f36a2349a0d906e911366136de diff --git a/external/stdpp b/external/stdpp deleted file mode 160000 index bc24e51..0000000 --- a/external/stdpp +++ /dev/null @@ -1 +0,0 @@ -Subproject commit bc24e51ca9ef6eb06af8731f97680725b2f0fb32 diff --git a/fairis/fair_termination.v b/fairis/fair_termination.v deleted file mode 100644 index 08d83a3..0000000 --- a/fairis/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: well_founded (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/fairis/fairness.v b/fairis/fairness.v deleted file mode 100644 index c53c183..0000000 --- a/fairis/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/fairis/fairness_finiteness.v b/fairis/fairness_finiteness.v deleted file mode 100644 index 511a189..0000000 --- a/fairis/fairness_finiteness.v +++ /dev/null @@ -1,431 +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 `{Countable (locale Λ)}. - Context `{LM: LiveModel Λ M}. - Context `{EqDecision M}. - - 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ζ) as Hfin. - by apply smaller_card_nat_finite in Hfin. - 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 Hxi. unfold enum_inner. rewrite elem_of_list_fmap. - exists (exist _ (δ', ℓ) Hxi). 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 $ ls_data s) (λ lab, get_role lab) aux). - - Program Definition enumerate_next extr (fmodtr: auxiliary_trace LM) c' oζ: - list (LiveStateData Λ M * @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 (ls_fuel δ1) ∪ live_roles _ s2); - (* ms ← enum_gmap_range_bounded' (live_roles _ s2 ∪ d) (locales_of_list c'.1); *) - let fss := enumerate_subdomain_gmap d (max_gmap (ls_fuel δ1) `max` LM.(lm_fl) s2) in - locs ← enumerate_dom_gsets' $ list_to_set $ locales_of_list c'.1; - ms ← enum_gmap_range_bounded' locs fss; - 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_map := `ms; - |}, ℓ'). - - Local Instance condition_1_decision x : - Decision - (∀ (ζ ζ' : locale Λ) (fs fs' : gmap (fmrole M) nat), - ζ ≠ ζ' → ls_map x !! ζ = Some fs → ls_map x !! ζ' = Some fs' → fs ##ₘ fs'). - Proof. apply make_decision. Qed. - - Definition to_ls (x: LiveStateData Λ M) : option LM := - match decide (∀ ζ ζ' fs fs', ζ ≠ ζ' → x.(ls_map) !! ζ = Some fs → x.(ls_map) !! ζ' = Some fs' → fs ##ₘ fs') - with - | right _ => None - | left Hdisj => - match decide (∀ ρ, ρ ∈ M.(live_roles) x.(ls_under) → ∃ ζ fs, x.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs) with - | right _ => None - | left Hlive => Some {| ls_data := x; ls_map_disj := Hdisj; ls_map_live := Hlive |} - end - end. - - Definition enumerate_next_valid extr (fmodtr: auxiliary_trace LM) c' oζ: list (LM * @mlabel LM) := - let ns := enumerate_next extr fmodtr c' oζ in - omap (λ '(x, ℓ), (λ x, (x, ℓ)) <$> to_ls x) ns. - - 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 [tp' σ'] oζ. - eapply finite_smaller_card_nat. - simpl. - eapply (in_list_finite (enumerate_next_valid ex atr (tp',σ') oζ)). - intros [δ' ℓ] [[Hlbl [Htrans Htids]] [Hξ Hφ]]. - unfold enumerate_next_valid. - - apply elem_of_list_omap. - exists (δ'.(ls_data), ℓ). - - split; last first. - { simpl. rewrite /to_ls /=. - destruct (decide - (∀ (ζ ζ' : locale Λ) (fs fs' : gmap (fmrole M) nat), - ζ ≠ ζ' → ls_map δ' !! ζ = Some fs → ls_map δ' !! ζ' = Some fs' → fs ##ₘ fs')); last first. - { pose proof ls_map_disj δ'. done. } - destruct (decide - (∀ ρ : fmrole M, ρ ∈ live_roles M δ' → ∃ (ζ : locale Λ) (fs : gmap (fmrole M) nat), - ls_map δ' !! ζ = Some fs ∧ ρ ∈ dom fs)). - - simpl. do 2 f_equal. destruct δ'. simpl. destruct ls_data. f_equal. - eapply proof_irrel. - eapply proof_irrel. - - pose proof ls_map_live δ'. done. } - - 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. } - - exists (dom δ'.(ls_data).(ls_map)). - split; last first. - { apply enumerate_dom_gsets'_spec. intros ζ Hin. simpl. - unfold tids_smaller in Htids. - specialize (Htids _ Hin). - by apply elem_of_list_to_set, locales_of_list_from_locale_from. } - - apply elem_of_list_bind. - unshelve eexists (ls_map δ' ↾ _); first done. split. - { apply elem_of_list_ret. destruct ℓ; destruct oζ; simpl; try naive_solver; - f_equal; try naive_solver. - - destruct δ'. simpl. destruct ls_data. simpl. done. - - destruct δ'. simpl. destruct ls_data. simpl. done. } - - apply enum_gmap_range_bounded'_spec. split=>//. - intros ζ fs Hlk. apply enumerate_subdomain_gmap_spec. - { intros ρ Hin. eapply ls_fuel_dom_data =>//. } - intros ρ f Hlk'. - have Hsome: ls_fuel δ' !! ρ = Some f by eapply ls_fuel_data. - have Hmapping: ls_mapping δ' !! ρ = Some ζ. - { eapply ls_mapping_data=>//. apply elem_of_dom. naive_solver. } - - destruct ℓ as [ρ' tid' | |]. - - destruct (decide (ρ = ρ')) as [-> | Hneq]. - + inversion Htrans as [? Hbig]. destruct Hbig as (Hmap&Hleq&?&Hlim&?&?). - rewrite Hsome /= in Hlim. 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. naive_solver. - - Unshelve. - + intros ??. apply make_decision. - + intros. apply make_proof_irrel. - + intros. apply make_proof_irrel. - + intros. apply make_proof_irrel. - + done. - Qed. -End finitary. - -Section finitary_simple. - Context `{M: FairModel}. - Context `{Λ: language}. - Context `{EqDecision M}. - Context `{Countable (locale Λ)}. - Context `{LM: LiveModel Λ M}. - - 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 Ht. unfold enum_inner. rewrite elem_of_list_fmap. - exists (exist _ (s2, ℓ) Ht). split =>//. apply elem_of_enum. - Qed. - - Program Definition enumerate_next_simple (fmodtr: auxiliary_trace LM) (c': cfg Λ) oζ: - list (LiveStateData Λ M * @mlabel LM) := - let δ1 := trace_last fmodtr in - '(s2, ℓ) ← (δ1.(ls_under), None) :: enum_inner_simple δ1.(ls_under); - d ← enumerate_dom_gsets' (dom (ls_fuel δ1) ∪ live_roles _ s2); - (* ms ← enum_gmap_range_bounded' (live_roles _ s2 ∪ d) (locales_of_list c'.1); *) - let fss := enumerate_subdomain_gmap d (max_gmap (ls_fuel δ1) `max` LM.(lm_fl) s2) in - locs ← enumerate_dom_gsets' $ list_to_set $ locales_of_list c'.1; - ms ← enum_gmap_range_bounded' locs fss; - 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_map := `ms; - |}, ℓ'). - - Definition enumerate_next_valid_simple (fmodtr: auxiliary_trace LM) c' oζ: list (LM * @mlabel LM) := - let ns := enumerate_next_simple fmodtr c' oζ in - omap (λ '(x, ℓ), (λ x, (x, ℓ)) <$> to_ls x) ns. - - Lemma valid_state_evolution_finitary_fairness_simple (φ: execution_trace Λ -> auxiliary_trace LM -> Prop) : - rel_finitary (valid_lift_fairness φ). - Proof. - rewrite /valid_lift_fairness. - intros ex atr [tp' σ'] oζ. - eapply finite_smaller_card_nat. - simpl. - eapply (in_list_finite (enumerate_next_valid_simple atr (tp',σ') oζ)). - intros [δ' ℓ] [[Hlab [Htrans Hsmall]] ?]. - unfold enumerate_next_valid. - - apply elem_of_list_omap. - exists (δ'.(ls_data), ℓ). - - split; last first. - { simpl. rewrite /to_ls /=. - destruct (decide - (∀ (ζ ζ' : locale Λ) (fs fs' : gmap (fmrole M) nat), - ζ ≠ ζ' → ls_map δ' !! ζ = Some fs → ls_map δ' !! ζ' = Some fs' → fs ##ₘ fs')); last first. - { pose proof ls_map_disj δ'. done. } - destruct (decide - (∀ ρ : fmrole M, ρ ∈ live_roles M δ' → ∃ (ζ : locale Λ) (fs : gmap (fmrole M) nat), - ls_map δ' !! ζ = Some fs ∧ ρ ∈ dom fs)). - - simpl. do 2 f_equal. destruct δ'. simpl. destruct ls_data. f_equal. - eapply proof_irrel. - eapply proof_irrel. - - pose proof ls_map_live δ'. done. } - - 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_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 $ 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. } - - exists (dom δ'.(ls_data).(ls_map)). - split; last first. - { apply enumerate_dom_gsets'_spec. intros ζ Hin. simpl. - unfold tids_smaller in Hsmall. - specialize (Hsmall _ Hin). - by apply elem_of_list_to_set, locales_of_list_from_locale_from. } - - apply elem_of_list_bind. - unshelve eexists (ls_map δ' ↾ _); first done. split. - { apply elem_of_list_ret. destruct ℓ; destruct oζ; simpl; try naive_solver; - f_equal; try naive_solver. - - destruct δ'. simpl. destruct ls_data. simpl. done. - - destruct δ'. simpl. destruct ls_data. simpl. done. } - - apply enum_gmap_range_bounded'_spec. split=>//. - intros ζ fs Hlk. apply enumerate_subdomain_gmap_spec. - { intros ρ Hin. eapply ls_fuel_dom_data =>//. } - intros ρ f Hlk'. - have Hsome: ls_fuel δ' !! ρ = Some f by eapply ls_fuel_data. - have Hmapping: ls_mapping δ' !! ρ = Some ζ. - { eapply ls_mapping_data=>//. apply elem_of_dom. naive_solver. } - - destruct ℓ as [ρ' tid' | |]. - - destruct (decide (ρ = ρ')) as [-> | Hneq]. - + inversion Htrans as [? Hbig]. destruct Hbig as (Hmap&Hleq&?&Hlim&?&?). - rewrite Hsome /= in Hlim. 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. naive_solver. - - Unshelve. - + intros ??. apply make_decision. - + intros. apply make_proof_irrel. - + intros. apply make_proof_irrel. - + intros. apply make_proof_irrel. - + done. - Qed. -End finitary_simple. - -(* TODO: Why do we need [LM] explicit here? *) -Definition live_rel `{Countable (locale Λ)} `(LM: LiveModel Λ M) - (ex : execution_trace Λ) (aux : auxiliary_trace LM) := - live_tids (LM:=LM) (trace_last ex) (trace_last aux). - -Definition sim_rel `{Countable (locale Λ)} `(LM: LiveModel Λ M) - (ex : execution_trace Λ) (aux : auxiliary_trace LM) := - valid_state_evolution_fairness ex aux ∧ live_rel LM ex aux. - -Definition sim_rel_with_user `{Countable (locale Λ)} `(LM: LiveModel Λ M) - (ξ : 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 - `{Countable (locale Λ)} `{LM:LiveModel Λ Mdl} - (ξ : 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_ξ - `{Countable (locale Λ)} `{LM:LiveModel Λ Mdl} ξ : - 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 - `{Countable (locale Λ)} `{LM:LiveModel Λ Mdl} - `{EqDecision (mstate LM)} `{EqDecision (mlabel LM)} - ξ : - 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/fairis/fuel.v b/fairis/fuel.v deleted file mode 100644 index 2c5d49f..0000000 --- a/fairis/fuel.v +++ /dev/null @@ -1,1261 +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 LiveStateData := MkLiveStateData { - ls_under:> M.(fmstate); - ls_map: gmap (locale Λ) (gmap M.(fmrole) nat); - }. - Record LiveState := MkLiveState { - ls_data :> LiveStateData; - - ls_map_disj: ∀ ζ ζ' fs fs', ζ ≠ ζ' → ls_data.(ls_map) !! ζ = Some fs → ls_data.(ls_map) !! ζ' = Some fs' → fs ##ₘ fs'; - ls_map_live: ∀ ρ, ρ ∈ M.(live_roles) ls_data.(ls_under) → ∃ ζ fs, ls_data.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs; - }. - - Implicit Type δ : LiveState. - - Definition ls_fuel (δ: LiveStateData) : gmap M.(fmrole) nat := - map_fold (λ _ m fs, m ∪ fs) ∅ δ.(ls_map). - Definition add_stuff ζ (m: gmap M.(fmrole) (locale Λ)) (rs: gset M.(fmrole)) := - gset_to_gmap ζ rs ∪ m. - Definition ls_mapping (δ: LiveStateData) : gmap M.(fmrole) (locale Λ) := - map_fold (λ ζ fs m, add_stuff ζ m (dom fs)) (∅: gmap M.(fmrole) (locale Λ)) δ.(ls_map). - - (* Lemma ls_fuel_dom δ ρ: ρ ∈ dom $ ls_mapping δ = dom $ ls_fuel δ. *) - Lemma dom_add_stuff ζ m rs : dom $ add_stuff ζ m rs = rs ∪ dom m. - Proof. - rewrite /add_stuff. - revert m. induction rs using set_ind_L; first set_solver; intros m. - rewrite gset_to_gmap_union_singleton !dom_union_L dom_insert_L. set_solver. - Qed. - - Lemma add_stuff_commute ζ1 ζ2 m s1 s2 : - s1 ## s2 → - add_stuff ζ2 (add_stuff ζ1 m s1) s2 = add_stuff ζ1 (add_stuff ζ2 m s2) s1. - Proof. - rewrite /add_stuff. intros Hdisj. rewrite !assoc. f_equal. - rewrite map_union_comm //. - apply map_disjoint_dom_2. rewrite !dom_gset_to_gmap //. - Qed. - (*TODO: why commute above and comm below? *) - - Lemma ls_same_doms δ: dom $ ls_mapping δ = dom $ ls_fuel δ. - Proof. - rewrite /ls_mapping /ls_fuel. - generalize (ls_map_disj δ). - induction δ.(ls_map) as [|ζ fs m Hnotin IH] using map_ind ; first set_solver. - intros Hdisj. - rewrite map_fold_insert_L //; last first. - { intros. apply add_stuff_commute. eapply map_disjoint_dom. rewrite comm in H0. eapply Hdisj; eauto. } - rewrite map_fold_insert_L //; last first. - { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } - rewrite dom_add_stuff !dom_union_L. - rewrite IH //. intros. eapply Hdisj; eauto; rewrite lookup_insert_ne //; naive_solver. - Qed. - - Lemma ls_fuel_data ρ δ ζ fs f: δ.(ls_map) !! ζ = Some fs → fs !! ρ = Some f → ls_fuel δ !! ρ = Some f. - Proof. - rewrite /ls_fuel. revert ρ ζ fs f. - generalize (ls_map_disj δ). - induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind ; first set_solver. - intros Hdisj ρ ζ fs f Hsome Hin. - rewrite map_fold_insert_L //; last first. - { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } - rewrite lookup_union_Some_raw. destruct (decide (ζ = ζ')) as [->|Hneq]. - - left. rewrite lookup_insert in Hsome. naive_solver. - - right. rewrite lookup_insert_ne // in Hsome. split. - + assert (fs ##ₘ fs'). - { eapply Hdisj; eauto; [rewrite lookup_insert_ne // | rewrite lookup_insert //]. } - by eapply map_disjoint_Some_l. - + eapply IH; eauto. intros. - eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. - Qed. - - Lemma ls_mapping_data ρ δ ζ fs: δ.(ls_map) !! ζ = Some fs → ρ ∈ dom fs → ls_mapping δ !! ρ = Some ζ. - Proof. - rewrite /ls_mapping. revert ρ ζ fs. - generalize (ls_map_disj δ). - induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind ; first set_solver. - intros Hdisj ρ ζ fs Hsome Hin. - rewrite map_fold_insert_L //; last first. - { intros. apply add_stuff_commute. eapply map_disjoint_dom. rewrite comm in H0. eapply Hdisj; eauto. } - rewrite /add_stuff. - rewrite lookup_union_Some_raw. destruct (decide (ζ = ζ')) as [->|Hneq]. - - left. rewrite lookup_insert in Hsome. rewrite lookup_gset_to_gmap_Some. naive_solver. - - right. rewrite lookup_insert_ne // in Hsome. split. - + assert (fs ##ₘ fs'). - { eapply Hdisj; eauto; [rewrite lookup_insert_ne // | rewrite lookup_insert //]. } - rewrite lookup_gset_to_gmap_None not_elem_of_dom. apply elem_of_dom in Hin as [??]. - by eapply map_disjoint_Some_l. - + eapply IH; eauto. intros. - eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. - Qed. - Lemma ls_mapping_data_inv ρ δ ζ: ls_mapping δ !! ρ = Some ζ → ∃ fs, δ.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs. - Proof. - rewrite /ls_mapping. revert ρ ζ. - generalize (ls_map_disj δ). - induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind ; first set_solver. - intros Hdisj ρ ζ Hsome. - rewrite map_fold_insert_L // in Hsome; last first. - { intros. apply add_stuff_commute. eapply map_disjoint_dom. rewrite comm in H0. eapply Hdisj; eauto. } - rewrite /add_stuff in Hsome. - rewrite lookup_union_Some_raw in Hsome. destruct Hsome as [Hsome|[Hnone Hsome]]. - - rewrite lookup_gset_to_gmap_Some in Hsome. destruct Hsome as [? ->]. - rewrite lookup_insert. naive_solver. - - assert (∃ fs : gmap (fmrole M) nat, m !! ζ = Some fs ∧ ρ ∈ dom fs) as (fs&?&?). - { eapply IH; eauto. intros. eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. } - exists fs; split; eauto. - rewrite lookup_insert_ne //. naive_solver. - Qed. - - Lemma ls_fuel_dom_data ρ δ ζ fs: δ.(ls_map) !! ζ = Some fs → ρ ∈ dom fs → ρ ∈ dom $ ls_fuel δ. - Proof. - rewrite /ls_fuel. revert ρ ζ fs. - generalize (ls_map_disj δ). - induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind ; first set_solver. - intros Hdisj ρ ζ fs Hsome Hin. - rewrite map_fold_insert_L //; last first. - { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } - rewrite dom_union. apply elem_of_union. destruct (decide (ζ = ζ')) as [->|Hneq]. - - left. rewrite lookup_insert in Hsome. naive_solver. - - right. rewrite lookup_insert_ne // in Hsome. eapply IH; eauto. intros. - eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. - Qed. - - Lemma ls_fuel_data_inv ρ δ f: ls_fuel δ !! ρ = Some f → ∃ ζ fs, δ.(ls_map) !! ζ = Some fs ∧ fs !! ρ = Some f. - Proof. - rewrite /ls_fuel. revert ρ f. - generalize (ls_map_disj δ). - induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind. - { intros ??. rewrite map_fold_empty. set_solver. } - intros Hdisj ρ f Hin. - rewrite map_fold_insert_L // in Hin; last first. - { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } - rewrite lookup_union_Some_raw in Hin. destruct Hin as [Hin|[? Hin]]. - - exists ζ', fs'. rewrite lookup_insert. naive_solver. - - assert (∃ ζ fs, m !! ζ = Some fs ∧ fs !! ρ = Some f) as [ζ [fs Hζ]]. - { apply IH; eauto. - intros ???????. eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. } - exists ζ, fs. rewrite lookup_insert_ne //. naive_solver. - Qed. - - Lemma ls_fuel_dom_data_inv ρ δ: ρ ∈ dom $ ls_fuel δ → ∃ ζ fs, δ.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs. - Proof. - rewrite /ls_fuel. revert ρ. - generalize (ls_map_disj δ). - induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind. - { intros ??. rewrite map_fold_empty. set_solver. } - intros Hdisj ρ Hin. - rewrite map_fold_insert_L // in Hin; last first. - { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } - rewrite dom_union in Hin. apply elem_of_union in Hin as [Hin|Hin]. - - exists ζ', fs'. rewrite lookup_insert. naive_solver. - - assert (∃ ζ fs, m !! ζ = Some fs ∧ ρ ∈ dom fs) as [ζ [fs Hζ]]. - { apply IH; eauto. - intros ???????. eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. } - exists ζ, fs. rewrite lookup_insert_ne //. naive_solver. - Qed. - - Lemma ls_fuel_suff δ ρ: ρ ∈ dom $ ls_fuel δ → ∃ ζ fs, δ.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs. - Proof. - rewrite /ls_fuel. revert ρ. - generalize (ls_map_disj δ). - induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind. - { intros ??. rewrite map_fold_empty. set_solver. } - intros Hdisj ρ Hin. - rewrite map_fold_insert_L // in Hin; last first. - { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } - rewrite dom_union in Hin. apply elem_of_union in Hin as [Hin|Hin]. - - exists ζ', fs'. rewrite lookup_insert. naive_solver. - - assert (∃ ζ fs, m !! ζ = Some fs ∧ ρ ∈ dom fs) as [ζ [fs Hζ]]. - { apply IH; eauto. - intros ???????. eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. } - exists ζ, fs. rewrite lookup_insert_ne //. naive_solver. - Qed. - - - Lemma ls_fuel_dom δ: M.(live_roles) δ.(ls_under) ⊆ dom $ ls_fuel δ. - Proof. - generalize (ls_map_live δ). - induction (live_roles M δ) as [|ρ ρs Hnotin IH] using set_ind_L ; first set_solver. - intros Hlive. apply union_subseteq; split; last first. - { apply IH. intros. apply Hlive. set_solver. } - apply singleton_subseteq_l. destruct (Hlive ρ ltac:(set_solver)) as (ζ&fs&Hlk&Hin). - by eapply ls_fuel_dom_data. - Qed. - - - Lemma ls_mapping_dom (m: LiveState): - M.(live_roles) m.(ls_under) ⊆ dom $ ls_mapping m. - 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: LiveStateData): - olocale Λ -> Prop := - | Same_tid tid (Hneqρ: Some ρ' ≠ oρ) (Hsametid: Some tid = ls_mapping a !! ρ'): - must_decrease ρ' oρ a b (Some tid) - | Change_tid otid (Hneqtid: ls_mapping a !! ρ' ≠ ls_mapping b !! ρ') - (Hissome: is_Some (ls_mapping b !! ρ')): - must_decrease ρ' oρ a b otid - (* | Zombie otid (Hismainrole: oρ = Some ρ') (Hnotalive: ρ' ∉ live_roles _ b) (Hnotdead: ρ' ∈ dom $ ls_fuel b): *) - (* must_decrease ρ' oρ a b otid *) - . - - Definition fuel_decr (tid: olocale Λ) (oρ: option M.(fmrole)) - (a b: LiveStateData) := - ∀ ρ', ρ' ∈ dom $ ls_fuel a -> ρ' ∈ dom $ ls_fuel b → - must_decrease ρ' oρ a b tid -> - oless (ls_fuel b !! ρ') (ls_fuel a !! ρ'). - - Definition fuel_must_not_incr oρ (a b: LiveStateData) := - ∀ ρ', ρ' ∈ dom $ ls_fuel a -> Some ρ' ≠ oρ -> - (oleq (ls_fuel b !! ρ') (ls_fuel a !! ρ') - ∨ (ρ' ∉ dom $ ls_fuel b ∧ ρ' ∉ M.(live_roles) a.(ls_under))). - - Lemma ls_map_agree {δ ρ ζ1 ζ2 fs1 fs2} : - δ.(ls_map) !! ζ1 = Some fs1 → - δ.(ls_map) !! ζ2 = Some fs2 → - ρ ∈ dom fs1 → - ρ ∈ dom fs2 → - ζ1 = ζ2 ∧ fs1 = fs2. - Proof. - intros Hlk1 Hlk2 [??]%elem_of_dom [??]%elem_of_dom. - destruct (decide (ζ1 = ζ2)) as [|Hneq]; first naive_solver. - have ?:= ls_map_disj _ _ _ _ _ Hneq Hlk1 Hlk2. exfalso. - by eapply map_disjoint_spec. - Qed. - - Definition ls_trans (fuel_limit : M → nat) (a: LiveStateData) ℓ (b: LiveStateData): Prop := - match ℓ with - | Take_step ρ tid => - M.(fmtrans) a (Some ρ) b - ∧ ls_mapping a !! ρ = Some tid - ∧ fuel_decr (Some tid) (Some ρ) a b - ∧ fuel_must_not_incr (Some ρ) a b - ∧ (oleq (ls_fuel b !! ρ) (Some (fuel_limit b))) - ∧ (∀ ρ, ρ ∈ (dom $ ls_fuel b) ∖ (dom $ ls_fuel a) -> oleq (ls_fuel b !! ρ) (Some (fuel_limit b))) - ∧ (dom $ ls_fuel b) ∖ (dom $ ls_fuel a) ⊆ live_roles _ b ∖ live_roles _ a - | Silent_step tid => - (∃ ρ, ls_mapping a !! ρ = Some tid) - ∧ fuel_decr (Some tid) None a b - ∧ fuel_must_not_incr None a b - ∧ dom $ ls_fuel b ⊆ dom $ ls_fuel a - ∧ 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 (ls_fuel b !! ρ) (Some (fuel_limit b))) - ∧ False (* TODO: add support for config steps later! *) - end. - - Lemma silent_step_suff_data fl (δ: LiveState) (fs fs' fs'': gmap _ nat) ζ (oζ' : option $ locale Λ) : - δ.(ls_map) !! ζ = Some fs → - fs ≠ ∅ → - (∀ ρ f', fs' !! ρ = Some f' → ∃ f, fs !! ρ = Some f ∧ f' < f) → - (∀ ρ f', fs'' !! ρ = Some f' → ∃ f, fs !! ρ = Some f ∧ f' < f) → - (dom fs ∖ (dom fs' ∪ dom fs'') ∩ M.(live_roles) δ = ∅) → - (dom fs' ∩ dom fs'' = ∅) → - (∀ ζ', oζ' = Some ζ' → ζ' ∉ dom δ.(ls_map)) → - (oζ' = None → fs'' = ∅) → - let data' := - match oζ' with - | None => δ.(ls_map) - | Some ζ' => <[ζ' := fs'']> δ.(ls_map) - end - in - let data'' := <[ζ := fs']> data' in - ∃ δ', δ'.(ls_data) = {| ls_under := δ; ls_map := data'' |} ∧ - ls_trans fl δ (Silent_step ζ) δ'. - Proof. - intros Hζ Hnemp Hfs' Hfs'' Hlives Hdisj Hnlocale Hifnone data' data''. - have Hincl' : dom fs' ⊆ dom fs. - { intros ?[? Hin]%elem_of_dom. by apply Hfs' in Hin as [?[?%elem_of_dom_2 ?]]. } - have Hincl'' : dom fs'' ⊆ dom fs. - { intros ?[? Hin]%elem_of_dom. by apply Hfs'' in Hin as [?[?%elem_of_dom_2 ?]]. } - assert (∃ δ', δ'.(ls_data) = {| ls_under := δ; ls_map := data'' |}) as [δ' Hd]. - { unshelve refine (ex_intro _ {| ls_data := {| ls_under := δ; ls_map := data'' |} |} _); last done. - { rewrite /data'' /=. intros z1 z2 fs1 fs2 Hneq Hlk1 Hlk2. apply map_disjoint_dom_2. - intros ρ Hin1 Hin2. destruct (decide (z1 = ζ)) as [->|Hneq1]. - - rewrite lookup_insert in Hlk1. simplify_eq. rewrite lookup_insert_ne // /data' in Hlk2. - destruct oζ' as [ζ'|]. - + destruct (decide (z2 = ζ')) as [->|Hneq2]. - * rewrite lookup_insert in Hlk2. simplify_eq. set_solver. - * rewrite lookup_insert_ne // in Hlk2. have ?: ρ ∈ dom fs by set_solver. - apply Hneq. eapply ls_map_agree; eauto. - + apply Hneq. eapply ls_map_agree; eauto. - - rewrite lookup_insert_ne // /data' in Hlk1. - destruct oζ' as [ζ'|]. - + destruct (decide (z1 = ζ')) as [->|Hneq2]. - * rewrite lookup_insert in Hlk1. simplify_eq. - destruct (decide (z2 = ζ)) as [->|Hneq3]. - ** rewrite lookup_insert in Hlk2. simplify_eq. set_solver. - ** rewrite !lookup_insert_ne // in Hlk2. specialize (Hnlocale _ ltac:(done)). - have ?: ρ ∈ dom fs by set_solver. - have ?: z2 = ζ by eapply ls_map_agree. simplify_eq. - * rewrite lookup_insert_ne // in Hlk1. - destruct (decide (z2 = ζ)) as [->|Hneq3]. - ** rewrite lookup_insert in Hlk2. simplify_eq. - have ?: ρ ∈ dom fs by set_solver. - apply Hneq. by eapply ls_map_agree. - ** rewrite lookup_insert_ne // /data' in Hlk2. - destruct (decide (z2 = ζ')) as [->|Hneq4]. - *** rewrite lookup_insert in Hlk2. simplify_eq. - apply Hneq1. eapply ls_map_agree; eauto. - *** rewrite lookup_insert_ne // in Hlk2. - have Hdone: fs1 ##ₘ fs2 by eapply (ls_map_disj δ z1 z2). - apply map_disjoint_dom in Hdone. - set_solver. - + destruct (decide (z2 = ζ)) as [->|Hneq3]. - ** rewrite lookup_insert in Hlk2. simplify_eq. - have ?: ρ ∈ dom fs by set_solver. - apply Hneq. by eapply ls_map_agree. - ** rewrite lookup_insert_ne // /data' in Hlk2. - have Hdone: fs1 ##ₘ fs2 by eapply (ls_map_disj δ z1 z2). - apply map_disjoint_dom in Hdone. - set_solver. } - { intros ρ Hlive. destruct (ls_map_live δ ρ Hlive) as (ζ0&fs0&?&?). - destruct (decide (ζ = ζ0)) as [->|]. - - have Hin: ρ ∈ dom fs' ∪ dom fs''. - { simpl in Hlive. simplify_eq. clear Hincl' Hincl''. - destruct (decide (ρ ∈ dom fs' ∪ dom fs'')); [done|set_solver]. } - apply elem_of_union in Hin as [Hin|Hin]. - + exists ζ0, fs'. rewrite lookup_insert //. - + destruct oζ' as [ζn|]; last naive_solver. - exists ζn, fs''. split=>//=. rewrite /data'' /data' lookup_insert_ne // ?lookup_insert //. - intros ->. eapply Hnlocale; eauto. by eapply elem_of_dom_2. - - exists ζ0, fs0. split; last done. rewrite /data'' /data' lookup_insert_ne // ?lookup_insert //. - destruct oζ' as [ζn|]; last naive_solver. rewrite lookup_insert_ne //. - intros ->. eapply Hnlocale; eauto. by eapply elem_of_dom_2. } } - exists δ'. split; first done. - constructor. - { destruct (map_choose _ Hnemp) as (ρ&?&?). exists ρ. eapply ls_mapping_data; eauto. - apply elem_of_dom. naive_solver. } - split; [|split; [| split; [|by rewrite Hd//]]]. - - rewrite /fuel_decr /=. intros ρ' Hin Hin' Hmd. - apply elem_of_dom in Hin as [f Hf]. - apply elem_of_dom in Hin' as [f' Hf']. - rewrite Hf Hf' /=. - inversion Hmd; simplify_eq. - + symmetry in Hsametid. - apply ls_mapping_data_inv in Hsametid as (fs0&Hmap0&Hin0). - simplify_eq. - apply ls_fuel_data_inv in Hf as (ζ'&fs0&?&?). - have [??] : ζ' = ζ ∧ fs0 = fs. - { eapply ls_map_agree; eauto. apply elem_of_dom; naive_solver. } - simplify_eq. - apply ls_fuel_data_inv in Hf' as (ζ2&fs2&Hmap'&Hfs2). - rewrite Hd /= /data'' in Hmap'. destruct (decide (ζ = ζ2)) as [->|Hneq]. - { rewrite lookup_insert in Hmap'. simplify_eq. - destruct (Hfs' _ _ Hfs2). naive_solver. } - rewrite lookup_insert_ne // /data' in Hmap'. destruct (oζ') as [ζn|]. - * destruct (decide (ζn = ζ2)) as [->|Hneqζ]. - ** rewrite lookup_insert in Hmap'. simplify_eq. - destruct (Hfs'' _ _ Hfs2). naive_solver. - ** rewrite lookup_insert_ne // in Hmap'. - have [??] : ζ2 = ζ ∧ fs2 = fs; last by simplify_eq. - eapply ls_map_agree; eauto. apply elem_of_dom; naive_solver. - * have [??] : ζ2 = ζ ∧ fs2 = fs; last by simplify_eq. - eapply ls_map_agree; eauto. apply elem_of_dom; naive_solver. - + destruct Hissome as [ζ0 Hlk0]. - rewrite Hlk0 in Hneqtid. - apply ls_fuel_data_inv in Hf as (ζ'&fs0&?&?). - apply ls_fuel_data_inv in Hf' as (ζ2&fs2&Hmap'&Hfs2). - apply ls_mapping_data_inv in Hlk0 as (fs3&Hmap3&Hdom3). - have [??] : ζ0 = ζ2 ∧ fs3 = fs2. - { eapply ls_map_agree; eauto. apply elem_of_dom; naive_solver. } - simplify_eq. - rewrite Hd /data'' /= in Hmap'. destruct (decide (ζ2 = ζ)); first simplify_eq. - * rewrite lookup_insert in Hmap'. symmetry in Hmap'. simplify_eq. - destruct (Hfs' _ _ Hfs2) as (?&?&?). exfalso; apply Hneqtid. - rewrite (ls_mapping_data ρ' δ ζ fs) in Hneqtid; [done|done|apply elem_of_dom; naive_solver]. - * rewrite lookup_insert_ne // /data' in Hmap'. destruct oζ' as [ζn|]. destruct (decide (ζ2 = ζn)). - ** simplify_eq. rewrite lookup_insert in Hmap'. simplify_eq. - destruct (Hfs'' _ _ Hfs2) as (ff&?&?). - have [??] : ζ' = ζ ∧ fs0 = fs; last by simplify_eq. - eapply ls_map_agree; eauto; apply elem_of_dom; naive_solver. - ** rewrite lookup_insert_ne // in Hmap'. exfalso; apply Hneqtid. - rewrite (ls_mapping_data ρ' δ ζ2 fs2) in Hneqtid; done. - ** have [??] : ζ' = ζ2 ∧ fs0 = fs2; last simplify_eq. - { eapply ls_map_agree; eauto; apply elem_of_dom; naive_solver. } - exfalso; apply Hneqtid. - eapply ls_mapping_data; eauto. - - rewrite /fuel_must_not_incr. intros ρ' Hin' _. - apply elem_of_dom in Hin' as [f Hf]. rewrite Hf. - apply ls_fuel_data_inv in Hf as (ζ'&fs0&Hmap&Hlk). - destruct (decide (ζ' = ζ)) as [->|]. - + have ? : fs0 = fs by naive_solver. simplify_eq. - destruct (decide (ρ' ∈ dom fs' ∪ dom fs'')) as [[Hin|Hin]%elem_of_union|Hnin]. - * left. apply elem_of_dom in Hin as [f' Hlk']. - destruct (Hfs' _ _ Hlk') as (?&?&?). - have -> /= : ls_fuel δ' !! ρ' = Some f'. - { eapply (ls_fuel_data _ _ ζ); eauto. rewrite Hd /data'' /= lookup_insert //. } - naive_solver lia. - * left. apply elem_of_dom in Hin as [f' Hlk']. - destruct (Hfs'' _ _ Hlk') as (?&?&?). - have -> /= : ls_fuel δ' !! ρ' = Some f'. - destruct oζ' as [ζn|]; last set_solver. - { eapply (ls_fuel_data _ _ ζn); eauto. - rewrite Hd /data'' /= lookup_insert_ne // /data' ?lookup_insert //. - intros ->. eapply Hnlocale; eauto. by eapply elem_of_dom_2. } - naive_solver lia. - * have Hdead: ρ' ∉ live_roles _ δ. - { eapply elem_of_dom_2 in Hlk. set_solver. } - right. split; last done. intros Habs. apply ls_fuel_dom_data_inv in Habs as (ζa&fsa&Hlka&Hina). - rewrite Hd /data'' /= in Hlka. - destruct (decide (ζa = ζ)). - { simplify_eq. rewrite lookup_insert in Hlka. simplify_eq. set_solver. } - rewrite lookup_insert_ne // /data' in Hlka. - destruct oζ' as [ζn|]. - ** destruct (decide (ζa = ζn)). - { simplify_eq. rewrite lookup_insert in Hlka. simplify_eq. set_solver. } - rewrite lookup_insert_ne // in Hlka. - have [??] : ζ = ζa ∧ fs = fsa; last done. - eapply ls_map_agree; eauto; apply elem_of_dom; naive_solver. - ** have [??] : ζ = ζa ∧ fs = fsa; last done. - eapply ls_map_agree; eauto; apply elem_of_dom; naive_solver. - + left. have ->: ls_fuel δ' !! ρ' = Some f; last naive_solver. - eapply (ls_fuel_data _ _ ζ'); eauto. - rewrite Hd /data'' /= lookup_insert_ne // /data'. destruct oζ' as [ζn|]; last done. - rewrite lookup_insert_ne //. intros ->. apply (Hnlocale ζ'); eauto. - by eapply elem_of_dom_2. - - intros ρ Hin. apply ls_fuel_dom_data_inv in Hin as (ζ0&fs0&Hlk0&Hin0). - rewrite Hd /data'' /= in Hlk0. destruct (decide (ζ0 = ζ)) as [->|]. - + rewrite lookup_insert in Hlk0. simplify_eq. eapply ls_fuel_dom_data; eauto. - + rewrite lookup_insert_ne // /data' in Hlk0. - destruct oζ' as [ζn|]. - * destruct (decide (ζ0 = ζn)) as [->|]. - ** rewrite lookup_insert in Hlk0. simplify_eq. eapply ls_fuel_dom_data; eauto. - ** rewrite lookup_insert_ne // /data' in Hlk0. eapply ls_fuel_dom_data; eauto. - * eapply ls_fuel_dom_data; eauto. - Qed. - - Lemma model_step_suff_data fl (δ: LiveState) ρ0 m' (fs fs': gmap _ nat) ζ : - fmtrans _ δ (Some ρ0) m' → - δ.(ls_map) !! ζ = Some fs → - ρ0 ∈ dom fs → - (∀ ρ f f', fs' !! ρ = Some f' → ρ ≠ ρ0 → fs !! ρ = Some f → f' < f) → - (∀ f'0, fs' !! ρ0 = Some f'0 → f'0 ≤ fl m') → - (∀ ρ, ρ ∈ dom fs' ∖ dom fs → ∀ f', fs' !! ρ = Some f' → f' ≤ fl m') → - (M.(live_roles) m' ∖ M.(live_roles) δ = dom fs' ∖ dom fs) → - (∀ ρ, ρ ∈ M.(live_roles) m' ∖ M.(live_roles) δ → ∀ ζ' fs', δ.(ls_map) !! ζ' = Some fs' → ρ ∉ dom fs') → - (dom fs ∖ dom fs' ∩ M.(live_roles) δ = ∅) → - let data' := <[ζ := fs']> δ.(ls_map) in - ∃ δ', δ'.(ls_data) = {| ls_under := m'; ls_map := data' |} ∧ - ls_trans fl δ (Take_step ρ0 ζ) δ'. - Proof. - intros Htrans Hζ Hρ0in Hfs' Hfl0 Hfln Hborn Hnew Hdead data'. - assert (∃ δ', δ'.(ls_data) = {| ls_under := m'; ls_map := data' |}) as [δ' Hd]. - { unshelve refine (ex_intro _ {| ls_data := {| ls_under := m'; ls_map := data' |} |} _); last done. - { rewrite /data' /=. intros z1 z2 fs1 fs2 Hneq Hlk1 Hlk2. apply map_disjoint_dom_2. - intros ρ Hin1 Hin2. - destruct (decide (z1 = ζ)) as [->|Hneq1]; destruct (decide (z2 = ζ)) as [->|Hneq2] =>//. - - rewrite lookup_insert in Hlk1. rewrite lookup_insert_ne // in Hlk2. simplify_eq. - destruct (decide (ρ ∈ dom fs)). - + have Hdone: fs ##ₘ fs2 by eapply (ls_map_disj δ ζ z2). - apply map_disjoint_dom in Hdone. set_solver. - + have Hdone: ρ ∉ dom fs2; last done. eapply Hnew. set_solver. done. - - rewrite lookup_insert in Hlk2. rewrite lookup_insert_ne // in Hlk1. simplify_eq. - destruct (decide (ρ ∈ dom fs)). - + have Hdone: fs ##ₘ fs1 by eapply (ls_map_disj δ ζ z1). - apply map_disjoint_dom in Hdone. set_solver. - + have Hdone: ρ ∉ dom fs1; last done. eapply Hnew. set_solver. done. - - rewrite lookup_insert_ne // in Hlk1. rewrite lookup_insert_ne // in Hlk2. - have Hdone: fs1 ##ₘ fs2 by eapply (ls_map_disj δ z1 z2). - apply map_disjoint_dom in Hdone. set_solver. } - { simpl. intros ρ Hlive. destruct (decide (ρ ∈ live_roles _ δ)) as [Hwaslive|Hnewborn]. - - destruct (ls_map_live δ ρ Hwaslive) as (ζ'&fs''&Hlk&Hdom). destruct (decide (ζ = ζ')). - + simplify_eq. exists ζ', fs'. rewrite lookup_insert. split; first done. set_solver. - + exists ζ', fs''. rewrite lookup_insert_ne //. - - exists ζ, fs'. rewrite lookup_insert. split; first done. set_solver. } } - have H0live: ρ0 ∈ live_roles _ δ by eapply fm_live_spec. - have Hζ' : ls_map δ' !! ζ = Some fs' by rewrite Hd lookup_insert //. - exists δ'. split; first done. constructor; first by rewrite Hd //. - - have Hdom: dom (ls_fuel δ') ∖ dom (ls_fuel δ) ⊆ live_roles M δ' ∖ live_roles M δ. - { intros ρ [Hin Hnin]%elem_of_difference. rewrite Hd Hborn. - apply elem_of_dom in Hin as [f' Hin]. - apply ls_fuel_data_inv in Hin as (ζ1&fs1&Hlk1&Hlk'1). - destruct (decide (ζ1 = ζ)); first simplify_eq; last first. - { rewrite Hd lookup_insert_ne // in Hlk1. exfalso. apply Hnin. - eapply ls_fuel_dom_data=>//. by apply elem_of_dom_2 in Hlk'1. } - apply elem_of_difference. split; first by apply elem_of_dom_2 in Hlk'1. - intros Hina. apply Hnin. eapply ls_fuel_dom_data=>//. } - - split; [| split; [| split; [| split; [| split; [| done]]]]]. - - eapply ls_mapping_data =>//. - - intros ρ Hin Hin' Hmd. - apply elem_of_dom in Hin as [f Hf]. - apply elem_of_dom in Hin' as [f' Hf']. - rewrite Hf Hf' /=. inversion Hmd; simplify_eq. - + symmetry in Hsametid. apply ls_mapping_data_inv in Hsametid as (fs1&Hlk1&Hin1). - rewrite Hζ in Hlk1. symmetry in Hlk1. simplify_eq. - apply ls_fuel_data_inv in Hf as (ζ1&fs1&Hlk1&Hlk'1). - have [??] : ζ1 = ζ ∧ fs1 = fs; last simplify_eq. - { eapply (ls_map_agree (ρ := ρ) Hlk1); eauto. by apply elem_of_dom_2 in Hlk'1. } - - apply ls_fuel_data_inv in Hf' as (ζ2&fs2&Hlk2&Hlk'2). - destruct (decide (ζ2 = ζ)); last first. - { rewrite Hd lookup_insert_ne // in Hlk2. - have [??] : ζ2 = ζ ∧ fs2 = fs; last simplify_eq. - eapply (ls_map_agree (ρ := ρ) Hlk2); eauto. by apply elem_of_dom_2 in Hlk'2. } - simplify_eq. eapply Hfs'=>//. naive_solver. - + exfalso. destruct Hissome as [ζ1 Hmap]. have Hmap' := Hmap. - apply ls_mapping_data_inv in Hmap as (fs1&Hlk&YHin). - destruct (decide (ζ1 = ζ)) as [->|]. - * simplify_eq. have ?: ρ ∈ dom fs. - { apply ls_fuel_data_inv in Hf as (ζ1&fs1&Hlk1&Hlk'1). - destruct (decide (ρ ∈ dom fs)); first done. exfalso. - eapply Hnew; eauto; last by apply elem_of_dom_2 in Hlk'1. - rewrite Hborn. set_solver. } - apply Hneqtid. rewrite Hmap'. by eapply ls_mapping_data. - * apply Hneqtid. rewrite Hmap'. - eapply ls_mapping_data=>//. - rewrite Hd lookup_insert_ne // in Hlk. - - intros ρ Hin Hneq. apply ls_fuel_dom_data_inv in Hin as (ζ1&fs1&Hlk1&Hdom1). - destruct (decide (ζ1 = ζ)). - + simplify_eq. destruct (decide (ρ ∈ dom fs')) as [Hin|]; [left| right; split; [|set_solver]]. - * apply elem_of_dom in Hin as [f' Hf']. - have ->: ls_fuel δ' !! ρ = Some f' by eapply ls_fuel_data. - apply elem_of_dom in Hdom1 as [f Hf]. - have -> /=: ls_fuel δ !! ρ = Some f by eapply ls_fuel_data. - naive_solver lia. - * intros Ha. apply ls_fuel_dom_data_inv in Ha as (ζ1&fs1&Hlk1&Hin1). - destruct (decide (ζ1 = ζ)) as [|Hneq1]; first naive_solver. - rewrite Hd lookup_insert_ne // in Hlk1. apply Hneq1. - by eapply ls_map_agree. - + left. apply elem_of_dom in Hdom1 as (f'&Hf'). - have ->: ls_fuel δ' !! ρ = Some f'. - { eapply (ls_fuel_data _ _ ζ1); eauto. rewrite Hd lookup_insert_ne //. } - have ->: ls_fuel δ !! ρ = Some f'. - { eapply (ls_fuel_data _ _ ζ1); eauto. } - naive_solver. - - intros. have H0dom: ρ0 ∈ dom fs' by set_solver. apply elem_of_dom in H0dom as [f' Hf']. - rewrite (ls_fuel_data _ _ _ _ _ Hζ' Hf') Hd /=. by eapply Hfl0. - - intros ρ [Hρin Hρnin]%elem_of_difference. - have Hn: ρ ∈ dom fs' ∖ dom fs. - { rewrite -Hborn. rewrite elem_of_subseteq {2}Hd /= in Hdom. apply Hdom. set_solver. } - apply elem_of_dom in Hρin as [f' Hρin]. rewrite Hρin. - apply ls_fuel_data_inv in Hρin as (ζ1&fs1&Hlk1&Hlk'1). simpl. rewrite Hd /=. - apply elem_of_difference in Hn as [Hn1 Hn2]. - have [??] : ζ1 = ζ ∧ fs1 = fs'. - { eapply ls_map_agree=>//. by apply elem_of_dom_2 in Hlk'1. } - simplify_eq. eapply Hfln; last done. by apply elem_of_difference. - Qed. - - Record LiveModel := { - lm_fl : M → nat; - lm_ls := LiveState; - lm_lbl := FairLabel M.(fmrole); - lm_ls_trans (δ: LiveState) (ℓ: FairLabel (fmrole M)) := 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) := - ∀ ζ, ζ ∈ dom $ ls_map δ -> is_Some (from_locale c ζ). - - Program Definition initial_ls `{LM: LiveModel} (s0: M) (ζ0: locale Λ) - : LM.(lm_ls) := - {| ls_data := {| ls_under := s0; - ls_map := {[ζ0 := gset_to_gmap (LM.(lm_fl) s0) (M.(live_roles) s0)]}; - |} |}. - Next Obligation. - intros ???????? Hlk1 Hlk2. simpl in *. exfalso. - apply lookup_singleton_Some in Hlk1. - apply lookup_singleton_Some in Hlk2. - naive_solver. - Qed. - Next Obligation. - intros ?? ζ ??. eexists ζ, _. rewrite lookup_singleton. split; eauto. - 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 _ _ {_ _}. -Arguments LiveStateData _ _ {_ _}. -Arguments LiveModel _ _ {_ _}. -Arguments fair_model_model _ {_ _ _} _. - -Definition live_model_to_model Λ M `{Countable (locale Λ)} : LiveModel Λ M -> Model := - λ lm, fair_model_model Λ lm. -Coercion live_model_to_model : LiveModel >-> Model. -Arguments live_model_to_model {_ _ _ _}. - -Definition auxtrace {Λ M} `{Countable (locale Λ)} (LM: LiveModel Λ M) := trace LM.(lm_ls) LM.(lm_lbl). - -Section aux_trace. - Context `{Countable (locale Λ)} `{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 (δ: LiveState Λ M) ℓ (tr: auxtrace LM): - 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 _ H1) (* 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 `{Countable (locale Λ)} `{LM:LiveModel Λ M} - (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 ζ → ρ ∉ M.(live_roles) δ. - -Definition exaux_traces_match `{Countable (locale Λ)} `{LM:LiveModel Λ M} : - extrace Λ → auxtrace LM → Prop := - traces_match labels_match - live_tids - locale_step - LM.(lm_ls_trans). - -Section fairness_preserved. - Context `{Countable (locale Λ)}. - Context `{LM: LiveModel Λ M}. - Implicit Type δ : LiveState Λ M. - - 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) ζ ρ: - ρ ∈ M.(live_roles) (trfirst auxtr) → - exaux_traces_match extr auxtr -> - ls_mapping (trfirst auxtr) !! ρ = Some ζ -> - locale_enabled ζ (trfirst extr). - Proof. - intros Hlive 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 ρ Hloc). - 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. - - done. - - 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(ls_mapping (trfirst tr) !! ρ) by eauto. - have [f Hfuel] : is_Some(ls_fuel (trfirst tr) !! ρ) 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 ρ Hζ). 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 (LM := LM) σ δ ∧ ψ σ δ) - 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 `{Countable (locale Λ)}. - Context `{LM: LiveModel Λ Mdl}. - Implicit Type δ : LiveState Λ Mdl. - - 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 (λ x, ls_under (ls_data x)) 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 $ ls_data (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 `{Countable (locale Λ)}. - Context `{LM: LiveModel Λ M}. - - (* Why is [LM] needed here? *) - Definition upto_stutter_auxtr := - upto_stutter (λ x, ls_under (Λ:=Λ) (M:=M) (ls_data x)) (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 `{Countable (locale Λ)}. - Context `{LM: LiveModel Λ M}. - - Lemma upto_stutter_mono' : - monotone2 (upto_stutter_ind (λ x, ls_under (Λ:=Λ) (M:=M) (ls_data x)) (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 `{Countable (locale Λ)}. - Context `{LM: LiveModel Λ M}. - - Notation upto_stutter_aux := (upto_stutter (λ x, ls_under (Λ := Λ) (ls_data x)) (Ul (Λ := Λ) (LM := LM))). - - Lemma upto_stutter_mono'' : (* TODO fix this proliferation *) - monotone2 (upto_stutter_ind (λ x, ls_under (Λ:=Λ) (M:=M) (ls_data x)) (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/fairis/fuel_termination.v b/fairis/fuel_termination.v deleted file mode 100644 index b6d9fcd..0000000 --- a/fairis/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 {Λ} `{Countable (locale Λ)} {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} `{Countable (locale Λ)} (LM:LiveModel Λ FM) - (ξ : 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/fairis/heap_lang/adequacy.v b/fairis/heap_lang/adequacy.v deleted file mode 100644 index 43ee2a7..0000000 --- a/fairis/heap_lang/adequacy.v +++ /dev/null @@ -1,479 +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 Import weakestpre adequacy. -From trillium.fairness Require Export fairness fair_termination fairness_finiteness fuel fuel_termination map_included_utils resources. -From trillium.program_logic Require Import ectx_lifting. -From trillium.fairness.heap_lang Require Import lang. -From trillium.fairness.heap_lang Require Import tactics notation. -From trillium.fairness.heap_lang Require Import lifting. -Set Default Proof Using "Type". - -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 ∅)%I) _); - first by auto. - apply elem_of_list_omap. - exists (e, (λ _: val, tid ↦M ∅)%I); 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. - -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. - -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, pointsto 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 [λ _, 0%nat ↦M ∅] (λ extr atr, ξ extr (map_underlying_trace atr)) ([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_fuel_mapping_init s1) as (γmap) "[Hmapa Hmapf]". - iMod (model_free_roles_init s1 (FR ∖ live_roles _ s1)) as (γfr) "[HFR Hfr]". - set (distG := - {| - heap_fairnessGS := {| - fairness_model_name := γmod; - fairness_model_fuel_mapping_name := γmap; - 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. } - iSpecialize ("Hwp" with "Hσ Hmodf Hfr [Hmapf]"). - { rewrite /init_fuel_map. - rewrite /has_fuels /frag_fuel_mapping_is. - rewrite fmap_insert fmap_empty. iFrame. } - iDestruct "Hwp" as ">[Hwp H]". - iModIntro. iFrame "Hwp". - iSplitL "Hgen Hmoda Hmapa HFR". - { unfold state_interp. simpl. iFrame. - iExists (ls_map (initial_ls s1 0%nat)). - iSplit; [done|]. - iSplit. - { iPureIntro. simpl. rewrite /fuel_map_preserve_dead. - intros ρ Hline. eexists 0%nat, _. rewrite lookup_insert. split; [done|]. - by rewrite dom_gset_to_gmap. } - iSplit. - { iPureIntro. intros tid Hlocs. rewrite lookup_singleton_ne //. - compute in Hlocs. set_solver. } - iFrame. } - 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 "_ !>". - iSplit; last done. iClear "H1". - iSplit; first done. - destruct (to_val e1) as [v1|] eqn:Heq. - + iSplit. - { iPureIntro. intros ρ tid Hinit. - apply ls_mapping_data_inv in Hinit. - destruct Hinit as [fs [HSome Hfs]]. - assert (tid = 0%nat). - { simpl in *. rewrite lookup_insert_Some in HSome. by set_solver. } - rewrite /from_locale //. simpl in *. set_solver. } - iIntros (tid e Hsome Hnoval ρ). destruct tid; last done. - simpl in Hsome. compute in Hsome. simplify_eq. - iAssert (0%nat ↦M ∅)%I with "[Hposts]" as "Hem". - { rewrite /= Heq /fmap /=. by iDestruct "Hposts" as "[??]". } - iDestruct "Hsi" as "(_&_&Hsi)". - iDestruct "Hsi" as (fm Hfmle Hfmdead Hmapinv) "(Hm & Hfm)". - iDestruct (has_fuels_agree with "Hfm Hem") as "%Hagree". - iPureIntro. - intros HSome. apply ls_mapping_data_inv in HSome. - destruct HSome as [fs [HSome Hfs]]. - destruct Hfmle as [Hfmle1 Hfmle2]. - rewrite /fuel_map_le_inner map_included_spec in Hfmle1. - pose proof Hagree as HSome'. - apply Hfmle1 in Hagree as (fs''&HSome''&Hfs''). simpl in *. clear Hfmle1. - simplify_eq. rewrite lookup_insert in HSome''. simplify_eq. - rewrite dom_gset_to_gmap in Hfs. - apply Hfmdead in Hfs as (tid''&fs'''&HSome'''&Hfs'''). - rewrite dom_singleton_L in Hfmle2. - assert (tid'' = 0%nat). - { apply elem_of_dom_2 in HSome'''. rewrite Hfmle2 in HSome'''. set_solver. } - simplify_eq. by set_solver. - + iSplit; iPureIntro. - { intros ρ tid Hinit. - apply ls_mapping_data_inv in Hinit. - destruct Hinit as [fs [HSome Hfs]]. - assert (tid = 0%nat). - { simpl in *. rewrite lookup_insert_Some in HSome. by set_solver. } - rewrite /from_locale //. simpl in *. set_solver. } - 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. - 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. - 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 (fm Hfmle Hfmdead Hmapinv) "(Hm & Hfm)". - iSplit; [|done]. - iSplit; [done|]. - iSplit. - + iPureIntro. intros ρ tid' Hsome. simpl. unfold tids_smaller in Htids. - eapply Htids. - apply ls_mapping_data_inv in Hsome. - destruct Hsome as [fs [HSome Hfs]]. - simpl in *. apply elem_of_dom. set_solver. - + iIntros (tid' e' Hsome Hnoval ρ HSome). simpl. - iAssert (tid' ↦M ∅)%I with "[Hposts]" as "H". - { destruct (to_val e') as [?|] eqn:Heq; last done. - iApply posts_of_empty_mapping => //. - apply from_locale_lookup =>//. } - iDestruct (has_fuels_agree with "Hfm H") as "%Hlk". - iPureIntro. - intros Hlive. - apply ls_mapping_data_inv in HSome. - destruct HSome as [fs [HSome Hfs]]. - destruct Hfmle as [Hfmle1 Hfmle2]. - rewrite /fuel_map_le_inner map_included_spec in Hfmle1. - pose proof Hlk as HSome'. - apply Hfmle1 in Hlk as (fs'&HSomefs&Hfs'). simpl in *. - simplify_eq. - apply Hfmdead in Hlive as (tid''&fs''&HSome''&Hfs''). - assert (tid'' = tid'). - { apply Hfmle1 in HSome'' as (fs'''&HSome'''&Hfs'''). - pose proof (δ.(ls_map_disj)) as Hdisj. - destruct (decide (tid' = tid'')) as [->|Hneq]; [done|]. - specialize (Hdisj tid' tid'' fs fs''' Hneq HSome HSome'''). - apply map_disjoint_dom in Hdisj. - apply map_included_subseteq_inv in Hfs'''. - set_solver. } - simplify_eq. - by set_solver. -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. - { do 2 (apply FunExt; intros?). apply PropExt. - 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 (λ x, ls_under (ls_data x)) 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. diff --git a/fairis/heap_lang/examples/choose_nat/choose_nat.v b/fairis/heap_lang/examples/choose_nat/choose_nat.v deleted file mode 100644 index 1909c58..0000000 --- a/fairis/heap_lang/examples/choose_nat/choose_nat.v +++ /dev/null @@ -1,297 +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. -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: #0 < "x" then #l <- ("x" - #1);; "go" #() else #(). -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. - -#[global] 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 -∗ - {{{ tid ↦M {[ () := f ]} ∗ frag_free_roles_are ∅ ∗ - own γ (◯E (Z.of_nat n)) }}} - decr_loop_prog l #() @ tid ; ⊤ - {{{ RET #(); tid ↦M ∅ }}}. - Proof. - iIntros (Hle1 Hle2) "#IH". - iIntros "!>" (Φ) "(Hf & Hr & Hm) HΦ". - iInduction n as [|n] "IHn" forall (f Hle1 Hle2). - { 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. - do 3 wp_pure _. - iInv Ns as ">HI" "Hclose". - iDestruct "HI" as (cn) "(Hs & Hl & Hcn)". - iApply (wp_pre_step ⊤). - wp_pures. - iModIntro. - iDestruct (own_valid_2 with "Hcn Hm") as %Hvalid%excl_auth_agree_L. - assert (cn = N 0) as ->. - { destruct cn; inversion Hvalid. by simplify_eq. } - iMod (has_fuels_dealloc _ _ _ (():fmrole cn_fair_model) with "Hs Hf") - as "[Hs Hf]"; [done|]. - iModIntro. - iMod ("Hclose" with "[Hs Hl Hcn]") as "_". - { iExists (N 0). iFrame. } - iModIntro. 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. - replace (Z.of_nat (S n) - 1)%Z with (Z.of_nat 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 n)) as ->. - { destruct cn; inversion Hvalid. by simplify_eq. } - (* Update the model state to maintain program correspondence *) - iApply (wp_step_model_singlerole _ _ (():fmrole cn_fair_model) (f - 7) - with "Hs [Hf] Hr"). - { constructor. } - { simpl. destruct n; set_solver. } - { by replace (f - 1 - 1 - 1 - 1 - 1 - 1 - 1)%nat with (f - 7)%nat by lia. } - iApply (wp_store with "Hl"). - iIntros "!> Hl Hs Hf Hr". - wp_pures. - iMod (own_update_2 _ _ _ with "Hcn Hm") as "[Hcn Hm]". - { apply (excl_auth_update _ _ (Z.of_nat n)%Z). } - iMod ("Hclose" with "[Hs Hl Hcn]") as "_". - { iExists (N n). iFrame. } - iApply fupd_mask_intro; [done|]. - iIntros "H". iMod "H". - iModIntro. simpl. wp_pures. - iApply ("IHn" with "[] [] Hf Hr Hm"); [iPureIntro; lia..|done]. - Qed. - - Lemma choose_nat_spec γ l tid (f:nat) : - 12 ≤ f → f ≤ 40 → - choose_nat_inv γ l -∗ - {{{ tid ↦M {[ () := 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_step_fuel with "[Hf]"). - 2: { rewrite has_fuels_gt_1; last by solve_fuel_positive. - rewrite fmap_insert fmap_empty. done. } - { set_solver. } - iApply wp_choose_nat. - iIntros "!>" (n) "Hf". - wp_pures. - iModIntro. - 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_step_model_singlerole _ _ (():fmrole cn_fair_model) (f - 3) - _ _ (N (S n)) - with "Hs [Hf] Hr"). - { constructor. } - { set_solver. } - { by replace (f - 1 - 1 - 1)%nat with (f - 3)%nat by lia. } - iApply (wp_store with "Hl"). - iIntros "!> Hl Hs Hf Hr". - wp_pures. - 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. } - iApply fupd_mask_intro; [done|]. - iIntros "H". iMod "H". - iModIntro. simpl. wp_pures. - by iApply (decr_loop_spec with "IH [$Hm $Hr $Hf]"); [lia|lia|]. - Qed. - -End proof. diff --git a/fairis/heap_lang/examples/choose_nat/choose_nat_adequacy.v b/fairis/heap_lang/examples/choose_nat/choose_nat_adequacy.v deleted file mode 100644 index 19caf13..0000000 --- a/fairis/heap_lang/examples/choose_nat/choose_nat_adequacy.v +++ /dev/null @@ -1,90 +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 notation adequacy. -From trillium.fairness.heap_lang.examples Require Import choose_nat. - -Import derived_laws_later.bi. - -Set Default Proof Using "Type". - -(** 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 gset_to_gmap_set_to_map. iFrame. } - iIntros (ex atr c Hvalid Hex Hatr Hends Hξ Hstuck Hequiv) "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/fairis/heap_lang/examples/even_odd/even_odd.v b/fairis/heap_lang/examples/even_odd/even_odd.v deleted file mode 100644 index 75c0ee5..0000000 --- a/fairis/heap_lang/examples/even_odd/even_odd.v +++ /dev/null @@ -1,348 +0,0 @@ -From stdpp Require Import 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.program_logic Require Export weakestpre. -From trillium.fairness Require Import fairness fair_termination. -From trillium.fairness.heap_lang Require Export lang lifting tactics proofmode. -From trillium.fairness.heap_lang Require Import notation. - -Import derived_laws_later.bi. - -Open Scope nat. - -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 -| odd_trans n : Nat.odd n → eotrans n (Some ρOdd) (S n) -| odd_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 : iProp Σ := - ∃ 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. - 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 ∗ tid ↦M {[ ρ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". - iModIntro. - iApply (wp_step_model_singlerole with "Hmod Hf HFR"). - { constructor. by eauto. } - { set_solver. } - iApply (wp_cmpxchg_suc with "Hn"); [by do 3 f_equiv|done|]. - iIntros "!> Hb Hmod Hf HFR". - iMod (even_update (M + 2) with "[$]") as "[Hay Heven]". - wp_pures. - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _. iFrame. subst. iEval (rewrite -Nat.add_1_r). - rewrite Nat2Z.inj_add !Nat.add_1_r Nat.even_succ -Nat.negb_even Heqn. - iFrame. replace (S (S N)) with (N + 2) by lia. iFrame. } - iApply fupd_mask_intro; [done|]. iIntros "H". iMod "H". - iModIntro. simpl. 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 "∗#". subst. iFrame. } - iPureIntro; lia. - - iDestruct (even_agree with "Heven Hay") as "%Heq". rewrite -> Heq in *. - iModIntro. - iApply (wp_step_model_singlerole with "Hmod Hf HFR"). - { apply even_fail. rewrite -Nat.negb_even. rewrite Heqn. done. } - { set_solver. } - iApply (wp_cmpxchg_fail with "Hn"); [intros Hne; simplify_eq; lia|done|]. - iIntros "!> Hb Hmod Hf HFR". - wp_pures. - iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). - { iNext. simplify_eq. iExists _. iFrame. - subst. iFrame. - rewrite Nat.add_1_r. rewrite Heqn. iFrame. } - iApply fupd_mask_intro; [done|]. iIntros "H". iMod "H". - iModIntro. simpl. wp_pures. - 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 ∗ tid ↦M {[ ρ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". - iModIntro. - iApply (wp_step_model_singlerole with "Hmod Hf HFR"). - { apply odd_trans. rewrite -Nat.negb_even. rewrite Heqn. done. } - { set_solver. } - iApply (wp_cmpxchg_suc with "Hn"); [by do 3 f_equiv|done|]. - iIntros "!> Hb Hmod Hf HFR". - iMod (odd_update (M + 2) with "[$]") as "[Han Hodd]". - wp_pures. - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _. iFrame. subst. - rewrite Nat.add_1_r Nat.even_succ -Nat.negb_even Heqn 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. } - iApply fupd_mask_intro; [done|]. iIntros "H". iMod "H". iModIntro. - simpl. wp_pures. - 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 *. - simplify_eq. iModIntro. - iApply (wp_step_model_singlerole with "Hmod Hf HFR"). - { apply odd_fail. by eauto. } - { set_solver. } - iApply (wp_cmpxchg_fail with "Hn"); - [by intros Hneq; simplify_eq; lia|done|]. - iIntros "!> Hb Hmod Hf HFR". - wp_pures. - iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). - { iNext. simplify_eq. iExists _. iFrame. - rewrite Heqn. iFrame. } - iApply fupd_mask_intro; [done|]. iIntros "H". iMod "H". iModIntro. - simpl. wp_pures. - 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 ∗ tid ↦M {[ 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 ∗ tid ↦M {[ ρ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 _). - iApply (wp_role_fork _ tid _ _ _ {[ρOdd := _]} {[ρEven := _]} - with "[Hf] [Heven_at]"). - { apply map_disjoint_dom. rewrite !dom_singleton. set_solver. } - { intros Hempty%map_positive_l. set_solver. } - { rewrite has_fuels_gt_1; last solve_fuel_positive. - rewrite !fmap_insert fmap_empty //. - rewrite insert_union_singleton_l. - rewrite map_union_comm; [done|]. - apply map_disjoint_dom. set_solver. } - { iIntros (tid') "!> Hf". - iApply (incr_loop_spec with "[Heven_at $Hf]"); [lia|iFrame "#∗"|]. - by iIntros "!>?". } - iIntros "!> Hf". - iIntros "!>". - wp_pures. - iApply (wp_role_fork _ tid _ _ _ ∅ {[ρOdd := _]} with "[Hf] [Hodd_at]"). - { apply map_disjoint_dom. rewrite !dom_singleton. set_solver. } - { rewrite map_union_comm. - - intros Hempty%map_positive_l. set_solver. - - apply map_disjoint_dom. rewrite dom_singleton. set_solver. } - { rewrite has_fuels_gt_1; last solve_fuel_positive. - rewrite !fmap_insert fmap_empty //. - rewrite insert_union_singleton_l. - rewrite map_union_comm; [done|]. - apply map_disjoint_dom. set_solver. } - { iIntros (tid') "!> Hf". - wp_pures. - 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". by iApply "HΦ". - - 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 _). - iApply (wp_role_fork _ tid _ _ _ {[ρEven := _]} {[ρOdd := _]} - with "[Hf] [Hodd_at]"). - { apply map_disjoint_dom. rewrite !dom_singleton. set_solver. } - { intros Hempty%map_positive_l. set_solver. } - { rewrite has_fuels_gt_1; last solve_fuel_positive. - rewrite !fmap_insert fmap_empty //. - rewrite insert_union_singleton_l. done. } - { iIntros (tid') "!> Hf". - iApply (incr_loop_spec with "[Hodd_at $Hf]"); [lia|iFrame "#∗"|]. - by iIntros "!>?". } - iIntros "!> Hf !>". - wp_pures. - iApply (wp_role_fork _ tid _ _ _ ∅ {[ρEven := _]} with "[Hf] [Heven_at]"). - { apply map_disjoint_dom. rewrite !dom_singleton. set_solver. } - { rewrite map_union_comm. - - intros Hempty%map_positive_l. set_solver. - - apply map_disjoint_dom. rewrite dom_singleton. set_solver. } - { rewrite has_fuels_gt_1; last solve_fuel_positive. - rewrite !fmap_insert fmap_empty //. - rewrite insert_union_singleton_l. - rewrite map_union_comm; [done|]. - apply map_disjoint_dom. set_solver. } - { iIntros (tid') "!> Hf". - wp_pures. - 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". by iApply "HΦ". - Qed. - -End proof_start. diff --git a/fairis/heap_lang/examples/even_odd/even_odd_adequacy.v b/fairis/heap_lang/examples/even_odd/even_odd_adequacy.v deleted file mode 100644 index 987490b..0000000 --- a/fairis/heap_lang/examples/even_odd/even_odd_adequacy.v +++ /dev/null @@ -1,648 +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.prelude Require Export finitary quantifiers sigma classical_instances. -From trillium.program_logic Require Export weakestpre. -From trillium.fairness Require Import fairness fair_termination fairness_finiteness trace_utils. -From trillium.fairness.heap_lang Require Export lang lifting tactics notation adequacy. -From trillium.fairness.heap_lang.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 ∘ ls_data) 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 ∘ ls_data) 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 $ ls_data s) (l ≫= Ul)). - -Lemma evenodd_mtr_aux_mono_preserved (mtr : mtrace the_fair_model) - (auxtr : auxtrace the_model) : - upto_stutter (ls_under ∘ ls_data) 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). - -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 %Hequiv [_ [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 (fm Hfmle Hfmdead Htp) "[Hδ Hfm]". - 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 → fm !! 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 (has_fuels_agree with "Hfm Hpost") as "?". } - assert (dom fm = list_to_set $ locales_of_list c.1). - { rewrite Hends in Htp. 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 Htp 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 (live_roles _ M = ∅) as Hlive. - { apply set_eq. intros i. split; [|done]. - intros (ζ&fs&HSome&Hfs)%Hfmdead. - assert (fm !! ζ = Some ∅). - { apply HMζ. - assert (ζ ∈ dom (ls_map (trace_last auxtr))) as Hin. - { destruct Hfmle as [Hfmle1 Hfmle2]. - rewrite /fuel_map_le_inner map_included_spec in Hfmle1. - apply Hfmle1 in HSome as (?&?&?). - by apply elem_of_dom. } - apply Hsmaller in Hin as [? Hin]. - rewrite Hends in Hin. - apply lookup_lt_is_Some_1. - by apply from_locale_lookup in Hin. } - by simplify_eq. } - 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/fairis/heap_lang/examples/yesno/yesno.v b/fairis/heap_lang/examples/yesno/yesno.v deleted file mode 100644 index c06698d..0000000 --- a/fairis/heap_lang/examples/yesno/yesno.v +++ /dev/null @@ -1,466 +0,0 @@ -From stdpp Require Import 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.program_logic Require Export weakestpre. -From trillium.fairness Require Import fairness fair_termination. -From trillium.fairness.heap_lang Require Export lang lifting tactics proofmode notation. - -Import derived_laws_later.bi. - -Open Scope nat. - -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 : iProp Σ := - ∃ N B, - ⌜(N, B) ≠ (0, false)⌝ ∗ - 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. - 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 ∗ tid ↦M {[ 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) "(>%Hnever & >HFR & >Hmod & >Bb & Hauths)" "Hclose". - destruct B; iDestruct "Hauths" as "[>Hay >Han]". - - iDestruct (yes_agree with "Hyes Hay") as "%Heq". - destruct (decide (M = 0)) as [->|Nneq]; first lia. - destruct (decide (M = 1)) as [->|Nneq1]. - + iModIntro. - iApply (wp_step_model_singlerole with "Hmod Hf HFR"). - { econstructor. lia. } - { set_solver. } - iApply (wp_cmpxchg_suc with "Bb"); [done|done|]. - iIntros "!> Hb Hmod Hf HFR". - iMod (yes_update 0 with "[$]") as "[Hay Hyes]". - wp_pures. - iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). - { iNext. iExists _, _. iFrame. simpl. iFrame. by iPureIntro. } - iApply fupd_mask_intro; [done|]. iMod 1. iModIntro. - simpl in *. wp_load. wp_store. wp_load. wp_pure _. simplify_eq. simpl. - iApply wp_atomic. - iInv Ns as (M B) "(>%Hbever' & >HFR & >Hmod & >Hb & Hauths)" "Hclose". - destruct B. - * iModIntro. - iApply (wp_step_fuel with "[Hf]"). - 2: { iClear "Hg". rewrite has_fuels_gt_1; last by solve_fuel_positive. - rewrite fmap_insert fmap_empty. done. } - { set_solver. } - iApply sswp_pure_step; [done|]. - iIntros "!> Hf". iApply wp_pre_step. wp_pures. - iApply fupd_mask_intro; [done|]. - iIntros "Hclose'". - iDestruct "Hauths" as "[Hay Han]". - iDestruct (yes_agree with "Hyes Hay") as %Heq. - assert (M = 0) by lia. simplify_eq. - iMod (has_fuels_dealloc _ _ _ (Y:fmrole the_fair_model) - with "Hmod Hf") as "[Hmod Hf]"; [done|]. - iModIntro. iMod "Hclose'". - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _, _. iFrame. done. } - iModIntro. iApply "Hk". - rewrite delete_insert; [|set_solver]. - iFrame "Hf". - * iDestruct "Hauths" as "[>Hay >Han]". iDestruct (yes_agree with "Hyes Hay") as %Heq. - assert (M = 1) by (destruct M; [done|lia]). simplify_eq. - iModIntro. - iApply (wp_step_fuel with "[Hf]"). - 2: { iClear "Hg". rewrite has_fuels_gt_1; last by solve_fuel_positive. - rewrite fmap_insert fmap_empty. done. } - { set_solver. } - iApply sswp_pure_step; [done|]. - iIntros "!> Hf". iApply wp_pre_step. wp_pures. - iApply fupd_mask_intro; [done|]. - iIntros "Hclose'". - iMod (has_fuels_dealloc _ _ _ (Y:fmrole the_fair_model) - with "Hmod Hf") as "[Hmod Hf]"; [set_solver|]. - iModIntro. iMod "Hclose'". - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _, _. iFrame. done. } - iModIntro. iApply "Hk". - rewrite delete_insert; [|set_solver]. - iFrame. - + assert (N = N) by lia. simplify_eq. - iModIntro. - iApply (wp_step_model_singlerole with "Hmod Hf HFR"). - { constructor. lia. } - { simpl. destruct M; [set_solver | destruct M; set_solver]. } - iApply (wp_cmpxchg_suc with "Bb"); [done|done|]. - iIntros "!> Hb Hmod Hf HFR". - iMod (yes_update (M-1) with "[$]") as "[Hay Hyes]". - wp_pures. iModIntro. - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _, _. iFrame. iPureIntro. intro contra. simplify_eq. } - iModIntro. - simpl. wp_load. wp_store. wp_load. wp_pures. - destruct (decide (0 < S M - 1)) as [Heq|Heq]. - * rewrite bool_decide_eq_true_2 //; last lia. - wp_pure _. - 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. - iModIntro. - iApply (wp_step_model_singlerole with "Hmod Hf HFR"). - { constructor. lia. } - { set_solver. } - iApply (wp_cmpxchg_fail with "Bb"); [done|done|]. - iIntros "!> Hb Hmod Hf HFR". - wp_pures. iModIntro. - iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). - { iNext. simplify_eq. iExists _, _. iFrame. iFrame. done. } - iModIntro. - simpl. wp_load. wp_pure _. rewrite bool_decide_eq_true_2; last lia. - wp_pure _. - 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 ∗ tid ↦M {[ 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 _). - iApply (wp_step_fuel with "[Hf]"). - { apply map_non_empty_singleton. } - { rewrite has_fuels_gt_1; last by solve_fuel_positive. - rewrite fmap_insert fmap_empty. done. } - iApply wp_alloc. iNext. iIntros (n) "HnN _ Hf". wp_pures. iModIntro. wp_pures. - 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 ∗ tid ↦M {[ 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) "(>%Hnever & >HFR & >Hmod & >Bb & Hauths)" "Hclose". - destruct B; iDestruct "Hauths" as "[>Hay >Han]"; last first. - - iDestruct (no_agree with "Hno Han") as "%Heq". - destruct (decide (M = 0)) as [->|Nneq]; first lia. - destruct (decide (M = 1)) as [->|Nneq1]. - + iModIntro. - iApply (wp_step_model_singlerole with "Hmod Hf HFR"). - { econstructor. } - { set_solver. } - iApply (wp_cmpxchg_suc with "Bb"); [done|done|]. - iIntros "!> Hb Hmod Hf HFR". - iMod (no_update 0 with "[$]") as "[Han Hno]". - wp_pures. iModIntro. - iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). - { iNext. iExists _, _. iFrame. simpl. iFrame. by iPureIntro. } - iModIntro. - simpl. wp_load. wp_store. wp_load. wp_pure _. simplify_eq. simpl. - iApply wp_atomic. - iInv Ns as (M B) "(>%Hbever' & >HFR & >Hmod & >Hb & Hauths)" "Hclose". - destruct B. - * iModIntro. - iApply (wp_step_fuel with "[Hf]"). - 2: { iClear "Hg". rewrite has_fuels_gt_1; last by solve_fuel_positive. - rewrite fmap_insert fmap_empty. done. } - { set_solver. } - iApply sswp_pure_step; [done|]. - iIntros "!> Hf". - iDestruct "Hauths" as "[Hay Han]". iDestruct (no_agree with "Hno Han") as %Heq. - assert (M = 0) by lia. simplify_eq. - iMod (has_fuels_dealloc _ _ _ - (No:fmrole the_fair_model) with "Hmod Hf") - as "[Hmod Hf]"; [set_solver|]. - wp_pures. iModIntro. - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _, _. iFrame. done. } - iModIntro. iApply "Hk". - rewrite delete_insert; [|done]. - 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. - iModIntro. - iApply (wp_step_model_singlerole with "Hmod Hf HFR"). - { econstructor. } - { simpl. destruct M; [set_solver | destruct M; set_solver]. } - iApply (wp_cmpxchg_suc with "Bb"); [done|done|]. - iIntros "!> Hb Hmod Hf HFR". - iMod (no_update (M) with "[$]") as "[Han Hno]". - wp_pures. iModIntro. - iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). - { iNext. iExists _, _. iFrame. iSplit; [done|]. - iApply (own_proper with "Hay"). f_equiv. apply leibniz_equiv_iff. lia. } - iModIntro. simpl. wp_load. wp_store. wp_load. wp_pures. - destruct (decide (0 < S M - 1)) as [Heq|Heq]. - * rewrite bool_decide_eq_true_2 //; last lia. - wp_pure _. - 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. - assert (M = N) by lia. simplify_eq. iModIntro. - iApply (wp_step_model_singlerole with "Hmod Hf HFR"). - { econstructor. lia. } - { set_solver. } - iApply (wp_cmpxchg_fail with "Bb"); [done|done|]. - iIntros "!> Hb Hmod Hf HFR". - wp_pures. - iModIntro. - iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). - { iNext. simplify_eq. iExists _, _. iFrame. iFrame. done. } - iModIntro. simpl. wp_load. wp_pure _. - rewrite bool_decide_eq_true_2; last lia. wp_pure _. - 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 ∗ tid ↦M {[ 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 _). - iApply (wp_step_fuel with "[Hf]"). - { apply map_non_empty_singleton. } - { rewrite has_fuels_gt_1; last by solve_fuel_positive. - rewrite fmap_insert fmap_empty. done. } - iApply wp_alloc. iNext. iIntros (n) "HnN _ Hf". wp_pures. iModIntro. wp_pures. - 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 ∅ ∗ - tid ↦M {[ 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_step_fuel with "[Hf]"). - 2: { rewrite has_fuels_gt_1; last by solve_fuel_positive. - rewrite !fmap_insert fmap_empty. done. } - { rewrite insert_union_singleton_l. - intros ?%map_positive_l. set_solver. } - iApply wp_alloc. iNext. iIntros (l) "HnN _ Hf". wp_pures. iModIntro. 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 _). - iApply (wp_role_fork _ tid _ _ _ {[No := _]} {[Y := _]} - with "[Hf] [Hyes_at]"). - { apply map_disjoint_dom. rewrite !dom_singleton. set_solver. } - { intros Hempty%map_positive_l. set_solver. } - { rewrite has_fuels_gt_1; last solve_fuel_positive. - rewrite !fmap_insert fmap_empty //. - rewrite insert_union_singleton_l. - rewrite map_union_comm; [done|]. - apply map_disjoint_dom. set_solver. } - { iIntros (tid') "!> Hf". iApply (yes_spec with "[-]"); last first. - + by eauto. - + iFrame "#∗". iPureIntro. lia. - + lia. } - iIntros "!> Hf !>". wp_pures. - iApply (wp_role_fork _ tid _ _ _ ∅ {[No := _]} with "[Hf] [Hno_at] [Hkont]"). - { apply map_disjoint_dom. rewrite !dom_singleton. set_solver. } - { rewrite map_union_comm. - - intros Hempty%map_positive_l. set_solver. - - apply map_disjoint_dom. rewrite dom_singleton. set_solver. } - { rewrite has_fuels_gt_1; last solve_fuel_positive. - rewrite !fmap_insert fmap_empty //. - rewrite insert_union_singleton_l. - rewrite map_union_comm; [done|]. - apply map_disjoint_dom. set_solver. } - { iIntros (tid') "!> Hf". iApply (no_spec with "[-]"); last first. - + by eauto. - + by iFrame "#∗". - + lia. } - iNext. iIntros "Hf". by iApply "Hkont". - Qed. - -End proof_start. diff --git a/fairis/heap_lang/examples/yesno/yesno_adequacy.v b/fairis/heap_lang/examples/yesno/yesno_adequacy.v deleted file mode 100644 index 8533225..0000000 --- a/fairis/heap_lang/examples/yesno/yesno_adequacy.v +++ /dev/null @@ -1,250 +0,0 @@ -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 notation adequacy. -From trillium.fairness.heap_lang.examples.yesno Require Import yesno. - -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: well_founded (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: well_founded (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/fairis/heap_lang/lang.v b/fairis/heap_lang/lang.v deleted file mode 100644 index 68737d1..0000000 --- a/fairis/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.program_logic 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/fairis/heap_lang/lifting.v b/fairis/heap_lang/lifting.v deleted file mode 100644 index a1b3093..0000000 --- a/fairis/heap_lang/lifting.v +++ /dev/null @@ -1,594 +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 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 Σ := { - iris_invGS := heap_invGS; - 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 ∅)%I; -}. - -(** Override the notations so that scopes and coercions work out *) -Notation "l ↦{ q } v" := (pointsto (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" := - (pointsto (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 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 allocN_atomic s v w : Atomic s (AllocN (Val v) (Val w)). -Proof. solve_atomic. Qed. -#[global] Instance alloc_atomic s v : Atomic s (Alloc (Val v)). -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. - -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. - -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 sswp_wand s e E (Φ Ψ : expr → iProp Σ) : - (∀ e, Φ e -∗ Ψ e) -∗ sswp s E e Φ -∗ sswp s E e Ψ. -Proof. - rewrite /sswp. iIntros "HΦΨ HΦ". - 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. - -Lemma has_fuels_decr E tid fs : - tid ↦M++ fs -∗ |~{E}~| tid ↦M fs. -Proof. - iIntros "Hf". rewrite weakestpre.pre_step_unseal. - iIntros (extr atr) "[%Hvse [Hσ Hm]]". - iMod (model_state_interp_has_fuels_decr with "Hm Hf") as "[$ $]". by iFrame. -Qed. - -Lemma has_fuels_dealloc E tid fs ρ δ : - ρ ∉ live_roles _ δ → frag_model_is δ -∗ tid ↦M fs -∗ - |~{E}~| frag_model_is δ ∗ tid ↦M (delete ρ fs). -Proof. - iIntros (Hnin) "Hst Hf". rewrite weakestpre.pre_step_unseal. - iIntros (extr atr) "[%Hvse [Hσ Hm]]". - iMod (model_state_interp_has_fuels_dealloc with "Hm Hst Hf") as "[Hm Hf]"; - [done|by iFrame]. -Qed. - -(* Rule from the Trillium article *) -Lemma wp_role_dealloc s tid E e fs ρ δ Φ : - ρ ∉ live_roles _ δ → frag_model_is δ -∗ tid ↦M fs -∗ - (frag_model_is δ -∗ tid ↦M (delete ρ fs) -∗ WP e @ s; tid; E {{ Φ }}) -∗ - WP e @ s; tid; E {{ Φ }}. -Proof. - iIntros (Hnin) "HM Hfuels Hwp". - iMod (has_fuels_dealloc with "HM Hfuels") as "[HM Hfuels]"; [done|]. - by iApply ("Hwp" with "HM Hfuels"). -Qed. - -Lemma wp_step_model s tid ρ (f1 : nat) fs fr s1 s2 E e Φ : - TCEq (to_val e) None → - fmtrans M s1 (Some ρ) s2 → - M.(live_roles) s2 ⊆ M.(live_roles) s1 → - ρ ∉ dom fs → - ▷ frag_model_is s1 -∗ - ▷ tid ↦M ({[ρ:=f1]} ∪ fmap S fs) -∗ - ▷ frag_free_roles_are fr -∗ - sswp s E e (λ e', frag_model_is s2 -∗ - tid ↦M ({[ρ:=(LM.(lm_fl) s2)]} ∪ fs) -∗ - frag_free_roles_are fr -∗ - WP e' @ s; tid; E {{ Φ }} ) -∗ - WP e @ s; tid; E {{ Φ }}. -Proof. - iIntros (Hval Htrans Hlive Hdom) ">Hst >Hfuel1 >Hfr Hwp". - rewrite wp_unfold /wp_pre. - rewrite /sswp. simpl. rewrite Hval. - iIntros (extr atr K tp1 tp2 σ1 Hvalid Hloc Hexend) "(% & Hsi & Hmi)". - iMod ("Hwp" with "Hsi") as (Hred) "Hwp". iIntros "!>". - iSplitR; [by rewrite Hexend in Hred|]. iIntros (????). rewrite Hexend. - iMod ("Hwp" with "[//]") as "Hwp". iIntros "!>!>". iMod "Hwp". iIntros "!>". - iApply step_fupdN_intro; [done|]. iIntros "!>". - iMod "Hwp" as "[Hσ [Hwp ->]]". - iDestruct (model_agree' with "Hmi Hst") as %Hmeq. iFrame. - rewrite /trace_ends_in in Hexend. rewrite -Hexend. - iMod (update_model_step with "Hfuel1 Hst Hmi") as - (δ2 Hvse) "(Hfuel & Hst & Hmod)"; eauto. - - rewrite -Hloc. eapply locale_step_atomic; eauto. by apply fill_step. - - iModIntro; iExists δ2, (Take_step ρ tid). rewrite big_sepL_nil. iFrame. - iSplit; [done|]. iDestruct ("Hwp" with "Hst Hfuel Hfr") as "Hwp". by iFrame. -Qed. - -Lemma wp_step_model_singlerole s tid ρ (f1 : nat) fr s1 s2 E e Φ : - TCEq (to_val e) None → - fmtrans M s1 (Some ρ) s2 → - M.(live_roles) s2 ⊆ M.(live_roles) s1 → - ▷ frag_model_is s1 -∗ ▷ tid ↦M {[ρ := f1]} -∗ ▷ frag_free_roles_are fr -∗ - sswp s E e (λ e', frag_model_is s2 -∗ - tid ↦M {[ρ := (LM.(lm_fl) s2)]} -∗ - frag_free_roles_are fr -∗ - WP e' @ s; tid; E {{ Φ }} ) -∗ - WP e @ s; tid; E {{ Φ }}. -Proof. - iIntros (Hval Htrans Hlive) ">Hst >Hfuel1 >Hfr Hwp". - replace ({[ρ := f1]}) with ({[ρ := f1]} ∪ (fmap S ∅:gmap _ _)); last first. - { rewrite fmap_empty. rewrite right_id_L. done. } - iApply (wp_step_model with "Hst Hfuel1 Hfr"); [done|set_solver|done|]. - iApply (sswp_wand with "[] Hwp"). iIntros (e') "Hwp Hst Hfuel1 Hfr". - rewrite right_id_L. iApply ("Hwp" with "Hst Hfuel1 Hfr"). -Qed. - -Lemma wp_step_fuel s tid E e fs Φ : - fs ≠ ∅ → ▷ tid ↦M++ fs -∗ - sswp s E e (λ e', tid ↦M fs -∗ WP e' @ s; tid; E {{ Φ }} ) -∗ - WP e @ s; tid; E {{ Φ }}. -Proof. - iIntros (?) ">HfuelS Hwp". rewrite wp_unfold /wp_pre /sswp /=. - destruct (to_val e). - { iMod (has_fuels_decr with "HfuelS") as "Hfuel". - iDestruct ("Hwp" with "Hfuel") as "Hwp". - iDestruct (wp_value_inv with "Hwp") as "Hwp". by iMod "Hwp". } - 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). - iMod ("Hwp" with "[//]") as "Hwp". - iIntros "!>!>". iMod "Hwp". iIntros "!>". - iApply step_fupdN_intro; [done|]. iIntros "!>". iMod "Hwp". rewrite -Hends. - iMod (update_fuel_step with "HfuelS Hmi") as (δ2) "(%Hvse & Hfuel & Hmod)" =>//. - { rewrite Hends -Hloc. eapply locale_step_atomic; eauto. by apply fill_step. } - iIntros "!>". iDestruct "Hwp" as "[Hsi [Hwp ->]]". - iExists _, (Silent_step tid). iFrame. iSplit; [done|]. - iDestruct ("Hwp" with "Hfuel") as "Hwp". iSplit; [|done]. - iApply (wp_wand with "Hwp"). iIntros (v) "HΦ'". by iFrame. -Qed. - -(* TODO: Move this somewhere else *) -Lemma heap_lang_locales_equiv_from_length (es10 es1 es20 es2 : list expr) : - length es10 = length es20 → length es1 = length es2 → - locales_equiv_from es10 es20 es1 es2. -Proof. - revert es10 es20 es2. - induction es1 as [|e es1 IHes1]; intros es10 es20 es2 Hlen; [by destruct es2|]. - destruct es2; [done|]=> /=. constructor; [done|]. - apply IHes1; [by rewrite !app_length=> /=;f_equiv|lia]. -Qed. - -Lemma heap_lang_locales_equiv_length (es1 es2 : list expr) : - length es1 = length es2 → locales_equiv es1 es2. -Proof. intros Hlen. by apply heap_lang_locales_equiv_from_length. Qed. - -Lemma wp_role_fork s tid E e Φ R1 R2 (Hdisj: R1 ##ₘ R2) (Hnemp: R1 ∪ R2 ≠ ∅): - tid ↦M++ (R1 ∪ R2) -∗ - (∀ tid', ▷ (tid' ↦M R2 -∗ WP e @ s; tid'; ⊤ {{ _, tid' ↦M ∅ }})) -∗ - ▷ (tid ↦M R1 ={E}=∗ Φ (LitV LitUnit)) -∗ - WP Fork e @ s; tid; E {{ Φ }}. -Proof. - iIntros "Htid He HΦ". iApply wp_lift_atomic_head_step; [done|]. - iIntros (extr auxtr K tp1 tp2 σ1 Hvalex Hexend Hloc) "(% & Hsi & Hmi)". - iMod (update_fork_step R1 R2 _ - (tp1 ++ ectx_language.fill K (Val $ LitV LitUnit) :: tp2 ++ [e]) - _ _ _ e _ σ1 with "Htid Hmi") as - (δ2 Hvse) "(Hfuels1 & Hfuels2 & Hmi)". - { done. } - { done. } - { rewrite /trace_ends_in in Hexend. rewrite Hexend. done. } - { rewrite -Hloc. rewrite -(language.locale_fill _ _ K). - rewrite /trace_ends_in in Hexend. rewrite Hexend. - econstructor 1 =>//. - apply fill_step, head_prim_step. econstructor. } - { list_simplifier. exists (tp1 ++ fill K #() :: tp2). - rewrite /trace_ends_in in Hexend. rewrite Hexend. - split; first by list_simplifier. - apply heap_lang_locales_equiv_length. simpl. - 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; [by iPureIntro|]. - iSplit; [|done]. iApply "He". by list_simplifier. -Qed. - -Lemma sswp_pure_step s E e1 e2 (Φ : Prop) Ψ : - PureExec Φ 1 e1 e2 → Φ → ▷ Ψ e2 -∗ sswp s E e1 Ψ%I. -Proof. - iIntros (Hpe HΦ) "HΨ". - assert (pure_step e1 e2) as Hps. - { specialize (Hpe HΦ). by apply nsteps_once_inv in Hpe. } - rewrite /sswp /=. - assert (to_val e1 = None) as ->. - { destruct Hps as [Hred _]. specialize (Hred (Build_state ∅ ∅)). - by eapply reducible_not_val. } - iIntros (σ) "Hσ". - iMod fupd_mask_subseteq as "Hclose"; last iModIntro; [by set_solver|]. - iSplit. - { destruct s; [|done]. by destruct Hps as [Hred _]. } - iIntros (e2' σ2 efs Hstep) "!>!>!>". - iMod "Hclose". iModIntro. destruct Hps as [_ Hstep']. - apply Hstep' in Hstep as [-> [-> ->]]. by iFrame. -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. - -Lemma wp_allocN_seq s E v n (Φ : expr → iProp Σ) : - 0 < n → - ▷ (∀ (l:loc), ([∗ list] i ∈ seq 0 (Z.to_nat n), - (l +ₗ (i : nat)) ↦ v ∗ meta_token (l +ₗ (i : nat)) ⊤) -∗ Φ #l) -∗ - sswp s E (AllocN (Val $ LitV $ LitInt $ n) (Val v)) Φ. -Proof. - iIntros (HnO) "HΦ". - rewrite /sswp. simpl. - iIntros (σ) "Hσ". - iMod fupd_mask_subseteq as "Hclose"; last iModIntro; first by set_solver. - iSplit. - { iPureIntro. destruct s; [|done]. apply head_prim_reducible. eauto. } - iIntros (e2 σ2 efs Hstep). iIntros "!>!>!>". - iMod "Hclose". - apply head_reducible_prim_step in Hstep; [|eauto]. - inv_head_step. - iMod (gen_heap_alloc_big _ (heap_array l (replicate (Z.to_nat n) v)) with "Hσ") - as "(Hσ & Hl & Hm)". - { apply heap_array_map_disjoint. - rewrite replicate_length Z2Nat.id ?Hexend; auto with lia. } - iFrame. - iModIntro. - iSplit; [|done]. - iApply "HΦ". - 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 s E v (Φ : expr → iProp Σ) : - ▷ (∀ l, l ↦ v -∗ meta_token l ⊤ -∗ Φ (LitV (LitLoc l))) -∗ - sswp s E (Alloc v) Φ. -Proof. - iIntros "HΦ". iApply wp_allocN_seq; [lia|]. - iIntros "!>" (l) "[[Hl Hm] _]". rewrite loc_add_0. - iApply ("HΦ" with "Hl Hm"). -Qed. - -Lemma wp_choose_nat s E (Φ : expr → iProp Σ) : - ▷ (∀ (n:nat), Φ $ Val $ LitV (LitInt n)) -∗ - sswp s E ChooseNat Φ. -Proof. - iIntros "HΦ". - rewrite /sswp. simpl. - iIntros (σ) "Hσ". - iMod fupd_mask_subseteq as "Hclose"; last iModIntro; first by set_solver. - iSplit. - { iPureIntro. destruct s; [|done]. apply head_prim_reducible. eauto. } - iIntros (e2 σ2 efs Hstep). iIntros "!>!>!>". - iMod "Hclose". - apply head_reducible_prim_step in Hstep; [|eauto]. - inv_head_step. - iFrame. - iModIntro. - iSplit; [|done]. - iApply "HΦ". - Unshelve. all: apply O. -Qed. - -Lemma wp_load s E l q v (Φ : expr → iProp Σ) : - ▷ l ↦{q} v -∗ - ▷ (l ↦{q} v -∗ Φ v) -∗ - sswp s E (Load (Val $ LitV $ LitLoc l)) Φ. -Proof. - iIntros ">Hl HΦ". - rewrite /sswp. simpl. - iIntros (σ) "Hσ". - iMod fupd_mask_subseteq as "Hclose"; last iModIntro; first by set_solver. - iDestruct (@gen_heap_valid with "Hσ Hl") as %Hheap. - iSplit. - { iPureIntro. destruct s; [|done]. apply head_prim_reducible. eauto. } - iIntros (e2 σ2 efs Hstep). iIntros "!>!>!>". - iMod "Hclose". - apply head_reducible_prim_step in Hstep; [|eauto]. - inv_head_step. - iFrame. - iModIntro. - iSplit; [|done]. - by iApply "HΦ". -Qed. - -Lemma wp_store s E l v' v (Φ : expr → iProp Σ) : - ▷ l ↦ v' -∗ - ▷ (l ↦ v -∗ Φ $ LitV LitUnit) -∗ - sswp s E (Store (Val $ LitV (LitLoc l)) (Val v)) Φ. -Proof. - iIntros ">Hl HΦ". 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. iModIntro. iSplit; [|done]. by iApply "HΦ". -Qed. - -Lemma wp_cmpxchg_fail s E l q v' v1 v2 (Φ : expr → iProp Σ) : - v' ≠ v1 → vals_compare_safe v' v1 → - ▷ l ↦{q} v' -∗ - ▷ (l ↦{q} v' -∗ Φ $ PairV v' (LitV $ LitBool false)) -∗ - sswp s E (CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2)) Φ. -Proof. - iIntros (??) ">Hl HΦ". 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". - iFrame. - apply head_reducible_prim_step in Hstep; [|by eauto]. - inv_head_step. - rewrite bool_decide_false //. iFrame. iModIntro. - iSplit; [|done]. - by iApply "HΦ". -Qed. - -Lemma wp_cmpxchg_suc s E l v' v1 v2 (Φ : expr → iProp Σ) : - v' = v1 → vals_compare_safe v' v1 → - ▷ l ↦ v' -∗ - ▷ (l ↦ v2 -∗ Φ $ PairV v' (LitV $ LitBool true)) -∗ - sswp s E (CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2)) Φ. -Proof. - iIntros (??) ">Hl HΦ". 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 (@gen_heap_update with "Hsi Hl") as "[Hsi Hl]". - iMod "Hclose". - iFrame. - apply head_reducible_prim_step in Hstep; [|by eauto]. - inv_head_step. - rewrite bool_decide_true //. iFrame. iModIntro. - iSplit; [|done]. - by iApply "HΦ". -Qed. - -End lifting. diff --git a/fairis/heap_lang/locations.v b/fairis/heap_lang/locations.v deleted file mode 100644 index 75221da..0000000 --- a/fairis/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/fairis/heap_lang/notation.v b/fairis/heap_lang/notation.v deleted file mode 100644 index c43d8ce..0000000 --- a/fairis/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/fairis/heap_lang/proofmode.v b/fairis/heap_lang/proofmode.v deleted file mode 100644 index 961402e..0000000 --- a/fairis/heap_lang/proofmode.v +++ /dev/null @@ -1,1030 +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. iIntros "?"; done. } - - inversion HPE; simplify_eq. - - iIntros "H Hf". - rewrite has_fuels_plus_split_S. - iApply (wp_step_fuel with "Hf"). - { by intros ?%fmap_empty_inv. } - iApply sswp_pure_step. - { econstructor =>//. constructor. } - { eapply pure_step_ctx. done. } - iModIntro. iIntros "Hf". iApply (IHn _ _ _ with "[H] [Hf]") => //. -Qed. - -Lemma equiv_wand {Σ} (P Q: iProp Σ): - P ≡ Q -> - P -∗ Q. -Proof. intros ->; auto. 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; - 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_step_fuel with "H1"); [by intros ?%fmap_empty_inv|]. - iApply (wp_load with "H2"). - iIntros "!> Hl Hf". wp_pures. 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_step_fuel with "H1"); [by intros ?%fmap_empty_inv|]. - iApply (wp_store with "H2"). - iIntros "!> Hl Hf". wp_pures. - 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/fairis/heap_lang/tactics.v b/fairis/heap_lang/tactics.v deleted file mode 100644 index e13b022..0000000 --- a/fairis/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/fairis/inftraces.v b/fairis/inftraces.v deleted file mode 100644 index fe8e24e..0000000 --- a/fairis/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/fairis/map_included_utils.v b/fairis/map_included_utils.v deleted file mode 100644 index e69eb39..0000000 --- a/fairis/map_included_utils.v +++ /dev/null @@ -1,485 +0,0 @@ -From Coq Require Import ssreflect. -From stdpp Require Import gmap. - -(* TODO: Make context, and generalise lemmas to canonical representation *) -Lemma map_included_spec `{∀ A, Lookup K A (MAP A)} {A} - (R : relation A) (m1 m2 : MAP A) : - map_included R m1 m2 ↔ - (∀ k v1, m1 !! k = Some v1 → ∃ v2, m2 !! k = Some v2 ∧ R v1 v2). -Proof. - split. - - rewrite /map_included /map_relation /option_relation. - intros HR. - intros k v1 Hv1. - specialize (HR k). rewrite Hv1 in HR. - destruct (m2 !! k) eqn:Heqn; [|done]. - exists a. done. - - intros HR. - rewrite /map_included /map_relation /option_relation. - intros k. - destruct (m1 !! k) eqn:Heqn. - + apply HR in Heqn as [v2 [Hv2 HR']]. - rewrite Hv2. done. - + by destruct (m2 !! k). -Qed. - -Lemma map_included_insert `{Countable K} {A} - (R : relation A) (m1 m2 : gmap K A) i x y : - R x y → - map_included R m1 m2 → - map_included R (<[i:=x]>m1) (<[i:=y]>m2). -Proof. - intros HR Hle. - rewrite /map_included /map_relation /option_relation. - intros k. - destruct (decide (i=k)) as [<-|Hneq]. - - rewrite !lookup_insert. done. - - rewrite lookup_insert_ne; [done|]. - rewrite lookup_insert_ne; [done|]. - apply Hle. -Qed. - - -Lemma map_included_refl `{∀ A, Lookup K A (MAP A)} {A} - `{!Reflexive R} (m : MAP A) : - map_included R m m. -Proof. rewrite map_included_spec. intros. by eauto. Qed. - -(* TODO: Move *) -(* TODO: Generalise to map_included instead of subseteq? *) -Lemma map_included_subseteq `{∀ A, Lookup K A (MAP A)} {A} - (R : relation A) (m1 m2 m3 : MAP A) : - m1 ⊆ m2 → map_included R m2 m3 → map_included R m1 m3. -Proof. - rewrite /subseteq /map_subseteq !map_included_spec. - intros Hle1 Hle2. - intros k v1 HSome. - apply Hle1 in HSome as [v2 [HSome HR]]. - apply Hle2 in HSome as [v3 [HSome HR']]. - exists v3. split; [done|]. - by subst. -Qed. - -(* TODO: Generalise to better typeclasses *) -Lemma map_included_subseteq_inv `{Countable K} {V} - (R : relation V) (m1 m2 : gmap K V) : - map_included R m1 m2 → (dom m1) ⊆ (dom m2). -Proof. - rewrite /map_included /map_relation /option_relation. - intros Hle k. rewrite !elem_of_dom. specialize (Hle k). - intros [? Heq]. rewrite Heq in Hle. - by destruct (m2 !! k). -Qed. - -Lemma map_included_transitivity `{∀ A, Lookup K A (MAP A)} {A} - `{!Transitive R} (m1 m2 m3 : MAP A) : - map_included R m1 m2 → map_included R m2 m3 → map_included R m1 m3. -Proof. - rewrite !map_included_spec. - intros Hle1 Hle2. - intros k v1 HSome. - apply Hle1 in HSome as [v2 [HSome HR]]. - apply Hle2 in HSome as [v3 [HSome HR']]. - exists v3. split; [done|]. - by etransitivity. -Qed. - -(* TODO: Generalize types *) -Lemma map_included_fmap `{Countable K} {A} - (R : relation A) (m : gmap K A) (f : A → A) : - (∀ x:A, R x (f x)) → map_included R m (f <$> m). -Proof. - intros Hf. intros k. rewrite lookup_fmap. - destruct (m !! k); [by apply Hf|done]. -Qed. - -Lemma map_included_mono `{Countable K} {A} - (R : relation A) (m1 m2 : gmap K A) (f : A → A) : - (∀ x1 x2 : A, R x1 x2 → R (f x1) (f x2)) → - map_included R m1 m2 → - map_included R (f <$> m1) (f <$> m2). -Proof. - rewrite !map_included_spec. - intros Hf Hle. intros k v1. - intros HSome. - apply lookup_fmap_Some in HSome as (v1'&HSome&Hv1'). - apply Hle in Hv1' as (v2'&HSome2&Hv2). - exists (f v2'). simplify_eq. - rewrite lookup_fmap. rewrite HSome2. - split; [done|]. by apply Hf. -Qed. - -Lemma map_included_mono_strong `{Countable K} {A} - (R : relation A) (m1 m2 : gmap K A) (f1 f2 : gmap K A → gmap K A) : - dom (f1 m1) ⊆ dom m1 → dom m2 ⊆ dom (f2 m2) → - (∀ k x1 x2 y1 y2, - m1 !! k = Some x1 → m2 !! k = Some x2 → - (f1 m1) !! k = Some y1 → (f2 m2) !! k = Some y2 → - R x1 x2 → R y1 y2) → - map_included R m1 m2 → - map_included R (f1 m1) (f2 m2). -Proof. - rewrite !map_included_spec. - intros Hle1 Hle2 Hf HR. intros k v1. - intros HSome1. - assert (∃ v1', m1 !! k = Some v1') as [v1' HSome1']. - { apply elem_of_dom_2 in HSome1. apply Hle1 in HSome1. - apply elem_of_dom in HSome1 as [? ->]. by eauto. } - pose proof HSome1' as HSome1''. - apply HR in HSome1'' as (v2'&HSome2'&Hv2'). - assert (∃ v2, f2 m2 !! k = Some v2) as [v2 HSome2]. - { apply elem_of_dom_2 in HSome2'. apply Hle2 in HSome2'. - apply elem_of_dom in HSome2' as [? ->]. by eauto. } - exists v2. split; [done|]. - by eapply Hf. -Qed. - -Lemma map_included_filter `{Countable K} {A} - (R : relation A) (m1 m2 : gmap K A) (P : (K * A) → Prop) - `{∀ x, Decision (P x)} : - (∀ k x1 x2, - m1 !! k = Some x1 → m2 !! k = Some x2 → P (k,x1) → P (k,x2)) → - map_included R m1 m2 → - map_included R (filter P m1) (filter P m2). -Proof. - rewrite !map_included_spec. - intros HP Hle k v1 HSome1. - pose proof HSome1 as HP'. - apply map_lookup_filter_Some_1_1 in HSome1. - apply map_lookup_filter_Some_1_2 in HP'. - pose proof HSome1 as HSome2. - apply Hle in HSome2 as [v2 [HSome2 HR]]. - specialize (HP k v1 v2 HSome1 HSome2 HP'). - exists v2. split; [|done]. - by apply map_lookup_filter_Some_2. -Qed. - -Lemma map_included_subseteq_r `{∀ A, Lookup K A (MAP A)} {A} - (R : relation A) (m1 m2 m3 : MAP A) : - m2 ⊆ m3 → map_included R m1 m2 → map_included R m1 m3. -Proof. - rewrite /subseteq /map_subseteq !map_included_spec. - intros Hle1 Hle2. - intros k v1 HSome. - apply Hle2 in HSome as [v2 [HSome HR]]. - apply Hle1 in HSome as [v3 [HSome HR']]. - exists v3. split; [done|]. - by subst. -Qed. - -Definition map_agree_R `{∀ A, Lookup K A (MAP A)} {A B} - (R : A → B → Prop) (m1 : MAP A) (m2 : MAP B) := - map_relation R (λ _, False) (λ _, False) m1 m2. - -Lemma map_agree_R_spec `{∀ A, Lookup K A (MAP A)} {A} - (R : relation A) (m1 m2 : MAP A) : - map_agree_R R m1 m2 ↔ - (∀ k v1, m1 !! k = Some v1 → ∃ v2, m2 !! k = Some v2 ∧ R v1 v2) ∧ - (∀ k v2, m2 !! k = Some v2 → ∃ v1, m1 !! k = Some v1 ∧ R v1 v2). -Proof. - rewrite /map_agree_R /map_relation /option_relation. split. - - intros HR. split. - + intros k v HSome. specialize (HR k). rewrite HSome in HR. - destruct (m2 !! k); [by eauto|done]. - + intros k v HSome. specialize (HR k). rewrite HSome in HR. - destruct (m1 !! k); [by eauto|done]. - - intros [HR1 HR2] k. - destruct (m1 !! k) as [v1|] eqn:Heqn1. - { by apply HR1 in Heqn1 as [? [-> ?]]. } - destruct (m2 !! k) as [v2|] eqn:Heqn2. - { apply HR2 in Heqn2 as [? [? ?]]. by simplify_eq. } - done. -Qed. - -Lemma map_included_delete `{Countable K} {V} - (R : relation V) (m1 m2 : gmap K V) k : - map_included R m1 m2 → - map_included R (delete k m1) (delete k m2). -Proof. - rewrite !map_included_spec. - intros Hle k' v HSome. - apply lookup_delete_Some in HSome as [HK HSome]. - apply Hle in HSome as (?&?&?). - exists x. by rewrite lookup_delete_ne. -Qed. - -Lemma map_agree_R_dom `{Countable K} {V} - (R : relation V) (m1 m2 : gmap K V) : - map_agree_R R m1 m2 → dom m1 = dom m2. -Proof. - rewrite map_agree_R_spec. intros [Hle1 Hle2]. apply set_eq. - intros k. split. - - intros [v1 HSome1]%elem_of_dom. - apply Hle1 in HSome1 as (?&?&?). - by apply elem_of_dom. - - intros [v2 HSome2]%elem_of_dom. - apply Hle2 in HSome2 as (?&?&?). - by apply elem_of_dom. -Qed. - -Lemma map_agree_R_insert `{Countable K} {V} - (R : relation V) (m1 m2 : gmap K V) k v1 v2 : - R v1 v2 → - map_agree_R R m1 m2 → - map_agree_R R (<[k:=v1]>m1) (<[k:=v2]>m2). -Proof. - rewrite !map_agree_R_spec. - intros HR [Hle1 Hle2]. - split. - - intros k' v1' HSome1. - destruct (decide (k = k')) as [->|Hneq]. - + rewrite lookup_insert in HSome1. simplify_eq. - exists v2. rewrite lookup_insert. done. - + rewrite lookup_insert_ne in HSome1; [done|]. - apply Hle1 in HSome1 as (v2'&HSome2&HR2). - exists v2'. rewrite lookup_insert_ne; [|done]. done. - - intros k' v2' HSome2. - destruct (decide (k = k')) as [->|Hneq]. - + rewrite lookup_insert in HSome2. simplify_eq. - exists v1. rewrite lookup_insert. done. - + rewrite lookup_insert_ne in HSome2; [done|]. - apply Hle2 in HSome2 as (v1'&HSome1&HR1). - exists v1'. rewrite lookup_insert_ne; [|done]. done. -Qed. - -Lemma map_agree_R_insert_inv `{Countable K} {V} - (R : relation V) (m1 m2 : gmap K V) k v1 v2 : - k ∉ dom m1 → k ∉ dom m2 → - map_agree_R R (<[k:=v1]>m1) (<[k:=v2]>m2) → - map_agree_R R m1 m2. -Proof. - intros Hnin1 Hnin2. - rewrite !map_agree_R_spec. - intros [Hle1 Hle2]. - split. - - intros k' v1' HSome1. - destruct (decide (k = k')) as [->|Hneq]. - { apply not_elem_of_dom in Hnin1. set_solver. } - assert (<[k:=v1]>m1 !! k' = Some v1') as HSome1'. - { by rewrite lookup_insert_ne. } - apply Hle1 in HSome1' as (v2'&HSome2&HR). - rewrite lookup_insert_ne in HSome2; [done|]. - by eauto. - - intros k' v2' HSome2. - destruct (decide (k = k')) as [->|Hneq]. - { apply not_elem_of_dom in Hnin2. set_solver. } - assert (<[k:=v2]>m2 !! k' = Some v2') as HSome2'. - { by rewrite lookup_insert_ne. } - apply Hle2 in HSome2' as (v1'&HSome1&HR). - rewrite lookup_insert_ne in HSome1; [done|]. - by eauto. -Qed. - -Lemma map_agree_R_agree `{Countable K} {V} - (R : relation V) (m1 m2 : gmap K V) k v1 v2 : - m1 !! k = Some v1 → m2 !! k = Some v2 → - map_agree_R R m1 m2 → - R v1 v2. -Proof. - rewrite map_agree_R_spec. - intros HSome1 HSome2 Hle. - apply Hle in HSome1 as (v2'&HSome2'&HR). - rewrite HSome2' in HSome2. by simplify_eq. -Qed. - -Lemma map_included_R_agree `{Countable K} {V} - (R : relation V) (m1 m2 : gmap K V) k v1 v2 : - m1 !! k = Some v1 → m2 !! k = Some v2 → - map_included R m1 m2 → - R v1 v2. -Proof. - rewrite map_included_spec. - intros HSome1 HSome2 Hle. - apply Hle in HSome1 as (v2'&HSome2'&HR). - rewrite HSome2' in HSome2. by simplify_eq. -Qed. - -Lemma map_included_map_agree_R `{Countable K} {V} - (R : relation V) (m1 m2 : gmap K V) : - map_included R m1 m2 → - ∃ m21 m22, - m2 = m21 ∪ m22 ∧ - m21 ##ₘ m22 ∧ - map_agree_R R m1 m21. -Proof. - revert m1. - induction m2 as [|k v2 m2 Hnin IHm2] using map_ind; intros m1 Hle. - { by exists ∅, ∅. } - destruct (decide (k ∈ dom m1)) as [Hin|Hnin']; last first. - { apply (map_included_delete _ _ _ k) in Hle. - rewrite delete_insert in Hle; [done|]. - apply IHm2 in Hle as (m21&m22&->&Hdisj&HR). - exists m21, (<[k:=v2]>m22). - assert (dom m1 = dom m21) as Hdom. - { eapply map_agree_R_dom. apply not_elem_of_dom in Hnin'. - by rewrite delete_notin in HR. } - apply map_disjoint_dom in Hdisj. - rewrite insert_union_r; [by apply not_elem_of_dom; set_solver|]. - split; [done|]. - apply not_elem_of_dom in Hnin'. - rewrite delete_notin in HR; [done|]. - split; [|done]. - apply map_disjoint_dom. - apply not_elem_of_dom in Hnin'. - set_solver. } - apply elem_of_dom in Hin as [v1 HSome]. - assert (R v1 v2). - { eapply map_included_R_agree; [| |done]. - - done. - - by rewrite lookup_insert. } - apply (map_included_delete _ _ _ k) in Hle. - rewrite delete_insert in Hle; [done|]. - apply IHm2 in Hle as (m21&m22&->&Hdisj&HR). - exists (<[k:=v2]>m21), m22. - assert (dom (delete k m1) = dom m21) as Hdom. - { eapply map_agree_R_dom. done. } - apply map_disjoint_dom in Hdisj. - rewrite insert_union_l. - split; [done|]. - apply (map_agree_R_insert _ _ _ k v1 v2) in HR; [|done]. - rewrite insert_delete in HR; [done|]. - split; [|done]. - apply map_disjoint_dom. - rewrite dom_insert_L. - apply not_elem_of_dom in Hnin. - set_solver. -Qed. - -Lemma map_agree_R_map_included `{Countable K} {V} - (R : relation V) (m1 m2 : gmap K V) : - map_agree_R R m1 m2 → map_included R m1 m2. -Proof. - rewrite map_included_spec map_agree_R_spec. - by intros [Hle _]. -Qed. - -Lemma map_agree_R_union_inv `{Countable K} {V} - (R : relation V) (m11 m12 m2 : gmap K V) : - m11 ##ₘ m12 → - map_agree_R R (m11 ∪ m12) m2 → - ∃ m21 m22, m2 = m21 ∪ m22 ∧ map_agree_R R m11 m21 ∧ - map_agree_R R m12 m22. -Proof. - intros Hdisj%map_disjoint_dom Hle. - pose proof Hle as Hdom%map_agree_R_dom. - rewrite comm in Hdom. - rewrite dom_union_L in Hdom. - apply dom_union_inv_L in Hdom as (m21&m22&->&Hdosj&Hdom1&Hdom2); - [|done]. - exists m21, m22. - split; [done|]. - split. - - apply map_agree_R_spec. - split. - + intros k v1 HSome1. - apply map_agree_R_spec in Hle as [Hle1 Hle2]. - assert ((m11 ∪ m12) !! k = Some v1) as HSome1'. - { rewrite lookup_union_l; [|done]. - apply not_elem_of_dom. - apply elem_of_dom_2 in HSome1. set_solver. } - apply Hle1 in HSome1' as (v2&HSome2'&HR). - assert (m21 !! k = Some v2) as HSome2. - { rewrite lookup_union_l in HSome2'; [|done]. - apply not_elem_of_dom. apply elem_of_dom_2 in HSome1. - set_solver. } - eauto. - + intros k v2 HSome2. - apply map_agree_R_spec in Hle as [Hle1 Hle2]. - assert ((m21 ∪ m22) !! k = Some v2) as HSome2'. - { rewrite lookup_union_l; [|done]. - apply not_elem_of_dom. - apply elem_of_dom_2 in HSome2. set_solver. } - apply Hle2 in HSome2' as (v1&HSome1'&HR). - assert (m11 !! k = Some v1) as HSome1. - { rewrite lookup_union_l in HSome1'; [|done]. - apply not_elem_of_dom. apply elem_of_dom_2 in HSome2. - set_solver. } - eauto. - - apply map_agree_R_spec. - split. - + intros k v1 HSome1. - apply map_agree_R_spec in Hle as [Hle1 Hle2]. - assert ((m11 ∪ m12) !! k = Some v1) as HSome1'. - { rewrite lookup_union_r; [|done]. - apply not_elem_of_dom. - apply elem_of_dom_2 in HSome1. set_solver. } - apply Hle1 in HSome1' as (v2&HSome2'&HR). - assert (m22 !! k = Some v2) as HSome2. - { rewrite lookup_union_r in HSome2'; [|done]. - apply not_elem_of_dom. apply elem_of_dom_2 in HSome1. - set_solver. } - eauto. - + intros k v2 HSome2. - apply map_agree_R_spec in Hle as [Hle1 Hle2]. - assert ((m21 ∪ m22) !! k = Some v2) as HSome2'. - { rewrite lookup_union_r; [|done]. - apply not_elem_of_dom. - apply elem_of_dom_2 in HSome2. set_solver. } - apply Hle2 in HSome2' as (v1&HSome1'&HR). - assert (m12 !! k = Some v1) as HSome1. - { rewrite lookup_union_r in HSome1'; [|done]. - apply not_elem_of_dom. apply elem_of_dom_2 in HSome2. - set_solver. } - eauto. -Qed. - -(* OBS: Need restrictions on f *) -Lemma map_agree_R_fmap_inv `{Countable K} {V} - (R : relation V) (m1 m2 : gmap K V) f : - (* OBS: Is this a general relation/function property? *) - (∀ v1 v2, R (f v1) v2 → ∃ v2', v2 = f v2') → - map_agree_R R (f <$> m1) m2 → - ∃ m2', m2 = f <$> m2'. -Proof. - revert m1. - induction m2 as [|k v2 m2 Hnin IHm2] using map_ind; intros m1 Hf Hle. - { exists ∅. rewrite fmap_empty. done. } - pose proof Hle as Hle'. - apply map_agree_R_spec in Hle. - assert (<[k:=v2]> m2 !! k = Some v2) as HSome2 - by by rewrite lookup_insert. - apply Hle in HSome2 as (v1&HSome1&HR). - apply lookup_fmap_Some in HSome1 as (v1'&<-&HSome1'). - assert (∃ v2', v2 = f v2') as [v2' Heq]. - { by eapply Hf. } - rewrite Heq in HR. - assert (map_agree_R R (f <$> (delete k m1)) m2) as Hle''. - { rewrite -(insert_id m1 k v1') in Hle'; [done|]. - rewrite -insert_delete_insert in Hle'. - rewrite fmap_insert in Hle'. - eapply map_agree_R_insert_inv; [| |apply Hle']. - - set_solver. - - apply not_elem_of_dom. set_solver. - } - apply IHm2 in Hle'' as [m2' Heq']; [|done]. - exists (<[k:=v2']>m2'). - rewrite fmap_insert. rewrite Heq. f_equiv. done. -Qed. - -(* OBS: Need restrictions on f *) -Lemma map_agree_R_fmap `{Countable K} {V} - (R : relation V) (m1 m2 : gmap K V) f : - (∀ v1 v2, R (f v1) (f v2) → R v1 v2) → - map_agree_R R (f <$> m1) (f <$> m2) → - map_agree_R R m1 m2. -Proof. - intros Hf. - rewrite !map_agree_R_spec. - intros [Hle1 Hle2]. - split. - - intros k v1 HSome1. - assert ((f <$> m1) !! k = Some (f v1)) as HSome1'. - { rewrite lookup_fmap. destruct (m1 !! k); [by simplify_eq|done]. } - apply Hle1 in HSome1' as (v2'&HSome2'&HR). - apply lookup_fmap_Some in HSome2' as (v2&<-&HSome2). - apply Hf in HR. - by eauto. - - intros k v2 HSome2. - assert ((f <$> m2) !! k = Some (f v2)) as HSome2'. - { rewrite lookup_fmap. destruct (m2 !! k); [by simplify_eq|done]. } - apply Hle2 in HSome2' as (v1'&HSome1'&HR). - apply lookup_fmap_Some in HSome1' as (v1&<-&HSome1). - apply Hf in HR. - by eauto. -Qed. - diff --git a/fairis/resources.v b/fairis/resources.v deleted file mode 100644 index d67eb05..0000000 --- a/fairis/resources.v +++ /dev/null @@ -1,2094 +0,0 @@ -From iris.algebra Require Import auth gmap gset excl. -From iris.proofmode Require Import tactics. -From trillium.fairness Require Import fairness fuel map_included_utils. - -Canonical Structure ModelO (Mdl : FairModel) := leibnizO Mdl. -Canonical Structure RoleO (Mdl : FairModel) := leibnizO (Mdl.(fmrole)). -Canonical Structure localeO (Λ : language) := leibnizO (locale Λ). - -Class fairnessGpreS `{Countable (locale Λ)} `(LM: LiveModel Λ M) Σ := { - fairnessGpreS_model :> inG Σ (authUR (optionUR (exclR (ModelO M)))); - fairnessGpreS_model_fuel_mapping :> - inG Σ (authUR (gmapUR (localeO Λ) - (exclR $ gmapUR (RoleO M) natO))); - fairnessGpreS_model_free_roles :> inG Σ (authUR (gset_disjUR (RoleO M))); -}. - -Class fairnessGS `{Countable (locale Λ)} `(LM : LiveModel Λ M) Σ := FairnessGS { - fairness_inG :> fairnessGpreS LM Σ; - (** Underlying model *) - fairness_model_name : gname; - (** Mapping of threads to roles with fuel *) - fairness_model_fuel_mapping_name : gname; - (** Set of free/availble roles *) - fairness_model_free_roles_name : gname; -}. - -Global Arguments fairnessGS {_ _ _ _} LM Σ. -Global Arguments fairness_model_name {_ _ _ _ LM Σ} _. -Global Arguments fairness_model_fuel_mapping_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 $ gmapUR (RoleO M) natO))); - GFunctor (authUR (gset_disjUR (RoleO M))) -]. - -Global Instance subG_fairnessGpreS {Σ} `{Countable (locale Λ)} `{LM : LiveModel Λ M} - : - 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 `{Countable (locale Λ)}. - Context `{LM: LiveModel Λ M}. - Context {Σ : gFunctors}. - Context {fG: fairnessGS LM Σ}. - - Notation Role := (M.(fmrole)). - - Definition auth_fuel_mapping_is - (m: gmap (locale Λ) (gmap Role nat)) : iProp Σ := - own (fairness_model_fuel_mapping_name fG) - (● (fmap Excl m : - ucmra_car (gmapUR _ (exclR $ gmapUR (RoleO M) natO) - ))). - - Definition frag_fuel_mapping_is - (m: gmap (locale Λ) (gmap Role nat)) : iProp Σ := - own (fairness_model_fuel_mapping_name fG) - (◯ (fmap Excl m: - ucmra_car (gmapUR _ (exclR $ gmapUR (RoleO M) natO) - ))). - - 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 fuel_map_le_inner (m1 m2 : gmap (locale Λ) (gmap Role nat)) := - map_included (λ (fs1 fs2 : gmap Role nat), - map_included (≤) fs1 fs2) m1 m2. - - Definition fuel_map_le (m1 m2 : gmap (locale Λ) (gmap Role nat)) := - fuel_map_le_inner m1 m2 ∧ - (* OBS: This is a bit hacky, should instead change definition. *) - dom m1 = dom m2. - - Definition fuel_map_preserve_dead - (m : gmap (locale Λ) (gmap Role nat)) - (ρs : gset Role) := - ∀ ρ, ρ ∈ ρs → ∃ ζ fs, m !! ζ = Some fs ∧ ρ ∈ dom fs. - - Definition fuel_map_preserve_threadpool (tp: list $ expr Λ) - (fuel_map : gmap (locale Λ) (gmap Role nat)) := - ∀ ζ, ζ ∉ locales_of_list tp → fuel_map !! ζ = None. - - Definition model_state_interp (tp: list $ expr Λ) (δ: LiveState Λ M): iProp Σ := - ∃ fuel_map, - ⌜ fuel_map_le fuel_map δ.(ls_map) ⌝ ∗ - ⌜ fuel_map_preserve_dead fuel_map (M.(live_roles) δ) ⌝ ∗ - ⌜ fuel_map_preserve_threadpool tp fuel_map ⌝ ∗ - auth_model_is δ ∗ auth_fuel_mapping_is fuel_map. - - Lemma model_state_interp_tids_smaller δ tp : - model_state_interp tp δ -∗ ⌜ tids_smaller tp δ ⌝. - Proof. - iIntros "(%m&[_ %Heq]&%&%Hbig&_)". - iPureIntro. - intros ζ Hin. - assert (¬ (ζ ∉ locales_of_list tp)). - - intros contra. - specialize (Hbig _ contra). - rewrite -Heq elem_of_dom Hbig in Hin. - inversion Hin. naive_solver. - - 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. intros ->; auto. Qed. - -Section model_state_lemmas. - Context `{Countable (locale Λ)}. - Context `{LM: LiveModel Λ M}. - Context {Σ : gFunctors}. - Context {fG: fairnessGS LM Σ}. - - Notation Role := (M.(fmrole)). - - Definition has_fuels (ζ: locale Λ) (fs: gmap Role nat) : iProp Σ := - frag_fuel_mapping_is {[ ζ := fs ]}. - - #[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. - - Definition has_fuels_S (ζ: locale Λ) (fs: gmap Role nat): iProp Σ := - has_fuels ζ (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_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. - -End model_state_lemmas. - -Notation "tid ↦M R" := (has_fuels tid R) (at level 20, format "tid ↦M R") : bi_scope. -Notation "tid ↦M++ R" := (has_fuels_S tid R) (at level 20, format "tid ↦M++ R") : bi_scope. - -Section adequacy. - Context `{Countable (locale Λ)}. - Context `{LM: LiveModel Λ M}. - 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. - - Definition init_fuel_map (s0: M) (ζ0: locale Λ) : - gmap (locale Λ) (exclR $ gmap (fmrole M) nat) := - {[ ζ0 := Excl (gset_to_gmap (LM.(lm_fl) s0) (M.(live_roles) s0)) ]}. - - Lemma model_fuel_mapping_init (s0: M) (ζ0: locale Λ) : - ⊢ |==> ∃ γ, - own γ (● (init_fuel_map s0 ζ0)) ∗ - own γ (◯ (init_fuel_map s0 ζ0)). - Proof. - iMod (own_alloc (● (init_fuel_map s0 ζ0) ⋅ - ◯ (init_fuel_map s0 ζ0))) as (γ) "[Hfl Hfr]". - { apply auth_both_valid_2; eauto. by apply singleton_valid. } - iExists _. by iSplitL "Hfl". - 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 `{Countable (locale Λ)}. - Context `{LM: LiveModel Λ M}. - 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 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 has_fuels_agree (ζ : locale Λ) (fs : gmap (fmrole M) nat) - (m : gmap (locale Λ) (gmap (fmrole M) nat)) : - auth_fuel_mapping_is m -∗ has_fuels ζ fs -∗ ⌜m !! ζ = Some fs⌝. - Proof. - iIntros "Hauth Hfrag". - iDestruct (own_valid_2 with "Hauth Hfrag") as %Hvalid. - iPureIntro. - apply auth_both_valid_discrete in Hvalid as [Hincl Hvalid]. - rewrite map_fmap_singleton in Hincl. - apply singleton_included_exclusive_l in Hincl; - [|apply _|done]. - rewrite lookup_fmap in Hincl. - apply leibniz_equiv in Hincl. - destruct (m !! ζ); simplify_eq/=; done. - Qed. - - Lemma has_fuels_update fm ζ fs fs' : - auth_fuel_mapping_is fm -∗ has_fuels ζ fs ==∗ - auth_fuel_mapping_is (<[ζ := fs']>fm) ∗ has_fuels ζ fs'. - Proof. - iIntros "Hfm Hfs". - rewrite /has_fuels_S. - iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. - iMod (own_update_2 with "Hfm Hfs") as "[$ $]"; [|done]. - apply auth_update. - rewrite !fmap_insert. - rewrite !fmap_empty. - rewrite -(insert_insert ∅ ζ (Excl fs') (Excl fs)). - eapply insert_local_update; [| |]. - - rewrite lookup_fmap. rewrite Hagree. simpl. done. - - simpl. rewrite lookup_insert. done. - - eapply exclusive_local_update. done. - Qed. - - Lemma has_fuels_decr (ζ : locale Λ) (fs : gmap (fmrole M) nat) - (m : gmap (locale Λ) (gmap (fmrole M) nat)) : - auth_fuel_mapping_is m -∗ has_fuels_S ζ fs ==∗ - auth_fuel_mapping_is (<[ζ := fs]>m) ∗ has_fuels ζ fs. - Proof. - iIntros "Hfm Hfs". - iMod (has_fuels_update with "Hfm Hfs") as "[Hfm Hfs]". - by iFrame. - Qed. - - Lemma has_fuels_delete fs ζ ρs ρ : - auth_fuel_mapping_is fs -∗ has_fuels ζ ρs ==∗ - auth_fuel_mapping_is (<[ζ := delete ρ ρs]>fs) ∗ - has_fuels ζ (delete ρ ρs). - Proof. - iIntros "Hfm Hfs". - iMod (has_fuels_update with "Hfm Hfs") as "[Hfm Hfs]". - by iFrame. - Qed. - - Lemma model_state_interp_has_fuels_decr tp δ tid fs : - model_state_interp tp δ -∗ has_fuels_S tid fs ==∗ - model_state_interp tp δ ∗ has_fuels tid fs. - Proof. - iDestruct 1 as - (fm [Hfmle Hdom] Hfmdead Htp) "(Hδ & Hfm)". - iIntros "Hfs". - iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. - iMod (has_fuels_decr with "Hfm Hfs") as "[Hfm Hfs]". - iModIntro. iFrame "Hfs". - iExists _. iFrame. - iPureIntro. repeat split. - - eapply map_included_transitivity; [|done]. - rewrite -{2}(insert_id fm tid (S <$> fs)); [|done]. - apply map_included_insert; [|apply map_included_refl]. - apply map_included_fmap. lia. - - rewrite -Hdom. rewrite -{2}(insert_id fm tid (S <$> fs)); [set_solver|]. - done. - - intros ρ Hin. apply Hfmdead in Hin as (ζ'&ρs&HSome&Hρ). - destruct (decide (tid = ζ')) as [->|Hneq]. - + exists ζ', fs. rewrite lookup_insert. - split; [done|]. set_solver. - + exists ζ', ρs. rewrite lookup_insert_ne; [|done]. done. - - intros ζ Hζ. - specialize (Htp ζ Hζ). - rewrite -(insert_id fm tid (S <$> fs)) in Htp; [|done]. - rewrite -not_elem_of_dom. - rewrite -not_elem_of_dom in Htp. - set_solver. - Qed. - - Lemma model_state_interp_has_fuels_dealloc tid fs ρ tp δ δ' : - ρ ∉ live_roles _ δ → - model_state_interp tp δ' -∗ - frag_model_is δ -∗ - has_fuels tid fs ==∗ - model_state_interp tp δ' ∗ frag_model_is δ ∗ has_fuels tid (delete ρ fs). - Proof. - intros Hρ. - destruct (decide (ρ ∈ dom fs)) as [Hin|Hnin]; last first. - { assert (delete ρ fs = fs) as ->. - { apply delete_notin. by rewrite -not_elem_of_dom. } - by iIntros "$$$". } - iDestruct 1 as - (fm [Hfmle Hdom] Hfmdead Htp) "(Hm & Hfm)". - iIntros "Hst Hfs". - iDestruct (model_agree with "Hm Hst") as %Heq. rewrite !Heq. - assert (is_Some (fs !! ρ)) as [f HSome]. - { by rewrite -elem_of_dom. } - iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. - iMod (has_fuels_delete with "Hfm Hfs") as "[Hfm Hfs]". - iModIntro. - iFrame "Hst". iFrame "Hfs". - iExists _. iFrame. rewrite Heq. iFrame. - iPureIntro. - repeat split; try done. - - rewrite /fuel_map_le. - eapply map_included_transitivity; [|done]. - rewrite -{2}(insert_id fm tid fs); [|done]. - apply map_included_insert; [|apply map_included_refl]. - eapply map_included_subseteq; [|done]. - apply delete_subseteq. - - rewrite dom_insert_L. - assert (tid ∈ dom fm). - { by apply elem_of_dom. } - set_solver. - - rewrite /fuel_map_preserve_dead. - intros ρ' Hρ'. - assert (ρ ≠ ρ') by set_solver. - rewrite /fuel_map_preserve_dead in Hfmdead. - rewrite Heq in Hfmdead. - apply Hfmdead in Hρ' as (ζ&ρs&HSome'&Hρs). - destruct (decide (tid = ζ)) as [->|Hneq]. - + exists ζ, (delete ρ fs). - rewrite lookup_insert. set_solver. - + exists ζ, ρs. rewrite lookup_insert_ne; [|done]. - set_solver. - - intros ζ Hζ. specialize (Htp ζ Hζ). - rewrite -not_elem_of_dom. - rewrite -not_elem_of_dom in Htp. - assert (ζ ≠ tid). - { intros ->. - assert (tid ∈ dom fm). - { rewrite elem_of_dom. by set_solver. } - set_solver. } - set_solver. - Qed. - - (* TODO: Move this *) - Lemma silent_step_suff_data_weak fl `(δ: LiveState Λ M) - (fs fs' : gmap _ nat) ζ : - δ.(ls_map) !! ζ = Some fs → - fs ≠ ∅ → - map_included (<) fs' fs → - (dom fs ∖ dom fs') ∩ M.(live_roles) δ = ∅ → - ∃ δ', δ'.(ls_data) = - {| ls_under := δ; - ls_map := <[ζ := fs']> δ.(ls_map) |} ∧ - ls_trans fl δ (Silent_step ζ) δ'. - Proof. - intros. - apply (silent_step_suff_data fl δ fs fs' ∅ ζ None); try done. - - rewrite map_included_spec in H2. done. - - set_solver. - - set_solver. - Qed. - - (* TODO: Change original lemma to not existentially quantify new state *) - Lemma silent_step_suff_data_weak_alt fl (δ δ' : LiveState Λ M) - (fs fs' : gmap _ nat) ζ : - δ.(ls_under) = δ'.(ls_under) → - δ.(ls_map) !! ζ = Some fs → - δ'.(ls_map) = <[ζ := fs']>δ.(ls_map) → - fs ≠ ∅ → - map_included (<) fs' fs → - (dom fs ∖ dom fs') ∩ M.(live_roles) δ = ∅ → - ls_trans fl δ (Silent_step ζ) δ'. - Proof. - rewrite map_included_spec. intros Hδ Hfs Hfs' Hne Hle Hlive. - assert (∃ δ', δ'.(ls_data) = - {| ls_under := δ; - ls_map := <[ζ := fs']> δ.(ls_map) |} ∧ - ls_trans fl δ (Silent_step ζ) δ') as (δ''&Heq&Htrans). - { apply (silent_step_suff_data fl δ fs fs' ∅ ζ None); try set_solver. } - rewrite Heq Hδ -Hfs' in Htrans. by destruct δ', ls_data. - Qed. - - Definition model_can_fuel_step (δ1 : LM) (ζ : locale Λ) (δ2 : LM) : Prop := - ∃ fs1 fs2, - δ1.(ls_under) = δ2.(ls_under) ∧ - δ1.(ls_map) !! ζ = Some fs1 ∧ - δ2.(ls_map) = <[ζ := fs2]>δ1.(ls_map) ∧ - fs1 ≠ ∅ ∧ - map_included (<) fs2 fs1 ∧ - (dom fs1 ∖ dom fs2) ∩ M.(live_roles) δ1 = ∅. - - Lemma model_can_fuel_step_trans fl ζ (δ δ' : LiveState Λ M) : - model_can_fuel_step δ ζ δ' → ls_trans fl δ (Silent_step ζ) δ'. - Proof. - destruct 1 as (?&?&?&?&?&?&?&?). by eapply silent_step_suff_data_weak_alt. - Qed. - - Definition decr_fuel_map (fs : gmap (fmrole M) nat) : gmap (fmrole M) nat := - (λ f, f - 1) <$> fs. - - Lemma decr_fuel_map_included fs : map_included (≤) (decr_fuel_map fs) fs. - Proof. - apply map_included_spec. intros k v1 Hm. - apply lookup_fmap_Some in Hm as [v2 [Hv2 Hm]]. - exists v2. split; [done|lia]. - Qed. - - Definition filter_fuel_map - δ (ρs : gset (fmrole M)) (fs : gmap (fmrole M) nat) : - gmap (fmrole M) nat := - (filter (λ ρf, ρf.1 ∈ M.(live_roles) δ.(ls_under) ∨ ρf.1 ∈ ρs)) fs. - - Lemma filter_fuel_map_included δ ρs fs : - map_included (≤) (filter_fuel_map δ ρs fs) fs. - Proof. - apply map_included_spec. - intros k v1 Hm. - exists v1. split; [|lia]. - pose proof (map_filter_subseteq - (λ ρf : fmrole M * nat, ρf.1 ∈ live_roles M δ ∨ ρf.1 ∈ ρs) fs) - as Hle. - rewrite map_subseteq_spec in Hle. - by apply Hle. - Qed. - - Definition model_update_locale_role_map - δ (ρs : gset (fmrole M)) : gmap (fmrole M) nat → gmap (fmrole M) nat := - decr_fuel_map ∘ filter_fuel_map δ ρs. - - Lemma model_update_locale_role_map_map_included δ ρs fs : - map_included (≤) (model_update_locale_role_map δ ρs fs) fs. - Proof. - rewrite /model_update_locale_role_map. - eapply map_included_transitivity; - [eapply decr_fuel_map_included|eapply filter_fuel_map_included]. - Qed. - - Definition model_update_locale_fuel_map - δ (ζ : locale Λ) (ρs : gset (fmrole M)) - (fm : gmap (locale Λ) (gmap (fmrole M) nat)) : - gmap (locale Λ) (gmap (fmrole M) nat) := - <[ζ:= model_update_locale_role_map δ ρs (fm !!! ζ)]>fm. - - Program Definition model_update_decr (ζ : locale Λ) (δ : LM) : LM := - {| - ls_data := - {| ls_under := δ.(ls_under); - ls_map := alter (fmap (λ f, f - 1)) ζ δ.(ls_map); |}; - |}. - Next Obligation. - intros ζ δ ζ1 ζ2 fs1 fs2 Hneq HSome1 HSome2. - simpl in *. - pose proof δ.(ls_map_disj) as Hdisj. - assert (∃ fs1', map_included (≤) fs1 fs1' ∧ ls_map δ !!! ζ1 = fs1') - as (fs1' & Hle1 & Hfs1'). - { destruct (decide (ζ = ζ1)) as [<-|Hneq']. - + rewrite lookup_alter in HSome1. - rewrite -lookup_fmap in HSome1. - apply lookup_fmap_Some in HSome1 as (fs1'&Hfs1'&HSome1'). - simplify_eq. - exists fs1'. rewrite lookup_total_alt. simpl. rewrite HSome1'. - split; [apply decr_fuel_map_included|done]. - + rewrite lookup_alter_ne in HSome1; [|done]. - rewrite lookup_total_alt. eexists _. - split; [done|by rewrite HSome1]. } - assert (∃ fs2', map_included (≤) fs2 fs2' ∧ ls_map δ !!! ζ2 = fs2') - as (fs2' & Hle2 & Hfs2'). - { destruct (decide (ζ = ζ2)) as [<-|Hneq']. - + rewrite lookup_alter in HSome2. - rewrite -lookup_fmap in HSome2. - apply lookup_fmap_Some in HSome2 as (fs2'&Hfs2'&HSome2'). - simplify_eq. - exists fs2'. rewrite lookup_total_alt. simpl. rewrite HSome2'. - split; [apply decr_fuel_map_included|done]. - + rewrite lookup_alter_ne in HSome2; [|done]. - rewrite lookup_total_alt. eexists _. - split; [done|by rewrite HSome2]. } - rewrite lookup_total_alt in Hfs1'. - rewrite lookup_total_alt in Hfs2'. - destruct (ls_map δ !! ζ1) as [fs1''|] eqn:Hfs1''; last first. - { apply map_included_subseteq_inv in Hle1. - apply map_disjoint_dom. set_solver. } - destruct (ls_map δ !! ζ2) as [fs2''|] eqn:Hfs2''; last first. - { apply map_included_subseteq_inv in Hle2. - apply map_disjoint_dom. set_solver. } - simplify_eq; simpl in *. - specialize (Hdisj ζ1 ζ2 fs1'' fs2'' Hneq Hfs1'' Hfs2''). - apply map_disjoint_spec. - rewrite map_disjoint_spec in Hdisj. - intros i x y HSome1' HSome2'. - rewrite map_included_spec in Hle1. - apply Hle1 in HSome1' as (?&?&?). - rewrite map_included_spec in Hle2. - apply Hle2 in HSome2' as (?&?&?). - by eapply Hdisj. - Qed. - Next Obligation. - intros ζ δ ρ Hlive. - simpl in *. - pose proof Hlive as Hlive'. - apply (ls_map_live δ) in Hlive as (ζ' & fs & HSome & Hdom). - destruct (decide (ζ = ζ')) as [<-|Hneq]. - - eexists ζ, _. - rewrite lookup_alter. rewrite HSome. simpl. - split; [done|]. - rewrite dom_fmap. done. - - eexists ζ', fs. by rewrite lookup_alter_ne. - Qed. - - Program Definition model_update_filter - (ζ : locale Λ) (ρs : gset (fmrole M)) (δ : LM) : LM := - {| - ls_data := - {| ls_under := δ.(ls_under); - ls_map := - alter (filter - (λ ρf, ρf.1 ∈ M.(live_roles) δ.(ls_under) ∨ ρf.1 ∈ ρs)) - ζ δ.(ls_map); |}; - |}. - Next Obligation. - intros ζ ρs δ ζ1 ζ2 fs1 fs2 Hneq HSome1 HSome2. - simpl in *. - pose proof δ.(ls_map_disj) as Hdisj. - assert (∃ fs1', map_included (≤) fs1 fs1' ∧ ls_map δ !!! ζ1 = fs1') - as (fs1' & Hle1 & Hfs1'). - { destruct (decide (ζ = ζ1)) as [<-|Hneq']. - + rewrite lookup_alter in HSome1. - rewrite -lookup_fmap in HSome1. - apply lookup_fmap_Some in HSome1 as (fs1'&Hfs1'&HSome1'). - simplify_eq. - exists fs1'. rewrite lookup_total_alt. simpl. rewrite HSome1'. - split; [apply filter_fuel_map_included|done]. - + rewrite lookup_alter_ne in HSome1; [|done]. - rewrite lookup_total_alt. eexists _. - split; [done|by rewrite HSome1]. } - assert (∃ fs2', map_included (≤) fs2 fs2' ∧ ls_map δ !!! ζ2 = fs2') - as (fs2' & Hle2 & Hfs2'). - { destruct (decide (ζ = ζ2)) as [<-|Hneq']. - + rewrite lookup_alter in HSome2. - rewrite -lookup_fmap in HSome2. - apply lookup_fmap_Some in HSome2 as (fs2'&Hfs2'&HSome2'). - simplify_eq. - exists fs2'. rewrite lookup_total_alt. simpl. rewrite HSome2'. - split; [apply filter_fuel_map_included|done]. - + rewrite lookup_alter_ne in HSome2; [|done]. - rewrite lookup_total_alt. eexists _. - split; [done|by rewrite HSome2]. } - rewrite lookup_total_alt in Hfs1'. - rewrite lookup_total_alt in Hfs2'. - destruct (ls_map δ !! ζ1) as [fs1''|] eqn:Hfs1''; last first. - { apply map_included_subseteq_inv in Hle1. - apply map_disjoint_dom. set_solver. } - destruct (ls_map δ !! ζ2) as [fs2''|] eqn:Hfs2''; last first. - { apply map_included_subseteq_inv in Hle2. - apply map_disjoint_dom. set_solver. } - simplify_eq; simpl in *. - specialize (Hdisj ζ1 ζ2 fs1'' fs2'' Hneq Hfs1'' Hfs2''). - apply map_disjoint_spec. - rewrite map_disjoint_spec in Hdisj. - intros i x y HSome1' HSome2'. - rewrite map_included_spec in Hle1. - apply Hle1 in HSome1' as (?&?&?). - rewrite map_included_spec in Hle2. - apply Hle2 in HSome2' as (?&?&?). - by eapply Hdisj. - Qed. - Next Obligation. - intros ζ ρs δ ρ Hlive. - simpl in *. - pose proof Hlive as Hlive'. - apply (ls_map_live δ) in Hlive as (ζ' & fs & HSome & Hdom). - destruct (decide (ζ = ζ')) as [<-|Hneq]. - - eexists ζ, _. - rewrite lookup_alter. rewrite HSome. simpl. - split; [done|]. - rewrite map_filter_or. - rewrite dom_union_L. - apply elem_of_union. left. - apply elem_of_dom. - apply elem_of_dom in Hdom as [f Heq]. exists f. - by apply map_lookup_filter_Some_2. - - eexists ζ', fs. by rewrite lookup_alter_ne. - Qed. - - Definition model_update_locale_fuel - (δ : LM) (ζ : locale Λ) (ρs : gset (fmrole M)) : LM := - model_update_decr ζ $ model_update_filter ζ ρs δ. - - Lemma model_update_locale_spec extr (auxtr : auxiliary_trace LM) ζ c2 ρs: - model_can_fuel_step (trace_last auxtr) ζ ((model_update_locale_fuel (trace_last auxtr) ζ) ρs) → - tids_smaller c2.1 (model_update_locale_fuel (trace_last auxtr) ζ ρs) → - valid_state_evolution_fairness - (extr :tr[Some ζ]: c2) - (auxtr :tr[Silent_step ζ]: - (model_update_locale_fuel (trace_last auxtr) ζ) ρs). - Proof. - intros Hstep Htids. destruct c2. - split; [done|]. split; [by apply model_can_fuel_step_trans|done]. - Qed. - - Definition map_disj (m : gmap (locale Λ) (gmap (fmrole M) nat)) := - ∀ ζ ζ' fs fs', ζ ≠ ζ' → m !! ζ = Some fs → m !! ζ' = Some fs' → fs ##ₘ fs'. - - Lemma decr_succ_compose_id : (λ f : nat, f - 1) ∘ S = id. - Proof. apply FunExt. intros x. simpl. lia. Qed. - - Definition map_inner_disj `{Countable K1} `{Countable K2} {V} - (m : gmap K1 (gmap K2 V)) := - ∀ (k1 k2 : K1) (vs1 vs2 : gmap K2 V), - k1 ≠ k2 → m !! k1 = Some vs1 → m !! k2 = Some vs2 → vs1 ##ₘ vs2. - - Lemma fuel_map_le_disj ζ1 ζ2 fm fs1 fs2 ρ - (fuel_map : gmap (locale Λ) (gmap (fmrole M) nat)) : - fuel_map_le_inner fm fuel_map → map_inner_disj fuel_map → - fm !! ζ1 = Some fs1 → fm !! ζ2 = Some fs2 → - ρ ∈ dom fs1 → ρ ∈ dom fs2 → - ζ1 = ζ2 ∧ fs1 = fs2. - Proof. - intros Hle Hdisj HSome1 HSome2 [f1 Hf1]%elem_of_dom [f2 Hf2]%elem_of_dom. - destruct (decide (ζ1 = ζ2)) as [->|Hneq]. - { simplify_eq. set_solver. } - rewrite /fuel_map_le_inner map_included_spec in Hle. - apply Hle in HSome1 as (fs1'&Hfs1'&Hle1). - apply Hle in HSome2 as (fs2'&Hfs2'&Hle2). - assert (ρ ∈ dom fs1') as [??]%elem_of_dom. - { apply elem_of_dom. rewrite map_included_spec in Hle1. - by apply Hle1 in Hf1 as (?&?&?). } - assert (ρ ∈ dom fs2') as [??]%elem_of_dom. - { apply elem_of_dom. rewrite map_included_spec in Hle2. - by apply Hle2 in Hf2 as (?&?&?). } - exfalso. rewrite /map_inner_disj in Hdisj. - specialize (Hdisj ζ1 ζ2 fs1' fs2' Hneq Hfs1' Hfs2'). - rewrite map_disjoint_spec in Hdisj. by eapply Hdisj. - Qed. - - Lemma fuel_map_le_disj' ζ1 ζ2 fm fs1 fs2 fs1' fs2' ρ - (fuel_map : gmap (locale Λ) (gmap (fmrole M) nat)) : - fuel_map_le_inner fm fuel_map → map_inner_disj fuel_map → - fm !! ζ1 = Some fs1 → fm !! ζ2 = Some fs2 → - fuel_map !! ζ1 = Some fs1' → fuel_map !! ζ2 = Some fs2' → - ρ ∈ dom fs1' → ρ ∈ dom fs2' → - ζ1 = ζ2 ∧ fs1 = fs2. - Proof. - intros Hle Hdisj HSome1 HSome2 HSome1' HSome2' - [f1 Hf1]%elem_of_dom [f2 Hf2]%elem_of_dom. - destruct (decide (ζ1 = ζ2)) as [->|Hneq]. - { simplify_eq. set_solver. } - rewrite /fuel_map_le_inner map_included_spec in Hle. - exfalso. rewrite /map_inner_disj in Hdisj. - specialize (Hdisj ζ1 ζ2 fs1' fs2' Hneq HSome1' HSome2'). - rewrite map_disjoint_spec in Hdisj. by eapply Hdisj. - Qed. - - (* TODO: Clean up *) - Lemma fuel_map_le_live_roles fm fm' (lρs : gset (fmrole M)) ζ ρs ρs' ρ : - map_inner_disj fm' → fuel_map_le_inner fm fm' → - fuel_map_preserve_dead fm lρs → - fm !! ζ = Some ρs → fm' !! ζ = Some ρs' → - ρ ∈ lρs → ρ ∈ dom ρs' → - ρ ∈ dom ρs. - Proof. - intros Hdisj Hfmle Hfmdead Hρ Hρs' Hlive [f Hf]%elem_of_dom. - rewrite /fuel_map_le_inner map_included_spec in Hfmle. - apply Hfmdead in Hlive as (ζ'&fs'&Hfs'&Hv2'). - assert (dom ρs = dom fs') as Heq. - { f_equiv. pose proof Hfs' as Hfs''. apply Hfmle in Hfs'' as (fs''&?&Hfs''). - eapply (fuel_map_le_disj' ζ ζ' fm ρs fs' ρs' fs'' ρ - fm'); try done. - - rewrite /fuel_map_le_inner map_included_spec. apply Hfmle. - - by apply elem_of_dom. - - rewrite map_included_spec in Hfs''. - apply elem_of_dom in Hv2' as [??]. - apply Hfs'' in H1. destruct H1 as (?&?&?). - by apply elem_of_dom. } - set_solver. - Qed. - - Lemma model_state_interp_can_fuel_step es δ ζ fs : - fs ≠ ∅ → model_state_interp es δ -∗ has_fuels_S ζ fs -∗ - ⌜model_can_fuel_step δ ζ ((model_update_locale_fuel δ ζ) (dom fs))⌝. - Proof. - iIntros (Hfs) "Hm Hfs". - iDestruct "Hm" as (fm Hfmle Hfmdead Htp) "(Hm & Hfm)". - rewrite /model_can_fuel_step. - iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. - rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. - pose proof Hagree as Hagree'. - apply Hfmle in Hagree as [v2 [HSome Hle]]. - iPureIntro. - exists v2. exists (model_update_locale_role_map δ (dom fs) v2). - repeat split; try done. - - simpl. rewrite -alter_compose. - rewrite -alter_insert. f_equiv; [done|by rewrite insert_id]. - - assert (dom fs ⊆ dom v2). - { erewrite <-dom_fmap_L. by eapply map_included_subseteq_inv. } - rewrite -dom_empty_iff_L. - rewrite -dom_empty_iff_L in Hfs. - set_solver. - - clear Htp Hfs. pose proof δ.(ls_map_disj) as Hdisj. - apply map_included_spec. - rewrite map_included_spec in Hle. - intros k v1 Hv2. - rewrite /model_update_locale_role_map lookup_fmap in Hv2. - apply fmap_Some in Hv2 as [? [Hv2 ->]]. - pose proof Hv2 as Hv2'%map_lookup_filter_Some_1_2. - apply map_lookup_filter_Some_1_1 in Hv2. - assert (k ∈ dom fs) as Hv2''. - { destruct Hv2' as [Hv2'|Hv2']; [|done]. - rewrite -(dom_fmap_L S fs). - eapply (fuel_map_le_live_roles _ δ.(ls_map)); [| |done..|]. - - intros ???????. eapply Hdisj; try done. - - rewrite /fuel_map_le_inner map_included_spec. apply Hfmle. - - by apply elem_of_dom. } - rewrite -(dom_fmap_L S) in Hv2''. - apply elem_of_dom in Hv2'' as [f Heq]. - pose proof Heq as Heq'. - apply lookup_fmap_Some in Heq' as [f' [<- _]]. - apply Hle in Heq as [f'' [Heq Hle']]. - exists f''. split; [done|]. - destruct f''; [lia|]. - simplify_eq. lia. - - rewrite /model_update_locale_role_map. - simpl. - rewrite dom_fmap_L. - clear. - induction v2 using map_ind. - { set_solver. } - rewrite /filter_fuel_map. - rewrite map_filter_insert. simpl. - case_decide. - + set_solver. - + rewrite -dom_difference_L. - rewrite map_filter_delete. - rewrite -insert_difference. - set_solver. - Qed. - - Lemma fuel_map_le_fuel_step fm ζ fs (δ:LM) : - fm !! ζ = Some (S <$> fs) → - fuel_map_le fm (ls_map δ) → - fuel_map_le (<[ζ:=fs]> fm) (ls_map (model_update_locale_fuel δ ζ (dom fs))). - Proof. - intros Hagree [Hfmle Hfmdom]. - split; [|by apply elem_of_dom_2 in Hagree; set_solver]. - rewrite /model_update_locale_fuel=> /=. - pose proof Hfmle as Hfmle'. rewrite /fuel_map_le_inner map_included_spec in Hfmle'. - apply Hfmle' in Hagree as [ρs [HSome Hρs]]. - rewrite -(insert_id (ls_map δ) ζ ρs); [|done]. - rewrite -alter_compose alter_insert=> /=. - apply map_included_insert; [|done]. - (* OBS: The remaining proof can likely be decomposed into library lemmas *) - clear Hfmle Hfmle' HSome Hfmdom. - apply map_included_spec. - intros ρ f1 Hρ. - rewrite map_included_spec in Hρs. - assert ((S <$> fs) !! ρ = Some (S f1)) as Hρ'; [by rewrite lookup_fmap Hρ|]. - specialize (Hρs ρ (S f1) Hρ') as [v2 [Hv2 Hle]]. - destruct v2; [lia|]. exists v2. split; [|lia]. - rewrite !lookup_fmap. - erewrite map_lookup_filter_Some_2; [|done|]; first by simpl; f_equal; lia. - simpl. - destruct (decide (ρ ∈ live_roles M δ ∨ ρ ∈ dom fs)) - as [Hin|Hnin]; first done. - apply Decidable.not_or in Hnin. destruct Hnin as [Hnin1 Hnin2]. - apply not_elem_of_dom in Hnin2. set_solver. - Qed. - - Lemma fuel_map_preserve_dead_fuel_step fm ζ fs (δ:LM) : - fm !! ζ = Some (S <$> fs) → - fuel_map_preserve_dead fm - (M.(live_roles) $ model_update_locale_fuel δ ζ (dom fs)) → - fuel_map_preserve_dead (<[ζ:=fs]> fm) - (M.(live_roles) $ (model_update_locale_fuel δ ζ (dom fs))). - Proof. - intros Hagree Hfmdead ρ Hin. apply Hfmdead in Hin as (ζ'&ρs&HSome&Hρ). - destruct (decide (ζ = ζ')) as [<-|Hneq]. - + exists ζ, fs. rewrite lookup_insert. by set_solver. - + exists ζ', ρs. rewrite lookup_insert_ne; [by set_solver|done]. - Qed. - - Lemma fuel_map_preserve_threadpool_fuel_step - c1 ζ c2 (fm1 fm2 : gmap _ (gmap (fmrole M) nat)) : - dom fm1 = dom fm2 → locale_step c1 (Some ζ) c2 → - fuel_map_preserve_threadpool c1.1 fm1 → - fuel_map_preserve_threadpool c2.1 fm2. - Proof. - rewrite /fuel_map_preserve_threadpool. - intros Hdom Hstep Htp. intros ζ' Hζ'. destruct c1, c2. - apply locales_of_list_step_incl in Hstep. - assert (ζ' ∉ locales_of_list l) as Hζ'' by set_solver. - apply Htp in Hζ''. - rewrite -not_elem_of_dom. rewrite -not_elem_of_dom in Hζ''. - set_solver. - Qed. - - Lemma model_state_interp_fuel_update c1 c2 δ ζ fs : - locale_step c1 (Some ζ) c2 → - model_state_interp c1.1 δ -∗ - has_fuels_S ζ fs ==∗ - model_state_interp c2.1 (model_update_locale_fuel δ ζ (dom fs)) ∗ - has_fuels ζ fs. - Proof. - iIntros (Hstep) "Hm Hfs". - iDestruct "Hm" as (fm Hfmle Hfmdead Htp) "(Hm & Hfm)". - iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. - iMod (has_fuels_decr with "Hfm Hfs") as "[Hfm $]". - iModIntro. iExists _. iFrame. iPureIntro. - split; [|split]. - - by apply fuel_map_le_fuel_step. - - by apply fuel_map_preserve_dead_fuel_step. - - eapply fuel_map_preserve_threadpool_fuel_step; [|done..]. - apply elem_of_dom_2 in Hagree. by set_solver. - Qed. - - Lemma update_fuel_step extr (auxtr : auxiliary_trace LM) c2 fs ζ : - fs ≠ ∅ → - locale_step (trace_last extr) (Some ζ) c2 → - has_fuels_S ζ fs -∗ - model_state_interp (trace_last extr).1 (trace_last auxtr) ==∗ - ∃ δ2, - ⌜ valid_state_evolution_fairness - (extr :tr[Some ζ]: c2) (auxtr :tr[Silent_step ζ]: δ2) ⌝ ∗ - has_fuels ζ fs ∗ model_state_interp c2.1 δ2. - Proof. - iIntros (Hdom Hstep) "Hfuel Hm". - iExists (model_update_locale_fuel (trace_last auxtr) ζ (dom fs)). - iDestruct (model_state_interp_can_fuel_step with "Hm Hfuel") as %Hcan_step; - [done|]. - iMod (model_state_interp_fuel_update with "Hm Hfuel") as "[Hm Hfuel]"; - [done..|]. - iDestruct (model_state_interp_tids_smaller with "Hm") as %Htids. - iModIntro. - iFrame "Hm Hfuel". - iPureIntro. by apply model_update_locale_spec. - Qed. - - (** Model step *) - - (* OBS: Maybe use fuel limit instead of generic [f] *) - Program Definition model_update_set (ζ : locale Λ) (ρ : fmrole M) (f : nat) (δ : LM) : LM := - {| - ls_data := - {| ls_under := δ.(ls_under); - ls_map := alter (alter (λ _, f) ρ) ζ δ.(ls_map); |}; - |}. - Next Obligation. - intros ζ ρ f δ ζ1 ζ2 fs1 fs2 Hneq HSome1 HSome2. simpl in *. - pose proof (δ.(ls_map_disj)) as Hdisj. - apply lookup_alter_Some in HSome1. - apply lookup_alter_Some in HSome2. - destruct HSome1 as [[-> [fs1' [HSome1 ->]]]|[_ HSome1]], - HSome2 as [[-> [fs2' [HSome2 ->]]]|[_ HSome2]]; - [done| | |]. - - specialize (Hdisj ζ1 ζ2 _ _ Hneq HSome1 HSome2). - rewrite map_disjoint_dom dom_alter_L. - rewrite map_disjoint_dom in Hdisj. set_solver. - - specialize (Hdisj ζ1 ζ2 _ _ Hneq HSome1 HSome2). - rewrite map_disjoint_dom dom_alter_L. - rewrite map_disjoint_dom in Hdisj. set_solver. - - by eapply Hdisj. - Qed. - Next Obligation. - intros ζ ρ f δ ρ' Hρ'. simpl in *. - pose proof (δ.(ls_map_live)) as Hlive. - apply Hlive in Hρ' as (ζ'&fs'&HSome&Hρ'). - destruct (decide (ζ = ζ')) as [<-|Hneq]. - - eexists ζ, _. rewrite lookup_alter HSome. split; [done|]. - by rewrite dom_alter_L. - - eexists ζ', _. by rewrite lookup_alter_ne. - Qed. - - Definition model_update_state (δ2 : M) (δ1 : LiveStateData Λ M) : - LiveStateData Λ M := - {| ls_under := δ2; - ls_map := δ1.(ls_map); |}. - - Lemma model_update_state_valid (δ2 : M) (δ1 : LM) : - M.(live_roles) δ2 ⊆ M.(live_roles) δ1 → - ∃ δ, (ls_data δ) = model_update_state δ2 δ1. - Proof. - intros Hle. - assert (∀ ζ ζ' fs fs', - ζ ≠ ζ' → (model_update_state δ2 δ1).(ls_map) !! ζ = Some fs → - (model_update_state δ2 δ1).(ls_map) !! ζ' = Some fs' → fs ##ₘ fs') as Hdisj'. - { intros. by eapply (δ1.(ls_map_disj)). } - assert (∀ ρ, ρ ∈ M.(live_roles) (model_update_state δ2 δ1).(ls_under) → - ∃ ζ fs, (model_update_state δ2 δ1).(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs) as Hlive'. - { pose proof (δ1.(ls_map_live)) as Hlive. - intros. - assert (ρ ∈ live_roles M δ1) as Hin by set_solver. - apply Hlive in Hin as (?&?&?&?). eexists _, _. done. } - exists - {| ls_data := model_update_state δ2 δ1; - ls_map_disj := Hdisj'; - ls_map_live := Hlive' |}. - done. - Qed. - - Definition model_update_model_step - (ζ : locale Λ) (ρs : gset (fmrole M)) ρ (δ2 : M) (δ : LM) : M := - model_update_state δ2 $ model_update_set ζ ρ (LM.(lm_fl) δ2) $ model_update_decr ζ $ model_update_filter ζ ρs δ. - - Lemma model_update_model_step_valid (ζ : locale Λ) (ρs : gset (fmrole M)) ρ (s2 : M) (δ1:LM) : - M.(live_roles) s2 ⊆ M.(live_roles) (ls_under δ1) → - ∃ δ, (ls_data δ) = model_update_model_step ζ ρs ρ s2 δ1. - Proof. intros. by apply model_update_state_valid. Qed. - - Lemma model_update s1 s2 s3 : - auth_model_is s1 -∗ frag_model_is s2 ==∗ - auth_model_is s3 ∗ frag_model_is s3. - Proof. - iIntros "Hauth Hfrag". - iMod (own_update_2 with "Hauth Hfrag") as "[$ $]"; [|done]. - apply auth_update. apply option_local_update. - by eapply exclusive_local_update. - Qed. - - Lemma alter_insert_alt `{Countable K} {A} (m : gmap K A) i f x : - m !! i = Some x → alter f i m = <[i := f x]> m. - Proof. - intros. rewrite -{1}(insert_id m i x); [|done]. apply alter_insert. - Qed. - - (* OBS: Need to make frag model abstract *) - Lemma model_state_interp_model_step_update (ρ : fmrole M) - (fs : gmap (fmrole M) nat) tp1 tp2 - (δ δ2 : LM) ζ σ1 σ2 (f1 : nat) s1 s2 : - ρ ∉ dom fs → - live_roles M s2 ⊆ live_roles M s1 → - locale_step (tp1, σ1) (Some ζ) (tp2, σ2) → - fmtrans _ s1 (Some ρ) s2 → - (ls_data δ2) = model_update_model_step ζ ({[ρ]} ∪ dom fs) ρ s2 δ → - model_state_interp tp1 δ -∗ - has_fuels ζ ({[ρ := f1]} ∪ (S <$> fs)) -∗ - frag_model_is s1 ==∗ - model_state_interp tp2 δ2 ∗ - has_fuels ζ ({[ρ := LM.(lm_fl) s2]} ∪ fs) ∗ - frag_model_is s2. - Proof. - iIntros (Hfs Hlive Hstep Hmstep Hδ2) "Hm Hf Hs". - iDestruct "Hm" as (fm Hfmle Hfmdead Htp) "(Hm & Hfm)". - iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. - iMod (has_fuels_update _ _ _ ({[ρ := lm_fl LM s2]} ∪ fs) with "Hfm Hf") - as "[Hfm Hf]". - iDestruct (model_agree with "Hm Hs") as %<-. - iMod (model_update _ _ s2 with "Hm Hs") as "[Hm Hs]". - iModIntro. iFrame. - rewrite Hδ2. iFrame. - iPureIntro. - split; [|split]. - - split; last first. - { simpl. - destruct Hfmle as [Hfmle Hdom]. - pose proof Hfmle as Hfmle'. - rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. - pose proof Hagree as Hagree'. - apply Hfmle in Hagree' as (fs'&HSome&Hfs'). - rewrite -(insert_id (ls_map δ) ζ fs'); [|done]. - rewrite !alter_insert. - set_solver. } - simpl. - destruct Hfmle as [Hfmle Hdom]. - pose proof Hfmle as Hfmle'. - rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. - pose proof Hagree as Hagree'. - apply Hfmle in Hagree' as (fs'&HSome&Hfs'). - rewrite -(insert_id (ls_map δ) ζ fs'); [|done]. - rewrite !alter_insert. - apply map_included_insert; [|done]. - assert ({[ρ := lm_fl LM s2]} ∪ fs = - (alter (λ _ : nat, lm_fl LM s2) ρ - ((λ f : nat, f - 1) <$> - (filter - (λ ρf : fmrole M * nat, ρf.1 ∈ live_roles M δ ∨ ρf.1 ∈ {[ρ]} ∪ dom fs) - ({[ρ := f1]} ∪ (S <$> fs)))))) as ->. - { rewrite -!insert_union_singleton_l. - rewrite map_filter_insert. simpl. - case_decide; [|set_solver]. - rewrite fmap_insert. rewrite alter_insert. f_equiv. - rewrite map_filter_fmap. - rewrite -map_fmap_compose. - rewrite decr_succ_compose_id. - rewrite map_fmap_id. - rewrite map_filter_id; [done|]. - intros i x Hin. apply elem_of_dom_2 in Hin. set_solver. } - apply map_included_mono_strong; [set_solver..| |]. - { intros k x1 x2 y1 y2 Hx1 Hx2 Hy1 Hy2 HR. - destruct (decide (k = ρ)) as [->|Hneq]. - - erewrite alter_insert_alt in Hy1; [|done]. - erewrite alter_insert_alt in Hy2; [|done]. - rewrite lookup_insert in Hy1. - rewrite lookup_insert in Hy2. by simplify_eq. - - rewrite lookup_alter_ne in Hy1; [|done]. - rewrite lookup_alter_ne in Hy2; [|done]. - by simplify_eq. } - apply map_included_mono_strong; [set_solver..| |]. - { intros k x1 x2 y1 y2 Hx1 Hx2 Hy1 Hy2 HR. - apply lookup_fmap_Some in Hy1 as (y1'&Hy1'&Hy1). - apply lookup_fmap_Some in Hy2 as (y2'&Hy2'&Hy2). - simplify_eq. lia. } - apply map_included_filter; [set_solver..|]. - done. - - apply elem_of_subseteq in Hlive. - intros ρ' Hin. - apply Hlive in Hin. - apply Hfmdead in Hin as (ζ'&ρs&HSome&Hρ). - destruct (decide (ζ = ζ')) as [<-|Hneq]. - + eexists ζ, _. rewrite lookup_insert. split; [done|]. by set_solver. - + eexists ζ', _. rewrite lookup_insert_ne; [|done]. - split; [done|]. by set_solver. - - rewrite /fuel_map_preserve_threadpool. - intros ζ' Hζ'. - apply locales_of_list_step_incl in Hstep. - assert (ζ' ∉ locales_of_list tp1) as Hζ'' by set_solver. - apply Htp in Hζ''. - rewrite -not_elem_of_dom. rewrite -not_elem_of_dom in Hζ''. - rewrite dom_insert_L. - rewrite -(insert_id fm ζ ({[ρ := f1]} ∪ (S <$> fs))) in Hζ''; [|done]. - rewrite dom_insert_L in Hζ''. - set_solver. - Qed. - - Lemma model_step_suff_data_weak_alt (δ1 δ2 : LiveState Λ M) ρ - (fs fs': gmap _ nat) ζ : - fmtrans _ δ1 (Some ρ) δ2 → - M.(live_roles) δ2 ⊆ M.(live_roles) δ1 → - δ1.(ls_map) !! ζ = Some fs → - δ2.(ls_map) = <[ζ := fs']> δ1.(ls_map) → - ρ ∈ dom fs → - fs' !! ρ = Some (LM.(lm_fl) (ls_under δ2)) → - map_included (<) (delete ρ fs') fs → - (dom fs ∖ dom fs' ∩ M.(live_roles) δ1 = ∅) → - ls_trans LM.(lm_fl) δ1 (Take_step ρ ζ) δ2. - Proof. - intros Hstep Hlive Hfs Hfs' Hρ Hρ' Hlt Hlive'. - assert (∃ (δ'':LiveState Λ M), δ''.(ls_data) = - {| ls_under := ls_under δ2; - ls_map := <[ζ := fs']> δ1.(ls_map) |} ∧ - ls_trans LM.(lm_fl) δ1 (Take_step ρ ζ) δ'') as (δ''&Heq&Htrans). - { eapply (model_step_suff_data); try done. - - rewrite map_included_spec in Hlt. - intros ρ' f f' Hf' Hneq Hf. - rewrite -(lookup_delete_ne _ ρ ρ') in Hf'; [|done]. - apply Hlt in Hf' as (?&?&?). by simplify_eq. - - set_solver. - - apply map_included_subseteq_inv in Hlt. set_solver. - - apply map_included_subseteq_inv in Hlt. set_solver. - - set_solver. } - rewrite Heq -Hfs' in Htrans. by destruct δ2, ls_data. - Qed. - - Definition model_can_model_step (δ1 : LM) (ζ : locale Λ) (ρ : fmrole M) (δ2 : LM) : Prop := - ∃ (fs fs' : gmap (fmrole M) nat), - fmtrans _ δ1 (Some ρ) δ2 ∧ - M.(live_roles) δ2 ⊆ M.(live_roles) δ1 ∧ - δ1.(ls_map) !! ζ = Some fs ∧ - δ2.(ls_map) = <[ζ := fs']> δ1.(ls_map) ∧ - ρ ∈ dom fs ∧ - fs' !! ρ = Some (LM.(lm_fl) (ls_under δ2)) ∧ - map_included (<) (delete ρ fs') fs ∧ - (dom fs ∖ dom fs' ∩ M.(live_roles) δ1 = ∅). - - Lemma model_can_model_step_trans ζ ρ (δ δ' : LiveState Λ M) : - model_can_model_step δ ζ ρ δ' → ls_trans (LM.(lm_fl)) δ (Take_step ρ ζ) δ'. - Proof. - destruct 1 as (?&?&?&?&?&?&?&?&?&?). - by eapply model_step_suff_data_weak_alt. - Qed. - - Lemma model_state_interp_can_model_step es (δ δ2 : LM) ζ ρ f - (fs : gmap (fmrole M) nat) (s1 s2 : M) : - fmtrans _ s1 (Some ρ) s2 → - M.(live_roles) s2 ⊆ M.(live_roles) s1 → - ρ ∉ dom fs → - (ls_data δ2) = model_update_model_step ζ ({[ρ]} ∪ dom fs) ρ s2 δ → - model_state_interp es δ -∗ - has_fuels ζ ({[ρ := f]} ∪ (S <$> fs)) -∗ - frag_model_is s1 -∗ - ⌜model_can_model_step δ ζ ρ δ2⌝. - Proof. - iIntros (Hstep Hle Hρ Hδ2) "Hm Hf Hδ". - iDestruct "Hm" as (fm Hfmle Hfmdead Htp) "(Hm & Hfm)". - iDestruct (model_agree with "Hm Hδ") as %<-. - iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. - iPureIntro. - rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. - pose proof Hagree as Hagree'. - apply Hfmle in Hagree as (fs'&Hζ&Hfs'). - assert (ρ ∈ dom fs') as Hρ'. - { apply map_included_subseteq_inv in Hfs'. set_solver. } - eexists _, _. repeat split; try done. - - by rewrite Hδ2. - - by rewrite Hδ2. - - rewrite Hδ2. simpl. rewrite -!alter_compose. - rewrite -{1}(insert_id (ls_map δ) ζ fs'); [|done]. - rewrite alter_insert. - f_equiv. - done. - - rewrite Hδ2. simpl. rewrite lookup_alter. rewrite lookup_fmap. - apply elem_of_dom in Hρ' as [f' Heq]. - apply fmap_Some; eexists; split; last done. - apply fmap_Some; eexists; split; last done. - apply map_lookup_filter_Some_2; first done. - right; set_solver. - - rewrite map_included_spec. - intros ρ' f' HSome. - assert (ρ ≠ ρ'). - { intros Heq. rewrite Heq in HSome. - by rewrite lookup_delete in HSome. } - rewrite lookup_delete_ne in HSome; [|done]. - exists (f' + 1). - split; [|lia]. - simpl in *. - rewrite lookup_alter_ne in HSome; [|done]. - rewrite lookup_fmap in HSome. - rewrite map_lookup_filter in HSome. simpl in *. - destruct (fs' !! ρ') eqn:Heqn; [|done]. - simpl in *. - destruct (decide (ρ' ∈ live_roles M δ ∨ ρ' ∈ {[ρ]} ∪ dom fs)) as [Hin|Hnin]. - + rewrite option_guard_True in HSome; [|done]. - simpl in *. simplify_eq. f_equiv. - assert (ρ' ∈ dom ({[ρ := f]} ∪ (S <$> fs))) as Hin'. - { destruct Hin as [Hin|Hin]; [|set_solver]. - eapply (fuel_map_le_live_roles _ δ.(ls_map)); [| |done..|]. - - intros ???????. by eapply δ.(ls_map_disj). - - rewrite /fuel_map_le_inner map_included_spec. apply Hfmle. - - by apply elem_of_dom. } - rewrite dom_union_L in Hin'. - apply elem_of_union in Hin' as [Hin'|Hin']; [set_solver|]. - apply elem_of_dom in Hin' as [v2 Hv2]. - rewrite map_included_spec in Hfs'. - specialize (Hfs' ρ' v2). - rewrite lookup_union_r in Hfs'; [|by rewrite lookup_insert_ne]. - destruct v2. - { apply lookup_fmap_Some in Hv2 as (?&?&?). lia. } - apply Hfs' in Hv2 as (n'&Hn'&Hn''). - simplify_eq. - lia. - + by rewrite option_guard_False in HSome. - - (* TODO: Make a lemma for this *) - simpl. - rewrite dom_alter_L. - rewrite dom_fmap_L. - clear. - induction fs' using map_ind. - { set_solver. } - rewrite /filter_fuel_map. - rewrite map_filter_insert. simpl. - case_decide. - + set_solver. - + rewrite -dom_difference_L. - rewrite map_filter_delete. - rewrite -insert_difference. - set_solver. - Qed. - - Lemma model_update_locale_spec_model_step extr - (auxtr : auxiliary_trace LM) ζ c2 ρs ρ δ2 s2 : - (ls_data δ2) = model_update_model_step ζ ({[ρ]} ∪ ρs) ρ s2 - (trace_last auxtr) → - model_can_model_step (trace_last auxtr) ζ ρ δ2 → - tids_smaller c2.1 δ2 → - valid_state_evolution_fairness - (extr :tr[Some ζ]: c2) - (auxtr :tr[Take_step ρ ζ]: δ2). - Proof. - intros Hstep Htids. destruct c2. - split; [done|]. split; [by apply model_can_model_step_trans|done]. - Qed. - - Lemma update_model_step - (extr : execution_trace Λ) - (auxtr: auxiliary_trace LM) c2 (s1 s2 : M) fs ρ (δ1 : LM) ζ f : - M.(live_roles) s2 ⊆ M.(live_roles) s1 → - ρ ∉ dom fs → - trace_last auxtr = δ1 → - locale_step (trace_last extr) (Some ζ) c2 → - fmtrans _ s1 (Some ρ) s2 → - has_fuels ζ ({[ρ := f]} ∪ (S <$> fs)) -∗ frag_model_is s1 -∗ - model_state_interp (trace_last extr).1 δ1 ==∗ - ∃ (δ2: LM), - ⌜valid_state_evolution_fairness - (extr :tr[Some ζ]: c2) (auxtr :tr[Take_step ρ ζ]: δ2)⌝ ∗ - has_fuels ζ ({[ρ := LM.(lm_fl) s2]} ∪ fs) ∗ - frag_model_is s2 ∗ model_state_interp c2.1 δ2. - Proof. - iIntros (Hlive Hdom Hlast Hstep Htrans) "Hfuel Hfrag Hm". - iDestruct (model_agree' with "Hm Hfrag") as %<-. - pose proof (model_update_model_step_valid - ζ ({[ρ]} ∪ dom fs) ρ s2 δ1) as [δ2 Hδ2]; [done|]. - iExists δ2. - iDestruct (model_state_interp_can_model_step with "Hm Hfuel Hfrag") - as %Hcan_step; [try done..|]. - destruct (trace_last extr), c2. - iMod (model_state_interp_model_step_update with "Hm Hfuel Hfrag") - as "(Hm&Hf&Hfrag)"; [done..|]. - iDestruct (model_state_interp_tids_smaller with "Hm") as %Htids. - iModIntro. - iFrame "Hm Hf Hfrag". - iPureIntro. subst. - by eapply model_update_locale_spec_model_step. - Qed. - - (** Fork step *) - - Definition has_forked (tp1 tp2 : list (expr Λ)) e : Prop := - ∃ tp1', tp2 = tp1' ++ [e] ∧ locales_equiv tp1 tp1'. - - Definition model_update_split - (ζ ζf : locale Λ) (ρs : gset (fmrole M)) - (δ : LiveStateData Λ M) : LiveStateData Λ M := - {| ls_under := δ.(ls_under); - ls_map := <[ζf := (filter (λ ρf, ρf.1 ∈ ρs)) (δ.(ls_map) !!! ζ)]> - (alter (filter (λ ρf, ρf.1 ∉ ρs)) ζ δ.(ls_map)); |}. - - Definition map_live (ρs : gset (fmrole M)) - (m : gmap (locale Λ) (gmap (fmrole M) nat)) : Prop := - ∀ ρ, ρ ∈ ρs → ∃ ζ fs, m !! ζ = Some fs ∧ ρ ∈ dom fs. - - Lemma disjoint_subseteq `{Countable A} (xs1 xs2 ys1 ys2 : gset A) : - xs1 ⊆ xs2 → ys1 ⊆ ys2 → xs2 ## ys2 → xs1 ## ys1. - Proof. - intros Hle1 Hle2 Hdisj x Hxs Hys. - eapply Hdisj; [by apply Hle1|by apply Hle2]. - Qed. - - Lemma disjoint_subseteq_l `{Countable A} (xs ys zs : gset A) : - xs ⊆ ys → ys ## zs → xs ## zs. - Proof. intros Hle Hdisj x Hxs Hzs. eapply Hdisj; [by apply Hle|done]. Qed. - - Lemma disjoint_subseteq_r `{Countable A} (xs ys zs : gset A) : - zs ⊆ ys → xs ## ys → xs ## zs. - Proof. intros Hle Hdisj x Hxs Hzs. eapply Hdisj; [done|by apply Hle]. Qed. - - Lemma model_update_split_valid ζ ζf ρs (δ1 : LM) : - ζ ∈ dom δ1.(ls_map) → ζf ∉ dom δ1.(ls_map) → - ∃ δ2, (ls_data δ2) = model_update_split ζ ζf ρs δ1. - Proof. - intros [ρs' HSome]%elem_of_dom Hnin. - set δ2 := model_update_split ζ ζf ρs δ1. - assert (ζ ≠ ζf) as Hneq. - { intros ->. apply not_elem_of_dom in Hnin. set_solver. } - assert (map_inner_disj δ2.(ls_map)) as Hdisj. - { simpl. - pose proof δ1.(ls_map_disj) as Hdisj. - intros ζ1 ζ2 ρs1 ρs2 Hneq' HSome1 HSome2. - destruct (decide (ζf = ζ1)) as [<-|Hneqf1]. - { rewrite lookup_insert in HSome1. - rewrite lookup_insert_ne in HSome2; [|done]. - rewrite lookup_total_alt in HSome1. - rewrite HSome in HSome1. - simpl in *. - destruct (decide (ζ = ζ2)) as [<-|Hneq2]. - { rewrite lookup_alter in HSome2. - rewrite HSome in HSome2. simpl in *. simplify_eq. - apply map_disjoint_dom. - pose proof (disjoint_filter_complement - (λ ρ : fmrole M, ρ ∈ ρs) (dom ρs')) as Hcomp. - by rewrite !filter_dom_L in Hcomp. } - rewrite lookup_alter_ne in HSome2; [|done]. - simplify_eq. - apply map_disjoint_dom. - pose proof (Hdisj ζ ζ2 _ _ Hneq2 HSome HSome2) as Hdisj. - apply map_disjoint_dom in Hdisj. - eapply disjoint_subseteq_l; [|done]. - apply dom_filter_subseteq. } - rewrite lookup_insert_ne in HSome1; [|done]. - destruct (decide (ζf = ζ2)) as [<-|Hneqf2]. - { rewrite lookup_insert in HSome2. - destruct (decide (ζ = ζ1)) as [<-|Hneq2]. - { rewrite lookup_alter in HSome1. - rewrite lookup_total_alt in HSome2. - rewrite HSome in HSome1. - rewrite HSome in HSome2. - simpl in *. simplify_eq. - apply map_disjoint_dom. - pose proof (disjoint_filter_complement - (λ ρ : fmrole M, ρ ∈ ρs) (dom ρs')) as Hcomp. - by rewrite !filter_dom_L in Hcomp. } - rewrite lookup_alter_ne in HSome1; [|done]. - rewrite lookup_total_alt in HSome2. - rewrite HSome in HSome2. - simpl in *. simplify_eq. - pose proof (Hdisj ζ ζ1 _ _ Hneq2 HSome HSome1) as Hdisj. - apply map_disjoint_dom. - apply map_disjoint_dom in Hdisj. - eapply disjoint_subseteq_r; [|done]. - apply dom_filter_subseteq. } - destruct (decide (ζ = ζ1)) as [<-|Hneq1]. - { rewrite lookup_alter in HSome1. - rewrite lookup_insert_ne in HSome2; [|done]. - rewrite lookup_alter_ne in HSome2; [|done]. - rewrite HSome in HSome1. - simpl in *. simplify_eq. - pose proof (Hdisj ζ ζ2 _ _ Hneq' HSome HSome2) as Hdisj. - apply map_disjoint_dom. - apply map_disjoint_dom in Hdisj. - eapply disjoint_subseteq_l; [|done]. - apply dom_filter_subseteq. } - destruct (decide (ζ = ζ2)) as [<-|Hneq2]. - { rewrite lookup_alter_ne in HSome1; [|done]. - rewrite lookup_insert_ne in HSome2; [|done]. - rewrite lookup_alter in HSome2. - rewrite HSome in HSome2. - simpl in *. simplify_eq. - pose proof (Hdisj ζ ζ1 _ _ Hneq1 HSome HSome1) as Hdisj. - apply map_disjoint_dom. - apply map_disjoint_dom in Hdisj. - eapply disjoint_subseteq_r; [|done]. - apply dom_filter_subseteq. } - rewrite lookup_alter_ne in HSome1; [|done]. - rewrite lookup_insert_ne in HSome2; [|done]. - rewrite lookup_alter_ne in HSome2; [|done]. - pose proof (Hdisj ζ1 ζ2 _ _ Hneq' HSome1 HSome2). - done. } - assert (map_live (M.(live_roles) δ2) δ2.(ls_map)) as Hlive. - { intros ρ Hin. - pose proof (δ1.(ls_map_live)) as Hlive. - apply Hlive in Hin as (ζ'&fs&HSome'&Hin'). - destruct (decide (ζ' = ζf)) as [->|Hneqf]. - { apply not_elem_of_dom in Hnin. set_solver. } - destruct (decide (ζ' = ζ)) as [->|Hneq']. - { rewrite HSome in HSome'. simplify_eq. - simpl. - destruct (decide (ρ ∈ ρs)) as [Hin|Hnin']. - - exists ζf, (filter (λ ρf : fmrole M * nat, ρf.1 ∈ ρs) fs). - rewrite lookup_insert. rewrite lookup_total_alt. rewrite HSome. simpl. - split; [done|]. - apply elem_of_dom. rewrite /is_Some. - apply elem_of_dom in Hin' as [??]. - eexists _. by apply map_lookup_filter_Some_2. - - exists ζ, (filter (λ ρf : fmrole M * nat, ρf.1 ∉ ρs) fs). - rewrite lookup_insert_ne; [|done]. - rewrite lookup_alter. rewrite HSome. simpl. - split; [done|]. - apply elem_of_dom. rewrite /is_Some. - apply elem_of_dom in Hin' as [??]. - eexists _. by apply map_lookup_filter_Some_2. } - exists ζ', fs. split; [|done]. - simpl. rewrite !lookup_insert_ne; [|done]. - rewrite lookup_alter_ne; [|done]. - done. } - by exists - {| ls_data := δ2; - ls_map_disj := Hdisj; - ls_map_live := Hlive |}. - Qed. - - Definition model_update_fork - (ζ : locale Λ) (ζf : locale Λ) - (ρs1 ρs2 : gset (fmrole M)) (δ : LM) : - LiveStateData Λ M := - model_update_split ζ ζf ρs2 $ - model_update_decr ζ $ - model_update_filter ζ ρs1 δ. - - Lemma model_update_fork_valid - ζ ζf (ρs1 ρs2 : gset (fmrole M)) (δ1 : LM) : - ζ ∈ dom δ1.(ls_map) → ζf ∉ dom δ1.(ls_map) → - ∃ δ2, (ls_data δ2) = model_update_fork ζ ζf ρs1 ρs2 δ1. - Proof. intros ??. by apply model_update_split_valid; set_solver. Qed. - - Lemma has_fuels_alloc fm ζ fs : - ζ ∉ dom fm → - auth_fuel_mapping_is fm ==∗ - auth_fuel_mapping_is (<[ζ := fs]>fm) ∗ has_fuels ζ fs. - Proof. - iIntros (Hnin) "Hfm". - rewrite /has_fuels_S. - iMod (own_update with "Hfm") as "[$ $]"; [|done]. - apply auth_update_alloc. - rewrite !fmap_insert. - rewrite !fmap_empty. - eapply alloc_local_update; [|done]. - apply not_elem_of_dom in Hnin. by rewrite lookup_fmap Hnin. - Qed. - - Lemma has_fuels_split fm ζ ζf fs1 fs2 : - ζf ∉ dom fm → fs1 ##ₘ fs2 → - auth_fuel_mapping_is fm -∗ has_fuels ζ (fs1 ∪ fs2) ==∗ - auth_fuel_mapping_is (<[ζf := fs2]>(<[ζ := fs1]>fm)) ∗ - has_fuels ζ fs1 ∗ has_fuels ζf fs2. - Proof. - iIntros (Hnin Hdisj) "Hfm Hfs". - iDestruct (has_fuels_agree with "Hfm Hfs") as %HSome. - assert (ζ ≠ ζf) as Hneq. - { rewrite not_elem_of_dom in Hnin. set_solver. } - iMod (has_fuels_update with "Hfm Hfs") as "[Hfm $]". - iMod (has_fuels_alloc with "Hfm") as "[$$]"; set_solver. - Qed. - - Lemma not_elem_of_locale_of_from_list (tp : list $ expr Λ) e : - locale_of tp e ∉ locales_of_list tp. - Proof. - unfold locales_of_list_from. - intros Habs. - apply elem_of_list_fmap in Habs as ((tp1&e1) & Hlo & Hpf). - apply prefixes_from_spec in Hpf as (tp2&tp3&He1&He2). - simplify_eq. - list_simplifier. - - have Hdone: (tp2 ++ e1 :: tp3, e) ∈ prefixes_from (tp2++[e1]) (tp3 ++ [e]). - { apply prefixes_from_spec. eexists _, _. list_simplifier. naive_solver. } - by apply locale_injective in Hdone. - Qed. - - Lemma elem_of_locale_of_from_list (tp1 tp2 : list $ expr Λ) e : - locales_equiv tp1 tp2 → - locale_of tp1 e ∈ locales_of_list (tp2++[e]). - Proof. - intros Heq. rewrite (locale_equiv _ _ _ Heq) /locales_of_list_from. - apply elem_of_list_fmap. exists (tp2, e). split=>//. - apply prefixes_from_spec. eexists _, _. list_simplifier. naive_solver. - Qed. - - Lemma model_state_interp_fork_update fs1 fs2 tp1 tp2 - (δ1 δ2 : LM) ζ efork σ1 σ2 : - (ls_data δ2) = model_update_fork ζ (locale_of tp1 efork) (dom fs1 ∪ dom fs2) (dom fs2) δ1 → - fs1 ∪ fs2 ≠ ∅ → fs1 ##ₘ fs2 → - has_forked tp1 tp2 efork → - locale_step (tp1, σ1) (Some ζ) (tp2, σ2) → - model_state_interp tp1 δ1 -∗ - has_fuels_S ζ (fs1 ∪ fs2) ==∗ - model_state_interp tp2 δ2 ∗ - has_fuels ζ fs1 ∗ - has_fuels (locale_of tp1 efork) fs2. - Proof. - iIntros (Hδ2 Hfs Hdisj Hforked Hstep) "Hm Hf". - iDestruct "Hm" as (fm Hfmle Hfmdead Htp) "(Hm & Hfm)". - iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. - assert (locale_of tp1 efork ∉ dom fm) as Hnin. - { pose proof (not_elem_of_locale_of_from_list tp1 efork) as Hes%Htp. - apply not_elem_of_dom in Hes. set_solver. } - assert (ζ ≠ locale_of tp1 efork) as Hneq. - { rewrite not_elem_of_dom in Hnin. set_solver. } - iMod (has_fuels_decr with "Hfm Hf") as "[Hfm Hf]". - iMod (has_fuels_split _ _ (locale_of tp1 efork) with "Hfm Hf") - as "[Hfm [Hf1 Hf2]]"; [|done|]. - { set_solver. } - iModIntro. iFrame. rewrite Hδ2. iFrame. - iPureIntro. - split; [|split]. - - split; last first. - { simpl. - destruct Hfmle as [Hfmle Hdom]. - pose proof Hfmle as Hfmle'. - rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. - pose proof Hagree as Hagree'. - apply Hfmle in Hagree' as (fs'&HSome&Hfs'). - rewrite -(insert_id (ls_map δ1) ζ fs'); [|done]. - rewrite !alter_insert. - set_solver. } - simpl. - destruct Hfmle as [Hfmle Hdom]. - pose proof Hfmle as Hfmle'. - rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. - pose proof Hagree as Hagree'. - apply Hfmle in Hagree' as (fs'&HSome&Hfs'). - rewrite -(insert_id (ls_map δ1) ζ fs'); [|done]. - rewrite !alter_insert. - rewrite insert_insert. - - apply map_included_map_agree_R in Hfs' - as (fs12'&fsf'&->&Hdisj'&Hfs'). - pose proof Hfs' as Hfs''. - apply map_agree_R_fmap_inv in Hfs'' as [fs1'' ->]; last first. - { intros ?[]?; [lia|by eauto]. } - apply map_agree_R_fmap in Hfs'; last first. - { intros. lia. } - apply map_agree_R_union_inv in Hfs' - as (fs1'&fs2'&->&Hfs1'&Hfs2'); [|done]. - - apply map_included_insert. - { rewrite lookup_total_alt. - rewrite lookup_insert. - rewrite map_filter_fmap. - rewrite map_filter_filter. - rewrite map_fmap_union. - rewrite map_filter_union; last first. - { apply map_disjoint_dom. apply map_disjoint_dom in Hdisj'. - set_solver. } - rewrite map_filter_union; last first. - { apply map_disjoint_dom. apply map_disjoint_dom in Hdisj. - apply map_agree_R_dom in Hfs1'. - apply map_agree_R_dom in Hfs2'. - set_solver. } - rewrite !map_fmap_union. - eapply map_included_subseteq_r. - { apply map_union_subseteq_l. } - eapply map_included_subseteq_r. - { apply map_union_subseteq_r. - apply map_disjoint_dom. - rewrite !map_filter_fmap. rewrite !dom_fmap_L. - apply map_disjoint_dom in Hdisj. - apply map_agree_R_dom in Hfs1'. - apply map_agree_R_dom in Hfs2'. - eapply disjoint_subseteq_l; [apply dom_filter_subseteq|]. - eapply disjoint_subseteq_r; [apply dom_filter_subseteq|]. - set_solver. } - rewrite map_filter_id; last first. - { simpl. - intros. apply elem_of_dom_2 in H0. - apply map_agree_R_dom in Hfs1'. - apply map_agree_R_dom in Hfs2'. - split; [set_solver|]. - set_solver. } - rewrite -map_fmap_compose. - rewrite decr_succ_compose_id. rewrite map_fmap_id. - by apply map_agree_R_map_included. } - - apply map_included_insert; [|done]. - rewrite map_filter_fmap. - rewrite map_filter_filter. - - rewrite !map_fmap_union. - rewrite map_filter_union; last first. - { apply map_disjoint_dom. apply map_disjoint_dom in Hdisj'. - set_solver. } - rewrite map_filter_union; last first. - { apply map_disjoint_dom. apply map_disjoint_dom in Hdisj. - apply map_agree_R_dom in Hfs1'. - apply map_agree_R_dom in Hfs2'. - set_solver. } - rewrite !map_fmap_union. - eapply map_included_subseteq_r. - { apply map_union_subseteq_l. } - eapply map_included_subseteq_r. - { apply map_union_subseteq_l. } - - rewrite map_filter_id; last first. - { simpl. - intros. apply elem_of_dom_2 in H0. - apply map_agree_R_dom in Hfs1'. - apply map_agree_R_dom in Hfs2'. - rewrite dom_fmap in H0. - apply map_disjoint_dom in Hdisj. - split; [set_solver|]. - set_solver. } - rewrite -map_fmap_compose. - rewrite decr_succ_compose_id. rewrite map_fmap_id. - by apply map_agree_R_map_included. - - intros ρ' Hin. - apply Hfmdead in Hin as (ζ'&ρs&HSome&Hρ). - destruct (decide (ζ = ζ')) as [<-|Hneq']. - + rewrite Hagree in HSome. - simplify_eq. - rewrite dom_fmap_L in Hρ. - rewrite dom_union_L in Hρ. - apply elem_of_union in Hρ. - destruct Hρ as [Hρ|Hρ]. - * eexists ζ, _. rewrite insert_insert. - rewrite insert_commute; [|done]. - rewrite lookup_insert. done. - * eexists (locale_of tp1 efork), _. rewrite insert_insert. - rewrite lookup_insert. done. - + assert (ζ' ≠ locale_of tp1 efork) as Hneq''. - { intros ->. apply not_elem_of_dom in Hnin. set_solver. } - eexists ζ', _. - rewrite lookup_insert_ne; [|done]. - rewrite insert_insert. - rewrite lookup_insert_ne; [|done]. - split; [done|]. by set_solver. - - rewrite /fuel_map_preserve_threadpool. - intros ζ' Hζ'. - apply locales_of_list_step_incl in Hstep. - assert (ζ' ∉ locales_of_list tp1) as Hζ'' by set_solver. - apply Htp in Hζ''. - rewrite insert_insert. - assert (ζ ≠ ζ') as Hneq'. - { set_solver. } - assert (locale_of tp1 efork ≠ ζ') as Hneq''. - { assert (locale_of tp1 efork ∈ locales_of_list tp2). - { destruct Hforked as [tp2' [-> Hequiv]]. - by apply elem_of_locale_of_from_list. } - set_solver. } - rewrite lookup_insert_ne; [|done]. - rewrite lookup_insert_ne; [|done]. - done. - Qed. - - Definition model_can_fork_step (δ1 : LM) (ζ ζf : locale Λ) (δ2 : LM) : Prop := - ∃ fs fs1 fs2, - δ1.(ls_under) = δ2.(ls_under) ∧ - δ1.(ls_map) !! ζ = Some fs ∧ fs ≠ ∅ ∧ - δ2.(ls_map) = <[ζ := fs1]>(<[ζf := fs2]> δ1.(ls_map)) ∧ - map_included (<) fs1 fs ∧ - map_included (<) fs2 fs ∧ - (dom fs ∖ (dom fs1 ∪ dom fs2) ∩ M.(live_roles) δ1 = ∅) ∧ - (dom fs1 ∩ dom fs2 = ∅) ∧ - ζf ∉ dom δ1.(ls_map). - - Lemma silent_step_suff_data_fork_weak fl `(δ: LiveState Λ M) - (fs fs1 fs2 : gmap _ nat) ζ ζf : - δ.(ls_map) !! ζ = Some fs → - fs ≠ ∅ → - map_included (<) fs1 fs → - map_included (<) fs2 fs → - (dom fs ∖ (dom fs1 ∪ dom fs2)) ∩ M.(live_roles) δ = ∅ → - (dom fs1 ∩ dom fs2 = ∅) → - ζf ∉ dom δ.(ls_map) → - ∃ δ', δ'.(ls_data) = - {| ls_under := δ; - ls_map := <[ζ := fs1]>(<[ζf := fs2]> δ.(ls_map)) |} ∧ - ls_trans fl δ (Silent_step ζ) δ'. - Proof. - intros. - apply (silent_step_suff_data fl δ fs fs1 fs2 ζ (Some ζf)); try done. - - rewrite map_included_spec in H2. done. - - rewrite map_included_spec in H3. done. - - set_solver. - Qed. - - (* TODO: Change original lemma to not existentially quantify new state *) - Lemma silent_step_suff_data_fork_weak_alt fl (δ δ': LiveState Λ M) - (fs fs1 fs2 : gmap _ nat) ζ ζf : - δ.(ls_under) = δ'.(ls_under) → - δ.(ls_map) !! ζ = Some fs → - δ'.(ls_map) = <[ζ := fs1]>(<[ζf := fs2]> δ.(ls_map)) → - fs ≠ ∅ → - map_included (<) fs1 fs → - map_included (<) fs2 fs → - (dom fs ∖ (dom fs1 ∪ dom fs2)) ∩ M.(live_roles) δ = ∅ → - (dom fs1 ∩ dom fs2 = ∅) → - ζf ∉ dom δ.(ls_map) → - ls_trans fl δ (Silent_step ζ) δ'. - Proof. - rewrite !map_included_spec. - intros Hδ Hfs Hfs12 Hne Hle1 Hle2 Hlive Hdisj Hnin. - assert (∃ δ', δ'.(ls_data) = - {| ls_under := δ; - ls_map := <[ζ := fs1]> (<[ζf := fs2]>δ.(ls_map)) |} ∧ - ls_trans fl δ (Silent_step ζ) δ') as (δ''&Heq&Htrans). - { apply (silent_step_suff_data fl δ fs fs1 fs2 ζ (Some ζf)); - try set_solver. } - rewrite Heq Hδ -Hfs12 in Htrans. by destruct δ', ls_data. - Qed. - - Lemma model_can_fork_step_trans fl ζ ζf (δ δ' : LiveState Λ M) : - model_can_fork_step δ ζ ζf δ' → ls_trans fl δ (Silent_step ζ) δ'. - Proof. - destruct 1 as (?&?&?&?&?&?&?&?&?&?&?&?). - by eapply silent_step_suff_data_fork_weak_alt. - Qed. - - Lemma model_state_interp_can_fork_step es (δ1 δ2 : LM) ζ - (fs1 fs2 : gmap (fmrole M) nat) e : - (ls_data δ2) = model_update_fork ζ (locale_of es e) (dom fs1 ∪ dom fs2) (dom fs2) δ1 → - (fs1 ∪ fs2) ≠ ∅ → fs1 ##ₘ fs2 → - model_state_interp es δ1 -∗ has_fuels_S ζ (fs1 ∪ fs2) -∗ - ⌜model_can_fork_step δ1 ζ (locale_of es e) δ2⌝. - Proof. - iIntros (Hδ2 Hne Hdisj) "Hm Hf". - iDestruct "Hm" as (fm [Hfmle Hdom] Hfmdead Htp) "(Hm & Hfm)". - iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. - pose proof Hagree as Hagree'. - rewrite /fuel_map_le_inner map_included_spec in Hfmle. - apply Hfmle in Hagree as (fs'&HSome&Hle). - iPureIntro. - apply map_included_map_agree_R in Hle as (fs12'&fsf'&->&Hdisj'&Hle). - pose proof Hle as Hle'. - apply map_agree_R_fmap_inv in Hle' as (fs12''&->); last first. - { intros. destruct v2; [lia|by eauto]. } - apply map_agree_R_fmap in Hle; last first. - { intros. lia. } - apply map_agree_R_union_inv in Hle as (fs1'&fs2'&->&Hle1&Hle2); - [|done]. - eexists _, fs1', fs2'. - repeat split. - - rewrite Hδ2. done. - - done. - - apply map_agree_R_dom in Hle1. - apply map_agree_R_dom in Hle2. - intros Heq. apply Hne. - apply dom_empty_iff_L in Heq. - apply dom_empty_iff_L. - set_solver. - - rewrite Hδ2. simpl. - rewrite insert_commute; last first. - { assert (locale_of es e ∉ locales_of_list es) as Hes%Htp. - apply not_elem_of_locale_of_from_list. - set_solver. } - f_equiv. - { rewrite lookup_total_alt. simpl. - rewrite !lookup_alter. rewrite HSome. - simpl. - rewrite map_filter_fmap. simpl. - rewrite map_filter_filter. simpl. - rewrite !map_fmap_union. - apply map_agree_R_dom in Hle1. - apply map_agree_R_dom in Hle2. - apply map_disjoint_dom in Hdisj. - apply map_disjoint_dom in Hdisj'. - rewrite map_filter_union; [|apply map_disjoint_dom; set_solver]. - rewrite map_filter_union; [|apply map_disjoint_dom; set_solver]. - assert (filter - (λ '(i, _), - i ∈ dom fs2 ∧ (i ∈ live_roles M δ1 ∨ i ∈ dom fs1 ∪ dom fs2)) - (S <$> fs1') = ∅) as Hfs1'. - { apply map_filter_empty_iff. - intros ρ f Hρ [HP1 HP2]. - apply elem_of_dom_2 in Hρ. - rewrite dom_fmap_L in Hρ. set_solver. } - assert (filter - (λ '(i, _), - i ∈ dom fs2 ∧ (i ∈ live_roles M δ1 ∨ i ∈ dom fs1 ∪ dom fs2)) - fsf' = ∅) as Hfsf'. - { apply map_filter_empty_iff. - intros ρ f Hρ [HP1 HP2]. - apply elem_of_dom_2 in Hρ. set_solver. } - rewrite Hfs1' Hfsf'. - rewrite left_id right_id. - rewrite map_filter_id; last first. - { intros. split. - - apply elem_of_dom_2 in H0. set_solver. - - right. - apply elem_of_dom_2 in H0. set_solver. } - rewrite -map_fmap_compose. - rewrite decr_succ_compose_id. - rewrite map_fmap_id. - done. } - rewrite -!alter_compose. - erewrite alter_insert_alt; [|done]. - f_equiv. - simpl. - rewrite map_filter_fmap. simpl. - rewrite map_filter_filter. simpl. - apply map_agree_R_dom in Hle1. - apply map_agree_R_dom in Hle2. - apply map_disjoint_dom in Hdisj. - apply map_disjoint_dom in Hdisj'. - rewrite !map_fmap_union. - rewrite map_filter_union; [|apply map_disjoint_dom; set_solver]. - rewrite map_filter_union; [|apply map_disjoint_dom; set_solver]. - assert (filter - (λ '(i, _), - (i ∉ dom fs2) ∧ (i ∈ live_roles M δ1 ∨ i ∈ dom fs1 ∪ dom fs2)) - (S <$> fs2') = ∅) as Hfs2'. - { apply map_filter_empty_iff. - intros ρ f Hρ [HP1 HP2]. - apply elem_of_dom_2 in Hρ. - rewrite dom_fmap_L in Hρ. set_solver. } - assert (filter - (λ '(i, _), - (i ∉ dom fs2) ∧ (i ∈ live_roles M δ1 ∨ i ∈ dom fs1 ∪ dom fs2)) - fsf' = ∅) as Hfsf'. - { apply map_filter_empty_iff. - intros ρ f Hρ [HP1 HP2]. - apply elem_of_dom_2 in Hρ. - rewrite Hle2 in HP1. - clear HP1. - assert (ρ ∈ (dom fs1 ∪ dom fs2)). - { destruct HP2 as [HP2|?]; [|done]. - rewrite -dom_union_L. - rewrite -(dom_fmap_L S). - eapply fuel_map_le_live_roles; [| | |apply Hagree'|..]. - - intros ????. by apply δ1.(ls_map_disj). - (* TODO: Fix this by unifying defs *) - - rewrite /fuel_map_le_inner map_included_spec. - eapply Hfmle. - - done. - - done. - - done. - - set_solver. } - set_solver. } - rewrite Hfs2' Hfsf'. - rewrite right_id right_id. - rewrite map_filter_id; last first. - { intros. split. - - apply elem_of_dom_2 in H0. set_solver. - - right. - apply elem_of_dom_2 in H0. set_solver. } - rewrite -map_fmap_compose. - rewrite decr_succ_compose_id. - rewrite map_fmap_id. - done. - - eapply (map_included_subseteq_r _ _ (S <$> fs1')). - { rewrite map_fmap_union. - etransitivity; apply map_union_subseteq_l. } - apply map_included_spec. - intros k v1 Hv1. exists (S v1). split; [|lia]. - by rewrite lookup_fmap Hv1. - - eapply (map_included_subseteq_r _ _ (S <$> fs2')). - { rewrite map_fmap_union. - rewrite (map_union_comm (S <$> fs1') (S <$> fs2')). - - etransitivity; apply map_union_subseteq_l. - - apply map_disjoint_dom. rewrite !dom_fmap_L. - apply map_disjoint_dom in Hdisj. - apply map_agree_R_dom in Hle1. - apply map_agree_R_dom in Hle2. - set_solver. } - apply map_included_spec. - intros k v1 Hv1. exists (S v1). split; [|lia]. - by rewrite lookup_fmap Hv1. - - rewrite -dom_empty_iff_L in Hne. - apply map_agree_R_dom in Hle1. - apply map_agree_R_dom in Hle2. - apply disjoint_intersection_L. - apply map_disjoint_dom in Hdisj. - apply map_disjoint_dom in Hdisj'. - rewrite dom_union_L. - rewrite dom_fmap_L. - rewrite -dom_union_L. - replace (dom (fs1' ∪ fs2' ∪ fsf') ∖ (dom fs1' ∪ dom fs2')) - with (dom fsf') by set_solver. - intros ρ Hin1 Hin2. - assert (ρ ∈ (dom fs1 ∪ dom fs2)). - { rewrite -dom_union_L. - rewrite -(dom_fmap_L S). - eapply fuel_map_le_live_roles; [| | |apply Hagree'|..]. - - intros ????. by apply δ1.(ls_map_disj). - - rewrite /fuel_map_le_inner map_included_spec. - eapply Hfmle. - - done. - - done. - - done. - - set_solver. } - set_solver. - - apply map_agree_R_dom in Hle1. - apply map_agree_R_dom in Hle2. - apply disjoint_intersection_L. - apply map_disjoint_dom in Hdisj. - set_solver. - - pose proof (not_elem_of_locale_of_from_list es e) - as Hes%Htp. - apply not_elem_of_dom in Hes. set_solver. - Qed. - - Lemma model_update_locale_spec_fork extr - (auxtr : auxiliary_trace LM) ζ ζf c2 ρs1 ρs2 δ2 : - δ2.(ls_data) = model_update_fork ζ ζf ρs1 ρs2 (trace_last auxtr) → - model_can_fork_step (trace_last auxtr) ζ ζf δ2 → - tids_smaller c2.1 δ2 → - valid_state_evolution_fairness - (extr :tr[Some ζ]: c2) - (auxtr :tr[Silent_step ζ]: δ2). - Proof. - intros Hstep Htids. destruct c2. - split; [done|]. split; [by eapply model_can_fork_step_trans|done]. - Qed. - - Lemma model_state_interp_has_fuels_agree es δ ζ (fs : gmap (fmrole M) nat) : - model_state_interp es δ -∗ has_fuels ζ fs -∗ - ⌜∃ fs', δ.(ls_map) !! ζ = Some fs' ∧ map_included (≤) fs fs'⌝. - Proof. - iIntros "Hm Hf". - iDestruct "Hm" as (fm [Hfmle _] Hfmdead Htp) "(Hm & Hfm)". - iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. - rewrite /fuel_map_le_inner map_included_spec in Hfmle. - apply Hfmle in Hagree as (fs'&HSome&Hfs'). - iPureIntro. by eexists _. - Qed. - - Lemma update_fork_step fs1 fs2 tp1 tp2 (extr : execution_trace Λ) - (auxtr: auxiliary_trace LM) ζ efork σ1 σ2 : - fs1 ∪ fs2 ≠ ∅ → fs1 ##ₘ fs2 → - trace_last extr = (tp1, σ1) → - locale_step (tp1, σ1) (Some ζ) (tp2, σ2) → - has_forked tp1 tp2 efork → - has_fuels_S ζ (fs1 ∪ fs2) -∗ - model_state_interp tp1 (trace_last auxtr) ==∗ - ∃ δ2, - ⌜valid_state_evolution_fairness - (extr :tr[Some ζ]: (tp2, σ2)) (auxtr :tr[Silent_step ζ]: δ2)⌝ ∗ - has_fuels ζ fs1 ∗ has_fuels (locale_of tp1 efork) fs2 ∗ - model_state_interp tp2 δ2. - Proof. - iIntros (Hdom Hdisj Hlast Hstep Hforked) "Hfuel Hm". - iDestruct (model_state_interp_has_fuels_agree with "Hm Hfuel") - as %(fs'&HSome&Hfs'). - iAssert (⌜(locale_of tp1 efork) ∉ dom (ls_map (trace_last auxtr))⌝)%I as %Hnin. - { destruct Hforked as (?&?&?). - iDestruct "Hm" as (fm [_ Hdom'] _ Htp) "[Hm Hfm]". - rewrite -Hdom'. - iPureIntro. apply not_elem_of_dom. apply Htp. - apply locale_step_equiv in Hstep. simpl in *. - apply not_elem_of_locale_of_from_list. } - epose proof (model_update_fork_valid _ _ _ _ _) as [δ2 Hδ]; - [by apply elem_of_dom|done|]. - iDestruct (model_state_interp_can_fork_step with "Hm Hfuel") as %Hcan_step; - [done..|]. - iMod (model_state_interp_fork_update with "Hm Hfuel") as "(Hm&Hf1&Hf2)"; - [done..|]. - iDestruct (model_state_interp_tids_smaller with "Hm") as %Htids. - iModIntro. - iExists δ2. - iFrame "Hm Hf1 Hf2". - iPureIntro. - by eapply model_update_locale_spec_fork. - 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. - -End model_state_lemmas. diff --git a/fairis/trace_utils.v b/fairis/trace_utils.v deleted file mode 100644 index 40dc554..0000000 --- a/fairis/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/program_logic/adequacy.v b/trillium/program_logic/adequacy.v index 30cc282..28ceb33 100644 --- a/trillium/program_logic/adequacy.v +++ b/trillium/program_logic/adequacy.v @@ -1196,7 +1196,7 @@ Proof. 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 length_fmap. rewrite prefixes_from_length. lia. } rewrite (locales_equiv_prefix_drop_alt es c'.1); [|by eapply locales_equiv_prefix_trans]. f_equiv. @@ -1610,7 +1610,7 @@ Proof. specialize (Hψ (t2, σ2)) as [Hsafe Hstuck]; [done|]. split; [|done]. intros i v Hlen1 Hlen2 Ht2. - rewrite fmap_length in Hlen2. + rewrite length_fmap 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|]. diff --git a/trillium/program_logic/weakestpre.v b/trillium/program_logic/weakestpre.v index 3d7623e..bbe1b41 100644 --- a/trillium/program_logic/weakestpre.v +++ b/trillium/program_logic/weakestpre.v @@ -5,7 +5,7 @@ From trillium.bi Require Export weakestpre. From iris.prelude Require Import options. Class irisG (Λ : language) (M : Model) (Σ : gFunctors) := IrisG { - iris_invGS :> invGS_gen HasNoLc Σ; + 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 From 0020c70835cf61b3815495f3dee781c5b732eb92 Mon Sep 17 00:00:00 2001 From: fresheed Date: Tue, 10 Jun 2025 15:53:54 +0200 Subject: [PATCH 02/17] made it build and install --- _CoqProject | 9 --------- make-package | 45 +++++++++++++++++++++++++++++++++++++++++++++ trillium.opam | 13 +++++++++++++ 3 files changed, 58 insertions(+), 9 deletions(-) create mode 100755 make-package create mode 100644 trillium.opam diff --git a/_CoqProject b/_CoqProject index 03cc163..e12d8e9 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,13 +1,4 @@ -Q trillium trillium --Q fairis trillium.fairness - --Q external/stdpp/stdpp stdpp --Q external/stdpp/stdpp_unstable stdpp.unstable --Q external/iris/iris iris --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/paco/src Paco -arg -w -arg -notation-overridden -arg -w -arg -redundant-canonical-projection diff --git a/make-package b/make-package new file mode 100755 index 0000000..57ed90f --- /dev/null +++ b/make-package @@ -0,0 +1,45 @@ +#!/bin/bash +set -e +# adapted from Iris repo build script. +# Helper script to build and/or install just one package out of this repository. +# Assumes that all the other packages it depends on have been installed already! + +# Make sure we get a GNU version of make. +# This is exactly how opam determines which make executable to use. +OS=$(uname) +MAKE="make" +if [ $OS == "FreeBSD" ] || [ $OS == "OpenBSD" ] ||\ + [ $OS == "NetBSD" ] || [ $OS == "DragonFly" ]; then + MAKE="gmake" +fi + +PROJECT="$1" +shift + +COQFILE="_CoqProject.$PROJECT" +MAKEFILE="Makefile.package.$PROJECT" + +# if ! grep -E -q "^$PROJECT/" _CoqProject; then +# echo "No files in $PROJECT/ found in _CoqProject; this does not seem to be a valid project name." +# exit 1 +# fi + +# Generate _CoqProject file and Makefile +rm -f "$COQFILE" +# Get the right "-Q" line. +grep -E "^-Q $PROJECT[ /]" _CoqProject >> "$COQFILE" +# # Get everything until the first empty line except for the "-Q" lines. +# sed -n '/./!q;p' _CoqProject | grep -E -v "^-Q " >> "$COQFILE" +cp _CoqProject "$COQFILE" +# # Get the files. +# grep -E "^$PROJECT/" _CoqProject >> "$COQFILE" +echo >> "$COQFILE" +find "$PROJECT/" -type f -name "*.v" >> "$COQFILE" +# Now we can run coq_makefile. +"${COQBIN}coq_makefile" -f "$COQFILE" -o "$MAKEFILE" + +# Run build +$MAKE -f "$MAKEFILE" "$@" + +# Cleanup +rm -f ".$MAKEFILE.d" "$MAKEFILE"* diff --git a/trillium.opam b/trillium.opam new file mode 100644 index 0000000..27bd419 --- /dev/null +++ b/trillium.opam @@ -0,0 +1,13 @@ +opam-version: "2.0" +name: "trillium" +synopsis: "Coq development of the Trillium framework" +maintainer: "Trillium Team" +authors: "Trillium Team" +license: "MIT" +build: ["./make-package" "trillium" "-j%{jobs}%"] +install: ["./make-package" "trillium" "install"] +depends: [ + "coq" { (= "9.0.0") } + "coq-iris" { (= "4.3.0") } + "coq-stdpp" { (="1.11.0") } +] \ No newline at end of file From a9e0286ce4846db7a6a935cb90cd9c3734a39158 Mon Sep 17 00:00:00 2001 From: fresheed Date: Fri, 13 Jun 2025 09:58:33 +0200 Subject: [PATCH 03/17] small change to align with Lawyer adequacy proofs --- trillium/program_logic/adequacy.v | 33 ++++++++++++++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) diff --git a/trillium/program_logic/adequacy.v b/trillium/program_logic/adequacy.v index 28ceb33..44def59 100644 --- a/trillium/program_logic/adequacy.v +++ b/trillium/program_logic/adequacy.v @@ -1495,6 +1495,36 @@ Proof. iModIntro; iIntros "[$ ?]"; done. Qed. +Definition cur_posts `{irisG Λ M Σ} (tp: list (expr Λ)) e0 (Φ0: val Λ → iProp Σ): iProp Σ := + posts_of tp (Φ0 :: ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> + prefixes_from [e0] (drop 1 tp))). + + +Definition rel_always_holds0 `{irisG Λ M Σ} + (ξ: execution_trace Λ → auxiliary_trace M → Prop) + (s: stuckness) + (stateI: execution_trace Λ → auxiliary_trace M → iProp Σ) + (Φ0: val Λ → iProp Σ) + e1 σ1 δ1: iProp Σ + := + ∀ (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' : finite_trace (cfg Λ) (olocale Λ)) + (atr' : auxiliary_trace M) (oζ : olocale Λ) + (ℓ: mlabel M), + trace_contract ex oζ ex' → trace_contract atr ℓ atr' → ξ ex' atr'⌝ -∗ + ⌜∀ e2 : expr Λ, 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 (Φ0 :: ((λ '(tnew, e), fork_post (locale_of tnew e)) <$> *) + (* prefixes_from [e1] (drop (length [e1]) c.1))) *) + cur_posts c.1 e1 Φ0 + ={⊤,∅}=∗ ⌜ξ ex atr⌝. + Theorem wp_strong_adequacy Λ M Σ `{!invGpreS Σ} (s: stuckness) (ξ : execution_trace Λ → auxiliary_trace M → Prop) @@ -1509,7 +1539,8 @@ Theorem wp_strong_adequacy Λ M Σ `{!invGpreS Σ} config_wp ∗ stateI (trace_singleton ([e1], σ1)) (trace_singleton δ1) ∗ WP e1 @ s; locale_of [] e1; ⊤ {{ Φ }} ∗ - rel_always_holds s [Φ] ξ ([e1], σ1) δ1) → + (* rel_always_holds s [Φ] ξ ([e1], σ1) δ1) → *) + rel_always_holds0 ξ s stateI Φ e1 σ1 δ1) -> continued_simulation ξ (trace_singleton ([e1], σ1)) (trace_singleton δ1). Proof. intros Hsc Hwptp. From 90d6b177830ccf243f6c1fafdef5a2d001a2710d Mon Sep 17 00:00:00 2001 From: fresheed Date: Fri, 13 Jun 2025 14:23:50 +0200 Subject: [PATCH 04/17] simplified make-package script --- make-package | 28 +++------------------------- 1 file changed, 3 insertions(+), 25 deletions(-) diff --git a/make-package b/make-package index 57ed90f..9171aa1 100755 --- a/make-package +++ b/make-package @@ -1,17 +1,6 @@ #!/bin/bash +# A simplified version of Iris project build script. set -e -# adapted from Iris repo build script. -# Helper script to build and/or install just one package out of this repository. -# Assumes that all the other packages it depends on have been installed already! - -# Make sure we get a GNU version of make. -# This is exactly how opam determines which make executable to use. -OS=$(uname) -MAKE="make" -if [ $OS == "FreeBSD" ] || [ $OS == "OpenBSD" ] ||\ - [ $OS == "NetBSD" ] || [ $OS == "DragonFly" ]; then - MAKE="gmake" -fi PROJECT="$1" shift @@ -19,27 +8,16 @@ shift COQFILE="_CoqProject.$PROJECT" MAKEFILE="Makefile.package.$PROJECT" -# if ! grep -E -q "^$PROJECT/" _CoqProject; then -# echo "No files in $PROJECT/ found in _CoqProject; this does not seem to be a valid project name." -# exit 1 -# fi - # Generate _CoqProject file and Makefile rm -f "$COQFILE" -# Get the right "-Q" line. -grep -E "^-Q $PROJECT[ /]" _CoqProject >> "$COQFILE" -# # Get everything until the first empty line except for the "-Q" lines. -# sed -n '/./!q;p' _CoqProject | grep -E -v "^-Q " >> "$COQFILE" cp _CoqProject "$COQFILE" -# # Get the files. -# grep -E "^$PROJECT/" _CoqProject >> "$COQFILE" -echo >> "$COQFILE" +# Get the files. find "$PROJECT/" -type f -name "*.v" >> "$COQFILE" # Now we can run coq_makefile. "${COQBIN}coq_makefile" -f "$COQFILE" -o "$MAKEFILE" # Run build -$MAKE -f "$MAKEFILE" "$@" +make -f "$MAKEFILE" "$@" # Cleanup rm -f ".$MAKEFILE.d" "$MAKEFILE"* From 3eba82bd0ddcc71f3b9ecdb2e9df1b6dcd133b0d Mon Sep 17 00:00:00 2001 From: fresheed Date: Thu, 26 Jun 2025 13:22:01 +0200 Subject: [PATCH 05/17] specified the current version of Trillium (quite arbitrary) --- trillium.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/trillium.opam b/trillium.opam index 27bd419..839b901 100644 --- a/trillium.opam +++ b/trillium.opam @@ -1,5 +1,6 @@ opam-version: "2.0" name: "trillium" +version: "2.0.0" synopsis: "Coq development of the Trillium framework" maintainer: "Trillium Team" authors: "Trillium Team" From 48850ef37e0b5826f6a47689833661da75f7a76f Mon Sep 17 00:00:00 2001 From: fresheed Date: Fri, 29 Aug 2025 11:18:13 +0200 Subject: [PATCH 06/17] cleaned up makefile --- Makefile | 19 ++++++------------- 1 file changed, 6 insertions(+), 13 deletions(-) diff --git a/Makefile b/Makefile index 91d00ec..e52740c 100644 --- a/Makefile +++ b/Makefile @@ -1,9 +1,7 @@ TRILLIUM_DIR := 'trillium' -LOCAL_SRC_DIRS := $(TRILLIUM_DIR) -SRC_DIRS := $(LOCAL_SRC_DIRS) +SRC_DIRS := $(TRILLIUM_DIR) -ALL_VFILES := $(shell find $(SRC_DIRS) -name "*.v") -VFILES := $(shell find $(LOCAL_SRC_DIRS) -name "*.v") +VFILES := $(shell find $(SRC_DIRS) -name "*.v") COQC := coqc Q:=@ @@ -13,9 +11,9 @@ COQPROJECT_ARGS := $(shell sed -E -e '/^\#/d' -e 's/-arg ([^ ]*)/\1/g' _CoqProje all: $(VFILES:.v=.vo) -.coqdeps.d: $(ALL_VFILES) _CoqProject +.coqdeps.d: $(VFILES) _CoqProject @echo "COQDEP $@" - $(Q)coqdep -vos -f _CoqProject $(ALL_VFILES) > $@ + $(Q)coqdep -vos -f _CoqProject $(VFILES) > $@ # do not try to build dependencies if cleaning or just building _CoqProject ifeq ($(filter clean,$(MAKECMDGOALS)),) @@ -44,7 +42,7 @@ clean: # project-specific targets .PHONY: build clean-trillium trillium -VPATH= $(TRILLIUM_DIR) $(FAIRIS_DIR) +VPATH= $(TRILLIUM_DIR) VPATH_FILES := $(shell find $(VPATH) -name "*.v") build: $(VPATH_FILES:.v=.vo) @@ -52,10 +50,5 @@ build: $(VPATH_FILES:.v=.vo) trillium : @$(MAKE) build VPATH=$(TRILLIUM_DIR) -clean-local: - @echo "CLEAN vo glob aux" - $(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) + @$(MAKE) clean SRC_DIRS=$(TRILLIUM_DIR) From 3bf4d8813a79d3064917c7833601535c22aa38f5 Mon Sep 17 00:00:00 2001 From: fresheed Date: Fri, 29 Aug 2025 12:32:03 +0200 Subject: [PATCH 07/17] added fairness/ dir, .opam file and paco dependency --- Makefile | 20 +- _CoqProject | 2 + fairness/execution_model.v | 44 ++ fairness/fairness.v | 356 ++++++++++++++ fairness/fin_branch.v | 56 +++ fairness/inftraces.v | 945 +++++++++++++++++++++++++++++++++++++ fairness/locales_helpers.v | 63 +++ fairness/nat_omega.v | 256 ++++++++++ fairness/trace_helpers.v | 200 ++++++++ fairness/trace_len.v | 192 ++++++++ fairness/trace_lookup.v | 696 +++++++++++++++++++++++++++ fairness/trace_utils.v | 275 +++++++++++ fairness/traces_match.v | 100 ++++ fairness/utils.v | 164 +++++++ fairness/utils_logic.v | 180 +++++++ fairness/utils_maps.v | 407 ++++++++++++++++ fairness/utils_relations.v | 159 +++++++ fairness/utils_sets.v | 371 +++++++++++++++ trillium.opam | 1 + 19 files changed, 4484 insertions(+), 3 deletions(-) create mode 100644 fairness/execution_model.v create mode 100644 fairness/fairness.v create mode 100644 fairness/fin_branch.v create mode 100644 fairness/inftraces.v create mode 100644 fairness/locales_helpers.v create mode 100644 fairness/nat_omega.v create mode 100644 fairness/trace_helpers.v create mode 100644 fairness/trace_len.v create mode 100644 fairness/trace_lookup.v create mode 100644 fairness/trace_utils.v create mode 100644 fairness/traces_match.v create mode 100644 fairness/utils.v create mode 100644 fairness/utils_logic.v create mode 100644 fairness/utils_maps.v create mode 100644 fairness/utils_relations.v create mode 100644 fairness/utils_sets.v diff --git a/Makefile b/Makefile index e52740c..a38bb82 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,7 @@ TRILLIUM_DIR := 'trillium' -SRC_DIRS := $(TRILLIUM_DIR) +HL_DIR := 'heap_lang' +FAIRNESS_DIR := 'fairness' +SRC_DIRS := $(TRILLIUM_DIR) $(FAIRNESS_DIR) $(HL_DIR) VFILES := $(shell find $(SRC_DIRS) -name "*.v") @@ -40,9 +42,9 @@ clean: rm -f .coqdeps.d # project-specific targets -.PHONY: build clean-trillium trillium +.PHONY: build clean-trillium trillium clean-fairness fairness clean-heap-lang heap-lang -VPATH= $(TRILLIUM_DIR) +VPATH= $(TRILLIUM_DIR) $(FAIRNESS_DIR) $(HL_DIR) VPATH_FILES := $(shell find $(VPATH) -name "*.v") build: $(VPATH_FILES:.v=.vo) @@ -50,5 +52,17 @@ build: $(VPATH_FILES:.v=.vo) trillium : @$(MAKE) build VPATH=$(TRILLIUM_DIR) +fairness : + @$(MAKE) build VPATH=$(FAIRNESS_DIR) + +heap-lang : + @$(MAKE) build VPATH=$(HL_DIR) + clean-trillium: @$(MAKE) clean SRC_DIRS=$(TRILLIUM_DIR) + +clean-fairness: + @$(MAKE) clean SRC_DIRS=$(FAIRNESS_DIR) + +clean-heap-lang: + @$(MAKE) clean SRC_DIRS=$(HL_DIR) diff --git a/_CoqProject b/_CoqProject index e12d8e9..b4333fc 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,4 +1,6 @@ -Q trillium trillium +-Q heap_lang heap_lang +-Q fairness fairness -arg -w -arg -notation-overridden -arg -w -arg -redundant-canonical-projection diff --git a/fairness/execution_model.v b/fairness/execution_model.v new file mode 100644 index 0000000..a9ab82d --- /dev/null +++ b/fairness/execution_model.v @@ -0,0 +1,44 @@ +From stdpp Require Import fin_maps. +From iris.proofmode Require Import tactics. +From trillium Require Import language. +From trillium.program_logic Require Import traces weakestpre. +From fairness Require Import inftraces fairness. + +Class ExecutionModel (Λ: language) (M: Model) := { + + (** these two are exepcted to be typeclasses themselves *) + em_preGS: gFunctors -> Set; + em_GS: gFunctors -> Set; + + em_Σ: gFunctors; + em_Σ_subG: forall Σ, subG em_Σ Σ -> em_preGS Σ; + + em_valid_evolution_step: + cfg Λ -> olocale Λ → cfg Λ → mstate M → mlabel M → mstate M → Prop; + + em_thread_post {Σ} `{em_GS Σ}: locale Λ -> iProp Σ; + + em_msi {Σ} `{em_GS Σ}: cfg Λ -> mstate M -> iProp Σ; + + em_init_param: Type; + em_init_resource {Σ: gFunctors} `{em_GS Σ}: mstate M → em_init_param -> iProp Σ; + em_is_init_st: cfg Λ -> mstate M -> Prop; + + em_initialization Σ `{ePreGS: em_preGS Σ}: + forall (s1: mstate M) (σ: cfg Λ) (p: em_init_param) + (INIT_ST: em_is_init_st σ s1), + ⊢ (|==> ∃ eGS: em_GS Σ, @em_init_resource _ eGS s1 p ∗ @em_msi _ eGS σ s1) +}. + +Section EMDefinitions. + Context `{EM: ExecutionModel Λ M}. + + Definition em_valid_state_evolution_fairness + (extr : execution_trace Λ) (auxtr: auxiliary_trace M) := + match extr, auxtr with + | (extr :tr[oζ]: σ), auxtr :tr[ℓ]: δ => + em_valid_evolution_step (trace_last extr) oζ σ (trace_last auxtr) ℓ δ + | _, _ => True + end. + +End EMDefinitions. diff --git a/fairness/fairness.v b/fairness/fairness.v new file mode 100644 index 0000000..629fe23 --- /dev/null +++ b/fairness/fairness.v @@ -0,0 +1,356 @@ +From stdpp Require Import option countable gmap ssreflect. +From Paco Require Import paco1 paco2 pacotac. +From fairness Require Export inftraces trace_lookup utils. +From trillium.program_logic Require Export traces. +From trillium.program_logic Require Import language adequacy. +From Stdlib Require Import Logic.Classical. + + +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; +}. + +Definition fair_model_model `(FM : FairModel) : Model := {| + mstate := fmstate FM; + mlabel := option (fmrole FM); + mtrans := fmtrans FM; +|}. + + +#[global] Existing Instance fmrole_eqdec. +#[global] Existing Instance fmrole_countable. +#[global] Existing Instance fmrole_inhabited. +#[global] Existing Instance fmstate_inhabited. + + +(** Definition of fairness for all kinds of traces *) +Section GeneralizedFairness. + Context {S L T: Type}. + Context (locale_prop: T -> S -> Prop). + Context (does_step: T -> S -> option (L * S) -> Prop). + + Definition fairness_sat_gen (t: T) (s: S) (step: option (L * S)) := + ¬ locale_prop t s \/ does_step t s step. + + Definition fair_by_gen (t: T) (otr: trace S L): Prop := + forall n, pred_at otr n (λ c _, locale_prop t c) -> + exists m s step, otr !! (n + m) = Some (s, step) /\ fairness_sat_gen t s step. + + Lemma fair_by_gen_after t tr tr' k: + after k tr = Some tr' -> + fair_by_gen t tr -> fair_by_gen t tr'. + Proof. + intros Haf Hf n Hp. + have Hh:= Hf (k+n). + have Hp': pred_at tr (k + n) (λ (c : S) (_ : option L), locale_prop t c). + { rewrite (pred_at_sum _ k) Haf /= //. } + have [m Hm] := Hh Hp'. + destruct Hm as (s & step & STEP & SAT). + do 3 eexists. split; eauto. + erewrite trace_lookup_after; eauto. + rewrite Nat.add_assoc. eauto. + Qed. + + Lemma fair_by_gen_cons (t: T) (c: S) (tid' : L) (r : trace S L): + fair_by_gen t (c -[ tid' ]-> r) → fair_by_gen t r. + Proof. intros H. by eapply (fair_by_gen_after t (c -[tid']-> r) r 1). Qed. + + Lemma fair_by_gen_cons_forall δ ℓ' r: + (∀ ℓ, fair_by_gen ℓ (δ -[ℓ']-> r)) -> (∀ ℓ, fair_by_gen ℓ r). + Proof. eauto using fair_by_gen_cons. Qed. + + Definition fair_by_gen' + (t: T) (otr: trace S L) := + forall n, from_option (locale_prop t) False (otr S!! n) -> + exists m s' step, otr !! (n + m) = Some (s', step) /\ + fairness_sat_gen t s' step. + + Definition fair_by_gen'_strong + (t: T) (otr: trace S L) := + forall n, from_option (locale_prop t) False (otr S!! n) -> + exists m s' step, otr !! (n + m) = Some (s', step) /\ + fairness_sat_gen t s' step /\ + (forall k sk stepk, n <= k < n + m -> otr !! k = Some (sk, stepk) -> + ¬ fairness_sat_gen t sk stepk). + + Lemma fair_by_gen_equiv: + forall (t: T) (otr: trace S L), + fair_by_gen t otr <-> fair_by_gen' t otr. + Proof. + intros. rewrite /fair_by_gen /fair_by_gen'. + apply forall_proper. intros n. + repeat setoid_rewrite pred_at_trace_lookup. + apply Morphisms_Prop.iff_iff_iff_impl_morphism. + 2: { done. } + destruct (otr S!! n); simpl; set_solver. + Qed. + + Lemma fair_by_gen'_strong_equiv + `{forall t s, Decision (locale_prop t s)} `{forall t s step, Decision (does_step t s step)}: + forall (t: T) (otr: trace S L), fair_by_gen' t otr <-> fair_by_gen'_strong t otr. + Proof. + intros. rewrite /fair_by_gen'_strong /fair_by_gen'. split. + 2: { intros FAIR ? EN. specialize (FAIR _ EN) as (?&?&?&?&?&?). eauto. } + intros FAIR ? EN. specialize (FAIR _ EN) as [m_ STEP]. + pattern m_ in STEP. eapply min_prop_dec in STEP. + 2: { intros k. destruct (otr !! (n + k)) as [[s step]| ] eqn:K. + 2: { right. set_solver. } + eapply Decision_iff_impl. + { rewrite ex_det_iff; [rewrite ex_det_iff| ]; [reflexivity| ..]. + - intros ? [[=] ?]. subst. reflexivity. + - intros ? (?& [=] & ?). subst. reflexivity. } + apply and_dec; try solve_decision. + by left. } + clear dependent m_. destruct STEP as (m & (?&?&?&?) & MINm). + do 3 eexists. repeat split; eauto. + intros k * [LE LT] KTH. intros SAT. + apply Nat.le_sum in LE as [d ->]. + specialize (MINm d ltac:(eauto)). lia. + Qed. + +End GeneralizedFairness. + +Global Instance fair_by_gen_Proper {S L T: Type}: + Proper ((eq ==> eq ==> iff) ==> (eq ==> eq ==> eq ==> iff) ==> eq ==> eq ==> iff) + (@fair_by_gen S L T). +Proof. + intros ?? LOC_IFF ?? STEP_IFF. + red. intros ?? ->. red. intros ?? ->. + rewrite /fair_by_gen. + apply forall_proper. intros. + erewrite pred_at_iff. + 2: { intros. eapply LOC_IFF; reflexivity. } + apply Morphisms_Prop.iff_iff_iff_impl_morphism; [reflexivity| ]. + repeat (apply exist_proper; intros). + apply Morphisms_Prop.and_iff_morphism; [done| ]. + rewrite /fairness_sat_gen. + apply Morphisms_Prop.or_iff_morphism. + - apply not_iff_compat, LOC_IFF; reflexivity. + - apply STEP_IFF; reflexivity. +Qed. + + +Section LocaleFairness. + (** TODO: this is in fact a case of fair_by_gen with a simpler does_step relation, + but formalizing it would require some routine work to adjust all the proofs. *) + Context {S L T: Type}. + Context (locale_prop: T -> S -> Prop). + Context (does_step: T -> L -> Prop). + + Definition fairness_sat (t: T) (s: S) (ol: option L) := + ¬ locale_prop t s \/ exists ℓ, ol = Some ℓ /\ does_step t ℓ. + + Definition fair_by (t: T) (otr: trace S L): Prop := + forall n, pred_at otr n (λ c _, locale_prop t c) -> + exists m, pred_at otr (n + m) (fairness_sat t). + + Lemma fair_by_after t tr tr' k: + after k tr = Some tr' -> + fair_by t tr -> fair_by t tr'. + Proof. + intros Haf Hf n Hp. + have Hh:= Hf (k+n). + have Hp': pred_at tr (k + n) (λ (c : S) (_ : option L), locale_prop t c). + { rewrite (pred_at_sum _ k) Haf /= //. } + have [m Hm] := Hh Hp'. exists m. + red. by rewrite <- Nat.add_assoc, !(pred_at_sum _ k), Haf in Hm. + Qed. + + Lemma fair_by_cons (t: T) (c: S) (tid' : L) (r : trace S L): + fair_by t (c -[ tid' ]-> r) → fair_by t r. + Proof. intros H. by eapply (fair_by_after t (c -[tid']-> r) r 1). Qed. + + Lemma fair_by_cons_forall δ ℓ' r: + (∀ ℓ, fair_by ℓ (δ -[ℓ']-> r)) -> (∀ ℓ, fair_by ℓ r). + Proof. eauto using fair_by_cons. Qed. + + Definition fair_by' (t: T) (otr: trace S L) := + forall n, from_option (locale_prop t) False (otr S!! n) -> + exists m s', otr S!! (n + m) = Some s' /\ + fairness_sat t s' (otr L!! (n + m)). + + Definition fair_by'_strong (t: T) (otr: trace S L) := + forall n, from_option (locale_prop t) False (otr S!! n) -> + exists m, ClassicalFacts.Minimal + (fun d => exists s', otr S!! (n + d) = Some s' /\ fairness_sat t s' (otr L!! (n + d))) m. + + Lemma fair_by_equiv: + forall (t: T) (otr: trace S L), fair_by t otr <-> fair_by' t otr. + Proof. + intros. rewrite /fair_by /fair_by'. + apply forall_proper. intros n. + repeat setoid_rewrite pred_at_trace_lookup. + apply Morphisms_Prop.iff_iff_iff_impl_morphism; [| done]. + destruct (otr S!! n); simpl; set_solver. + Qed. + + Global Instance fairness_sat_dec + `{forall t s, Decision (locale_prop t s)} + `{forall t l, Decision (does_step t l)}: + forall t s ol, Decision (fairness_sat t s ol). + Proof using. + intros. rewrite /fairness_sat. + destruct (decide (locale_prop t s)) as [EN| ]; [| left; tauto]. + destruct ol as [l| ]; [| right; set_solver]. + destruct (decide (does_step t l)). + - left. eauto. + - right. set_solver. + Qed. + + Lemma fair_by'_strenghten + `{forall t s ol, Decision (fairness_sat t s ol)}: + forall (t: T) (otr: trace S L), fair_by' t otr <-> fair_by'_strong t otr. + Proof using. + intros. rewrite /fair_by' /fair_by'_strong. + apply forall_proper. intros n. + apply impl_iff_intro. intros Pn. destruct (otr S!! n) eqn:NTH; [| done]. + simpl in Pn. + split. + 2: { intros (?&?&?). eauto. } + intros [m EX]. pattern m in EX. apply min_prop_dec_impl in EX. + { destruct EX. eauto. } + intros i. destruct (otr S!! (n + i)) eqn:NEXT. + 2: { right. set_solver. } + destruct (decide (fairness_sat t s0 (otr L!! (n + i)))). + - left. eauto. + - right. set_solver. + Qed. + + Definition weakly_fair (t: T) (tr: trace S L) := + forall n, + is_Some (tr S!! n) -> + (** using True as default to support finite traces *) + (forall k, n <= k -> from_option (locale_prop t) True (tr S!! k)) -> + exists m ℓ, tr L!! (n + m) = Some ℓ /\ does_step t ℓ. + + Lemma fair_by'_weakly_fair τ tr: + fair_by' τ tr <-> weakly_fair τ tr. + Proof using. + rewrite /fair_by' /weakly_fair. apply forall_proper. intros n. + split. + - intros FAIR [δ NTH] ALW. + pose proof (ALW n ltac:(lia)) as ENn. rewrite NTH /= in ENn. + rewrite NTH in FAIR. ospecialize (FAIR ltac:(done)). + destruct FAIR as (d & δ' & MTH & SAT). + destruct SAT as [DIS | STEP]; [| by eauto]. + specialize (ALW (n + d) ltac:(lia)). by rewrite MTH in ALW. + - intros FAIR. + destruct (tr S!! n) as [δ | ] eqn:NTH; [| done]. simpl in *. + intros ENn. specialize (FAIR ltac:(done)). + destruct (classic (∀ k, n ≤ k → from_option (locale_prop τ) True (tr S!! k))). + { specialize (FAIR H). destruct FAIR as (m & ℓ & MTHl & STEP). + pose proof MTHl as [[? MTH] _]%mk_is_Some%label_lookup_states. + do 2 eexists. split; eauto. right. eauto. } + apply not_forall_exists_not in H as [m DIS]. + apply imply_to_and in DIS as [LE DIS]. + destruct (tr S!! m) as [? | ] eqn:MTH; [| done]. simpl in *. + apply Nat.le_sum in LE as [? ->]. + do 2 eexists. split; eauto. + by left. + Qed. + +End LocaleFairness. + +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 tid_match (ζ : locale Λ) (oζ': olocale Λ) := + oζ' = Some ζ. + + Definition fair_ex ζ (extr: extrace Λ): Prop := + fair_by locale_enabled tid_match ζ extr. + + 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. + + Definition extrace_fairly_terminating (extr : extrace Λ) := + extrace_valid extr → + (∀ tid, fair_ex tid extr) → + terminating_trace extr. + +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. + + Global Instance rem_dec: forall ρ st, Decision (role_enabled_model ρ st). + Proof. + intros. rewrite /role_enabled_model. solve_decision. + Qed. + + Definition role_match (ρ : fmrole M) (oρ': option $ fmrole M) := + oρ' = Some ρ. + + Definition fair_model_trace ρ (mtr: mtrace M): Prop := + fair_by role_enabled_model role_match ρ mtr. + + Definition mtrace_valid := trace_valid (fmtrans M). + +End model_traces. + + +Definition FM_strong_lr (FM: FairModel) := + forall st ρ, ρ ∈ live_roles FM st <-> exists st', fmtrans FM st (Some ρ) st'. + + +Global Hint Resolve fair_by_cons: core. +Global Hint Resolve trace_valid_mono : paco. diff --git a/fairness/fin_branch.v b/fairness/fin_branch.v new file mode 100644 index 0000000..c6822f5 --- /dev/null +++ b/fairness/fin_branch.v @@ -0,0 +1,56 @@ +From stdpp Require Import base sets. +From iris.proofmode Require Import tactics. +From fairness Require Import utils. +From trillium.prelude Require Import classical_instances. + + +Section ListApprox. + Context {A: Type}. + + Definition list_approx (P: A -> Prop) := + { l: list A | forall a, P a -> a ∈ l }. + + Fixpoint list_approx_repeat (R: A -> A → Prop) + (APX: forall a, list_approx (R a)) + (n: nat) + (a: A) + := + match n with + | 0 => [a] + | S n => + let la := APX a in + flat_map (list_approx_repeat R APX n) (proj1_sig la) + end. + + Lemma list_approx_repeat_spec (R: A -> A -> Prop) APX n a: + forall b, relations.nsteps R n a b -> b ∈ list_approx_repeat R APX n a. + Proof using. + revert a. induction n. + { simpl. intros ??. rewrite nsteps_0. set_solver. } + intros ??. rewrite -rel_compose_nsteps_next'. + intros (? & STEP & STEPS). + apply IHn in STEPS. simpl. + apply elem_of_list_In. apply in_flat_map. eexists. split. + 2: eapply elem_of_list_In; eauto. + destruct APX. simpl in *. apply elem_of_list_In. eauto. + Qed. + +End ListApprox. + +Section SmallerCardLA. + Context {A: Type}. + Context {EQDEC: EqDecision A}. + Context (P: A -> Prop). + + Local Instance P_PI: forall a, ProofIrrel (P a). + Proof using. intros. apply make_proof_irrel. Qed. + + Lemma list_approx_smaller_card (APX: list_approx P): + quantifiers.smaller_card {a | P a} nat. + Proof using EQDEC. + apply finitary.finite_smaller_card_nat. + destruct APX as [??]. + by eapply finitary.in_list_finite. + Qed. + +End SmallerCardLA. diff --git a/fairness/inftraces.v b/fairness/inftraces.v new file mode 100644 index 0000000..3ec5613 --- /dev/null +++ b/fairness/inftraces.v @@ -0,0 +1,945 @@ +From stdpp Require Import option. +From Paco Require Import paco1 paco2 pacotac. +From trillium.program_logic Require Import adequacy. +From fairness Require Import utils_logic. + +From Stdlib Require Import Relations.Relation_Definitions Relations.Relation_Operators. +From Stdlib Require Import 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. + + Lemma after_0_id (tr : trace St L): + after 0 tr = Some tr. + Proof. done. Qed. + + 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 after_S_tr_cons (tr: trace St L) n s ℓ atr + (AFTER: after n tr = Some (s -[ℓ]-> atr)): + after (S n) tr = Some atr. + Proof. + by rewrite -Nat.add_1_r after_sum' AFTER. + 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. + + Lemma pred_at_state_trfirst (tr: trace St L) (P : St → Prop): + pred_at tr 0 (fun st _ => P st) ↔ P (trfirst tr). + Proof. + rewrite /pred_at. destruct tr; eauto. + Qed. + + Lemma pred_at_dec (P: St → option L → Prop) + (DEC: forall st ro, Decision (P st ro)): + forall tr i, Decision (pred_at tr i P). + Proof using. + intros tr i. unfold pred_at. + destruct (after i tr); [destruct t| ]; auto. + solve_decision. + Qed. + + Lemma pred_at_or + P1 P2 (tr: trace St L) i: + pred_at tr i P1 \/ pred_at tr i P2 <-> pred_at tr i (fun x y => P1 x y \/ P2 x y). + Proof using. + unfold pred_at. destruct (after i tr); [destruct t| ]; tauto. + Qed. + + Lemma pred_at_ex {T: Type} (P : T -> St → option L → Prop) tr n: + pred_at tr n (fun s ol => exists t, P t s ol) <-> exists t, pred_at tr n (P t). + Proof. + rewrite /pred_at. destruct after. + 2: { intuition. by destruct H. } + destruct t; eauto. + Qed. + + Lemma pred_at_impl (P Q: St -> option L -> Prop) + (IMPL: forall s ol, P s ol -> Q s ol): + forall tr i, pred_at tr i P -> pred_at tr i Q. + Proof. + rewrite /pred_at. intros. + destruct after; intuition; destruct t. + all: by apply IMPL. + Qed. + + Lemma pred_at_iff (P Q: St -> option L -> Prop) + (IFF: forall s ol, P s ol <-> Q s ol): + forall tr i, pred_at tr i P <-> pred_at tr i Q. + Proof. + intros. rewrite /pred_at. + destruct after; intuition; destruct t. + all: by apply IFF. + 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. + + Lemma infinite_neg_finite (tr : trace St L): + terminating_trace tr <-> ¬ infinite_trace tr. + Proof. + rewrite /terminating_trace /infinite_trace. split. + - intros [n A]. intros A'. specialize (A' n). rewrite A in A'. by destruct A'. + - intros [n A%eq_None_not_Some]%not_forall_exists_not. eexists; eauto. + Qed. + + Lemma terminating_trace_after (tr atr: trace St L) i + (AFTER: after i tr = Some atr) + (FIN_ATR: terminating_trace atr): + terminating_trace tr. + Proof. + destruct FIN_ATR as [n FIN]. + exists (i + n). by rewrite after_sum' AFTER. + 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 TraceValid. + Context {St L: Type}. + Context (trans: St -> L -> St -> Prop). + + Let traceM := trace St L. + + Inductive trace_valid_ind (trace_valid_coind: traceM -> Prop) : + traceM -> Prop := + | trace_valid_singleton δ: trace_valid_ind _ ⟨δ⟩ + | trace_valid_cons δ ℓ tr: + trans δ ℓ (trfirst tr) -> + trace_valid_coind tr → + trace_valid_ind _ (δ -[ℓ]-> tr). + + Definition trace_valid := paco1 trace_valid_ind bot1. + + Lemma trace_valid_mono : + monotone1 trace_valid_ind. + Proof. + unfold monotone1. intros x0 r r' IN LE. + induction IN; try (econstructor; eauto; done). + Qed. + Hint Resolve trace_valid_mono : paco. + + Lemma trace_valid_after (mtr mtr' : traceM) k : + after k mtr = Some mtr' → trace_valid mtr → trace_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. + + Lemma trace_valid_tail s l (tr: traceM) + (VALID': trace_valid (s -[l]-> tr)): + trace_valid tr. + Proof. by eapply trace_valid_after with (k := 1); eauto. Qed. + + Lemma trace_valid_cons_inv (tr: trace St L) s l + (VALID: trace_valid (s -[l]-> tr)): + trace_valid tr /\ trans s l (trfirst tr). + Proof using. + punfold VALID. inversion VALID. subst. + pclearbot. done. + Qed. + +End TraceValid. + +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. + + Lemma traces_match_preserves_termination tr1 tr2 : + traces_match tr1 tr2 -> + terminating_trace tr2 -> + terminating_trace tr1. + Proof. + intros Hmatch [n HNone]. + revert tr1 tr2 Hmatch HNone. induction n as [|n IHn]; first done. + intros tr1 tr2 Hmatch HNone. + replace (S n) with (1 + n) in HNone =>//. + rewrite (after_sum' _ 1) in HNone. + destruct tr2 as [s| s ℓ tr2']; + 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_valid1 + (tr1: trace S1 L1) (tr2: trace S2 L2): + traces_match tr1 tr2 -> + trace_valid trans1 tr1. + Proof. + revert tr1 tr2. pcofix CH. intros tr1 tr2 Hmatch. + pfold. + inversion Hmatch; [by econstructor| ]. + constructor =>//. + specialize (CH _ _ H3). + eauto. + Qed. + + Lemma traces_match_valid2 + (tr1: trace S1 L1) (tr2: trace S2 L2): + traces_match tr1 tr2 -> + trace_valid trans2 tr2. + Proof. + revert tr1 tr2. pcofix CH. intros tr1 tr2 Hmatch. + pfold. + inversion Hmatch; [by econstructor| ]. + constructor =>//. + specialize (CH _ _ H3). + eauto. + Qed. + + Lemma traces_match_after' + (tr1 : trace S1 L1) (tr2 : trace S2 L2) (n : nat) + (tr1' : trace S1 L1): + traces_match tr1 tr2 + → after n tr1 = Some tr1' + → ∃ tr2' : trace S2 L2, + after n tr2 = Some tr2' ∧ traces_match tr1' tr2'. + Proof. + revert tr1 tr2. + induction n; intros tr1 tr2. + { simpl. intros. exists tr2. simplify_eq. done. } + move=> /= Hm Ha. destruct tr1 as [|s ℓ tr1''] eqn:Heq; first done. + destruct tr2; first by inversion Hm. + inversion Hm; simplify_eq. by eapply IHn. + Qed. + +End simulation. + +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_compose {L1 L2 L3 S1 S2 S3: Type} + {Rℓ12 Rs12 Rℓ23 Rs23 trans1 trans2 trans3} + (tr1 : trace S1 L1) (tr2 : trace S2 L2) (tr3 : trace S3 L3): + traces_match Rℓ12 Rs12 trans1 trans2 tr1 tr2 → + traces_match Rℓ23 Rs23 trans2 trans3 tr2 tr3 → + traces_match + (fun l1 l3 => exists l2, Rℓ12 l1 l2 /\ Rℓ23 l2 l3) + (fun s1 s3 => exists s2, Rs12 s1 s2 /\ Rs23 s2 s3) + trans1 trans3 + tr1 tr3 + . +Proof using. + intros *. revert tr1 tr2 tr3. + cofix CIH. + intros tr1. destruct tr1. + { simpl. intros. inversion H. subst. inversion H0. subst. + constructor. eauto. } + intros. inversion H. subst. inversion H0. subst. + constructor; eauto. +Qed. + + +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. + 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. + +Global Instance oless_dec: forall x y, Decision (oless x y). +Proof. + destruct x, y; simpl; solve_decision. +Qed. + +Global Instance oleq_dec: forall x y, Decision (oleq x y). +Proof. + destruct x, y; simpl; solve_decision. +Qed. + + +Section dec_unless. + Context {St S' L L': Type}. + Context (Us: St -> S'). + Context (Usls: St -> L -> St -> option L'). + + Definition dec_unless Ψ (tr: trace St L) := + ∀ n, match after n tr with + | Some ⟨ _ ⟩ | None => True + | Some (s -[ℓ]-> tr') => + (∃ ℓ', Usls s ℓ (trfirst tr') = 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 (Usls: St -> L -> St -> 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 ℓ: + (Usls s ℓ (trfirst btr) = None) -> + 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' -> + Usls s ℓ (trfirst btr) = 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_trfirst btr str + (CORR: upto_stutter btr str): + trfirst str = Us (trfirst btr). + Proof. + punfold CORR. by inversion CORR. + Qed. + + 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. + + Definition prefix_states_upto (btr: trace St L) (str: trace S' L') n' n := + (forall i b, i <= n' -> + pred_at btr i (fun b' _ => b' = b) -> + exists j, pred_at str j (fun s' _ => s' = Us b) /\ j <= n). + + (* TODO: try to express the prefix property with 'upto_stutter' and 'subtrace' *) + Lemma upto_stutter_after_strong {btr str} n {str'}: + upto_stutter btr str -> + after n str = Some str' -> + ∃ n' btr', after n' btr = Some btr' ∧ upto_stutter btr' str' /\ + prefix_states_upto btr str n' n. + Proof. + have Hw: ∀ (P: nat -> Prop), (∃ n, P (S n)) -> (∃ n, P n). + { intros P [x ?]. by exists (S x). } + unfold prefix_states_upto. + revert btr str str'. induction n as [|n IH]; intros btr str str' Hupto Hafter. + { injection Hafter => <-. clear Hafter. exists 0, btr. + do 2 (split; [done| ]). + intros. assert (i = 0) as -> by lia. + exists 0. split; [| done]. apply pred_at_state_trfirst. + apply pred_at_state_trfirst in H0. subst. + eapply upto_stutter_trfirst; eauto. } + 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. + specialize (IHH _ Hafter) as (n' & btr' & AFTER & UPTO & PRE). + exists n', btr'. do 2 (split; eauto). intros. + destruct i. + { apply pred_at_state_trfirst in H0. simpl in H0. subst b. + exists 0. split; [| lia]. apply pred_at_state_trfirst. + congruence. } + apply le_S_n in H. apply pred_at_S in H0. + specialize (PRE _ _ H H0). eauto. + - intros str' Hafter. simpl in Hafter. + apply Hw. simpl. + specialize (IH btr str str' ltac:(by destruct Hind) ltac:(done)). + destruct IH as (n' & btr' & AFTER & UPTO & PRE). + exists n', btr'. do 2 (split; eauto). intros. + destruct i. + { apply pred_at_state_trfirst in H2. simpl in H2. subst b. + exists 0. split; [| lia]. apply pred_at_state_trfirst. + simpl. congruence. } + apply le_S_n in H1. apply pred_at_S in H2. + specialize (PRE _ _ H1 H2) as (j & Pj & ?). + exists (S j). split; [| lia]. by apply pred_at_S. + Qed. + + Local Ltac gd t := generalize dependent t. + + Lemma upto_stutter_after' + {btr : trace St L} {str : trace S' L'} (n : nat) {btr' : trace St L}: + upto_stutter btr str + → after n btr = Some btr' + → ∃ (n' : nat) (str' : trace S' L'), + after n' str = Some str' ∧ upto_stutter btr' str'. + Proof. + have Hw: ∀ (P: nat -> Prop), (∃ n, P (S n)) -> (∃ n, P n). + { intros P [x ?]. by exists (S x). } + + intros. + gd btr. gd str. gd btr'. induction n as [|n IH]; intros btr' str btr Hupto Hafter. + { injection Hafter => <-. clear Hafter. exists 0, str. done. } + punfold Hupto. + inversion Hupto; subst. + - done. + - simpl in Hafter. rename btr0 into btr. + specialize (IH btr' str btr). + eapply IH; eauto. + by pfold. + - simpl in Hafter. rename btr0 into btr. rename str0 into str. + specialize (IH btr' str btr). + assert (upto_stutter btr str) as UPTO'. + { inversion H1; eauto. done. } + specialize (IH UPTO' Hafter) as (?&?&?&?). + eauto. + 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. + + Lemma upto_stutter_terminating_trace: + ∀ (tr1 : trace St L) (tr2 : trace S' L'), + upto_stutter tr1 tr2 → terminating_trace tr1 → terminating_trace tr2. + Proof. + intros * UPTO TERM1. + red in TERM1. destruct TERM1 as [len'1 AFTER1]. + pattern len'1 in AFTER1. + apply min_prop_dec in AFTER1 as [len1 [LEN1 MIN1]]; [| solve_decision]. clear len'1. + destruct len1. + { simpl in LEN1. done. } + destruct (after len1 tr1) eqn:A1. + 2: { specialize (MIN1 _ A1). lia. } + rewrite -Nat.add_1_r after_sum' A1 in LEN1. + destruct t; [| done]. + eapply upto_stutter_after' in A1; eauto. + destruct A1 as (?&?&?&UPTO'). + punfold UPTO'. inversion UPTO'. subst. + exists (S x). + rewrite -Nat.add_1_r after_sum' H. done. + Qed. + + Program Fixpoint destutter_once_step N Ψ (btr: trace St L): + Ψ (trfirst btr) < N → + dec_unless Us Usls Ψ btr → + S' + (S' * L' * { btr' : trace St L | dec_unless Us Usls Ψ btr'}) := + match N as n return + Ψ (trfirst btr) < n → + dec_unless Us Usls Ψ btr → + S' + (S' * L' * { btr' : trace St L | dec_unless Us Usls Ψ 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 Usls Ψ btr'}) with + | tr_singl s => λ _, inl (Us s) + | tr_cons s l btr' => + λ Hbtreq, + match Usls s l (trfirst btr') as z return Usls s l (trfirst btr') = z → S' + (S' * L' * { btr' : trace St L | dec_unless Us Usls Ψ 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 Usls Ψ 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 Usls Ψ 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 (Usls s ℓ (trfirst btr')) 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 Usls Ψ 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 (Usls s ℓ (trfirst btr')) 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 Usls Ψ btr): + upto_stutter btr (destutter Ψ btr Hdec). + Proof. eapply destutter_spec_ind. Qed. + + Lemma can_destutter Ψ (btr: trace St L) (Hdec: dec_unless Us Usls Ψ 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 *) + +From Stdlib Require Import Logic.Classical_Prop. + + +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_forall_exists_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/locales_helpers.v b/fairness/locales_helpers.v new file mode 100644 index 0000000..5c21de5 --- /dev/null +++ b/fairness/locales_helpers.v @@ -0,0 +1,63 @@ +From trillium.program_logic Require Import language adequacy. +From fairness Require Import utils. + +Section XX. + Context `{Countable (locale Λ)}. + + Notation "'Tid'" := (locale Λ). + + (* TODO: unify with existing locales_of_list_from_locale_from, + remove restriction for Λ *) + + Lemma locales_of_list_from_locale_from' tp0 tp1 ζ: + ζ ∈ locales_of_list_from tp0 tp1 (Λ := Λ) -> + is_Some (from_locale_from tp0 tp1 ζ). + Proof. + clear -tp0 tp1 ζ. + revert tp0; induction tp1 as [|e1 tp1 IH]; intros tp0. + { simpl. intros H. inversion H. } + simpl. + rewrite /locales_of_list_from /=. intros. + destruct (decide (locale_of tp0 e1 = ζ)); simplify_eq; first set_solver. + apply elem_of_cons in H as [?| ?]; [done| ]. + set_solver. + Qed. + + Lemma locale_step_from_locale_src `{EqDecision (expr Λ)} c1 c2 ζ: + locale_step c1 (Some ζ) c2 → + is_Some(from_locale c1.1 ζ). + Proof. + intros Hstep. inversion Hstep; simplify_eq=>//. + rewrite /from_locale. rewrite from_locale_from_Some; try done. + apply prefixes_from_spec; eauto. + Qed. + + Definition locales_of_cfg (c: cfg Λ): gset (locale Λ) := + list_to_set (locales_of_list c.1). + + Definition locales_of_cfg_singleton e σ: + locales_of_cfg ([e], σ) = {[ locale_of [] e ]}. + Proof. + rewrite /locales_of_cfg. simpl. set_solver. + Qed. + + Lemma locales_of_cfg_Some τ tp σ: + τ ∈ locales_of_cfg (tp, σ) <-> is_Some (from_locale tp τ). + Proof. + rewrite /locales_of_cfg. simpl. rewrite elem_of_list_to_set. + split. + - apply locales_of_list_from_locale_from'. + - apply locales_of_list_from_locale_from. + Qed. + + Definition step_fork (c1 c2: cfg Λ): option (locale Λ) := + let diff := locales_of_cfg c2 ∖ locales_of_cfg c1 in + gset_pick diff. + + Definition extr_last_fork (extr: execution_trace Λ): option (locale Λ) := + match extr with + | {tr[ _ ]} => None + | extr' :tr[oζ]: c' => step_fork (trace_last extr') c' + end. + +End XX. diff --git a/fairness/nat_omega.v b/fairness/nat_omega.v new file mode 100644 index 0000000..c518d8f --- /dev/null +++ b/fairness/nat_omega.v @@ -0,0 +1,256 @@ +(** * Natural numbers with infinity *) +(** Adapted from HahnOmega in coq-hahn library *) + +From iris.proofmode Require Import tactics. +From Stdlib.Init Require Import Peano. + +Set Implicit Arguments. + +Inductive nat_omega := NOinfinity | NOnum (n: nat). + +Ltac lia_NO len := destruct len; [done| simpl in *; lia]. +Ltac lia_NO' len := destruct len; simpl in *; try (done || lia). + +Global Instance nomega_eqdec: EqDecision nat_omega. +Proof. solve_decision. Qed. + +Module NOmega. + + Definition t := nat_omega. + + Definition zero := NOnum 0. + + Definition one := NOnum 1. + + Definition two := NOnum 2. + + Definition succ n := + match n with + | NOinfinity => NOinfinity + | NOnum n => NOnum (S n) + end. + + Definition pred n := + match n with + | NOinfinity => NOinfinity + | NOnum n => NOnum (Nat.pred n) + end. + + Definition add n m := + match n, m with + | NOnum n, NOnum m => NOnum (n + m) + | _, _ => NOinfinity + end. + + Definition double n := + match n with + | NOnum n => NOnum (Nat.double n) + | _ => NOinfinity + end. + + Definition sub n m := + match n, m with + | NOnum n, NOnum m => NOnum (n - m) + | NOnum n, NOinfinity => NOnum 0 + | NOinfinity, _ => NOinfinity + end. + + Definition eqb n m := + match n, m with + | NOnum n, NOnum m => Nat.eqb n m + | NOinfinity, NOinfinity => true + | _, _ => false + end. + + Definition ltb n m := + match n, m with + | NOnum n, NOnum m => Nat.ltb n m + | NOnum n, NOinfinity => true + | NOinfinity, _ => false + end. + + Definition max n m := + match n, m with + | NOnum n, NOnum m => NOnum (Nat.max n m) + | _, _ => NOinfinity + end. + + Definition min n m := + match n, m with + | NOnum n, NOnum m => NOnum (Nat.min n m) + | NOnum n, NOinfinity => NOnum n + | NOinfinity, _ => m + end. + + Definition le n m := + match n, m with + | _, NOinfinity => True + | NOnum n, NOnum m => n <= m + | _, _ => False + end. + + Global Instance nomega_le_eqdec: forall x y, Decision (le x y). + Proof. + intros. lia_NO' x; lia_NO' y; solve_decision. + Qed. + + Global Instance NOmega_le_TO: TotalOrder NOmega.le. + Proof. + split. + - split. + + split. + * intros [|]; red; lia. + * intros [|] [|] [|]; done || simpl; lia. + + intros [|] [|]; try (done || simpl; lia). + simpl. intros. f_equal. lia. + - red. unfold strict. intros [|] [|]; try (done || simpl; lia). + + simpl. tauto. + + simpl. destruct (Nat.lt_trichotomy n n0) as [?|[?|?]]; try lia. + subst. tauto. + Qed. + + Definition lt n m := + match n, m with + | NOinfinity, _ => False + | NOnum n, NOnum m => n < m + | NOnum n, NOinfinity => True + end. + + Definition lt_nat_l n m := + match m with + | NOnum m => n < m + | NOinfinity => True + end. + + Global Instance no_lt_nat_l_dec: forall x y, Decision (lt_nat_l x y). + Proof. + intros. destruct y. + + by left. + + simpl. solve_decision. + Qed. + + Definition sub_nat_l n m := + match m with + | NOnum m => (n - m) + | NOinfinity => 0 + end. + + Lemma pred_succ n : pred (succ n) = n. + Proof. destruct n; eauto. Qed. + + Lemma pred_0 : pred zero = zero. + Proof. eauto. Qed. + + + Lemma add_0_l n : add zero n = n. + Proof. destruct n; eauto. Qed. + + Lemma add_0_r n : add n zero = n. + Proof. destruct n; simpl; auto using Nat.add_0_r. Qed. + + Lemma sub_0_r n : sub n zero = n. + Proof. destruct n; simpl; auto using Nat.sub_0_r. Qed. + + Lemma eqb_eq n m : eqb n m <-> n = m. + Proof. + destruct n, m; simpl; try done. + rewrite Is_true_true Nat.eqb_eq. + split; congruence. + Qed. + + Lemma ltb_lt n m : ltb n m <-> lt n m. + Proof. + destruct n, m; simpl; try done. + rewrite Is_true_true Nat.ltb_lt. + split; congruence. + Qed. + + Lemma max_l n m : le m n -> max n m = n. + Proof. + destruct n, m; try done. + simpl. intros. by rewrite Nat.max_l. + Qed. + + Lemma max_r n m : le n m -> max n m = m. + Proof. + destruct n, m; try done. + simpl. intros. by rewrite Nat.max_r. + Qed. + + Lemma min_l n m : le n m -> min n m = n. + Proof. + destruct n, m; try done. + simpl. intros. by rewrite Nat.min_l. + Qed. + + Lemma min_r n m : le m n -> min n m = m. + Proof. + destruct n, m; try done. + simpl. intros. by rewrite Nat.min_r. + Qed. + + Lemma lt_irrefl x : ~ lt x x. + Proof. + destruct x; eauto. simpl. lia. + Qed. + + Lemma succ_inj n m : succ n = succ m -> n = m. + Proof. + destruct n, m; try done. + simpl. intros [=]. congruence. + Qed. + + Lemma lt_le_incl n m : lt n m -> le n m. + Proof. + destruct n, m; try done. + simpl. auto with arith. + Qed. + + Lemma lt_trans n m p : lt n m -> lt m p -> lt n p. + Proof. + destruct n, m, p; try done. + simpl. lia. + Qed. + + Lemma le_trans n m p : le n m -> le m p -> le n p. + Proof. + destruct n, m, p; try done. + simpl. lia. + Qed. + + Lemma lt_lt_nat n m k : + n < m -> NOmega.lt_nat_l m k -> NOmega.lt_nat_l n k. + Proof. + destruct k; try done. + simpl. lia. + Qed. + + Lemma le_lt_nat n m k : + n <= m -> NOmega.lt_nat_l m k -> NOmega.lt_nat_l n k. + Proof. + destruct k; try done. + simpl. lia. + Qed. + + Lemma lt_trichotomy (x y: nat_omega): + lt x y \/ x = y \/ lt y x. + Proof using. + destruct x, y; simpl; try lia; eauto. + pose proof (PeanoNat.Nat.lt_trichotomy n n0). + destruct H as [? | [? | ?]]; auto. + Qed. + + Lemma le_iff_not_lt_nat (n: nat) (x: nat_omega): + NOmega.le x (NOnum n) <-> ¬ lt_nat_l n x. + Proof. lia_NO x. Qed. + + Lemma nomega_le_lt_eq x y: + NOmega.le x y <-> NOmega.lt x y \/ x = y. + Proof. + lia_NO' x; lia_NO' y; try tauto. + - split; try done. intros [[] | [=]]. + - rewrite Nat.le_lteq. apply Morphisms_Prop.or_iff_morphism; [done| ]. + split; [intros -> | intros [=->]]; done. + Qed. + +End NOmega. diff --git a/fairness/trace_helpers.v b/fairness/trace_helpers.v new file mode 100644 index 0000000..5ed8e0e --- /dev/null +++ b/fairness/trace_helpers.v @@ -0,0 +1,200 @@ +From iris.proofmode Require Import tactics. +From fairness Require Import trace_len trace_lookup inftraces fairness trace_utils nat_omega. + +Close Scope Z_scope. + + +Section FMTraceHelpers. + Context {M: FairModel}. + Let St := fmstate M. + Let L := fmrole M. + + Definition set_fair_model_trace (T: L -> Prop) tr := + forall ρ (Tρ: T ρ), fair_model_trace ρ tr. + + Definition strong_fair_model_trace (tr: mtrace M) (ρ: fmrole M) := + forall n (EN: pred_at tr n (λ δ _, role_enabled_model ρ δ)), + exists m, ClassicalFacts.Minimal + (fun x => pred_at tr (n+x) (λ δ ℓ, ¬ role_enabled_model ρ δ \/ + ℓ = Some (Some ρ))) m. + + + Lemma fair_model_trace_defs_equiv (tr: mtrace M) (ρ: fmrole M): + fair_model_trace ρ tr <-> strong_fair_model_trace tr ρ. + Proof using. + + split. + 2: { intros FAIR. do 2 red. intros. + red in FAIR. specialize (FAIR n H) as [m [FAIR MIN]]. + exists m. eapply pred_at_iff; [| apply FAIR]. + intros. rewrite /role_match. + apply Morphisms_Prop.or_iff_morphism; [done| ]. + split; [intros (?&->&->)|intros ->]; eauto. } + + intros FAIR. red. intros. + red in FAIR. + specialize (@FAIR n). destruct FAIR; auto. + + pattern x in H. eapply min_prop_dec in H as [d MIN]. + { clear x. exists d. + eapply Minimal_proper; eauto. + red. intros. symmetry. + apply pred_at_iff. + intros. rewrite /role_match. + apply Morphisms_Prop.or_iff_morphism; [done| ]. + split; [intros (?&->&->)|intros ->]; eauto. } + + intros. + eapply pred_at_dec. intros. + apply or_dec. + 2: { destruct ro; [destruct o| ]. + - destruct (decide (f = ρ)). + + subst. left. eexists. split; eauto. done. + + right. by intros (?&[=<-]&[=]). + - right. by intros (?&[=<-]&[=]). + - right. by intros (?&[=<-]&[=]). } + apply not_dec. + rewrite /role_enabled_model. solve_decision. + Qed. + + Definition strong_fair_model_trace_alt (tr: mtrace M) (ρ: fmrole M) := + forall n st (NTH: tr S!! n = Some st) (EN: role_enabled_model ρ st), + exists m, ClassicalFacts.Minimal ( + fun x => (exists st', tr S!! (n + x) = Some st' /\ + ¬ role_enabled_model ρ st') \/ + (tr L!! (n + x) = Some (Some ρ)) + ) m. + + Lemma strong_fair_model_trace_alt_defs_equiv (tr: mtrace M) (ρ: fmrole M): + strong_fair_model_trace tr ρ <-> strong_fair_model_trace_alt tr ρ. + Proof using. + rewrite /strong_fair_model_trace /strong_fair_model_trace_alt. + pose proof trace_has_len tr as [len LEN]. + split; intros. + - specialize (H n). + specialize (H ltac:(by apply pred_at_trace_lookup; eauto)). + destruct H as [m [PROP MIN]]. exists m. split. + { apply pred_at_or in PROP as [PROP | PROP]; + [left | right]; apply pred_at_trace_lookup in PROP as [? [??]]; eauto. } + intros. apply MIN. apply pred_at_trace_lookup. + destruct H as [(?&?&?) | STEP]; [by eauto|]. + opose proof * (proj1 (label_lookup_states tr (n + k))) as [[st' ST'] _]; eauto. + - apply pred_at_trace_lookup in EN as [? [Tn EN]]. + specialize (H _ _ Tn EN). destruct H as [m [PROP MIN]]. + exists m. split. + + apply pred_at_trace_lookup. destruct PROP as [(?&?&?) | STEP]; eauto. + opose proof * (proj1 (label_lookup_states tr (n + m))) as [[st' ST'] _]; eauto. + + intros. apply MIN. apply pred_at_or in H. destruct H as [DIS | STEP]. + * left. apply pred_at_trace_lookup in DIS. eauto. + * right. apply pred_at_trace_lookup in STEP as [?[??]]. eauto. + Qed. + + + Section ValidTracesProperties. + Context {tr: mtrace M} (VALID: mtrace_valid tr). + + Local Ltac gd t := generalize dependent t. + + Definition label_kept_state_gen (Ps: St -> Prop) (Pstep: St -> option L -> St -> Prop) := + forall st oℓ' st' (P1: Ps st) (PSTEP: Pstep st oℓ' st') (STEP: fmtrans _ st oℓ' st'), + Ps st'. + + Lemma steps_keep_state_gen i (P: St -> Prop) Pstep j + (Pi: exists st, tr S!! i = Some st /\ P st) + (P_KEPT: label_kept_state_gen P Pstep) + (NOρ: forall (k: nat) st1 oℓ' st2 (IKJ: i <= k < j), tr !! k = Some (st1, Some (oℓ', st2)) -> Pstep st1 oℓ' st2): + forall k st' (IKJ: i <= k <= j) (KTH: tr S!! k = Some st'), P st'. + Proof using VALID. + intros k st' [IK KJ]. apply Nat.le_sum in IK as [d ->]. gd st'. induction d. + { rewrite Nat.add_0_r. destruct Pi as (? & ? & ?). intros. congruence. } + intros st'' KTH. rewrite Nat.add_succ_r -Nat.add_1_r in KTH. + pose proof (trace_has_len tr) as [len LEN]. + opose proof * (proj2 (trace_lookup_dom_strong _ _ LEN (i + d))) as [st' CUR]. + { eapply state_lookup_dom; eauto. } + + destruct CUR as (oℓ' & st''_ & CUR). + pose proof CUR as (PREV & CUR' & STEP)%state_label_lookup. + assert (st''_ = st'') as -> by congruence. + red in P_KEPT. eapply P_KEPT. + - apply IHd; [lia| eauto]. + - eapply NOρ; eauto. lia. + - eapply trace_valid_steps'; eauto. + Qed. + + Definition label_kept_state (Ps: St -> Prop) (Pl: option L -> Prop) := + forall st oℓ' st' (Pst: Ps st) (Poℓ: Pl oℓ') (STEP: fmtrans _ st oℓ' st'), + Ps st'. + + Definition other_step ρ: option (fmrole M) -> Prop := + fun oρ' => oρ' ≠ Some ρ. + + Lemma steps_keep_state i (P: St -> Prop) Pl j + (Pi: exists st, tr S!! i = Some st /\ P st) + (P_KEPT: label_kept_state P Pl) + (NOρ: forall (k: nat) oℓ' (IKJ: i <= k < j), tr L!! k = Some oℓ' -> Pl oℓ'): + forall k st' (IKJ: i <= k <= j) (KTH: tr S!! k = Some st'), P st'. + Proof using VALID. + intros k st' [IK KJ]. apply Nat.le_sum in IK as [d ->]. gd st'. induction d. + { rewrite Nat.add_0_r. destruct Pi as (? & ? & ?). intros. congruence. } + intros st'' KTH. rewrite Nat.add_succ_r -Nat.add_1_r in KTH. + pose proof (trace_has_len tr) as [len LEN]. + opose proof * (proj2 (trace_lookup_dom_strong _ _ LEN (i + d))) as [st' CUR]. + { eapply state_lookup_dom; eauto. } + destruct CUR as (oℓ' & st''_ & (PREV & CUR & STEP)%state_label_lookup). + assert (st''_ = st'') as -> by congruence. + red in P_KEPT. eapply P_KEPT. + - apply IHd; [lia| eauto]. + - eapply NOρ; eauto. lia. + - eapply trace_valid_steps'; eauto. + apply state_label_lookup. eauto. + Qed. + + Lemma steps_keep_state_inf i (P: St -> Prop) Pl + (Pi: exists st, tr S!! i = Some st /\ P st) + (P_KEPT: label_kept_state P Pl) + (NOρ: forall (k: nat) oℓ', i <= k -> tr L!! k = Some oℓ' -> Pl oℓ'): + forall k st' (IK: i <= k) (KTH: tr S!! k = Some st'), P st'. + Proof using VALID. + intros. eapply steps_keep_state; eauto. + intros p **. eapply (NOρ p); eauto. lia. + Qed. + + Lemma kept_state_fair_step (ρ: L) (P: St -> Prop) + (KEPT: label_kept_state P (other_step ρ)) + (P_EN: forall st (Pst: P st), @role_enabled_model M ρ st) + (FAIRρ: fair_model_trace ρ tr): + forall i st (ITH: tr S!! i = Some st) (Pst: P st), + exists j st', ClassicalFacts.Minimal (fun j => i <= j /\ tr L!! j = Some $ Some ρ) j /\ + tr S!! j = Some st' /\ P st'. + Proof using VALID. + intros. + apply fair_model_trace_defs_equiv, strong_fair_model_trace_alt_defs_equiv in FAIRρ. + red in FAIRρ. edestruct FAIRρ as [d [STEP MIN]]; [eauto| ..]. + { apply P_EN. eauto. } + clear FAIRρ. + + pose proof (trace_has_len tr) as [len LEN]. + assert (NOmega.lt_nat_l (i + d) len) as DOMid. + { destruct STEP as [(?&?&?) | STEP]. + - eapply state_lookup_dom; eauto. + - apply NOmega.lt_lt_nat with (m := i + d + 1); [lia| ]. + eapply label_lookup_dom; eauto. } + pose proof (proj2 (state_lookup_dom _ _ LEN (i + d)) DOMid) as [st' IDTH]. + + opose proof * (steps_keep_state i _ _ (i + d)) as NEXT_EN; eauto. + { intros. destruct IKJ as [[v ->]%Nat.le_sum KJ]. + intros ->. enough (d <= v); [lia| ]. apply MIN. eauto. } + { lia. } + + destruct STEP as [(st'_ & ST' & DIS') | STEP]. + { assert (st'_ = st') as -> by congruence. + destruct DIS'. apply P_EN. eauto. } + exists (i + d), st'. split; eauto. + red. split; [split; [lia| eauto]| ]. + intros k [LE' STEP']. apply Nat.le_sum in LE' as [d' ->]. + enough (d <= d'); [lia| ]. apply MIN. eauto. + Qed. + + End ValidTracesProperties. + +End FMTraceHelpers. diff --git a/fairness/trace_len.v b/fairness/trace_len.v new file mode 100644 index 0000000..be97ea2 --- /dev/null +++ b/fairness/trace_len.v @@ -0,0 +1,192 @@ +From stdpp Require Import decidable option ssreflect. +From Stdlib Require Import Arith. +From fairness Require Import nat_omega inftraces utils_logic. +Import numbers. + +Section TraceLen. + Context {St L: Type}. + + Instance NOmega_lt_le (x y: nat_omega): + Decision (NOmega.lt x y). + Proof using. + destruct x, y; simpl; solve_decision. + Qed. + + Definition trace_len_is (tr: trace St L) (len: nat_omega) := + forall (i: nat), is_Some (after i tr) <-> NOmega.lt_nat_l i len. + + Lemma trace_has_len (tr: trace St L): + exists len, trace_len_is tr len. + Proof using. + destruct (infinite_or_finite tr) as [INF | FIN_]. + { exists NOinfinity. red. intros. red in INF. + simpl. split; auto using INF. } + red in FIN_. + assert (exists n, ClassicalFacts.Minimal (fun n => after n tr = None) n) as FIN. + { destruct FIN_. eapply min_prop_dec; eauto. solve_decision. } + clear FIN_. destruct FIN as [n [SIZE MIN]]. + exists (NOnum n). red. intros i. simpl. split. + - intros SOME. destruct (le_lt_dec n i) as [LE| ]; auto. + apply Nat.le_sum in LE as [d ->]. + rewrite after_sum' in SOME. rewrite SIZE in SOME. by destruct SOME. + - intros LT. destruct (is_Some_dec (after i tr)); auto. + specialize (MIN i). destruct (after i tr); try done. + specialize (MIN eq_refl). lia. + Qed. + + Lemma trace_len_cons s l (tr: trace St L) (len: nat_omega) + (LEN: trace_len_is tr len): + trace_len_is (s -[l]-> tr) (NOmega.succ len). + Proof. + unfold trace_len_is in *. intros. + destruct i. + { simpl. lia_NO' len. simpl. intuition. lia. } + simpl. rewrite LEN. lia_NO len. + Qed. + + Lemma trace_len_uniq (tr: trace St L) (len1 len2: nat_omega) + (LEN1: trace_len_is tr len1) (LEN2: trace_len_is tr len2): + len1 = len2. + Proof. + unfold trace_len_is in *. + destruct (NOmega.lt_trichotomy len1 len2) as [?|[?|?]]; auto. + - destruct len1; [done| ]. + pose proof (proj2 (LEN2 n)) as L2. specialize (L2 ltac:(lia_NO len2)). + specialize (proj1 (LEN1 _) L2). simpl. lia. + - destruct len2; [done| ]. + pose proof (proj2 (LEN1 n)) as L1. specialize (L1 ltac:(lia_NO len1)). + specialize (proj1 (LEN2 _) L1). simpl. lia. + Qed. + + Lemma trace_len_tail s l (tr: trace St L) (len: nat_omega) + (LEN: trace_len_is (s -[l]-> tr) len): + trace_len_is tr (NOmega.pred len). + Proof. + pose proof (trace_has_len tr) as [len' LEN']. + pose proof (trace_len_cons s l _ _ LEN'). + opose proof (trace_len_uniq _ _ _ LEN H) as ->; eauto. + lia_NO' len'. + Qed. + + Lemma trace_len_singleton (s: St): + trace_len_is ⟨ s ⟩ (NOnum 1). + Proof. + red. intros. destruct i; simpl. + - rewrite is_Some_Some_True. lia. + - rewrite is_Some_None_False. lia. + Qed. + + Local Ltac gd t := generalize dependent t. + + Lemma trace_len_after (tr tr': trace St L) i + (len: nat_omega) + (LEN: trace_len_is tr len) + (AFTER: after i tr = Some tr'): + trace_len_is tr' (NOmega.sub len (NOnum i)). + Proof. + gd tr. gd tr'. gd len. induction i. + { intros. simpl in AFTER. + rewrite NOmega.sub_0_r. inversion AFTER. by subst. } + intros. destruct tr; [done| ]. + simpl in AFTER. + pose proof (trace_len_tail _ _ _ _ LEN). + specialize (IHi _ _ _ H AFTER). + lia_NO' len. simpl in *. + by replace (n - S i) with (Nat.pred n - i) by lia. + Qed. + + Lemma trace_len_0_inv (tr: trace St L) + (LEN1: trace_len_is tr (NOnum 0)): + False. + Proof. + pose proof (proj1 (LEN1 0)). ospecialize (H _); eauto. + red in H. lia. + Qed. + + Lemma trace_len_gt_0 (tr: trace St L): + forall len, trace_len_is tr len -> NOmega.lt_nat_l 0 len. + Proof. + intros. lia_NO' len. destruct n; [| lia]. + by apply trace_len_0_inv in H. + Qed. + + Lemma trace_len_1_inv (tr: trace St L) + (LEN1: trace_len_is tr (NOnum 1)): + exists s, tr = ⟨ s ⟩. + Proof. + destruct tr; eauto. + pose proof (proj1 (LEN1 1)). ospecialize (H _); eauto. + red in H. lia. + Qed. + + Lemma trace_len_neg (tr: trace St L) (len: nat_omega) + (LEN: trace_len_is tr len): + forall (i: nat), after i tr = None <-> NOmega.le len (NOnum i). + Proof. + intros. specialize (LEN i). + destruct (after i tr). + - apply proj1 in LEN. ospecialize (LEN _); eauto. + split; try done. lia_NO len. + - split; try done. intros _. + lia_NO' len. + + by destruct (proj2 LEN I). + + destruct (decide (n <= i)); [done| ]. + by destruct (proj2 LEN ltac:(lia)). + Qed. + + Lemma terminating_trace_equiv (tr: trace St L) len + (LEN: trace_len_is tr len): + terminating_trace tr <-> exists n, len = NOnum n. + Proof. + rewrite /terminating_trace. split. + - intros [? N]. eapply trace_len_neg in N; eauto. + lia_NO' len. eauto. + - intros [? ->]. exists x. + eapply trace_len_neg; eauto. simpl. lia. + Qed. + + Lemma infinite_trace_equiv (tr : trace St L) (len : nat_omega) + (LEN: trace_len_is tr len): + infinite_trace tr ↔ len = NOinfinity. + Proof. + rewrite /infinite_trace. split. + - intros A. destruct len; [done| ]. + eapply trace_len_neg with (i := n), proj2 in LEN. + specialize (A n) as [? T]. rewrite LEN in T; [done| ]. simpl. lia. + - intros -> ?. by apply LEN. + Qed. + +End TraceLen. + + +Section TracesMatch. + + Lemma traces_match_same_length_impl {L1 L2 S1 S2 : Type} + R1 R2 step1 step2 tr1 tr2 len1 len2 + (LEN1: trace_len_is tr1 len1) + (LEN2: trace_len_is tr2 len2) + (MATCH: @traces_match L1 L2 S1 S2 R1 R2 step1 step2 tr1 tr2) + (LT: NOmega.lt len1 len2): + False. + Proof. + destruct len1; [done| ]. + pose proof (proj2 (LEN2 n)) as LL2. specialize (LL2 ltac:(lia_NO len2)) as [atr2 AFTER2]. + pose proof (traces_match_after _ _ _ _ _ _ _ _ MATCH AFTER2) as (atr1 & AFTER1 & _). + specialize (proj1 (LEN1 _) (mk_is_Some _ _ AFTER1)). simpl. lia. + Qed. + + Lemma traces_match_same_length {L1 L2 S1 S2 : Type} + R1 R2 step1 step2 tr1 tr2 len1 len2 + (LEN1: trace_len_is tr1 len1) + (LEN2: trace_len_is tr2 len2) + (MATCH: @traces_match L1 L2 S1 S2 R1 R2 step1 step2 tr1 tr2): + len1 = len2. + Proof. + unfold trace_len_is in *. + destruct (NOmega.lt_trichotomy len1 len2) as [?|[?|?]]; auto; exfalso. + - eapply traces_match_same_length_impl with (tr1 := tr1) (tr2 := tr2); eauto. + - apply traces_match_flip in MATCH. + eapply @traces_match_same_length_impl with (tr1 := tr2) (tr2 := tr1); eauto. + Qed. + +End TracesMatch. diff --git a/fairness/trace_lookup.v b/fairness/trace_lookup.v new file mode 100644 index 0000000..7951abd --- /dev/null +++ b/fairness/trace_lookup.v @@ -0,0 +1,696 @@ +From fairness Require Import nat_omega trace_len inftraces trace_utils utils. +From stdpp Require Import base ssreflect. +From Paco Require Import paco1 paco2 pacotac. + + +Section TraceLookup. + Context {St L: Type}. + + (** Postpone instantiation of Lookup to make the notations work properly after *) + Let trace_lookup_impl (tr: trace St L) i := + match (after i tr) with + | None => None + | Some (tr_singl s) => Some (s, None) + | Some (tr_cons s l tr') => Some (s, Some (l, trfirst tr')) + end. + + + Definition state_lookup (tr: trace St L) (i: nat): option St := + match trace_lookup_impl tr i with + | Some (st, _) => Some st + | None => None + end. + + Definition label_lookup (tr: trace St L) (i: nat): option L := + match trace_lookup_impl tr i with + | Some (_, Some (ℓ, _)) => Some ℓ + | _ => None + end. + + Global Instance state_lookup_Lookup: Lookup nat St (trace St L) := + fun i tr => state_lookup tr i. + + Global Instance label_lookup_Lookup: Lookup nat L (trace St L) := + fun i tr => label_lookup tr i. + + Notation "tr S!! i" := (state_lookup tr i) (at level 20). + Notation "tr L!! i" := (label_lookup tr i) (at level 20). + + Global Instance trace_lookup: Lookup nat (St * option (L * St)) (trace St L) := + fun i tr => trace_lookup_impl tr i. + + Local Ltac unfold_lookups := + rewrite /lookup /state_lookup /label_lookup /trace_lookup /trace_lookup_impl. + + Lemma trace_lookup_trichotomy (tr: trace St L) (len: nat_omega) + (LEN: trace_len_is tr len): + forall i, (exists st ℓ st', tr !! i = Some (st, Some (ℓ, st')) /\ NOmega.lt_nat_l (i + 1) len) \/ + (exists st, tr !! i = Some (st, None) /\ len = NOnum (i + 1)) \/ + (tr !! i = None /\ NOmega.le len (NOnum i)). + Proof using. + intros. + pose proof (LEN i) as Ai. pose proof (LEN (i + 1)) as Ai'. + rewrite after_sum' in Ai'. + destruct (NOmega_lt_le (NOnum i) len). + 2: { right. right. apply not_iff_compat, proj2 in Ai, Ai'. + destruct len; simpl in *; try done. + specialize (Ai ltac:(lia)). specialize (Ai' ltac:(lia)). + split; [| lia]. + apply eq_None_not_Some in Ai. rewrite Ai in Ai'. + unfold_lookups. by rewrite Ai. } + apply proj2 in Ai. + specialize (Ai ltac:(lia_NO len)) as [ti Ai]. + rewrite Ai in Ai'. + destruct (decide (NOnum (i + 1) = len)) eqn:EQ'. + { right. left. subst. simpl in *. clear EQ'. + apply not_iff_compat, proj2 in Ai'. specialize (Ai' ltac:(lia)). + apply eq_None_not_Some in Ai'. + unfold_lookups. rewrite Ai. destruct ti; eauto. congruence. } + assert (NOmega.lt_nat_l (i + 1) len) as LT'. + { destruct len; try done; simpl in *. + destruct (decide (i + 1 < n0)); auto. destruct n. f_equal. lia. } + left. + apply proj2 in Ai'. specialize (Ai' LT'). destruct Ai' as [ti' Ai']. + unfold_lookups. rewrite Ai. + destruct ti; simpl in *; eauto. congruence. + Qed. + + Lemma trace_lookup_dom (tr: trace St L) (len: nat_omega) + (LEN: trace_len_is tr len): + forall i, is_Some (tr !! i) <-> NOmega.lt_nat_l i len. + Proof using. + intros i. destruct (trace_lookup_trichotomy _ _ LEN i) as [LT | [EQ | GT]]. + - destruct LT as (?&?&?<&?). rewrite LT. + split; intros; auto. + destruct len; simpl in *; try lia. + - destruct EQ as (?&EQ&?). subst. + rewrite EQ. split; simpl in *; intros; auto. lia. + - destruct GT as [GT ?]. split; intros. + + rewrite GT in H0. by destruct H0. + + lia_NO len. + Qed. + + Lemma trace_lookup_dom_neg (tr : trace St L) (len : nat_omega) + (LEN: trace_len_is tr len): + ∀ i, tr !! i = None ↔ NOmega.le len (NOnum i). + Proof. + intros. erewrite <- trace_len_neg; eauto. + unfold_lookups. destruct after; [destruct t| ]; done. + Qed. + + Lemma trace_lookup_dom_strong (tr: trace St L) (len: nat_omega) + (LEN: trace_len_is tr len): + forall i, (exists st ℓ st', tr !! i = Some (st, Some (ℓ, st'))) <-> NOmega.lt_nat_l (i + 1) len. + Proof using. + intros i. destruct (trace_lookup_trichotomy _ _ LEN i) as [LT | [EQ | GT]]. + - destruct LT as (?&?&?<&?). rewrite LT. + split; intros; eauto. + - destruct EQ as (?&->&?). + subst. split; intros. + + destruct H as (?&?&?&?). congruence. + + simpl in *; lia. + - destruct len; try done; simpl in *. + + tauto. + + destruct GT as [-> ?]. split. + * by intros (?&?&?&?). + * lia. + Qed. + + Lemma trace_lookup_dom_eq (tr: trace St L) (len: nat_omega) + (LEN: trace_len_is tr len): + forall i, (exists st, tr !! i = Some (st, None)) <-> len = NOnum (i + 1). + Proof using. + intros i. destruct (trace_lookup_trichotomy _ _ LEN i) as [LT | [EQ | GT]]. + - destruct LT as (?&?&?<&?). rewrite LT. split; intros. + + by destruct H0. + + subst. simpl in *; lia. + - destruct EQ as (?&->&?). split; intros; eauto. + - destruct len; try done; simpl in *. + + tauto. + + destruct GT as [-> ?]. split. + * by intros (?&?). + * intros [=]. lia. + Qed. + + Lemma state_label_lookup (tr: trace St L): + forall i st st' ℓ, + tr !! i = Some (st, Some (ℓ, st')) <-> + (tr S!! i = Some st /\ tr S!! (i + 1) = Some st' /\ tr L!! i = Some ℓ). + Proof using. + intros. unfold_lookups. rewrite after_sum'. + destruct (after i tr); simpl. + 2: { split; [intros [=] | intros [[=] _]]. } + destruct t; auto. + { split; [intros [=] | intros [_ [[=] _]]]. } + simpl. split; intros. + - inversion H. subst. split; auto. destruct t; auto. + - destruct t; destruct H as ([=] & [=] & [=]); subst; auto. + Qed. + + Lemma state_lookup_dom (tr: trace St L) (len: nat_omega) + (LEN: trace_len_is tr len): + forall i, is_Some (tr S!! i) <-> NOmega.lt_nat_l i len. + Proof using. + intros. etransitivity; [| apply trace_lookup_dom]; eauto. + unfold_lookups. destruct (after i tr); try done. + 2: { split; by intros []. } + by destruct t. + Qed. + + Lemma state_lookup_dom_neg (tr: trace St L) (len: nat_omega) + (LEN: trace_len_is tr len): + forall i, tr S!! i = None <-> NOmega.le len (NOnum i). + Proof using. + intros i. + pose proof (state_lookup_dom _ _ LEN i) as EQUIV. + apply not_iff_compat in EQUIV. + by rewrite -eq_None_not_Some -NOmega.le_iff_not_lt_nat in EQUIV. + Qed. + + Lemma label_lookup_dom (tr: trace St L) (len: nat_omega) + (LEN: trace_len_is tr len): + forall i, is_Some (tr L!! i) <-> NOmega.lt_nat_l (i + 1) len. + Proof using. + intros. rewrite /label_lookup. + pose proof (trace_lookup_trichotomy _ _ LEN i) as X. rewrite /lookup /trace_lookup in X. + destruct X as [LT | [EQ | GT]]. + - destruct LT as (?&?&?<&?). rewrite LT. done. + - destruct EQ as (?&->&->). simpl. split; [by intros []| lia]. + - destruct GT as [-> ?]. + lia_NO' len. split; [by intros []| lia]. + Qed. + + Lemma state_lookup_prev (tr: trace St L) i (DOM: is_Some (tr S!! i)): + forall j (LE: j <= i), is_Some (tr S!! j). + Proof using. + intros. pose proof (trace_has_len tr) as [len ?]. + eapply state_lookup_dom in DOM; eauto. + eapply state_lookup_dom; eauto. destruct len; eauto. simpl in *. lia. + Qed. + + Lemma label_lookup_prev (tr : trace St L) i (DOM: is_Some (tr L!! i)): + ∀ j (LE: j ≤ i), is_Some (tr L!! j). + Proof using. + intros. pose proof (trace_has_len tr) as [len ?]. + eapply label_lookup_dom in DOM; eauto. + eapply label_lookup_dom; eauto. destruct len; eauto. simpl in *. lia. + Qed. + + Lemma label_lookup_states (tr: trace St L): + forall i, is_Some (tr L!! i) <-> is_Some (tr S!! i) /\ is_Some (tr S!! (i + 1)). + Proof using. + pose proof (trace_has_len tr) as [len ?]. + intros. etransitivity; [apply label_lookup_dom| ]; eauto. + etransitivity; [symmetry; eapply state_lookup_dom| ]; eauto. + split; try tauto. intros. split; auto. + eapply state_lookup_prev; eauto. lia. + Qed. + + Lemma label_lookup_states' (tr: trace St L): + forall i, is_Some (tr L!! i) <-> is_Some (tr S!! (S i)). + Proof using. + intros. rewrite label_lookup_states. + rewrite Nat.add_1_r. rewrite and_comm iff_and_impl_helper; [done| ]. + intros. eapply state_lookup_prev; eauto. + Qed. + + Lemma next_state_lookup (tr: trace St L): + forall i, is_Some (tr S!! (S i)) <-> is_Some (tr S!! i) /\ is_Some (tr L!! i). + Proof using. + intros. rewrite label_lookup_states. rewrite Nat.add_1_r. + split; [| tauto]. intros. apply and_assoc. split; eauto. + rewrite and_idemp. eapply state_lookup_prev; eauto. + Qed. + + Lemma pred_at_trace_lookup (tr: trace St L) (i: nat) P: + pred_at tr i P <-> exists st, tr S!! i = Some st /\ P st (tr L!! i). + Proof using. + destruct (trace_has_len tr) as [len LEN]. + rewrite /state_lookup /label_lookup /trace_lookup_impl. + rewrite /pred_at. destruct (after i tr) eqn:Ai. + 2: { split; intros; try done. by destruct H as [? [[=] ?]]. } + destruct t; split; intros; eauto; destruct H as [? [[=] ?]]; congruence. + Qed. + + Lemma pred_at_trace_lookup' (tr : trace St L) (i : nat) (P : St → option L → Prop): + pred_at tr i P ↔ exists s step, tr !! i = Some (s, step) /\ + P s (from_option (Some ∘ fst) None step). + Proof. + rewrite pred_at_trace_lookup. + pose proof (trace_has_len tr) as [len LEN]. + destruct (trace_lookup_trichotomy _ _ LEN i) as [T|[T|T]]. + - destruct T as (?&?&?&ITH&?). + rewrite ITH. + rewrite /lookup /trace_lookup in ITH. + rewrite /lookup /state_lookup /label_lookup. + rewrite ITH. split. + + intros (?&[=->]&?). eauto. + + intros (?&?&[=->]&?). subst. eauto. + - destruct T as (?&ITH&->). + rewrite ITH. + rewrite /lookup /trace_lookup in ITH. + rewrite /lookup /state_lookup /label_lookup. + rewrite ITH. split. + + intros (?&[=->]&?). eauto. + + intros (?&?&[=]&?). subst. eauto. + - destruct T as [ITH ?]. rewrite ITH. + rewrite /lookup /trace_lookup in ITH. + rewrite /lookup /state_lookup /label_lookup. + rewrite ITH. split. + + by intros (?&[=]&?). + + by intros (?&?&[=]&?). + Qed. + + Lemma inf_trace_lookup (tr: trace St L) + (INF: trace_len_is tr NOinfinity): + forall i, exists c1 ℓ c2, tr !! i = Some (c1, Some (ℓ, c2)). + Proof. + intros. eapply trace_lookup_dom_strong; done. + Qed. + + Lemma trace_lookup_cons s l (tr: trace St L) i: + (s -[ l ]-> tr) !! S i = tr !! i. + Proof. done. Qed. + + Lemma trace_state_lookup_simpl (tr: trace St L) i s' step s + (TLi: tr !! i = Some (s', step)) + (SLi: tr S!! i = Some s): + s' = s. + Proof. + rewrite /state_lookup in SLi. rewrite /lookup /trace_lookup in TLi. + destruct (trace_lookup_impl tr i) as [[??]|]; congruence. + Qed. + + Lemma trace_lookup_0_cons s ℓ (tr: trace St L): + (s -[ℓ]-> tr) !! 0 = Some (s, Some (ℓ, trfirst tr)). + Proof. done. Qed. + + Lemma state_lookup_cons s l (tr: trace St L) i: + (s -[ l ]-> tr) S!! S i = tr S!! i. + Proof. done. Qed. + + Lemma label_lookup_cons s l (tr: trace St L) i: + (s -[ l ]-> tr) S!! S i = tr S!! i. + Proof. done. Qed. + + Lemma trace_label_lookup_simpl (tr: trace St L) i step ℓ + (TLi: tr !! i = Some step) + (SLi: tr L!! i = Some ℓ): + exists s1 s2, step = (s1, Some (ℓ, s2)). + Proof. + rewrite /label_lookup /trace_lookup_impl in SLi. rewrite /lookup /trace_lookup /trace_lookup_impl in TLi. + destruct (after i tr); try done. + destruct t; try done. inversion SLi. inversion TLi. subst. eauto. + Qed. + + Lemma state_lookup_0 (tr: trace St L): + tr S!! 0 = Some (trfirst tr). + Proof. by destruct tr. Qed. + + Lemma label_lookup_0 st ℓ (tr: trace St L): + (st -[ℓ]-> tr) L!! 0 = Some ℓ. + Proof. done. Qed. + + Lemma trace_state_lookup_simpl' (tr: trace St L) i st: + (exists step, tr !! i = Some step /\ fst step = st) <-> tr S!! i = Some st. + Proof. + unfold_lookups. + destruct after. + 2: { split; [intros (?&?&?) | intros ?]; done. } + destruct t. + all: split; [intros ([??]&?&?) | intros [=]]; simpl in *; subst. + all: congruence || eauto. + Qed. + + Lemma trace_state_lookup (tr: trace St L) i st ostep + (ITH: tr !! i = Some (st, ostep)): + tr S!! i = Some st. + Proof. + eapply trace_state_lookup_simpl'; eauto. + Qed. + + Lemma trace_label_lookup_simpl' (tr: trace St L) i ℓ: + (exists s1 s2, tr !! i = Some (s1, Some (ℓ, s2))) <-> tr L!! i = Some ℓ. + Proof. + split. + { intros (?&?&?%state_label_lookup). tauto. } + unfold_lookups. + destruct after; [| done]. + destruct t; [done| ]. intros [=->]. eauto. + Qed. + + Lemma trace_lookup_0_singleton (s: St): + (⟨ s ⟩: trace St L) !! 0 = Some (s, None). + Proof. done. Qed. + + Lemma trace_lookup_0 (tr: trace St L): + exists ostep, tr !! 0 = Some (trfirst tr, ostep). + Proof. + destruct tr; eauto. + Qed. + + Lemma trace_lookup_0_Some (tr: trace St L): + is_Some (tr !! 0). + Proof. + pose proof (trace_has_len tr) as [len LEN]. + eapply trace_lookup_dom; eauto. + eapply trace_len_gt_0; eauto. + Qed. + +End TraceLookup. + +Notation "tr S!! i" := (state_lookup tr i) (at level 20). +Notation "tr L!! i" := (label_lookup tr i) (at level 20). + + +Section After. + Context {St L: Type}. + + Local Ltac unfold_lookups := + rewrite /lookup /state_lookup /label_lookup /trace_lookup. + + Lemma trace_lookup_after (tr atr: trace St L) (a: nat) + (AFTER: after a tr = Some atr): + forall k, atr !! k = tr !! (a + k). + Proof. + intros. unfold_lookups. + rewrite after_sum'. by rewrite AFTER. + Qed. + + Lemma state_lookup_after (tr atr: trace St L) (a: nat) + (AFTER: after a tr = Some atr): + forall k, atr S!! k = tr S!! (a + k). + Proof. + intros. unfold_lookups. + rewrite after_sum'. by rewrite AFTER. + Qed. + + Lemma label_lookup_after (tr atr: trace St L) (a: nat) + (AFTER: after a tr = Some atr): + forall k, atr L!! k = tr L!! (a + k). + Proof. + intros. unfold_lookups. + rewrite after_sum'. by rewrite AFTER. + Qed. + + Lemma state_lookup_after_0 (tr atr : trace St L) n + (AFTER: after n tr = Some atr): + tr S!! n = Some (trfirst atr). + Proof. + rewrite -(Nat.add_0_r n). + erewrite <- state_lookup_after; eauto. + apply state_lookup_0. + Qed. + + Lemma state_lookup_after' (tr: trace St L) n st: + (exists atr, after n tr = Some atr /\ trfirst atr = st) <-> tr S!! n = Some st. + Proof. + destruct (after n tr) as [atr| ] eqn:AFTER. + 2: { split; [by intros (?&?&?)| ]. + pose proof (trace_has_len tr) as [len ?]. + eintros ?%mk_is_Some%state_lookup_dom; eauto. + eapply trace_len_neg in AFTER; eauto. lia_NO len. } + erewrite state_lookup_after_0; eauto. + split. + - intros (?&[=->]&?). congruence. + - intros [=]. eauto. + Qed. + + Lemma trace_lookup_after_strong (tr: trace St L) s1 ℓ s2 n: + (exists atr', after n tr = Some (s1 -[ℓ]-> atr') /\ trfirst atr' = s2) <-> tr !! n = Some (s1, Some (ℓ, s2)). + Proof. + destruct (after n tr) as [atr| ] eqn:AFTER. + 2: { split; [by intros (?&?&?)| ]. + pose proof (trace_has_len tr) as [len LEN]. + intros NTH. + opose proof * (proj1 (trace_lookup_dom_strong _ _ LEN n)); eauto. + eapply trace_len_neg in AFTER; eauto. lia_NO' len. } + + rewrite /lookup /trace_lookup AFTER. + split. + - intros (?&[=->]&?). congruence. + - intros EQ. destruct atr; [congruence| ]. + inversion EQ. subst. eauto. + Qed. + + Lemma trace_lookup_after_weak (tr: trace St L) s n: + (exists atr, after n tr = Some atr /\ trfirst atr = s) <-> exists ostep, tr !! n = Some (s, ostep). + Proof. + rewrite /lookup /trace_lookup. + destruct after. + 2: { by split; [intros (?&?&?)| intros (?&?)]. } + transitivity (trfirst t = s). + { split; eauto. by intros (?&[=->]&?). } + destruct t; simpl; eauto. + all: split; [intros ->| intros (?&[=])]; eauto. + Qed. + + Lemma trace_lookup_prev (tr: trace St L) i st2 ostep + (ITH': tr !! S i = Some (st2, ostep)): + exists st1 l, tr !! i = Some (st1, Some (l, st2)). + Proof. + pose proof (trace_has_len tr) as [len LEN]. + opose proof * (proj2 (trace_lookup_dom_strong _ _ LEN i)) as X. + { eapply trace_lookup_dom; eauto. + by rewrite Nat.add_1_r. } + destruct X as (?&?&st'&ITH). + enough (st' = st2). + { subst. eauto. } + apply state_label_lookup in ITH as (?&ITH'_&?). + rewrite Nat.add_1_r in ITH'_. + symmetry. + eapply trace_state_lookup_simpl; eauto. + Qed. + +End After. + + +Section TracesMatch. + Context {L1 L2 S1 S2: Type}. + Context {Rℓ : L1 → L2 → Prop}. + Context {Rs : S1 → S2 → Prop}. + Context {trans1 : S1 → L1 → S1 → Prop}. + Context {trans2 : S2 → L2 → S2 → Prop}. + + + Lemma traces_match_trace_lookup_general + (tr1 : trace S1 L1) (tr2 : trace S2 L2) (n : nat) + (MATCH: traces_match Rℓ Rs trans1 trans2 tr1 tr2): + match tr1 !! n, tr2 !! n with + | Some step1, Some step2 => + Rs (fst step1) (fst step2) /\ + match snd step1, snd step2 with + | Some (ℓ1, s1'), Some (ℓ2, s2') => Rℓ ℓ1 ℓ2 /\ Rs s1' s2' + | None, None => True + | _, _ => False + end + | None, None => True + | _ , _ => False + end. + Proof. + pose proof (trace_has_len tr1) as [len LEN1]. pose proof (trace_has_len tr2) as [? LEN2]. + opose proof * (traces_match_same_length _ _ _ _ tr1 tr2) as X; eauto. subst x. + destruct (tr1 !! n) as [[s1 step1]| ] eqn:STEP1, (tr2 !! n) as [[s2 step2]| ] eqn:STEP2. + 4: done. + 3: { eapply mk_is_Some, trace_lookup_dom in STEP2; eauto. + eapply trace_lookup_dom_neg in STEP1; eauto. + lia_NO len. } + 2: { eapply mk_is_Some, trace_lookup_dom in STEP1; eauto. + eapply trace_lookup_dom_neg in STEP2; eauto. + lia_NO len. } + + opose proof * (proj1 (trace_state_lookup_simpl' tr1 n s1)) as ST1; eauto. + opose proof * (proj1 (trace_state_lookup_simpl' tr2 n s2)) as ST2; eauto. + simpl in *. + pose proof (proj2 (state_lookup_after' _ _ _) ST1) as (atr1 & AFTER1 & A1). + opose proof * (traces_match_after' _ _ _ _ tr1 tr2) as X; eauto. + destruct X as (atr2 & AFTER2 & A2). + split. + { apply traces_match_first in A2. + erewrite state_lookup_after_0 in ST1; eauto. + erewrite state_lookup_after_0 in ST2; eauto. + congruence. } + destruct step1 as [[ℓ1 s1']| ], step2 as [[ℓ2 s2']| ]. + 4: done. + 3: { opose proof * (proj1 (trace_lookup_dom_strong _ _ LEN2 n)); eauto. + opose proof * (proj1 (trace_lookup_dom_eq _ _ LEN1 n)); eauto. + lia_NO' len. inversion H0. lia. } + 2: { opose proof * (proj1 (trace_lookup_dom_strong _ _ LEN1 n)); eauto. + opose proof * (proj1 (trace_lookup_dom_eq _ _ LEN2 n)); eauto. + lia_NO' len. inversion H0. lia. } + + apply trace_lookup_after_strong in STEP1 as (?&AFTER1'&?), STEP2 as (?&AFTER2'&?). + erewrite AFTER1' in AFTER1. rewrite AFTER2' in AFTER2. + inversion AFTER1. inversion AFTER2. subst atr1 atr2. + inversion A2. subst. split; eauto. + eapply traces_match_first; eauto. + Qed. + + Lemma traces_match_state_lookup_1 + (tr1 : trace S1 L1) (tr2 : trace S2 L2) (n : nat) st1 + (MATCH: traces_match Rℓ Rs trans1 trans2 tr1 tr2) + (ST1: tr1 S!! n = Some st1): + exists st2, tr2 S!! n = Some st2 /\ Rs st1 st2. + Proof. + apply trace_state_lookup_simpl' in ST1 as ([s1 ostep1] & NTH1 & <-). + pose proof (traces_match_trace_lookup_general _ _ n MATCH) as STEPS. + rewrite NTH1 in STEPS. + destruct (tr2 !! n) as [[s2 ostep2]|] eqn:NTH2; [| done]. simpl in *. + destruct STEPS. eexists. split; eauto. + eapply trace_state_lookup_simpl'; eauto. + Qed. + + Lemma traces_match_state_lookup_2 + (tr1 : trace S1 L1) (tr2 : trace S2 L2) (n : nat) st2 + (MATCH: traces_match Rℓ Rs trans1 trans2 tr1 tr2) + (ST2: tr2 S!! n = Some st2): + exists st1, tr1 S!! n = Some st1 /\ Rs st1 st2. + Proof. + apply trace_state_lookup_simpl' in ST2 as ([s2 ostep2] & NTH2 & <-). + pose proof (traces_match_trace_lookup_general _ _ n MATCH) as STEPS. + rewrite NTH2 in STEPS. + destruct (tr1 !! n) as [[s1 ostep1]|] eqn:NTH1; [| done]. simpl in *. + destruct STEPS. eexists. split; eauto. + eapply trace_state_lookup_simpl'; eauto. + Qed. + + Lemma traces_match_label_lookup_1 + (tr1 : trace S1 L1) (tr2 : trace S2 L2) (n : nat) ℓ1 + (MATCH: traces_match Rℓ Rs trans1 trans2 tr1 tr2) + (LBL1: tr1 L!! n = Some ℓ1): + exists ℓ2, tr2 L!! n = Some ℓ2 /\ Rℓ ℓ1 ℓ2. + Proof. + apply trace_label_lookup_simpl' in LBL1 as (s & s' & NTH1). + pose proof (traces_match_trace_lookup_general _ _ n MATCH) as STEPS. + rewrite NTH1 in STEPS. + destruct (tr2 !! n) as [[s2 ostep2]|] eqn:NTH2; [| done]. simpl in *. + destruct ostep2 as [[??]|]; [| tauto]. destruct STEPS as (?&?&?). + eexists. split; eauto. + eapply trace_label_lookup_simpl'; eauto. + Qed. + + Lemma traces_match_label_lookup_2 + (tr1 : trace S1 L1) (tr2 : trace S2 L2) (n : nat) ℓ2 + (MATCH: traces_match Rℓ Rs trans1 trans2 tr1 tr2) + (LBL2: tr2 L!! n = Some ℓ2): + exists ℓ1, tr1 L!! n = Some ℓ1 /\ Rℓ ℓ1 ℓ2. + Proof. + apply trace_label_lookup_simpl' in LBL2 as (s & s' & NTH2). + pose proof (traces_match_trace_lookup_general _ _ n MATCH) as STEPS. + rewrite NTH2 in STEPS. + destruct (tr1 !! n) as [[s1 ostep1]|] eqn:NTH1; [| done]. simpl in *. + destruct ostep1 as [[??]|]; [| tauto]. destruct STEPS as (?&?&?). + eexists. split; eauto. + eapply trace_label_lookup_simpl'; eauto. + Qed. + +End TracesMatch. + + +Section UptoStutter. + Context {St S' L L' : Type}. + Context {Us : St → S'}. + Context {Usls: St -> L -> St -> option L'}. + + Lemma upto_stutter_trace_label_lookup {btr : trace St L} {str : trace S' L'} + (n : nat) st ℓ st' l: + upto_stutter Us Usls btr str → + btr !! n = Some (st, Some (ℓ, st')) -> + Usls st ℓ st' = Some l -> + ∃ (n' : nat), str L!! n' = Some l. + Proof. + intros UPTO NTH MATCH. + pose proof (trace_has_len btr) as [? LEN]. + apply trace_lookup_after_strong in NTH as (atr' & AFTER & A0). + ogeneralize * (upto_stutter_after' _ _ n UPTO); eauto. + intros (n' & str' & AFTER' & UPTOn). + exists n'. + rewrite -(Nat.add_0_r n'). erewrite <- label_lookup_after; eauto. + punfold UPTOn; [| by apply upto_stutter_mono]. + inversion UPTOn; subst; try congruence. + rewrite label_lookup_0. congruence. + Qed. + + Lemma upto_stutter_state_lookup {btr : trace St L} {str : trace S' L'} n' st': + upto_stutter Us Usls btr str + → str S!! n' = Some st' -> + ∃ n st, btr S!! n = Some st /\ Us st = st'. + Proof. + intros UPTO NTH. + pose proof (trace_has_len str) as [? LEN]. + pose proof (proj1 (state_lookup_dom _ _ LEN n') (mk_is_Some _ _ NTH)) as BOUND. + pose proof (proj2 (LEN _) BOUND) as [str_n AFTER]. + ogeneralize * (upto_stutter_after _ _ n' UPTO); eauto. + intros (n & btr' & AFTER' & UPTOn). + exists n. + rewrite -(Nat.add_0_r n). erewrite <- state_lookup_after; eauto. + rewrite state_lookup_0. f_equal. + eexists. split; [reflexivity| ]. + etransitivity. + { symmetry. eapply upto_stutter_trfirst; eauto. } + apply Some_inj. rewrite -state_lookup_0. + erewrite state_lookup_after; eauto. by rewrite Nat.add_0_r. + Qed. + + Lemma upto_stutter_state_lookup' {btr : trace St L} {str : trace S' L'} (n : nat) bst: + upto_stutter Us Usls btr str + → btr S!! n = Some bst -> + ∃ (n' : nat), + str S!! n' = Some (Us bst). + Proof. + intros UPTO NTH. + pose proof (trace_has_len btr) as [? LEN]. + pose proof (proj1 (state_lookup_dom _ _ LEN n) (mk_is_Some _ _ NTH)) as BOUND. + pose proof (proj2 (LEN _) BOUND) as [btr_n AFTER]. + ogeneralize * (upto_stutter_after' _ _ n UPTO); eauto. + intros (n' & str' & AFTER' & UPTOn). + exists n'. + rewrite -(Nat.add_0_r n'). erewrite <- state_lookup_after; eauto. + rewrite state_lookup_0. f_equal. + erewrite upto_stutter_trfirst; [..| apply UPTOn]; eauto. + f_equal. apply Some_inj. + rewrite -state_lookup_0. + erewrite state_lookup_after; eauto. by rewrite Nat.add_0_r. + Qed. + +End UptoStutter. + + +Section ValidTracesProperties. + Context {St L: Type}. + Context (trans: St -> L -> St -> Prop). + + Context (tr: trace St L). + Hypothesis VALID: trace_valid trans tr. + + Local Ltac gd t := generalize dependent t. + + Lemma trace_valid_steps' i st ℓ st' + (ITH: tr !! i = Some (st, Some (ℓ, st'))): + trans st ℓ st'. + Proof using VALID. + gd st. gd ℓ. gd st'. gd tr. clear dependent tr. + induction i. + { simpl. intros. punfold VALID. inversion VALID. + 3: { by apply trace_valid_mono. } + - subst. done. + - subst. inversion ITH. by subst. } + intros. simpl in ITH. + destruct tr. + { inversion ITH. } + punfold VALID; [| by apply trace_valid_mono]. + inversion_clear VALID; pclearbot; auto. + eapply IHi; eauto. + Qed. + + Lemma trace_valid_steps'' i st ℓ st' + (ST1: tr S!! i = Some st) + (ST2: tr S!! (i + 1) = Some st') + (LBL: tr L!! i = Some ℓ): + trans st ℓ st'. + Proof using VALID. + eapply trace_valid_steps'. + apply state_label_lookup. eauto. + Qed. + +End ValidTracesProperties. diff --git a/fairness/trace_utils.v b/fairness/trace_utils.v new file mode 100644 index 0000000..9f8d1b3 --- /dev/null +++ b/fairness/trace_utils.v @@ -0,0 +1,275 @@ +From stdpp Require Import option. +From Paco Require Import paco1 paco2 pacotac. +From fairness Require Export inftraces. +Import stdpp.ssreflect. +From trillium Require Import traces. + +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. + set (Hh:= Hf (k+n)). + assert (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 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_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. + +Definition to_trace_trfirst {S L : Type} + (s: S) (il: inflist (L * S)): + trfirst (to_trace s il) = s. +Proof. + destruct il as [| [??]]; done. +Qed. diff --git a/fairness/traces_match.v b/fairness/traces_match.v new file mode 100644 index 0000000..4b12392 --- /dev/null +++ b/fairness/traces_match.v @@ -0,0 +1,100 @@ +From iris.proofmode Require Import tactics. +From trillium Require Import language. +From fairness Require Import inftraces fairness. + + +Section TracesMatch. + Context `{Λ: language}. + Context `{M: Model}. + + Let model_trace := trace (mstate M) (mlabel M). + + Context (evolution_pred: cfg Λ -> olocale Λ → cfg Λ → + M → mlabel M → M -> Prop). + + Context (state_rel: cfg Λ -> mstate M -> Prop). + Context (lbl_rel: olocale Λ -> mlabel M -> Prop). + Hypothesis (LBL_REL_EV: forall c1 oζ c2 δ1 ℓ δ2, + evolution_pred c1 oζ c2 δ1 ℓ δ2 -> + lbl_rel oζ ℓ). + Hypothesis (STEP_EV: forall c1 oζ c2 δ1 ℓ δ2, + evolution_pred c1 oζ c2 δ1 ℓ δ2 -> + mtrans δ1 ℓ δ2). + + Definition exaux_traces_match: + extrace Λ → model_trace → Prop := + traces_match lbl_rel + state_rel + locale_step + (@mtrans M). + + Lemma valid_inf_system_trace_implies_traces_match_strong' + (φ : execution_trace Λ -> auxiliary_trace M -> Prop) + ex atr iex iatr progtr (auxtr : model_trace): + (forall (ex: execution_trace Λ) (atr: auxiliary_trace M), + φ ex atr -> state_rel (trace_last ex) (trace_last atr)) -> + (forall (ex: execution_trace Λ) (oζ: olocale Λ) (c: cfg Λ) + (atr: auxiliary_trace M) (ℓ: mlabel M) (δ: mstate M), + φ (ex :tr[ oζ ]: c) (atr :tr[ ℓ ]: δ) -> + evolution_pred (trace_last ex) oζ c (trace_last atr) ℓ δ) -> + exec_trace_match ex iex progtr -> + exec_trace_match atr iatr auxtr -> + valid_inf_system_trace φ ex atr iex iatr -> + traces_match lbl_rel + state_rel + locale_step + (@mtrans M) 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'. + specialize (Hφ2 _ _ _ _ _ _ Hphi') as STEP. + econstructor. + + eapply LBL_REL_EV; 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; eapply STEP_EV; eauto. + + eapply IH; eauto. + Qed. + + + Definition valid_state_evolution_fairness + (extr : execution_trace Λ) (auxtr : auxiliary_trace M) := + match extr, auxtr with + | (extr :tr[oζ]: (es, σ)), auxtr :tr[ℓ]: δ => + evolution_pred (trace_last extr) oζ (es, σ) (trace_last auxtr) ℓ δ + | _, _ => True + end. + + (* TODO: this should already be covered by .._strong' lemma above *) + Lemma valid_inf_system_trace_implies_traces_match + (φ : execution_trace Λ -> auxiliary_trace M -> Prop) + ex atr iex iatr progtr (auxtr : model_trace): + (forall (ex: execution_trace Λ) (atr: auxiliary_trace M), + φ ex atr -> state_rel (trace_last ex) (trace_last atr)) -> + (forall (ex: execution_trace Λ) (atr: auxiliary_trace M), + φ 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 -> + traces_match lbl_rel + state_rel + locale_step + (@mtrans M) progtr auxtr. + Proof. + intros. eapply valid_inf_system_trace_implies_traces_match_strong'; eauto. + intros. apply H0 in H4. red in H4. by destruct c. + Qed. + + +End TracesMatch. diff --git a/fairness/utils.v b/fairness/utils.v new file mode 100644 index 0000000..f6c14ee --- /dev/null +++ b/fairness/utils.v @@ -0,0 +1,164 @@ +From iris.algebra Require Import gmap gset. +From iris.proofmode Require Import tactics. +From trillium.prelude Require Import quantifiers finitary. +From fairness Require Export utils_logic utils_sets utils_maps utils_relations. + + +(* TODO: move these lemmas to appropriate places *) + +Section Disjoint. + + Lemma disjoint_subseteq: + ∀ {A C : Type} {H : ElemOf A C} {H0 : Empty C} {H1 : Singleton A C} + {H2 : Union C} {H3 : Intersection C} {H4 : Difference C}, + `{Set_ A C} → ∀ X1 X2 Y1 Y2: C, X1 ⊆ Y1 -> X2 ⊆ Y2 → Y1 ## Y2 -> X1 ## X2. + Proof. intros. set_solver. Qed. + +End Disjoint. + + +Lemma map_img_sets_split_helper `{Countable K, Countable A} (k: K) (m: gmap K (gset A)): + flatten_gset $ map_img m = default ∅ (m !! k) ∪ (flatten_gset $ map_img (delete k m)). +Proof using. + rewrite {1}(map_split m k). rewrite map_img_union_disjoint_L. + 2: { destruct (m !! k) eqn:KTH; simpl. + all: apply map_disjoint_dom; set_solver. } + rewrite flatten_gset_union. f_equal. + destruct (m !! k) eqn:KTH; simpl. + - by rewrite map_img_singleton_L flatten_gset_singleton. + - by rewrite map_img_empty_L flatten_gset_empty. +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. + + Lemma big_opM_fmap_singletons + {B: cmra} (m : gmap K A) (f: A -> B) + (LE: LeibnizEquiv B): + ([^ op map] k↦x ∈ m, f <$> {[k := x]}) = (f <$> m: gmap K B). + Proof. + intros. pattern m. apply map_ind. + { rewrite big_opM_empty fmap_empty. done. } + intros. + rewrite insert_union_singleton_l. + apply leibniz_equiv. + rewrite big_opM_union. + 2: { by apply map_disjoint_singleton_l_2. } + rewrite H1. rewrite big_opM_singleton. + rewrite map_fmap_union. rewrite !map_fmap_singleton /=. + apply leibniz_equiv_iff. apply gmap_disj_op_union. + apply map_disjoint_singleton_l_2. rewrite lookup_fmap H0. done. + Qed. + + Lemma big_opM_insert_delete': + ∀ {M : ofe} {o : M → M → M} {Monoid0 : Monoid o} + {B : Type} + (f : K → B → M) (m : gmap K B) (i : K) (x : B), + m !! i = Some x -> + ([^ o map] k↦y ∈ m, f k y) + ≡ o (f i x) ([^ o map] k↦y ∈ delete i m, f k y). + Proof. + intros. rewrite -big_opM_insert_delete. + symmetry. eapply big_opM_insert_override; eauto. + Qed. + +End bigop_utils. + + + +Lemma fmap_flat_map {A B C: Type} (f : A → list B) (g: B -> C) (l : list A): + g <$> (flat_map f l) = flat_map ((fmap g) ∘ f) l. +Proof. + induction l; [done| ]. + simpl. rewrite fmap_app. congruence. +Qed. + +Lemma concat_NoDup {A: Type} (ll : list (list A)): + (forall i l, ll !! i = Some l -> NoDup l) -> + (forall i j li lj, i ≠ j -> ll !! i = Some li -> ll !! j = Some lj -> li ## lj) -> + NoDup (concat ll). +Proof. + induction ll. + { constructor. } + intros. simpl. apply NoDup_app. repeat split. + { apply (H 0). done. } + 2: { apply IHll. + - intros. apply (H (S i)). done. + - intros. apply (H0 (S i) (S j)); auto. } + intros. intros [lx [INlx INx]]%elem_of_list_In%in_concat. + apply elem_of_list_In, elem_of_list_lookup_1 in INlx as [ix IX]. + eapply (H0 0 (S ix)). + - lia. + - simpl. reflexivity. + - simpl. apply IX. + - eauto. + - by apply elem_of_list_In. +Qed. + + +Ltac add_case C name := + match goal with + | |- ?G => assert (C -> G) as name + end. + + +Section Arithmetic. + + Lemma even_succ_negb n: Nat.even (S n) = negb $ Nat.even n. + Proof. by rewrite Nat.even_succ Nat.negb_even. Qed. + + Lemma odd_succ_negb n: Nat.odd (S n) = negb $ Nat.odd n. + Proof. by rewrite Nat.odd_succ Nat.negb_odd. Qed. + + Lemma even_plus1_negb n: Nat.even (n + 1) = negb $ Nat.even n. + Proof. by rewrite Nat.add_1_r even_succ_negb. Qed. + + Lemma odd_plus1_negb n: Nat.odd (n + 1) = negb $ Nat.odd n. + Proof. by rewrite Nat.add_1_r odd_succ_negb. Qed. + + 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. + + Lemma even_or_odd n: Nat.even n \/ Nat.odd n. + Proof. + destruct (decide (Nat.even n)) as [| O]; auto. + apply negb_prop_intro in O. rewrite Nat.negb_even in O. tauto. + Qed. + +End Arithmetic. diff --git a/fairness/utils_logic.v b/fairness/utils_logic.v new file mode 100644 index 0000000..9ab3ae7 --- /dev/null +++ b/fairness/utils_logic.v @@ -0,0 +1,180 @@ +From Stdlib Require Import ClassicalFacts. +From Stdlib Require Import Lia. +From stdpp Require Import base option. + + +Section LogicHelpers. + + Lemma ex2_comm {A B: Type} (P: A -> B -> Prop): + (exists (a: A) (b: B), P a b) <-> (exists (b: B) (a: A), P a b). + Proof. + split; intros (?&?&?); eauto. + Qed. + + Lemma iff_and_impl_helper {A B: Prop} (AB: A -> B): + A /\ B <-> A. + Proof. tauto. Qed. + + Lemma iff_True_helper {A: Prop}: + (A <-> True) <-> A. + Proof. tauto. Qed. + + Lemma iff_False_helper {A: Prop}: + (A <-> False) <-> not A. + Proof. tauto. Qed. + + Lemma ex_and_comm {T: Type} (A: Prop) (B: T -> Prop): + (exists t, A /\ B t) <-> A /\ exists t, B t. + Proof. split; intros (?&?&?); eauto. Qed. + + Lemma ex_prod {A B: Type} (P: A * B -> Prop): + (exists ab, P ab) <-> (exists a b, P (a, b)). + Proof. + split. + - intros [[??] ?]. eauto. + - intros (?&?&?). eauto. + Qed. + + Lemma ex_prod' {A B: Type} (P: A -> B -> Prop): + (exists a b, P a b) <-> (exists ab, P (fst ab) (snd ab)). + Proof. + split. + - intros (?&?&?). eexists (_, _). eauto. + - intros [[??] ?]. eauto. + Qed. + + Lemma ex_proper3 {A B C: Prop} (P Q: A -> B -> C -> Prop) + (EQUIV: forall a b c, P a b c <-> Q a b c): + (exists a b c, P a b c) <-> (exists a b c, Q a b c). + Proof. + split; intros (?&?&?&?); do 3 eexists; apply EQUIV; eauto. + Qed. + + Lemma ex_det_iff {A: Type} (P: A -> Prop) a + (DET: forall a', P a' -> a' = a): + (exists a', P a') <-> P a. + Proof. + split; [| eauto]. + intros [? ?]. erewrite <- DET; eauto. + Qed. + + Lemma iff_and_pre {A B C: Prop} + (BC: A -> (B <-> C)): + A /\ B <-> A /\ C. + Proof using. tauto. Qed. + + Lemma curry_uncurry_prop {A B C: Prop}: + (A -> B -> C) <-> (A /\ B -> C). + Proof. tauto. Qed. + + Lemma forall_eq_gen {A: Type} (P: A -> Prop): + forall a, P a <-> (forall a', a' = a -> P a'). + Proof. + split; eauto. + intros ?? ->. eauto. + Qed. + + Lemma exist_impl_forall {A: Type} {P: A -> Prop} {Q: Prop}: + ((exists x, P x) -> Q) <-> (forall x, P x -> Q). + Proof using. + split. + - intros PQ x Px. eauto. + - intros PQ [x Px]. eauto. + Qed. + + Lemma forall_prod_helper {A B: Type} (P: A -> B -> Prop): + (forall a b, P a b) <-> (forall ab: A * B, P (fst ab) (snd ab)). + Proof. + split; eauto. intros PP ??. + apply (PP (a, b)). + Qed. + + Lemma impl_iff_intro {A B C: Prop} + (PRE: A -> B <-> C): + (A -> B) <-> (A -> C). + Proof using. tauto. Qed. + +End LogicHelpers. + + +Lemma min_prop_dec_impl (P: nat -> Prop) (DEC: forall n, Decision (P n)): + forall n, P n -> {m | Minimal P m}. +Proof. + intros n Pn. + + assert (forall p, p <= n + 1 -> ({m | Minimal P m} + {forall k, k < p -> ¬ P k})) as MIN'. + 2: { destruct (MIN' (n + 1)); eauto. edestruct n0; eauto. lia. } + + induction p. + { intros. right. lia. } + intros. destruct IHp; [lia| auto| ]. + rewrite PeanoNat.Nat.add_1_r in H. apply le_S_n in H. + destruct (DEC p). + - left. exists p. split; auto. intros. + destruct (PeanoNat.Nat.le_decidable p k); auto. + destruct (n0 k); auto. lia. + - right. intros. destruct (PeanoNat.Nat.eq_decidable k p); [congruence| ]. + apply n0. lia. +Qed. + +Lemma min_prop_dec (P: nat -> Prop) (DEC: forall n, Decision (P n)): + ClassicalFacts.Minimization_Property P. +Proof using. + red. intros ? Pn. + edestruct (min_prop_dec_impl _ _ _ Pn). eauto. +Qed. + +Global Instance Minimal_proper: + Proper (pointwise_relation nat iff ==> eq ==> iff) ClassicalFacts.Minimal. +Proof using. + red. red. intros. red. intros. subst. red in H. + split; intros [P MIN]. + all: split; [| intros; apply MIN]; apply H; auto. +Qed. + +Definition Minimal_pos (P: BinNums.positive → Prop) (n : BinNums.positive) := + P n ∧ (∀ k, P k → BinPos.Pos.le n k). + +Lemma min_prop_dec_impl_pos (P: BinNums.positive -> Prop) (DEC: forall n, Decision (P n)): + ∀ n, P n → {m: BinNums.positive | Minimal_pos P m }. +Proof. + intros n Pn. + epose proof (min_prop_dec_impl (P ∘ BinPos.Pos.of_nat) _ (BinPos.Pos.to_nat n)) as [m [Pm MINm]]. + { red. rewrite Pnat.Pos2Nat.id. auto. } + exists (BinPos.Pos.of_nat m). split; auto. + intros. + specialize (MINm (BinPos.Pos.to_nat k) ltac:(red; rewrite Pnat.Pos2Nat.id; eauto)). + lia. +Qed. + + +(* TODO: already exists somewhere? *) +Lemma Decision_iff_impl (P Q: Prop) (PQ: P <-> Q) (DEC_P: Decision P): + Decision Q. +Proof using. + destruct DEC_P; [left | right]; tauto. +Qed. + +Instance ex_fin_dec {T: Type} (P: T -> Prop) (l: list T) + (DEC: forall a, Decision (P a)) + (IN: forall a, P a -> In a l): + Decision (exists a, P a). +Proof. + destruct (Exists_dec P l) as [EX|NEX]. + { eauto. } + - left. apply List.Exists_exists in EX as (?&?&?). eauto. + - right. intros [a Pa]. apply NEX. + apply List.Exists_exists. eexists. split; eauto. +Qed. + +(** useful for rewriting in equivalences *) +Lemma is_Some_Some_True {A: Type} (a: A): + is_Some (Some a) <-> True. +Proof. done. Qed. + +(** useful for rewriting in equivalences *) +Lemma is_Some_None_False {A: Type}: + is_Some (None: option A) <-> False. +Proof. + split; [| done]. by intros []. +Qed. diff --git a/fairness/utils_maps.v b/fairness/utils_maps.v new file mode 100644 index 0000000..e2874bd --- /dev/null +++ b/fairness/utils_maps.v @@ -0,0 +1,407 @@ +From stdpp Require Import base. +From iris.proofmode Require Import tactics. +From fairness Require Export utils_logic. +From iris.algebra Require Import gmap gset agree. +From trillium.prelude Require Import finitary. + +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. + + Lemma gmap_disj_op_union: + ∀ {A : cmra} (m1 m2 : gmap K A), + map_disjoint m1 m2 -> m1 ⋅ m2 = m1 ∪ m2. + Proof using. + intros. apply map_eq. intros. + rewrite lookup_op lookup_union. + destruct (m1 !! i) eqn:L1, (m2 !! i) eqn:L2; try done. + eapply map_disjoint_spec in H; done. + Qed. + + Lemma map_split {A: Type} (m: gmap K A) k: + m = from_option (singletonM k) ∅ (m !! k) ∪ delete k m. + Proof using. + apply map_eq. intros k'. + destruct (decide (k' = k)) as [->|?]. + - destruct (m !! k) eqn:KTH. + + simpl. rewrite lookup_union_l'. + all: by rewrite lookup_singleton. + + simpl. rewrite lookup_union_r; [| done]. + by rewrite lookup_delete. + - rewrite lookup_union_r. + 2: { destruct (m !! k); [| set_solver]. + by rewrite lookup_singleton_ne. } + by rewrite lookup_delete_ne. + Qed. + + Lemma lookup_map_singleton {A: Type} (k: K) (a: A) k': + ({[ k := a ]}: gmap K A) !! k' = if (decide (k' = k)) then Some a else None. + Proof using. + destruct decide; subst. + - apply lookup_singleton. + - by apply lookup_singleton_ne. + Qed. + + Lemma map_fold_union + {V B: Type} + (m1 m2: gmap K V) + (f: K → V → B → B) + (b0: B) + (DISJ: map_disjoint m1 m2) + (ASSOC: forall a b c d e, f a b (f c d e) = f c d (f a b e)) + : + map_fold f b0 (m1 ∪ m2) = map_fold f (map_fold f b0 m1) m2. + Proof using. + clear -DISJ ASSOC. + revert DISJ. pattern m2. apply map_ind; clear m2. + { rewrite map_union_empty. rewrite map_fold_empty. done. } + intros ??? NOI IH DISJ. rewrite map_union_comm; [| set_solver]. + rewrite -insert_union_l. simpl. + rewrite map_fold_insert_L. + 3: { rewrite lookup_union_r; [| done]. + apply not_elem_of_dom. intros IN. + apply map_disjoint_dom in DISJ. + set_solver. } + 2: { done. } + apply map_disjoint_dom in DISJ. specialize (IH ltac:(apply map_disjoint_dom; set_solver)). + rewrite map_union_comm in IH. + 2: { apply map_disjoint_dom. set_solver. } + rewrite IH. + rewrite map_fold_insert_L; done. + Qed. + + Lemma gmap_filter_dom_id {A: Type} (m: gmap K A): + filter (fun '(k, _) => k ∈ dom m) m = m. + Proof. + rewrite map_filter_id; [done| ]. + intros. by eapply elem_of_dom_2. + Qed. + + Lemma gmap_empty_subseteq_equiv {A: Type} (m: gmap K A): + m ⊆ ∅ <-> m = ∅. + Proof. + clear. + split; [| set_solver]. + intros E. destruct (map_eq_dec_empty m); try set_solver. + apply map_choose in n as (?&?&?). + eapply lookup_weaken in E; set_solver. + Qed. + + Lemma gmap_filter_disj_id {A: Type} (m1 m2: gmap K A) + (DISJ: m1 ##ₘ m2): + m1 = filter (λ '(k, _), k ∈ dom m1) (m1 ∪ m2). + Proof. + rewrite map_filter_union; auto. + rewrite map_union_comm; [| by apply map_disjoint_filter]. + rewrite gmap_filter_dom_id. + symmetry. apply map_subseteq_union. etransitivity; [| apply map_empty_subseteq]. + apply gmap_empty_subseteq_equiv. + eapply map_filter_empty_iff. apply map_Forall_lookup_2. + intros. intros [? ?]%elem_of_dom. eapply map_disjoint_spec; eauto. + Qed. + +End gmap. + +Lemma map_img_insert_L : + ∀ {K : Type} {M : Type → Type} {H : FMap M} {H0 : ∀ A : Type, Lookup K A (M A)} + {H1 : ∀ A : Type, Empty (M A)} {H2 : ∀ A : Type, PartialAlter K A (M A)} + {H3 : OMap M} {H4 : Merge M} + {H5 : ∀ A : Type, MapFold K A (M A)} + {EqDecision0 : EqDecision K} + , + FinMap K M + → ∀ {A SA : Type} {H7 : ElemOf A SA} {H8 : Empty SA} + {H9 : Singleton A SA} {H10 : Union SA} {H11 : Intersection SA} + {H12 : Difference SA} + {LE: LeibnizEquiv SA} + , + Set_ A SA + → ∀ (m : M A) (i : K) (x : A), + map_img (<[i:=x]> m) = ({[x]}: SA) ∪ map_img (delete i m). +Proof. + intros. apply leibniz_equiv. apply map_img_insert. +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_filter_sub {K V: Type} `{Countable K} (m: gmap K V) + (ks: gset K): + dom (filter (λ '(k, _), k ∈ ks) m) ⊆ ks. +Proof. + apply elem_of_subseteq. + intros ? IN. rewrite elem_of_dom in IN. destruct IN as [? IN]. + apply map_lookup_filter_Some in IN. apply IN. +Qed. + +Lemma dom_filter_comm {K A: Type} `{Countable K} + (P: K -> Prop) `{∀ x : K, Decision (P x)}: + forall (m: gmap K A), dom (filter (fun '(k, _) => P k) m) = filter P (dom m). +Proof. + intros. apply leibniz_equiv. apply dom_filter. intros. + rewrite elem_of_filter elem_of_dom. + rewrite /is_Some. split; [intros [?[??]] | intros [? [??]]]; eauto. +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. + + +Lemma gmap_filter_or `{Countable K} {A: Type} (P1 P2: K * A -> Prop) + `{forall x, Decision (P1 x)} `{forall x, Decision (P2 x)} + (m: gmap K A): + filter (fun x => P1 x \/ P2 x) m = filter P1 m ∪ filter P2 m. +Proof using. + clear. + apply map_eq. intros k. + destruct (m !! k) eqn:KTH. + 2: { etrans; [| symmetry]. + { eapply map_lookup_filter_None. tauto. } + apply lookup_union_None_2; eapply map_lookup_filter_None; tauto. } + destruct (decide (P1 (k, a))). + { erewrite map_lookup_filter_Some_2; eauto. + erewrite lookup_union_Some_l; eauto. eapply map_lookup_filter_Some; eauto. } + erewrite lookup_union_r; eauto. + 2: { eapply map_lookup_filter_None. set_solver. } + destruct (decide (P2 (k, a))). + { erewrite map_lookup_filter_Some_2; eauto. + symmetry. apply map_lookup_filter_Some_2; eauto. } + etrans; [| symmetry]; eapply map_lookup_filter_None; set_solver. +Qed. + +Section MapsInverseMatch. + 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. + + Lemma maps_inverse_match_exact (v: V) (S: gset K): + maps_inverse_match (gset_to_gmap v S) {[v := S]}. + Proof. + red. intros. rewrite lookup_gset_to_gmap_Some. split. + - intros [? ->]. eexists. split; eauto. apply lookup_singleton. + - intros [? [[? ->]%lookup_singleton_Some ?]]. done. + Qed. + + Lemma maps_inverse_match_uniq1 (m1 m2: gmap K V) (m': gmap V (gset K)) + (M1: maps_inverse_match m1 m') (M2: maps_inverse_match m2 m'): + m1 = m2. + Proof. + red in M1, M2. apply map_eq. intros. + destruct (m1 !! i) eqn:L1. + - pose proof (proj1 (M1 _ _) L1) as EQ. + pose proof (proj2 (M2 _ _) EQ). + congruence. + - destruct (m2 !! i) eqn:L2; [| done]. + pose proof (proj1 (M2 _ _) L2) as EQ. + pose proof (proj2 (M1 _ _) EQ). + congruence. + Qed. + + Lemma maps_inverse_match_subseteq (m1 m2: gmap K V) (m1' m2': gmap V (gset K)) + (M1: maps_inverse_match m1 m1') (M2: maps_inverse_match m2 m2') + (SUB: dom m1' ⊆ dom m2') + (INCL: forall v S1 S2, m1' !! v = Some S1 -> m2' !! v = Some S2 -> S1 ⊆ S2): + m1 ⊆ m2. + Proof. + red in M1, M2. apply map_subseteq_spec. intros. + specialize (proj1 (M1 _ _) H1) as [? [L1 ?]]. + apply M2. + specialize (SUB x (elem_of_dom_2 _ _ _ L1)). + apply elem_of_dom in SUB as [? ?]. + eexists. split; eauto. set_solver. + Qed. + + Lemma mim_in_1 (m: gmap K V) (m': gmap V (gset K)) k v + (MIM: maps_inverse_match m m') + (DOM: m !! k = Some v): + v ∈ dom m'. + Proof. + red in MIM. + pose proof (proj1 (MIM _ _) DOM) as (?&?&?). + apply elem_of_dom. set_solver. + Qed. + + Lemma mim_in_2 (m: gmap K V) (m': gmap V (gset K)) k v + (MIM: maps_inverse_match m m') + (IN: k ∈ default ∅ (m' !! v)): + k ∈ dom m. + Proof. + red in MIM. + destruct (m' !! v) eqn:TM. + 2: { done. } + simpl in IN. + specialize (MIM k v). apply proj2 in MIM. + eapply elem_of_dom. eexists. + apply MIM. eauto. + Qed. + + Lemma mim_lookup_helper + (tm: gmap V (gset K)) (m: gmap K V) + R ζ + (MIM: maps_inverse_match m tm) + (NE: R ≠ ∅) + (DOM: ∀ ρ, m !! ρ = Some ζ ↔ ρ ∈ R): + tm !! ζ = Some R. + Proof. + apply finitary.set_choose_L' in NE as [k INR]. + pose proof (proj2 (DOM k) INR) as MAP. + red in MIM. specialize MIM with (v := ζ). + pose proof (proj1 (MIM _ ) MAP) as (R' & TM' & IN'). + rewrite TM'. f_equal. + apply set_eq. clear dependent k. intros k. + rewrite <- DOM. rewrite TM' in MIM. split. + - intros IN'. apply MIM. eauto. + - intros ?%MIM. set_solver. + Qed. + + Lemma mim_neg m tm + (MIM: maps_inverse_match m tm): + ∀ (k: K), m !! k = None <-> forall g, k ∉ default ∅ (tm !! g). + Proof. + intros. red in MIM. specialize (MIM k). split. + - intros MAP. intros g IN. + destruct (tm !! g) eqn:TM; set_solver. + - intros NIN. destruct (m !! k) eqn:MAP; [| done]. + pose proof (proj1 (MIM v) eq_refl) as (?&?&?). + specialize (NIN v). rewrite H1 in NIN. set_solver. + Qed. + +End MapsInverseMatch. + +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 TmapDisj. + Context `{Countable K} `{Countable V}. + + Definition tmap_disj (tm: gmap K (gset V)) := + forall (k1 k2: K) (S1 S2: gset V) (NEQ: k1 ≠ k2), + tm !! k1 = Some S1 -> tm !! k2 = Some S2 -> S1 ## S2. + + Global Instance tmap_disj_dec tm: Decision (tmap_disj tm). + Proof. + set pairs := let d := elements (dom tm) in + k1 ← d; k2 ← d; + if (decide (k1 = k2)) then [] else [(k1, k2)]. + set alt := Forall (fun '(k1, k2) => (default ∅ (tm !! k1)) ## (default ∅ (tm !! k2))) pairs. + apply Decision_iff_impl with (P := alt); [| solve_decision]. + rewrite /alt. rewrite Forall_forall. + rewrite /pairs. + repeat setoid_rewrite elem_of_list_bind. + repeat setoid_rewrite elem_of_elements. + rewrite /tmap_disj. + repeat setoid_rewrite elem_of_dom. + rewrite forall_prod_helper. apply forall_proper. intros [k1 k2]. simpl. + erewrite ex_det_iff with (a := k1). + 2: { intros ?. erewrite ex_det_iff with (a := k2). + 2: { intros ?. destruct decide; set_solver. } + destruct decide; set_solver. } + erewrite ex_det_iff with (a := k2). + 2: { intros ?. destruct decide; set_solver. } + destruct decide; [set_solver| ]. + destruct (tm !! k1), (tm !! k2); set_solver. + Qed. + +End TmapDisj. + + +Lemma map_nat_agree_valid {A: ofe} (m: gmap nat A): + ✓ ((to_agree <$> m): gmapUR nat (agreeR A)). +Proof using. + red. intros k. + destruct lookup eqn:LL; [| done]. + apply lookup_fmap_Some in LL. + destruct LL as (a&<-&?). + done. +Qed. diff --git a/fairness/utils_relations.v b/fairness/utils_relations.v new file mode 100644 index 0000000..78ca523 --- /dev/null +++ b/fairness/utils_relations.v @@ -0,0 +1,159 @@ +From Stdlib Require Import Relation_Operators Operators_Properties. +From stdpp Require Import relations. +From iris.proofmode Require Import tactics. + + +Section RelationsUtils. + Context {A: Type}. + + (* TODO: find existing definition *) + Definition rel_compose (R1 R2 : relation A): relation A := + fun x y => exists z, R1 x z /\ R2 z y. + + Global Instance rel_subseteq: SubsetEq (relation A) := + fun R1 R2 => forall x y, R1 x y -> R2 x y. + + Global Instance rel_compose_mono: + Proper (subseteq ==> subseteq ==> subseteq) rel_compose. + Proof. + red. intros ??????. rewrite /rel_compose. + red. intros ?? (?&?&?). eexists. eauto. + Qed. + + Lemma nsteps_0 (R: relation A) x y: nsteps R 0 x y <-> x = y. + Proof. + split. + - intros STEP. by inversion STEP. + - intros ->. constructor. + Qed. + + Lemma nsteps_1 (R: relation A) x y: nsteps R 1 x y <-> R x y. + Proof. + split. + - intros STEP. inversion STEP; subst. inversion H1. by subst. + - intros. econstructor; eauto. constructor. + Qed. + + Lemma rel_compose_nsteps_next' (r: relation A) n: + forall x y, + rel_compose r (relations.nsteps r n) x y <-> + relations.nsteps r (S n) x y. + Proof using. + intros. split. + - intros (?&?&?). econstructor; eauto. + - intros STEP. inversion STEP. subst. eexists. eauto. + Qed. + + Lemma rel_compose_assoc (R1 R2 R3: relation A) x y: + rel_compose (rel_compose R1 R2) R3 x y <-> rel_compose R1 (rel_compose R2 R3) x y. + Proof. + intros. rewrite /rel_compose. set_solver. + Qed. + + Lemma rel_compose_nsteps_plus (r: relation A) n m: + forall x y, + rel_compose (relations.nsteps r n) (relations.nsteps r m) x y <-> + relations.nsteps r (n + m) x y. + Proof using. + intros. generalize dependent y. generalize dependent x. induction n; intros. + { rewrite /rel_compose. simpl. setoid_rewrite nsteps_0. set_solver. } + rewrite Nat.add_succ_l -rel_compose_nsteps_next'. + rewrite /rel_compose. setoid_rewrite <- rel_compose_nsteps_next'. + setoid_rewrite rel_compose_assoc. rewrite /rel_compose. + by setoid_rewrite IHn. + Qed. + + Lemma rel_compose_nsteps_next (r: relation A) n: + forall x y, + rel_compose (relations.nsteps r n) r x y <-> + relations.nsteps r (S n) x y. + Proof using. + intros. rewrite /rel_compose. + setoid_rewrite <- (nsteps_1 r). setoid_rewrite rel_compose_nsteps_plus. + f_equiv. lia. + Qed. + + Global Instance rel_subseteq_po: PreOrder rel_subseteq. + Proof. + rewrite /rel_subseteq. split; eauto. + Qed. + + Lemma strict_not_both (R: relation A) x y: + strict R x y -> strict R y x -> False. + Proof using. + clear. intros [??] [??]. done. + Qed. + + Global Instance nsteps_mono n: + Proper (subseteq ==> subseteq) (fun R => nsteps R n). + Proof. + red. induction n. + { intros ????? ?%nsteps_0. by apply nsteps_0. } + intros ????? (? & STEPS & STEP)%rel_compose_nsteps_next. + eapply IHn in STEPS; eauto. + eapply rel_compose_nsteps_next. eexists. split; eauto. + Qed. + + Lemma clos_refl_nsteps (R: relation A) x y + (CR: clos_refl _ R x y): + exists n, nsteps R n x y. + Proof using. + inversion CR; subst. + - exists 1. by apply nsteps_1. + - exists 0. by apply nsteps_0. + Qed. + + Global Instance nsteps_impl: + Proper ((eq ==> eq ==> impl) ==> eq ==> (eq ==> eq ==> impl)) (@relations.nsteps A). + Proof using. + red. intros ?????????????. subst. red in H. + generalize dependent y2. induction y0. + { intros ?. by rewrite !nsteps_0. } + intros ?. rewrite -!rel_compose_nsteps_next. + intros (?&STEPS&STEP). apply IHy0 in STEPS. + eexists. split; eauto. eapply H; eauto. + Qed. + + Global Instance clos_trans_1n_proper_impl (R: relation A) + (E: relation A) + {REFL_E: Reflexive E} + (PR: Proper (E ==> E ==> impl) R): + Proper (E ==> E ==> impl) (clos_trans_1n _ R). + Proof using. + red. intros x1 x2 Ex y1 y2 Ey. intros TR. + generalize dependent x2. generalize dependent y2. + induction TR. + + intros. econstructor. eapply PR; [..| apply H]; done. + + intros y2 Ez x2 Ex. + rename x into x1. + rename y2 into z2. rename z into z1. + rename y into y1. + eapply PR in H; eauto. + specialize (IHTR _ Ez). + specialize (IHTR _ ltac:(reflexivity)). + eapply Relation_Operators.t1n_trans; eauto. + Qed. + + Global Instance clos_trans_1n_proper_iff (R: relation A) + (E: relation A) + {SYM_E: Symmetric E} + {REFL_E: Reflexive E} + (PR: Proper (E ==> E ==> iff) R): + Proper (E ==> E ==> iff) (clos_trans_1n _ R). + Proof using. + red. + assert (Proper (E ==> E ==> impl) R). + { intros ???????. symmetry in H, H0. + eapply PR; eauto. } + intros x1 x2 Ex y1 y2 Ey. split; intros. + - eapply clos_trans_1n_proper_impl; eauto. + - symmetry in Ex, Ey. eapply clos_trans_1n_proper_impl; eauto. + Qed. + + Lemma clos_trans_tn1_t1n_iff (R : relation A) (x y : A): + clos_trans_n1 A R x y ↔ clos_trans_1n A R x y. + Proof using. + by rewrite -clos_trans_t1n_iff clos_trans_tn1_iff. + Qed. + +End RelationsUtils. diff --git a/fairness/utils_sets.v b/fairness/utils_sets.v new file mode 100644 index 0000000..c1dabbb --- /dev/null +++ b/fairness/utils_sets.v @@ -0,0 +1,371 @@ +From stdpp Require Import base. +From iris.proofmode Require Import tactics. +From fairness Require Export utils_logic. +From iris.algebra Require Import gset. + +Section SetMapProperties. + + Lemma set_map_compose_gset {A1 A2 A3: Type} + `{EqDecision A1} `{EqDecision A2} `{EqDecision A3} + `{Countable A1} `{Countable A2} `{Countable A3} + (f: A2 -> A3) (g: A1 -> A2) (m: gset A1): + set_map (f ∘ g) m (D:=gset _) = set_map f (set_map g m (D:= gset _)). + Proof using. + set_solver. + Qed. + + Lemma elem_of_map_inj_gset {A B} + `{EqDecision A} `{Countable A} + `{EqDecision B} `{Countable B} + (f: A -> B) (m: gset A) (a: A) (INJ: Inj eq eq f): + a ∈ m <-> f a ∈ set_map f m (D := gset _). + Proof using. + split; [apply elem_of_map_2| ]. + intros IN. apply elem_of_map_1 in IN as (a' & EQ & IN). + apply INJ in EQ. congruence. + Qed. + +End SetMapProperties. + + + +Section Powerset. + Context {K: Type}. + Context `{Countable K}. + + (** it's easier to perform recursion on lists *) + + Fixpoint powerlist (l: list K): gset (gset K) := + match l with + | [] => {[ ∅ ]} + | k :: l' => let p' := powerlist l' in + p' ∪ (set_map (fun s => {[ k ]} ∪ s) p') + end. + + Definition powerset (s: gset K): gset (gset K) := + powerlist (elements s). + + Lemma powerlist_nil l: + ∅ ∈ powerlist l. + Proof. induction l; set_solver. Qed. + + Instance powerlist_perm_Proper: + Proper (Permutation ==> eq) powerlist. + Proof. + induction 1; csimpl; auto; cycle -1. + 1, 2: congruence. + rewrite -!union_assoc_L. f_equal. + rewrite !set_map_union_L. + rewrite !union_assoc_L. f_equal. + { set_solver. } + rewrite -!set_map_compose_gset. apply leibniz_equiv. + f_equiv. red. simpl. set_solver. + Qed. + + Lemma powerset_spec s: + forall e, e ⊆ s <-> e ∈ powerset s. + Proof. + intros. rewrite /powerset. + revert e. pattern s. apply set_ind. + { intros ?? EQUIV. apply leibniz_equiv_iff in EQUIV. by rewrite EQUIV. } + { rewrite elements_empty. simpl. + setoid_rewrite elem_of_singleton. + intros. set_solver. } + clear s. intros k s NIN IND e. + rewrite elements_disj_union; [| set_solver]. + rewrite elements_singleton. simpl. + rewrite !elem_of_union elem_of_map. + repeat setoid_rewrite <- IND. + erewrite ex_det_iff with (a := e ∖ {[ k ]}). + 2: { set_solver. } + destruct (decide (k ∈ e)); set_solver. + Qed. + +End Powerset. + + +Lemma set_filter_equiv: + ∀ {A C : Type} {H : ElemOf A C} {H0 : Empty C} {H1 : Singleton A C} + {H2 : Union C} {H3 : Intersection C} {H4 : Difference C} + {H5 : Elements A C} {EqDecision0 : EqDecision A} + {LL: LeibnizEquiv C} + {FS: FinSet A C} + (P1 P2 : A → Prop) + (DEC1: ∀ x : A, Decision (P1 x)) (DEC2: ∀ x : A, Decision (P2 x)) + (P_EQ: forall x, P1 x <-> P2 x) + (c1 c2: C) + (EQUIV: c1 ≡ c2), + filter P1 c1 = filter P2 c2. +Proof. set_solver. Qed. + +Lemma set_filter_and: + ∀ {A C : Type} {H : ElemOf A C} {H0 : Empty C} {H1 : Singleton A C} + {H2 : Union C} {H3 : Intersection C} {H4 : Difference C} + {H5 : Elements A C} {EqDecision0 : EqDecision A} + {LL: LeibnizEquiv C} + {FS: FinSet A C} + (P1 P2 : A → Prop) + (DEC1: ∀ x : A, Decision (P1 x)) (DEC2: ∀ x : A, Decision (P2 x)) + (c: C), + filter P1 (filter P2 c) = filter (fun x => P1 x /\ P2 x) c. +Proof. set_solver. Qed. + +Lemma set_filter_comm: + ∀ {A C : Type} {H : ElemOf A C} {H0 : Empty C} {H1 : Singleton A C} + {H2 : Union C} {H3 : Intersection C} {H4 : Difference C} + {H5 : Elements A C} {EqDecision0 : EqDecision A} + {LL: LeibnizEquiv C} + {FS: FinSet A C} + (P1 P2 : A → Prop) + (DEC1: ∀ x : A, Decision (P1 x)) (DEC2: ∀ x : A, Decision (P2 x)) + (c: C), + filter P1 (filter P2 c) = filter P2 (filter P1 c). +Proof. set_solver. Qed. + +Lemma filter_singleton_if: + ∀ {A C : Type} {H : ElemOf A C} {H0 : Empty C} {H1 : Singleton A C} + {H2 : Union C} {H3 : Intersection C} {H4 : Difference C} + {H5 : Elements A C} {EqDecision0 : EqDecision A}, + FinSet A C + → ∀ (P : A → Prop) {H7 : ∀ x : A, Decision (P x)} (x : A), + filter P ({[x]} : C) ≡ if decide (P x) then {[x]} else ∅. +Proof. intros. destruct decide; set_solver. Qed. + +Lemma elements_list_to_set_disj `{Countable A} (l: list A): + elements $ (list_to_set_disj l: gmultiset A) ≡ₚ l. +Proof using. + clear. induction l. + { done. } + simpl. rewrite gmultiset_elements_disj_union. + simpl. rewrite gmultiset_elements_singleton. + rewrite IHl. done. +Qed. + +Lemma gset_filter_subseteq_mono_strong `{Countable A} (P Q: A -> Prop) + `{∀ x, Decision (P x)} `{∀ x, Decision (Q x)} + (g: gset A) + (IMPL: ∀ x, x ∈ g -> P x -> Q x): + filter P g ⊆ filter Q g. +Proof using. clear -IMPL. set_solver. Qed. + +Lemma gset_filter_True `{Countable K} (g: gset K) + (P: K -> Prop) + `{∀ x, Decision (P x)} + (TRUE: forall k, k ∈ g -> P k): + filter P g = g. +Proof using. clear -TRUE. set_solver. Qed. + +Lemma GSet_inj_equiv: + ∀ `{Countable K}, Inj equiv equiv (@GSet K _ _). +Proof using. solve_proper. Qed. + +Lemma GSet_Proper: + ∀ `{Countable K}, Proper (equiv ==> equiv) (@GSet K _ _). +Proof using. solve_proper. Qed. + +Lemma gset_not_elem_of_equiv_not_empty_L: + ∀ {A : Type} `{Countable A}, + ∀ (X : gset A), X ≠ ∅ ↔ (exists x : A, x ∈ X). +Proof. + intros. split. + - by apply set_choose_L. + - set_solver. +Qed. + +Lemma length_size `{Countable K} (g: gset K): + length (elements g) = size g. +Proof. + rewrite -{2}(list_to_set_elements_L g). + rewrite size_list_to_set; [done| ]. apply NoDup_elements. +Qed. + + +Section FlattenGset. + Context `{Countable K}. + + (* TODO: find existing? *) + Definition flatten_gset (ss: gset (gset K)): gset K := + list_to_set (concat (map elements (elements ss))). + + Lemma flatten_gset_spec (ss: gset (gset K)): + forall k, k ∈ flatten_gset ss <-> exists s, s ∈ ss /\ k ∈ s. + Proof. + intros. rewrite /flatten_gset. + rewrite elem_of_list_to_set. + rewrite elem_of_list_In in_concat. + setoid_rewrite in_map_iff. + repeat setoid_rewrite <- elem_of_list_In. + split. + - intros (?&(l&<-&?)&?). exists l. set_solver. + - intros (s&?&?). exists (elements s). set_solver. + Qed. + + Lemma flatten_gset_disjoint (ss: gset (gset K)) s': + flatten_gset ss ## s' <-> forall s, s ∈ ss -> s ## s'. + Proof. + repeat setoid_rewrite elem_of_disjoint. setoid_rewrite flatten_gset_spec. + set_solver. + Qed. + + Lemma flatten_gset_union (S1 S2: gset (gset K)): + flatten_gset (S1 ∪ S2) = flatten_gset S1 ∪ flatten_gset S2. + Proof. + rewrite /flatten_gset. set_solver. + Qed. + + Lemma flatten_gset_singleton (S: gset K): + flatten_gset {[ S ]} = S. + Proof. + rewrite /flatten_gset. rewrite elements_singleton. set_solver. + Qed. + + Lemma flatten_gset_empty: flatten_gset ∅ = (∅: gset K). + Proof using. set_solver. Qed. + +End FlattenGset. + +Section GsetPick. + Context `{Countable K}. + + Definition gset_pick (g: gset K) := + let l := elements g in + match l with + | [] => None + | e :: _ => Some e + end. + + Lemma gset_pick_None (g: gset K): + gset_pick g = None <-> g = ∅. + Proof. + rewrite /gset_pick. destruct (elements g) eqn:E. + - apply elements_empty_inv in E. apply leibniz_equiv_iff in E. done. + - split; [done| ]. intros ->. simpl in E. set_solver. + Qed. + + Lemma gset_pick_is_Some (g: gset K): + is_Some (gset_pick g) <-> g ≠ ∅. + Proof. + rewrite -not_eq_None_Some. apply not_iff_compat, gset_pick_None. + Qed. + + Lemma gset_pick_Some (g: gset K) k: + gset_pick g = Some k -> k ∈ g. + Proof. + rewrite /gset_pick. destruct elements eqn:E; [done| ]. + intros [=->]. apply elem_of_elements. rewrite E. constructor. + Qed. + + Lemma gset_pick_singleton (k: K): + gset_pick {[ k ]} = Some k. + Proof. + rewrite /gset_pick. rewrite elements_singleton. done. + Qed. + +End GsetPick. + + +Section ExtractSomes. + Context {A: Type}. + + Definition extract_Somes (l: list (option A)): list A := + flat_map (from_option (fun a => [a]) []) l. + + Lemma extract_Somes_spec (l: list (option A)): + forall a, In (Some a) l <-> In a (extract_Somes l). + Proof. + intros. rewrite /extract_Somes. + rewrite in_flat_map_Exists. + rewrite List.Exists_exists. simpl. + erewrite ex_det_iff with (a := Some a). + 2: { intros ? [? ?]. destruct a'; try done. + simpl in H0. set_solver. } + simpl. set_solver. + Qed. + + Context `{Countable A}. + + Definition extract_Somes_gset (s: gset (option A)): gset A := + list_to_set ∘ extract_Somes ∘ elements $ s. + + Lemma extract_Somes_gset_spec (s: gset (option A)): + forall a, Some a ∈ s <-> a ∈ (extract_Somes_gset s). + Proof. + intros. rewrite /extract_Somes_gset. + rewrite elem_of_list_to_set. + rewrite elem_of_list_In. rewrite -extract_Somes_spec. + rewrite -elem_of_list_In. rewrite elem_of_elements. + done. + Qed. + + Lemma extract_Somes_gset_inv (s: gset (option A)): + set_map Some (extract_Somes_gset s) = s ∖ {[ None ]}. + Proof. + apply set_eq. intros ?. rewrite elem_of_map. + setoid_rewrite <- extract_Somes_gset_spec. + rewrite elem_of_difference not_elem_of_singleton. + split; [intros (?&->&?) | intros [??]]. + - set_solver. + - destruct x; eauto. done. + Qed. + + Lemma extract_Somes_gset_singleton (ok: option A): + extract_Somes_gset {[ ok ]} = match ok with | Some k => {[ k ]} | None => ∅ end. + Proof using. + destruct ok; try set_solver. + apply set_eq. intros ?. rewrite <- extract_Somes_gset_spec. + set_solver. + Qed. + +End ExtractSomes. + + +Lemma gset_to_gmap_singleton `{Countable K} {B: Type} (b: B) (k: K): + gset_to_gmap b {[ k ]} = {[ k := b ]}. +Proof. + rewrite /gset_to_gmap. simpl. rewrite map_fmap_singleton. done. +Qed. + +Lemma set_Forall_subseteq {A C : Type} `{ElemOf A C} + (P: A → Prop) (x y: C) + (SUB: y ⊆ x): + set_Forall P x -> set_Forall P y. +Proof using. clear -SUB. set_solver. Qed. + + +Section SetMax. + + Definition set_max (X: gset nat): nat := + list_max $ elements $ X. + + Lemma set_max_spec X n: + set_max X ≤ n ↔ set_Forall (λ k, k ≤ n) X. + Proof using. + rewrite /set_max. rewrite list_max_le. + by rewrite set_Forall_elements. + Qed. + + (* TODO: does it exist already? *) + Lemma list_max_elems X: + forall x, x ∈ X -> x <= list_max X. + Proof using. + induction X. + { set_solver. } + intros x. rewrite elem_of_cons. intros [->|?]; simpl. + - lia. + - etrans; [| apply Nat.le_max_r]. eauto. + Qed. + + Lemma set_max_elems X: + forall x, x ∈ X -> x <= set_max X. + Proof using. + intros x IN. rewrite /set_max. + apply list_max_elems. by apply elem_of_elements. + Qed. + + Lemma set_max_singleton x: + set_max {[ x ]} = x. + Proof using. + rewrite /set_max. rewrite elements_singleton. simpl. lia. + Qed. + +End SetMax. diff --git a/trillium.opam b/trillium.opam index 839b901..c882eb9 100644 --- a/trillium.opam +++ b/trillium.opam @@ -11,4 +11,5 @@ depends: [ "coq" { (= "9.0.0") } "coq-iris" { (= "4.3.0") } "coq-stdpp" { (="1.11.0") } + "coq-paco" { (= "4.2.3") } ] \ No newline at end of file From bec12c68e0a9693bf1c57579bad4e863fe9ffef0 Mon Sep 17 00:00:00 2001 From: fresheed Date: Fri, 29 Aug 2025 12:37:38 +0200 Subject: [PATCH 08/17] added heap_lang dir --- heap_lang/heap_lang_defs.v | 315 ++++++++++++++ heap_lang/lang.v | 750 ++++++++++++++++++++++++++++++++ heap_lang/locales_helpers_hl.v | 123 ++++++ heap_lang/locations.v | 48 ++ heap_lang/notation.v | 159 +++++++ heap_lang/simulation_adequacy.v | 287 ++++++++++++ heap_lang/sswp_logic.v | 248 +++++++++++ heap_lang/tactics.v | 49 +++ 8 files changed, 1979 insertions(+) create mode 100644 heap_lang/heap_lang_defs.v create mode 100644 heap_lang/lang.v create mode 100644 heap_lang/locales_helpers_hl.v create mode 100644 heap_lang/locations.v create mode 100644 heap_lang/notation.v create mode 100644 heap_lang/simulation_adequacy.v create mode 100644 heap_lang/sswp_logic.v create mode 100644 heap_lang/tactics.v diff --git a/heap_lang/heap_lang_defs.v b/heap_lang/heap_lang_defs.v new file mode 100644 index 0000000..f79c5a3 --- /dev/null +++ b/heap_lang/heap_lang_defs.v @@ -0,0 +1,315 @@ +From iris.base_logic Require Export gen_heap. +From iris.proofmode Require Import tactics. +From trillium.program_logic Require Export weakestpre. +From heap_lang Require Export lang. +From fairness Require Export execution_model. +From heap_lang Require Import tactics notation. + + +(* TODO: the missing fact of em_GS etc. being typeclasses + hardens automatic resolution of their instances *) +Class heapGpreS Σ `(EM: ExecutionModel heap_lang M) := HeapPreG { + heapGpreS_inv :: invGpreS Σ; + heapGpreS_gen_heap :: gen_heapGpreS loc val Σ; + heapGpreS_em :: em_preGS Σ; +}. + + +Class heapGS Σ `(EM: ExecutionModel heap_lang M) := HeapG { + heap_inG :: heapGpreS Σ EM; + + heap_invGS :: invGS_gen HasNoLc Σ; + heap_gen_heapGS :: gen_heapGS loc val Σ; + + heap_fairnessGS :: em_GS Σ; +}. + +Definition heapΣ `(EM: ExecutionModel heap_lang M) : gFunctors := + #[ invΣ; gen_heapΣ loc val; em_Σ ]. + + +(* TODO: automatize *) +Global Instance subG_heapPreG {Σ} `{EM: ExecutionModel heap_lang M}: + subG (heapΣ EM) Σ → heapGpreS Σ EM. +Proof. + intros. + enough (em_preGS Σ); [solve_inG| ]. + apply em_Σ_subG. solve_inG. +Qed. + +#[global] Instance heapG_irisG `{EM: ExecutionModel heap_lang M} `{HGS: !heapGS Σ EM}: + irisG heap_lang M Σ := { + state_interp extr auxtr := + (⌜em_valid_state_evolution_fairness extr auxtr⌝ ∗ + gen_heap_interp (trace_last extr).2.(heap) ∗ + em_msi (trace_last extr) (trace_last auxtr) (em_GS0 := heap_fairnessGS))%I ; + fork_post tid := fun _ => em_thread_post tid (em_GS0 := heap_fairnessGS); +}. + +Section GeneralProperties. + Context `{EM: ExecutionModel heap_lang M}. + Context `{HGS: @heapGS Σ _ EM}. + Let eGS := heap_fairnessGS. + + Lemma posts_of_empty_mapping_multiple (es e: expr) v (tid : nat) (tp : list expr): + tp !! tid = Some e -> + to_val e = Some v -> + (* cur_posts tp e1 (fun _ => em_thread_post 0%nat (em_GS0 := eGS)) -∗ *) + (let Φs := map (fun τ _ => @em_thread_post heap_lang M EM Σ (@heap_fairnessGS Σ M EM _) τ) (seq 0 (length tp)) in + posts_of tp Φs) -∗ + em_thread_post tid (em_GS0 := eGS). + Proof. + intros Hsome Hval. simpl. + + rewrite (big_sepL_elem_of (λ x, x.2 x.1) _ (v, (fun _ => em_thread_post tid)) _) //. + { eauto. } + apply elem_of_list_omap. + exists (e, (fun _ => em_thread_post tid (em_GS0 := eGS))); 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 (S tid). split; auto. + rewrite lookup_seq_lt. + { set_solver. } + eapply lookup_lt_is_Some; eauto. + Qed. + + (* TODO: derive from previous? *) + Lemma posts_of_empty_mapping (e1 e: expr) v (tid : nat) (tp : list expr): + tp !! tid = Some e -> + to_val e = Some v -> + cur_posts tp e1 (fun _ => em_thread_post 0%nat (em_GS0 := eGS)) -∗ + em_thread_post tid (em_GS0 := eGS). + Proof. + intros Hsome Hval. simpl. + + rewrite /cur_posts. + rewrite (big_sepL_elem_of (λ x, x.2 x.1) _ (v, (fun _ => em_thread_post tid)) _) //. + { eauto. } + apply elem_of_list_omap. + exists (e, (fun _ => em_thread_post tid (em_GS0 := eGS))); 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 /= length_take_le //. + assert (tid < length tp)%nat; last lia. by eapply lookup_lt_Some. + Qed. + +End GeneralProperties. + +(** Override the notations so that scopes and coercions work out *) +Notation "l ↦{ q } v" := (pointsto (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" := + (pointsto (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. + +(* [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. + + +Section Heap. + Context `{EM: ExecutionModel heap_lang M}. + Context `{HGS: @heapGS Σ _ EM}. + + (** 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. + +End Heap. diff --git a/heap_lang/lang.v b/heap_lang/lang.v new file mode 100644 index 0000000..aa693e8 --- /dev/null +++ b/heap_lang/lang.v @@ -0,0 +1,750 @@ +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 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 !length_app /=. 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/heap_lang/locales_helpers_hl.v b/heap_lang/locales_helpers_hl.v new file mode 100644 index 0000000..dc111fb --- /dev/null +++ b/heap_lang/locales_helpers_hl.v @@ -0,0 +1,123 @@ +From fairness Require Import locales_helpers utils_sets. +From heap_lang Require Export lang tactics notation. + + +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 length_app /= in H. + rewrite length_app /= 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 length_app /=. f_equal; lia. + * rewrite length_app /=. 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 length_app=> /=. lia. +Qed. + +Lemma locales_of_list_indexes (es : list expr) : + locales_of_list es = indexes es. +Proof. apply locales_of_list_from_indexes. Qed. + +Lemma locales_of_cfg_simpl l σ: + locales_of_cfg (l, σ) = set_seq 0 (length l). +Proof. + rewrite /locales_of_cfg. f_equal. simpl. + rewrite !locales_of_list_from_indexes. simpl. + rewrite !imap_seq_0. rewrite !list_fmap_id. + apply list_to_set_seq. +Qed. + +Lemma length_upd_middle {A: Type} (x y: A) l1 l2: + length (l1 ++ x :: l2) = length (l1 ++ y :: l2). +Proof. intros. rewrite !length_app. simpl. lia. Qed. + +Lemma locale_step_sub c1 c2 τ + (STEP: locale_step c1 (Some τ) c2): + locales_of_cfg c1 ⊆ locales_of_cfg c2. +Proof. + inversion STEP. subst. + + rewrite !locales_of_cfg_simpl. + rewrite app_comm_cons. rewrite app_assoc. rewrite (length_app _ efs). + rewrite -!list_to_set_seq. rewrite seq_app. + rewrite list_to_set_app. + rewrite (length_upd_middle e1 e2). set_solver. +Qed. + +Lemma locale_step_fresh_exact c1 c2 τ τ' + (STEP: locale_step c1 (Some τ) c2) + (FRESH: τ' ∈ locales_of_cfg c2 ∖ locales_of_cfg c1): + locales_of_cfg c2 = locales_of_cfg c1 ∪ {[ τ' ]} /\ τ' ∉ locales_of_cfg c1. +Proof. + inversion STEP. subst. + revert FRESH. + + rewrite !locales_of_cfg_simpl. + rewrite app_comm_cons. rewrite app_assoc. rewrite length_app. + rewrite -!list_to_set_seq. rewrite seq_app. simpl. + rewrite list_to_set_app_L. rewrite !list_to_set_seq. + + rewrite (length_upd_middle e2 e1). remember (length (t1 ++ e1 :: t2)) as N. + rewrite -HeqN. remember (set_seq 0 N) as D. + + rewrite difference_union_distr_l_L. rewrite subseteq_empty_difference; [| done]. + rewrite union_empty_l. intros [DOM2 NDOM1]%elem_of_difference. + split; [| done]. + f_equal. + + assert (¬ (efs = [])) as FORK. + { intros NOFORK. inversion H3. subst. inversion H1; subst; done. } + inversion H3. subst. inversion H1; subst; try done. + simpl in DOM2. rewrite union_empty_r in DOM2. apply elem_of_singleton in DOM2. + simpl. set_solver. +Qed. + +Lemma locale_step_fork_Some c1 τ c2 τ' + (STEP: locale_step c1 (Some τ) c2) + (FORK: step_fork c1 c2 = Some τ'): + locales_of_cfg c2 = locales_of_cfg c1 ∪ {[τ']} ∧ τ' ∉ locales_of_cfg c1. +Proof using. + apply gset_pick_Some in FORK. + eapply locale_step_fresh_exact in FORK; eauto. +Qed. diff --git a/heap_lang/locations.v b/heap_lang/locations.v new file mode 100644 index 0000000..75221da --- /dev/null +++ b/heap_lang/locations.v @@ -0,0 +1,48 @@ +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/heap_lang/notation.v b/heap_lang/notation.v new file mode 100644 index 0000000..d70384e --- /dev/null +++ b/heap_lang/notation.v @@ -0,0 +1,159 @@ +From trillium.program_logic Require Import language. +From 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/heap_lang/simulation_adequacy.v b/heap_lang/simulation_adequacy.v new file mode 100644 index 0000000..bfbe7ab --- /dev/null +++ b/heap_lang/simulation_adequacy.v @@ -0,0 +1,287 @@ +From stdpp Require Import fin_maps. +From iris.proofmode Require Import tactics. +From trillium.program_logic Require Export weakestpre adequacy. +From fairness Require Export fairness traces_match trace_utils. +From heap_lang Require Export lang heap_lang_defs. + +Definition heap_lang_extrace : Type := extrace heap_lang. + + +Section adequacy. + + Definition wp_premise + `{EM: ExecutionModel heap_lang M} + (Σ: gFunctors) + (s: stuckness) (e1 : expr) σ1 (s1: mstate M) + (R: execution_trace heap_lang → auxiliary_trace M → Prop) + (p: em_init_param) + := + (∀ `{Hinv : @heapGS Σ M EM} , + ⊢ (([∗ map] l ↦ v ∈ heap σ1, pointsto l (DfracOwn 1) v) ∗ + em_init_resource s1 p (em_GS0 := heap_fairnessGS) + ={⊤}=∗ + WP e1 @ s; locale_of [] e1; ⊤ {{ _, em_thread_post 0%nat (em_GS0 := heap_fairnessGS)}} ∗ + rel_always_holds0 R s state_interp (fun _ => em_thread_post 0%nat (em_GS0 := heap_fairnessGS)) e1 σ1 s1)). + + Definition wp_premise_multiple + `{EM: ExecutionModel heap_lang M} + (Σ: gFunctors) + (s: stuckness) es σ1 (s1: mstate M) + (R: execution_trace heap_lang → auxiliary_trace M → Prop) + (p: em_init_param) + := + (∀ `{Hinv : @heapGS Σ M EM} , + ⊢ (([∗ map] l ↦ v ∈ heap σ1, pointsto l (DfracOwn 1) v) ∗ + em_init_resource s1 p (em_GS0 := heap_fairnessGS) + ={⊤}=∗ + let Φs := map (fun i _ => em_thread_post i%nat (em_GS0 := heap_fairnessGS)) (seq 0 (length es)) in + wptp s es Φs ∗ + rel_always_holds s Φs R (es, σ1) s1)). + + Lemma wp_premise_single `{EM: ExecutionModel heap_lang M} Σ + s e1 σ1 s1 R p: + wp_premise Σ s e1 σ1 s1 R p -> wp_premise_multiple Σ s [e1] σ1 s1 R p. + Proof using. + rewrite /wp_premise /wp_premise_multiple. + iIntros "%WP1 % [HEAP INIT]". + iMod (WP1 Hinv with "[$HEAP $INIT]") as "[WP1 RAH]". + iFrame. set_solver. + Qed. + + Theorem strong_simulation_adequacy_general_multiple + `{hPre: @heapGpreS Σ M EM} (s: stuckness) (es : list expr) σ1 (s1: M) + (R: execution_trace heap_lang → auxiliary_trace M → Prop) + (p: em_init_param) + : + length es ≥ 1 -> + rel_finitary R → + em_is_init_st (es, σ1) s1 -> + em_valid_state_evolution_fairness {tr[ (es, σ1) ]} {tr[ s1 ]} -> + (wp_premise_multiple Σ s es σ1 s1 R p) -> + continued_simulation R (trace_singleton (es, σ1)) (trace_singleton s1). + Proof. + intros LEN Hfin INIT VALID1 H. + apply (wp_strong_adequacy_multiple_with_trace_inv heap_lang M Σ s); try done. + + iIntros (?) "". + + iMod (gen_heap_init (heap σ1)) as (genheap)" [Hgen [Hσ _]]". + iMod (em_initialization _ s1 (es, σ1) p) as (fGS) "[LM_INIT MSI]"; [done| ]. + Unshelve. 2: by apply hPre. + + set (distG := {| heap_fairnessGS := (fGS: (em_GS Σ (ExecutionModel := EM))) |}). + iPoseProof (H distG) as "Hwp". clear H. + + iExists state_interp, (λ _ _, ⌜ True ⌝%I), _, (fun τ _ => em_thread_post τ). + iSplitR. + { unfold config_wp. iIntros "!>!>" (???????) "?". done. } + + iSpecialize ("Hwp" with "[Hσ LM_INIT]"); [by iFrame| ]. + iDestruct "Hwp" as ">[Hwp H]". + iModIntro. iFrame "Hwp Hgen MSI". + + (* TODO: make a lemma *) + iIntros (??????????) "SI POSTS". + rewrite /rel_always_holds. iDestruct ("H" with "[][][][][][][] SI POSTS") as "R". + all: try by done. + iSplit. + - iModIntro; iIntros "[$ ?]"; done. + - eauto. + Qed. + + Theorem strong_simulation_adequacy_general + `{hPre: @heapGpreS Σ M EM} (s: stuckness) (e1 : expr) σ1 (s1: M) + (R: execution_trace heap_lang → auxiliary_trace M → Prop) + (p: em_init_param) + : + rel_finitary R → + em_is_init_st ([e1], σ1) s1 -> + em_valid_state_evolution_fairness {tr[ ([e1], σ1) ]} {tr[ s1 ]} -> + (wp_premise Σ s e1 σ1 s1 R p) -> + continued_simulation R (trace_singleton ([e1], σ1)) (trace_singleton s1). + Proof. + intros. eapply strong_simulation_adequacy_general_multiple. + 1-4: by eauto. + apply wp_premise_single. eauto. + Qed. + + Theorem strong_simulation_adequacy_inftraces_multiple Σ + `{hPre: @heapGpreS Σ M EM} (s: stuckness) + (es : list expr) σ1 (s1: M) + (R: execution_trace heap_lang → auxiliary_trace M → Prop) + (p: em_init_param) + (iex : inf_execution_trace heap_lang) + (Hvex : valid_inf_exec (trace_singleton (es, σ1)) iex) + : + length es ≥ 1 -> + rel_finitary R → + em_is_init_st (es, σ1) s1 -> + (wp_premise_multiple Σ s es σ1 s1 R p) -> + exists iatr, + @valid_inf_system_trace _ M + (@continued_simulation + heap_lang + M + R) + (trace_singleton (es, σ1)) + (trace_singleton s1) + iex + iatr. + Proof. + intros LEN Hfin Hwp. + eexists. + eapply produced_inf_aux_trace_valid_inf. + Unshelve. + - econstructor. + - eapply (strong_simulation_adequacy_general_multiple s) => //. + - done. + Qed. + + Theorem strong_simulation_adequacy_inftraces Σ + `{hPre: @heapGpreS Σ M EM} (s: stuckness) + (e1 : expr) σ1 (s1: M) + (R: execution_trace heap_lang → auxiliary_trace M → Prop) + (p: em_init_param) + (iex : inf_execution_trace heap_lang) + (Hvex : valid_inf_exec (trace_singleton ([e1], σ1)) iex) + : + rel_finitary R → + em_is_init_st ([e1], σ1) s1 -> + (wp_premise Σ s e1 σ1 s1 R p) -> + exists iatr, + @valid_inf_system_trace _ M + (@continued_simulation + heap_lang + M + R) + (trace_singleton ([e1], σ1)) + (trace_singleton s1) + iex + iatr. + Proof. + intros. eapply strong_simulation_adequacy_inftraces_multiple. + 1-5: by eauto. + by eapply wp_premise_single. + Qed. + + Theorem strong_simulation_adequacy_traces_multiple Σ + `{hPre: @heapGpreS Σ M EM} (s: stuckness) + (es: list expr) σ1 (s1: M) + (R: execution_trace heap_lang → auxiliary_trace M → Prop) + (p: em_init_param) + + (extr : heap_lang_extrace) + (Hvex : extrace_valid extr) + (Hexfirst : trfirst extr = (es, σ1)) + + (valid_step: cfg heap_lang -> olocale heap_lang → cfg heap_lang → + mstate M → mlabel M → mstate M -> Prop) + (state_rel: cfg heap_lang -> mstate M -> Prop) + (lbl_rel: olocale heap_lang -> mlabel M -> Prop) + (STEP_LBL_REL: forall c1 oζ c2 δ1 ℓ δ2, + valid_step c1 oζ c2 δ1 ℓ δ2 -> + lbl_rel oζ ℓ) + (STEP_MTRANS: forall c1 oζ c2 δ1 ℓ δ2, + valid_step c1 oζ c2 δ1 ℓ δ2 -> + mtrans δ1 ℓ δ2) + (R_ST: forall extr mtr, R extr mtr -> state_rel (trace_last extr) (trace_last mtr)) + (R_STEP: forall extr mtr, R extr mtr -> valid_state_evolution_fairness valid_step extr mtr) + + : + length es ≥ 1 -> + rel_finitary R → + em_is_init_st (es, σ1) s1 -> + (wp_premise_multiple Σ s es σ1 s1 R p) -> + ∃ (mtr : trace (mstate M) (mlabel M)), + traces_match lbl_rel state_rel locale_step (@mtrans M) extr mtr /\ + trfirst mtr = s1. + Proof. + intros ? Hfin INIT Hwp. + have [iatr MATCH] : exists iatr, + @valid_inf_system_trace + heap_lang M + (@continued_simulation + heap_lang + M + R) + (trace_singleton (es, (trfirst extr).2)) + (trace_singleton s1) + (from_trace extr) + iatr. + { eapply (strong_simulation_adequacy_inftraces_multiple _ s); eauto. + 1: eapply from_trace_preserves_validity; eauto; first econstructor. + all: try by rewrite Hexfirst. } + rewrite Hexfirst in MATCH. simpl in *. + exists (to_trace s1 iatr). + + split. + 2: { by rewrite to_trace_trfirst. } + + pose proof MATCH as INF_REF. (** see remark below *) + eapply (valid_inf_system_trace_implies_traces_match + valid_step + state_rel + lbl_rel + ltac:(idtac) + ltac:(idtac) + (continued_simulation R)) in MATCH; cycle 1. + { intros ?? ?%continued_simulation_rel. eauto. } + { intros ?? ?%continued_simulation_rel. eauto. } + { apply from_trace_spec. simpl. + rewrite Hexfirst. done. } + { apply to_trace_spec. } + Unshelve. 2,3: by eauto. + + assert (exists len, trace_len.trace_len_is extr len /\ trace_len.trace_len_is (to_trace s1 iatr) len) as LEN. (** see remark below *) + { simpl in MATCH. + pose proof (trace_len.trace_has_len extr) as [len LEN]. + pose proof (trace_len.trace_has_len (to_trace s1 iatr)) as [len' LEN']. + eapply trace_len.traces_match_same_length in MATCH; eauto. subst. + eauto. } + + (** INF_REF and LEN together give the traces mentioned in + the refinement section of Lawyer paper + (same length, related by infinite extension of refinement). + However, our proofs proceed differency, + using the notion of traces_match (MATCH hypothesis). *) + + apply MATCH. + Qed. + + Theorem strong_simulation_adequacy_traces Σ + `{hPre: @heapGpreS Σ M EM} (s: stuckness) + (e1 : expr) σ1 (s1: M) + (R: execution_trace heap_lang → auxiliary_trace M → Prop) + (p: em_init_param) + + (extr : heap_lang_extrace) + (Hvex : extrace_valid extr) + (Hexfirst : trfirst extr = ([e1], σ1)) + + (valid_step: cfg heap_lang -> olocale heap_lang → cfg heap_lang → + mstate M → mlabel M → mstate M -> Prop) + (state_rel: cfg heap_lang -> mstate M -> Prop) + (lbl_rel: olocale heap_lang -> mlabel M -> Prop) + (STEP_LBL_REL: forall c1 oζ c2 δ1 ℓ δ2, + valid_step c1 oζ c2 δ1 ℓ δ2 -> + lbl_rel oζ ℓ) + (STEP_MTRANS: forall c1 oζ c2 δ1 ℓ δ2, + valid_step c1 oζ c2 δ1 ℓ δ2 -> + mtrans δ1 ℓ δ2) + (R_ST: forall extr mtr, R extr mtr -> state_rel (trace_last extr) (trace_last mtr)) + (R_STEP: forall extr mtr, R extr mtr -> valid_state_evolution_fairness valid_step extr mtr) + + : + rel_finitary R → + em_is_init_st ([e1], σ1) s1 -> + (wp_premise Σ s e1 σ1 s1 R p) -> + ∃ (mtr : trace (mstate M) (mlabel M)), + traces_match lbl_rel state_rel locale_step (@mtrans M) extr mtr /\ + trfirst mtr = s1. + Proof. + intros. eapply strong_simulation_adequacy_traces_multiple; last first. + { by eapply wp_premise_single. } + all: by eauto. + Qed. + +End adequacy. diff --git a/heap_lang/sswp_logic.v b/heap_lang/sswp_logic.v new file mode 100644 index 0000000..08095be --- /dev/null +++ b/heap_lang/sswp_logic.v @@ -0,0 +1,248 @@ +From stdpp Require Import fin_maps. +From iris.proofmode Require Import tactics. +From iris.base_logic Require Export gen_heap. +From heap_lang Require Export heap_lang_defs. +From heap_lang Require Import tactics notation. + + +Section SSWP. + Set Default Proof Using "Type". + + Context `{EM: ExecutionModel heap_lang M}. + Context `{hGS: @heapGS Σ _ EM}. + + Let eGS := heap_fairnessGS. + + 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 sswp_wand s e E (Φ Ψ : expr → iProp Σ) : + (∀ e, Φ e -∗ Ψ e) -∗ sswp s E e Φ -∗ sswp s E e Ψ. + Proof. + rewrite /sswp. iIntros "HΦΨ HΦ". + 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. + + Lemma sswp_fupd s (E E': coPset) e Φ + (NVAL: language.to_val e = None): + (|={E, E'}=> (sswp s E' e (fun k => |={E', E}=> Φ k))) -∗ (sswp s E e Φ). + Proof using. + iIntros "WP". rewrite /sswp. + simpl in *. rewrite NVAL. iIntros (?) "HEAP". + iMod ("WP" with "[$]") as "WP". iMod "WP" as "[? WP]". iModIntro. + iFrame. iIntros. iMod ("WP" with "[//]") as "X". + iModIntro. iNext. iMod "X". iModIntro. iMod "X" as "(X & Y & Z)". iFrame. + done. + Qed. + + Lemma sswp_pure_step s E e1 e2 (Φ : Prop) Ψ : + PureExec Φ 1 e1 e2 → Φ → ▷ Ψ e2 -∗ sswp s E e1 Ψ%I. + Proof. + iIntros (Hpe HΦ) "HΨ". + assert (pure_step e1 e2) as Hps. + { specialize (Hpe HΦ). by apply nsteps_once_inv in Hpe. } + rewrite /sswp /=. + assert (to_val e1 = None) as ->. + { destruct Hps as [Hred _]. specialize (Hred (Build_state ∅ ∅)). + by eapply reducible_not_val. } + iIntros (σ) "Hσ". + iMod fupd_mask_subseteq as "Hclose"; last iModIntro; [by set_solver|]. + iSplit. + { destruct s; [|done]. by destruct Hps as [Hred _]. } + iIntros (e2' σ2 efs Hstep) "!>!>!>". + iMod "Hclose". iModIntro. destruct Hps as [_ Hstep']. + apply Hstep' in Hstep as [-> [-> ->]]. by iFrame. + Qed. + + Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _; simpl : core. + 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. + + Lemma wp_allocN_seq s E v n (Φ : expr → iProp Σ) : + 0 < n → + ▷ (∀ (l:loc), ([∗ list] i ∈ seq 0 (Z.to_nat n), + (l +ₗ (i : nat)) ↦ v ∗ meta_token (l +ₗ (i : nat)) ⊤) -∗ Φ #l) -∗ + sswp s E (AllocN (Val $ LitV $ LitInt $ n) (Val v)) Φ. + Proof. + iIntros (HnO) "HΦ". + rewrite /sswp. simpl. + iIntros (σ) "Hσ". + iMod fupd_mask_subseteq as "Hclose"; last iModIntro; first by set_solver. + iSplit. + { iPureIntro. destruct s; [|done]. apply head_prim_reducible. eauto. } + iIntros (e2 σ2 efs Hstep). iIntros "!>!>!>". + iMod "Hclose". + apply head_reducible_prim_step in Hstep; [|eauto]. + inv_head_step. + iMod (gen_heap_alloc_big _ (heap_array l (replicate (Z.to_nat n) v)) with "Hσ") + as "(Hσ & Hl & Hm)". + { apply heap_array_map_disjoint. + rewrite length_replicate Z2Nat.id ?Hexend; auto with lia. } + iFrame. + iModIntro. + iSplit; [|done]. + iApply "HΦ". + iApply big_sepL_sep. iSplitL "Hl". + + by iApply heap_array_to_seq_mapsto. + + iApply (heap_array_to_seq_meta with "Hm"). by rewrite length_replicate. + Qed. + + Lemma wp_alloc s E v (Φ : expr → iProp Σ) : + ▷ (∀ l, l ↦ v -∗ meta_token l ⊤ -∗ Φ (LitV (LitLoc l))) -∗ + sswp s E (Alloc v) Φ. + Proof. + iIntros "HΦ". iApply wp_allocN_seq; [lia|]. + iIntros "!>" (l) "[[Hl Hm] _]". rewrite loc_add_0. + iApply ("HΦ" with "Hl Hm"). + Qed. + + Lemma wp_choose_nat s E (Φ : expr → iProp Σ) : + ▷ (∀ (n:nat), Φ $ Val $ LitV (LitInt n)) -∗ + sswp s E ChooseNat Φ. + Proof. + iIntros "HΦ". + rewrite /sswp. simpl. + iIntros (σ) "Hσ". + iMod fupd_mask_subseteq as "Hclose"; last iModIntro; first by set_solver. + iSplit. + { iPureIntro. destruct s; [|done]. apply head_prim_reducible. eauto. } + iIntros (e2 σ2 efs Hstep). iIntros "!>!>!>". + iMod "Hclose". + apply head_reducible_prim_step in Hstep; [|eauto]. + inv_head_step. + iFrame. + iModIntro. + iSplit; [|done]. + iApply "HΦ". + Unshelve. all: apply O. + Qed. + + Lemma wp_load s E l q v (Φ : expr → iProp Σ) : + ▷ l ↦{q} v -∗ + ▷ (l ↦{q} v -∗ Φ v) -∗ + sswp s E (Load (Val $ LitV $ LitLoc l)) Φ. + Proof. + iIntros ">Hl HΦ". + rewrite /sswp. simpl. + iIntros (σ) "Hσ". + iMod fupd_mask_subseteq as "Hclose"; last iModIntro; first by set_solver. + iDestruct (@gen_heap_valid with "Hσ Hl") as %Hheap. + iSplit. + { iPureIntro. destruct s; [|done]. apply head_prim_reducible. eauto. } + iIntros (e2 σ2 efs Hstep). iIntros "!>!>!>". + iMod "Hclose". + apply head_reducible_prim_step in Hstep; [|eauto]. + inv_head_step. + iFrame. + iModIntro. + iSplit; [|done]. + by iApply "HΦ". + Qed. + + Lemma wp_store s E l v' v (Φ : expr → iProp Σ) : + ▷ l ↦ v' -∗ + ▷ (l ↦ v -∗ Φ $ LitV LitUnit) -∗ + sswp s E (Store (Val $ LitV (LitLoc l)) (Val v)) Φ. + Proof. + iIntros ">Hl HΦ". 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. iModIntro. iSplit; [|done]. by iApply "HΦ". + Qed. + + Lemma wp_cmpxchg_fail s E l q v' v1 v2 (Φ : expr → iProp Σ) : + v' ≠ v1 → vals_compare_safe v' v1 → + ▷ l ↦{q} v' -∗ + ▷ (l ↦{q} v' -∗ Φ $ PairV v' (LitV $ LitBool false)) -∗ + sswp s E (CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2)) Φ. + Proof. + iIntros (??) ">Hl HΦ". 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". + iFrame. + apply head_reducible_prim_step in Hstep; [|by eauto]. + inv_head_step. + rewrite bool_decide_false //. iFrame. iModIntro. + iSplit; [|done]. + by iApply "HΦ". + Qed. + + Lemma wp_cmpxchg_suc s E l v' v1 v2 (Φ : expr → iProp Σ) : + v' = v1 → vals_compare_safe v' v1 → + ▷ l ↦ v' -∗ + ▷ (l ↦ v2 -∗ Φ $ PairV v' (LitV $ LitBool true)) -∗ + sswp s E (CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2)) Φ. + Proof. + iIntros (??) ">Hl HΦ". 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 (@gen_heap_update with "Hsi Hl") as "[Hsi Hl]". + iMod "Hclose". + iFrame. + apply head_reducible_prim_step in Hstep; [|by eauto]. + inv_head_step. + rewrite bool_decide_true //. iFrame. iModIntro. + iSplit; [|done]. + by iApply "HΦ". + Qed. + + Lemma wp_faa s E (l: loc) (i a: Z) (Φ : expr → iProp Σ) : + ▷ l ↦ #i -∗ + ▷ (l ↦ #(i + a) -∗ Φ #i) -∗ + sswp s E (FAA #l #a) Φ. + Proof. + iIntros ">Hl HΦ". 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 (@gen_heap_update with "Hsi Hl") as "[Hsi Hl]". + iMod "Hclose". + iFrame. + apply head_reducible_prim_step in Hstep; [|by eauto]. + inv_head_step. + iFrame. iModIntro. + iSplit; [|done]. + by iApply "HΦ". + Qed. + +End SSWP. diff --git a/heap_lang/tactics.v b/heap_lang/tactics.v new file mode 100644 index 0000000..52f287f --- /dev/null +++ b/heap_lang/tactics.v @@ -0,0 +1,49 @@ +From 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. From 9d16f6858634d996578412be5f412cc890f629e7 Mon Sep 17 00:00:00 2001 From: fresheed Date: Sun, 31 Aug 2025 15:40:23 +0200 Subject: [PATCH 09/17] restored fairis up to examples --- Makefile | 13 +- _CoqProject | 1 + fairis/destuttering.v | 340 ++++++ fairis/fair_termination.v | 114 ++ fairis/fairness.v | 89 ++ fairis/fairness_finiteness.v | 432 +++++++ fairis/fuel.v | 1287 +++++++++++++++++++++ fairis/fuel_termination.v | 61 + fairis/map_included_utils.v | 484 ++++++++ fairis/resources.v | 2095 ++++++++++++++++++++++++++++++++++ fairness/inftraces.v | 335 ------ fairness/trace_lookup.v | 69 -- 12 files changed, 4913 insertions(+), 407 deletions(-) create mode 100644 fairis/destuttering.v create mode 100644 fairis/fair_termination.v create mode 100644 fairis/fairness.v create mode 100644 fairis/fairness_finiteness.v create mode 100644 fairis/fuel.v create mode 100644 fairis/fuel_termination.v create mode 100644 fairis/map_included_utils.v create mode 100644 fairis/resources.v diff --git a/Makefile b/Makefile index a38bb82..b05bc18 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,8 @@ TRILLIUM_DIR := 'trillium' HL_DIR := 'heap_lang' FAIRNESS_DIR := 'fairness' -SRC_DIRS := $(TRILLIUM_DIR) $(FAIRNESS_DIR) $(HL_DIR) +FAIRIS_DIR := 'fairis' +SRC_DIRS := $(TRILLIUM_DIR) $(FAIRNESS_DIR) $(HL_DIR) $(FAIRIS_DIR) VFILES := $(shell find $(SRC_DIRS) -name "*.v") @@ -42,9 +43,9 @@ clean: rm -f .coqdeps.d # project-specific targets -.PHONY: build clean-trillium trillium clean-fairness fairness clean-heap-lang heap-lang +.PHONY: build clean-trillium trillium clean-fairness fairness clean-heap-lang heap-lang clean-fairis fairis -VPATH= $(TRILLIUM_DIR) $(FAIRNESS_DIR) $(HL_DIR) +VPATH= $(TRILLIUM_DIR) $(FAIRNESS_DIR) $(HL_DIR) $(FAIRIS_DIR) VPATH_FILES := $(shell find $(VPATH) -name "*.v") build: $(VPATH_FILES:.v=.vo) @@ -58,6 +59,9 @@ fairness : heap-lang : @$(MAKE) build VPATH=$(HL_DIR) +fairis : + @$(MAKE) build VPATH=$(FAIRIS_DIR) + clean-trillium: @$(MAKE) clean SRC_DIRS=$(TRILLIUM_DIR) @@ -66,3 +70,6 @@ clean-fairness: clean-heap-lang: @$(MAKE) clean SRC_DIRS=$(HL_DIR) + +clean-fairis: + @$(MAKE) clean SRC_DIRS=$(FAIRIS_DIR) diff --git a/_CoqProject b/_CoqProject index b4333fc..344f20d 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,6 +1,7 @@ -Q trillium trillium -Q heap_lang heap_lang -Q fairness fairness +-Q fairis fairis -arg -w -arg -notation-overridden -arg -w -arg -redundant-canonical-projection diff --git a/fairis/destuttering.v b/fairis/destuttering.v new file mode 100644 index 0000000..60f65bb --- /dev/null +++ b/fairis/destuttering.v @@ -0,0 +1,340 @@ +From fairness Require Import inftraces trace_lookup trace_len. +From Paco Require Import paco1 paco2 pacotac. +From iris.proofmode Require Import tactics. + + + +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. + assert (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; eauto. + by destruct Hind. + Qed. + + Local Ltac gd t := generalize dependent t. + + Lemma upto_stutter_after' + {btr : trace St L} {str : trace S' L'} (n : nat) {btr' : trace St L}: + upto_stutter btr str + → after n btr = Some btr' + → ∃ (n' : nat) (str' : trace S' L'), + after n' str = Some str' ∧ upto_stutter btr' str'. + Proof. + have Hw: ∀ (P: nat -> Prop), (∃ n, P (S n)) -> (∃ n, P n). + { intros P [x ?]. by exists (S x). } + + intros. + gd btr. gd str. gd btr'. induction n as [|n IH]; intros btr' str btr Hupto Hafter. + { injection Hafter => <-. clear Hafter. exists 0, str. done. } + punfold Hupto. + inversion Hupto; subst. + - done. + - simpl in Hafter. rename btr0 into btr. + specialize (IH btr' str btr). + eapply IH; eauto. + by pfold. + - simpl in Hafter. rename btr0 into btr. rename str0 into str. + specialize (IH btr' str btr). + assert (upto_stutter btr str) as UPTO'. + { inversion H1; eauto. done. } + specialize (IH UPTO' Hafter) as (?&?&?&?). + eauto. + Qed. + + Lemma upto_stutter_after_None {btr str} n: + upto_stutter btr str -> + after n str = None -> + ∃ n', after n' btr = None. + Proof. + assert (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; eauto. + 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. + + Lemma upto_stutter_trfirst btr str + (CORR: upto_stutter btr str): + trfirst str = Us (trfirst btr). + Proof. + punfold CORR. by inversion CORR. + 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. + + +Section Lookup. + Context {St S' L L' : Type}. + Context {Us : St → S'}. + Context (Ul: L -> option L'). + + Lemma upto_stutter_trace_label_lookup {btr : trace St L} {str : trace S' L'} + (n : nat) st ℓ st' l: + upto_stutter Us Ul btr str → + btr !! n = Some (st, Some (ℓ, st')) -> + Ul ℓ = Some l -> + ∃ (n' : nat), str L!! n' = Some l. + Proof. + intros UPTO NTH MATCH. + pose proof (trace_has_len btr) as [? LEN]. + apply trace_lookup_after_strong in NTH as (atr' & AFTER & A0). + ogeneralize * (upto_stutter_after' _ _ n UPTO); eauto. + intros (n' & str' & AFTER' & UPTOn). + exists n'. + rewrite -(Nat.add_0_r n'). erewrite <- label_lookup_after; eauto. + punfold UPTOn; [| by apply upto_stutter_mono]. + inversion UPTOn; subst; try congruence. + rewrite label_lookup_0. congruence. + Qed. + + Lemma upto_stutter_state_lookup {btr : trace St L} {str : trace S' L'} n' st': + upto_stutter Us Ul btr str + → str S!! n' = Some st' -> + ∃ n st, btr S!! n = Some st /\ Us st = st'. + Proof. + intros UPTO NTH. + pose proof (trace_has_len str) as [? LEN]. + pose proof (proj1 (state_lookup_dom _ _ LEN n') (mk_is_Some _ _ NTH)) as BOUND. + pose proof (proj2 (LEN _) BOUND) as [str_n AFTER]. + ogeneralize * (upto_stutter_after _ _ n' UPTO); eauto. + intros (n & btr' & AFTER' & UPTOn). + exists n. + rewrite -(Nat.add_0_r n). erewrite <- state_lookup_after; eauto. + rewrite state_lookup_0. f_equal. + eexists. split; [reflexivity| ]. + etransitivity. + { symmetry. eapply upto_stutter_trfirst; eauto. } + apply Some_inj. rewrite -state_lookup_0. + erewrite state_lookup_after; eauto. by rewrite Nat.add_0_r. + Qed. + + Lemma upto_stutter_state_lookup' {btr : trace St L} {str : trace S' L'} (n : nat) bst: + upto_stutter Us Ul btr str + → btr S!! n = Some bst -> + ∃ (n' : nat), + str S!! n' = Some (Us bst). + Proof. + intros UPTO NTH. + pose proof (trace_has_len btr) as [? LEN]. + pose proof (proj1 (state_lookup_dom _ _ LEN n) (mk_is_Some _ _ NTH)) as BOUND. + pose proof (proj2 (LEN _) BOUND) as [btr_n AFTER]. + ogeneralize * (upto_stutter_after' _ _ n UPTO); eauto. + intros (n' & str' & AFTER' & UPTOn). + exists n'. + rewrite -(Nat.add_0_r n'). erewrite <- state_lookup_after; eauto. + rewrite state_lookup_0. f_equal. + erewrite upto_stutter_trfirst; [..| apply UPTOn]; eauto. + f_equal. apply Some_inj. + rewrite -state_lookup_0. + erewrite state_lookup_after; eauto. by rewrite Nat.add_0_r. + Qed. + +End Lookup. diff --git a/fairis/fair_termination.v b/fairis/fair_termination.v new file mode 100644 index 0000000..35f65f5 --- /dev/null +++ b/fairis/fair_termination.v @@ -0,0 +1,114 @@ +From fairness Require Export fairness. +From stdpp Require Import option. +From Paco Require Import pacotac. +From iris.proofmode Require Import tactics. + + +(* 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. + +Class FairTerminatingModel (Mdl: FairModel) := { + ftm_leq: relation Mdl; + ftm_order: PreOrder ftm_leq; + ftm_wf: well_founded (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 *. + + (* replace (fairness_sat role_enabled_model role_match *) + (* (ftm_decreasing_role (trfirst mtr))) with ((fun c => fairness_sat role_enabled_model role_match *) + (* (ftm_decreasing_role c)) (trfirst mtr)) in Hev. *) + + rewrite /pred_at /= in Hev. + (* destruct Hev as [Hev|Hev]; first by destruct mtr; done. *) + destruct mtr. + { exists 1. done. } + destruct Hev as [Hev|Hev]; [done| ]. + rewrite /role_match in Hev. + destruct Hev as (? & [=<-] & EQ). simpl in EQ. + simpl. + 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. + + eapply fair_by_cons_forall; eauto. + - 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. + eapply fair_by_cons_forall; eauto. + + 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 =>//. + * eapply fair_by_cons_forall; eauto. + * 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/fairis/fairness.v b/fairis/fairness.v new file mode 100644 index 0000000..53edc6b --- /dev/null +++ b/fairis/fairness.v @@ -0,0 +1,89 @@ +(* 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. *) + + +(* 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/fairis/fairness_finiteness.v b/fairis/fairness_finiteness.v new file mode 100644 index 0000000..29fa9ce --- /dev/null +++ b/fairis/fairness_finiteness.v @@ -0,0 +1,432 @@ +From stdpp Require Import finite. +From trillium.prelude Require Import finitary quantifiers classical_instances. +From fairness Require Import fairness. +From fairis Require Import 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 `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + Context `{EqDecision M}. + + 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ζ) as Hfin. + by apply smaller_card_nat_finite in Hfin. + 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 Hxi. unfold enum_inner. rewrite elem_of_list_fmap. + exists (exist _ (δ', ℓ) Hxi). 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 $ ls_data s) (λ lab, get_role lab) aux). + + Program Definition enumerate_next extr (fmodtr: auxiliary_trace LM) c' oζ: + list (LiveStateData Λ M * @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 (ls_fuel δ1) ∪ live_roles _ s2); + (* ms ← enum_gmap_range_bounded' (live_roles _ s2 ∪ d) (locales_of_list c'.1); *) + let fss := enumerate_subdomain_gmap d (max_gmap (ls_fuel δ1) `max` LM.(lm_fl) s2) in + locs ← enumerate_dom_gsets' $ list_to_set $ locales_of_list c'.1; + ms ← enum_gmap_range_bounded' locs fss; + 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_map := `ms; + |}, ℓ'). + + Local Instance condition_1_decision x : + Decision + (∀ (ζ ζ' : locale Λ) (fs fs' : gmap (fmrole M) nat), + ζ ≠ ζ' → ls_map x !! ζ = Some fs → ls_map x !! ζ' = Some fs' → fs ##ₘ fs'). + Proof. apply make_decision. Qed. + + Definition to_ls (x: LiveStateData Λ M) : option LM := + match decide (∀ ζ ζ' fs fs', ζ ≠ ζ' → x.(ls_map) !! ζ = Some fs → x.(ls_map) !! ζ' = Some fs' → fs ##ₘ fs') + with + | right _ => None + | left Hdisj => + match decide (∀ ρ, ρ ∈ M.(live_roles) x.(ls_under) → ∃ ζ fs, x.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs) with + | right _ => None + | left Hlive => Some {| ls_data := x; ls_map_disj := Hdisj; ls_map_live := Hlive |} + end + end. + + Definition enumerate_next_valid extr (fmodtr: auxiliary_trace LM) c' oζ: list (LM * @mlabel LM) := + let ns := enumerate_next extr fmodtr c' oζ in + omap (λ '(x, ℓ), (λ x, (x, ℓ)) <$> to_ls x) ns. + + 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 [tp' σ'] oζ. + eapply finite_smaller_card_nat. + simpl. + eapply (in_list_finite (enumerate_next_valid ex atr (tp',σ') oζ)). + intros [δ' ℓ] [[Hlbl [Htrans Htids]] [Hξ Hφ]]. + unfold enumerate_next_valid. + + apply elem_of_list_omap. + exists (δ'.(ls_data), ℓ). + + split; last first. + { simpl. rewrite /to_ls /=. + destruct (decide + (∀ (ζ ζ' : locale Λ) (fs fs' : gmap (fmrole M) nat), + ζ ≠ ζ' → ls_map δ' !! ζ = Some fs → ls_map δ' !! ζ' = Some fs' → fs ##ₘ fs')); last first. + { pose proof ls_map_disj δ'. done. } + destruct (decide + (∀ ρ : fmrole M, ρ ∈ live_roles M δ' → ∃ (ζ : locale Λ) (fs : gmap (fmrole M) nat), + ls_map δ' !! ζ = Some fs ∧ ρ ∈ dom fs)). + - simpl. do 2 f_equal. destruct δ'. simpl. destruct ls_data. f_equal. + eapply proof_irrel. + eapply proof_irrel. + - pose proof ls_map_live δ'. done. } + + 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. } + + exists (dom δ'.(ls_data).(ls_map)). + split; last first. + { apply enumerate_dom_gsets'_spec. intros ζ Hin. simpl. + unfold tids_smaller in Htids. + specialize (Htids _ Hin). + by apply elem_of_list_to_set, locales_of_list_from_locale_from. } + + apply elem_of_list_bind. + unshelve eexists (ls_map δ' ↾ _); first done. split. + { apply elem_of_list_ret. destruct ℓ; destruct oζ; simpl; try naive_solver; + f_equal; try naive_solver. + - destruct δ'. simpl. destruct ls_data. simpl. done. + - destruct δ'. simpl. destruct ls_data. simpl. done. } + + apply enum_gmap_range_bounded'_spec. split=>//. + intros ζ fs Hlk. apply enumerate_subdomain_gmap_spec. + { intros ρ Hin. eapply ls_fuel_dom_data =>//. } + intros ρ f Hlk'. + have Hsome: ls_fuel δ' !! ρ = Some f by eapply ls_fuel_data. + have Hmapping: ls_mapping δ' !! ρ = Some ζ. + { eapply ls_mapping_data=>//. apply elem_of_dom. naive_solver. } + + destruct ℓ as [ρ' tid' | |]. + - destruct (decide (ρ = ρ')) as [-> | Hneq]. + + inversion Htrans as [? Hbig]. destruct Hbig as (Hmap&Hleq&?&Hlim&?&?). + rewrite Hsome /= in Hlim. 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. naive_solver. + + Unshelve. + + intros ??. apply make_decision. + + intros. apply make_proof_irrel. + + intros. apply make_proof_irrel. + + intros. apply make_proof_irrel. + + done. + Qed. +End finitary. + +Section finitary_simple. + Context `{M: FairModel}. + Context `{Λ: language}. + Context `{EqDecision M}. + Context `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + + 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 Ht. unfold enum_inner. rewrite elem_of_list_fmap. + exists (exist _ (s2, ℓ) Ht). split =>//. apply elem_of_enum. + Qed. + + Program Definition enumerate_next_simple (fmodtr: auxiliary_trace LM) (c': cfg Λ) oζ: + list (LiveStateData Λ M * @mlabel LM) := + let δ1 := trace_last fmodtr in + '(s2, ℓ) ← (δ1.(ls_under), None) :: enum_inner_simple δ1.(ls_under); + d ← enumerate_dom_gsets' (dom (ls_fuel δ1) ∪ live_roles _ s2); + (* ms ← enum_gmap_range_bounded' (live_roles _ s2 ∪ d) (locales_of_list c'.1); *) + let fss := enumerate_subdomain_gmap d (max_gmap (ls_fuel δ1) `max` LM.(lm_fl) s2) in + locs ← enumerate_dom_gsets' $ list_to_set $ locales_of_list c'.1; + ms ← enum_gmap_range_bounded' locs fss; + 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_map := `ms; + |}, ℓ'). + + Definition enumerate_next_valid_simple (fmodtr: auxiliary_trace LM) c' oζ: list (LM * @mlabel LM) := + let ns := enumerate_next_simple fmodtr c' oζ in + omap (λ '(x, ℓ), (λ x, (x, ℓ)) <$> to_ls x) ns. + + Lemma valid_state_evolution_finitary_fairness_simple (φ: execution_trace Λ -> auxiliary_trace LM -> Prop) : + rel_finitary (valid_lift_fairness φ). + Proof. + rewrite /valid_lift_fairness. + intros ex atr [tp' σ'] oζ. + eapply finite_smaller_card_nat. + simpl. + eapply (in_list_finite (enumerate_next_valid_simple atr (tp',σ') oζ)). + intros [δ' ℓ] [[Hlab [Htrans Hsmall]] ?]. + unfold enumerate_next_valid. + + apply elem_of_list_omap. + exists (δ'.(ls_data), ℓ). + + split; last first. + { simpl. rewrite /to_ls /=. + destruct (decide + (∀ (ζ ζ' : locale Λ) (fs fs' : gmap (fmrole M) nat), + ζ ≠ ζ' → ls_map δ' !! ζ = Some fs → ls_map δ' !! ζ' = Some fs' → fs ##ₘ fs')); last first. + { pose proof ls_map_disj δ'. done. } + destruct (decide + (∀ ρ : fmrole M, ρ ∈ live_roles M δ' → ∃ (ζ : locale Λ) (fs : gmap (fmrole M) nat), + ls_map δ' !! ζ = Some fs ∧ ρ ∈ dom fs)). + - simpl. do 2 f_equal. destruct δ'. simpl. destruct ls_data. f_equal. + eapply proof_irrel. + eapply proof_irrel. + - pose proof ls_map_live δ'. done. } + + 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_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 $ 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. } + + exists (dom δ'.(ls_data).(ls_map)). + split; last first. + { apply enumerate_dom_gsets'_spec. intros ζ Hin. simpl. + unfold tids_smaller in Hsmall. + specialize (Hsmall _ Hin). + by apply elem_of_list_to_set, locales_of_list_from_locale_from. } + + apply elem_of_list_bind. + unshelve eexists (ls_map δ' ↾ _); first done. split. + { apply elem_of_list_ret. destruct ℓ; destruct oζ; simpl; try naive_solver; + f_equal; try naive_solver. + - destruct δ'. simpl. destruct ls_data. simpl. done. + - destruct δ'. simpl. destruct ls_data. simpl. done. } + + apply enum_gmap_range_bounded'_spec. split=>//. + intros ζ fs Hlk. apply enumerate_subdomain_gmap_spec. + { intros ρ Hin. eapply ls_fuel_dom_data =>//. } + intros ρ f Hlk'. + have Hsome: ls_fuel δ' !! ρ = Some f by eapply ls_fuel_data. + have Hmapping: ls_mapping δ' !! ρ = Some ζ. + { eapply ls_mapping_data=>//. apply elem_of_dom. naive_solver. } + + destruct ℓ as [ρ' tid' | |]. + - destruct (decide (ρ = ρ')) as [-> | Hneq]. + + inversion Htrans as [? Hbig]. destruct Hbig as (Hmap&Hleq&?&Hlim&?&?). + rewrite Hsome /= in Hlim. 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. naive_solver. + + Unshelve. + + intros ??. apply make_decision. + + intros. apply make_proof_irrel. + + intros. apply make_proof_irrel. + + intros. apply make_proof_irrel. + + done. + Qed. +End finitary_simple. + +(* TODO: Why do we need [LM] explicit here? *) +Definition live_rel `{Countable (locale Λ)} `(LM: LiveModel Λ M) + (ex : execution_trace Λ) (aux : auxiliary_trace LM) := + live_tids (LM:=LM) (trace_last ex) (trace_last aux). + +Definition sim_rel `{Countable (locale Λ)} `(LM: LiveModel Λ M) + (ex : execution_trace Λ) (aux : auxiliary_trace LM) := + valid_state_evolution_fairness ex aux ∧ live_rel LM ex aux. + +Definition sim_rel_with_user `{Countable (locale Λ)} `(LM: LiveModel Λ M) + (ξ : 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 + `{Countable (locale Λ)} `{LM:LiveModel Λ Mdl} + (ξ : 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_ξ + `{Countable (locale Λ)} `{LM:LiveModel Λ Mdl} ξ : + 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 + `{Countable (locale Λ)} `{LM:LiveModel Λ Mdl} + `{EqDecision (mstate LM)} `{EqDecision (mlabel LM)} + ξ : + 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/fairis/fuel.v b/fairis/fuel.v new file mode 100644 index 0000000..485d1d2 --- /dev/null +++ b/fairis/fuel.v @@ -0,0 +1,1287 @@ +From stdpp Require Import option gmap. +From Paco Require Import paco1 paco2 pacotac. +From trillium.program_logic Require Export adequacy. +From fairness Require Export inftraces fairness. +From fairis Require Import destuttering. + + +Section fairness. + Context {Λ : language}. + Context {M: FairModel}. + Context `{Countable (locale Λ)}. + + Record LiveStateData := MkLiveStateData { + ls_under:> M.(fmstate); + ls_map: gmap (locale Λ) (gmap M.(fmrole) nat); + }. + Record LiveState := MkLiveState { + ls_data :> LiveStateData; + + ls_map_disj: ∀ ζ ζ' fs fs', ζ ≠ ζ' → ls_data.(ls_map) !! ζ = Some fs → ls_data.(ls_map) !! ζ' = Some fs' → fs ##ₘ fs'; + ls_map_live: ∀ ρ, ρ ∈ M.(live_roles) ls_data.(ls_under) → ∃ ζ fs, ls_data.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs; + }. + + Implicit Type δ : LiveState. + + Definition ls_fuel (δ: LiveStateData) : gmap M.(fmrole) nat := + map_fold (λ _ m fs, m ∪ fs) ∅ δ.(ls_map). + Definition add_stuff ζ (m: gmap M.(fmrole) (locale Λ)) (rs: gset M.(fmrole)) := + gset_to_gmap ζ rs ∪ m. + Definition ls_mapping (δ: LiveStateData) : gmap M.(fmrole) (locale Λ) := + map_fold (λ ζ fs m, add_stuff ζ m (dom fs)) (∅: gmap M.(fmrole) (locale Λ)) δ.(ls_map). + + (* Lemma ls_fuel_dom δ ρ: ρ ∈ dom $ ls_mapping δ = dom $ ls_fuel δ. *) + Lemma dom_add_stuff ζ m rs : dom $ add_stuff ζ m rs = rs ∪ dom m. + Proof. + rewrite /add_stuff. + revert m. induction rs using set_ind_L; first set_solver; intros m. + rewrite gset_to_gmap_union_singleton !dom_union_L dom_insert_L. set_solver. + Qed. + + Lemma add_stuff_commute ζ1 ζ2 m s1 s2 : + s1 ## s2 → + add_stuff ζ2 (add_stuff ζ1 m s1) s2 = add_stuff ζ1 (add_stuff ζ2 m s2) s1. + Proof. + rewrite /add_stuff. intros Hdisj. rewrite !assoc. f_equal. + rewrite map_union_comm //. + apply map_disjoint_dom_2. rewrite !dom_gset_to_gmap //. + Qed. + (*TODO: why commute above and comm below? *) + + Lemma ls_same_doms δ: dom $ ls_mapping δ = dom $ ls_fuel δ. + Proof. + rewrite /ls_mapping /ls_fuel. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ fs m Hnotin IH] using map_ind ; first set_solver. + intros Hdisj. + rewrite map_fold_insert_L //; last first. + { intros. apply add_stuff_commute. eapply map_disjoint_dom. rewrite comm in H0. eapply Hdisj; eauto. } + rewrite map_fold_insert_L //; last first. + { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } + rewrite dom_add_stuff !dom_union_L. + rewrite IH //. intros. eapply Hdisj; eauto; rewrite lookup_insert_ne //; naive_solver. + Qed. + + Lemma ls_fuel_data ρ δ ζ fs f: δ.(ls_map) !! ζ = Some fs → fs !! ρ = Some f → ls_fuel δ !! ρ = Some f. + Proof. + rewrite /ls_fuel. revert ρ ζ fs f. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind ; first set_solver. + intros Hdisj ρ ζ fs f Hsome Hin. + rewrite map_fold_insert_L //; last first. + { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } + rewrite lookup_union_Some_raw. destruct (decide (ζ = ζ')) as [->|Hneq]. + - left. rewrite lookup_insert in Hsome. naive_solver. + - right. rewrite lookup_insert_ne // in Hsome. split. + + assert (fs ##ₘ fs'). + { eapply Hdisj; eauto; [rewrite lookup_insert_ne // | rewrite lookup_insert //]. } + by eapply map_disjoint_Some_l. + + eapply IH; eauto. intros. + eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. + Qed. + + Lemma ls_mapping_data ρ δ ζ fs: δ.(ls_map) !! ζ = Some fs → ρ ∈ dom fs → ls_mapping δ !! ρ = Some ζ. + Proof. + rewrite /ls_mapping. revert ρ ζ fs. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind ; first set_solver. + intros Hdisj ρ ζ fs Hsome Hin. + rewrite map_fold_insert_L //; last first. + { intros. apply add_stuff_commute. eapply map_disjoint_dom. rewrite comm in H0. eapply Hdisj; eauto. } + rewrite /add_stuff. + rewrite lookup_union_Some_raw. destruct (decide (ζ = ζ')) as [->|Hneq]. + - left. rewrite lookup_insert in Hsome. rewrite lookup_gset_to_gmap_Some. naive_solver. + - right. rewrite lookup_insert_ne // in Hsome. split. + + assert (fs ##ₘ fs'). + { eapply Hdisj; eauto; [rewrite lookup_insert_ne // | rewrite lookup_insert //]. } + rewrite lookup_gset_to_gmap_None not_elem_of_dom. apply elem_of_dom in Hin as [??]. + by eapply map_disjoint_Some_l. + + eapply IH; eauto. intros. + eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. + Qed. + Lemma ls_mapping_data_inv ρ δ ζ: ls_mapping δ !! ρ = Some ζ → ∃ fs, δ.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs. + Proof. + rewrite /ls_mapping. revert ρ ζ. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind ; first set_solver. + intros Hdisj ρ ζ Hsome. + rewrite map_fold_insert_L // in Hsome; last first. + { intros. apply add_stuff_commute. eapply map_disjoint_dom. rewrite comm in H0. eapply Hdisj; eauto. } + rewrite /add_stuff in Hsome. + rewrite lookup_union_Some_raw in Hsome. destruct Hsome as [Hsome|[Hnone Hsome]]. + - rewrite lookup_gset_to_gmap_Some in Hsome. destruct Hsome as [? ->]. + rewrite lookup_insert. naive_solver. + - assert (∃ fs : gmap (fmrole M) nat, m !! ζ = Some fs ∧ ρ ∈ dom fs) as (fs&?&?). + { eapply IH; eauto. intros. eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. } + exists fs; split; eauto. + rewrite lookup_insert_ne //. naive_solver. + Qed. + + Lemma ls_fuel_dom_data ρ δ ζ fs: δ.(ls_map) !! ζ = Some fs → ρ ∈ dom fs → ρ ∈ dom $ ls_fuel δ. + Proof. + rewrite /ls_fuel. revert ρ ζ fs. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind ; first set_solver. + intros Hdisj ρ ζ fs Hsome Hin. + rewrite map_fold_insert_L //; last first. + { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } + rewrite dom_union. apply elem_of_union. destruct (decide (ζ = ζ')) as [->|Hneq]. + - left. rewrite lookup_insert in Hsome. naive_solver. + - right. rewrite lookup_insert_ne // in Hsome. eapply IH; eauto. intros. + eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. + Qed. + + Lemma ls_fuel_data_inv ρ δ f: ls_fuel δ !! ρ = Some f → ∃ ζ fs, δ.(ls_map) !! ζ = Some fs ∧ fs !! ρ = Some f. + Proof. + rewrite /ls_fuel. revert ρ f. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind. + { intros ??. rewrite map_fold_empty. set_solver. } + intros Hdisj ρ f Hin. + rewrite map_fold_insert_L // in Hin; last first. + { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } + rewrite lookup_union_Some_raw in Hin. destruct Hin as [Hin|[? Hin]]. + - exists ζ', fs'. rewrite lookup_insert. naive_solver. + - assert (∃ ζ fs, m !! ζ = Some fs ∧ fs !! ρ = Some f) as [ζ [fs Hζ]]. + { apply IH; eauto. + intros ???????. eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. } + exists ζ, fs. rewrite lookup_insert_ne //. naive_solver. + Qed. + + Lemma ls_fuel_dom_data_inv ρ δ: ρ ∈ dom $ ls_fuel δ → ∃ ζ fs, δ.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs. + Proof. + rewrite /ls_fuel. revert ρ. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind. + { intros ??. rewrite map_fold_empty. set_solver. } + intros Hdisj ρ Hin. + rewrite map_fold_insert_L // in Hin; last first. + { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } + rewrite dom_union in Hin. apply elem_of_union in Hin as [Hin|Hin]. + - exists ζ', fs'. rewrite lookup_insert. naive_solver. + - assert (∃ ζ fs, m !! ζ = Some fs ∧ ρ ∈ dom fs) as [ζ [fs Hζ]]. + { apply IH; eauto. + intros ???????. eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. } + exists ζ, fs. rewrite lookup_insert_ne //. naive_solver. + Qed. + + Lemma ls_fuel_suff δ ρ: ρ ∈ dom $ ls_fuel δ → ∃ ζ fs, δ.(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs. + Proof. + rewrite /ls_fuel. revert ρ. + generalize (ls_map_disj δ). + induction δ.(ls_map) as [|ζ' fs' m Hnotin IH] using map_ind. + { intros ??. rewrite map_fold_empty. set_solver. } + intros Hdisj ρ Hin. + rewrite map_fold_insert_L // in Hin; last first. + { intros. rewrite !assoc. rewrite (map_union_comm z1 z2) //. eapply Hdisj; eauto. } + rewrite dom_union in Hin. apply elem_of_union in Hin as [Hin|Hin]. + - exists ζ', fs'. rewrite lookup_insert. naive_solver. + - assert (∃ ζ fs, m !! ζ = Some fs ∧ ρ ∈ dom fs) as [ζ [fs Hζ]]. + { apply IH; eauto. + intros ???????. eapply Hdisj; eauto; rewrite lookup_insert_ne //; set_solver. } + exists ζ, fs. rewrite lookup_insert_ne //. naive_solver. + Qed. + + + Lemma ls_fuel_dom δ: M.(live_roles) δ.(ls_under) ⊆ dom $ ls_fuel δ. + Proof. + generalize (ls_map_live δ). + induction (live_roles M δ) as [|ρ ρs Hnotin IH] using set_ind_L ; first set_solver. + intros Hlive. apply union_subseteq; split; last first. + { apply IH. intros. apply Hlive. set_solver. } + apply singleton_subseteq_l. destruct (Hlive ρ ltac:(set_solver)) as (ζ&fs&Hlk&Hin). + by eapply ls_fuel_dom_data. + Qed. + + + Lemma ls_mapping_dom (m: LiveState): + M.(live_roles) m.(ls_under) ⊆ dom $ ls_mapping m. + 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: LiveStateData): + olocale Λ -> Prop := + | Same_tid tid (Hneqρ: Some ρ' ≠ oρ) (Hsametid: Some tid = ls_mapping a !! ρ'): + must_decrease ρ' oρ a b (Some tid) + | Change_tid otid (Hneqtid: ls_mapping a !! ρ' ≠ ls_mapping b !! ρ') + (Hissome: is_Some (ls_mapping b !! ρ')): + must_decrease ρ' oρ a b otid + (* | Zombie otid (Hismainrole: oρ = Some ρ') (Hnotalive: ρ' ∉ live_roles _ b) (Hnotdead: ρ' ∈ dom $ ls_fuel b): *) + (* must_decrease ρ' oρ a b otid *) + . + + Definition fuel_decr (tid: olocale Λ) (oρ: option M.(fmrole)) + (a b: LiveStateData) := + ∀ ρ', ρ' ∈ dom $ ls_fuel a -> ρ' ∈ dom $ ls_fuel b → + must_decrease ρ' oρ a b tid -> + oless (ls_fuel b !! ρ') (ls_fuel a !! ρ'). + + Definition fuel_must_not_incr oρ (a b: LiveStateData) := + ∀ ρ', ρ' ∈ dom $ ls_fuel a -> Some ρ' ≠ oρ -> + (oleq (ls_fuel b !! ρ') (ls_fuel a !! ρ') + ∨ (ρ' ∉ dom $ ls_fuel b ∧ ρ' ∉ M.(live_roles) a.(ls_under))). + + Lemma ls_map_agree {δ ρ ζ1 ζ2 fs1 fs2} : + δ.(ls_map) !! ζ1 = Some fs1 → + δ.(ls_map) !! ζ2 = Some fs2 → + ρ ∈ dom fs1 → + ρ ∈ dom fs2 → + ζ1 = ζ2 ∧ fs1 = fs2. + Proof. + intros Hlk1 Hlk2 [??]%elem_of_dom [??]%elem_of_dom. + destruct (decide (ζ1 = ζ2)) as [|Hneq]; first naive_solver. + have ?:= ls_map_disj _ _ _ _ _ Hneq Hlk1 Hlk2. exfalso. + by eapply map_disjoint_spec. + Qed. + + Definition ls_trans (fuel_limit : M → nat) (a: LiveStateData) ℓ (b: LiveStateData): Prop := + match ℓ with + | Take_step ρ tid => + M.(fmtrans) a (Some ρ) b + ∧ ls_mapping a !! ρ = Some tid + ∧ fuel_decr (Some tid) (Some ρ) a b + ∧ fuel_must_not_incr (Some ρ) a b + ∧ (oleq (ls_fuel b !! ρ) (Some (fuel_limit b))) + ∧ (∀ ρ, ρ ∈ (dom $ ls_fuel b) ∖ (dom $ ls_fuel a) -> oleq (ls_fuel b !! ρ) (Some (fuel_limit b))) + ∧ (dom $ ls_fuel b) ∖ (dom $ ls_fuel a) ⊆ live_roles _ b ∖ live_roles _ a + | Silent_step tid => + (∃ ρ, ls_mapping a !! ρ = Some tid) + ∧ fuel_decr (Some tid) None a b + ∧ fuel_must_not_incr None a b + ∧ dom $ ls_fuel b ⊆ dom $ ls_fuel a + ∧ 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 (ls_fuel b !! ρ) (Some (fuel_limit b))) + ∧ False (* TODO: add support for config steps later! *) + end. + + Lemma silent_step_suff_data fl (δ: LiveState) (fs fs' fs'': gmap _ nat) ζ (oζ' : option $ locale Λ) : + δ.(ls_map) !! ζ = Some fs → + fs ≠ ∅ → + (∀ ρ f', fs' !! ρ = Some f' → ∃ f, fs !! ρ = Some f ∧ f' < f) → + (∀ ρ f', fs'' !! ρ = Some f' → ∃ f, fs !! ρ = Some f ∧ f' < f) → + (dom fs ∖ (dom fs' ∪ dom fs'') ∩ M.(live_roles) δ = ∅) → + (dom fs' ∩ dom fs'' = ∅) → + (∀ ζ', oζ' = Some ζ' → ζ' ∉ dom δ.(ls_map)) → + (oζ' = None → fs'' = ∅) → + let data' := + match oζ' with + | None => δ.(ls_map) + | Some ζ' => <[ζ' := fs'']> δ.(ls_map) + end + in + let data'' := <[ζ := fs']> data' in + ∃ δ', δ'.(ls_data) = {| ls_under := δ; ls_map := data'' |} ∧ + ls_trans fl δ (Silent_step ζ) δ'. + Proof. + intros Hζ Hnemp Hfs' Hfs'' Hlives Hdisj Hnlocale Hifnone data' data''. + have Hincl' : dom fs' ⊆ dom fs. + { intros ?[? Hin]%elem_of_dom. by apply Hfs' in Hin as [?[?%elem_of_dom_2 ?]]. } + have Hincl'' : dom fs'' ⊆ dom fs. + { intros ?[? Hin]%elem_of_dom. by apply Hfs'' in Hin as [?[?%elem_of_dom_2 ?]]. } + assert (∃ δ', δ'.(ls_data) = {| ls_under := δ; ls_map := data'' |}) as [δ' Hd]. + { unshelve refine (ex_intro _ {| ls_data := {| ls_under := δ; ls_map := data'' |} |} _); last done. + { rewrite /data'' /=. intros z1 z2 fs1 fs2 Hneq Hlk1 Hlk2. apply map_disjoint_dom_2. + intros ρ Hin1 Hin2. destruct (decide (z1 = ζ)) as [->|Hneq1]. + - rewrite lookup_insert in Hlk1. simplify_eq. rewrite lookup_insert_ne // /data' in Hlk2. + destruct oζ' as [ζ'|]. + + destruct (decide (z2 = ζ')) as [->|Hneq2]. + * rewrite lookup_insert in Hlk2. simplify_eq. set_solver. + * rewrite lookup_insert_ne // in Hlk2. have ?: ρ ∈ dom fs by set_solver. + apply Hneq. eapply ls_map_agree; eauto. + + apply Hneq. eapply ls_map_agree; eauto. + - rewrite lookup_insert_ne // /data' in Hlk1. + destruct oζ' as [ζ'|]. + + destruct (decide (z1 = ζ')) as [->|Hneq2]. + * rewrite lookup_insert in Hlk1. simplify_eq. + destruct (decide (z2 = ζ)) as [->|Hneq3]. + ** rewrite lookup_insert in Hlk2. simplify_eq. set_solver. + ** rewrite !lookup_insert_ne // in Hlk2. specialize (Hnlocale _ ltac:(done)). + have ?: ρ ∈ dom fs by set_solver. + have ?: z2 = ζ by eapply ls_map_agree. simplify_eq. + * rewrite lookup_insert_ne // in Hlk1. + destruct (decide (z2 = ζ)) as [->|Hneq3]. + ** rewrite lookup_insert in Hlk2. simplify_eq. + have ?: ρ ∈ dom fs by set_solver. + apply Hneq. by eapply ls_map_agree. + ** rewrite lookup_insert_ne // /data' in Hlk2. + destruct (decide (z2 = ζ')) as [->|Hneq4]. + *** rewrite lookup_insert in Hlk2. simplify_eq. + apply Hneq1. eapply ls_map_agree; eauto. + *** rewrite lookup_insert_ne // in Hlk2. + have Hdone: fs1 ##ₘ fs2 by eapply (ls_map_disj δ z1 z2). + apply map_disjoint_dom in Hdone. + set_solver. + + destruct (decide (z2 = ζ)) as [->|Hneq3]. + ** rewrite lookup_insert in Hlk2. simplify_eq. + have ?: ρ ∈ dom fs by set_solver. + apply Hneq. by eapply ls_map_agree. + ** rewrite lookup_insert_ne // /data' in Hlk2. + have Hdone: fs1 ##ₘ fs2 by eapply (ls_map_disj δ z1 z2). + apply map_disjoint_dom in Hdone. + set_solver. } + { intros ρ Hlive. destruct (ls_map_live δ ρ Hlive) as (ζ0&fs0&?&?). + destruct (decide (ζ = ζ0)) as [->|]. + - have Hin: ρ ∈ dom fs' ∪ dom fs''. + { simpl in Hlive. simplify_eq. clear Hincl' Hincl''. + destruct (decide (ρ ∈ dom fs' ∪ dom fs'')); [done|set_solver]. } + apply elem_of_union in Hin as [Hin|Hin]. + + exists ζ0, fs'. rewrite lookup_insert //. + + destruct oζ' as [ζn|]; last naive_solver. + exists ζn, fs''. split=>//=. rewrite /data'' /data' lookup_insert_ne // ?lookup_insert //. + intros ->. eapply Hnlocale; eauto. by eapply elem_of_dom_2. + - exists ζ0, fs0. split; last done. rewrite /data'' /data' lookup_insert_ne // ?lookup_insert //. + destruct oζ' as [ζn|]; last naive_solver. rewrite lookup_insert_ne //. + intros ->. eapply Hnlocale; eauto. by eapply elem_of_dom_2. } } + exists δ'. split; first done. + constructor. + { destruct (map_choose _ Hnemp) as (ρ&?&?). exists ρ. eapply ls_mapping_data; eauto. + apply elem_of_dom. naive_solver. } + split; [|split; [| split; [|by rewrite Hd//]]]. + - rewrite /fuel_decr /=. intros ρ' Hin Hin' Hmd. + apply elem_of_dom in Hin as [f Hf]. + apply elem_of_dom in Hin' as [f' Hf']. + rewrite Hf Hf' /=. + inversion Hmd; simplify_eq. + + symmetry in Hsametid. + apply ls_mapping_data_inv in Hsametid as (fs0&Hmap0&Hin0). + simplify_eq. + apply ls_fuel_data_inv in Hf as (ζ'&fs0&?&?). + have [??] : ζ' = ζ ∧ fs0 = fs. + { eapply ls_map_agree; eauto. apply elem_of_dom; naive_solver. } + simplify_eq. + apply ls_fuel_data_inv in Hf' as (ζ2&fs2&Hmap'&Hfs2). + rewrite Hd /= /data'' in Hmap'. destruct (decide (ζ = ζ2)) as [->|Hneq]. + { rewrite lookup_insert in Hmap'. simplify_eq. + destruct (Hfs' _ _ Hfs2). naive_solver. } + rewrite lookup_insert_ne // /data' in Hmap'. destruct (oζ') as [ζn|]. + * destruct (decide (ζn = ζ2)) as [->|Hneqζ]. + ** rewrite lookup_insert in Hmap'. simplify_eq. + destruct (Hfs'' _ _ Hfs2). naive_solver. + ** rewrite lookup_insert_ne // in Hmap'. + have [??] : ζ2 = ζ ∧ fs2 = fs; last by simplify_eq. + eapply ls_map_agree; eauto. apply elem_of_dom; naive_solver. + * have [??] : ζ2 = ζ ∧ fs2 = fs; last by simplify_eq. + eapply ls_map_agree; eauto. apply elem_of_dom; naive_solver. + + destruct Hissome as [ζ0 Hlk0]. + rewrite Hlk0 in Hneqtid. + apply ls_fuel_data_inv in Hf as (ζ'&fs0&?&?). + apply ls_fuel_data_inv in Hf' as (ζ2&fs2&Hmap'&Hfs2). + apply ls_mapping_data_inv in Hlk0 as (fs3&Hmap3&Hdom3). + have [??] : ζ0 = ζ2 ∧ fs3 = fs2. + { eapply ls_map_agree; eauto. apply elem_of_dom; naive_solver. } + simplify_eq. + rewrite Hd /data'' /= in Hmap'. destruct (decide (ζ2 = ζ)); first simplify_eq. + * rewrite lookup_insert in Hmap'. symmetry in Hmap'. simplify_eq. + destruct (Hfs' _ _ Hfs2) as (?&?&?). exfalso; apply Hneqtid. + rewrite (ls_mapping_data ρ' δ ζ fs) in Hneqtid; [done|done|apply elem_of_dom; naive_solver]. + * rewrite lookup_insert_ne // /data' in Hmap'. destruct oζ' as [ζn|]. destruct (decide (ζ2 = ζn)). + ** simplify_eq. rewrite lookup_insert in Hmap'. simplify_eq. + destruct (Hfs'' _ _ Hfs2) as (ff&?&?). + have [??] : ζ' = ζ ∧ fs0 = fs; last by simplify_eq. + eapply ls_map_agree; eauto; apply elem_of_dom; naive_solver. + ** rewrite lookup_insert_ne // in Hmap'. exfalso; apply Hneqtid. + rewrite (ls_mapping_data ρ' δ ζ2 fs2) in Hneqtid; done. + ** have [??] : ζ' = ζ2 ∧ fs0 = fs2; last simplify_eq. + { eapply ls_map_agree; eauto; apply elem_of_dom; naive_solver. } + exfalso; apply Hneqtid. + eapply ls_mapping_data; eauto. + - rewrite /fuel_must_not_incr. intros ρ' Hin' _. + apply elem_of_dom in Hin' as [f Hf]. rewrite Hf. + apply ls_fuel_data_inv in Hf as (ζ'&fs0&Hmap&Hlk). + destruct (decide (ζ' = ζ)) as [->|]. + + have ? : fs0 = fs by naive_solver. simplify_eq. + destruct (decide (ρ' ∈ dom fs' ∪ dom fs'')) as [[Hin|Hin]%elem_of_union|Hnin]. + * left. apply elem_of_dom in Hin as [f' Hlk']. + destruct (Hfs' _ _ Hlk') as (?&?&?). + have -> /= : ls_fuel δ' !! ρ' = Some f'. + { eapply (ls_fuel_data _ _ ζ); eauto. rewrite Hd /data'' /= lookup_insert //. } + naive_solver lia. + * left. apply elem_of_dom in Hin as [f' Hlk']. + destruct (Hfs'' _ _ Hlk') as (?&?&?). + have -> /= : ls_fuel δ' !! ρ' = Some f'. + destruct oζ' as [ζn|]; last set_solver. + { eapply (ls_fuel_data _ _ ζn); eauto. + rewrite Hd /data'' /= lookup_insert_ne // /data' ?lookup_insert //. + intros ->. eapply Hnlocale; eauto. by eapply elem_of_dom_2. } + naive_solver lia. + * have Hdead: ρ' ∉ live_roles _ δ. + { eapply elem_of_dom_2 in Hlk. set_solver. } + right. split; last done. intros Habs. apply ls_fuel_dom_data_inv in Habs as (ζa&fsa&Hlka&Hina). + rewrite Hd /data'' /= in Hlka. + destruct (decide (ζa = ζ)). + { simplify_eq. rewrite lookup_insert in Hlka. simplify_eq. set_solver. } + rewrite lookup_insert_ne // /data' in Hlka. + destruct oζ' as [ζn|]. + ** destruct (decide (ζa = ζn)). + { simplify_eq. rewrite lookup_insert in Hlka. simplify_eq. set_solver. } + rewrite lookup_insert_ne // in Hlka. + have [??] : ζ = ζa ∧ fs = fsa; last done. + eapply ls_map_agree; eauto; apply elem_of_dom; naive_solver. + ** have [??] : ζ = ζa ∧ fs = fsa; last done. + eapply ls_map_agree; eauto; apply elem_of_dom; naive_solver. + + left. have ->: ls_fuel δ' !! ρ' = Some f; last naive_solver. + eapply (ls_fuel_data _ _ ζ'); eauto. + rewrite Hd /data'' /= lookup_insert_ne // /data'. destruct oζ' as [ζn|]; last done. + rewrite lookup_insert_ne //. intros ->. apply (Hnlocale ζ'); eauto. + by eapply elem_of_dom_2. + - intros ρ Hin. apply ls_fuel_dom_data_inv in Hin as (ζ0&fs0&Hlk0&Hin0). + rewrite Hd /data'' /= in Hlk0. destruct (decide (ζ0 = ζ)) as [->|]. + + rewrite lookup_insert in Hlk0. simplify_eq. eapply ls_fuel_dom_data; eauto. + + rewrite lookup_insert_ne // /data' in Hlk0. + destruct oζ' as [ζn|]. + * destruct (decide (ζ0 = ζn)) as [->|]. + ** rewrite lookup_insert in Hlk0. simplify_eq. eapply ls_fuel_dom_data; eauto. + ** rewrite lookup_insert_ne // /data' in Hlk0. eapply ls_fuel_dom_data; eauto. + * eapply ls_fuel_dom_data; eauto. + Qed. + + Lemma model_step_suff_data fl (δ: LiveState) ρ0 m' (fs fs': gmap _ nat) ζ : + fmtrans _ δ (Some ρ0) m' → + δ.(ls_map) !! ζ = Some fs → + ρ0 ∈ dom fs → + (∀ ρ f f', fs' !! ρ = Some f' → ρ ≠ ρ0 → fs !! ρ = Some f → f' < f) → + (∀ f'0, fs' !! ρ0 = Some f'0 → f'0 ≤ fl m') → + (∀ ρ, ρ ∈ dom fs' ∖ dom fs → ∀ f', fs' !! ρ = Some f' → f' ≤ fl m') → + (M.(live_roles) m' ∖ M.(live_roles) δ = dom fs' ∖ dom fs) → + (∀ ρ, ρ ∈ M.(live_roles) m' ∖ M.(live_roles) δ → ∀ ζ' fs', δ.(ls_map) !! ζ' = Some fs' → ρ ∉ dom fs') → + (dom fs ∖ dom fs' ∩ M.(live_roles) δ = ∅) → + let data' := <[ζ := fs']> δ.(ls_map) in + ∃ δ', δ'.(ls_data) = {| ls_under := m'; ls_map := data' |} ∧ + ls_trans fl δ (Take_step ρ0 ζ) δ'. + Proof. + intros Htrans Hζ Hρ0in Hfs' Hfl0 Hfln Hborn Hnew Hdead data'. + assert (∃ δ', δ'.(ls_data) = {| ls_under := m'; ls_map := data' |}) as [δ' Hd]. + { unshelve refine (ex_intro _ {| ls_data := {| ls_under := m'; ls_map := data' |} |} _); last done. + { rewrite /data' /=. intros z1 z2 fs1 fs2 Hneq Hlk1 Hlk2. apply map_disjoint_dom_2. + intros ρ Hin1 Hin2. + destruct (decide (z1 = ζ)) as [->|Hneq1]; destruct (decide (z2 = ζ)) as [->|Hneq2] =>//. + - rewrite lookup_insert in Hlk1. rewrite lookup_insert_ne // in Hlk2. simplify_eq. + destruct (decide (ρ ∈ dom fs)). + + have Hdone: fs ##ₘ fs2 by eapply (ls_map_disj δ ζ z2). + apply map_disjoint_dom in Hdone. set_solver. + + have Hdone: ρ ∉ dom fs2; last done. eapply Hnew. set_solver. done. + - rewrite lookup_insert in Hlk2. rewrite lookup_insert_ne // in Hlk1. simplify_eq. + destruct (decide (ρ ∈ dom fs)). + + have Hdone: fs ##ₘ fs1 by eapply (ls_map_disj δ ζ z1). + apply map_disjoint_dom in Hdone. set_solver. + + have Hdone: ρ ∉ dom fs1; last done. eapply Hnew. set_solver. done. + - rewrite lookup_insert_ne // in Hlk1. rewrite lookup_insert_ne // in Hlk2. + have Hdone: fs1 ##ₘ fs2 by eapply (ls_map_disj δ z1 z2). + apply map_disjoint_dom in Hdone. set_solver. } + { simpl. intros ρ Hlive. destruct (decide (ρ ∈ live_roles _ δ)) as [Hwaslive|Hnewborn]. + - destruct (ls_map_live δ ρ Hwaslive) as (ζ'&fs''&Hlk&Hdom). destruct (decide (ζ = ζ')). + + simplify_eq. exists ζ', fs'. rewrite lookup_insert. split; first done. set_solver. + + exists ζ', fs''. rewrite lookup_insert_ne //. + - exists ζ, fs'. rewrite lookup_insert. split; first done. set_solver. } } + have H0live: ρ0 ∈ live_roles _ δ by eapply fm_live_spec. + have Hζ' : ls_map δ' !! ζ = Some fs' by rewrite Hd lookup_insert //. + exists δ'. split; first done. constructor; first by rewrite Hd //. + + have Hdom: dom (ls_fuel δ') ∖ dom (ls_fuel δ) ⊆ live_roles M δ' ∖ live_roles M δ. + { intros ρ [Hin Hnin]%elem_of_difference. rewrite Hd Hborn. + apply elem_of_dom in Hin as [f' Hin]. + apply ls_fuel_data_inv in Hin as (ζ1&fs1&Hlk1&Hlk'1). + destruct (decide (ζ1 = ζ)); first simplify_eq; last first. + { rewrite Hd lookup_insert_ne // in Hlk1. exfalso. apply Hnin. + eapply ls_fuel_dom_data=>//. by apply elem_of_dom_2 in Hlk'1. } + apply elem_of_difference. split; first by apply elem_of_dom_2 in Hlk'1. + intros Hina. apply Hnin. eapply ls_fuel_dom_data=>//. } + + split; [| split; [| split; [| split; [| split; [| done]]]]]. + - eapply ls_mapping_data =>//. + - intros ρ Hin Hin' Hmd. + apply elem_of_dom in Hin as [f Hf]. + apply elem_of_dom in Hin' as [f' Hf']. + rewrite Hf Hf' /=. inversion Hmd; simplify_eq. + + symmetry in Hsametid. apply ls_mapping_data_inv in Hsametid as (fs1&Hlk1&Hin1). + rewrite Hζ in Hlk1. symmetry in Hlk1. simplify_eq. + apply ls_fuel_data_inv in Hf as (ζ1&fs1&Hlk1&Hlk'1). + have [??] : ζ1 = ζ ∧ fs1 = fs; last simplify_eq. + { eapply (ls_map_agree (ρ := ρ) Hlk1); eauto. by apply elem_of_dom_2 in Hlk'1. } + + apply ls_fuel_data_inv in Hf' as (ζ2&fs2&Hlk2&Hlk'2). + destruct (decide (ζ2 = ζ)); last first. + { rewrite Hd lookup_insert_ne // in Hlk2. + have [??] : ζ2 = ζ ∧ fs2 = fs; last simplify_eq. + eapply (ls_map_agree (ρ := ρ) Hlk2); eauto. by apply elem_of_dom_2 in Hlk'2. } + simplify_eq. eapply Hfs'=>//. naive_solver. + + exfalso. destruct Hissome as [ζ1 Hmap]. have Hmap' := Hmap. + apply ls_mapping_data_inv in Hmap as (fs1&Hlk&YHin). + destruct (decide (ζ1 = ζ)) as [->|]. + * simplify_eq. have ?: ρ ∈ dom fs. + { apply ls_fuel_data_inv in Hf as (ζ1&fs1&Hlk1&Hlk'1). + destruct (decide (ρ ∈ dom fs)); first done. exfalso. + eapply Hnew; eauto; last by apply elem_of_dom_2 in Hlk'1. + rewrite Hborn. set_solver. } + apply Hneqtid. rewrite Hmap'. by eapply ls_mapping_data. + * apply Hneqtid. rewrite Hmap'. + eapply ls_mapping_data=>//. + rewrite Hd lookup_insert_ne // in Hlk. + - intros ρ Hin Hneq. apply ls_fuel_dom_data_inv in Hin as (ζ1&fs1&Hlk1&Hdom1). + destruct (decide (ζ1 = ζ)). + + simplify_eq. destruct (decide (ρ ∈ dom fs')) as [Hin|]; [left| right; split; [|set_solver]]. + * apply elem_of_dom in Hin as [f' Hf']. + have ->: ls_fuel δ' !! ρ = Some f' by eapply ls_fuel_data. + apply elem_of_dom in Hdom1 as [f Hf]. + have -> /=: ls_fuel δ !! ρ = Some f by eapply ls_fuel_data. + naive_solver lia. + * intros Ha. apply ls_fuel_dom_data_inv in Ha as (ζ1&fs1&Hlk1&Hin1). + destruct (decide (ζ1 = ζ)) as [|Hneq1]; first naive_solver. + rewrite Hd lookup_insert_ne // in Hlk1. apply Hneq1. + by eapply ls_map_agree. + + left. apply elem_of_dom in Hdom1 as (f'&Hf'). + have ->: ls_fuel δ' !! ρ = Some f'. + { eapply (ls_fuel_data _ _ ζ1); eauto. rewrite Hd lookup_insert_ne //. } + have ->: ls_fuel δ !! ρ = Some f'. + { eapply (ls_fuel_data _ _ ζ1); eauto. } + naive_solver. + - intros. have H0dom: ρ0 ∈ dom fs' by set_solver. apply elem_of_dom in H0dom as [f' Hf']. + rewrite (ls_fuel_data _ _ _ _ _ Hζ' Hf') Hd /=. by eapply Hfl0. + - intros ρ [Hρin Hρnin]%elem_of_difference. + have Hn: ρ ∈ dom fs' ∖ dom fs. + { rewrite -Hborn. rewrite elem_of_subseteq {2}Hd /= in Hdom. apply Hdom. set_solver. } + apply elem_of_dom in Hρin as [f' Hρin]. rewrite Hρin. + apply ls_fuel_data_inv in Hρin as (ζ1&fs1&Hlk1&Hlk'1). simpl. rewrite Hd /=. + apply elem_of_difference in Hn as [Hn1 Hn2]. + have [??] : ζ1 = ζ ∧ fs1 = fs'. + { eapply ls_map_agree=>//. by apply elem_of_dom_2 in Hlk'1. } + simplify_eq. eapply Hfln; last done. by apply elem_of_difference. + Qed. + + Record LiveModel := { + lm_fl : M → nat; + lm_ls := LiveState; + lm_lbl := FairLabel M.(fmrole); + lm_ls_trans (δ: LiveState) (ℓ: FairLabel (fmrole M)) := 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) := + ∀ ζ, ζ ∈ dom $ ls_map δ -> is_Some (from_locale c ζ). + + Program Definition initial_ls `{LM: LiveModel} (s0: M) (ζ0: locale Λ) + : LM.(lm_ls) := + {| ls_data := {| ls_under := s0; + ls_map := {[ζ0 := gset_to_gmap (LM.(lm_fl) s0) (M.(live_roles) s0)]}; + |} |}. + Next Obligation. + intros ???????? Hlk1 Hlk2. simpl in *. exfalso. + apply lookup_singleton_Some in Hlk1. + apply lookup_singleton_Some in Hlk2. + naive_solver. + Qed. + Next Obligation. + intros ?? ζ ??. eexists ζ, _. rewrite lookup_singleton. split; eauto. + 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 _ _ {_ _}. +Arguments LiveStateData _ _ {_ _}. +Arguments LiveModel _ _ {_ _}. +Arguments fair_model_model _ {_ _ _} _. + +Definition live_model_to_model Λ M `{Countable (locale Λ)} : LiveModel Λ M -> Model := + λ lm, fair_model_model Λ lm. +Coercion live_model_to_model : LiveModel >-> Model. +Arguments live_model_to_model {_ _ _ _}. + +Definition auxtrace {Λ M} `{Countable (locale Λ)} (LM: LiveModel Λ M) := trace LM.(lm_ls) LM.(lm_lbl). + +Section aux_trace. + Context `{Countable (locale Λ)} `{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 (δ: LiveState Λ M) ℓ (tr: auxtrace LM): + 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 _ H1) (* 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 `{Countable (locale Λ)} `{LM:LiveModel Λ M} + (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 ζ → ρ ∉ M.(live_roles) δ. + +Definition exaux_traces_match `{Countable (locale Λ)} `{LM:LiveModel Λ M} : + extrace Λ → auxtrace LM → Prop := + traces_match labels_match + live_tids + locale_step + LM.(lm_ls_trans). + +Section fairness_preserved. + Context `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + Implicit Type δ : LiveState Λ M. + + 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) ζ ρ: + ρ ∈ M.(live_roles) (trfirst auxtr) → + exaux_traces_match extr auxtr -> + ls_mapping (trfirst auxtr) !! ρ = Some ζ -> + locale_enabled ζ (trfirst extr). + Proof. + intros Hlive 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 ρ Hloc). + 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 pred_at_step_helper extr' p ζ': + pred_at extr' p (fairness_sat locale_enabled tid_match ζ') <-> + pred_at extr' p (λ x y, ¬ locale_enabled ζ' x ∨ y = Some (Some ζ')). + Proof using. + apply pred_at_iff. intros ??. + rewrite /fairness_sat. apply Morphisms_Prop.or_iff_morphism; [done| ]. + rewrite /tid_match. split. + - by intros (?&->&[=->]). + - intros ->. eauto. + Qed. + + 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. + rewrite pred_at_or. eapply pred_at_step_helper; 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. eapply fair_by_cons. apply Hfair. } + 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. + - done. + - 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. } + rewrite pred_at_or. eapply pred_at_step_helper; eauto. + 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(ls_mapping (trfirst tr) !! ρ) by eauto. + have [f Hfuel] : is_Some(ls_fuel (trfirst tr) !! ρ) 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 ρ Hζ). 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 ?. eapply fair_by_after; eauto. + { apply Hex. } + rewrite pred_at_or. eapply pred_at_step_helper; eauto. + 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 (LM := LM) σ δ ∧ ψ σ δ) + 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 `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ Mdl}. + Implicit Type δ : LiveState Λ Mdl. + + 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 (λ x, ls_under (ls_data x)) 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 $ ls_data (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 `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + + (* Why is [LM] needed here? *) + Definition upto_stutter_auxtr := + upto_stutter (λ x, ls_under (Λ:=Λ) (M:=M) (ls_data x)) (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 `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + + Lemma upto_stutter_mono' : + monotone2 (upto_stutter_ind (λ x, ls_under (Λ:=Λ) (M:=M) (ls_data x)) (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 `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + + Notation upto_stutter_aux := (upto_stutter (λ x, ls_under (Λ := Λ) (ls_data x)) (Ul (Λ := Λ) (LM := LM))). + + Lemma upto_stutter_mono'' : (* TODO fix this proliferation *) + monotone2 (upto_stutter_ind (λ x, ls_under (Λ:=Λ) (M:=M) (ls_data x)) (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 //. + rewrite pred_at_or in Hres. + eapply pred_at_impl; [| by apply Hres]. + simpl. rewrite /fairness_sat. intros ?? [? | ->]; eauto. + right. eexists. split; done. + 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/fairis/fuel_termination.v b/fairis/fuel_termination.v new file mode 100644 index 0000000..47ceab0 --- /dev/null +++ b/fairis/fuel_termination.v @@ -0,0 +1,61 @@ +From stdpp Require Import option. +From Paco Require Import pacotac. +From fairness Require Export fairness. +From fairis Require Import fair_termination fuel. + +Definition auxtrace_fairly_terminating {Λ} `{Countable (locale Λ)} {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} `{Countable (locale Λ)} (LM:LiveModel Λ FM) + (ξ : 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/fairis/map_included_utils.v b/fairis/map_included_utils.v new file mode 100644 index 0000000..30ac408 --- /dev/null +++ b/fairis/map_included_utils.v @@ -0,0 +1,484 @@ +From Coq Require Import ssreflect. +From stdpp Require Import gmap. + +(* TODO: Make context, and generalise lemmas to canonical representation *) +Lemma map_included_spec `{∀ A, Lookup K A (MAP A)} {A} + (R : relation A) (m1 m2 : MAP A) : + map_included (fun _ => R) m1 m2 ↔ + (∀ k v1, m1 !! k = Some v1 → ∃ v2, m2 !! k = Some v2 ∧ R v1 v2). +Proof. + split. + - rewrite /map_included /map_relation /option_relation. + intros HR. + intros k v1 Hv1. + specialize (HR k). rewrite Hv1 in HR. + destruct (m2 !! k) eqn:Heqn; [|done]. + exists a. done. + - intros HR. + rewrite /map_included /map_relation /option_relation. + intros k. + destruct (m1 !! k) eqn:Heqn. + + apply HR in Heqn as [v2 [Hv2 HR']]. + rewrite Hv2. done. + + by destruct (m2 !! k). +Qed. + +Lemma map_included_insert `{Countable K} {A} + (R : relation A) (m1 m2 : gmap K A) i x y : + R x y → + map_included (fun _ => R) m1 m2 → + map_included (fun _ => R) (<[i:=x]>m1) (<[i:=y]>m2). +Proof. + intros HR Hle. + rewrite /map_included /map_relation /option_relation. + intros k. + destruct (decide (i=k)) as [<-|Hneq]. + - rewrite !lookup_insert. done. + - rewrite lookup_insert_ne; [done|]. + rewrite lookup_insert_ne; [done|]. + apply Hle. +Qed. + + +Lemma map_included_refl `{∀ A, Lookup K A (MAP A)} {A} + `{!Reflexive R} (m : MAP A) : + map_included (fun _ => R) m m. +Proof. rewrite map_included_spec. intros. by eauto. Qed. + +(* TODO: Move *) +(* TODO: Generalise to map_included instead of subseteq? *) +Lemma map_included_subseteq `{∀ A, Lookup K A (MAP A)} {A} + (R : relation A) (m1 m2 m3 : MAP A) : + m1 ⊆ m2 → map_included (fun _ => R) m2 m3 → map_included (fun _ => R) m1 m3. +Proof. + rewrite /subseteq /map_subseteq !map_included_spec. + intros Hle1 Hle2. + intros k v1 HSome. + apply Hle1 in HSome as [v2 [HSome HR]]. + apply Hle2 in HSome as [v3 [HSome HR']]. + exists v3. split; [done|]. + by subst. +Qed. + +(* TODO: Generalise to better typeclasses *) +Lemma map_included_subseteq_inv `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) : + map_included (fun _ => R) m1 m2 → (dom m1) ⊆ (dom m2). +Proof. + rewrite /map_included /map_relation /option_relation. + intros Hle k. rewrite !elem_of_dom. specialize (Hle k). + intros [? Heq]. rewrite Heq in Hle. + by destruct (m2 !! k). +Qed. + +Lemma map_included_transitivity `{∀ A, Lookup K A (MAP A)} {A} + `{!Transitive R} (m1 m2 m3 : MAP A) : + map_included (fun _ => R) m1 m2 → map_included (fun _ => R) m2 m3 → map_included (fun _ => R) m1 m3. +Proof. + rewrite !map_included_spec. + intros Hle1 Hle2. + intros k v1 HSome. + apply Hle1 in HSome as [v2 [HSome HR]]. + apply Hle2 in HSome as [v3 [HSome HR']]. + exists v3. split; [done|]. + by etransitivity. +Qed. + +(* TODO: Generalize types *) +Lemma map_included_fmap `{Countable K} {A} + (R : relation A) (m : gmap K A) (f : A → A) : + (∀ x:A, R x (f x)) → map_included (fun _ => R) m (f <$> m). +Proof. + intros Hf. intros k. rewrite lookup_fmap. + destruct (m !! k); [by apply Hf|done]. +Qed. + +Lemma map_included_mono `{Countable K} {A} + (R : relation A) (m1 m2 : gmap K A) (f : A → A) : + (∀ x1 x2 : A, R x1 x2 → R (f x1) (f x2)) → + map_included (fun _ => R) m1 m2 → + map_included (fun _ => R) (f <$> m1) (f <$> m2). +Proof. + rewrite !map_included_spec. + intros Hf Hle. intros k v1. + intros HSome. + apply lookup_fmap_Some in HSome as (v1'&HSome&Hv1'). + apply Hle in Hv1' as (v2'&HSome2&Hv2). + exists (f v2'). simplify_eq. + rewrite lookup_fmap. rewrite HSome2. + split; [done|]. by apply Hf. +Qed. + +Lemma map_included_mono_strong `{Countable K} {A} + (R : relation A) (m1 m2 : gmap K A) (f1 f2 : gmap K A → gmap K A) : + dom (f1 m1) ⊆ dom m1 → dom m2 ⊆ dom (f2 m2) → + (∀ k x1 x2 y1 y2, + m1 !! k = Some x1 → m2 !! k = Some x2 → + (f1 m1) !! k = Some y1 → (f2 m2) !! k = Some y2 → + R x1 x2 → R y1 y2) → + map_included (fun _ => R) m1 m2 → + map_included (fun _ => R) (f1 m1) (f2 m2). +Proof. + rewrite !map_included_spec. + intros Hle1 Hle2 Hf HR. intros k v1. + intros HSome1. + assert (∃ v1', m1 !! k = Some v1') as [v1' HSome1']. + { apply elem_of_dom_2 in HSome1. apply Hle1 in HSome1. + apply elem_of_dom in HSome1 as [? ->]. by eauto. } + pose proof HSome1' as HSome1''. + apply HR in HSome1'' as (v2'&HSome2'&Hv2'). + assert (∃ v2, f2 m2 !! k = Some v2) as [v2 HSome2]. + { apply elem_of_dom_2 in HSome2'. apply Hle2 in HSome2'. + apply elem_of_dom in HSome2' as [? ->]. by eauto. } + exists v2. split; [done|]. + by eapply Hf. +Qed. + +Lemma map_included_filter `{Countable K} {A} + (R : relation A) (m1 m2 : gmap K A) (P : (K * A) → Prop) + `{∀ x, Decision (P x)} : + (∀ k x1 x2, + m1 !! k = Some x1 → m2 !! k = Some x2 → P (k,x1) → P (k,x2)) → + map_included (fun _ => R) m1 m2 → + map_included (fun _ => R) (filter P m1) (filter P m2). +Proof. + rewrite !map_included_spec. + intros HP Hle k v1 HSome1. + pose proof HSome1 as HP'. + apply map_lookup_filter_Some_1_1 in HSome1. + apply map_lookup_filter_Some_1_2 in HP'. + pose proof HSome1 as HSome2. + apply Hle in HSome2 as [v2 [HSome2 HR]]. + specialize (HP k v1 v2 HSome1 HSome2 HP'). + exists v2. split; [|done]. + by apply map_lookup_filter_Some_2. +Qed. + +Lemma map_included_subseteq_r `{∀ A, Lookup K A (MAP A)} {A} + (R : relation A) (m1 m2 m3 : MAP A) : + m2 ⊆ m3 → map_included (fun _ => R) m1 m2 → map_included (fun _ => R) m1 m3. +Proof. + rewrite /subseteq /map_subseteq !map_included_spec. + intros Hle1 Hle2. + intros k v1 HSome. + apply Hle2 in HSome as [v2 [HSome HR]]. + apply Hle1 in HSome as [v3 [HSome HR']]. + exists v3. split; [done|]. + by subst. +Qed. + +Definition map_agree_R `{∀ A, Lookup K A (MAP A)} {A B} + (R : A → B → Prop) (m1 : MAP A) (m2 : MAP B) := + map_relation (fun _ => R) (λ _ _ , False) (λ _ _, False) m1 m2. + +Lemma map_agree_R_spec `{∀ A, Lookup K A (MAP A)} {A} + (R : relation A) (m1 m2 : MAP A) : + map_agree_R R m1 m2 ↔ + (∀ k v1, m1 !! k = Some v1 → ∃ v2, m2 !! k = Some v2 ∧ R v1 v2) ∧ + (∀ k v2, m2 !! k = Some v2 → ∃ v1, m1 !! k = Some v1 ∧ R v1 v2). +Proof. + rewrite /map_agree_R /map_relation /option_relation. split. + - intros HR. split. + + intros k v HSome. specialize (HR k). rewrite HSome in HR. + destruct (m2 !! k); [by eauto|done]. + + intros k v HSome. specialize (HR k). rewrite HSome in HR. + destruct (m1 !! k); [by eauto|done]. + - intros [HR1 HR2] k. + destruct (m1 !! k) as [v1|] eqn:Heqn1. + { by apply HR1 in Heqn1 as [? [-> ?]]. } + destruct (m2 !! k) as [v2|] eqn:Heqn2. + { apply HR2 in Heqn2 as [? [? ?]]. by simplify_eq. } + done. +Qed. + +Lemma map_included_delete `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) k : + map_included (fun _ => R) m1 m2 → + map_included (fun _ => R) (delete k m1) (delete k m2). +Proof. + rewrite !map_included_spec. + intros Hle k' v HSome. + apply lookup_delete_Some in HSome as [HK HSome]. + apply Hle in HSome as (?&?&?). + exists x. by rewrite lookup_delete_ne. +Qed. + +Lemma map_agree_R_dom `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) : + map_agree_R R m1 m2 → dom m1 = dom m2. +Proof. + rewrite map_agree_R_spec. intros [Hle1 Hle2]. apply set_eq. + intros k. split. + - intros [v1 HSome1]%elem_of_dom. + apply Hle1 in HSome1 as (?&?&?). + by apply elem_of_dom. + - intros [v2 HSome2]%elem_of_dom. + apply Hle2 in HSome2 as (?&?&?). + by apply elem_of_dom. +Qed. + +Lemma map_agree_R_insert `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) k v1 v2 : + R v1 v2 → + map_agree_R R m1 m2 → + map_agree_R R (<[k:=v1]>m1) (<[k:=v2]>m2). +Proof. + rewrite !map_agree_R_spec. + intros HR [Hle1 Hle2]. + split. + - intros k' v1' HSome1. + destruct (decide (k = k')) as [->|Hneq]. + + rewrite lookup_insert in HSome1. simplify_eq. + exists v2. rewrite lookup_insert. done. + + rewrite lookup_insert_ne in HSome1; [done|]. + apply Hle1 in HSome1 as (v2'&HSome2&HR2). + exists v2'. rewrite lookup_insert_ne; [|done]. done. + - intros k' v2' HSome2. + destruct (decide (k = k')) as [->|Hneq]. + + rewrite lookup_insert in HSome2. simplify_eq. + exists v1. rewrite lookup_insert. done. + + rewrite lookup_insert_ne in HSome2; [done|]. + apply Hle2 in HSome2 as (v1'&HSome1&HR1). + exists v1'. rewrite lookup_insert_ne; [|done]. done. +Qed. + +Lemma map_agree_R_insert_inv `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) k v1 v2 : + k ∉ dom m1 → k ∉ dom m2 → + map_agree_R R (<[k:=v1]>m1) (<[k:=v2]>m2) → + map_agree_R R m1 m2. +Proof. + intros Hnin1 Hnin2. + rewrite !map_agree_R_spec. + intros [Hle1 Hle2]. + split. + - intros k' v1' HSome1. + destruct (decide (k = k')) as [->|Hneq]. + { apply not_elem_of_dom in Hnin1. set_solver. } + assert (<[k:=v1]>m1 !! k' = Some v1') as HSome1'. + { by rewrite lookup_insert_ne. } + apply Hle1 in HSome1' as (v2'&HSome2&HR). + rewrite lookup_insert_ne in HSome2; [done|]. + by eauto. + - intros k' v2' HSome2. + destruct (decide (k = k')) as [->|Hneq]. + { apply not_elem_of_dom in Hnin2. set_solver. } + assert (<[k:=v2]>m2 !! k' = Some v2') as HSome2'. + { by rewrite lookup_insert_ne. } + apply Hle2 in HSome2' as (v1'&HSome1&HR). + rewrite lookup_insert_ne in HSome1; [done|]. + by eauto. +Qed. + +Lemma map_agree_R_agree `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) k v1 v2 : + m1 !! k = Some v1 → m2 !! k = Some v2 → + map_agree_R R m1 m2 → + R v1 v2. +Proof. + rewrite map_agree_R_spec. + intros HSome1 HSome2 Hle. + apply Hle in HSome1 as (v2'&HSome2'&HR). + rewrite HSome2' in HSome2. by simplify_eq. +Qed. + +Lemma map_included_R_agree `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) k v1 v2 : + m1 !! k = Some v1 → m2 !! k = Some v2 → + map_included (fun _ => R) m1 m2 → + R v1 v2. +Proof. + rewrite map_included_spec. + intros HSome1 HSome2 Hle. + apply Hle in HSome1 as (v2'&HSome2'&HR). + rewrite HSome2' in HSome2. by simplify_eq. +Qed. + +Lemma map_included_map_agree_R `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) : + map_included (fun _ => R) m1 m2 → + ∃ m21 m22, + m2 = m21 ∪ m22 ∧ + m21 ##ₘ m22 ∧ + map_agree_R R m1 m21. +Proof. + revert m1. + induction m2 as [|k v2 m2 Hnin IHm2] using map_ind; intros m1 Hle. + { by exists ∅, ∅. } + destruct (decide (k ∈ dom m1)) as [Hin|Hnin']; last first. + { apply (map_included_delete _ _ _ k) in Hle. + rewrite delete_insert in Hle; [done|]. + apply IHm2 in Hle as (m21&m22&->&Hdisj&HR). + exists m21, (<[k:=v2]>m22). + assert (dom m1 = dom m21) as Hdom. + { eapply map_agree_R_dom. apply not_elem_of_dom in Hnin'. + by rewrite delete_notin in HR. } + apply map_disjoint_dom in Hdisj. + rewrite insert_union_r; [by apply not_elem_of_dom; set_solver|]. + split; [done|]. + apply not_elem_of_dom in Hnin'. + rewrite delete_notin in HR; [done|]. + split; [|done]. + apply map_disjoint_dom. + apply not_elem_of_dom in Hnin'. + set_solver. } + apply elem_of_dom in Hin as [v1 HSome]. + assert (R v1 v2). + { eapply map_included_R_agree; [| |done]. + - done. + - by rewrite lookup_insert. } + apply (map_included_delete _ _ _ k) in Hle. + rewrite delete_insert in Hle; [done|]. + apply IHm2 in Hle as (m21&m22&->&Hdisj&HR). + exists (<[k:=v2]>m21), m22. + assert (dom (delete k m1) = dom m21) as Hdom. + { eapply map_agree_R_dom. done. } + apply map_disjoint_dom in Hdisj. + rewrite insert_union_l. + split; [done|]. + apply (map_agree_R_insert _ _ _ k v1 v2) in HR; [|done]. + rewrite insert_delete in HR; [done|]. + split; [|done]. + apply map_disjoint_dom. + rewrite dom_insert_L. + apply not_elem_of_dom in Hnin. + set_solver. +Qed. + +Lemma map_agree_R_map_included `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) : + map_agree_R R m1 m2 → map_included (fun _ => R) m1 m2. +Proof. + rewrite map_included_spec map_agree_R_spec. + by intros [Hle _]. +Qed. + +Lemma map_agree_R_union_inv `{Countable K} {V} + (R : relation V) (m11 m12 m2 : gmap K V) : + m11 ##ₘ m12 → + map_agree_R R (m11 ∪ m12) m2 → + ∃ m21 m22, m2 = m21 ∪ m22 ∧ map_agree_R R m11 m21 ∧ + map_agree_R R m12 m22. +Proof. + intros Hdisj%map_disjoint_dom Hle. + pose proof Hle as Hdom%map_agree_R_dom. + rewrite comm in Hdom. + rewrite dom_union_L in Hdom. + apply dom_union_inv_L in Hdom as (m21&m22&->&Hdosj&Hdom1&Hdom2); + [|done]. + exists m21, m22. + split; [done|]. + split. + - apply map_agree_R_spec. + split. + + intros k v1 HSome1. + apply map_agree_R_spec in Hle as [Hle1 Hle2]. + assert ((m11 ∪ m12) !! k = Some v1) as HSome1'. + { rewrite lookup_union_l; [|done]. + apply not_elem_of_dom. + apply elem_of_dom_2 in HSome1. set_solver. } + apply Hle1 in HSome1' as (v2&HSome2'&HR). + assert (m21 !! k = Some v2) as HSome2. + { rewrite lookup_union_l in HSome2'; [|done]. + apply not_elem_of_dom. apply elem_of_dom_2 in HSome1. + set_solver. } + eauto. + + intros k v2 HSome2. + apply map_agree_R_spec in Hle as [Hle1 Hle2]. + assert ((m21 ∪ m22) !! k = Some v2) as HSome2'. + { rewrite lookup_union_l; [|done]. + apply not_elem_of_dom. + apply elem_of_dom_2 in HSome2. set_solver. } + apply Hle2 in HSome2' as (v1&HSome1'&HR). + assert (m11 !! k = Some v1) as HSome1. + { rewrite lookup_union_l in HSome1'; [|done]. + apply not_elem_of_dom. apply elem_of_dom_2 in HSome2. + set_solver. } + eauto. + - apply map_agree_R_spec. + split. + + intros k v1 HSome1. + apply map_agree_R_spec in Hle as [Hle1 Hle2]. + assert ((m11 ∪ m12) !! k = Some v1) as HSome1'. + { rewrite lookup_union_r; [|done]. + apply not_elem_of_dom. + apply elem_of_dom_2 in HSome1. set_solver. } + apply Hle1 in HSome1' as (v2&HSome2'&HR). + assert (m22 !! k = Some v2) as HSome2. + { rewrite lookup_union_r in HSome2'; [|done]. + apply not_elem_of_dom. apply elem_of_dom_2 in HSome1. + set_solver. } + eauto. + + intros k v2 HSome2. + apply map_agree_R_spec in Hle as [Hle1 Hle2]. + assert ((m21 ∪ m22) !! k = Some v2) as HSome2'. + { rewrite lookup_union_r; [|done]. + apply not_elem_of_dom. + apply elem_of_dom_2 in HSome2. set_solver. } + apply Hle2 in HSome2' as (v1&HSome1'&HR). + assert (m12 !! k = Some v1) as HSome1. + { rewrite lookup_union_r in HSome1'; [|done]. + apply not_elem_of_dom. apply elem_of_dom_2 in HSome2. + set_solver. } + eauto. +Qed. + +(* OBS: Need restrictions on f *) +Lemma map_agree_R_fmap_inv `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) f : + (* OBS: Is this a general relation/function property? *) + (∀ v1 v2, R (f v1) v2 → ∃ v2', v2 = f v2') → + map_agree_R R (f <$> m1) m2 → + ∃ m2', m2 = f <$> m2'. +Proof. + revert m1. + induction m2 as [|k v2 m2 Hnin IHm2] using map_ind; intros m1 Hf Hle. + { exists ∅. rewrite fmap_empty. done. } + pose proof Hle as Hle'. + apply map_agree_R_spec in Hle. + assert (<[k:=v2]> m2 !! k = Some v2) as HSome2 + by by rewrite lookup_insert. + apply Hle in HSome2 as (v1&HSome1&HR). + apply lookup_fmap_Some in HSome1 as (v1'&<-&HSome1'). + assert (∃ v2', v2 = f v2') as [v2' Heq]. + { by eapply Hf. } + rewrite Heq in HR. + assert (map_agree_R R (f <$> (delete k m1)) m2) as Hle''. + { rewrite -(insert_id m1 k v1') in Hle'; [done|]. + rewrite -insert_delete_insert in Hle'. + rewrite fmap_insert in Hle'. + eapply map_agree_R_insert_inv; [| |apply Hle']. + - set_solver. + - apply not_elem_of_dom. set_solver. + } + apply IHm2 in Hle'' as [m2' Heq']; [|done]. + exists (<[k:=v2']>m2'). + rewrite fmap_insert. rewrite Heq. f_equiv. done. +Qed. + +(* OBS: Need restrictions on f *) +Lemma map_agree_R_fmap `{Countable K} {V} + (R : relation V) (m1 m2 : gmap K V) f : + (∀ v1 v2, R (f v1) (f v2) → R v1 v2) → + map_agree_R R (f <$> m1) (f <$> m2) → + map_agree_R R m1 m2. +Proof. + intros Hf. + rewrite !map_agree_R_spec. + intros [Hle1 Hle2]. + split. + - intros k v1 HSome1. + assert ((f <$> m1) !! k = Some (f v1)) as HSome1'. + { rewrite lookup_fmap. destruct (m1 !! k); [by simplify_eq|done]. } + apply Hle1 in HSome1' as (v2'&HSome2'&HR). + apply lookup_fmap_Some in HSome2' as (v2&<-&HSome2). + apply Hf in HR. + by eauto. + - intros k v2 HSome2. + assert ((f <$> m2) !! k = Some (f v2)) as HSome2'. + { rewrite lookup_fmap. destruct (m2 !! k); [by simplify_eq|done]. } + apply Hle2 in HSome2' as (v1'&HSome1'&HR). + apply lookup_fmap_Some in HSome1' as (v1&<-&HSome1). + apply Hf in HR. + by eauto. +Qed. diff --git a/fairis/resources.v b/fairis/resources.v new file mode 100644 index 0000000..8f71a2b --- /dev/null +++ b/fairis/resources.v @@ -0,0 +1,2095 @@ +From iris.algebra Require Import auth gmap gset excl. +From iris.proofmode Require Import tactics. +From fairness Require Import fairness. +From fairis Require Import fuel map_included_utils. + +Canonical Structure ModelO (Mdl : FairModel) := leibnizO Mdl. +Canonical Structure RoleO (Mdl : FairModel) := leibnizO (Mdl.(fmrole)). +Canonical Structure localeO (Λ : language) := leibnizO (locale Λ). + +Class fairnessGpreS `{Countable (locale Λ)} `(LM: LiveModel Λ M) Σ := { + fairnessGpreS_model :: inG Σ (authUR (optionUR (exclR (ModelO M)))); + fairnessGpreS_model_fuel_mapping :: + inG Σ (authUR (gmapUR (localeO Λ) + (exclR $ gmapUR (RoleO M) natO))); + fairnessGpreS_model_free_roles :: inG Σ (authUR (gset_disjUR (RoleO M))); +}. + +Class fairnessGS `{Countable (locale Λ)} `(LM : LiveModel Λ M) Σ := FairnessGS { + fairness_inG :: fairnessGpreS LM Σ; + (** Underlying model *) + fairness_model_name : gname; + (** Mapping of threads to roles with fuel *) + fairness_model_fuel_mapping_name : gname; + (** Set of free/availble roles *) + fairness_model_free_roles_name : gname; +}. + +Global Arguments fairnessGS {_ _ _ _} LM Σ. +Global Arguments fairness_model_name {_ _ _ _ LM Σ} _. +Global Arguments fairness_model_fuel_mapping_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 $ gmapUR (RoleO M) natO))); + GFunctor (authUR (gset_disjUR (RoleO M))) +]. + +Global Instance subG_fairnessGpreS {Σ} `{Countable (locale Λ)} `{LM : LiveModel Λ M} + : + 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 `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + Context {Σ : gFunctors}. + Context {fG: fairnessGS LM Σ}. + + Notation Role := (M.(fmrole)). + + Definition auth_fuel_mapping_is + (m: gmap (locale Λ) (gmap Role nat)) : iProp Σ := + own (fairness_model_fuel_mapping_name fG) + (● (fmap Excl m : + ucmra_car (gmapUR _ (exclR $ gmapUR (RoleO M) natO) + ))). + + Definition frag_fuel_mapping_is + (m: gmap (locale Λ) (gmap Role nat)) : iProp Σ := + own (fairness_model_fuel_mapping_name fG) + (◯ (fmap Excl m: + ucmra_car (gmapUR _ (exclR $ gmapUR (RoleO M) natO) + ))). + + 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 fuel_map_le_inner (m1 m2 : gmap (locale Λ) (gmap Role nat)) := + map_included (λ _ (fs1 fs2 : gmap Role nat), + map_included (fun _ => (≤)) fs1 fs2) m1 m2. + + Definition fuel_map_le (m1 m2 : gmap (locale Λ) (gmap Role nat)) := + fuel_map_le_inner m1 m2 ∧ + (* OBS: This is a bit hacky, should instead change definition. *) + dom m1 = dom m2. + + Definition fuel_map_preserve_dead + (m : gmap (locale Λ) (gmap Role nat)) + (ρs : gset Role) := + ∀ ρ, ρ ∈ ρs → ∃ ζ fs, m !! ζ = Some fs ∧ ρ ∈ dom fs. + + Definition fuel_map_preserve_threadpool (tp: list $ expr Λ) + (fuel_map : gmap (locale Λ) (gmap Role nat)) := + ∀ ζ, ζ ∉ locales_of_list tp → fuel_map !! ζ = None. + + Definition model_state_interp (tp: list $ expr Λ) (δ: LiveState Λ M): iProp Σ := + ∃ fuel_map, + ⌜ fuel_map_le fuel_map δ.(ls_map) ⌝ ∗ + ⌜ fuel_map_preserve_dead fuel_map (M.(live_roles) δ) ⌝ ∗ + ⌜ fuel_map_preserve_threadpool tp fuel_map ⌝ ∗ + auth_model_is δ ∗ auth_fuel_mapping_is fuel_map. + + Lemma model_state_interp_tids_smaller δ tp : + model_state_interp tp δ -∗ ⌜ tids_smaller tp δ ⌝. + Proof. + iIntros "(%m&[_ %Heq]&%&%Hbig&_)". + iPureIntro. + intros ζ Hin. + assert (¬ (ζ ∉ locales_of_list tp)). + - intros contra. + specialize (Hbig _ contra). + rewrite -Heq elem_of_dom Hbig in Hin. + inversion Hin. naive_solver. + - 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. intros ->; auto. Qed. + +Section model_state_lemmas. + Context `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + Context {Σ : gFunctors}. + Context {fG: fairnessGS LM Σ}. + + Notation Role := (M.(fmrole)). + + Definition has_fuels (ζ: locale Λ) (fs: gmap Role nat) : iProp Σ := + frag_fuel_mapping_is {[ ζ := fs ]}. + + #[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. + + Definition has_fuels_S (ζ: locale Λ) (fs: gmap Role nat): iProp Σ := + has_fuels ζ (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_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. + +End model_state_lemmas. + +Notation "tid ↦M R" := (has_fuels tid R) (at level 20, format "tid ↦M R") : bi_scope. +Notation "tid ↦M++ R" := (has_fuels_S tid R) (at level 20, format "tid ↦M++ R") : bi_scope. + +Section adequacy. + Context `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + 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. + + Definition init_fuel_map (s0: M) (ζ0: locale Λ) : + gmap (locale Λ) (exclR $ gmap (fmrole M) nat) := + {[ ζ0 := Excl (gset_to_gmap (LM.(lm_fl) s0) (M.(live_roles) s0)) ]}. + + Lemma model_fuel_mapping_init (s0: M) (ζ0: locale Λ) : + ⊢ |==> ∃ γ, + own γ (● (init_fuel_map s0 ζ0)) ∗ + own γ (◯ (init_fuel_map s0 ζ0)). + Proof. + iMod (own_alloc (● (init_fuel_map s0 ζ0) ⋅ + ◯ (init_fuel_map s0 ζ0))) as (γ) "[Hfl Hfr]". + { apply auth_both_valid_2; eauto. by apply singleton_valid. } + iExists _. by iSplitL "Hfl". + 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 `{Countable (locale Λ)}. + Context `{LM: LiveModel Λ M}. + 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 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 has_fuels_agree (ζ : locale Λ) (fs : gmap (fmrole M) nat) + (m : gmap (locale Λ) (gmap (fmrole M) nat)) : + auth_fuel_mapping_is m -∗ has_fuels ζ fs -∗ ⌜m !! ζ = Some fs⌝. + Proof. + iIntros "Hauth Hfrag". + iDestruct (own_valid_2 with "Hauth Hfrag") as %Hvalid. + iPureIntro. + apply auth_both_valid_discrete in Hvalid as [Hincl Hvalid]. + rewrite map_fmap_singleton in Hincl. + apply singleton_included_exclusive_l in Hincl; + [|apply _|done]. + rewrite lookup_fmap in Hincl. + apply leibniz_equiv in Hincl. + destruct (m !! ζ); simplify_eq/=; done. + Qed. + + Lemma has_fuels_update fm ζ fs fs' : + auth_fuel_mapping_is fm -∗ has_fuels ζ fs ==∗ + auth_fuel_mapping_is (<[ζ := fs']>fm) ∗ has_fuels ζ fs'. + Proof. + iIntros "Hfm Hfs". + rewrite /has_fuels_S. + iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. + iMod (own_update_2 with "Hfm Hfs") as "[$ $]"; [|done]. + apply auth_update. + rewrite !fmap_insert. + rewrite !fmap_empty. + rewrite -(insert_insert ∅ ζ (Excl fs') (Excl fs)). + eapply insert_local_update; [| |]. + - rewrite lookup_fmap. rewrite Hagree. simpl. done. + - simpl. rewrite lookup_insert. done. + - eapply exclusive_local_update. done. + Qed. + + Lemma has_fuels_decr (ζ : locale Λ) (fs : gmap (fmrole M) nat) + (m : gmap (locale Λ) (gmap (fmrole M) nat)) : + auth_fuel_mapping_is m -∗ has_fuels_S ζ fs ==∗ + auth_fuel_mapping_is (<[ζ := fs]>m) ∗ has_fuels ζ fs. + Proof. + iIntros "Hfm Hfs". + iMod (has_fuels_update with "Hfm Hfs") as "[Hfm Hfs]". + by iFrame. + Qed. + + Lemma has_fuels_delete fs ζ ρs ρ : + auth_fuel_mapping_is fs -∗ has_fuels ζ ρs ==∗ + auth_fuel_mapping_is (<[ζ := delete ρ ρs]>fs) ∗ + has_fuels ζ (delete ρ ρs). + Proof. + iIntros "Hfm Hfs". + iMod (has_fuels_update with "Hfm Hfs") as "[Hfm Hfs]". + by iFrame. + Qed. + + Lemma model_state_interp_has_fuels_decr tp δ tid fs : + model_state_interp tp δ -∗ has_fuels_S tid fs ==∗ + model_state_interp tp δ ∗ has_fuels tid fs. + Proof. + iDestruct 1 as + (fm [Hfmle Hdom] Hfmdead Htp) "(Hδ & Hfm)". + iIntros "Hfs". + iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. + iMod (has_fuels_decr with "Hfm Hfs") as "[Hfm Hfs]". + iModIntro. iFrame "Hfs". + iExists _. iFrame. + iPureIntro. repeat split. + - eapply map_included_transitivity; [|done]. + rewrite -{2}(insert_id fm tid (S <$> fs)); [|done]. + apply map_included_insert; [|apply map_included_refl]. + apply map_included_fmap. lia. + - rewrite -Hdom. rewrite -{2}(insert_id fm tid (S <$> fs)); [set_solver|]. + done. + - intros ρ Hin. apply Hfmdead in Hin as (ζ'&ρs&HSome&Hρ). + destruct (decide (tid = ζ')) as [->|Hneq]. + + exists ζ', fs. rewrite lookup_insert. + split; [done|]. set_solver. + + exists ζ', ρs. rewrite lookup_insert_ne; [|done]. done. + - intros ζ Hζ. + specialize (Htp ζ Hζ). + rewrite -(insert_id fm tid (S <$> fs)) in Htp; [|done]. + rewrite -not_elem_of_dom. + rewrite -not_elem_of_dom in Htp. + set_solver. + Qed. + + Lemma model_state_interp_has_fuels_dealloc tid fs ρ tp δ δ' : + ρ ∉ live_roles _ δ → + model_state_interp tp δ' -∗ + frag_model_is δ -∗ + has_fuels tid fs ==∗ + model_state_interp tp δ' ∗ frag_model_is δ ∗ has_fuels tid (delete ρ fs). + Proof. + intros Hρ. + destruct (decide (ρ ∈ dom fs)) as [Hin|Hnin]; last first. + { assert (delete ρ fs = fs) as ->. + { apply delete_notin. by rewrite -not_elem_of_dom. } + by iIntros "$$$". } + iDestruct 1 as + (fm [Hfmle Hdom] Hfmdead Htp) "(Hm & Hfm)". + iIntros "Hst Hfs". + iDestruct (model_agree with "Hm Hst") as %Heq. rewrite !Heq. + assert (is_Some (fs !! ρ)) as [f HSome]. + { by rewrite -elem_of_dom. } + iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. + iMod (has_fuels_delete with "Hfm Hfs") as "[Hfm Hfs]". + iModIntro. + iFrame "Hst". iFrame "Hfs". + iExists _. iFrame. rewrite Heq. iFrame. + iPureIntro. + repeat split; try done. + - rewrite /fuel_map_le. + eapply map_included_transitivity; [|done]. + rewrite -{2}(insert_id fm tid fs); [|done]. + apply map_included_insert; [|apply map_included_refl]. + eapply map_included_subseteq; [|done]. + apply delete_subseteq. + - rewrite dom_insert_L. + assert (tid ∈ dom fm). + { by apply elem_of_dom. } + set_solver. + - rewrite /fuel_map_preserve_dead. + intros ρ' Hρ'. + assert (ρ ≠ ρ') by set_solver. + rewrite /fuel_map_preserve_dead in Hfmdead. + rewrite Heq in Hfmdead. + apply Hfmdead in Hρ' as (ζ&ρs&HSome'&Hρs). + destruct (decide (tid = ζ)) as [->|Hneq]. + + exists ζ, (delete ρ fs). + rewrite lookup_insert. set_solver. + + exists ζ, ρs. rewrite lookup_insert_ne; [|done]. + set_solver. + - intros ζ Hζ. specialize (Htp ζ Hζ). + rewrite -not_elem_of_dom. + rewrite -not_elem_of_dom in Htp. + assert (ζ ≠ tid). + { intros ->. + assert (tid ∈ dom fm). + { rewrite elem_of_dom. by set_solver. } + set_solver. } + set_solver. + Qed. + + (* TODO: Move this *) + Lemma silent_step_suff_data_weak fl `(δ: LiveState Λ M) + (fs fs' : gmap _ nat) ζ : + δ.(ls_map) !! ζ = Some fs → + fs ≠ ∅ → + map_included (fun _ => (<)) fs' fs → + (dom fs ∖ dom fs') ∩ M.(live_roles) δ = ∅ → + ∃ δ', δ'.(ls_data) = + {| ls_under := δ; + ls_map := <[ζ := fs']> δ.(ls_map) |} ∧ + ls_trans fl δ (Silent_step ζ) δ'. + Proof. + intros. + apply (silent_step_suff_data fl δ fs fs' ∅ ζ None); try done. + - rewrite map_included_spec in H2. done. + - set_solver. + - set_solver. + Qed. + + (* TODO: Change original lemma to not existentially quantify new state *) + Lemma silent_step_suff_data_weak_alt fl (δ δ' : LiveState Λ M) + (fs fs' : gmap _ nat) ζ : + δ.(ls_under) = δ'.(ls_under) → + δ.(ls_map) !! ζ = Some fs → + δ'.(ls_map) = <[ζ := fs']>δ.(ls_map) → + fs ≠ ∅ → + map_included (fun _ => (<)) fs' fs → + (dom fs ∖ dom fs') ∩ M.(live_roles) δ = ∅ → + ls_trans fl δ (Silent_step ζ) δ'. + Proof. + rewrite map_included_spec. intros Hδ Hfs Hfs' Hne Hle Hlive. + assert (∃ δ', δ'.(ls_data) = + {| ls_under := δ; + ls_map := <[ζ := fs']> δ.(ls_map) |} ∧ + ls_trans fl δ (Silent_step ζ) δ') as (δ''&Heq&Htrans). + { apply (silent_step_suff_data fl δ fs fs' ∅ ζ None); try set_solver. } + rewrite Heq Hδ -Hfs' in Htrans. by destruct δ', ls_data. + Qed. + + Definition model_can_fuel_step (δ1 : LM) (ζ : locale Λ) (δ2 : LM) : Prop := + ∃ fs1 fs2, + δ1.(ls_under) = δ2.(ls_under) ∧ + δ1.(ls_map) !! ζ = Some fs1 ∧ + δ2.(ls_map) = <[ζ := fs2]>δ1.(ls_map) ∧ + fs1 ≠ ∅ ∧ + map_included (fun _ => (<)) fs2 fs1 ∧ + (dom fs1 ∖ dom fs2) ∩ M.(live_roles) δ1 = ∅. + + Lemma model_can_fuel_step_trans fl ζ (δ δ' : LiveState Λ M) : + model_can_fuel_step δ ζ δ' → ls_trans fl δ (Silent_step ζ) δ'. + Proof. + destruct 1 as (?&?&?&?&?&?&?&?). by eapply silent_step_suff_data_weak_alt. + Qed. + + Definition decr_fuel_map (fs : gmap (fmrole M) nat) : gmap (fmrole M) nat := + (λ f, f - 1) <$> fs. + + Lemma decr_fuel_map_included fs : map_included (fun _ => (≤)) (decr_fuel_map fs) fs. + Proof. + apply map_included_spec. intros k v1 Hm. + apply lookup_fmap_Some in Hm as [v2 [Hv2 Hm]]. + exists v2. split; [done|lia]. + Qed. + + Definition filter_fuel_map + δ (ρs : gset (fmrole M)) (fs : gmap (fmrole M) nat) : + gmap (fmrole M) nat := + (filter (λ ρf, ρf.1 ∈ M.(live_roles) δ.(ls_under) ∨ ρf.1 ∈ ρs)) fs. + + Lemma filter_fuel_map_included δ ρs fs : + map_included (fun _ => (≤)) (filter_fuel_map δ ρs fs) fs. + Proof. + apply map_included_spec. + intros k v1 Hm. + exists v1. split; [|lia]. + pose proof (map_filter_subseteq + (λ ρf : fmrole M * nat, ρf.1 ∈ live_roles M δ ∨ ρf.1 ∈ ρs) fs) + as Hle. + rewrite map_subseteq_spec in Hle. + by apply Hle. + Qed. + + Definition model_update_locale_role_map + δ (ρs : gset (fmrole M)) : gmap (fmrole M) nat → gmap (fmrole M) nat := + decr_fuel_map ∘ filter_fuel_map δ ρs. + + Lemma model_update_locale_role_map_map_included δ ρs fs : + map_included (fun _ => (≤)) (model_update_locale_role_map δ ρs fs) fs. + Proof. + rewrite /model_update_locale_role_map. + eapply map_included_transitivity; + [eapply decr_fuel_map_included|eapply filter_fuel_map_included]. + Qed. + + Definition model_update_locale_fuel_map + δ (ζ : locale Λ) (ρs : gset (fmrole M)) + (fm : gmap (locale Λ) (gmap (fmrole M) nat)) : + gmap (locale Λ) (gmap (fmrole M) nat) := + <[ζ:= model_update_locale_role_map δ ρs (fm !!! ζ)]>fm. + + Program Definition model_update_decr (ζ : locale Λ) (δ : LM) : LM := + {| + ls_data := + {| ls_under := δ.(ls_under); + ls_map := alter (fmap (λ f, f - 1)) ζ δ.(ls_map); |}; + |}. + Next Obligation. + intros ζ δ ζ1 ζ2 fs1 fs2 Hneq HSome1 HSome2. + simpl in *. + pose proof δ.(ls_map_disj) as Hdisj. + assert (∃ fs1', map_included (fun _ => (≤)) fs1 fs1' ∧ ls_map δ !!! ζ1 = fs1') + as (fs1' & Hle1 & Hfs1'). + { destruct (decide (ζ = ζ1)) as [<-|Hneq']. + + rewrite lookup_alter in HSome1. + rewrite -lookup_fmap in HSome1. + apply lookup_fmap_Some in HSome1 as (fs1'&Hfs1'&HSome1'). + simplify_eq. + exists fs1'. rewrite lookup_total_alt. simpl. rewrite HSome1'. + split; [apply decr_fuel_map_included|done]. + + rewrite lookup_alter_ne in HSome1; [|done]. + rewrite lookup_total_alt. eexists _. + split; [done|by rewrite HSome1]. } + assert (∃ fs2', map_included (fun _ => (≤)) fs2 fs2' ∧ ls_map δ !!! ζ2 = fs2') + as (fs2' & Hle2 & Hfs2'). + { destruct (decide (ζ = ζ2)) as [<-|Hneq']. + + rewrite lookup_alter in HSome2. + rewrite -lookup_fmap in HSome2. + apply lookup_fmap_Some in HSome2 as (fs2'&Hfs2'&HSome2'). + simplify_eq. + exists fs2'. rewrite lookup_total_alt. simpl. rewrite HSome2'. + split; [apply decr_fuel_map_included|done]. + + rewrite lookup_alter_ne in HSome2; [|done]. + rewrite lookup_total_alt. eexists _. + split; [done|by rewrite HSome2]. } + rewrite lookup_total_alt in Hfs1'. + rewrite lookup_total_alt in Hfs2'. + destruct (ls_map δ !! ζ1) as [fs1''|] eqn:Hfs1''; last first. + { apply map_included_subseteq_inv in Hle1. + apply map_disjoint_dom. set_solver. } + destruct (ls_map δ !! ζ2) as [fs2''|] eqn:Hfs2''; last first. + { apply map_included_subseteq_inv in Hle2. + apply map_disjoint_dom. set_solver. } + simplify_eq; simpl in *. + specialize (Hdisj ζ1 ζ2 fs1'' fs2'' Hneq Hfs1'' Hfs2''). + apply map_disjoint_spec. + rewrite map_disjoint_spec in Hdisj. + intros i x y HSome1' HSome2'. + rewrite map_included_spec in Hle1. + apply Hle1 in HSome1' as (?&?&?). + rewrite map_included_spec in Hle2. + apply Hle2 in HSome2' as (?&?&?). + by eapply Hdisj. + Qed. + Next Obligation. + intros ζ δ ρ Hlive. + simpl in *. + pose proof Hlive as Hlive'. + apply (ls_map_live δ) in Hlive as (ζ' & fs & HSome & Hdom). + destruct (decide (ζ = ζ')) as [<-|Hneq]. + - eexists ζ, _. + rewrite lookup_alter. rewrite HSome. simpl. + split; [done|]. + rewrite dom_fmap. done. + - eexists ζ', fs. by rewrite lookup_alter_ne. + Qed. + + Program Definition model_update_filter + (ζ : locale Λ) (ρs : gset (fmrole M)) (δ : LM) : LM := + {| + ls_data := + {| ls_under := δ.(ls_under); + ls_map := + alter (filter + (λ ρf, ρf.1 ∈ M.(live_roles) δ.(ls_under) ∨ ρf.1 ∈ ρs)) + ζ δ.(ls_map); |}; + |}. + Next Obligation. + intros ζ ρs δ ζ1 ζ2 fs1 fs2 Hneq HSome1 HSome2. + simpl in *. + pose proof δ.(ls_map_disj) as Hdisj. + assert (∃ fs1', map_included (fun _ => (≤)) fs1 fs1' ∧ ls_map δ !!! ζ1 = fs1') + as (fs1' & Hle1 & Hfs1'). + { destruct (decide (ζ = ζ1)) as [<-|Hneq']. + + rewrite lookup_alter in HSome1. + rewrite -lookup_fmap in HSome1. + apply lookup_fmap_Some in HSome1 as (fs1'&Hfs1'&HSome1'). + simplify_eq. + exists fs1'. rewrite lookup_total_alt. simpl. rewrite HSome1'. + split; [apply filter_fuel_map_included|done]. + + rewrite lookup_alter_ne in HSome1; [|done]. + rewrite lookup_total_alt. eexists _. + split; [done|by rewrite HSome1]. } + assert (∃ fs2', map_included (fun _ => (≤)) fs2 fs2' ∧ ls_map δ !!! ζ2 = fs2') + as (fs2' & Hle2 & Hfs2'). + { destruct (decide (ζ = ζ2)) as [<-|Hneq']. + + rewrite lookup_alter in HSome2. + rewrite -lookup_fmap in HSome2. + apply lookup_fmap_Some in HSome2 as (fs2'&Hfs2'&HSome2'). + simplify_eq. + exists fs2'. rewrite lookup_total_alt. simpl. rewrite HSome2'. + split; [apply filter_fuel_map_included|done]. + + rewrite lookup_alter_ne in HSome2; [|done]. + rewrite lookup_total_alt. eexists _. + split; [done|by rewrite HSome2]. } + rewrite lookup_total_alt in Hfs1'. + rewrite lookup_total_alt in Hfs2'. + destruct (ls_map δ !! ζ1) as [fs1''|] eqn:Hfs1''; last first. + { apply map_included_subseteq_inv in Hle1. + apply map_disjoint_dom. set_solver. } + destruct (ls_map δ !! ζ2) as [fs2''|] eqn:Hfs2''; last first. + { apply map_included_subseteq_inv in Hle2. + apply map_disjoint_dom. set_solver. } + simplify_eq; simpl in *. + specialize (Hdisj ζ1 ζ2 fs1'' fs2'' Hneq Hfs1'' Hfs2''). + apply map_disjoint_spec. + rewrite map_disjoint_spec in Hdisj. + intros i x y HSome1' HSome2'. + rewrite map_included_spec in Hle1. + apply Hle1 in HSome1' as (?&?&?). + rewrite map_included_spec in Hle2. + apply Hle2 in HSome2' as (?&?&?). + by eapply Hdisj. + Qed. + Next Obligation. + intros ζ ρs δ ρ Hlive. + simpl in *. + pose proof Hlive as Hlive'. + apply (ls_map_live δ) in Hlive as (ζ' & fs & HSome & Hdom). + destruct (decide (ζ = ζ')) as [<-|Hneq]. + - eexists ζ, _. + rewrite lookup_alter. rewrite HSome. simpl. + split; [done|]. + rewrite map_filter_or. + rewrite dom_union_L. + apply elem_of_union. left. + apply elem_of_dom. + apply elem_of_dom in Hdom as [f Heq]. exists f. + by apply map_lookup_filter_Some_2. + - eexists ζ', fs. by rewrite lookup_alter_ne. + Qed. + + Definition model_update_locale_fuel + (δ : LM) (ζ : locale Λ) (ρs : gset (fmrole M)) : LM := + model_update_decr ζ $ model_update_filter ζ ρs δ. + + Lemma model_update_locale_spec extr (auxtr : auxiliary_trace LM) ζ c2 ρs: + model_can_fuel_step (trace_last auxtr) ζ ((model_update_locale_fuel (trace_last auxtr) ζ) ρs) → + tids_smaller c2.1 (model_update_locale_fuel (trace_last auxtr) ζ ρs) → + valid_state_evolution_fairness + (extr :tr[Some ζ]: c2) + (auxtr :tr[Silent_step ζ]: + (model_update_locale_fuel (trace_last auxtr) ζ) ρs). + Proof. + intros Hstep Htids. destruct c2. + split; [done|]. split; [by apply model_can_fuel_step_trans|done]. + Qed. + + Definition map_disj (m : gmap (locale Λ) (gmap (fmrole M) nat)) := + ∀ ζ ζ' fs fs', ζ ≠ ζ' → m !! ζ = Some fs → m !! ζ' = Some fs' → fs ##ₘ fs'. + + Lemma decr_succ_compose_id : (λ f : nat, f - 1) ∘ S = id. + Proof. apply FunExt. intros x. simpl. lia. Qed. + + Definition map_inner_disj `{Countable K1} `{Countable K2} {V} + (m : gmap K1 (gmap K2 V)) := + ∀ (k1 k2 : K1) (vs1 vs2 : gmap K2 V), + k1 ≠ k2 → m !! k1 = Some vs1 → m !! k2 = Some vs2 → vs1 ##ₘ vs2. + + Lemma fuel_map_le_disj ζ1 ζ2 fm fs1 fs2 ρ + (fuel_map : gmap (locale Λ) (gmap (fmrole M) nat)) : + fuel_map_le_inner fm fuel_map → map_inner_disj fuel_map → + fm !! ζ1 = Some fs1 → fm !! ζ2 = Some fs2 → + ρ ∈ dom fs1 → ρ ∈ dom fs2 → + ζ1 = ζ2 ∧ fs1 = fs2. + Proof. + intros Hle Hdisj HSome1 HSome2 [f1 Hf1]%elem_of_dom [f2 Hf2]%elem_of_dom. + destruct (decide (ζ1 = ζ2)) as [->|Hneq]. + { simplify_eq. set_solver. } + rewrite /fuel_map_le_inner map_included_spec in Hle. + apply Hle in HSome1 as (fs1'&Hfs1'&Hle1). + apply Hle in HSome2 as (fs2'&Hfs2'&Hle2). + assert (ρ ∈ dom fs1') as [??]%elem_of_dom. + { apply elem_of_dom. rewrite map_included_spec in Hle1. + by apply Hle1 in Hf1 as (?&?&?). } + assert (ρ ∈ dom fs2') as [??]%elem_of_dom. + { apply elem_of_dom. rewrite map_included_spec in Hle2. + by apply Hle2 in Hf2 as (?&?&?). } + exfalso. rewrite /map_inner_disj in Hdisj. + specialize (Hdisj ζ1 ζ2 fs1' fs2' Hneq Hfs1' Hfs2'). + rewrite map_disjoint_spec in Hdisj. by eapply Hdisj. + Qed. + + Lemma fuel_map_le_disj' ζ1 ζ2 fm fs1 fs2 fs1' fs2' ρ + (fuel_map : gmap (locale Λ) (gmap (fmrole M) nat)) : + fuel_map_le_inner fm fuel_map → map_inner_disj fuel_map → + fm !! ζ1 = Some fs1 → fm !! ζ2 = Some fs2 → + fuel_map !! ζ1 = Some fs1' → fuel_map !! ζ2 = Some fs2' → + ρ ∈ dom fs1' → ρ ∈ dom fs2' → + ζ1 = ζ2 ∧ fs1 = fs2. + Proof. + intros Hle Hdisj HSome1 HSome2 HSome1' HSome2' + [f1 Hf1]%elem_of_dom [f2 Hf2]%elem_of_dom. + destruct (decide (ζ1 = ζ2)) as [->|Hneq]. + { simplify_eq. set_solver. } + rewrite /fuel_map_le_inner map_included_spec in Hle. + exfalso. rewrite /map_inner_disj in Hdisj. + specialize (Hdisj ζ1 ζ2 fs1' fs2' Hneq HSome1' HSome2'). + rewrite map_disjoint_spec in Hdisj. by eapply Hdisj. + Qed. + + (* TODO: Clean up *) + Lemma fuel_map_le_live_roles fm fm' (lρs : gset (fmrole M)) ζ ρs ρs' ρ : + map_inner_disj fm' → fuel_map_le_inner fm fm' → + fuel_map_preserve_dead fm lρs → + fm !! ζ = Some ρs → fm' !! ζ = Some ρs' → + ρ ∈ lρs → ρ ∈ dom ρs' → + ρ ∈ dom ρs. + Proof. + intros Hdisj Hfmle Hfmdead Hρ Hρs' Hlive [f Hf]%elem_of_dom. + rewrite /fuel_map_le_inner map_included_spec in Hfmle. + apply Hfmdead in Hlive as (ζ'&fs'&Hfs'&Hv2'). + assert (dom ρs = dom fs') as Heq. + { f_equiv. pose proof Hfs' as Hfs''. apply Hfmle in Hfs'' as (fs''&?&Hfs''). + eapply (fuel_map_le_disj' ζ ζ' fm ρs fs' ρs' fs'' ρ + fm'); try done. + - rewrite /fuel_map_le_inner map_included_spec. apply Hfmle. + - by apply elem_of_dom. + - rewrite map_included_spec in Hfs''. + apply elem_of_dom in Hv2' as [??]. + apply Hfs'' in H1. destruct H1 as (?&?&?). + by apply elem_of_dom. } + set_solver. + Qed. + + Lemma model_state_interp_can_fuel_step es δ ζ fs : + fs ≠ ∅ → model_state_interp es δ -∗ has_fuels_S ζ fs -∗ + ⌜model_can_fuel_step δ ζ ((model_update_locale_fuel δ ζ) (dom fs))⌝. + Proof. + iIntros (Hfs) "Hm Hfs". + iDestruct "Hm" as (fm Hfmle Hfmdead Htp) "(Hm & Hfm)". + rewrite /model_can_fuel_step. + iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. + rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. + pose proof Hagree as Hagree'. + apply Hfmle in Hagree as [v2 [HSome Hle]]. + iPureIntro. + exists v2. exists (model_update_locale_role_map δ (dom fs) v2). + repeat split; try done. + - simpl. rewrite -alter_compose. + rewrite -alter_insert. f_equiv; [done|by rewrite insert_id]. + - assert (dom fs ⊆ dom v2). + { erewrite <-dom_fmap_L. by eapply map_included_subseteq_inv. } + rewrite -dom_empty_iff_L. + rewrite -dom_empty_iff_L in Hfs. + set_solver. + - clear Htp Hfs. pose proof δ.(ls_map_disj) as Hdisj. + apply map_included_spec. + rewrite map_included_spec in Hle. + intros k v1 Hv2. + rewrite /model_update_locale_role_map lookup_fmap in Hv2. + apply fmap_Some in Hv2 as [? [Hv2 ->]]. + pose proof Hv2 as Hv2'%map_lookup_filter_Some_1_2. + apply map_lookup_filter_Some_1_1 in Hv2. + assert (k ∈ dom fs) as Hv2''. + { destruct Hv2' as [Hv2'|Hv2']; [|done]. + rewrite -(dom_fmap_L S fs). + eapply (fuel_map_le_live_roles _ δ.(ls_map)); [| |done..|]. + - intros ???????. eapply Hdisj; try done. + - rewrite /fuel_map_le_inner map_included_spec. apply Hfmle. + - by apply elem_of_dom. } + rewrite -(dom_fmap_L S) in Hv2''. + apply elem_of_dom in Hv2'' as [f Heq]. + pose proof Heq as Heq'. + apply lookup_fmap_Some in Heq' as [f' [<- _]]. + apply Hle in Heq as [f'' [Heq Hle']]. + exists f''. split; [done|]. + destruct f''; [lia|]. + simplify_eq. lia. + - rewrite /model_update_locale_role_map. + simpl. + rewrite dom_fmap_L. + clear. + induction v2 using map_ind. + { set_solver. } + rewrite /filter_fuel_map. + rewrite map_filter_insert. simpl. + case_decide. + + set_solver. + + rewrite -dom_difference_L. + rewrite map_filter_delete. + rewrite -insert_difference. + set_solver. + Qed. + + Lemma fuel_map_le_fuel_step fm ζ fs (δ:LM) : + fm !! ζ = Some (S <$> fs) → + fuel_map_le fm (ls_map δ) → + fuel_map_le (<[ζ:=fs]> fm) (ls_map (model_update_locale_fuel δ ζ (dom fs))). + Proof. + intros Hagree [Hfmle Hfmdom]. + split; [|by apply elem_of_dom_2 in Hagree; set_solver]. + rewrite /model_update_locale_fuel=> /=. + pose proof Hfmle as Hfmle'. rewrite /fuel_map_le_inner map_included_spec in Hfmle'. + apply Hfmle' in Hagree as [ρs [HSome Hρs]]. + rewrite -(insert_id (ls_map δ) ζ ρs); [|done]. + rewrite -alter_compose alter_insert=> /=. + apply map_included_insert; [|done]. + (* OBS: The remaining proof can likely be decomposed into library lemmas *) + clear Hfmle Hfmle' HSome Hfmdom. + apply map_included_spec. + intros ρ f1 Hρ. + rewrite map_included_spec in Hρs. + assert ((S <$> fs) !! ρ = Some (S f1)) as Hρ'; [by rewrite lookup_fmap Hρ|]. + specialize (Hρs ρ (S f1) Hρ') as [v2 [Hv2 Hle]]. + destruct v2; [lia|]. exists v2. split; [|lia]. + rewrite !lookup_fmap. + erewrite map_lookup_filter_Some_2; [|done|]; first by simpl; f_equal; lia. + simpl. + destruct (decide (ρ ∈ live_roles M δ ∨ ρ ∈ dom fs)) + as [Hin|Hnin]; first done. + apply Decidable.not_or in Hnin. destruct Hnin as [Hnin1 Hnin2]. + apply not_elem_of_dom in Hnin2. set_solver. + Qed. + + Lemma fuel_map_preserve_dead_fuel_step fm ζ fs (δ:LM) : + fm !! ζ = Some (S <$> fs) → + fuel_map_preserve_dead fm + (M.(live_roles) $ model_update_locale_fuel δ ζ (dom fs)) → + fuel_map_preserve_dead (<[ζ:=fs]> fm) + (M.(live_roles) $ (model_update_locale_fuel δ ζ (dom fs))). + Proof. + intros Hagree Hfmdead ρ Hin. apply Hfmdead in Hin as (ζ'&ρs&HSome&Hρ). + destruct (decide (ζ = ζ')) as [<-|Hneq]. + + exists ζ, fs. rewrite lookup_insert. by set_solver. + + exists ζ', ρs. rewrite lookup_insert_ne; [by set_solver|done]. + Qed. + + Lemma fuel_map_preserve_threadpool_fuel_step + c1 ζ c2 (fm1 fm2 : gmap _ (gmap (fmrole M) nat)) : + dom fm1 = dom fm2 → locale_step c1 (Some ζ) c2 → + fuel_map_preserve_threadpool c1.1 fm1 → + fuel_map_preserve_threadpool c2.1 fm2. + Proof. + rewrite /fuel_map_preserve_threadpool. + intros Hdom Hstep Htp. intros ζ' Hζ'. destruct c1, c2. + apply locales_of_list_step_incl in Hstep. + assert (ζ' ∉ locales_of_list l) as Hζ'' by set_solver. + apply Htp in Hζ''. + rewrite -not_elem_of_dom. rewrite -not_elem_of_dom in Hζ''. + set_solver. + Qed. + + Lemma model_state_interp_fuel_update c1 c2 δ ζ fs : + locale_step c1 (Some ζ) c2 → + model_state_interp c1.1 δ -∗ + has_fuels_S ζ fs ==∗ + model_state_interp c2.1 (model_update_locale_fuel δ ζ (dom fs)) ∗ + has_fuels ζ fs. + Proof. + iIntros (Hstep) "Hm Hfs". + iDestruct "Hm" as (fm Hfmle Hfmdead Htp) "(Hm & Hfm)". + iDestruct (has_fuels_agree with "Hfm Hfs") as %Hagree. + iMod (has_fuels_decr with "Hfm Hfs") as "[Hfm $]". + iModIntro. iExists _. iFrame. iPureIntro. + split; [|split]. + - by apply fuel_map_le_fuel_step. + - by apply fuel_map_preserve_dead_fuel_step. + - eapply fuel_map_preserve_threadpool_fuel_step; [|done..]. + apply elem_of_dom_2 in Hagree. by set_solver. + Qed. + + Lemma update_fuel_step extr (auxtr : auxiliary_trace LM) c2 fs ζ : + fs ≠ ∅ → + locale_step (trace_last extr) (Some ζ) c2 → + has_fuels_S ζ fs -∗ + model_state_interp (trace_last extr).1 (trace_last auxtr) ==∗ + ∃ δ2, + ⌜ valid_state_evolution_fairness + (extr :tr[Some ζ]: c2) (auxtr :tr[Silent_step ζ]: δ2) ⌝ ∗ + has_fuels ζ fs ∗ model_state_interp c2.1 δ2. + Proof. + iIntros (Hdom Hstep) "Hfuel Hm". + iExists (model_update_locale_fuel (trace_last auxtr) ζ (dom fs)). + iDestruct (model_state_interp_can_fuel_step with "Hm Hfuel") as %Hcan_step; + [done|]. + iMod (model_state_interp_fuel_update with "Hm Hfuel") as "[Hm Hfuel]"; + [done..|]. + iDestruct (model_state_interp_tids_smaller with "Hm") as %Htids. + iModIntro. + iFrame "Hm Hfuel". + iPureIntro. by apply model_update_locale_spec. + Qed. + + (** Model step *) + + (* OBS: Maybe use fuel limit instead of generic [f] *) + Program Definition model_update_set (ζ : locale Λ) (ρ : fmrole M) (f : nat) (δ : LM) : LM := + {| + ls_data := + {| ls_under := δ.(ls_under); + ls_map := alter (alter (λ _, f) ρ) ζ δ.(ls_map); |}; + |}. + Next Obligation. + intros ζ ρ f δ ζ1 ζ2 fs1 fs2 Hneq HSome1 HSome2. simpl in *. + pose proof (δ.(ls_map_disj)) as Hdisj. + apply lookup_alter_Some in HSome1. + apply lookup_alter_Some in HSome2. + destruct HSome1 as [[-> [fs1' [HSome1 ->]]]|[_ HSome1]], + HSome2 as [[-> [fs2' [HSome2 ->]]]|[_ HSome2]]; + [done| | |]. + - specialize (Hdisj ζ1 ζ2 _ _ Hneq HSome1 HSome2). + rewrite map_disjoint_dom dom_alter_L. + rewrite map_disjoint_dom in Hdisj. set_solver. + - specialize (Hdisj ζ1 ζ2 _ _ Hneq HSome1 HSome2). + rewrite map_disjoint_dom dom_alter_L. + rewrite map_disjoint_dom in Hdisj. set_solver. + - by eapply Hdisj. + Qed. + Next Obligation. + intros ζ ρ f δ ρ' Hρ'. simpl in *. + pose proof (δ.(ls_map_live)) as Hlive. + apply Hlive in Hρ' as (ζ'&fs'&HSome&Hρ'). + destruct (decide (ζ = ζ')) as [<-|Hneq]. + - eexists ζ, _. rewrite lookup_alter HSome. split; [done|]. + by rewrite dom_alter_L. + - eexists ζ', _. by rewrite lookup_alter_ne. + Qed. + + Definition model_update_state (δ2 : M) (δ1 : LiveStateData Λ M) : + LiveStateData Λ M := + {| ls_under := δ2; + ls_map := δ1.(ls_map); |}. + + Lemma model_update_state_valid (δ2 : M) (δ1 : LM) : + M.(live_roles) δ2 ⊆ M.(live_roles) δ1 → + ∃ δ, (ls_data δ) = model_update_state δ2 δ1. + Proof. + intros Hle. + assert (∀ ζ ζ' fs fs', + ζ ≠ ζ' → (model_update_state δ2 δ1).(ls_map) !! ζ = Some fs → + (model_update_state δ2 δ1).(ls_map) !! ζ' = Some fs' → fs ##ₘ fs') as Hdisj'. + { intros. by eapply (δ1.(ls_map_disj)). } + assert (∀ ρ, ρ ∈ M.(live_roles) (model_update_state δ2 δ1).(ls_under) → + ∃ ζ fs, (model_update_state δ2 δ1).(ls_map) !! ζ = Some fs ∧ ρ ∈ dom fs) as Hlive'. + { pose proof (δ1.(ls_map_live)) as Hlive. + intros. + assert (ρ ∈ live_roles M δ1) as Hin by set_solver. + apply Hlive in Hin as (?&?&?&?). eexists _, _. done. } + exists + {| ls_data := model_update_state δ2 δ1; + ls_map_disj := Hdisj'; + ls_map_live := Hlive' |}. + done. + Qed. + + Definition model_update_model_step + (ζ : locale Λ) (ρs : gset (fmrole M)) ρ (δ2 : M) (δ : LM) : M := + model_update_state δ2 $ model_update_set ζ ρ (LM.(lm_fl) δ2) $ model_update_decr ζ $ model_update_filter ζ ρs δ. + + Lemma model_update_model_step_valid (ζ : locale Λ) (ρs : gset (fmrole M)) ρ (s2 : M) (δ1:LM) : + M.(live_roles) s2 ⊆ M.(live_roles) (ls_under δ1) → + ∃ δ, (ls_data δ) = model_update_model_step ζ ρs ρ s2 δ1. + Proof. intros. by apply model_update_state_valid. Qed. + + Lemma model_update s1 s2 s3 : + auth_model_is s1 -∗ frag_model_is s2 ==∗ + auth_model_is s3 ∗ frag_model_is s3. + Proof. + iIntros "Hauth Hfrag". + iMod (own_update_2 with "Hauth Hfrag") as "[$ $]"; [|done]. + apply auth_update. apply option_local_update. + by eapply exclusive_local_update. + Qed. + + Lemma alter_insert_alt `{Countable K} {A} (m : gmap K A) i f x : + m !! i = Some x → alter f i m = <[i := f x]> m. + Proof. + intros. rewrite -{1}(insert_id m i x); [|done]. apply alter_insert. + Qed. + + (* OBS: Need to make frag model abstract *) + Lemma model_state_interp_model_step_update (ρ : fmrole M) + (fs : gmap (fmrole M) nat) tp1 tp2 + (δ δ2 : LM) ζ σ1 σ2 (f1 : nat) s1 s2 : + ρ ∉ dom fs → + live_roles M s2 ⊆ live_roles M s1 → + locale_step (tp1, σ1) (Some ζ) (tp2, σ2) → + fmtrans _ s1 (Some ρ) s2 → + (ls_data δ2) = model_update_model_step ζ ({[ρ]} ∪ dom fs) ρ s2 δ → + model_state_interp tp1 δ -∗ + has_fuels ζ ({[ρ := f1]} ∪ (S <$> fs)) -∗ + frag_model_is s1 ==∗ + model_state_interp tp2 δ2 ∗ + has_fuels ζ ({[ρ := LM.(lm_fl) s2]} ∪ fs) ∗ + frag_model_is s2. + Proof. + iIntros (Hfs Hlive Hstep Hmstep Hδ2) "Hm Hf Hs". + iDestruct "Hm" as (fm Hfmle Hfmdead Htp) "(Hm & Hfm)". + iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. + iMod (has_fuels_update _ _ _ ({[ρ := lm_fl LM s2]} ∪ fs) with "Hfm Hf") + as "[Hfm Hf]". + iDestruct (model_agree with "Hm Hs") as %<-. + iMod (model_update _ _ s2 with "Hm Hs") as "[Hm Hs]". + iModIntro. iFrame. + rewrite Hδ2. iFrame. + iPureIntro. + split; [|split]. + - split; last first. + { simpl. + destruct Hfmle as [Hfmle Hdom]. + pose proof Hfmle as Hfmle'. + rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. + pose proof Hagree as Hagree'. + apply Hfmle in Hagree' as (fs'&HSome&Hfs'). + rewrite -(insert_id (ls_map δ) ζ fs'); [|done]. + rewrite !alter_insert. + set_solver. } + simpl. + destruct Hfmle as [Hfmle Hdom]. + pose proof Hfmle as Hfmle'. + rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. + pose proof Hagree as Hagree'. + apply Hfmle in Hagree' as (fs'&HSome&Hfs'). + rewrite -(insert_id (ls_map δ) ζ fs'); [|done]. + rewrite !alter_insert. + apply map_included_insert; [|done]. + assert ({[ρ := lm_fl LM s2]} ∪ fs = + (alter (λ _ : nat, lm_fl LM s2) ρ + ((λ f : nat, f - 1) <$> + (filter + (λ ρf : fmrole M * nat, ρf.1 ∈ live_roles M δ ∨ ρf.1 ∈ {[ρ]} ∪ dom fs) + ({[ρ := f1]} ∪ (S <$> fs)))))) as ->. + { rewrite -!insert_union_singleton_l. + rewrite map_filter_insert. simpl. + case_decide; [|set_solver]. + rewrite fmap_insert. rewrite alter_insert. f_equiv. + rewrite map_filter_fmap. + rewrite -map_fmap_compose. + rewrite decr_succ_compose_id. + rewrite map_fmap_id. + rewrite map_filter_id; [done|]. + intros i x Hin. apply elem_of_dom_2 in Hin. set_solver. } + apply map_included_mono_strong; [set_solver..| |]. + { intros k x1 x2 y1 y2 Hx1 Hx2 Hy1 Hy2 HR. + destruct (decide (k = ρ)) as [->|Hneq]. + - erewrite alter_insert_alt in Hy1; [|done]. + erewrite alter_insert_alt in Hy2; [|done]. + rewrite lookup_insert in Hy1. + rewrite lookup_insert in Hy2. by simplify_eq. + - rewrite lookup_alter_ne in Hy1; [|done]. + rewrite lookup_alter_ne in Hy2; [|done]. + by simplify_eq. } + apply map_included_mono_strong; [set_solver..| |]. + { intros k x1 x2 y1 y2 Hx1 Hx2 Hy1 Hy2 HR. + apply lookup_fmap_Some in Hy1 as (y1'&Hy1'&Hy1). + apply lookup_fmap_Some in Hy2 as (y2'&Hy2'&Hy2). + simplify_eq. lia. } + apply map_included_filter; [set_solver..|]. + done. + - apply elem_of_subseteq in Hlive. + intros ρ' Hin. + apply Hlive in Hin. + apply Hfmdead in Hin as (ζ'&ρs&HSome&Hρ). + destruct (decide (ζ = ζ')) as [<-|Hneq]. + + eexists ζ, _. rewrite lookup_insert. split; [done|]. by set_solver. + + eexists ζ', _. rewrite lookup_insert_ne; [|done]. + split; [done|]. by set_solver. + - rewrite /fuel_map_preserve_threadpool. + intros ζ' Hζ'. + apply locales_of_list_step_incl in Hstep. + assert (ζ' ∉ locales_of_list tp1) as Hζ'' by set_solver. + apply Htp in Hζ''. + rewrite -not_elem_of_dom. rewrite -not_elem_of_dom in Hζ''. + rewrite dom_insert_L. + rewrite -(insert_id fm ζ ({[ρ := f1]} ∪ (S <$> fs))) in Hζ''; [|done]. + rewrite dom_insert_L in Hζ''. + set_solver. + Qed. + + Lemma model_step_suff_data_weak_alt (δ1 δ2 : LiveState Λ M) ρ + (fs fs': gmap _ nat) ζ : + fmtrans _ δ1 (Some ρ) δ2 → + M.(live_roles) δ2 ⊆ M.(live_roles) δ1 → + δ1.(ls_map) !! ζ = Some fs → + δ2.(ls_map) = <[ζ := fs']> δ1.(ls_map) → + ρ ∈ dom fs → + fs' !! ρ = Some (LM.(lm_fl) (ls_under δ2)) → + map_included (fun _ => (<)) (delete ρ fs') fs → + (dom fs ∖ dom fs' ∩ M.(live_roles) δ1 = ∅) → + ls_trans LM.(lm_fl) δ1 (Take_step ρ ζ) δ2. + Proof. + intros Hstep Hlive Hfs Hfs' Hρ Hρ' Hlt Hlive'. + assert (∃ (δ'':LiveState Λ M), δ''.(ls_data) = + {| ls_under := ls_under δ2; + ls_map := <[ζ := fs']> δ1.(ls_map) |} ∧ + ls_trans LM.(lm_fl) δ1 (Take_step ρ ζ) δ'') as (δ''&Heq&Htrans). + { eapply (model_step_suff_data); try done. + - rewrite map_included_spec in Hlt. + intros ρ' f f' Hf' Hneq Hf. + rewrite -(lookup_delete_ne _ ρ ρ') in Hf'; [|done]. + apply Hlt in Hf' as (?&?&?). by simplify_eq. + - set_solver. + - apply map_included_subseteq_inv in Hlt. set_solver. + - apply map_included_subseteq_inv in Hlt. set_solver. + - set_solver. } + rewrite Heq -Hfs' in Htrans. by destruct δ2, ls_data. + Qed. + + Definition model_can_model_step (δ1 : LM) (ζ : locale Λ) (ρ : fmrole M) (δ2 : LM) : Prop := + ∃ (fs fs' : gmap (fmrole M) nat), + fmtrans _ δ1 (Some ρ) δ2 ∧ + M.(live_roles) δ2 ⊆ M.(live_roles) δ1 ∧ + δ1.(ls_map) !! ζ = Some fs ∧ + δ2.(ls_map) = <[ζ := fs']> δ1.(ls_map) ∧ + ρ ∈ dom fs ∧ + fs' !! ρ = Some (LM.(lm_fl) (ls_under δ2)) ∧ + map_included (fun _ => (<)) (delete ρ fs') fs ∧ + (dom fs ∖ dom fs' ∩ M.(live_roles) δ1 = ∅). + + Lemma model_can_model_step_trans ζ ρ (δ δ' : LiveState Λ M) : + model_can_model_step δ ζ ρ δ' → ls_trans (LM.(lm_fl)) δ (Take_step ρ ζ) δ'. + Proof. + destruct 1 as (?&?&?&?&?&?&?&?&?&?). + by eapply model_step_suff_data_weak_alt. + Qed. + + Lemma model_state_interp_can_model_step es (δ δ2 : LM) ζ ρ f + (fs : gmap (fmrole M) nat) (s1 s2 : M) : + fmtrans _ s1 (Some ρ) s2 → + M.(live_roles) s2 ⊆ M.(live_roles) s1 → + ρ ∉ dom fs → + (ls_data δ2) = model_update_model_step ζ ({[ρ]} ∪ dom fs) ρ s2 δ → + model_state_interp es δ -∗ + has_fuels ζ ({[ρ := f]} ∪ (S <$> fs)) -∗ + frag_model_is s1 -∗ + ⌜model_can_model_step δ ζ ρ δ2⌝. + Proof. + iIntros (Hstep Hle Hρ Hδ2) "Hm Hf Hδ". + iDestruct "Hm" as (fm Hfmle Hfmdead Htp) "(Hm & Hfm)". + iDestruct (model_agree with "Hm Hδ") as %<-. + iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. + iPureIntro. + rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. + pose proof Hagree as Hagree'. + apply Hfmle in Hagree as (fs'&Hζ&Hfs'). + assert (ρ ∈ dom fs') as Hρ'. + { apply map_included_subseteq_inv in Hfs'. set_solver. } + eexists _, _. repeat split; try done. + - by rewrite Hδ2. + - by rewrite Hδ2. + - rewrite Hδ2. simpl. rewrite -!alter_compose. + rewrite -{1}(insert_id (ls_map δ) ζ fs'); [|done]. + rewrite alter_insert. + f_equiv. + done. + - rewrite Hδ2. simpl. rewrite lookup_alter. rewrite lookup_fmap. + apply elem_of_dom in Hρ' as [f' Heq]. + apply fmap_Some; eexists; split; last done. + apply fmap_Some; eexists; split; last done. + apply map_lookup_filter_Some_2; first done. + right; set_solver. + - rewrite map_included_spec. + intros ρ' f' HSome. + assert (ρ ≠ ρ'). + { intros Heq. rewrite Heq in HSome. + by rewrite lookup_delete in HSome. } + rewrite lookup_delete_ne in HSome; [|done]. + exists (f' + 1). + split; [|lia]. + simpl in *. + rewrite lookup_alter_ne in HSome; [|done]. + rewrite lookup_fmap in HSome. + rewrite map_lookup_filter in HSome. simpl in *. + destruct (fs' !! ρ') eqn:Heqn; [|done]. + simpl in *. + destruct (decide (ρ' ∈ live_roles M δ ∨ ρ' ∈ {[ρ]} ∪ dom fs)) as [Hin|Hnin]. + + rewrite option_guard_True in HSome; [|done]. + simpl in *. simplify_eq. f_equiv. + assert (ρ' ∈ dom ({[ρ := f]} ∪ (S <$> fs))) as Hin'. + { destruct Hin as [Hin|Hin]; [|set_solver]. + eapply (fuel_map_le_live_roles _ δ.(ls_map)); [| |done..|]. + - intros ???????. by eapply δ.(ls_map_disj). + - rewrite /fuel_map_le_inner map_included_spec. apply Hfmle. + - by apply elem_of_dom. } + rewrite dom_union_L in Hin'. + apply elem_of_union in Hin' as [Hin'|Hin']; [set_solver|]. + apply elem_of_dom in Hin' as [v2 Hv2]. + rewrite map_included_spec in Hfs'. + specialize (Hfs' ρ' v2). + rewrite lookup_union_r in Hfs'; [|by rewrite lookup_insert_ne]. + destruct v2. + { apply lookup_fmap_Some in Hv2 as (?&?&?). lia. } + apply Hfs' in Hv2 as (n'&Hn'&Hn''). + simplify_eq. + lia. + + by rewrite option_guard_False in HSome. + - (* TODO: Make a lemma for this *) + simpl. + rewrite dom_alter_L. + rewrite dom_fmap_L. + clear. + induction fs' using map_ind. + { set_solver. } + rewrite /filter_fuel_map. + rewrite map_filter_insert. simpl. + case_decide. + + set_solver. + + rewrite -dom_difference_L. + rewrite map_filter_delete. + rewrite -insert_difference. + set_solver. + Qed. + + Lemma model_update_locale_spec_model_step extr + (auxtr : auxiliary_trace LM) ζ c2 ρs ρ δ2 s2 : + (ls_data δ2) = model_update_model_step ζ ({[ρ]} ∪ ρs) ρ s2 + (trace_last auxtr) → + model_can_model_step (trace_last auxtr) ζ ρ δ2 → + tids_smaller c2.1 δ2 → + valid_state_evolution_fairness + (extr :tr[Some ζ]: c2) + (auxtr :tr[Take_step ρ ζ]: δ2). + Proof. + intros Hstep Htids. destruct c2. + split; [done|]. split; [by apply model_can_model_step_trans|done]. + Qed. + + Lemma update_model_step + (extr : execution_trace Λ) + (auxtr: auxiliary_trace LM) c2 (s1 s2 : M) fs ρ (δ1 : LM) ζ f : + M.(live_roles) s2 ⊆ M.(live_roles) s1 → + ρ ∉ dom fs → + trace_last auxtr = δ1 → + locale_step (trace_last extr) (Some ζ) c2 → + fmtrans _ s1 (Some ρ) s2 → + has_fuels ζ ({[ρ := f]} ∪ (S <$> fs)) -∗ frag_model_is s1 -∗ + model_state_interp (trace_last extr).1 δ1 ==∗ + ∃ (δ2: LM), + ⌜valid_state_evolution_fairness + (extr :tr[Some ζ]: c2) (auxtr :tr[Take_step ρ ζ]: δ2)⌝ ∗ + has_fuels ζ ({[ρ := LM.(lm_fl) s2]} ∪ fs) ∗ + frag_model_is s2 ∗ model_state_interp c2.1 δ2. + Proof. + iIntros (Hlive Hdom Hlast Hstep Htrans) "Hfuel Hfrag Hm". + iDestruct (model_agree' with "Hm Hfrag") as %<-. + pose proof (model_update_model_step_valid + ζ ({[ρ]} ∪ dom fs) ρ s2 δ1) as [δ2 Hδ2]; [done|]. + iExists δ2. + iDestruct (model_state_interp_can_model_step with "Hm Hfuel Hfrag") + as %Hcan_step; [try done..|]. + destruct (trace_last extr), c2. + iMod (model_state_interp_model_step_update with "Hm Hfuel Hfrag") + as "(Hm&Hf&Hfrag)"; [done..|]. + iDestruct (model_state_interp_tids_smaller with "Hm") as %Htids. + iModIntro. + iFrame "Hm Hf Hfrag". + iPureIntro. subst. + by eapply model_update_locale_spec_model_step. + Qed. + + (** Fork step *) + + Definition has_forked (tp1 tp2 : list (expr Λ)) e : Prop := + ∃ tp1', tp2 = tp1' ++ [e] ∧ locales_equiv tp1 tp1'. + + Definition model_update_split + (ζ ζf : locale Λ) (ρs : gset (fmrole M)) + (δ : LiveStateData Λ M) : LiveStateData Λ M := + {| ls_under := δ.(ls_under); + ls_map := <[ζf := (filter (λ ρf, ρf.1 ∈ ρs)) (δ.(ls_map) !!! ζ)]> + (alter (filter (λ ρf, ρf.1 ∉ ρs)) ζ δ.(ls_map)); |}. + + Definition map_live (ρs : gset (fmrole M)) + (m : gmap (locale Λ) (gmap (fmrole M) nat)) : Prop := + ∀ ρ, ρ ∈ ρs → ∃ ζ fs, m !! ζ = Some fs ∧ ρ ∈ dom fs. + + Lemma disjoint_subseteq `{Countable A} (xs1 xs2 ys1 ys2 : gset A) : + xs1 ⊆ xs2 → ys1 ⊆ ys2 → xs2 ## ys2 → xs1 ## ys1. + Proof. + intros Hle1 Hle2 Hdisj x Hxs Hys. + eapply Hdisj; [by apply Hle1|by apply Hle2]. + Qed. + + Lemma disjoint_subseteq_l `{Countable A} (xs ys zs : gset A) : + xs ⊆ ys → ys ## zs → xs ## zs. + Proof. intros Hle Hdisj x Hxs Hzs. eapply Hdisj; [by apply Hle|done]. Qed. + + Lemma disjoint_subseteq_r `{Countable A} (xs ys zs : gset A) : + zs ⊆ ys → xs ## ys → xs ## zs. + Proof. intros Hle Hdisj x Hxs Hzs. eapply Hdisj; [done|by apply Hle]. Qed. + + Lemma model_update_split_valid ζ ζf ρs (δ1 : LM) : + ζ ∈ dom δ1.(ls_map) → ζf ∉ dom δ1.(ls_map) → + ∃ δ2, (ls_data δ2) = model_update_split ζ ζf ρs δ1. + Proof. + intros [ρs' HSome]%elem_of_dom Hnin. + set δ2 := model_update_split ζ ζf ρs δ1. + assert (ζ ≠ ζf) as Hneq. + { intros ->. apply not_elem_of_dom in Hnin. set_solver. } + assert (map_inner_disj δ2.(ls_map)) as Hdisj. + { simpl. + pose proof δ1.(ls_map_disj) as Hdisj. + intros ζ1 ζ2 ρs1 ρs2 Hneq' HSome1 HSome2. + destruct (decide (ζf = ζ1)) as [<-|Hneqf1]. + { rewrite lookup_insert in HSome1. + rewrite lookup_insert_ne in HSome2; [|done]. + rewrite lookup_total_alt in HSome1. + rewrite HSome in HSome1. + simpl in *. + destruct (decide (ζ = ζ2)) as [<-|Hneq2]. + { rewrite lookup_alter in HSome2. + rewrite HSome in HSome2. simpl in *. simplify_eq. + apply map_disjoint_dom. + pose proof (disjoint_filter_complement + (λ ρ : fmrole M, ρ ∈ ρs) (dom ρs')) as Hcomp. + by rewrite !filter_dom_L in Hcomp. } + rewrite lookup_alter_ne in HSome2; [|done]. + simplify_eq. + apply map_disjoint_dom. + pose proof (Hdisj ζ ζ2 _ _ Hneq2 HSome HSome2) as Hdisj. + apply map_disjoint_dom in Hdisj. + eapply disjoint_subseteq_l; [|done]. + apply dom_filter_subseteq. } + rewrite lookup_insert_ne in HSome1; [|done]. + destruct (decide (ζf = ζ2)) as [<-|Hneqf2]. + { rewrite lookup_insert in HSome2. + destruct (decide (ζ = ζ1)) as [<-|Hneq2]. + { rewrite lookup_alter in HSome1. + rewrite lookup_total_alt in HSome2. + rewrite HSome in HSome1. + rewrite HSome in HSome2. + simpl in *. simplify_eq. + apply map_disjoint_dom. + pose proof (disjoint_filter_complement + (λ ρ : fmrole M, ρ ∈ ρs) (dom ρs')) as Hcomp. + by rewrite !filter_dom_L in Hcomp. } + rewrite lookup_alter_ne in HSome1; [|done]. + rewrite lookup_total_alt in HSome2. + rewrite HSome in HSome2. + simpl in *. simplify_eq. + pose proof (Hdisj ζ ζ1 _ _ Hneq2 HSome HSome1) as Hdisj. + apply map_disjoint_dom. + apply map_disjoint_dom in Hdisj. + eapply disjoint_subseteq_r; [|done]. + apply dom_filter_subseteq. } + destruct (decide (ζ = ζ1)) as [<-|Hneq1]. + { rewrite lookup_alter in HSome1. + rewrite lookup_insert_ne in HSome2; [|done]. + rewrite lookup_alter_ne in HSome2; [|done]. + rewrite HSome in HSome1. + simpl in *. simplify_eq. + pose proof (Hdisj ζ ζ2 _ _ Hneq' HSome HSome2) as Hdisj. + apply map_disjoint_dom. + apply map_disjoint_dom in Hdisj. + eapply disjoint_subseteq_l; [|done]. + apply dom_filter_subseteq. } + destruct (decide (ζ = ζ2)) as [<-|Hneq2]. + { rewrite lookup_alter_ne in HSome1; [|done]. + rewrite lookup_insert_ne in HSome2; [|done]. + rewrite lookup_alter in HSome2. + rewrite HSome in HSome2. + simpl in *. simplify_eq. + pose proof (Hdisj ζ ζ1 _ _ Hneq1 HSome HSome1) as Hdisj. + apply map_disjoint_dom. + apply map_disjoint_dom in Hdisj. + eapply disjoint_subseteq_r; [|done]. + apply dom_filter_subseteq. } + rewrite lookup_alter_ne in HSome1; [|done]. + rewrite lookup_insert_ne in HSome2; [|done]. + rewrite lookup_alter_ne in HSome2; [|done]. + pose proof (Hdisj ζ1 ζ2 _ _ Hneq' HSome1 HSome2). + done. } + assert (map_live (M.(live_roles) δ2) δ2.(ls_map)) as Hlive. + { intros ρ Hin. + pose proof (δ1.(ls_map_live)) as Hlive. + apply Hlive in Hin as (ζ'&fs&HSome'&Hin'). + destruct (decide (ζ' = ζf)) as [->|Hneqf]. + { apply not_elem_of_dom in Hnin. set_solver. } + destruct (decide (ζ' = ζ)) as [->|Hneq']. + { rewrite HSome in HSome'. simplify_eq. + simpl. + destruct (decide (ρ ∈ ρs)) as [Hin|Hnin']. + - exists ζf, (filter (λ ρf : fmrole M * nat, ρf.1 ∈ ρs) fs). + rewrite lookup_insert. rewrite lookup_total_alt. rewrite HSome. simpl. + split; [done|]. + apply elem_of_dom. rewrite /is_Some. + apply elem_of_dom in Hin' as [??]. + eexists _. by apply map_lookup_filter_Some_2. + - exists ζ, (filter (λ ρf : fmrole M * nat, ρf.1 ∉ ρs) fs). + rewrite lookup_insert_ne; [|done]. + rewrite lookup_alter. rewrite HSome. simpl. + split; [done|]. + apply elem_of_dom. rewrite /is_Some. + apply elem_of_dom in Hin' as [??]. + eexists _. by apply map_lookup_filter_Some_2. } + exists ζ', fs. split; [|done]. + simpl. rewrite !lookup_insert_ne; [|done]. + rewrite lookup_alter_ne; [|done]. + done. } + by exists + {| ls_data := δ2; + ls_map_disj := Hdisj; + ls_map_live := Hlive |}. + Qed. + + Definition model_update_fork + (ζ : locale Λ) (ζf : locale Λ) + (ρs1 ρs2 : gset (fmrole M)) (δ : LM) : + LiveStateData Λ M := + model_update_split ζ ζf ρs2 $ + model_update_decr ζ $ + model_update_filter ζ ρs1 δ. + + Lemma model_update_fork_valid + ζ ζf (ρs1 ρs2 : gset (fmrole M)) (δ1 : LM) : + ζ ∈ dom δ1.(ls_map) → ζf ∉ dom δ1.(ls_map) → + ∃ δ2, (ls_data δ2) = model_update_fork ζ ζf ρs1 ρs2 δ1. + Proof. intros ??. by apply model_update_split_valid; set_solver. Qed. + + Lemma has_fuels_alloc fm ζ fs : + ζ ∉ dom fm → + auth_fuel_mapping_is fm ==∗ + auth_fuel_mapping_is (<[ζ := fs]>fm) ∗ has_fuels ζ fs. + Proof. + iIntros (Hnin) "Hfm". + rewrite /has_fuels_S. + iMod (own_update with "Hfm") as "[$ $]"; [|done]. + apply auth_update_alloc. + rewrite !fmap_insert. + rewrite !fmap_empty. + eapply alloc_local_update; [|done]. + apply not_elem_of_dom in Hnin. by rewrite lookup_fmap Hnin. + Qed. + + Lemma has_fuels_split fm ζ ζf fs1 fs2 : + ζf ∉ dom fm → fs1 ##ₘ fs2 → + auth_fuel_mapping_is fm -∗ has_fuels ζ (fs1 ∪ fs2) ==∗ + auth_fuel_mapping_is (<[ζf := fs2]>(<[ζ := fs1]>fm)) ∗ + has_fuels ζ fs1 ∗ has_fuels ζf fs2. + Proof. + iIntros (Hnin Hdisj) "Hfm Hfs". + iDestruct (has_fuels_agree with "Hfm Hfs") as %HSome. + assert (ζ ≠ ζf) as Hneq. + { rewrite not_elem_of_dom in Hnin. set_solver. } + iMod (has_fuels_update with "Hfm Hfs") as "[Hfm $]". + iMod (has_fuels_alloc with "Hfm") as "[$$]"; set_solver. + Qed. + + Lemma not_elem_of_locale_of_from_list (tp : list $ expr Λ) e : + locale_of tp e ∉ locales_of_list tp. + Proof. + unfold locales_of_list_from. + intros Habs. + apply elem_of_list_fmap in Habs as ((tp1&e1) & Hlo & Hpf). + apply prefixes_from_spec in Hpf as (tp2&tp3&He1&He2). + simplify_eq. + list_simplifier. + + have Hdone: (tp2 ++ e1 :: tp3, e) ∈ prefixes_from (tp2++[e1]) (tp3 ++ [e]). + { apply prefixes_from_spec. eexists _, _. list_simplifier. naive_solver. } + by apply locale_injective in Hdone. + Qed. + + Lemma elem_of_locale_of_from_list (tp1 tp2 : list $ expr Λ) e : + locales_equiv tp1 tp2 → + locale_of tp1 e ∈ locales_of_list (tp2++[e]). + Proof. + intros Heq. rewrite (locale_equiv _ _ _ Heq) /locales_of_list_from. + apply elem_of_list_fmap. exists (tp2, e). split=>//. + apply prefixes_from_spec. eexists _, _. list_simplifier. naive_solver. + Qed. + + Lemma model_state_interp_fork_update fs1 fs2 tp1 tp2 + (δ1 δ2 : LM) ζ efork σ1 σ2 : + (ls_data δ2) = model_update_fork ζ (locale_of tp1 efork) (dom fs1 ∪ dom fs2) (dom fs2) δ1 → + fs1 ∪ fs2 ≠ ∅ → fs1 ##ₘ fs2 → + has_forked tp1 tp2 efork → + locale_step (tp1, σ1) (Some ζ) (tp2, σ2) → + model_state_interp tp1 δ1 -∗ + has_fuels_S ζ (fs1 ∪ fs2) ==∗ + model_state_interp tp2 δ2 ∗ + has_fuels ζ fs1 ∗ + has_fuels (locale_of tp1 efork) fs2. + Proof. + iIntros (Hδ2 Hfs Hdisj Hforked Hstep) "Hm Hf". + iDestruct "Hm" as (fm Hfmle Hfmdead Htp) "(Hm & Hfm)". + iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. + assert (locale_of tp1 efork ∉ dom fm) as Hnin. + { pose proof (not_elem_of_locale_of_from_list tp1 efork) as Hes%Htp. + apply not_elem_of_dom in Hes. set_solver. } + assert (ζ ≠ locale_of tp1 efork) as Hneq. + { rewrite not_elem_of_dom in Hnin. set_solver. } + iMod (has_fuels_decr with "Hfm Hf") as "[Hfm Hf]". + iMod (has_fuels_split _ _ (locale_of tp1 efork) with "Hfm Hf") + as "[Hfm [Hf1 Hf2]]"; [|done|]. + { set_solver. } + iModIntro. iFrame. rewrite Hδ2. iFrame. + iPureIntro. + split; [|split]. + - split; last first. + { simpl. + destruct Hfmle as [Hfmle Hdom]. + pose proof Hfmle as Hfmle'. + rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. + pose proof Hagree as Hagree'. + apply Hfmle in Hagree' as (fs'&HSome&Hfs'). + rewrite -(insert_id (ls_map δ1) ζ fs'); [|done]. + rewrite !alter_insert. + set_solver. } + simpl. + destruct Hfmle as [Hfmle Hdom]. + pose proof Hfmle as Hfmle'. + rewrite /fuel_map_le /fuel_map_le_inner map_included_spec in Hfmle. + pose proof Hagree as Hagree'. + apply Hfmle in Hagree' as (fs'&HSome&Hfs'). + rewrite -(insert_id (ls_map δ1) ζ fs'); [|done]. + rewrite !alter_insert. + rewrite insert_insert. + + apply map_included_map_agree_R in Hfs' + as (fs12'&fsf'&->&Hdisj'&Hfs'). + pose proof Hfs' as Hfs''. + apply map_agree_R_fmap_inv in Hfs'' as [fs1'' ->]; last first. + { intros ?[]?; [lia|by eauto]. } + apply map_agree_R_fmap in Hfs'; last first. + { intros. lia. } + apply map_agree_R_union_inv in Hfs' + as (fs1'&fs2'&->&Hfs1'&Hfs2'); [|done]. + + apply map_included_insert. + { rewrite lookup_total_alt. + rewrite lookup_insert. + rewrite map_filter_fmap. + rewrite map_filter_filter. + rewrite map_fmap_union. + rewrite map_filter_union; last first. + { apply map_disjoint_dom. apply map_disjoint_dom in Hdisj'. + set_solver. } + rewrite map_filter_union; last first. + { apply map_disjoint_dom. apply map_disjoint_dom in Hdisj. + apply map_agree_R_dom in Hfs1'. + apply map_agree_R_dom in Hfs2'. + set_solver. } + rewrite !map_fmap_union. + eapply map_included_subseteq_r. + { apply map_union_subseteq_l. } + eapply map_included_subseteq_r. + { apply map_union_subseteq_r. + apply map_disjoint_dom. + rewrite !map_filter_fmap. rewrite !dom_fmap_L. + apply map_disjoint_dom in Hdisj. + apply map_agree_R_dom in Hfs1'. + apply map_agree_R_dom in Hfs2'. + eapply disjoint_subseteq_l; [apply dom_filter_subseteq|]. + eapply disjoint_subseteq_r; [apply dom_filter_subseteq|]. + set_solver. } + rewrite map_filter_id; last first. + { simpl. + intros. apply elem_of_dom_2 in H0. + apply map_agree_R_dom in Hfs1'. + apply map_agree_R_dom in Hfs2'. + split; [set_solver|]. + set_solver. } + rewrite -map_fmap_compose. + rewrite decr_succ_compose_id. rewrite map_fmap_id. + by apply map_agree_R_map_included. } + + apply map_included_insert; [|done]. + rewrite map_filter_fmap. + rewrite map_filter_filter. + + rewrite !map_fmap_union. + rewrite map_filter_union; last first. + { apply map_disjoint_dom. apply map_disjoint_dom in Hdisj'. + set_solver. } + rewrite map_filter_union; last first. + { apply map_disjoint_dom. apply map_disjoint_dom in Hdisj. + apply map_agree_R_dom in Hfs1'. + apply map_agree_R_dom in Hfs2'. + set_solver. } + rewrite !map_fmap_union. + eapply map_included_subseteq_r. + { apply map_union_subseteq_l. } + eapply map_included_subseteq_r. + { apply map_union_subseteq_l. } + + rewrite map_filter_id; last first. + { simpl. + intros. apply elem_of_dom_2 in H0. + apply map_agree_R_dom in Hfs1'. + apply map_agree_R_dom in Hfs2'. + rewrite dom_fmap in H0. + apply map_disjoint_dom in Hdisj. + split; [set_solver|]. + set_solver. } + rewrite -map_fmap_compose. + rewrite decr_succ_compose_id. rewrite map_fmap_id. + by apply map_agree_R_map_included. + - intros ρ' Hin. + apply Hfmdead in Hin as (ζ'&ρs&HSome&Hρ). + destruct (decide (ζ = ζ')) as [<-|Hneq']. + + rewrite Hagree in HSome. + simplify_eq. + rewrite dom_fmap_L in Hρ. + rewrite dom_union_L in Hρ. + apply elem_of_union in Hρ. + destruct Hρ as [Hρ|Hρ]. + * eexists ζ, _. rewrite insert_insert. + rewrite insert_commute; [|done]. + rewrite lookup_insert. done. + * eexists (locale_of tp1 efork), _. rewrite insert_insert. + rewrite lookup_insert. done. + + assert (ζ' ≠ locale_of tp1 efork) as Hneq''. + { intros ->. apply not_elem_of_dom in Hnin. set_solver. } + eexists ζ', _. + rewrite lookup_insert_ne; [|done]. + rewrite insert_insert. + rewrite lookup_insert_ne; [|done]. + split; [done|]. by set_solver. + - rewrite /fuel_map_preserve_threadpool. + intros ζ' Hζ'. + apply locales_of_list_step_incl in Hstep. + assert (ζ' ∉ locales_of_list tp1) as Hζ'' by set_solver. + apply Htp in Hζ''. + rewrite insert_insert. + assert (ζ ≠ ζ') as Hneq'. + { set_solver. } + assert (locale_of tp1 efork ≠ ζ') as Hneq''. + { assert (locale_of tp1 efork ∈ locales_of_list tp2). + { destruct Hforked as [tp2' [-> Hequiv]]. + by apply elem_of_locale_of_from_list. } + set_solver. } + rewrite lookup_insert_ne; [|done]. + rewrite lookup_insert_ne; [|done]. + done. + Qed. + + Definition model_can_fork_step (δ1 : LM) (ζ ζf : locale Λ) (δ2 : LM) : Prop := + ∃ fs fs1 fs2, + δ1.(ls_under) = δ2.(ls_under) ∧ + δ1.(ls_map) !! ζ = Some fs ∧ fs ≠ ∅ ∧ + δ2.(ls_map) = <[ζ := fs1]>(<[ζf := fs2]> δ1.(ls_map)) ∧ + map_included (fun _ => (<)) fs1 fs ∧ + map_included (fun _ => (<)) fs2 fs ∧ + (dom fs ∖ (dom fs1 ∪ dom fs2) ∩ M.(live_roles) δ1 = ∅) ∧ + (dom fs1 ∩ dom fs2 = ∅) ∧ + ζf ∉ dom δ1.(ls_map). + + Lemma silent_step_suff_data_fork_weak fl `(δ: LiveState Λ M) + (fs fs1 fs2 : gmap _ nat) ζ ζf : + δ.(ls_map) !! ζ = Some fs → + fs ≠ ∅ → + map_included (fun _ => (<)) fs1 fs → + map_included (fun _ => (<)) fs2 fs → + (dom fs ∖ (dom fs1 ∪ dom fs2)) ∩ M.(live_roles) δ = ∅ → + (dom fs1 ∩ dom fs2 = ∅) → + ζf ∉ dom δ.(ls_map) → + ∃ δ', δ'.(ls_data) = + {| ls_under := δ; + ls_map := <[ζ := fs1]>(<[ζf := fs2]> δ.(ls_map)) |} ∧ + ls_trans fl δ (Silent_step ζ) δ'. + Proof. + intros. + apply (silent_step_suff_data fl δ fs fs1 fs2 ζ (Some ζf)); try done. + - rewrite map_included_spec in H2. done. + - rewrite map_included_spec in H3. done. + - set_solver. + Qed. + + (* TODO: Change original lemma to not existentially quantify new state *) + Lemma silent_step_suff_data_fork_weak_alt fl (δ δ': LiveState Λ M) + (fs fs1 fs2 : gmap _ nat) ζ ζf : + δ.(ls_under) = δ'.(ls_under) → + δ.(ls_map) !! ζ = Some fs → + δ'.(ls_map) = <[ζ := fs1]>(<[ζf := fs2]> δ.(ls_map)) → + fs ≠ ∅ → + map_included (fun _ => (<)) fs1 fs → + map_included (fun _ => (<)) fs2 fs → + (dom fs ∖ (dom fs1 ∪ dom fs2)) ∩ M.(live_roles) δ = ∅ → + (dom fs1 ∩ dom fs2 = ∅) → + ζf ∉ dom δ.(ls_map) → + ls_trans fl δ (Silent_step ζ) δ'. + Proof. + rewrite !map_included_spec. + intros Hδ Hfs Hfs12 Hne Hle1 Hle2 Hlive Hdisj Hnin. + assert (∃ δ', δ'.(ls_data) = + {| ls_under := δ; + ls_map := <[ζ := fs1]> (<[ζf := fs2]>δ.(ls_map)) |} ∧ + ls_trans fl δ (Silent_step ζ) δ') as (δ''&Heq&Htrans). + { apply (silent_step_suff_data fl δ fs fs1 fs2 ζ (Some ζf)); + try set_solver. } + rewrite Heq Hδ -Hfs12 in Htrans. by destruct δ', ls_data. + Qed. + + Lemma model_can_fork_step_trans fl ζ ζf (δ δ' : LiveState Λ M) : + model_can_fork_step δ ζ ζf δ' → ls_trans fl δ (Silent_step ζ) δ'. + Proof. + destruct 1 as (?&?&?&?&?&?&?&?&?&?&?&?). + by eapply silent_step_suff_data_fork_weak_alt. + Qed. + + Lemma model_state_interp_can_fork_step es (δ1 δ2 : LM) ζ + (fs1 fs2 : gmap (fmrole M) nat) e : + (ls_data δ2) = model_update_fork ζ (locale_of es e) (dom fs1 ∪ dom fs2) (dom fs2) δ1 → + (fs1 ∪ fs2) ≠ ∅ → fs1 ##ₘ fs2 → + model_state_interp es δ1 -∗ has_fuels_S ζ (fs1 ∪ fs2) -∗ + ⌜model_can_fork_step δ1 ζ (locale_of es e) δ2⌝. + Proof. + iIntros (Hδ2 Hne Hdisj) "Hm Hf". + iDestruct "Hm" as (fm [Hfmle Hdom] Hfmdead Htp) "(Hm & Hfm)". + iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. + pose proof Hagree as Hagree'. + rewrite /fuel_map_le_inner map_included_spec in Hfmle. + apply Hfmle in Hagree as (fs'&HSome&Hle). + iPureIntro. + apply map_included_map_agree_R in Hle as (fs12'&fsf'&->&Hdisj'&Hle). + pose proof Hle as Hle'. + apply map_agree_R_fmap_inv in Hle' as (fs12''&->); last first. + { intros. destruct v2; [lia|by eauto]. } + apply map_agree_R_fmap in Hle; last first. + { intros. lia. } + apply map_agree_R_union_inv in Hle as (fs1'&fs2'&->&Hle1&Hle2); + [|done]. + eexists _, fs1', fs2'. + repeat split. + - rewrite Hδ2. done. + - done. + - apply map_agree_R_dom in Hle1. + apply map_agree_R_dom in Hle2. + intros Heq. apply Hne. + apply dom_empty_iff_L in Heq. + apply dom_empty_iff_L. + set_solver. + - rewrite Hδ2. simpl. + rewrite insert_commute; last first. + { assert (locale_of es e ∉ locales_of_list es) as Hes%Htp. + apply not_elem_of_locale_of_from_list. + set_solver. } + f_equiv. + { rewrite lookup_total_alt. simpl. + rewrite !lookup_alter. rewrite HSome. + simpl. + rewrite map_filter_fmap. simpl. + rewrite map_filter_filter. simpl. + rewrite !map_fmap_union. + apply map_agree_R_dom in Hle1. + apply map_agree_R_dom in Hle2. + apply map_disjoint_dom in Hdisj. + apply map_disjoint_dom in Hdisj'. + rewrite map_filter_union; [|apply map_disjoint_dom; set_solver]. + rewrite map_filter_union; [|apply map_disjoint_dom; set_solver]. + assert (filter + (λ '(i, _), + i ∈ dom fs2 ∧ (i ∈ live_roles M δ1 ∨ i ∈ dom fs1 ∪ dom fs2)) + (S <$> fs1') = ∅) as Hfs1'. + { apply map_filter_empty_iff. + intros ρ f Hρ [HP1 HP2]. + apply elem_of_dom_2 in Hρ. + rewrite dom_fmap_L in Hρ. set_solver. } + assert (filter + (λ '(i, _), + i ∈ dom fs2 ∧ (i ∈ live_roles M δ1 ∨ i ∈ dom fs1 ∪ dom fs2)) + fsf' = ∅) as Hfsf'. + { apply map_filter_empty_iff. + intros ρ f Hρ [HP1 HP2]. + apply elem_of_dom_2 in Hρ. set_solver. } + rewrite Hfs1' Hfsf'. + rewrite left_id right_id. + rewrite map_filter_id; last first. + { intros. split. + - apply elem_of_dom_2 in H0. set_solver. + - right. + apply elem_of_dom_2 in H0. set_solver. } + rewrite -map_fmap_compose. + rewrite decr_succ_compose_id. + rewrite map_fmap_id. + done. } + rewrite -!alter_compose. + erewrite alter_insert_alt; [|done]. + f_equiv. + simpl. + rewrite map_filter_fmap. simpl. + rewrite map_filter_filter. simpl. + apply map_agree_R_dom in Hle1. + apply map_agree_R_dom in Hle2. + apply map_disjoint_dom in Hdisj. + apply map_disjoint_dom in Hdisj'. + rewrite !map_fmap_union. + rewrite map_filter_union; [|apply map_disjoint_dom; set_solver]. + rewrite map_filter_union; [|apply map_disjoint_dom; set_solver]. + assert (filter + (λ '(i, _), + (i ∉ dom fs2) ∧ (i ∈ live_roles M δ1 ∨ i ∈ dom fs1 ∪ dom fs2)) + (S <$> fs2') = ∅) as Hfs2'. + { apply map_filter_empty_iff. + intros ρ f Hρ [HP1 HP2]. + apply elem_of_dom_2 in Hρ. + rewrite dom_fmap_L in Hρ. set_solver. } + assert (filter + (λ '(i, _), + (i ∉ dom fs2) ∧ (i ∈ live_roles M δ1 ∨ i ∈ dom fs1 ∪ dom fs2)) + fsf' = ∅) as Hfsf'. + { apply map_filter_empty_iff. + intros ρ f Hρ [HP1 HP2]. + apply elem_of_dom_2 in Hρ. + rewrite Hle2 in HP1. + clear HP1. + assert (ρ ∈ (dom fs1 ∪ dom fs2)). + { destruct HP2 as [HP2|?]; [|done]. + rewrite -dom_union_L. + rewrite -(dom_fmap_L S). + eapply fuel_map_le_live_roles; [| | |apply Hagree'|..]. + - intros ????. by apply δ1.(ls_map_disj). + (* TODO: Fix this by unifying defs *) + - rewrite /fuel_map_le_inner map_included_spec. + eapply Hfmle. + - done. + - done. + - done. + - set_solver. } + set_solver. } + rewrite Hfs2' Hfsf'. + rewrite right_id right_id. + rewrite map_filter_id; last first. + { intros. split. + - apply elem_of_dom_2 in H0. set_solver. + - right. + apply elem_of_dom_2 in H0. set_solver. } + rewrite -map_fmap_compose. + rewrite decr_succ_compose_id. + rewrite map_fmap_id. + done. + - eapply (map_included_subseteq_r _ _ (S <$> fs1')). + { rewrite map_fmap_union. + etransitivity; apply map_union_subseteq_l. } + apply map_included_spec. + intros k v1 Hv1. exists (S v1). split; [|lia]. + by rewrite lookup_fmap Hv1. + - eapply (map_included_subseteq_r _ _ (S <$> fs2')). + { rewrite map_fmap_union. + rewrite (map_union_comm (S <$> fs1') (S <$> fs2')). + - etransitivity; apply map_union_subseteq_l. + - apply map_disjoint_dom. rewrite !dom_fmap_L. + apply map_disjoint_dom in Hdisj. + apply map_agree_R_dom in Hle1. + apply map_agree_R_dom in Hle2. + set_solver. } + apply map_included_spec. + intros k v1 Hv1. exists (S v1). split; [|lia]. + by rewrite lookup_fmap Hv1. + - rewrite -dom_empty_iff_L in Hne. + apply map_agree_R_dom in Hle1. + apply map_agree_R_dom in Hle2. + apply disjoint_intersection_L. + apply map_disjoint_dom in Hdisj. + apply map_disjoint_dom in Hdisj'. + rewrite dom_union_L. + rewrite dom_fmap_L. + rewrite -dom_union_L. + replace (dom (fs1' ∪ fs2' ∪ fsf') ∖ (dom fs1' ∪ dom fs2')) + with (dom fsf') by set_solver. + intros ρ Hin1 Hin2. + assert (ρ ∈ (dom fs1 ∪ dom fs2)). + { rewrite -dom_union_L. + rewrite -(dom_fmap_L S). + eapply fuel_map_le_live_roles; [| | |apply Hagree'|..]. + - intros ????. by apply δ1.(ls_map_disj). + - rewrite /fuel_map_le_inner map_included_spec. + eapply Hfmle. + - done. + - done. + - done. + - set_solver. } + set_solver. + - apply map_agree_R_dom in Hle1. + apply map_agree_R_dom in Hle2. + apply disjoint_intersection_L. + apply map_disjoint_dom in Hdisj. + set_solver. + - pose proof (not_elem_of_locale_of_from_list es e) + as Hes%Htp. + apply not_elem_of_dom in Hes. set_solver. + Qed. + + Lemma model_update_locale_spec_fork extr + (auxtr : auxiliary_trace LM) ζ ζf c2 ρs1 ρs2 δ2 : + δ2.(ls_data) = model_update_fork ζ ζf ρs1 ρs2 (trace_last auxtr) → + model_can_fork_step (trace_last auxtr) ζ ζf δ2 → + tids_smaller c2.1 δ2 → + valid_state_evolution_fairness + (extr :tr[Some ζ]: c2) + (auxtr :tr[Silent_step ζ]: δ2). + Proof. + intros Hstep Htids. destruct c2. + split; [done|]. split; [by eapply model_can_fork_step_trans|done]. + Qed. + + Lemma model_state_interp_has_fuels_agree es δ ζ (fs : gmap (fmrole M) nat) : + model_state_interp es δ -∗ has_fuels ζ fs -∗ + ⌜∃ fs', δ.(ls_map) !! ζ = Some fs' ∧ map_included (fun _ => (≤)) fs fs'⌝. + Proof. + iIntros "Hm Hf". + iDestruct "Hm" as (fm [Hfmle _] Hfmdead Htp) "(Hm & Hfm)". + iDestruct (has_fuels_agree with "Hfm Hf") as %Hagree. + rewrite /fuel_map_le_inner map_included_spec in Hfmle. + apply Hfmle in Hagree as (fs'&HSome&Hfs'). + iPureIntro. by eexists _. + Qed. + + Lemma update_fork_step fs1 fs2 tp1 tp2 (extr : execution_trace Λ) + (auxtr: auxiliary_trace LM) ζ efork σ1 σ2 : + fs1 ∪ fs2 ≠ ∅ → fs1 ##ₘ fs2 → + trace_last extr = (tp1, σ1) → + locale_step (tp1, σ1) (Some ζ) (tp2, σ2) → + has_forked tp1 tp2 efork → + has_fuels_S ζ (fs1 ∪ fs2) -∗ + model_state_interp tp1 (trace_last auxtr) ==∗ + ∃ δ2, + ⌜valid_state_evolution_fairness + (extr :tr[Some ζ]: (tp2, σ2)) (auxtr :tr[Silent_step ζ]: δ2)⌝ ∗ + has_fuels ζ fs1 ∗ has_fuels (locale_of tp1 efork) fs2 ∗ + model_state_interp tp2 δ2. + Proof. + iIntros (Hdom Hdisj Hlast Hstep Hforked) "Hfuel Hm". + iDestruct (model_state_interp_has_fuels_agree with "Hm Hfuel") + as %(fs'&HSome&Hfs'). + iAssert (⌜(locale_of tp1 efork) ∉ dom (ls_map (trace_last auxtr))⌝)%I as %Hnin. + { destruct Hforked as (?&?&?). + iDestruct "Hm" as (fm [_ Hdom'] _ Htp) "[Hm Hfm]". + rewrite -Hdom'. + iPureIntro. apply not_elem_of_dom. apply Htp. + apply locale_step_equiv in Hstep. simpl in *. + apply not_elem_of_locale_of_from_list. } + epose proof (model_update_fork_valid _ _ _ _ _) as [δ2 Hδ]; + [by apply elem_of_dom|done|]. + iDestruct (model_state_interp_can_fork_step with "Hm Hfuel") as %Hcan_step; + [done..|]. + iMod (model_state_interp_fork_update with "Hm Hfuel") as "(Hm&Hf1&Hf2)"; + [done..|]. + iDestruct (model_state_interp_tids_smaller with "Hm") as %Htids. + iModIntro. + iExists δ2. + iFrame "Hm Hf1 Hf2". + iPureIntro. + by eapply model_update_locale_spec_fork. + 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. + +End model_state_lemmas. diff --git a/fairness/inftraces.v b/fairness/inftraces.v index 3ec5613..8246c9c 100644 --- a/fairness/inftraces.v +++ b/fairness/inftraces.v @@ -488,341 +488,6 @@ Proof. Qed. -Section dec_unless. - Context {St S' L L': Type}. - Context (Us: St -> S'). - Context (Usls: St -> L -> St -> option L'). - - Definition dec_unless Ψ (tr: trace St L) := - ∀ n, match after n tr with - | Some ⟨ _ ⟩ | None => True - | Some (s -[ℓ]-> tr') => - (∃ ℓ', Usls s ℓ (trfirst tr') = 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 (Usls: St -> L -> St -> 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 ℓ: - (Usls s ℓ (trfirst btr) = None) -> - 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' -> - Usls s ℓ (trfirst btr) = 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_trfirst btr str - (CORR: upto_stutter btr str): - trfirst str = Us (trfirst btr). - Proof. - punfold CORR. by inversion CORR. - Qed. - - 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. - - Definition prefix_states_upto (btr: trace St L) (str: trace S' L') n' n := - (forall i b, i <= n' -> - pred_at btr i (fun b' _ => b' = b) -> - exists j, pred_at str j (fun s' _ => s' = Us b) /\ j <= n). - - (* TODO: try to express the prefix property with 'upto_stutter' and 'subtrace' *) - Lemma upto_stutter_after_strong {btr str} n {str'}: - upto_stutter btr str -> - after n str = Some str' -> - ∃ n' btr', after n' btr = Some btr' ∧ upto_stutter btr' str' /\ - prefix_states_upto btr str n' n. - Proof. - have Hw: ∀ (P: nat -> Prop), (∃ n, P (S n)) -> (∃ n, P n). - { intros P [x ?]. by exists (S x). } - unfold prefix_states_upto. - revert btr str str'. induction n as [|n IH]; intros btr str str' Hupto Hafter. - { injection Hafter => <-. clear Hafter. exists 0, btr. - do 2 (split; [done| ]). - intros. assert (i = 0) as -> by lia. - exists 0. split; [| done]. apply pred_at_state_trfirst. - apply pred_at_state_trfirst in H0. subst. - eapply upto_stutter_trfirst; eauto. } - 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. - specialize (IHH _ Hafter) as (n' & btr' & AFTER & UPTO & PRE). - exists n', btr'. do 2 (split; eauto). intros. - destruct i. - { apply pred_at_state_trfirst in H0. simpl in H0. subst b. - exists 0. split; [| lia]. apply pred_at_state_trfirst. - congruence. } - apply le_S_n in H. apply pred_at_S in H0. - specialize (PRE _ _ H H0). eauto. - - intros str' Hafter. simpl in Hafter. - apply Hw. simpl. - specialize (IH btr str str' ltac:(by destruct Hind) ltac:(done)). - destruct IH as (n' & btr' & AFTER & UPTO & PRE). - exists n', btr'. do 2 (split; eauto). intros. - destruct i. - { apply pred_at_state_trfirst in H2. simpl in H2. subst b. - exists 0. split; [| lia]. apply pred_at_state_trfirst. - simpl. congruence. } - apply le_S_n in H1. apply pred_at_S in H2. - specialize (PRE _ _ H1 H2) as (j & Pj & ?). - exists (S j). split; [| lia]. by apply pred_at_S. - Qed. - - Local Ltac gd t := generalize dependent t. - - Lemma upto_stutter_after' - {btr : trace St L} {str : trace S' L'} (n : nat) {btr' : trace St L}: - upto_stutter btr str - → after n btr = Some btr' - → ∃ (n' : nat) (str' : trace S' L'), - after n' str = Some str' ∧ upto_stutter btr' str'. - Proof. - have Hw: ∀ (P: nat -> Prop), (∃ n, P (S n)) -> (∃ n, P n). - { intros P [x ?]. by exists (S x). } - - intros. - gd btr. gd str. gd btr'. induction n as [|n IH]; intros btr' str btr Hupto Hafter. - { injection Hafter => <-. clear Hafter. exists 0, str. done. } - punfold Hupto. - inversion Hupto; subst. - - done. - - simpl in Hafter. rename btr0 into btr. - specialize (IH btr' str btr). - eapply IH; eauto. - by pfold. - - simpl in Hafter. rename btr0 into btr. rename str0 into str. - specialize (IH btr' str btr). - assert (upto_stutter btr str) as UPTO'. - { inversion H1; eauto. done. } - specialize (IH UPTO' Hafter) as (?&?&?&?). - eauto. - 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. - - Lemma upto_stutter_terminating_trace: - ∀ (tr1 : trace St L) (tr2 : trace S' L'), - upto_stutter tr1 tr2 → terminating_trace tr1 → terminating_trace tr2. - Proof. - intros * UPTO TERM1. - red in TERM1. destruct TERM1 as [len'1 AFTER1]. - pattern len'1 in AFTER1. - apply min_prop_dec in AFTER1 as [len1 [LEN1 MIN1]]; [| solve_decision]. clear len'1. - destruct len1. - { simpl in LEN1. done. } - destruct (after len1 tr1) eqn:A1. - 2: { specialize (MIN1 _ A1). lia. } - rewrite -Nat.add_1_r after_sum' A1 in LEN1. - destruct t; [| done]. - eapply upto_stutter_after' in A1; eauto. - destruct A1 as (?&?&?&UPTO'). - punfold UPTO'. inversion UPTO'. subst. - exists (S x). - rewrite -Nat.add_1_r after_sum' H. done. - Qed. - - Program Fixpoint destutter_once_step N Ψ (btr: trace St L): - Ψ (trfirst btr) < N → - dec_unless Us Usls Ψ btr → - S' + (S' * L' * { btr' : trace St L | dec_unless Us Usls Ψ btr'}) := - match N as n return - Ψ (trfirst btr) < n → - dec_unless Us Usls Ψ btr → - S' + (S' * L' * { btr' : trace St L | dec_unless Us Usls Ψ 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 Usls Ψ btr'}) with - | tr_singl s => λ _, inl (Us s) - | tr_cons s l btr' => - λ Hbtreq, - match Usls s l (trfirst btr') as z return Usls s l (trfirst btr') = z → S' + (S' * L' * { btr' : trace St L | dec_unless Us Usls Ψ 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 Usls Ψ 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 Usls Ψ 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 (Usls s ℓ (trfirst btr')) 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 Usls Ψ 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 (Usls s ℓ (trfirst btr')) 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 Usls Ψ btr): - upto_stutter btr (destutter Ψ btr Hdec). - Proof. eapply destutter_spec_ind. Qed. - - Lemma can_destutter Ψ (btr: trace St L) (Hdec: dec_unless Us Usls Ψ 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. diff --git a/fairness/trace_lookup.v b/fairness/trace_lookup.v index 7951abd..0d90161 100644 --- a/fairness/trace_lookup.v +++ b/fairness/trace_lookup.v @@ -587,75 +587,6 @@ Section TracesMatch. End TracesMatch. -Section UptoStutter. - Context {St S' L L' : Type}. - Context {Us : St → S'}. - Context {Usls: St -> L -> St -> option L'}. - - Lemma upto_stutter_trace_label_lookup {btr : trace St L} {str : trace S' L'} - (n : nat) st ℓ st' l: - upto_stutter Us Usls btr str → - btr !! n = Some (st, Some (ℓ, st')) -> - Usls st ℓ st' = Some l -> - ∃ (n' : nat), str L!! n' = Some l. - Proof. - intros UPTO NTH MATCH. - pose proof (trace_has_len btr) as [? LEN]. - apply trace_lookup_after_strong in NTH as (atr' & AFTER & A0). - ogeneralize * (upto_stutter_after' _ _ n UPTO); eauto. - intros (n' & str' & AFTER' & UPTOn). - exists n'. - rewrite -(Nat.add_0_r n'). erewrite <- label_lookup_after; eauto. - punfold UPTOn; [| by apply upto_stutter_mono]. - inversion UPTOn; subst; try congruence. - rewrite label_lookup_0. congruence. - Qed. - - Lemma upto_stutter_state_lookup {btr : trace St L} {str : trace S' L'} n' st': - upto_stutter Us Usls btr str - → str S!! n' = Some st' -> - ∃ n st, btr S!! n = Some st /\ Us st = st'. - Proof. - intros UPTO NTH. - pose proof (trace_has_len str) as [? LEN]. - pose proof (proj1 (state_lookup_dom _ _ LEN n') (mk_is_Some _ _ NTH)) as BOUND. - pose proof (proj2 (LEN _) BOUND) as [str_n AFTER]. - ogeneralize * (upto_stutter_after _ _ n' UPTO); eauto. - intros (n & btr' & AFTER' & UPTOn). - exists n. - rewrite -(Nat.add_0_r n). erewrite <- state_lookup_after; eauto. - rewrite state_lookup_0. f_equal. - eexists. split; [reflexivity| ]. - etransitivity. - { symmetry. eapply upto_stutter_trfirst; eauto. } - apply Some_inj. rewrite -state_lookup_0. - erewrite state_lookup_after; eauto. by rewrite Nat.add_0_r. - Qed. - - Lemma upto_stutter_state_lookup' {btr : trace St L} {str : trace S' L'} (n : nat) bst: - upto_stutter Us Usls btr str - → btr S!! n = Some bst -> - ∃ (n' : nat), - str S!! n' = Some (Us bst). - Proof. - intros UPTO NTH. - pose proof (trace_has_len btr) as [? LEN]. - pose proof (proj1 (state_lookup_dom _ _ LEN n) (mk_is_Some _ _ NTH)) as BOUND. - pose proof (proj2 (LEN _) BOUND) as [btr_n AFTER]. - ogeneralize * (upto_stutter_after' _ _ n UPTO); eauto. - intros (n' & str' & AFTER' & UPTOn). - exists n'. - rewrite -(Nat.add_0_r n'). erewrite <- state_lookup_after; eauto. - rewrite state_lookup_0. f_equal. - erewrite upto_stutter_trfirst; [..| apply UPTOn]; eauto. - f_equal. apply Some_inj. - rewrite -state_lookup_0. - erewrite state_lookup_after; eauto. by rewrite Nat.add_0_r. - Qed. - -End UptoStutter. - - Section ValidTracesProperties. Context {St L: Type}. Context (trans: St -> L -> St -> Prop). From 82cb6a2af7c9c0c136ad689555936ffa4402afdd Mon Sep 17 00:00:00 2001 From: fresheed Date: Sat, 6 Sep 2025 16:08:30 +0200 Subject: [PATCH 10/17] extracted general heaplang stuff, restored fairis adequacy as is --- fairis/adequacy.v | 401 ++++++++++++++++++++++++++++++++ fairis/heap_lang_lm.v | 37 +++ heap_lang/heap_lang_defs.v | 93 +++----- heap_lang/simulation_adequacy.v | 287 ----------------------- heap_lang/sswp_logic.v | 24 +- 5 files changed, 482 insertions(+), 360 deletions(-) create mode 100644 fairis/adequacy.v create mode 100644 fairis/heap_lang_lm.v delete mode 100644 heap_lang/simulation_adequacy.v diff --git a/fairis/adequacy.v b/fairis/adequacy.v new file mode 100644 index 0000000..ebae0d3 --- /dev/null +++ b/fairis/adequacy.v @@ -0,0 +1,401 @@ +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 Import weakestpre adequacy. +From fairness Require Export fairness. +From fairis Require Import fair_termination fairness_finiteness fuel fuel_termination map_included_utils resources heap_lang_lm destuttering. +From trillium.program_logic Require Import ectx_lifting. +From heap_lang Require Import locales_helpers_hl. + + +Set Default Proof Using "Type". + +Section adequacy. + +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. + +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, pointsto 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 [λ _, 0%nat ↦M ∅] (λ extr atr, ξ extr (map_underlying_trace atr)) ([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_fuel_mapping_init s1) as (γmap) "[Hmapa Hmapf]". + iMod (model_free_roles_init s1 (FR ∖ live_roles _ s1)) as (γfr) "[HFR Hfr]". + set (hG := {| heap1_gen_heapGS := genheap |}). + set (distG := + {| + heap_fairnessGS := {| + fairness_model_name := γmod; + fairness_model_fuel_mapping_name := γmap; + 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. } + iSpecialize ("Hwp" with "Hσ Hmodf Hfr [Hmapf]"). + { rewrite /init_fuel_map. + rewrite /has_fuels /frag_fuel_mapping_is. + rewrite fmap_insert fmap_empty. iFrame. } + iDestruct "Hwp" as ">[Hwp H]". + iModIntro. iFrame "Hwp". + iSplitL "Hgen Hmoda Hmapa HFR". + { unfold state_interp. simpl. iFrame. + iExists (ls_map (initial_ls s1 0%nat)). + iSplit; [done|]. + iSplit. + { iPureIntro. simpl. rewrite /fuel_map_preserve_dead. + intros ρ Hline. eexists 0%nat, _. rewrite lookup_insert. split; [done|]. + by rewrite dom_gset_to_gmap. } + iSplit. + { iPureIntro. intros tid Hlocs. rewrite lookup_singleton_ne //. + compute in Hlocs. set_solver. } + iFrame. } + 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 "_ !>". + iSplit; last done. iClear "H1". + iSplit; first done. + destruct (to_val e1) as [v1|] eqn:Heq. + + iSplit. + { iPureIntro. intros ρ tid Hinit. + apply ls_mapping_data_inv in Hinit. + destruct Hinit as [fs [HSome Hfs]]. + assert (tid = 0%nat). + { simpl in *. rewrite lookup_insert_Some in HSome. by set_solver. } + rewrite /from_locale //. simpl in *. set_solver. } + iIntros (tid e Hsome Hnoval ρ). destruct tid; last done. + simpl in Hsome. compute in Hsome. simplify_eq. + iAssert (0%nat ↦M ∅)%I with "[Hposts]" as "Hem". + { rewrite /= Heq /fmap /=. by iDestruct "Hposts" as "[??]". } + iDestruct "Hsi" as "(_&_&Hsi)". + iDestruct "Hsi" as (fm Hfmle Hfmdead Hmapinv) "(Hm & Hfm)". + iDestruct (has_fuels_agree with "Hfm Hem") as "%Hagree". + iPureIntro. + intros HSome. apply ls_mapping_data_inv in HSome. + destruct HSome as [fs [HSome Hfs]]. + destruct Hfmle as [Hfmle1 Hfmle2]. + rewrite /fuel_map_le_inner map_included_spec in Hfmle1. + pose proof Hagree as HSome'. + apply Hfmle1 in Hagree as (fs''&HSome''&Hfs''). simpl in *. clear Hfmle1. + simplify_eq. rewrite lookup_insert in HSome''. simplify_eq. + rewrite dom_gset_to_gmap in Hfs. + apply Hfmdead in Hfs as (tid''&fs'''&HSome'''&Hfs'''). + rewrite dom_singleton_L in Hfmle2. + assert (tid'' = 0%nat). + { apply elem_of_dom_2 in HSome'''. rewrite Hfmle2 in HSome'''. set_solver. } + simplify_eq. by set_solver. + + iSplit; iPureIntro. + { intros ρ tid Hinit. + apply ls_mapping_data_inv in Hinit. + destruct Hinit as [fs [HSome Hfs]]. + assert (tid = 0%nat). + { simpl in *. rewrite lookup_insert_Some in HSome. by set_solver. } + rewrite /from_locale //. simpl in *. set_solver. } + 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. + 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. + 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 (fm Hfmle Hfmdead Hmapinv) "(Hm & Hfm)". + iSplit; [|done]. + iSplit; [done|]. + iSplit. + + iPureIntro. intros ρ tid' Hsome. simpl. unfold tids_smaller in Htids. + eapply Htids. + apply ls_mapping_data_inv in Hsome. + destruct Hsome as [fs [HSome Hfs]]. + simpl in *. apply elem_of_dom. set_solver. + + iIntros (tid' e' Hsome Hnoval ρ HSome). simpl. + iAssert (tid' ↦M ∅)%I with "[Hposts]" as "H". + { destruct (to_val e') as [?|] eqn:Heq; last done. + iApply posts_of_empty_mapping => //. + apply from_locale_lookup =>//. } + iDestruct (has_fuels_agree with "Hfm H") as "%Hlk". + iPureIntro. + intros Hlive. + apply ls_mapping_data_inv in HSome. + destruct HSome as [fs [HSome Hfs]]. + destruct Hfmle as [Hfmle1 Hfmle2]. + rewrite /fuel_map_le_inner map_included_spec in Hfmle1. + pose proof Hlk as HSome'. + apply Hfmle1 in Hlk as (fs'&HSomefs&Hfs'). simpl in *. + simplify_eq. + apply Hfmdead in Hlive as (tid''&fs''&HSome''&Hfs''). + assert (tid'' = tid'). + { apply Hfmle1 in HSome'' as (fs'''&HSome'''&Hfs'''). + pose proof (δ.(ls_map_disj)) as Hdisj. + destruct (decide (tid' = tid'')) as [->|Hneq]; [done|]. + specialize (Hdisj tid' tid'' fs fs''' Hneq HSome HSome'''). + apply map_disjoint_dom in Hdisj. + apply map_included_subseteq_inv in Hfs'''. + set_solver. } + simplify_eq. + by set_solver. +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. + { do 2 (apply FunExt; intros?). apply PropExt. + 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 (λ x, ls_under (ls_data x)) 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. diff --git a/fairis/heap_lang_lm.v b/fairis/heap_lang_lm.v new file mode 100644 index 0000000..27aced8 --- /dev/null +++ b/fairis/heap_lang_lm.v @@ -0,0 +1,37 @@ +From iris.base_logic Require Export gen_heap. +From iris.proofmode Require Import tactics. +From trillium.program_logic Require Export weakestpre. +(* From fairness Require Import fairness. *) +From fairis Require Import fuel resources. +From heap_lang Require Export lang tactics notation heap_lang_defs. + + +Class heapGpreS Σ `(LM: LiveModel heap_lang M) := HeapPreG { + heapGpreS_inv :: invGpreS Σ; + heapGpreS_gen_heap :: heap1GpreS Σ; + heapGpreS_fairness :: fairnessGpreS LM Σ; +}. + +Class heapGS Σ `(LM:LiveModel heap_lang M) := HeapG { + heap_inG :: heapGpreS Σ LM; + heap_invGS : invGS_gen HasNoLc Σ; + heap_gen_heapGS :: heap1GS Σ; + heap_fairnessGS :: fairnessGS LM Σ; +}. + +Definition heapΣ (M : FairModel) : gFunctors := + #[ invΣ; heap1Σ; 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 Σ := { + iris_invGS := heap_invGS; + 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 ∅)%I; +}. diff --git a/heap_lang/heap_lang_defs.v b/heap_lang/heap_lang_defs.v index f79c5a3..75d0d42 100644 --- a/heap_lang/heap_lang_defs.v +++ b/heap_lang/heap_lang_defs.v @@ -2,69 +2,44 @@ From iris.base_logic Require Export gen_heap. From iris.proofmode Require Import tactics. From trillium.program_logic Require Export weakestpre. From heap_lang Require Export lang. -From fairness Require Export execution_model. From heap_lang Require Import tactics notation. -(* TODO: the missing fact of em_GS etc. being typeclasses - hardens automatic resolution of their instances *) -Class heapGpreS Σ `(EM: ExecutionModel heap_lang M) := HeapPreG { - heapGpreS_inv :: invGpreS Σ; - heapGpreS_gen_heap :: gen_heapGpreS loc val Σ; - heapGpreS_em :: em_preGS Σ; +Class heap1GpreS Σ := Heap1PreG { + heap1GpreS_gen_heap :: gen_heapGpreS loc val Σ; }. -Class heapGS Σ `(EM: ExecutionModel heap_lang M) := HeapG { - heap_inG :: heapGpreS Σ EM; +Class heap1GS Σ := Heap1G { + heap1_inG :: heap1GpreS Σ; + heap1_gen_heapGS :: gen_heapGS loc val Σ; +}. - heap_invGS :: invGS_gen HasNoLc Σ; - heap_gen_heapGS :: gen_heapGS loc val Σ; +Definition heap1Σ : gFunctors := + #[ gen_heapΣ loc val ]. - heap_fairnessGS :: em_GS Σ; -}. -Definition heapΣ `(EM: ExecutionModel heap_lang M) : gFunctors := - #[ invΣ; gen_heapΣ loc val; em_Σ ]. - - -(* TODO: automatize *) -Global Instance subG_heapPreG {Σ} `{EM: ExecutionModel heap_lang M}: - subG (heapΣ EM) Σ → heapGpreS Σ EM. -Proof. - intros. - enough (em_preGS Σ); [solve_inG| ]. - apply em_Σ_subG. solve_inG. -Qed. - -#[global] Instance heapG_irisG `{EM: ExecutionModel heap_lang M} `{HGS: !heapGS Σ EM}: - irisG heap_lang M Σ := { - state_interp extr auxtr := - (⌜em_valid_state_evolution_fairness extr auxtr⌝ ∗ - gen_heap_interp (trace_last extr).2.(heap) ∗ - em_msi (trace_last extr) (trace_last auxtr) (em_GS0 := heap_fairnessGS))%I ; - fork_post tid := fun _ => em_thread_post tid (em_GS0 := heap_fairnessGS); -}. +Global Instance subG_heap1PreG {Σ}: subG heap1Σ Σ → heap1GpreS Σ. +Proof. solve_inG. Qed. + Section GeneralProperties. - Context `{EM: ExecutionModel heap_lang M}. - Context `{HGS: @heapGS Σ _ EM}. - Let eGS := heap_fairnessGS. + (* Context `{HGS: @heap1GS Σ}. *) + Context `{irisG heap_lang M Σ}. - Lemma posts_of_empty_mapping_multiple (es e: expr) v (tid : nat) (tp : list expr): + Lemma posts_of_empty_mapping_multiple + (es e: expr) v (tid : locale heap_lang) (tp : list expr): tp !! tid = Some e -> to_val e = Some v -> - (* cur_posts tp e1 (fun _ => em_thread_post 0%nat (em_GS0 := eGS)) -∗ *) - (let Φs := map (fun τ _ => @em_thread_post heap_lang M EM Σ (@heap_fairnessGS Σ M EM _) τ) (seq 0 (length tp)) in - posts_of tp Φs) -∗ - em_thread_post tid (em_GS0 := eGS). + (let Φs := map fork_post (seq 0 (length tp)) in posts_of tp Φs) -∗ + fork_post tid v. Proof. intros Hsome Hval. simpl. - rewrite (big_sepL_elem_of (λ x, x.2 x.1) _ (v, (fun _ => em_thread_post tid)) _) //. + rewrite (big_sepL_elem_of (λ x, x.2 x.1) _ (v, fork_post tid) _) //. { eauto. } apply elem_of_list_omap. - exists (e, (fun _ => em_thread_post tid (em_GS0 := eGS))); split; last first. + exists (e, (fun v => fork_post tid v)); split; last first. - simpl. apply fmap_Some. exists v. split; done. - destruct tp as [|e1' tp]; first set_solver. simpl. apply elem_of_cons. @@ -82,16 +57,15 @@ Section GeneralProperties. Lemma posts_of_empty_mapping (e1 e: expr) v (tid : nat) (tp : list expr): tp !! tid = Some e -> to_val e = Some v -> - cur_posts tp e1 (fun _ => em_thread_post 0%nat (em_GS0 := eGS)) -∗ - em_thread_post tid (em_GS0 := eGS). + cur_posts tp e1 (fun v => fork_post 0%nat v) -∗ + fork_post tid v. Proof. intros Hsome Hval. simpl. - rewrite /cur_posts. - rewrite (big_sepL_elem_of (λ x, x.2 x.1) _ (v, (fun _ => em_thread_post tid)) _) //. + rewrite (big_sepL_elem_of (λ x, x.2 x.1) _ (v, fork_post tid) _) //. { eauto. } apply elem_of_list_omap. - exists (e, (fun _ => em_thread_post tid (em_GS0 := eGS))); split; last first. + exists (e, (fun v => fork_post tid v)); split; last first. - simpl. apply fmap_Some. exists v. split; done. - destruct tp as [|e1' tp]; first set_solver. simpl. apply elem_of_cons. @@ -131,20 +105,20 @@ Ltac inv_head_step := inversion H; subst; clear H end. -Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _; simpl : core. +Global Hint Extern 0 (head_reducible _ _) => 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 Hint Extern 1 (head_step _ _ _ _ _) => econstructor : core. +Global Hint Extern 0 (head_step (CmpXchg _ _ _) _ _ _ _) => eapply CmpXchgS : core. +Global Hint Extern 0 (head_step (AllocN _ _) _ _ _ _) => apply alloc_fresh : core. +Global 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 := +Global Ltac solve_atomic := apply strongly_atomic_atomic, ectx_language_atomic; [inversion 1; naive_solver |apply ectxi_language_sub_redexes_are_values; intros [] **; naive_solver]. @@ -187,9 +161,9 @@ 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 := +Global Ltac solve_exec_safe := intros; subst; do 3 eexists; econstructor; eauto. +Global Ltac solve_exec_puredet := simpl; intros; by inv_head_step. +Global Ltac solve_pure_exec := subst; intros ?; apply nsteps_once, pure_head_step_pure_step; constructor; [solve_exec_safe | solve_exec_puredet]. @@ -274,8 +248,7 @@ Proof. solve_pure_exec. Qed. Section Heap. - Context `{EM: ExecutionModel heap_lang M}. - Context `{HGS: @heapGS Σ _ EM}. + Context `{HGS: @heap1GS Σ}. (** Heap *) (** The usable rules for [allocN] stated in terms of the [array] proposition diff --git a/heap_lang/simulation_adequacy.v b/heap_lang/simulation_adequacy.v deleted file mode 100644 index bfbe7ab..0000000 --- a/heap_lang/simulation_adequacy.v +++ /dev/null @@ -1,287 +0,0 @@ -From stdpp Require Import fin_maps. -From iris.proofmode Require Import tactics. -From trillium.program_logic Require Export weakestpre adequacy. -From fairness Require Export fairness traces_match trace_utils. -From heap_lang Require Export lang heap_lang_defs. - -Definition heap_lang_extrace : Type := extrace heap_lang. - - -Section adequacy. - - Definition wp_premise - `{EM: ExecutionModel heap_lang M} - (Σ: gFunctors) - (s: stuckness) (e1 : expr) σ1 (s1: mstate M) - (R: execution_trace heap_lang → auxiliary_trace M → Prop) - (p: em_init_param) - := - (∀ `{Hinv : @heapGS Σ M EM} , - ⊢ (([∗ map] l ↦ v ∈ heap σ1, pointsto l (DfracOwn 1) v) ∗ - em_init_resource s1 p (em_GS0 := heap_fairnessGS) - ={⊤}=∗ - WP e1 @ s; locale_of [] e1; ⊤ {{ _, em_thread_post 0%nat (em_GS0 := heap_fairnessGS)}} ∗ - rel_always_holds0 R s state_interp (fun _ => em_thread_post 0%nat (em_GS0 := heap_fairnessGS)) e1 σ1 s1)). - - Definition wp_premise_multiple - `{EM: ExecutionModel heap_lang M} - (Σ: gFunctors) - (s: stuckness) es σ1 (s1: mstate M) - (R: execution_trace heap_lang → auxiliary_trace M → Prop) - (p: em_init_param) - := - (∀ `{Hinv : @heapGS Σ M EM} , - ⊢ (([∗ map] l ↦ v ∈ heap σ1, pointsto l (DfracOwn 1) v) ∗ - em_init_resource s1 p (em_GS0 := heap_fairnessGS) - ={⊤}=∗ - let Φs := map (fun i _ => em_thread_post i%nat (em_GS0 := heap_fairnessGS)) (seq 0 (length es)) in - wptp s es Φs ∗ - rel_always_holds s Φs R (es, σ1) s1)). - - Lemma wp_premise_single `{EM: ExecutionModel heap_lang M} Σ - s e1 σ1 s1 R p: - wp_premise Σ s e1 σ1 s1 R p -> wp_premise_multiple Σ s [e1] σ1 s1 R p. - Proof using. - rewrite /wp_premise /wp_premise_multiple. - iIntros "%WP1 % [HEAP INIT]". - iMod (WP1 Hinv with "[$HEAP $INIT]") as "[WP1 RAH]". - iFrame. set_solver. - Qed. - - Theorem strong_simulation_adequacy_general_multiple - `{hPre: @heapGpreS Σ M EM} (s: stuckness) (es : list expr) σ1 (s1: M) - (R: execution_trace heap_lang → auxiliary_trace M → Prop) - (p: em_init_param) - : - length es ≥ 1 -> - rel_finitary R → - em_is_init_st (es, σ1) s1 -> - em_valid_state_evolution_fairness {tr[ (es, σ1) ]} {tr[ s1 ]} -> - (wp_premise_multiple Σ s es σ1 s1 R p) -> - continued_simulation R (trace_singleton (es, σ1)) (trace_singleton s1). - Proof. - intros LEN Hfin INIT VALID1 H. - apply (wp_strong_adequacy_multiple_with_trace_inv heap_lang M Σ s); try done. - - iIntros (?) "". - - iMod (gen_heap_init (heap σ1)) as (genheap)" [Hgen [Hσ _]]". - iMod (em_initialization _ s1 (es, σ1) p) as (fGS) "[LM_INIT MSI]"; [done| ]. - Unshelve. 2: by apply hPre. - - set (distG := {| heap_fairnessGS := (fGS: (em_GS Σ (ExecutionModel := EM))) |}). - iPoseProof (H distG) as "Hwp". clear H. - - iExists state_interp, (λ _ _, ⌜ True ⌝%I), _, (fun τ _ => em_thread_post τ). - iSplitR. - { unfold config_wp. iIntros "!>!>" (???????) "?". done. } - - iSpecialize ("Hwp" with "[Hσ LM_INIT]"); [by iFrame| ]. - iDestruct "Hwp" as ">[Hwp H]". - iModIntro. iFrame "Hwp Hgen MSI". - - (* TODO: make a lemma *) - iIntros (??????????) "SI POSTS". - rewrite /rel_always_holds. iDestruct ("H" with "[][][][][][][] SI POSTS") as "R". - all: try by done. - iSplit. - - iModIntro; iIntros "[$ ?]"; done. - - eauto. - Qed. - - Theorem strong_simulation_adequacy_general - `{hPre: @heapGpreS Σ M EM} (s: stuckness) (e1 : expr) σ1 (s1: M) - (R: execution_trace heap_lang → auxiliary_trace M → Prop) - (p: em_init_param) - : - rel_finitary R → - em_is_init_st ([e1], σ1) s1 -> - em_valid_state_evolution_fairness {tr[ ([e1], σ1) ]} {tr[ s1 ]} -> - (wp_premise Σ s e1 σ1 s1 R p) -> - continued_simulation R (trace_singleton ([e1], σ1)) (trace_singleton s1). - Proof. - intros. eapply strong_simulation_adequacy_general_multiple. - 1-4: by eauto. - apply wp_premise_single. eauto. - Qed. - - Theorem strong_simulation_adequacy_inftraces_multiple Σ - `{hPre: @heapGpreS Σ M EM} (s: stuckness) - (es : list expr) σ1 (s1: M) - (R: execution_trace heap_lang → auxiliary_trace M → Prop) - (p: em_init_param) - (iex : inf_execution_trace heap_lang) - (Hvex : valid_inf_exec (trace_singleton (es, σ1)) iex) - : - length es ≥ 1 -> - rel_finitary R → - em_is_init_st (es, σ1) s1 -> - (wp_premise_multiple Σ s es σ1 s1 R p) -> - exists iatr, - @valid_inf_system_trace _ M - (@continued_simulation - heap_lang - M - R) - (trace_singleton (es, σ1)) - (trace_singleton s1) - iex - iatr. - Proof. - intros LEN Hfin Hwp. - eexists. - eapply produced_inf_aux_trace_valid_inf. - Unshelve. - - econstructor. - - eapply (strong_simulation_adequacy_general_multiple s) => //. - - done. - Qed. - - Theorem strong_simulation_adequacy_inftraces Σ - `{hPre: @heapGpreS Σ M EM} (s: stuckness) - (e1 : expr) σ1 (s1: M) - (R: execution_trace heap_lang → auxiliary_trace M → Prop) - (p: em_init_param) - (iex : inf_execution_trace heap_lang) - (Hvex : valid_inf_exec (trace_singleton ([e1], σ1)) iex) - : - rel_finitary R → - em_is_init_st ([e1], σ1) s1 -> - (wp_premise Σ s e1 σ1 s1 R p) -> - exists iatr, - @valid_inf_system_trace _ M - (@continued_simulation - heap_lang - M - R) - (trace_singleton ([e1], σ1)) - (trace_singleton s1) - iex - iatr. - Proof. - intros. eapply strong_simulation_adequacy_inftraces_multiple. - 1-5: by eauto. - by eapply wp_premise_single. - Qed. - - Theorem strong_simulation_adequacy_traces_multiple Σ - `{hPre: @heapGpreS Σ M EM} (s: stuckness) - (es: list expr) σ1 (s1: M) - (R: execution_trace heap_lang → auxiliary_trace M → Prop) - (p: em_init_param) - - (extr : heap_lang_extrace) - (Hvex : extrace_valid extr) - (Hexfirst : trfirst extr = (es, σ1)) - - (valid_step: cfg heap_lang -> olocale heap_lang → cfg heap_lang → - mstate M → mlabel M → mstate M -> Prop) - (state_rel: cfg heap_lang -> mstate M -> Prop) - (lbl_rel: olocale heap_lang -> mlabel M -> Prop) - (STEP_LBL_REL: forall c1 oζ c2 δ1 ℓ δ2, - valid_step c1 oζ c2 δ1 ℓ δ2 -> - lbl_rel oζ ℓ) - (STEP_MTRANS: forall c1 oζ c2 δ1 ℓ δ2, - valid_step c1 oζ c2 δ1 ℓ δ2 -> - mtrans δ1 ℓ δ2) - (R_ST: forall extr mtr, R extr mtr -> state_rel (trace_last extr) (trace_last mtr)) - (R_STEP: forall extr mtr, R extr mtr -> valid_state_evolution_fairness valid_step extr mtr) - - : - length es ≥ 1 -> - rel_finitary R → - em_is_init_st (es, σ1) s1 -> - (wp_premise_multiple Σ s es σ1 s1 R p) -> - ∃ (mtr : trace (mstate M) (mlabel M)), - traces_match lbl_rel state_rel locale_step (@mtrans M) extr mtr /\ - trfirst mtr = s1. - Proof. - intros ? Hfin INIT Hwp. - have [iatr MATCH] : exists iatr, - @valid_inf_system_trace - heap_lang M - (@continued_simulation - heap_lang - M - R) - (trace_singleton (es, (trfirst extr).2)) - (trace_singleton s1) - (from_trace extr) - iatr. - { eapply (strong_simulation_adequacy_inftraces_multiple _ s); eauto. - 1: eapply from_trace_preserves_validity; eauto; first econstructor. - all: try by rewrite Hexfirst. } - rewrite Hexfirst in MATCH. simpl in *. - exists (to_trace s1 iatr). - - split. - 2: { by rewrite to_trace_trfirst. } - - pose proof MATCH as INF_REF. (** see remark below *) - eapply (valid_inf_system_trace_implies_traces_match - valid_step - state_rel - lbl_rel - ltac:(idtac) - ltac:(idtac) - (continued_simulation R)) in MATCH; cycle 1. - { intros ?? ?%continued_simulation_rel. eauto. } - { intros ?? ?%continued_simulation_rel. eauto. } - { apply from_trace_spec. simpl. - rewrite Hexfirst. done. } - { apply to_trace_spec. } - Unshelve. 2,3: by eauto. - - assert (exists len, trace_len.trace_len_is extr len /\ trace_len.trace_len_is (to_trace s1 iatr) len) as LEN. (** see remark below *) - { simpl in MATCH. - pose proof (trace_len.trace_has_len extr) as [len LEN]. - pose proof (trace_len.trace_has_len (to_trace s1 iatr)) as [len' LEN']. - eapply trace_len.traces_match_same_length in MATCH; eauto. subst. - eauto. } - - (** INF_REF and LEN together give the traces mentioned in - the refinement section of Lawyer paper - (same length, related by infinite extension of refinement). - However, our proofs proceed differency, - using the notion of traces_match (MATCH hypothesis). *) - - apply MATCH. - Qed. - - Theorem strong_simulation_adequacy_traces Σ - `{hPre: @heapGpreS Σ M EM} (s: stuckness) - (e1 : expr) σ1 (s1: M) - (R: execution_trace heap_lang → auxiliary_trace M → Prop) - (p: em_init_param) - - (extr : heap_lang_extrace) - (Hvex : extrace_valid extr) - (Hexfirst : trfirst extr = ([e1], σ1)) - - (valid_step: cfg heap_lang -> olocale heap_lang → cfg heap_lang → - mstate M → mlabel M → mstate M -> Prop) - (state_rel: cfg heap_lang -> mstate M -> Prop) - (lbl_rel: olocale heap_lang -> mlabel M -> Prop) - (STEP_LBL_REL: forall c1 oζ c2 δ1 ℓ δ2, - valid_step c1 oζ c2 δ1 ℓ δ2 -> - lbl_rel oζ ℓ) - (STEP_MTRANS: forall c1 oζ c2 δ1 ℓ δ2, - valid_step c1 oζ c2 δ1 ℓ δ2 -> - mtrans δ1 ℓ δ2) - (R_ST: forall extr mtr, R extr mtr -> state_rel (trace_last extr) (trace_last mtr)) - (R_STEP: forall extr mtr, R extr mtr -> valid_state_evolution_fairness valid_step extr mtr) - - : - rel_finitary R → - em_is_init_st ([e1], σ1) s1 -> - (wp_premise Σ s e1 σ1 s1 R p) -> - ∃ (mtr : trace (mstate M) (mlabel M)), - traces_match lbl_rel state_rel locale_step (@mtrans M) extr mtr /\ - trfirst mtr = s1. - Proof. - intros. eapply strong_simulation_adequacy_traces_multiple; last first. - { by eapply wp_premise_single. } - all: by eauto. - Qed. - -End adequacy. diff --git a/heap_lang/sswp_logic.v b/heap_lang/sswp_logic.v index 08095be..d888894 100644 --- a/heap_lang/sswp_logic.v +++ b/heap_lang/sswp_logic.v @@ -8,11 +8,9 @@ From heap_lang Require Import tactics notation. Section SSWP. Set Default Proof Using "Type". - Context `{EM: ExecutionModel heap_lang M}. - Context `{hGS: @heapGS Σ _ EM}. + Context `{hGS: @heap1GS Σ}. + Context {iGS: invGS_gen HasNoLc Σ}. - Let eGS := heap_fairnessGS. - Definition sswp (s : stuckness) E e1 (Φ : expr → iProp Σ) : iProp Σ := match to_val e1 with | Some v => |={E}=> (Φ (of_val v)) @@ -67,16 +65,16 @@ Section SSWP. apply Hstep' in Hstep as [-> [-> ->]]. by iFrame. Qed. - Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _; simpl : core. - 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. + (* Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _; simpl : core. *) + (* 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. + (* #[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. *) Lemma wp_allocN_seq s E v n (Φ : expr → iProp Σ) : 0 < n → From a1424420223f24cc11790ef1fa90117fadf11707 Mon Sep 17 00:00:00 2001 From: fresheed Date: Sat, 6 Sep 2025 16:24:34 +0200 Subject: [PATCH 11/17] restored fairis proof rules and tactics --- fairis/lifting.v | 160 +++++ fairis/proofmode.v | 1030 ++++++++++++++++++++++++++++++++ heap_lang/locales_helpers_hl.v | 20 + 3 files changed, 1210 insertions(+) create mode 100644 fairis/lifting.v create mode 100644 fairis/proofmode.v diff --git a/fairis/lifting.v b/fairis/lifting.v new file mode 100644 index 0000000..993bc60 --- /dev/null +++ b/fairis/lifting.v @@ -0,0 +1,160 @@ +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 ectx_lifting. +From heap_lang Require Export sswp_logic locales_helpers_hl. +From fairis Require Export fuel resources heap_lang_lm + (* fair_termination 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)). *) + +Section lifting. +Context `{LM:LiveModel heap_lang M}. +Context `{!heapGS Σ LM}. + +Lemma has_fuels_decr E tid fs : + tid ↦M++ fs -∗ |~{E}~| tid ↦M fs. +Proof. + iIntros "Hf". rewrite weakestpre.pre_step_unseal. + iIntros (extr atr) "[%Hvse [Hσ Hm]]". + iMod (model_state_interp_has_fuels_decr with "Hm Hf") as "[$ $]". by iFrame. +Qed. + +Lemma has_fuels_dealloc E tid fs ρ δ : + ρ ∉ live_roles _ δ → frag_model_is δ -∗ tid ↦M fs -∗ + |~{E}~| frag_model_is δ ∗ tid ↦M (delete ρ fs). +Proof. + iIntros (Hnin) "Hst Hf". rewrite weakestpre.pre_step_unseal. + iIntros (extr atr) "[%Hvse [Hσ Hm]]". + iMod (model_state_interp_has_fuels_dealloc with "Hm Hst Hf") as "[Hm Hf]"; + [done|by iFrame]. +Qed. + +(* Rule from the Trillium article *) +Lemma wp_role_dealloc s tid E e fs ρ δ Φ : + ρ ∉ live_roles _ δ → frag_model_is δ -∗ tid ↦M fs -∗ + (frag_model_is δ -∗ tid ↦M (delete ρ fs) -∗ WP e @ s; tid; E {{ Φ }}) -∗ + WP e @ s; tid; E {{ Φ }}. +Proof. + iIntros (Hnin) "HM Hfuels Hwp". + iMod (has_fuels_dealloc with "HM Hfuels") as "[HM Hfuels]"; [done|]. + by iApply ("Hwp" with "HM Hfuels"). +Qed. + +Lemma wp_step_model s tid ρ (f1 : nat) fs fr s1 s2 E e Φ : + TCEq (to_val e) None → + fmtrans M s1 (Some ρ) s2 → + M.(live_roles) s2 ⊆ M.(live_roles) s1 → + ρ ∉ dom fs → + ▷ frag_model_is s1 -∗ + ▷ tid ↦M ({[ρ:=f1]} ∪ fmap S fs) -∗ + ▷ frag_free_roles_are fr -∗ + sswp s E e (λ e', frag_model_is s2 -∗ + tid ↦M ({[ρ:=(LM.(lm_fl) s2)]} ∪ fs) -∗ + frag_free_roles_are fr -∗ + WP e' @ s; tid; E {{ Φ }} ) -∗ + WP e @ s; tid; E {{ Φ }}. +Proof. + iIntros (Hval Htrans Hlive Hdom) ">Hst >Hfuel1 >Hfr Hwp". + rewrite wp_unfold /wp_pre. + rewrite /sswp. simpl. rewrite Hval. + iIntros (extr atr K tp1 tp2 σ1 Hvalid Hloc Hexend) "(% & Hsi & Hmi)". + iMod ("Hwp" with "Hsi") as (Hred) "Hwp". iIntros "!>". + iSplitR; [by rewrite Hexend in Hred|]. iIntros (????). rewrite Hexend. + iMod ("Hwp" with "[//]") as "Hwp". iIntros "!>!>". iMod "Hwp". iIntros "!>". + iApply step_fupdN_intro; [done|]. iIntros "!>". + iMod "Hwp" as "[Hσ [Hwp ->]]". + iDestruct (model_agree' with "Hmi Hst") as %Hmeq. iFrame. + rewrite /trace_ends_in in Hexend. rewrite -Hexend. + iMod (update_model_step with "Hfuel1 Hst Hmi") as + (δ2 Hvse) "(Hfuel & Hst & Hmod)"; eauto. + - rewrite -Hloc. eapply locale_step_atomic; eauto. by apply fill_step. + - iModIntro; iExists δ2, (Take_step ρ tid). rewrite big_sepL_nil. iFrame. + iSplit; [done|]. iDestruct ("Hwp" with "Hst Hfuel Hfr") as "Hwp". by iFrame. +Qed. + +Lemma wp_step_model_singlerole s tid ρ (f1 : nat) fr s1 s2 E e Φ : + TCEq (to_val e) None → + fmtrans M s1 (Some ρ) s2 → + M.(live_roles) s2 ⊆ M.(live_roles) s1 → + ▷ frag_model_is s1 -∗ ▷ tid ↦M {[ρ := f1]} -∗ ▷ frag_free_roles_are fr -∗ + sswp s E e (λ e', frag_model_is s2 -∗ + tid ↦M {[ρ := (LM.(lm_fl) s2)]} -∗ + frag_free_roles_are fr -∗ + WP e' @ s; tid; E {{ Φ }} ) -∗ + WP e @ s; tid; E {{ Φ }}. +Proof. + iIntros (Hval Htrans Hlive) ">Hst >Hfuel1 >Hfr Hwp". + replace ({[ρ := f1]}) with ({[ρ := f1]} ∪ (fmap S ∅:gmap _ _)); last first. + { rewrite fmap_empty. rewrite right_id_L. done. } + iApply (wp_step_model with "Hst Hfuel1 Hfr"); [done|set_solver|done|]. + iApply (sswp_wand with "[] Hwp"). iIntros (e') "Hwp Hst Hfuel1 Hfr". + rewrite right_id_L. iApply ("Hwp" with "Hst Hfuel1 Hfr"). +Qed. + +Lemma wp_step_fuel s tid E e fs Φ : + fs ≠ ∅ → ▷ tid ↦M++ fs -∗ + sswp s E e (λ e', tid ↦M fs -∗ WP e' @ s; tid; E {{ Φ }} ) -∗ + WP e @ s; tid; E {{ Φ }}. +Proof. + iIntros (?) ">HfuelS Hwp". rewrite wp_unfold /wp_pre /sswp /=. + destruct (to_val e). + { iMod (has_fuels_decr with "HfuelS") as "Hfuel". + iDestruct ("Hwp" with "Hfuel") as "Hwp". + iDestruct (wp_value_inv with "Hwp") as "Hwp". by iMod "Hwp". } + 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). + iMod ("Hwp" with "[//]") as "Hwp". + iIntros "!>!>". iMod "Hwp". iIntros "!>". + iApply step_fupdN_intro; [done|]. iIntros "!>". iMod "Hwp". rewrite -Hends. + iMod (update_fuel_step with "HfuelS Hmi") as (δ2) "(%Hvse & Hfuel & Hmod)" =>//. + { rewrite Hends -Hloc. eapply locale_step_atomic; eauto. by apply fill_step. } + iIntros "!>". iDestruct "Hwp" as "[Hsi [Hwp ->]]". + iExists _, (Silent_step tid). iFrame. iSplit; [done|]. + iDestruct ("Hwp" with "Hfuel") as "Hwp". iSplit; [|done]. + iApply (wp_wand with "Hwp"). iIntros (v) "HΦ'". by iFrame. +Qed. + +Lemma wp_role_fork s tid E e Φ R1 R2 (Hdisj: R1 ##ₘ R2) (Hnemp: R1 ∪ R2 ≠ ∅): + tid ↦M++ (R1 ∪ R2) -∗ + (∀ tid', ▷ (tid' ↦M R2 -∗ WP e @ s; tid'; ⊤ {{ _, tid' ↦M ∅ }})) -∗ + ▷ (tid ↦M R1 ={E}=∗ Φ (LitV LitUnit)) -∗ + WP Fork e @ s; tid; E {{ Φ }}. +Proof. + iIntros "Htid He HΦ". iApply wp_lift_atomic_head_step; [done|]. + iIntros (extr auxtr K tp1 tp2 σ1 Hvalex Hexend Hloc) "(% & Hsi & Hmi)". + iMod (update_fork_step R1 R2 _ + (tp1 ++ ectx_language.fill K (Val $ LitV LitUnit) :: tp2 ++ [e]) + _ _ _ e _ σ1 with "Htid Hmi") as + (δ2 Hvse) "(Hfuels1 & Hfuels2 & Hmi)". + { done. } + { done. } + { rewrite /trace_ends_in in Hexend. rewrite Hexend. done. } + { rewrite -Hloc. rewrite -(language.locale_fill _ _ K). + rewrite /trace_ends_in in Hexend. rewrite Hexend. + econstructor 1 =>//. + apply fill_step, head_prim_step. econstructor. } + { list_simplifier. exists (tp1 ++ fill K #() :: tp2). + rewrite /trace_ends_in in Hexend. rewrite Hexend. + split; first by list_simplifier. + apply heap_lang_locales_equiv_length. simpl. + 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; [by iPureIntro|]. + iSplit; [|done]. iApply "He". by list_simplifier. +Qed. + +End lifting. diff --git a/fairis/proofmode.v b/fairis/proofmode.v new file mode 100644 index 0000000..2e8a169 --- /dev/null +++ b/fairis/proofmode.v @@ -0,0 +1,1030 @@ +From iris.proofmode Require Import coq_tactics reduction spec_patterns. +From iris.proofmode Require Export tactics. +From trillium.program_logic Require Import atomic. +From fairis Require Import fuel heap_lang_lm resources lifting. +(* 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. iIntros "?"; done. } + + inversion HPE; simplify_eq. + + iIntros "H Hf". + rewrite has_fuels_plus_split_S. + iApply (wp_step_fuel with "Hf"). + { by intros ?%fmap_empty_inv. } + iApply sswp_pure_step. + { econstructor =>//. constructor. } + { eapply pure_step_ctx. done. } + iModIntro. iIntros "Hf". iApply (IHn _ _ _ with "[H] [Hf]") => //. +Qed. + +Lemma equiv_wand {Σ} (P Q: iProp Σ): + P ≡ Q -> + P -∗ Q. +Proof. intros ->; auto. 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; + 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_step_fuel with "H1"); [by intros ?%fmap_empty_inv|]. + iApply (wp_load with "H2"). + iIntros "!> Hl Hf". wp_pures. 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_step_fuel with "H1"); [by intros ?%fmap_empty_inv|]. + iApply (wp_store with "H2"). + iIntros "!> Hl Hf". wp_pures. + 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/heap_lang/locales_helpers_hl.v b/heap_lang/locales_helpers_hl.v index dc111fb..e2cbcb1 100644 --- a/heap_lang/locales_helpers_hl.v +++ b/heap_lang/locales_helpers_hl.v @@ -121,3 +121,23 @@ Proof using. apply gset_pick_Some in FORK. eapply locale_step_fresh_exact in FORK; eauto. Qed. + + +(* TODO: found in Fairis, might have duplicates somewhere above/around *) +(****************) + +Lemma heap_lang_locales_equiv_from_length (es10 es1 es20 es2 : list expr) : + length es10 = length es20 → length es1 = length es2 → + locales_equiv_from es10 es20 es1 es2. +Proof. + revert es10 es20 es2. + induction es1 as [|e es1 IHes1]; intros es10 es20 es2 Hlen; [by destruct es2|]. + destruct es2; [done|]=> /=. constructor; [done|]. + apply IHes1; [by rewrite !app_length=> /=;f_equiv|lia]. +Qed. + +Lemma heap_lang_locales_equiv_length (es1 es2 : list expr) : + length es1 = length es2 → locales_equiv es1 es2. +Proof. intros Hlen. by apply heap_lang_locales_equiv_from_length. Qed. + +(****************) From e2bd0c56e109fe1d9b579072400fed75bfa9b351 Mon Sep 17 00:00:00 2001 From: fresheed Date: Sat, 6 Sep 2025 16:28:22 +0200 Subject: [PATCH 12/17] restored yesno example --- fairis/examples/yesno/yesno.v | 467 +++++++++++++++++++++++++ fairis/examples/yesno/yesno_adequacy.v | 250 +++++++++++++ 2 files changed, 717 insertions(+) create mode 100644 fairis/examples/yesno/yesno.v create mode 100644 fairis/examples/yesno/yesno_adequacy.v diff --git a/fairis/examples/yesno/yesno.v b/fairis/examples/yesno/yesno.v new file mode 100644 index 0000000..7925cd3 --- /dev/null +++ b/fairis/examples/yesno/yesno.v @@ -0,0 +1,467 @@ +From stdpp Require Import 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.program_logic Require Export weakestpre. +From fairness Require Import fairness. +From fairis Require Import fuel lifting fair_termination proofmode heap_lang_lm. +(* From trillium.fairness.heap_lang Require Export lang lifting tactics proofmode notation. *) + +Import derived_laws_later.bi. + +Open Scope nat. + +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 : iProp Σ := + ∃ N B, + ⌜(N, B) ≠ (0, false)⌝ ∗ + 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. + 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 ∗ tid ↦M {[ 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) "(>%Hnever & >HFR & >Hmod & >Bb & Hauths)" "Hclose". + destruct B; iDestruct "Hauths" as "[>Hay >Han]". + - iDestruct (yes_agree with "Hyes Hay") as "%Heq". + destruct (decide (M = 0)) as [->|Nneq]; first lia. + destruct (decide (M = 1)) as [->|Nneq1]. + + iModIntro. + iApply (wp_step_model_singlerole with "Hmod Hf HFR"). + { econstructor. lia. } + { set_solver. } + iApply (wp_cmpxchg_suc with "Bb"); [done|done|]. + iIntros "!> Hb Hmod Hf HFR". + iMod (yes_update 0 with "[$]") as "[Hay Hyes]". + wp_pures. + iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). + { iNext. iExists _, _. iFrame. simpl. iFrame. by iPureIntro. } + iApply fupd_mask_intro; [done|]. iMod 1. iModIntro. + simpl in *. wp_load. wp_store. wp_load. wp_pure _. simplify_eq. simpl. + iApply wp_atomic. + iInv Ns as (M B) "(>%Hbever' & >HFR & >Hmod & >Hb & Hauths)" "Hclose". + destruct B. + * iModIntro. + iApply (wp_step_fuel with "[Hf]"). + 2: { iClear "Hg". rewrite has_fuels_gt_1; last by solve_fuel_positive. + rewrite fmap_insert fmap_empty. done. } + { set_solver. } + iApply sswp_pure_step; [done|]. + iIntros "!> Hf". iApply wp_pre_step. wp_pures. + iApply fupd_mask_intro; [done|]. + iIntros "Hclose'". + iDestruct "Hauths" as "[Hay Han]". + iDestruct (yes_agree with "Hyes Hay") as %Heq. + assert (M = 0) by lia. simplify_eq. + iMod (has_fuels_dealloc _ _ _ (Y:fmrole the_fair_model) + with "Hmod Hf") as "[Hmod Hf]"; [done|]. + iModIntro. iMod "Hclose'". + iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). + { iNext. iExists _, _. iFrame. done. } + iModIntro. iApply "Hk". + rewrite delete_insert; [|set_solver]. + iFrame "Hf". + * iDestruct "Hauths" as "[>Hay >Han]". iDestruct (yes_agree with "Hyes Hay") as %Heq. + assert (M = 1) by (destruct M; [done|lia]). simplify_eq. + iModIntro. + iApply (wp_step_fuel with "[Hf]"). + 2: { iClear "Hg". rewrite has_fuels_gt_1; last by solve_fuel_positive. + rewrite fmap_insert fmap_empty. done. } + { set_solver. } + iApply sswp_pure_step; [done|]. + iIntros "!> Hf". iApply wp_pre_step. wp_pures. + iApply fupd_mask_intro; [done|]. + iIntros "Hclose'". + iMod (has_fuels_dealloc _ _ _ (Y:fmrole the_fair_model) + with "Hmod Hf") as "[Hmod Hf]"; [set_solver|]. + iModIntro. iMod "Hclose'". + iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). + { iNext. iExists _, _. iFrame. done. } + iModIntro. iApply "Hk". + rewrite delete_insert; [|set_solver]. + iFrame. + + assert (N = N) by lia. simplify_eq. + iModIntro. + iApply (wp_step_model_singlerole with "Hmod Hf HFR"). + { constructor. lia. } + { simpl. destruct M; [set_solver | destruct M; set_solver]. } + iApply (wp_cmpxchg_suc with "Bb"); [done|done|]. + iIntros "!> Hb Hmod Hf HFR". + iMod (yes_update (M-1) with "[$]") as "[Hay Hyes]". + wp_pures. iModIntro. + iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). + { iNext. iExists _, _. iFrame. iPureIntro. intro contra. simplify_eq. } + iModIntro. + simpl. wp_load. wp_store. wp_load. wp_pures. + destruct (decide (0 < S M - 1)) as [Heq|Heq]. + * rewrite bool_decide_eq_true_2 //; last lia. + wp_pure _. + 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. + iModIntro. + iApply (wp_step_model_singlerole with "Hmod Hf HFR"). + { constructor. lia. } + { set_solver. } + iApply (wp_cmpxchg_fail with "Bb"); [done|done|]. + iIntros "!> Hb Hmod Hf HFR". + wp_pures. iModIntro. + iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). + { iNext. simplify_eq. iExists _, _. iFrame. iFrame. done. } + iModIntro. + simpl. wp_load. wp_pure _. rewrite bool_decide_eq_true_2; last lia. + wp_pure _. + 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 ∗ tid ↦M {[ 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 _). + iApply (wp_step_fuel with "[Hf]"). + { apply map_non_empty_singleton. } + { rewrite has_fuels_gt_1; last by solve_fuel_positive. + rewrite fmap_insert fmap_empty. done. } + iApply wp_alloc. iNext. iIntros (n) "HnN _ Hf". wp_pures. iModIntro. wp_pures. + 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 ∗ tid ↦M {[ 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) "(>%Hnever & >HFR & >Hmod & >Bb & Hauths)" "Hclose". + destruct B; iDestruct "Hauths" as "[>Hay >Han]"; last first. + - iDestruct (no_agree with "Hno Han") as "%Heq". + destruct (decide (M = 0)) as [->|Nneq]; first lia. + destruct (decide (M = 1)) as [->|Nneq1]. + + iModIntro. + iApply (wp_step_model_singlerole with "Hmod Hf HFR"). + { econstructor. } + { set_solver. } + iApply (wp_cmpxchg_suc with "Bb"); [done|done|]. + iIntros "!> Hb Hmod Hf HFR". + iMod (no_update 0 with "[$]") as "[Han Hno]". + wp_pures. iModIntro. + iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). + { iNext. iExists _, _. iFrame. simpl. iFrame. by iPureIntro. } + iModIntro. + simpl. wp_load. wp_store. wp_load. wp_pure _. simplify_eq. simpl. + iApply wp_atomic. + iInv Ns as (M B) "(>%Hbever' & >HFR & >Hmod & >Hb & Hauths)" "Hclose". + destruct B. + * iModIntro. + iApply (wp_step_fuel with "[Hf]"). + 2: { iClear "Hg". rewrite has_fuels_gt_1; last by solve_fuel_positive. + rewrite fmap_insert fmap_empty. done. } + { set_solver. } + iApply sswp_pure_step; [done|]. + iIntros "!> Hf". + iDestruct "Hauths" as "[Hay Han]". iDestruct (no_agree with "Hno Han") as %Heq. + assert (M = 0) by lia. simplify_eq. + iMod (has_fuels_dealloc _ _ _ + (No:fmrole the_fair_model) with "Hmod Hf") + as "[Hmod Hf]"; [set_solver|]. + wp_pures. iModIntro. + iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). + { iNext. iExists _, _. iFrame. done. } + iModIntro. iApply "Hk". + rewrite delete_insert; [|done]. + 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. + iModIntro. + iApply (wp_step_model_singlerole with "Hmod Hf HFR"). + { econstructor. } + { simpl. destruct M; [set_solver | destruct M; set_solver]. } + iApply (wp_cmpxchg_suc with "Bb"); [done|done|]. + iIntros "!> Hb Hmod Hf HFR". + iMod (no_update (M) with "[$]") as "[Han Hno]". + wp_pures. iModIntro. + iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). + { iNext. iExists _, _. iFrame. iSplit; [done|]. + iApply (own_proper with "Hay"). f_equiv. apply leibniz_equiv_iff. lia. } + iModIntro. simpl. wp_load. wp_store. wp_load. wp_pures. + destruct (decide (0 < S M - 1)) as [Heq|Heq]. + * rewrite bool_decide_eq_true_2 //; last lia. + wp_pure _. + 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. + assert (M = N) by lia. simplify_eq. iModIntro. + iApply (wp_step_model_singlerole with "Hmod Hf HFR"). + { econstructor. lia. } + { set_solver. } + iApply (wp_cmpxchg_fail with "Bb"); [done|done|]. + iIntros "!> Hb Hmod Hf HFR". + wp_pures. + iModIntro. + iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). + { iNext. simplify_eq. iExists _, _. iFrame. iFrame. done. } + iModIntro. simpl. wp_load. wp_pure _. + rewrite bool_decide_eq_true_2; last lia. wp_pure _. + 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 ∗ tid ↦M {[ 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 _). + iApply (wp_step_fuel with "[Hf]"). + { apply map_non_empty_singleton. } + { rewrite has_fuels_gt_1; last by solve_fuel_positive. + rewrite fmap_insert fmap_empty. done. } + iApply wp_alloc. iNext. iIntros (n) "HnN _ Hf". wp_pures. iModIntro. wp_pures. + 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 ∅ ∗ + tid ↦M {[ 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_step_fuel with "[Hf]"). + 2: { rewrite has_fuels_gt_1; last by solve_fuel_positive. + rewrite !fmap_insert fmap_empty. done. } + { rewrite insert_union_singleton_l. + intros ?%map_positive_l. set_solver. } + iApply wp_alloc. iNext. iIntros (l) "HnN _ Hf". wp_pures. iModIntro. 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 _). + iApply (wp_role_fork _ tid _ _ _ {[No := _]} {[Y := _]} + with "[Hf] [Hyes_at]"). + { apply map_disjoint_dom. rewrite !dom_singleton. set_solver. } + { intros Hempty%map_positive_l. set_solver. } + { rewrite has_fuels_gt_1; last solve_fuel_positive. + rewrite !fmap_insert fmap_empty //. + rewrite insert_union_singleton_l. + rewrite map_union_comm; [done|]. + apply map_disjoint_dom. set_solver. } + { iIntros (tid') "!> Hf". iApply (yes_spec with "[-]"); last first. + + by eauto. + + iFrame "#∗". iPureIntro. lia. + + lia. } + iIntros "!> Hf !>". wp_pures. + iApply (wp_role_fork _ tid _ _ _ ∅ {[No := _]} with "[Hf] [Hno_at] [Hkont]"). + { apply map_disjoint_dom. rewrite !dom_singleton. set_solver. } + { rewrite map_union_comm. + - intros Hempty%map_positive_l. set_solver. + - apply map_disjoint_dom. rewrite dom_singleton. set_solver. } + { rewrite has_fuels_gt_1; last solve_fuel_positive. + rewrite !fmap_insert fmap_empty //. + rewrite insert_union_singleton_l. + rewrite map_union_comm; [done|]. + apply map_disjoint_dom. set_solver. } + { iIntros (tid') "!> Hf". iApply (no_spec with "[-]"); last first. + + by eauto. + + by iFrame "#∗". + + lia. } + iNext. iIntros "Hf". by iApply "Hkont". + Qed. + +End proof_start. diff --git a/fairis/examples/yesno/yesno_adequacy.v b/fairis/examples/yesno/yesno_adequacy.v new file mode 100644 index 0000000..7ab473b --- /dev/null +++ b/fairis/examples/yesno/yesno_adequacy.v @@ -0,0 +1,250 @@ +From iris.proofmode Require Import tactics. +From trillium.program_logic Require Export weakestpre. +From fairness Require Import fairness. +From trillium.prelude Require Export finitary quantifiers sigma classical_instances. +From fairis Require Import lifting adequacy fair_termination fairness_finiteness. +From fairis.examples.yesno Require Import yesno. + +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: well_founded (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: well_founded (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. From 58c27a32c5682f0065b213483eec788951b28987 Mon Sep 17 00:00:00 2001 From: fresheed Date: Sat, 6 Sep 2025 16:41:08 +0200 Subject: [PATCH 13/17] restored all examples of fairis --- fairis/examples/choose_nat/choose_nat.v | 295 ++++++++ .../examples/choose_nat/choose_nat_adequacy.v | 89 +++ fairis/examples/even_odd/even_odd.v | 346 +++++++++ fairis/examples/even_odd/even_odd_adequacy.v | 683 ++++++++++++++++++ fairis/examples/yesno/yesno.v | 1 - 5 files changed, 1413 insertions(+), 1 deletion(-) create mode 100644 fairis/examples/choose_nat/choose_nat.v create mode 100644 fairis/examples/choose_nat/choose_nat_adequacy.v create mode 100644 fairis/examples/even_odd/even_odd.v create mode 100644 fairis/examples/even_odd/even_odd_adequacy.v diff --git a/fairis/examples/choose_nat/choose_nat.v b/fairis/examples/choose_nat/choose_nat.v new file mode 100644 index 0000000..4afce93 --- /dev/null +++ b/fairis/examples/choose_nat/choose_nat.v @@ -0,0 +1,295 @@ +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 fairness Require Import fairness. +From fairis Require Import fuel lifting fair_termination proofmode heap_lang_lm. + +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: #0 < "x" then #l <- ("x" - #1);; "go" #() else #(). +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. + +#[global] 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 -∗ + {{{ tid ↦M {[ () := f ]} ∗ frag_free_roles_are ∅ ∗ + own γ (◯E (Z.of_nat n)) }}} + decr_loop_prog l #() @ tid ; ⊤ + {{{ RET #(); tid ↦M ∅ }}}. + Proof. + iIntros (Hle1 Hle2) "#IH". + iIntros "!>" (Φ) "(Hf & Hr & Hm) HΦ". + iInduction n as [|n] "IHn" forall (f Hle1 Hle2). + { 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. + do 3 wp_pure _. + iInv Ns as ">HI" "Hclose". + iDestruct "HI" as (cn) "(Hs & Hl & Hcn)". + iApply (wp_pre_step ⊤). + wp_pures. + iModIntro. + iDestruct (own_valid_2 with "Hcn Hm") as %Hvalid%excl_auth_agree_L. + assert (cn = N 0) as ->. + { destruct cn; inversion Hvalid. by simplify_eq. } + iMod (has_fuels_dealloc _ _ _ (():fmrole cn_fair_model) with "Hs Hf") + as "[Hs Hf]"; [done|]. + iModIntro. + iMod ("Hclose" with "[Hs Hl Hcn]") as "_". + { iExists (N 0). iFrame. } + iModIntro. 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. + replace (Z.of_nat (S n) - 1)%Z with (Z.of_nat 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 n)) as ->. + { destruct cn; inversion Hvalid. by simplify_eq. } + (* Update the model state to maintain program correspondence *) + iApply (wp_step_model_singlerole _ _ (():fmrole cn_fair_model) (f - 7) + with "Hs [Hf] Hr"). + { constructor. } + { simpl. destruct n; set_solver. } + { by replace (f - 1 - 1 - 1 - 1 - 1 - 1 - 1)%nat with (f - 7)%nat by lia. } + iApply (wp_store with "Hl"). + iIntros "!> Hl Hs Hf Hr". + wp_pures. + iMod (own_update_2 _ _ _ with "Hcn Hm") as "[Hcn Hm]". + { apply (excl_auth_update _ _ (Z.of_nat n)%Z). } + iMod ("Hclose" with "[Hs Hl Hcn]") as "_". + { iExists (N n). iFrame. } + iApply fupd_mask_intro; [done|]. + iIntros "H". iMod "H". + iModIntro. simpl. wp_pures. + iApply ("IHn" with "[] [] Hf Hr Hm"); [iPureIntro; lia..|done]. + Qed. + + Lemma choose_nat_spec γ l tid (f:nat) : + 12 ≤ f → f ≤ 40 → + choose_nat_inv γ l -∗ + {{{ tid ↦M {[ () := 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_step_fuel with "[Hf]"). + 2: { rewrite has_fuels_gt_1; last by solve_fuel_positive. + rewrite fmap_insert fmap_empty. done. } + { set_solver. } + iApply wp_choose_nat. + iIntros "!>" (n) "Hf". + wp_pures. + iModIntro. + 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_step_model_singlerole _ _ (():fmrole cn_fair_model) (f - 3) + _ _ (N (S n)) + with "Hs [Hf] Hr"). + { constructor. } + { set_solver. } + { by replace (f - 1 - 1 - 1)%nat with (f - 3)%nat by lia. } + iApply (wp_store with "Hl"). + iIntros "!> Hl Hs Hf Hr". + wp_pures. + 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. } + iApply fupd_mask_intro; [done|]. + iIntros "H". iMod "H". + iModIntro. simpl. wp_pures. + by iApply (decr_loop_spec with "IH [$Hm $Hr $Hf]"); [lia|lia|]. + Qed. + +End proof. diff --git a/fairis/examples/choose_nat/choose_nat_adequacy.v b/fairis/examples/choose_nat/choose_nat_adequacy.v new file mode 100644 index 0000000..91d1e69 --- /dev/null +++ b/fairis/examples/choose_nat/choose_nat_adequacy.v @@ -0,0 +1,89 @@ +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 fairness Require Import fairness. +From fairis Require Import fuel lifting fair_termination fairness_finiteness proofmode heap_lang_lm adequacy. +From fairis.examples.choose_nat Require Import choose_nat. + +Import derived_laws_later.bi. + +Set Default Proof Using "Type". + +(** 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 gset_to_gmap_set_to_map. iFrame. } + iIntros (ex atr c Hvalid Hex Hatr Hends Hξ Hstuck Hequiv) "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/fairis/examples/even_odd/even_odd.v b/fairis/examples/even_odd/even_odd.v new file mode 100644 index 0000000..f048c0a --- /dev/null +++ b/fairis/examples/even_odd/even_odd.v @@ -0,0 +1,346 @@ +From stdpp Require Import 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 fairness Require Import fairness. +From fairis Require Import fuel lifting fair_termination proofmode heap_lang_lm. + +Import derived_laws_later.bi. + +Open Scope nat. + +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 +| odd_trans n : Nat.odd n → eotrans n (Some ρOdd) (S n) +| odd_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 : iProp Σ := + ∃ 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. + 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 ∗ tid ↦M {[ ρ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". + iModIntro. + iApply (wp_step_model_singlerole with "Hmod Hf HFR"). + { constructor. by eauto. } + { set_solver. } + iApply (wp_cmpxchg_suc with "Hn"); [by do 3 f_equiv|done|]. + iIntros "!> Hb Hmod Hf HFR". + iMod (even_update (M + 2) with "[$]") as "[Hay Heven]". + wp_pures. + iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). + { iNext. iExists _. iFrame. subst. iEval (rewrite -Nat.add_1_r). + rewrite Nat2Z.inj_add !Nat.add_1_r Nat.even_succ -Nat.negb_even Heqn. + iFrame. replace (S (S N)) with (N + 2) by lia. iFrame. } + iApply fupd_mask_intro; [done|]. iIntros "H". iMod "H". + iModIntro. simpl. 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 "∗#". subst. iFrame. } + iPureIntro; lia. + - iDestruct (even_agree with "Heven Hay") as "%Heq". rewrite -> Heq in *. + iModIntro. + iApply (wp_step_model_singlerole with "Hmod Hf HFR"). + { apply even_fail. rewrite -Nat.negb_even. rewrite Heqn. done. } + { set_solver. } + iApply (wp_cmpxchg_fail with "Hn"); [intros Hne; simplify_eq; lia|done|]. + iIntros "!> Hb Hmod Hf HFR". + wp_pures. + iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). + { iNext. simplify_eq. iExists _. iFrame. + subst. iFrame. + rewrite Nat.add_1_r. rewrite Heqn. iFrame. } + iApply fupd_mask_intro; [done|]. iIntros "H". iMod "H". + iModIntro. simpl. wp_pures. + 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 ∗ tid ↦M {[ ρ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". + iModIntro. + iApply (wp_step_model_singlerole with "Hmod Hf HFR"). + { apply odd_trans. rewrite -Nat.negb_even. rewrite Heqn. done. } + { set_solver. } + iApply (wp_cmpxchg_suc with "Hn"); [by do 3 f_equiv|done|]. + iIntros "!> Hb Hmod Hf HFR". + iMod (odd_update (M + 2) with "[$]") as "[Han Hodd]". + wp_pures. + iMod ("Hclose" with "[Hmod Hay Han Hb HFR]"). + { iNext. iExists _. iFrame. subst. + rewrite Nat.add_1_r Nat.even_succ -Nat.negb_even Heqn 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. } + iApply fupd_mask_intro; [done|]. iIntros "H". iMod "H". iModIntro. + simpl. wp_pures. + 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 *. + simplify_eq. iModIntro. + iApply (wp_step_model_singlerole with "Hmod Hf HFR"). + { apply odd_fail. by eauto. } + { set_solver. } + iApply (wp_cmpxchg_fail with "Hn"); + [by intros Hneq; simplify_eq; lia|done|]. + iIntros "!> Hb Hmod Hf HFR". + wp_pures. + iMod ("Hclose" with "[Hmod Hb Hay Han HFR]"). + { iNext. simplify_eq. iExists _. iFrame. + rewrite Heqn. iFrame. } + iApply fupd_mask_intro; [done|]. iIntros "H". iMod "H". iModIntro. + simpl. wp_pures. + 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 ∗ tid ↦M {[ 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 ∗ tid ↦M {[ ρ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 _). + iApply (wp_role_fork _ tid _ _ _ {[ρOdd := _]} {[ρEven := _]} + with "[Hf] [Heven_at]"). + { apply map_disjoint_dom. rewrite !dom_singleton. set_solver. } + { intros Hempty%map_positive_l. set_solver. } + { rewrite has_fuels_gt_1; last solve_fuel_positive. + rewrite !fmap_insert fmap_empty //. + rewrite insert_union_singleton_l. + rewrite map_union_comm; [done|]. + apply map_disjoint_dom. set_solver. } + { iIntros (tid') "!> Hf". + iApply (incr_loop_spec with "[Heven_at $Hf]"); [lia|iFrame "#∗"|]. + by iIntros "!>?". } + iIntros "!> Hf". + iIntros "!>". + wp_pures. + iApply (wp_role_fork _ tid _ _ _ ∅ {[ρOdd := _]} with "[Hf] [Hodd_at]"). + { apply map_disjoint_dom. rewrite !dom_singleton. set_solver. } + { rewrite map_union_comm. + - intros Hempty%map_positive_l. set_solver. + - apply map_disjoint_dom. rewrite dom_singleton. set_solver. } + { rewrite has_fuels_gt_1; last solve_fuel_positive. + rewrite !fmap_insert fmap_empty //. + rewrite insert_union_singleton_l. + rewrite map_union_comm; [done|]. + apply map_disjoint_dom. set_solver. } + { iIntros (tid') "!> Hf". + wp_pures. + 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". by iApply "HΦ". + - 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 _). + iApply (wp_role_fork _ tid _ _ _ {[ρEven := _]} {[ρOdd := _]} + with "[Hf] [Hodd_at]"). + { apply map_disjoint_dom. rewrite !dom_singleton. set_solver. } + { intros Hempty%map_positive_l. set_solver. } + { rewrite has_fuels_gt_1; last solve_fuel_positive. + rewrite !fmap_insert fmap_empty //. + rewrite insert_union_singleton_l. done. } + { iIntros (tid') "!> Hf". + iApply (incr_loop_spec with "[Hodd_at $Hf]"); [lia|iFrame "#∗"|]. + by iIntros "!>?". } + iIntros "!> Hf !>". + wp_pures. + iApply (wp_role_fork _ tid _ _ _ ∅ {[ρEven := _]} with "[Hf] [Heven_at]"). + { apply map_disjoint_dom. rewrite !dom_singleton. set_solver. } + { rewrite map_union_comm. + - intros Hempty%map_positive_l. set_solver. + - apply map_disjoint_dom. rewrite dom_singleton. set_solver. } + { rewrite has_fuels_gt_1; last solve_fuel_positive. + rewrite !fmap_insert fmap_empty //. + rewrite insert_union_singleton_l. + rewrite map_union_comm; [done|]. + apply map_disjoint_dom. set_solver. } + { iIntros (tid') "!> Hf". + wp_pures. + 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". by iApply "HΦ". + Qed. + +End proof_start. diff --git a/fairis/examples/even_odd/even_odd_adequacy.v b/fairis/examples/even_odd/even_odd_adequacy.v new file mode 100644 index 0000000..7882a9d --- /dev/null +++ b/fairis/examples/even_odd/even_odd_adequacy.v @@ -0,0 +1,683 @@ +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.prelude Require Export finitary quantifiers sigma classical_instances. +From trillium.program_logic Require Export weakestpre. +From fairness Require Import trace_utils. +From fairis Require Import lifting adequacy fair_termination fairness_finiteness destuttering map_included_utils. +From fairis.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]. + rewrite -pred_at_or in Hfair. destruct Hfair as [Hfair | Hfair]. + - rewrite /pred_at in Hfair. destruct (after (n + m) mtr); [|done]. + rewrite /role_enabled_model in Hfair. destruct t; destruct ρ; set_solver. + - eexists. eapply pred_at_impl; [| exact Hfair]. + simpl. intros ? ? (?&->&[=]). congruence. +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 trace_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 trace_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 trace_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 trace_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 trace_valid_after in Hvalid; [|done]. + destruct (Nat.even i) eqn:Heqn. + - assert (∀ ρ : fmrole the_fair_model, fair_model_trace ρ mtr') as Hfair'. + { intros. eapply fair_by_after; eauto. apply Hfair. } + 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. eapply fair_by_after; eauto. apply Hfair. } + 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 trace_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)). + +(* TODO: move to fairness/trace_utils *) +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. + +Lemma evenodd_mtr_aux_progress_preserved + (mtr : mtrace the_fair_model) + (auxtr : auxtrace the_model) : + upto_stutter (ls_under ∘ ls_data) 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 ∘ ls_data) 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 $ ls_data s) (l ≫= Ul)). + +Lemma evenodd_mtr_aux_mono_preserved (mtr : mtrace the_fair_model) + (auxtr : auxtrace the_model) : + upto_stutter (ls_under ∘ ls_data) 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). + +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 %Hequiv [_ [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 (fm Hfmle Hfmdead Htp) "[Hδ Hfm]". + 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 length_take. + 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 → fm !! 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 (has_fuels_agree with "Hfm Hpost") as "?". } + assert (dom fm = list_to_set $ locales_of_list c.1). + { rewrite Hends in Htp. 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 Htp 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 (live_roles _ M = ∅) as Hlive. + { apply set_eq. intros i. split; [|done]. + intros (ζ&fs&HSome&Hfs)%Hfmdead. + assert (fm !! ζ = Some ∅). + { apply HMζ. + assert (ζ ∈ dom (ls_map (trace_last auxtr))) as Hin. + { destruct Hfmle as [Hfmle1 Hfmle2]. + rewrite /fuel_map_le_inner map_included_spec in Hfmle1. + apply Hfmle1 in HSome as (?&?&?). + by apply elem_of_dom. } + apply Hsmaller in Hin as [? Hin]. + rewrite Hends in Hin. + apply lookup_lt_is_Some_1. + by apply from_locale_lookup in Hin. } + by simplify_eq. } + 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/fairis/examples/yesno/yesno.v b/fairis/examples/yesno/yesno.v index 7925cd3..f96ca2c 100644 --- a/fairis/examples/yesno/yesno.v +++ b/fairis/examples/yesno/yesno.v @@ -8,7 +8,6 @@ From trillium.prelude Require Export finitary quantifiers sigma classical_instan From trillium.program_logic Require Export weakestpre. From fairness Require Import fairness. From fairis Require Import fuel lifting fair_termination proofmode heap_lang_lm. -(* From trillium.fairness.heap_lang Require Export lang lifting tactics proofmode notation. *) Import derived_laws_later.bi. From c28630a11c445c68b3ba49a8eea1220d77148208 Mon Sep 17 00:00:00 2001 From: fresheed Date: Sun, 21 Sep 2025 13:50:35 +0200 Subject: [PATCH 14/17] fixing warnings --- fairis/lifting.v | 2 +- fairness/execution_model.v | 44 ------------------------------- heap_lang/locales_helpers_hl.v | 2 +- trillium/events/event.v | 4 +-- trillium/prelude/finitary.v | 2 +- trillium/program_logic/adequacy.v | 14 +++++----- trillium/traces/infinite_trace.v | 2 +- trillium/traces/trace.v | 8 +++--- 8 files changed, 17 insertions(+), 61 deletions(-) delete mode 100644 fairness/execution_model.v diff --git a/fairis/lifting.v b/fairis/lifting.v index 993bc60..de6a0f4 100644 --- a/fairis/lifting.v +++ b/fairis/lifting.v @@ -148,7 +148,7 @@ Proof. rewrite /trace_ends_in in Hexend. rewrite Hexend. split; first by list_simplifier. apply heap_lang_locales_equiv_length. simpl. - rewrite !app_length //=. } + rewrite !length_app //=. } 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. diff --git a/fairness/execution_model.v b/fairness/execution_model.v deleted file mode 100644 index a9ab82d..0000000 --- a/fairness/execution_model.v +++ /dev/null @@ -1,44 +0,0 @@ -From stdpp Require Import fin_maps. -From iris.proofmode Require Import tactics. -From trillium Require Import language. -From trillium.program_logic Require Import traces weakestpre. -From fairness Require Import inftraces fairness. - -Class ExecutionModel (Λ: language) (M: Model) := { - - (** these two are exepcted to be typeclasses themselves *) - em_preGS: gFunctors -> Set; - em_GS: gFunctors -> Set; - - em_Σ: gFunctors; - em_Σ_subG: forall Σ, subG em_Σ Σ -> em_preGS Σ; - - em_valid_evolution_step: - cfg Λ -> olocale Λ → cfg Λ → mstate M → mlabel M → mstate M → Prop; - - em_thread_post {Σ} `{em_GS Σ}: locale Λ -> iProp Σ; - - em_msi {Σ} `{em_GS Σ}: cfg Λ -> mstate M -> iProp Σ; - - em_init_param: Type; - em_init_resource {Σ: gFunctors} `{em_GS Σ}: mstate M → em_init_param -> iProp Σ; - em_is_init_st: cfg Λ -> mstate M -> Prop; - - em_initialization Σ `{ePreGS: em_preGS Σ}: - forall (s1: mstate M) (σ: cfg Λ) (p: em_init_param) - (INIT_ST: em_is_init_st σ s1), - ⊢ (|==> ∃ eGS: em_GS Σ, @em_init_resource _ eGS s1 p ∗ @em_msi _ eGS σ s1) -}. - -Section EMDefinitions. - Context `{EM: ExecutionModel Λ M}. - - Definition em_valid_state_evolution_fairness - (extr : execution_trace Λ) (auxtr: auxiliary_trace M) := - match extr, auxtr with - | (extr :tr[oζ]: σ), auxtr :tr[ℓ]: δ => - em_valid_evolution_step (trace_last extr) oζ σ (trace_last auxtr) ℓ δ - | _, _ => True - end. - -End EMDefinitions. diff --git a/heap_lang/locales_helpers_hl.v b/heap_lang/locales_helpers_hl.v index e2cbcb1..7a77635 100644 --- a/heap_lang/locales_helpers_hl.v +++ b/heap_lang/locales_helpers_hl.v @@ -133,7 +133,7 @@ Proof. revert es10 es20 es2. induction es1 as [|e es1 IHes1]; intros es10 es20 es2 Hlen; [by destruct es2|]. destruct es2; [done|]=> /=. constructor; [done|]. - apply IHes1; [by rewrite !app_length=> /=;f_equiv|lia]. + apply IHes1; [by rewrite !length_app=> /=;f_equiv|lia]. Qed. Lemma heap_lang_locales_equiv_length (es1 es2 : list expr) : diff --git a/trillium/events/event.v b/trillium/events/event.v index 63287b7..12a1716 100644 --- a/trillium/events/event.v +++ b/trillium/events/event.v @@ -128,7 +128,7 @@ Section properties. { 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. } + rewrite !length_app //= in Heq'; lia. } destruct (length tp1' - length tp1); last first. { simpl in *. rewrite Heq1' in Heq2'; simplify_eq. @@ -329,7 +329,7 @@ Section properties. rewrite Hevs2 in Hevs'2; rewrite Hevs'2. rewrite -app_assoc. eexists; split_and!; [|done|]. - { rewrite !app_length /=; lia. } + { rewrite !length_app /=; 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'. diff --git a/trillium/prelude/finitary.v b/trillium/prelude/finitary.v index 21cdfda..bd5563d 100644 --- a/trillium/prelude/finitary.v +++ b/trillium/prelude/finitary.v @@ -86,7 +86,7 @@ Section smaller_card_nat_finite. 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. + simpl; rewrite length_app, IHn; simpl; lia. Qed. Lemma no_fin_make_list_prefix l n1 n2 : diff --git a/trillium/program_logic/adequacy.v b/trillium/program_logic/adequacy.v index 44def59..17e994f 100644 --- a/trillium/program_logic/adequacy.v +++ b/trillium/program_logic/adequacy.v @@ -14,7 +14,7 @@ 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. + rewrite !length_app /= !length_app; lia. Qed. Lemma valid_exec_length {Λ} ex (tp1 tp2 : list $ expr Λ) σ1 σ2: @@ -149,10 +149,10 @@ Section locales_helpers. - 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. + apply Forall2_length in Hequiv. rewrite !prefixes_from_length length_app /= in Hequiv. simpl in Hlen. lia. + destruct t1. - { apply Forall2_length in Hequiv. rewrite !prefixes_from_length !app_length /= in Hequiv. + { apply Forall2_length in Hequiv. rewrite !prefixes_from_length !length_app /= in Hequiv. simpl in Hlen. lia. } assert (H: locales_equiv_from (t0 ++ e :: t1) (t0' ++ a :: t1') (x :: t2) (y :: t2')). @@ -224,7 +224,7 @@ Section locales_helpers. 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 !length_app //=. } rewrite take_app_length. apply locales_equiv_middle. eapply locale_step_preserve =>//. - rewrite take_ge =>//. apply locales_equiv_refl. @@ -539,7 +539,7 @@ Section locales_utils. 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. } + by rewrite !length_skipn Hequiv. } apply locales_equiv_prefix_from_drop in Hprefix1. apply locales_equiv_prefix_from_drop in Hprefix2. apply locales_equiv_from_comm in Hprefix1. @@ -803,7 +803,7 @@ Section adequacy_helper_lemmas. + 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. + * rewrite !length_app. lia. * apply locales_equiv_snoc =>//. list_simplifier. apply locale_equiv =>//. + simpl. apply IHt =>//. simpl in Hlen1. lia. Qed. @@ -845,7 +845,7 @@ Section adequacy_helper_lemmas. (* TODO: factorize the two halves *) rewrite big_sepL2_alt; iSplit. - iIntros "H". iSplit. - { rewrite drop_app_length // map_length !prefixes_from_length //. } + { rewrite drop_app_length // length_map !prefixes_from_length //. } iInduction efs as [|ef efs] "IH" forall (t); first done. rewrite /= !drop_app_length //=. iDestruct "H" as "[H1 H]". rewrite (right_id [] (++)). iFrame. diff --git a/trillium/traces/infinite_trace.v b/trillium/traces/infinite_trace.v index 6b426a1..e12f2b3 100644 --- a/trillium/traces/infinite_trace.v +++ b/trillium/traces/infinite_trace.v @@ -131,7 +131,7 @@ Global Instance ilist_fmap : FMap inflist := Section inflist_fmap. Context {A B} (f : A → B). - Lemma inflist_fmap_length (il : inflist A) : inflist_same_length il (f <$> il). + Lemma inflist_flength_map (il : inflist A) : inflist_same_length il (f <$> il). Proof. intros n; revert il; induction n; intros il. - rewrite (inflist_unfold_fold (f <$> il)). diff --git a/trillium/traces/trace.v b/trillium/traces/trace.v index 3b677e7..6e43b26 100644 --- a/trillium/traces/trace.v +++ b/trillium/traces/trace.v @@ -274,7 +274,7 @@ Section finite_trace. ((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 length_app /= 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. @@ -284,9 +284,9 @@ Section finite_trace. ((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. + rewrite length_app /= trace_append_list_snoc /=. + rewrite map_app (lookup_app_r (_ :: _)) /=; last by rewrite length_map /=; lia. + rewrite length_map. replace (length l + 1 - S (length l)) with 0 by lia. done. Qed. From 47103dd3cdf59bab27f5664cf0ff3e4c5851a51f Mon Sep 17 00:00:00 2001 From: fresheed Date: Sun, 21 Sep 2025 13:53:50 +0200 Subject: [PATCH 15/17] sketched a new readme --- README.md | 100 ++++++++++++++++++++++++++++-------------------------- 1 file changed, 51 insertions(+), 49 deletions(-) diff --git a/README.md b/README.md index 19635ca..8f24b26 100644 --- a/README.md +++ b/README.md @@ -3,65 +3,67 @@ Trillium is a higher-order concurrent separation logic for proving trace refinements between programs and models. The logic is built using the [Iris](https://iris-project.org) program logic framework and -mechanized in the [Coq proof assistant](https://coq.inria.fr/). +mechanized in the [Coq proof assistant](https://rocq-prover.org/). ## Directory Structure - [`trillium/`](trillium/): The Trillium program logic framework -- [`fairis/`](fairis/): The Fairis instantiation of Trillium for reasoning - about fair termination of concurrent programs. - + [`heap_lang/`](fairis/heap_lang/): HeapLang instantiation with fuel model - * [`examples/`](fairis/heap_lang/examples/): Examples and case studies +- [`heap_lang/`](heap_lang/) - a variation of HeapLang language (most notably - enriched with locales) -- [`external/`](external/): External dependencies +- [`fairness/`](fairness/) - a number of various trace and model utilities; most notably - a uniform definition of trace and model fairness. -## Compiling - -The project maintains compatibility with Coq 8.17 and relies on `coqc` being -available in your shell. Clone the external git submodule dependencies using - - git submodule update --init --recursive - -Alternatively, clone the repository using the `--recurse-submodules` flag. - -Run `make -jN` to build the full development, where `N` is the number of your -CPU cores. - -Note that the compilation of the external dependencies is known to print -a lot of warning messages when compiled with Coq 8.17. +- [`fairis/`](fairis/) - The Fairis program logic - an instantiation of Trillium for reasoning about fair termination of HeapLang programs. -## Git submodule dependencies -This project uses git submodules to manage dependencies with other Coq -libraries. By default, when working with a repository that uses submodules, the -submodules will *not* be populated and updated automatically, and it is often -necessary to invoke `git submodule update --init --recursive` or use the -`--recurse-submodules` flag. However, this can be automated by setting the -`submodule.recurse` setting to `true` in your git config by running - - git config --global submodule.recurse true - -This will make `git clone`, `git checkout`, `git pull`, etc. work as you would -expect and it should rarely be necessary to invoke any `git submodule update` -commands. - -A git submodule is pinned to a particular commit of an external (remote) -repository. If new commits have been pushed to the remote repository and you -wish to integrate these in to the development, invoke - - git submodule update --remote - -to fetch the new commits and apply them to your local repository. This changes -which commit your *local* submodule is pinned to. Remember to commit and push -the submodule update to make it visible to other users of the repository. +## Compiling -Read more about git submodules in [this -tutorial](https://git-scm.com/book/en/v2/Git-Tools-Submodules). + # create a new opam environment + opam switch create trillium_env 5.2.0 + # switch into the new environment + eval $(opam env --switch=trillium_env) + + # set up repository for Rocq packages + opam repo add rocq-released https://rocq-prover.github.io/opam/released/ + + # install all dependencies of Trillium + opam install . --deps-only + # build Trillium; adjust the number of jobs as needed + make -j 5 + +## Using Trillium in your project + +The instruction below applies until Trillium is released as a publicly available opam package. + +Your project should be set up as an opam package. +With that, add the Trillium dependency to its `.opam` file: + + depends: [ + # ... + "trillium" { (= "2.2.0") } + ] + +Then, clone the Trillium repo at some local path TRILLIUM_PATH. +After that, execute the following in the root of your project: + + # create a new opam environment for your project + opam switch create project-env 5.2.0 + # switch into the new environment + eval $(opam env --switch=project-env) + + # set up repository for Rocq packages + opam repo add rocq-released https://rocq-prover.github.io/opam/released/ + # set up the local repository for Trillium + opam pin add trillium TRILLIUM_PATH --no-action + + # install all dependencies of your project; Trillium will be installed as a part of it + opam install . --deps-only + # build your project + make -j 5 + ## Publications -A [preprint](https://iris-project.org/pdfs/2021-submitted-trillium.pdf) is -available describing Trillium, a program logic framework for both proving -partial correctness properties and trace properties; Aneris is now an -instantiation of the Trillium framework. +- Trillium: Higher-Order Concurrent and Distributed Separation Logic for Intensional Refinement. + Amin Timany, Simon Oddershede Gregersen, Léo Stefanesco, Jonas Kastberg Hinrichsen, Léon Gondelman, Abel Nieto, Lars Birkedal + In POPL 2024: ACM SIGPLAN Symposium on Principles of Programming Languages From 58d95c15e6191bb7f8d8d371e23f67e332ccacac Mon Sep 17 00:00:00 2001 From: Egor Namakonov Date: Sun, 21 Sep 2025 13:56:42 +0200 Subject: [PATCH 16/17] Update README.md --- README.md | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 8f24b26..1afd37e 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ Trillium is a higher-order concurrent separation logic for proving trace refinements between programs and models. The logic is built using the [Iris](https://iris-project.org) program logic framework and -mechanized in the [Coq proof assistant](https://rocq-prover.org/). +mechanized in the [Rocq proof assistant](https://rocq-prover.org/). ## Directory Structure @@ -65,5 +65,7 @@ After that, execute the following in the root of your project: ## Publications - Trillium: Higher-Order Concurrent and Distributed Separation Logic for Intensional Refinement. - Amin Timany, Simon Oddershede Gregersen, Léo Stefanesco, Jonas Kastberg Hinrichsen, Léon Gondelman, Abel Nieto, Lars Birkedal + + Amin Timany, Simon Oddershede Gregersen, Léo Stefanesco, Jonas Kastberg Hinrichsen, Léon Gondelman, Abel Nieto, Lars Birkedal. + In POPL 2024: ACM SIGPLAN Symposium on Principles of Programming Languages From 02ee7fc38046c1c46a0cd2a9765733bea1592e59 Mon Sep 17 00:00:00 2001 From: fresheed Date: Sun, 21 Sep 2025 13:56:58 +0200 Subject: [PATCH 17/17] fixed warnings --- fairis/map_included_utils.v | 2 +- trillium/bi/weakestpre.v | 2 +- trillium/prelude/classical.v | 2 +- trillium/prelude/finitary.v | 8 ++++---- trillium/prelude/fixpoint.v | 4 ++-- trillium/prelude/quantifiers.v | 4 ++-- trillium/prelude/sigma.v | 4 ++-- trillium/traces/infinite_trace.v | 4 ++-- trillium/traces/trace_properties.v | 2 +- 9 files changed, 16 insertions(+), 16 deletions(-) diff --git a/fairis/map_included_utils.v b/fairis/map_included_utils.v index 30ac408..d7fa80a 100644 --- a/fairis/map_included_utils.v +++ b/fairis/map_included_utils.v @@ -1,4 +1,4 @@ -From Coq Require Import ssreflect. +From Stdlib Require Import ssreflect. From stdpp Require Import gmap. (* TODO: Make context, and generalise lemmas to canonical representation *) diff --git a/trillium/bi/weakestpre.v b/trillium/bi/weakestpre.v index 324f7c8..1b828cd 100644 --- a/trillium/bi/weakestpre.v +++ b/trillium/bi/weakestpre.v @@ -30,7 +30,7 @@ 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. +Arguments wp {_ _ _ _} _ _ _ %_E %_I. #[global] Instance: Params (@wp) 8 := {}. (** Notations for partial weakest preconditions *) diff --git a/trillium/prelude/classical.v b/trillium/prelude/classical.v index daf7149..bee8c05 100644 --- a/trillium/prelude/classical.v +++ b/trillium/prelude/classical.v @@ -1,4 +1,4 @@ -From Coq.Unicode Require Import Utf8. +From Stdlib.Unicode Require Import Utf8. Axiom FunExt : ∀ (A : Type) (B : A → Type) (f g : ∀ x, B x), (∀ x, f x = g x) → f = g. diff --git a/trillium/prelude/finitary.v b/trillium/prelude/finitary.v index bd5563d..8224541 100644 --- a/trillium/prelude/finitary.v +++ b/trillium/prelude/finitary.v @@ -1,5 +1,5 @@ -From Coq.Unicode Require Import Utf8. -From Coq.micromega Require Import Lia. +From Stdlib.Unicode Require Import Utf8. +From Stdlib.micromega Require Import Lia. From trillium.prelude Require Import classical quantifiers sigma classical_instances. From stdpp Require Import finite fin_sets gmap list. @@ -362,8 +362,8 @@ Section in_list_finite. End in_list_finite. -Require Import Coq.Logic.Epsilon. -Require Import Coq.Sorting.Permutation. +Require Import Stdlib.Logic.Epsilon. +Require Import Stdlib.Sorting.Permutation. Section finite_range_gmap. Context `{!EqDecision K, !Countable K}. diff --git a/trillium/prelude/fixpoint.v b/trillium/prelude/fixpoint.v index ccf39e8..5f1c62d 100644 --- a/trillium/prelude/fixpoint.v +++ b/trillium/prelude/fixpoint.v @@ -1,5 +1,5 @@ -From Coq.Unicode Require Import Utf8. -From Coq.ssr Require Import ssreflect. +From Stdlib.Unicode Require Import Utf8. +From Stdlib.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. diff --git a/trillium/prelude/quantifiers.v b/trillium/prelude/quantifiers.v index d90273f..aac6120 100644 --- a/trillium/prelude/quantifiers.v +++ b/trillium/prelude/quantifiers.v @@ -1,5 +1,5 @@ -From Coq.Unicode Require Import Utf8. -From Coq.micromega Require Import Lia. +From Stdlib.Unicode Require Import Utf8. +From Stdlib.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. diff --git a/trillium/prelude/sigma.v b/trillium/prelude/sigma.v index 8d32aac..b530533 100644 --- a/trillium/prelude/sigma.v +++ b/trillium/prelude/sigma.v @@ -1,7 +1,7 @@ -From Coq.Unicode Require Import Utf8. +From Stdlib.Unicode Require Import Utf8. From stdpp Require Import base list. From trillium.prelude Require Import classical. -From Coq.ssr Require Import ssreflect. +From Stdlib.ssr Require Import ssreflect. Lemma sig_eq {A} (P : A → Prop) (x y : sig P) : proj1_sig x = proj1_sig y → x = y. diff --git a/trillium/traces/infinite_trace.v b/trillium/traces/infinite_trace.v index e12f2b3..9ff7034 100644 --- a/trillium/traces/infinite_trace.v +++ b/trillium/traces/infinite_trace.v @@ -1,4 +1,4 @@ -From Coq.ssr Require Import ssreflect. +From Stdlib.ssr Require Import ssreflect. From stdpp Require Import prelude. Set Default Proof Using "Type". @@ -12,7 +12,7 @@ CoInductive inflist (A : Type) : Type := Bind Scope inflist_scope with inflist. Arguments infnil {_}, _. -Arguments infcons {_} _ _%inflist. +Arguments infcons {_} _ %_inflist. Module InfListNotations. Notation "[ ]" := infnil (format "[ ]") : inflist_scope. diff --git a/trillium/traces/trace_properties.v b/trillium/traces/trace_properties.v index a8e1668..dfa1455 100644 --- a/trillium/traces/trace_properties.v +++ b/trillium/traces/trace_properties.v @@ -1,5 +1,5 @@ From stdpp Require Export base prelude finite. -From Coq.ssr Require Import ssreflect. +From Stdlib.ssr Require Import ssreflect. From trillium.traces Require Import infinite_trace trace. Import InfListNotations.