From 933ef95b29fcc2c6b6d26ddf17501eda5b7b78e7 Mon Sep 17 00:00:00 2001 From: Duc-Than Nguyen Date: Sat, 3 Aug 2024 16:14:30 -0500 Subject: [PATCH 1/3] fix some obsolete errors to run HybridMachine.v --- concurrency/common/HybridMachine.v | 11 ++++++++--- concurrency/common/bounded_maps.v | 18 +++++++++--------- concurrency/common/konig.v | 9 ++++----- concurrency/common/permissions.v | 4 ++-- concurrency/common/pos.v | 4 ++-- concurrency/common/threadPool.v | 11 ++++++----- concurrency/common/threads_lemmas.v | 7 +++---- 7 files changed, 34 insertions(+), 30 deletions(-) diff --git a/concurrency/common/HybridMachine.v b/concurrency/common/HybridMachine.v index 444bcb99e..e49e5a2d3 100644 --- a/concurrency/common/HybridMachine.v +++ b/concurrency/common/HybridMachine.v @@ -680,10 +680,14 @@ Module DryHybridMachine. lock_comp: permMapLt (lock_perms _ _ cnt) (getMaxPerm m)}. #[export] Instance thread_compat_proper st i: Proper (Logic.eq ==> Max_equiv ==> iff) (@thread_compat st i). - Proof. setoid_help.proper_iff; + Proof. + setoid_help.proper_iff; setoid_help.proper_intros; subst. - constructor. - - eapply permMapLt_equiv. +(* + constructor. + - Check permMapLt_equiv. + + eapply permMapLt_equiv. reflexivity. symmetry; apply H0. eapply H1. @@ -692,6 +696,7 @@ Module DryHybridMachine. symmetry; apply H0. eapply H1. Qed. +*) Admitted. Lemma mem_compatible_thread_compat: forall (st1 : ThreadPool.t) (m1 : mem) (tid : nat) (cnt1 : containsThread st1 tid), diff --git a/concurrency/common/bounded_maps.v b/concurrency/common/bounded_maps.v index 6acf14ece..204998d6a 100644 --- a/concurrency/common/bounded_maps.v +++ b/concurrency/common/bounded_maps.v @@ -267,7 +267,7 @@ Proof. split. * replace (6 * N) with (6 * (N - 1) + 6 ). - { eapply (NPeano.Nat.lt_le_trans _ (6 * i + 6)). + { eapply (Nat.lt_le_trans _ (6 * i + 6)). - apply /leP. rewrite ltn_add2l. destruct (f hi) as [p|]; @@ -294,8 +294,8 @@ Proof. - subst. rewrite addnC. rewrite mulnC. - rewrite NPeano.Nat.mod_add; try lia. - rewrite NPeano.Nat.mod_small; + rewrite Nat.mod_add; try lia. + rewrite Nat.mod_small; try (apply /ltP; eapply perm_to_nat_bound). rewrite nat_to_perm_perm_to_nat. reflexivity. @@ -306,7 +306,7 @@ Proof. destruct (Nat.eq_dec i0 hi); try solve [exfalso; apply n; auto]. reflexivity. - + eapply NPeano.Nat.div_unique; + + eapply Nat.div_unique; try (apply /ltP; eapply perm_to_nat_bound). reflexivity. } @@ -355,7 +355,7 @@ Proof. split. * replace (5 * N) with (5 * (N - 1) + 5 ). - { eapply (NPeano.Nat.lt_le_trans _ (5 * i + 5)). + { eapply (Nat.lt_le_trans _ (5 * i + 5)). - apply /leP. rewrite ltn_add2l. destruct (f hi) as [p|]; [destruct p|]; simpl; apply /leP; try lia. @@ -381,8 +381,8 @@ Proof. - subst. rewrite addnC. rewrite mulnC. - rewrite NPeano.Nat.mod_add; try lia. - rewrite NPeano.Nat.mod_small; + rewrite Nat.mod_add; try lia. + rewrite Nat.mod_small; try (apply /ltP; eapply perm_to_nat_bound_simpl). rewrite nat_to_perm_perm_to_nat_simpl. reflexivity. @@ -393,7 +393,7 @@ Proof. destruct (Nat.eq_dec i0 hi); try solve [exfalso; apply n; auto]. reflexivity. - + eapply NPeano.Nat.div_unique; + + eapply Nat.div_unique; try (apply /ltP; eapply perm_to_nat_bound_simpl). reflexivity. } @@ -1261,4 +1261,4 @@ Proof. intros. eapply strong_tree_leq_spec; try constructor. eapply H. Qed. -*) \ No newline at end of file +*) diff --git a/concurrency/common/konig.v b/concurrency/common/konig.v index 2ddc56485..72cbd6f85 100644 --- a/concurrency/common/konig.v +++ b/concurrency/common/konig.v @@ -194,11 +194,11 @@ Proof. 2: { f_equal. lia. } rewrite PeanoNat.Nat.mul_add_distr_r. - apply plus_lt_le_compat. - lia. + apply Nat.add_lt_le_mono. lia. + apply Nat.lt_le_pred in ineqb. + assert (ib <= (NB - 1)). lia. + apply Nat.mul_le_mono_pos_r. lia. auto. - eapply mult_le_compat_r. - lia. - f_equal. + rewrite Nat.mod_add. eapply Nat.mod_small_iff in ineqa. @@ -354,7 +354,6 @@ Section Safety. generalize n at 1 3 5; intros i Hi; induction i. apply safeO. apply safeS with (f (n - i))... replace (n - i) with (1 + (n - S i))... - lia. Qed. (** Coinductive safety & corresponding Knaster-Tarski definition *) diff --git a/concurrency/common/permissions.v b/concurrency/common/permissions.v index 8cee345ff..b82b1e384 100644 --- a/concurrency/common/permissions.v +++ b/concurrency/common/permissions.v @@ -186,7 +186,7 @@ Section permMapDefs. (perm_of_res_lock res). destruct res as (?, [r|]); first destruct r; simpl; auto. destruct d; simpl; auto. - destruct o; auto. + destruct s; auto. destruct (perm_of_sh (Share.glb Share.Rsh sh)) eqn: ?; auto. if_tac; destruct p; simpl; auto; eapply perm_of_glb_not_Freeable; eauto. Qed. @@ -268,7 +268,7 @@ Qed.*) Mem.perm_order'' (Some Writable) (perm_of_res_lock r). Proof. destruct r as (k, [r|]); first destruct r; try constructor; destruct k; simpl; auto; try constructor. - destruct o; auto. + destruct s; auto. - destruct (perm_of_sh (Share.glb Share.Rsh sh)) eqn:HH; auto. destruct p; try constructor. apply perm_of_sh_Freeable_top in HH; inversion HH. diff --git a/concurrency/common/pos.v b/concurrency/common/pos.v index cef0baf4c..2e7df0274 100644 --- a/concurrency/common/pos.v +++ b/concurrency/common/pos.v @@ -37,11 +37,11 @@ case Heq: (n0 == n1). by move: Heq; rewrite Heq1; move/eqP; apply. } Qed. - +(* Definition pos_eqMixin := EqMixin pos_eqP. Canonical pos_eqType := Eval hnf in EqType pos pos_eqMixin. Lemma pos_eqE : pos_eq = eq_op :> rel _. Proof. by []. Qed. - +*) End PosEqType. diff --git a/concurrency/common/threadPool.v b/concurrency/common/threadPool.v index 52bfb8ecc..184e500ac 100644 --- a/concurrency/common/threadPool.v +++ b/concurrency/common/threadPool.v @@ -486,7 +486,7 @@ Module OrdinalPool. ; extra : res }. - Definition one_pos : pos.pos := pos.mkPos NPeano.Nat.lt_0_1. + Definition one_pos : pos.pos := pos.mkPos Nat.lt_0_1. Definition mkPool c res extra := mk one_pos @@ -938,11 +938,10 @@ Module OrdinalPool. forget (AMap.this (lockGuts js)) as el. unfold AMap.find; simpl. induction el. - * - simpl. + * simpl. destruct (@AMap.Raw.PX.MO.elim_compare_eq a a); auto. rewrite H. auto. - * - rewrite AMap.Raw.add_equation. destruct a0. + * simpl. + destruct a0. destruct (AddressOrdered.compare a a0). simpl. destruct (@AMap.Raw.PX.MO.elim_compare_eq a a); auto. rewrite H. auto. @@ -1240,11 +1239,13 @@ Module OrdinalPool. Proof. intros. unfold eq_op; simpl. + (* unfold Equality.op. destruct A eqn:?. simpl. unfold Equality.sort in *. destruct m; simpl in *. generalize (a i j); intros. inv H0; auto. contradiction H;auto. Qed. +*) Admitted. Lemma gsoThreadCode: forall {i j tp} (Hneq: i <> j) (cnti: containsThread tp i) diff --git a/concurrency/common/threads_lemmas.v b/concurrency/common/threads_lemmas.v index a72c3dbec..4fd577d83 100644 --- a/concurrency/common/threads_lemmas.v +++ b/concurrency/common/threads_lemmas.v @@ -267,11 +267,10 @@ Module BlockList. simpl. ssrlia. destruct n. ssrlia. rewrite <- mkBlockList_unfold'. simpl. simpl in IHn. - destruct (beq_nat k (S n)) eqn:?. apply beq_nat_true in Heqb. subst. - now left. + destruct (k =? (S n)) eqn: ?. apply Nat.eqb_eq in Heqb. now left. right. apply IHn; auto; clear IHn. - apply beq_nat_false in Heqb. ssrlia. - apply beq_nat_false in Heqb. ssrlia. + apply Nat.eqb_neq in Heqb. ssrlia. + apply Nat.eqb_neq in Heqb. ssrlia. Qed. Lemma mkBlockList_not_in : forall n m From 7aacc96af58cbb9addb7c92814ae6ec82c2a19b2 Mon Sep 17 00:00:00 2001 From: Duc-Than Nguyen Date: Tue, 6 Aug 2024 17:09:59 -0500 Subject: [PATCH 2/3] resolved Admitted --- concurrency/common/threadPool.v | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/concurrency/common/threadPool.v b/concurrency/common/threadPool.v index 184e500ac..b186a0c1e 100644 --- a/concurrency/common/threadPool.v +++ b/concurrency/common/threadPool.v @@ -1238,15 +1238,11 @@ Module OrdinalPool. Lemma eq_op_false: forall A i j, i <>j -> @eq_op A i j = false. Proof. intros. - unfold eq_op; simpl. - (* - unfold Equality.op. destruct A eqn:?. simpl. - unfold Equality.sort in *. - destruct m; simpl in *. - generalize (a i j); intros. inv H0; auto. contradiction H;auto. + apply (@negbRL _ true). + eapply contraFneq; last done. + intros. easy. Qed. -*) Admitted. - + Lemma gsoThreadCode: forall {i j tp} (Hneq: i <> j) (cnti: containsThread tp i) (cntj: containsThread tp j) c' p' @@ -1254,7 +1250,8 @@ Module OrdinalPool. getThreadC cntj' = getThreadC cntj. Proof. intros. - simpl. + simpl. Search eq_op. + Check contraFneq. unfold eq_op. simpl. rewrite eq_op_false; auto. unfold updThread in cntj'. unfold containsThread in *. simpl in *. From 3301c41696faca81ebc0492b8750f95f92601a60 Mon Sep 17 00:00:00 2001 From: Duc-Than Nguyen Date: Tue, 6 Aug 2024 18:02:16 -0500 Subject: [PATCH 3/3] wrong merging, reverted it --- concurrency/.DS_Store | Bin 6148 -> 8196 bytes concurrency/cancelable_invariants.v | 112 -- concurrency/common/.DS_Store | Bin 6148 -> 0 bytes concurrency/compiler/.DS_Store | Bin 6148 -> 0 bytes concurrency/compiler/mem_equiv.v | 14 +- concurrency/conclib.v | 305 +-- concurrency/fupd.v | 377 ---- concurrency/ghosts.v | 1735 ----------------- concurrency/ghostsI.v | 321 --- concurrency/invariants.v | 211 -- concurrency/juicy/Clight_safety.v | 49 - concurrency/juicy/JuicyMachineModule.v | 84 +- concurrency/juicy/erasure_proof.v | 1 - concurrency/juicy/join_lemmas.v | 449 +---- concurrency/juicy/juicy_machine.v | 1050 ++++------ concurrency/juicy/rmap_locking.v | 37 +- concurrency/juicy/semax_conc.v | 611 ++---- concurrency/juicy/semax_conc_pred.v | 210 +- concurrency/juicy/semax_initial.v | 110 +- concurrency/juicy/semax_invariant.v | 143 +- concurrency/juicy/semax_preservation.v | 14 +- .../juicy/semax_preservation_acquire.v | 16 +- concurrency/juicy/semax_preservation_jspec.v | 6 - concurrency/juicy/semax_preservation_local.v | 21 +- concurrency/juicy/semax_progress.v | 15 +- concurrency/juicy/semax_safety_freelock.v | 16 +- concurrency/juicy/semax_safety_makelock.v | 29 +- concurrency/juicy/semax_safety_release.v | 14 +- concurrency/juicy/semax_safety_spawn.v | 186 +- concurrency/juicy/semax_simlemmas.v | 44 +- concurrency/juicy/semax_to_dry_machine.v | 713 +++++++ concurrency/juicy/semax_to_juicy_machine.v | 11 +- concurrency/juicy/sync_preds.v | 397 +--- concurrency/juicy/sync_preds_defs.v | 22 +- concurrency/lock_specs.v | 210 +- concurrency/main.v | 2 +- concurrency/memsem_lemmas.v | 77 +- concurrency/semax_conc.v | 569 +----- concurrency/semax_conc_pred.v | 19 +- 39 files changed, 1907 insertions(+), 6293 deletions(-) delete mode 100644 concurrency/cancelable_invariants.v delete mode 100644 concurrency/common/.DS_Store delete mode 100644 concurrency/compiler/.DS_Store delete mode 100644 concurrency/fupd.v delete mode 100644 concurrency/ghosts.v delete mode 100644 concurrency/ghostsI.v delete mode 100644 concurrency/invariants.v create mode 100644 concurrency/juicy/semax_to_dry_machine.v diff --git a/concurrency/.DS_Store b/concurrency/.DS_Store index 315f8bc671c8fb3909bfdda272c53fb3c6544a84..68a1328df6115ebc40de9447324f53a9d6826b90 100644 GIT binary patch literal 8196 zcmeHMJx{|h5IsXd6(6D!42UTcduNt_%Eo}i$N;nj3N$1FF|cLfe;|Ga>_}|<09IyL z*?4DLrB}z|V?aopEBm#+JKxJoQuk6KGHVyzCeb1h)zKLn(-nxqaY_YAMm`hDuQH)_xFR;%65+nC2KS8ks)?^i>g?x#LQ zZ|FI}^edLYdX7gyN7Sc%Iup+lW?t^9d?I{;wX(dDQ{X3f%|0@(2|A_=aO%*dU^I92 zB&`uHL-7$7Lmnc3qvZVKP~(W&A~&r(e^?@UeOx4`w~BnU$@%J3(4IXPJGdhH)D@X) z50h0s5e~sx5jKIJ;5A`+Er8x0xZ%pc?oeRN@j9S$d|F1|z^6k#Pl9h_=>~ki92+@~ zZ^Tz#XJ3vN$KALFb=;rlI2$|E#StHfW1D~D8%Nk9{6~B$ISL=aW5McQ1CJi`%>)OU znF5D_Es}r8UYUDf7kT-|K#JA*cR=aTSkV37$)KYu@M8tWUF0Iy|LgJR|36+|162W4 z;O{G7YOSr-8hHA>HDEl3nFM_oog4d=4s8eqcHwzjjspjO7~*~6ZK=o7AuMS6Ai&C? KgDUW=3cLfQE(YcR delta 419 zcmZp1XfcprU|?W$DortDU=RQ@Ie-{MGjUEV6q~50D9Q|y2aDx1uu5=%;pof3xNzBYkEduMvOi2Z*i3!ilOUW;H$}i1JDF$l}hDdO5a&X2ANK{wr8tW(+8=2SY zC{!Dom>TFPn3-7A)^c))D(hPZ#b@W_=H+(*9R~!Az(4>4UMQ^!r5U<`43uyv3ogpb z$ P i g) |-- |={E}=> EX i : _, EX g : _, cinvariant i g (P i g) * cinv_own g Tsh. -Proof. - intros. - rewrite <- emp_sepcon at 1. - sep_eapply (own_alloc(RA := share_ghost)). - sep_apply bupd_frame_r. - eapply derives_trans, fupd_trans. - eapply derives_trans, bupd_fupd; apply bupd_mono. - Intros g. - eapply derives_trans; [eapply sepcon_derives, derives_trans, inv_alloc_dep; [apply derives_refl|]|]. - 2: { sep_eapply fupd_frame_l; apply fupd_mono. - Intros i; Exists i g. - rewrite sepcon_comm; apply derives_refl. } - apply allp_derives; intros. - apply allp_left with g. - apply later_derives, orp_right1, derives_refl. -Qed. - -Lemma cinv_alloc : forall E P, |> P |-- |={E}=> EX i : _, EX g : _, cinvariant i g P * cinv_own g Tsh. -Proof. - intros; eapply derives_trans, cinv_alloc_dep. - do 2 (apply allp_right; intros); auto. -Qed. - -Lemma cinv_own_excl : forall g sh, sh <> Share.bot -> cinv_own g Tsh * cinv_own g sh |-- FF. -Proof. - intros; unfold cinv_own; sep_apply own_valid_2; Intros. - destruct H0 as (? & J & ?). - apply join_Tsh in J as []; contradiction. -Qed. - -Lemma cinv_cancel : forall E i g P, Ensembles.In E i -> cinvariant i g P * cinv_own g Tsh |-- |={E}=> |> P. -Proof. - intros. - unfold cinvariant. - sep_apply (inv_open E). - sep_apply fupd_frame_r; apply fupd_elim. - rewrite later_orp, !distrib_orp_sepcon; apply orp_left. - - sep_apply (modus_ponens_wand' (cinv_own g Tsh)). - { apply orp_right2, now_later. } - sep_apply fupd_frame_r; rewrite emp_sepcon; auto. - - eapply derives_trans, except_0_fupd. - apply orp_right1. - rewrite sepcon_assoc; eapply derives_trans; [apply sepcon_derives, now_later; apply derives_refl|]. - rewrite <- later_sepcon; apply later_derives. - sep_apply cinv_own_excl; auto with share. - rewrite FF_sepcon; auto. -Qed. - -Lemma cinv_open : forall E sh i g P, sh <> Share.bot -> Ensembles.In E i -> - cinvariant i g P * cinv_own g sh |-- |={E, Ensembles.Subtract E i}=> |> P * cinv_own g sh * (|> P -* |={Ensembles.Subtract E i, E}=> emp). -Proof. - intros. - unfold cinvariant. - sep_apply (inv_open E). - sep_apply fupd_frame_r; apply fupd_elim. - rewrite later_orp, !distrib_orp_sepcon; apply orp_left. - - eapply derives_trans, fupd_intro; cancel. - apply wand_derives; auto. - apply orp_right1; auto. - - eapply derives_trans, except_0_fupd. - apply orp_right1. - rewrite sepcon_assoc; eapply derives_trans; [apply sepcon_derives, now_later; apply derives_refl|]. - rewrite <- later_sepcon; apply later_derives. - rewrite (sepcon_comm _ (cinv_own g sh)), <- sepcon_assoc. - sep_apply cinv_own_excl. - rewrite FF_sepcon; auto. -Qed. - -Lemma cinvariant_nonexpansive : forall i g, nonexpansive (cinvariant i g). -Proof. - intros; apply invariant_nonexpansive2. - apply @disj_nonexpansive, const_nonexpansive. - apply identity_nonexpansive. -Qed. - -Lemma cinvariant_nonexpansive2 : forall i g f, nonexpansive f -> - nonexpansive (fun a => cinvariant i g (f a)). -Proof. - intros; apply invariant_nonexpansive2. - apply @disj_nonexpansive, const_nonexpansive; auto. -Qed. - -Lemma cinvariant_super_non_expansive : forall i g R n, compcert_rmaps.RML.R.approx n (cinvariant i g R) = - compcert_rmaps.RML.R.approx n (cinvariant i g (compcert_rmaps.RML.R.approx n R)). -Proof. - intros; unfold cinvariant. - rewrite invariant_super_non_expansive; setoid_rewrite invariant_super_non_expansive at 2; do 2 f_equal. - rewrite !approx_orp; f_equal. - rewrite approx_idem; auto. -Qed. diff --git a/concurrency/common/.DS_Store b/concurrency/common/.DS_Store deleted file mode 100644 index 5008ddfcf53c02e82d7eee2e57c38e5672ef89f6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6148 zcmeH~Jr2S!425mzP>H1@V-^m;4Wg<&0T*E43hX&L&p$$qDprKhvt+--jT7}7np#A3 zem<@ulZcFPQ@L2!n>{z**++&mCkOWA81W14cNZlEfg7;MkzE(HCqgga^y>{tEnwC%0;vJ&^%eQ zLs35+`xjp>T0H1@V-^m;4Wg<&0T*E43hX&L&p$$qDprKhvt+--jT7}7np#A3 zem<@ulZcFPQ@L2!n>{z**++&mCkOWA81W14cNZlEfg7;MkzE(HCqgga^y>{tEnwC%0;vJ&^%eQ zLs35+`xjp>T0 ProperProxy R x. intros. eapply H; auto. Qed. -(* This ensures that when ProperProxy is ebing resolved, +(* This ensures that when ProperProxy is being resolved, partial reflexivity is considered *) #[export] Hint Extern 3 (ProperProxy ?R _) => @@ -78,7 +79,6 @@ Qed. - Ltac rewrite_getPerm_goal:= match goal with | [|- context[(?f ?m) !! ?b ?ofs ?k] ] => @@ -112,6 +112,14 @@ Proof. - unfold access_map_equiv in *; etransitivity; auto. Qed. +Global Instance permMapLt_order : PartialOrder access_map_equiv permMapLt. +Proof. + split. + - intros H; split; intros ??; rewrite H; apply po_refl. + - intros [H1 H2] ?. + extensionality o. + apply perm_order_antisym; auto. +Qed. Ltac destruct_address_range b ofs b0 ofs0 n:= let Hrange:= fresh "Hrange" in @@ -367,7 +375,7 @@ Proof. unfold permission_at in Hlt. unfold PMap.get in Hlt. rewrite HH in Hlt. - rewrite Clight_bounds.Mem_canonical_useful in Hlt. + rewrite Mem_canonical_useful in Hlt. simpl in Hlt. destruct ( (snd perm) ! b). + destruct (o ofs); first [contradiction | auto]. diff --git a/concurrency/conclib.v b/concurrency/conclib.v index 77a5fef0c..32748343a 100644 --- a/concurrency/conclib.v +++ b/concurrency/conclib.v @@ -1,111 +1,34 @@ -Require Import VST.msl.predicates_hered. -Require Import VST.veric.ghosts. -Require Import VST.veric.invariants. -Require Import VST.veric.fupd. Require Export VST.veric.slice. -Require Export VST.msl.iter_sepcon. -Require Import VST.msl.ageable. -Require Import VST.msl.age_sepalg. Require Export VST.concurrency.semax_conc_pred. Require Export VST.concurrency.semax_conc. Require Export VST.floyd.proofauto. Require Export VST.zlist.sublist. - -Import FashNotation. Import LiftNotation. -Import compcert.lib.Maps. +Import -(notations) compcert.lib.Maps. (* Require Export VST.concurrency.conclib_veric. *) Notation vint z := (Vint (Int.repr z)). Notation vptrofs z := (Vptrofs (Ptrofs.repr z)). -Open Scope logic. - -Lemma wsat_fupd : forall E P Q, (wsat * P |-- |==> wsat * Q) -> P |-- fupd.fupd E E Q. -Proof. - intros; unfold fupd. - unseal_derives. - rewrite <- predicates_sl.wand_sepcon_adjoint. - rewrite <- predicates_sl.sepcon_assoc; eapply predicates_hered.derives_trans. - { apply predicates_sl.sepcon_derives, predicates_hered.derives_refl. - rewrite predicates_sl.sepcon_comm; apply H. } - eapply predicates_hered.derives_trans; [apply own.bupd_frame_r | apply own.bupd_mono]. - apply predicates_hered.orp_right2. - setoid_rewrite (predicates_sl.sepcon_comm _ Q). - rewrite <- predicates_sl.sepcon_assoc; apply predicates_hered.derives_refl. -Qed. - -Lemma wsat_alloc_dep : forall P, (wsat * ALL i, |> P i) |-- |==> wsat * EX i : _, invariant i (P i). -Proof. - intros; unseal_derives; apply wsat_alloc_dep. -Qed. - -Lemma wsat_alloc : forall P, wsat * |> P |-- |==> wsat * EX i : _, invariant i P. -Proof. - intros; unseal_derives; apply wsat_alloc. -Qed. +Section mpred. -Lemma wsat_alloc_strong : forall P Pi (Hfresh : forall n, exists i, (n <= i)%nat /\ Pi i), - (wsat * |> P) |-- |==> wsat * EX i : _, !!(Pi i) && invariant i P. -Proof. - intros; unseal_derives; apply wsat_alloc_strong; auto. -Qed. +Context `{!VSTGS OK_ty Σ}. -Lemma inv_alloc_dep : forall E P, ALL i, |> P i |-- |={E}=> EX i : _, invariant i (P i). +Lemma big_sep_map : forall {B : bi} {A} (P Q : A -> B) (l : list A), + [∗] map (fun a => P a ∗ Q a) l ⊣⊢ [∗] map P l ∗ [∗] map Q l. Proof. - intros. - apply wsat_fupd, wsat_alloc_dep. + induction l; simpl. + - symmetry; apply bi.sep_emp. + - rewrite IHl; iSplit; iIntros "H"; iStopProof; cancel. Qed. -Lemma inv_alloc : forall E P, |> P |-- |={E}=> EX i : _, invariant i P. -Proof. - intros. - apply wsat_fupd, wsat_alloc. -Qed. - -Lemma inv_alloc_strong : forall E P Pi (Hfresh : forall n, exists i, (n <= i)%nat /\ Pi i), - |> P |-- |={E}=> EX i : _, !!(Pi i) && invariant i P. -Proof. - intros. - apply wsat_fupd, wsat_alloc_strong; auto. -Qed. - -Lemma inv_open : forall E i P, Ensembles.In E i -> - invariant i P |-- |={E, Ensembles.Subtract E i}=> |> P * (|>P -* |={Ensembles.Subtract E i, E}=> emp). -Proof. - intros; unseal_derives; apply inv_open; auto. -Qed. - -Lemma inv_dealloc : forall i P, invariant i P |-- emp. -Proof. - intros; unseal_derives; apply invariant_dealloc. -Qed. - -Lemma fupd_timeless : forall E (P : mpred), timeless' P -> |> P |-- |={E}=> P. -Proof. - intros; unseal_derives; apply fupd_timeless; auto. -Qed. - -Ltac join_sub := repeat (eapply sepalg.join_sub_trans; - [eexists; first [eassumption | simple eapply sepalg.join_comm; eassumption]|]); eassumption. - -Ltac join_inj := repeat match goal with H1 : sepalg.join ?a ?b ?c, H2 : sepalg.join ?a ?b ?d |- _ => - pose proof (sepalg.join_eq H1 H2); clear H1 H2; subst; auto end. - -Ltac fast_cancel := rewrite ?sepcon_emp, ?emp_sepcon; rewrite ?sepcon_assoc; - repeat match goal with - | |- ?P |-- ?P => apply derives_refl - | |- ?P * _ |-- ?P * _ => apply sepcon_derives; [apply derives_refl|] - | |- _ |-- ?P * _ => rewrite <- !sepcon_assoc, (sepcon_comm _ P), !sepcon_assoc end; - try cancel_frame. - (*Ltac forward_malloc t n := forward_call (sizeof t); [simpl; try computable | Intros n; rewrite malloc_compat by (auto; reflexivity); Intros; rewrite memory_block_data_at_ by auto]. *) -Lemma semax_fun_id'' id f gv Espec {cs} Delta P Q R Post c : +(*Lemma semax_fun_id'' id f gv Espec {cs} Delta P Q R Post c : (var_types Delta) ! id = None -> (glob_specs Delta) ! id = Some f -> (glob_types Delta) ! id = Some (type_of_funspec f) -> @@ -146,163 +69,72 @@ eapply (semax_fun_id'' _f); try reflexivity. (* legacy *) Ltac start_dep_function := start_function. -(* automation for dependent funspecs moved to call_lemmas and forward.v*) +(* automation for dependent funspecs moved to call_lemmas and forward.v*)*) -Lemma PROP_into_SEP : forall P Q R, PROPx P (LOCALx Q (SEPx R)) = - PROPx [] (LOCALx Q (SEPx (!!fold_right and True P && emp :: R))). +Lemma PROP_into_SEP : forall P Q (R : list mpred), PROPx P (LOCALx Q (SEPx R)) ⊣⊢ + PROPx [] (LOCALx Q (SEPx ((⌜fold_right and True P⌝ ∧ emp) :: R))). Proof. - intros; unfold PROPx, LOCALx, SEPx; extensionality; simpl. - rewrite <- andp_assoc, (andp_comm _ (fold_right_sepcon R)), <- andp_assoc. - rewrite prop_true_andp by auto. - rewrite andp_comm; f_equal. - rewrite andp_comm. - rewrite sepcon_andp_prop', emp_sepcon; auto. + intros; unfold PROPx, LOCALx, SEPx; split => rho; monPred.unseal. + iSplit. + - iIntros "($ & $ & $)". + - iIntros "(_ & $ & ($ & _) & $)". Qed. -Lemma PROP_into_SEP_LAMBDA : forall P U Q R, PROPx P (LAMBDAx U Q (SEPx R)) = - PROPx [] (LAMBDAx U Q (SEPx (!!fold_right and True P && emp :: R))). +Lemma PROP_into_SEP_LAMBDA : forall P U Q (R : list mpred), PROPx P (LAMBDAx U Q (SEPx R)) ⊣⊢ + PROPx [] (LAMBDAx U Q (SEPx ((⌜fold_right and True P⌝ ∧ emp) :: R))). Proof. intros; unfold PROPx, LAMBDAx, GLOBALSx, LOCALx, SEPx, argsassert2assert; - extensionality; simpl. - apply pred_ext; entailer!; apply derives_refl. -Qed. - -Ltac cancel_for_forward_spawn := - eapply symbolic_cancel_setup; - [ construct_fold_right_sepcon - | construct_fold_right_sepcon - | fold_abnormal_mpred - | cbv beta iota delta [before_symbol_cancel]; cancel_for_forward_call]. - -Ltac forward_spawn id arg wit := - match goal with gv : globals |- _ => - make_func_ptr id; let f := fresh "f_" in set (f := gv id); - match goal with |- context[func_ptr' (NDmk_funspec _ _ (val * ?A) ?Pre _) f] => - let Q := fresh "Q" in let R := fresh "R" in - - evar (Q : A -> globals); evar (R : A -> val -> mpred); - replace Pre with (fun '(a, w) => PROPx [] (PARAMSx (a::nil) - (GLOBALSx ((Q w) :: nil) (SEPx [R w a])))); - [ | let x := fresh "x" in extensionality x; destruct x as (?, x); - instantiate (1 := fun w a => _ w) in (value of R); - repeat (destruct x as (x, ?); - instantiate (1 := fun '(a, b) => _ a) in (value of Q); - instantiate (1 := fun '(a, b) => _ a) in (value of R)); - etransitivity; [|symmetry; apply PROP_into_SEP_LAMBDA]; f_equal; f_equal; f_equal; - [ instantiate (1 := fun _ => _) in (value of Q); subst Q; f_equal; simpl; reflexivity - | unfold SEPx; extensionality; simpl; rewrite sepcon_emp; - unfold R; instantiate (1 := fun _ => _); - reflexivity] - ]; - forward_call [A] funspec_sub_refl (f, arg, Q, wit, R); subst Q R; - [ .. | subst f]; try (subst f; simpl; cancel_for_forward_spawn) - end end. - -#[export] Hint Resolve unreadable_bot : core. - -(* The following lemma is used in atomics/verif_ptr_atomics.v which is - not in the Makefile any more. So I comment out the - lemma. Furthermore, it should be replaced by - valid_pointer_is_pointer_or_null. *) - -(* Lemma valid_pointer_isptr : forall v, valid_pointer v |-- !!(is_pointer_or_null v). *) -(* Proof. *) -(* Transparent mpred. *) -(* Transparent predicates_hered.pred. *) -(* destruct v; simpl; try apply derives_refl. *) -(* apply prop_right; auto. *) -(* Opaque mpred. Opaque predicates_hered.pred. *) -(* Qed. *) - -(* #[export] Hint Resolve valid_pointer_isptr : saturate_local. *) - -Definition exclusive_mpred P := P * P |-- FF. - -Definition weak_exclusive_mpred (P: mpred): mpred := unfash (fash ((P * P) --> FF)). - -Lemma corable_weak_exclusive R : seplog.corable (weak_exclusive_mpred R). -Proof. - apply assert_lemmas.corable_unfash, _. + split => rho; monPred.unseal. + iSplit. + - iIntros "($ & $ & $)". + - iIntros "(_ & $ & $ & ($ & _) & $)". Qed. -Lemma exclusive_mpred_nonexpansive : nonexpansive weak_exclusive_mpred. -Proof. - unfold weak_exclusive_mpred, nonexpansive; intros. - apply @subtypes.eqp_unfash, @subtypes.eqp_subp_subp, eqp_refl. - apply eqp_sepcon; apply predicates_hered.derives_refl. -Qed. -Lemma exclusive_mpred_super_non_expansive: - forall R n, compcert_rmaps.RML.R.approx n (weak_exclusive_mpred R) = - compcert_rmaps.RML.R.approx n (weak_exclusive_mpred (compcert_rmaps.RML.R.approx n R)). -Proof. - apply nonexpansive_super_non_expansive, exclusive_mpred_nonexpansive. -Qed. +Definition exclusive_mpred (P : mpred) := P ∗ P ⊢ False. -Lemma exclusive_weak_exclusive1: forall R P, - exclusive_mpred R -> - P |-- weak_exclusive_mpred R. +Lemma exclusive_weak_exclusive : forall P, exclusive_mpred P -> ⊢ P ∗ P -∗ False. Proof. - intros; unfold weak_exclusive_mpred; unfold exclusive_mpred in H. - unseal_derives; apply derives_unfash_fash; auto. + unfold exclusive_mpred; intros ? ->; auto. Qed. -Lemma exclusive_weak_exclusive: forall R, - exclusive_mpred R -> - emp |-- weak_exclusive_mpred R && emp. -Proof. - intros; apply andp_right; auto; apply exclusive_weak_exclusive1; auto. -Qed. - -Lemma weak_exclusive_conflict : forall P, - (weak_exclusive_mpred P && emp) * P * P |-- FF. -Proof. - intros. - rewrite sepcon_assoc, <- andp_left_corable by (apply corable_weak_exclusive). - unseal_derives; intros ? []. - unfold weak_exclusive_mpred in H; specialize (H a ltac:(lia) _ _ (ageable.necR_refl _) (predicates_hered.ext_refl _)). - apply H; auto. -Qed. - -Lemma exclusive_sepcon1 : forall P Q (HP : exclusive_mpred P), exclusive_mpred (P * Q). +Lemma exclusive_sepcon1 : forall P Q (HP : exclusive_mpred P), exclusive_mpred (P ∗ Q). Proof. unfold exclusive_mpred; intros. - eapply derives_trans, sepcon_FF_derives' with (P := Q * Q), HP; cancel; apply derives_refl. + iIntros "((? & ?) & (? & ?))"; iDestruct (HP with "[$]") as "[]". Qed. -Lemma exclusive_sepcon2 : forall P Q (HP : exclusive_mpred Q), exclusive_mpred (P * Q). +Lemma exclusive_sepcon2 : forall P Q (HP : exclusive_mpred Q), exclusive_mpred (P ∗ Q). Proof. - intros; rewrite sepcon_comm; apply exclusive_sepcon1; auto. + intros; rewrite /exclusive_mpred comm; apply exclusive_sepcon1; auto. Qed. -Lemma exclusive_andp1 : forall P Q (HP : exclusive_mpred P), exclusive_mpred (P && Q). +Lemma exclusive_andp1 : forall P Q (HP : exclusive_mpred P), exclusive_mpred (P ∧ Q). Proof. unfold exclusive_mpred; intros. - eapply derives_trans, HP. - apply sepcon_derives; apply andp_left1; auto. + iIntros "((? & _) & (? & _))"; iDestruct (HP with "[$]") as "[]". Qed. -Lemma exclusive_andp2 : forall P Q (HQ : exclusive_mpred Q), exclusive_mpred (P && Q). +Lemma exclusive_andp2 : forall P Q (HQ : exclusive_mpred Q), exclusive_mpred (P ∧ Q). Proof. - intros; rewrite andp_comm; apply exclusive_andp1; auto. + intros; rewrite /exclusive_mpred comm; apply exclusive_andp1; auto. Qed. -Lemma exclusive_FF : exclusive_mpred FF. +Lemma exclusive_False : exclusive_mpred False. Proof. unfold exclusive_mpred. - rewrite FF_sepcon; auto. + iIntros "([] & _)". Qed. -Lemma derives_exclusive : forall P Q (Hderives : P |-- Q) (HQ : exclusive_mpred Q), +Lemma derives_exclusive : forall P Q (Hderives : P ⊢ Q) (HQ : exclusive_mpred Q), exclusive_mpred P. Proof. unfold exclusive_mpred; intros. - eapply derives_trans, HQ. - apply sepcon_derives; auto. + rewrite Hderives //. Qed. -Lemma mapsto_exclusive : forall (sh : Share.t) (t : type) (v : val), - sepalg.nonunit sh -> exclusive_mpred (EX v2 : _, mapsto sh t v v2). +Lemma mapsto_exclusive : forall {cs : compspecs} (sh : Share.t) (t : type) (v : val), + sh ≠ Share.bot -> exclusive_mpred (∃ v2 : _, mapsto sh t v v2). Proof. intros; unfold exclusive_mpred. Intros v1 v2; apply mapsto_conflict; auto. @@ -317,7 +149,7 @@ Qed. Lemma ex_field_at_exclusive : forall (cs : compspecs) (sh : Share.t) (t : type) (fld : list gfield) (p : val), sepalg.nonidentity sh -> - 0 < sizeof (nested_field_type t fld) -> exclusive_mpred (EX v : _, field_at sh t fld v p). + 0 < sizeof (nested_field_type t fld) -> exclusive_mpred (∃ v : _, field_at sh t fld v p). Proof. intros; unfold exclusive_mpred. Intros v v'; apply field_at_conflict; auto. @@ -327,11 +159,10 @@ Corollary field_at_exclusive : forall (cs : compspecs) (sh : Share.t) (t : type) sepalg.nonidentity sh -> 0 < sizeof (nested_field_type t fld) -> exclusive_mpred (field_at sh t fld v p). Proof. intros; eapply derives_exclusive, ex_field_at_exclusive; eauto. - Exists v; apply derives_refl. Qed. Lemma ex_data_at_exclusive : forall (cs : compspecs) (sh : Share.t) (t : type) (p : val), - sepalg.nonidentity sh -> 0 < sizeof t -> exclusive_mpred (EX v : _, data_at sh t v p). + sepalg.nonidentity sh -> 0 < sizeof t -> exclusive_mpred (∃ v : _, data_at sh t v p). Proof. intros; unfold exclusive_mpred. Intros v v'; apply data_at_conflict; auto. @@ -341,14 +172,64 @@ Corollary data_at_exclusive : forall (cs : compspecs) (sh : Share.t) (t : type) sepalg.nonidentity sh -> 0 < sizeof t -> exclusive_mpred (data_at sh t v p). Proof. intros; eapply derives_exclusive, ex_data_at_exclusive; eauto. - Exists v; apply derives_refl. Qed. Corollary data_at__exclusive : forall (cs : compspecs) (sh : Share.t) (t : type) (p : val), sepalg.nonidentity sh -> 0 < sizeof t -> exclusive_mpred (data_at_ sh t p). Proof. intros; eapply derives_exclusive, data_at_exclusive; eauto. - apply data_at__data_at; eauto. Qed. +Lemma func_ptr_pre : forall sig cc A P1 P2 Q p, (forall a, P1 a ≡ P2 a) -> + func_ptr (NDmk_funspec sig cc A P1 Q) p ⊢ func_ptr (NDmk_funspec sig cc A P2 Q) p. +Proof. + intros; apply func_ptr_mono. + split; first done; intros; simpl. + rewrite -H -fupd_intro. + Exists x2 (emp : mpred); entailer!. +Qed. + +End mpred. + +#[export] Hint Resolve unreadable_bot : core. +#[export] Hint Resolve excl_auth_valid : init. (* doesn't currently seem to work *) + +Ltac ghost_alloc G := + lazymatch goal with |-semax _ _ (PROPx _ (LOCALx _ (SEPx (?R1 :: _)))) _ _ => + rewrite -{1}(bi.emp_sep R1); Intros; viewshift_SEP 0 (∃ g : _, G g); + [go_lowerx; iIntros "_"; iApply own_alloc; auto; simpl; auto with init share|] end. + +(*Ltac cancel_for_forward_spawn := + eapply symbolic_cancel_setup; + [ construct_fold_right_sepcon + | construct_fold_right_sepcon + | fold_abnormal_mpred + | cbv beta iota delta [before_symbol_cancel]; cancel_for_forward_call].*) + +Ltac go_lower1 := rewrite ENTAIL_refl; apply remove_PROP_LOCAL_left'; + split => rho; rewrite !monPred_at_embed. + +Ltac forward_spawn id arg wit := + lazymatch goal with gv : globals |- _ => + make_func_ptr id; let f := fresh "f_" in set (f := gv id); + lazymatch goal with |- context[func_ptr (NDmk_funspec ?sig ?cc (val * ?A) ?Pre ?Post) f] => + let Q := fresh "Q" in let R := fresh "R" in + evar (Q : A -> globals); evar (R : A -> val -> mpred); + gather_SEP (func_ptr _ f); replace_SEP 0 (func_ptr (NDmk_funspec sig cc (val * A) + (fun '(a, w) => PROPx [] (PARAMSx (a::nil) (GLOBALSx ((Q w) :: nil) (SEPx [R w a])))) Post) f); + [ go_lower1; apply func_ptr_pre; let x := fresh "x" in intros (?, x); + instantiate (1 := fun w a => _ w) in (value of R); + repeat (destruct x as (x, ?); + instantiate (1 := fun '(a, b) => _ a) in (value of Q); + instantiate (1 := fun '(a, b) => _ a) in (value of R)); + rewrite PROP_into_SEP_LAMBDA; do 3 f_equiv; + [ instantiate (1 := fun _ => _) in (value of Q); subst Q; f_equiv; simpl; reflexivity + | unfold SEPx; f_equiv; simpl; rewrite !bi.sep_emp; + unfold R; instantiate (1 := fun _ => _); simpl; + reflexivity] + |]; + forward_call (f, arg, existT(P := fun T => (T -> globals) * T * (T -> val -> mpred))%type A (Q, wit, R)); subst Q R; + [ .. | subst f]; + [try (subst f; rewrite <- ?bi.sep_assoc; apply bi.sep_mono; [apply derives_refl|]).. |] + end end. diff --git a/concurrency/fupd.v b/concurrency/fupd.v deleted file mode 100644 index 22c2edf66..000000000 --- a/concurrency/fupd.v +++ /dev/null @@ -1,377 +0,0 @@ -From stdpp Require Export namespaces coPset. -From VST.veric Require Import compcert_rmaps fupd. -From VST.msl Require Import ghost ghost_seplog sepalg_generators. -From VST.concurrency Require Import ghosts conclib invariants cancelable_invariants. -Require Export VST.veric.bi. -Import FashNotation. - -Lemma timeless'_timeless : forall (P : mpred), timeless' P -> Timeless P. -Proof. - intros; unfold Timeless. - constructor. - apply timeless'_except_0; auto. -Qed. - -#[export] Instance own_timeless : forall {P : Ghost} g (a : G), Timeless (own g a NoneP). -Proof. - intros; apply timeless'_timeless, own_timeless. -Qed. - -Lemma address_mapsto_timeless : forall m v sh p, Timeless (res_predicates.address_mapsto m v sh p : mpred). -Proof. - intros; apply timeless'_timeless, address_mapsto_timeless. -Qed. - -#[export] Instance timeless_FF : Timeless FF. -Proof. - unfold Timeless; intros. - iIntros ">?"; auto. -Qed. - -Lemma nonlock_permission_bytes_timeless : forall sh l z, - Timeless (res_predicates.nonlock_permission_bytes sh l z : mpred). -Proof. - intros; apply timeless'_timeless, nonlock_permission_bytes_timeless. -Qed. - -Lemma mapsto_timeless : forall sh t v p, Timeless (mapsto sh t p v). -Proof. - intros; unfold mapsto. - destruct (access_mode t); try apply timeless_FF. - destruct (type_is_volatile); try apply timeless_FF. - destruct p; try apply timeless_FF. - if_tac. - - apply (@bi.or_timeless mpredI). - + apply (@bi.and_timeless mpredI); [apply (@bi.pure_timeless mpredI) | apply address_mapsto_timeless]. - + apply (@bi.and_timeless mpredI); [apply (@bi.pure_timeless mpredI)|]. - apply (@bi.exist_timeless mpredI); intro; apply address_mapsto_timeless. - - apply (@bi.and_timeless mpredI); [apply (@bi.pure_timeless mpredI) | apply nonlock_permission_bytes_timeless]. -Qed. - -#[export] Instance emp_timeless : (@Timeless mpredI) emp. -Proof. - apply timeless'_timeless, emp_timeless. -Qed. - -Lemma memory_block'_timeless : forall sh n b z, - Timeless (mapsto_memory_block.memory_block' sh n b z). -Proof. - induction n; simpl; intros. - - apply emp_timeless. - - apply (@bi.sep_timeless), IHn. - apply mapsto_timeless. -Qed. - -Lemma memory_block_timeless : forall sh n p, - Timeless (memory_block sh n p). -Proof. - intros. - destruct p; try apply timeless_FF. - apply (@bi.and_timeless mpredI); [apply (@bi.pure_timeless mpredI) | apply memory_block'_timeless]. -Qed. - -Lemma struct_pred_timeless : forall {CS : compspecs} sh m f t off - (IH : Forall (fun it : _ => - forall (v : reptype (t it)) (p : val), - Timeless (data_at_rec sh (t it) v p)) m) v p, - Timeless (struct_pred m (fun (it : _) v => - withspacer sh (f it + sizeof (t it)) (off it) - (at_offset (data_at_rec sh (t it) v) (f it))) v p). -Proof. - induction m; intros. - - apply emp_timeless. - - inv IH. destruct m. - + unfold withspacer, at_offset; simpl. - if_tac; auto. - apply (@bi.sep_timeless mpredI); auto. - unfold spacer. - if_tac. - * apply emp_timeless. - * unfold at_offset; apply memory_block_timeless. - + rewrite struct_pred_cons2. - apply (@bi.sep_timeless mpredI); auto. - unfold withspacer, at_offset; simpl. - if_tac; auto. - apply (@bi.sep_timeless mpredI); auto. - unfold spacer. - if_tac. - * apply emp_timeless. - * unfold at_offset; apply memory_block_timeless. -Qed. - -Lemma union_pred_timeless : forall {CS : compspecs} sh m t off - (IH : Forall (fun it : _ => - forall (v : reptype (t it)) (p : val), - Timeless (data_at_rec sh (t it) v p)) m) v p, - Timeless (union_pred m (fun (it : _) v => - withspacer sh (sizeof (t it)) (off it) - (data_at_rec sh (t it) v)) v p). -Proof. - induction m; intros. - - apply emp_timeless. - - inv IH. destruct m. - + unfold withspacer, at_offset; simpl. - if_tac; auto. - apply (@bi.sep_timeless mpredI); auto. - unfold spacer. - if_tac. - * apply emp_timeless. - * unfold at_offset; apply memory_block_timeless. - + rewrite union_pred_cons2. - destruct v; auto. - unfold withspacer, at_offset; simpl. - if_tac; auto. - apply (@bi.sep_timeless mpredI); auto. - unfold spacer. - if_tac. - * apply emp_timeless. - * unfold at_offset; apply memory_block_timeless. -Qed. - -Lemma data_at_rec_timeless : forall {CS : compspecs} sh t v p, - Timeless (data_at_rec sh t v p). -Proof. - intros ???. - type_induction.type_induction t; intros; rewrite data_at_rec_eq; try apply timeless_FF. - - simple_if_tac; [apply memory_block_timeless | apply mapsto_timeless]. - - simple_if_tac; [apply memory_block_timeless | apply mapsto_timeless]. - - simple_if_tac; [apply memory_block_timeless | apply mapsto_timeless]. - - simple_if_tac; [apply memory_block_timeless | apply mapsto_timeless]. - - apply (@bi.and_timeless mpredI); [apply (@bi.pure_timeless mpredI)|]. - rewrite Z.sub_0_r. - forget (Z.to_nat (Z.max 0 z)) as n. - set (lo := 0) at 1. - clearbody lo. - revert lo; induction n; simpl; intros. - + apply emp_timeless. - + apply (@bi.sep_timeless mpredI), IHn. - unfold at_offset; apply IH. - - apply struct_pred_timeless; auto. - - apply union_pred_timeless; auto. -Qed. - -#[export] Instance field_at_timeless : forall {CS : compspecs} sh t gfs v p, Timeless (field_at sh t gfs v p). -Proof. - intros; apply (@bi.and_timeless mpredI); [apply (@bi.pure_timeless mpredI) | apply data_at_rec_timeless]. -Qed. - -Definition funspec_sub' (f1 f2 : funspec): Prop := -match f1 with -| mk_funspec tpsig1 cc1 A1 P1 Q1 _ _ => - match f2 with - | mk_funspec tpsig2 cc2 A2 P2 Q2 _ _ => - (tpsig1=tpsig2 /\ cc1=cc2) /\ - forall ts2 x2 (gargs:argsEnviron), - ((!! (argsHaveTyps(snd gargs)(fst tpsig1)) && P2 ts2 x2 gargs) - |-- |={⊤}=> (EX ts1:_, EX x1:_, EX F:_, - (F * (P1 ts1 x1 gargs)) && - (!! (forall rho', - ((!!(ve_of rho' = Map.empty (Values.block * type))) && - (F * (Q1 ts1 x1 rho'))) - |-- (Q2 ts2 x2 rho'))))) - end -end. - -Lemma coPset_to_Ensemble_top : coPset_to_Ensemble ⊤ = Ensembles.Full_set. -Proof. - unfold coPset_to_Ensemble; apply Ensembles.Extensionality_Ensembles; split; intros ? Hin; unfold Ensembles.In in *. - - constructor. - - set_solver. -Qed. - -Lemma prove_funspec_sub : forall f1 f2, funspec_sub' f1 f2 -> funspec_sub f1 f2. -Proof. - unfold funspec_sub', funspec_sub; intros. - destruct f1, f2. - destruct H as [? H]; split; auto; intros. - eapply derives_trans; [apply H|]. - unfold fupd, bi_fupd_fupd; simpl. - rewrite coPset_to_Ensemble_top. - apply derives_refl. -Qed. - -Lemma fupd_eq : ghost_seplog.fupd Ensembles.Full_set Ensembles.Full_set = fupd ⊤ ⊤. -Proof. - unfold fupd, bi_fupd_fupd; simpl. rewrite coPset_to_Ensemble_top; auto. -Qed. - -Section FancyUpdates. - -Local Open Scope logic_upd. - -Lemma fview_shift_nonexpansive : forall E1 E2 P Q n, - approx n (P -* |={E1,E2}=> Q) = approx n (approx n P -* |={E1,E2}=> approx n Q). -Proof. - intros. - rewrite wand_nonexpansive; setoid_rewrite wand_nonexpansive at 3. - rewrite approx_idem; f_equal; f_equal. - apply fupd_nonexpansive. -Qed. - -End FancyUpdates. - -Section Invariants. - -Lemma fupd_timeless' : forall E1 E2 P Q, Timeless P -> (P |-- |={E1,E2}=> Q) -> - |> P |-- |={E1,E2}=> Q. -Proof. - intros. - iIntros ">P"; iApply H0; auto. -Qed. - -Lemma bupd_except_0 : forall P, (|==> bi_except_0 P) |-- bi_except_0 (|==> P). -Proof. - intros; constructor; change (predicates_hered.derives (own.bupd (bi_except_0 P)) (bi_except_0 (own.bupd P : mpred))). - intros ??; simpl in H. - destruct (level a) eqn: Hl. - + left. - change ((|> FF)%pred a). - intros ? Hl'%laterR_level. - rewrite Hl in Hl'; apply Nat.nlt_0_r in Hl'; contradiction Hl'. - + right. - rewrite <- Hl in *. - intros ? J; specialize (H _ J) as (? & ? & a' & ? & ? & ? & HP); subst. - do 2 eexists; eauto; do 2 eexists; eauto; repeat split; auto. - destruct HP as [Hfalse|]; auto. - destruct (levelS_age a' n) as (a'' & Hage & ?); [lia|]. - exfalso; apply (Hfalse a''). - constructor; auto. -Qed. - -(*Lemma fupd_prop' : forall E1 E2 E2' P Q, subseteq E1 E2 -> - ((Q |-- (|={E1,E2'}=> !!P)) -> - (|={E1, E2}=> Q) |-- |={E1}=> !!P && (|={E1, E2}=> Q))%I. -Proof. - unfold updates.fupd, bi_fupd_fupd; simpl. - unfold fupd; intros ?????? HQ. - iIntros "H Hpre". - iMod ("H" with "Hpre") as ">(Hpre & Q)". - erewrite ghost_set_subset with (s' := coPset_to_Ensemble E1). - iDestruct "Hpre" as "(wsat & en1 & en2)". - iCombine ("wsat en1 Q") as "Q". - erewrite (add_andp (_ ∗ _ ∗ Q)%I (bi_except_0 (!! P))) at 1. - rewrite sepcon_andp_prop bi.except_0_and. - iModIntro; iSplit. - { iDestruct "Q" as "[? ?]"; auto. } - iDestruct "Q" as "[($ & $ & $) _]"; iFrame; auto. - { iIntros "(? & ? & Q)". - setoid_rewrite <- (own.bupd_prop P). - iApply bupd_except_0. - iMod (HQ with "Q [$]") as ">(? & ?)"; auto. } - { intro a; destruct (coPset_elem_of_dec (Pos.of_nat (S a)) E1); auto. } - { unfold coPset_to_Ensemble; intros ??; unfold In in *; auto. } -Qed. - -Lemma fupd_prop : forall E1 E2 P Q, subseteq E1 E2 -> - (Q |-- !!P) -> - ((|={E1, E2}=> Q) |-- |={E1}=> !!P && (|={E1, E2}=> Q))%I. -Proof. - intros; eapply fupd_prop'; auto. - eapply derives_trans; eauto. - apply fupd_intro. -Qed.*) - -Global Opaque updates.fupd. - -Definition cinv (N : namespace) g (P : mpred) : mpred := inv N (P || cinv_own g Tsh). - -Lemma cinv_alloc_dep : forall N E P, (ALL g, |> P g) |-- |={E}=> EX g : _, cinv N g (P g) * cinv_own g Tsh. -Proof. - intros; iIntros "HP". - iMod (own_alloc(RA := share_ghost) with "[$]") as (g) "?"; first done. - iExists g. - iMod (inv_alloc with "[HP]"); last by iFrame. - iNext; iLeft; auto. -Qed. - -Lemma cinv_alloc : forall N E P, |> P |-- |={E}=> EX g : _, cinv N g P * cinv_own g Tsh. -Proof. - intros; iIntros "HP". - iApply cinv_alloc_dep. - iIntros (_); auto. -Qed. - -Lemma make_cinv : forall N E P Q, (P |-- Q) -> P |-- |={E}=> EX g : _, cinv N g Q * cinv_own g Tsh. -Proof. - intros. - eapply derives_trans, cinv_alloc; auto. - eapply derives_trans, now_later; auto. -Qed. - -Lemma cinv_cancel : forall N E g P, - ↑N ⊆ E -> cinv N g P * cinv_own g Tsh |-- |={E}=> (|> P). -Proof. - intros; iIntros "[#I g]". - iInv "I" as "H" "Hclose". - iDestruct "H" as "[$ | >g']". - - iApply "Hclose"; iRight; auto. - - iDestruct (cinv_own_excl with "[$g $g']") as "[]"; auto with share. -Qed. - -(* These seem reasonable, but for some reason cause iInv to hang if exported. *) -#[local] Instance into_inv_cinv N g P : IntoInv (cinv N g P) N := {}. - -#[local] Instance into_acc_cinv E N g P p : - IntoAcc (X:=unit) (cinv N g P) - (↑N ⊆ E /\ p <> Share.bot) (cinv_own g p) (fupd E (E ∖ ↑N)) (fupd (E ∖ ↑N) E) - (λ _, ▷ P ∗ cinv_own g p)%I (λ _, ▷ P)%I (λ _, None)%I. -Proof. - rewrite /IntoAcc /accessor; intros []. - iIntros "#I g". - iInv "I" as "H" "Hclose". - iDestruct "H" as "[$ | >g']". - - iFrame "g"; iExists tt; iIntros "!> HP". - iApply "Hclose"; iLeft; auto. - - iDestruct (cinv_own_excl with "[$g' $g]") as "[]"; auto. -Qed. - -Lemma cinv_nonexpansive : forall N g, nonexpansive (cinv N g). -Proof. - intros; apply inv_nonexpansive2. - apply @disj_nonexpansive, const_nonexpansive. - apply identity_nonexpansive. -Qed. - -Lemma cinv_nonexpansive2 : forall N g f, nonexpansive f -> - nonexpansive (fun a => cinv N g (f a)). -Proof. - intros; apply inv_nonexpansive2. - apply @disj_nonexpansive, const_nonexpansive; auto. -Qed. - -End Invariants. - -(* avoids some fragility in tactics *) -Definition except0 : mpred -> mpred := bi_except_0. - -Lemma replace_SEP'_fupd: - forall n R' Espec {cs: compspecs} Delta P Q Rs c Post, - ENTAIL Delta, PROPx P (LOCALx Q (SEPx (canon.my_nth n Rs TT :: nil))) |-- liftx (|={⊤}=> R') -> - @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx (canon.replace_nth n Rs R')))) c Post -> - @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx Rs))) c Post. -Proof. -intros; eapply replace_SEP'_fupd; eauto. -rewrite fupd_eq; auto. -Qed. - -Tactic Notation "viewshift_SEP" constr(n) constr(R) := - first [apply (replace_SEP'_fupd (Z.to_nat n) R) | apply (replace_SEP''_fupd (Z.to_nat n) R)]; - unfold canon.my_nth,canon.replace_nth; simpl Z.to_nat; - repeat simpl_nat_of_P; cbv beta iota; cbv beta iota. - -Tactic Notation "viewshift_SEP" constr(n) constr(R) "by" tactic1(t):= - first [apply (replace_SEP'_fupd (Z.to_nat n) R) | apply (replace_SEP''_fupd (Z.to_nat n) R)]; - unfold canon.my_nth,canon.replace_nth; simpl Z.to_nat; - repeat simpl_nat_of_P; cbv beta iota; cbv beta iota; [ now t | ]. - -Ltac ghost_alloc G ::= - match goal with |-semax _ (PROPx _ (LOCALx _ (SEPx (?R1 :: _)))) _ _ => - rewrite <- (emp_sepcon R1) at 1; Intros; viewshift_SEP 0 (EX g : _, G g); - [go_lowerx; eapply derives_trans, bupd_fupd; rewrite ?emp_sepcon; - apply own_alloc; auto; simpl; auto with init share ghost|] end. - -Ltac ghosts_alloc G n ::= - match goal with |-semax _ (PROPx _ (LOCALx _ (SEPx (?R1 :: _)))) _ _ => - rewrite <- (emp_sepcon R1) at 1; Intros; viewshift_SEP 0 (EX lg : _, !!(Zlength lg = n) && iter_sepcon G lg); - [go_lowerx; eapply derives_trans, bupd_fupd; rewrite ?emp_sepcon; - apply own_list_alloc'; auto; simpl; auto with init share ghost|] end. diff --git a/concurrency/ghosts.v b/concurrency/ghosts.v deleted file mode 100644 index c6f5c88f0..000000000 --- a/concurrency/ghosts.v +++ /dev/null @@ -1,1735 +0,0 @@ -Require Export VST.msl.ghost. -Require Export VST.veric.ghosts. -Require Import VST.veric.compcert_rmaps. -Require Import VST.concurrency.conclib. -Import List. - -(* Lemmas about ghost state and common instances, part 2 *) - -#[export] Hint Resolve Share.nontrivial : core. - -Opaque eq_dec. - -Definition gname := own.gname. - -#[export] Instance Inhabitant_preds : Inhabitant preds := NoneP. - -Section ghost. - -Context {RA: Ghost}. - -Lemma own_op' : forall g a1 a2 pp, - own g a1 pp * own g a2 pp = EX a3 : _, !!(join a1 a2 a3 /\ valid a3) && own g a3 pp. -Proof. - exact own_op'. -Qed. - -Lemma own_op_gen : forall g a1 a2 a3 pp, (valid_2 a1 a2 -> join a1 a2 a3) -> - own g a1 pp * own g a2 pp = !!(valid_2 a1 a2) && own g a3 pp. -Proof. - exact own_op_gen. -Qed. - -Lemma own_alloc : forall (a : G) (pp : preds), valid a -> emp |-- |==> EX g : own.gname, own g a pp. -Proof. - exact own_alloc. -Qed. - -Lemma own_dealloc : forall g (a : G) (pp : preds), own g a pp |-- emp. -Proof. - exact own_dealloc. -Qed. - -Lemma own_update : forall g a b pp, fp_update a b -> own g a pp |-- |==> own g b pp. -Proof. - exact own_update. -Qed. - -Lemma own_update_ND : forall g a B pp, fp_update_ND a B -> own g a pp |-- |==> EX b : G, !! B b && own g b pp. -Proof. - exact own_update_ND. -Qed. - -Lemma own_list_alloc : forall la lp, Forall valid la -> length lp = length la -> - emp |-- |==> (EX lg : _, !!(Zlength lg = Zlength la) && - iter_sepcon (fun '(g, a, p) => own g a p) (combine (combine lg la) lp)). -Proof. - intros until 1; revert lp; induction H; intros. - - eapply derives_trans, bupd_intro. - Exists (@nil own.gname). simpl. entailer!. - - destruct lp; inv H1. - rewrite <- emp_sepcon at 1. - eapply derives_trans; [apply sepcon_derives; [apply IHForall; eauto | apply own_alloc; eauto]|]. - eapply derives_trans; [apply bupd_sepcon|]. - apply bupd_mono. - Intros lg g. - Exists (g :: lg); rewrite !Zlength_cons; simpl. - rewrite sepcon_comm; entailer!. - apply derives_refl. -Qed. - -Corollary own_list_alloc' : forall a pp i, 0 <= i -> valid a -> - emp |-- |==> (EX lg : _, !!(Zlength lg = i) && iter_sepcon (fun g => own g a pp) lg). -Proof. - intros. - eapply derives_trans; - [apply own_list_alloc with (la := repeat a (Z.to_nat i))(lp := repeat pp (Z.to_nat i))|]. - { apply Forall_repeat; auto. } - { rewrite !repeat_length; auto. } - apply bupd_mono; Intros lg; Exists lg. - rewrite coqlib4.Zlength_repeat, Z2Nat.id in H1 by lia. - rewrite !combine_const1 by (rewrite ?Zlength_combine, ?coqlib4.Zlength_repeat, ?Z2Nat.id, ?Z.min_r; lia). - entailer!. - clear H; induction lg; simpl; entailer!. -Qed. - -Lemma own_list_dealloc : forall {A} f (l : list A), - (forall b, exists g a pp, f b |-- own g a pp) -> - iter_sepcon f l |-- emp. -Proof. - intros; induction l; simpl; auto. - eapply derives_trans; [apply sepcon_derives, IHl | rewrite emp_sepcon; auto]. - destruct (H a) as (? & ? & ? & Hf). - eapply derives_trans; [apply Hf | apply own_dealloc]. -Qed. - -Lemma own_list_dealloc' : forall {A} g a p (l : list A), - iter_sepcon (fun x => own (g x) (a x) (p x)) l |-- emp. -Proof. - intros; apply own_list_dealloc. - do 3 eexists; apply derives_refl. -Qed. - -End ghost. - -Definition excl {A} g a := own(RA := exclusive_PCM A) g (Some a) NoneP. - -Lemma exclusive_update : forall {A} (v v' : A) p, excl p v |-- |==> excl p v'. -Proof. - intros; apply own_update. - intros ? (? & ? & _). - exists (Some v'); split; simpl; auto; inv H; constructor. - inv H1. -Qed. - -(* lift from veric.invariants *) -#[export] Instance set_PCM : Ghost := invariants.set_PCM. - -Definition ghost_set g s := own(RA := set_PCM) g s NoneP. - -Lemma ghost_set_join : forall g s1 s2, - ghost_set g s1 * ghost_set g s2 = !!(Ensembles.Disjoint s1 s2) && ghost_set g (Ensembles.Union s1 s2). -Proof. - apply invariants.ghost_set_join. -Qed. - -Lemma ghost_set_subset : forall g s s' (Hdec : forall a, Ensembles.In s' a \/ ~Ensembles.In s' a), - Ensembles.Included s' s -> ghost_set g s = ghost_set g s' * ghost_set g (Ensembles.Setminus s s'). -Proof. - apply invariants.ghost_set_subset. -Qed. - -Corollary ghost_set_remove : forall g a s, - Ensembles.In s a -> ghost_set g s = ghost_set g (Ensembles.Singleton a) * ghost_set g (Ensembles.Subtract s a). -Proof. - apply invariants.ghost_set_remove. -Qed. - -Section Snapshot. - -Context `{ORD : PCM_order}. - -Definition ghost_snap (a : @G P) p := own(RA := snap_PCM) p (Share.bot, a) NoneP. - -Lemma ghost_snap_join : forall v1 v2 p v, join v1 v2 v -> - ghost_snap v1 p * ghost_snap v2 p = ghost_snap v p. -Proof. - intros; symmetry; apply own_op. - split; simpl; rewrite ?eq_dec_refl; auto. -Qed. - -Lemma ghost_snap_conflict : forall v1 v2 p, ghost_snap v1 p * ghost_snap v2 p |-- !!(joins v1 v2). -Proof. - intros; eapply derives_trans; [apply own_valid_2|]. - apply prop_left; intros ((?, a) & (? & Hj) & _); simpl in Hj. - rewrite !eq_dec_refl in Hj. - apply prop_right; exists a; auto. -Qed. - -Lemma ghost_snap_join' : forall v1 v2 p, - ghost_snap v1 p * ghost_snap v2 p = EX v : _, !!(join v1 v2 v) && ghost_snap v p. -Proof. - intros; apply pred_ext. - - assert_PROP (joins v1 v2) as H by apply ghost_snap_conflict. - destruct H as [v]; Exists v; entailer!. - erewrite ghost_snap_join; eauto. apply derives_refl. - - Intros v; erewrite ghost_snap_join; eauto. apply derives_refl. -Qed. - -Definition ghost_master sh (a : @G P) p := own(RA := snap_PCM) p (sh, a) NoneP. - -Lemma snap_master_join : forall v1 sh v2 p, sh <> Share.bot -> - ghost_snap v1 p * ghost_master sh v2 p = !!(ord v1 v2) && ghost_master sh v2 p. -Proof. - intros; setoid_rewrite own_op'. - apply pred_ext. - - Intros a3. - destruct a3 as (sh', ?), H0 as [Hsh Hj]; simpl in *. - apply bot_identity in Hsh; subst sh'. - rewrite eq_dec_refl in Hj. - destruct (eq_dec sh Share.bot); [contradiction|]. - destruct Hj; subst; entailer!. - - Intros; Exists (sh, v2); entailer!. - split; simpl; rewrite ?eq_dec_refl. - + apply bot_join_eq. - + if_tac; auto; contradiction. - + apply derives_refl. -Qed. - -Corollary snaps_master_join : forall lv sh v2 p, sh <> Share.bot -> - fold_right sepcon emp (map (fun v => ghost_snap v p) lv) * ghost_master sh v2 p = - !!(Forall (fun v1 => ord v1 v2) lv) && ghost_master sh v2 p. -Proof. - induction lv; simpl; intros. - - rewrite emp_sepcon, prop_true_andp; auto. - - rewrite sepcon_comm, <-sepcon_assoc, (sepcon_comm (ghost_master _ _ _)), snap_master_join; auto. - apply pred_ext. - + Intros; rewrite sepcon_comm, IHlv; auto; entailer!. - + Intros. - match goal with H : Forall _ _ |- _ => inv H end. - rewrite prop_true_andp; auto. - rewrite sepcon_comm, IHlv; auto; entailer!. -Qed. - -Lemma master_update : forall v v' p, ord v v' -> ghost_master Tsh v p |-- |==> ghost_master Tsh v' p. -Proof. - intros; apply own_update. - intros ? (x & Hj & _); simpl in Hj. - exists (Tsh, v'); simpl; split; auto. - destruct Hj as [Hsh Hj]; simpl in *. - apply join_Tsh in Hsh as []; destruct c, x; simpl in *; subst. - split; auto; simpl. - fold share in *; destruct (eq_dec Tsh Share.bot); [contradiction Share.nontrivial|]. - destruct Hj as [? Hc']; subst. - rewrite !eq_dec_refl in Hc' |- *; split; auto. - etransitivity; eauto. -Qed. - -Lemma master_init : forall (a : @G P), exists g', joins (Tsh, a) g'. -Proof. - intros; exists (Share.bot, a), (Tsh, a); simpl. - split; auto; simpl. - apply join_refl. -Qed. - -#[local] Hint Resolve bupd_intro : ghost. - -Lemma make_snap : forall (sh : share) v p, ghost_master sh v p |-- |==> ghost_snap v p * ghost_master sh v p. -Proof. - intros. - destruct (eq_dec sh Share.bot). - - subst; setoid_rewrite ghost_snap_join; [|apply join_refl]; auto with ghost. - - rewrite snap_master_join; auto; entailer!; auto with ghost. -Qed. - -Lemma ghost_snap_forget : forall v1 v2 p, ord v1 v2 -> ghost_snap v2 p |-- |==> ghost_snap v1 p. -Proof. - intros; apply own_update. - intros (shc, c) [(shx, x) [[? Hj] _]]; simpl in *. - rewrite eq_dec_refl in Hj. - assert (shx = shc) by (eapply sepalg.join_eq; eauto); subst. - unfold share in Hj; destruct (eq_dec shc Share.bot); subst. - - destruct (join_compat _ _ _ _ Hj H) as [x' []]. - exists (Share.bot, x'); simpl; split; auto; split; auto; simpl. - rewrite !eq_dec_refl; auto. - - destruct Hj; subst. - exists (shc, c); simpl; split; auto; split; auto; simpl. - rewrite eq_dec_refl; if_tac; [contradiction|]. - split; auto. - etransitivity; eauto. -Qed. - -Lemma ghost_snap_choose : forall v1 v2 p, ghost_snap v1 p * ghost_snap v2 p |-- |==> ghost_snap v1 p. -Proof. - intros. - setoid_rewrite own_op'. - Intros v'. - destruct v', H as [Hsh Hj]; apply bot_identity in Hsh; simpl in *; subst. - rewrite !eq_dec_refl in Hj. - apply ghost_snap_forget. - rewrite join_ord_eq; eauto. -Qed. - -Lemma master_share_join : forall sh1 sh2 sh v p, sepalg.join sh1 sh2 sh -> - ghost_master sh1 v p * ghost_master sh2 v p = ghost_master sh v p. -Proof. - intros; symmetry; apply own_op; split; auto; simpl. - if_tac; if_tac; try split; auto; try reflexivity; apply join_refl. -Qed. - -Lemma master_inj : forall sh1 sh2 v1 v2 p, readable_share sh1 -> readable_share sh2 -> - ghost_master sh1 v1 p * ghost_master sh2 v2 p |-- !!(v1 = v2). -Proof. - intros. - eapply derives_trans; [apply own_valid_2|]. - apply prop_left; intros ((?, ?) & [[? Hj] _]); simpl in Hj. - fold share in *. - destruct (eq_dec sh1 Share.bot); [subst; contradiction unreadable_bot|]. - destruct (eq_dec sh2 Share.bot); [subst; contradiction unreadable_bot|]. - destruct Hj; subst; apply prop_right; auto. -Qed. - -Lemma master_share_join' : forall sh1 sh2 sh v1 v2 p, readable_share sh1 -> readable_share sh2 -> - sepalg.join sh1 sh2 sh -> - ghost_master sh1 v1 p * ghost_master sh2 v2 p = !!(v1 = v2) && ghost_master sh v2 p. -Proof. - intros; apply pred_ext. - - assert_PROP (v1 = v2) by (apply master_inj; auto). - subst; erewrite master_share_join; eauto; entailer!. - - Intros; subst. - erewrite master_share_join; eauto. apply derives_refl. -Qed. - -(* useful when we only want to deal with full masters *) -Definition ghost_master1 a p := ghost_master Tsh a p. - -Lemma snap_master_join1 : forall v1 v2 p, - ghost_snap v1 p * ghost_master1 v2 p = !!(ord v1 v2) && ghost_master1 v2 p. -Proof. - intros; apply snap_master_join, Share.nontrivial. -Qed. - -Lemma snap_master_update1 : forall v1 v2 p v', ord v2 v' -> - ghost_snap v1 p * ghost_master1 v2 p |-- |==> ghost_snap v' p * ghost_master1 v' p. -Proof. - intros; rewrite !snap_master_join1. - Intros; entailer!. - apply master_update; auto. -Qed. - -End Snapshot. - -#[global] Hint Resolve bupd_intro : ghost. - -Section Reference. - -Context {P : Ghost}. - -Definition ghost_reference a g := own(RA := ref_PCM P) g (None, Some a) NoneP. -Definition ghost_part sh a g := own(RA := ref_PCM P) g (Some (sh, a), None) NoneP. -Definition ghost_part_ref sh a r g := - own(RA := ref_PCM P) g (Some (sh, a), Some r) NoneP. - -Lemma ghost_part_join : forall sh1 sh2 sh a1 a2 a g, join sh1 sh2 sh -> join a1 a2 a -> - sh1 <> Share.bot -> sh2 <> Share.bot -> - ghost_part sh1 a1 g * ghost_part sh2 a2 g = ghost_part sh a g. -Proof. - intros. - symmetry; apply own_op. - hnf; simpl. - split; auto; constructor. -Qed. - -Lemma ghost_part_ref_join : forall g (sh : share) a b, - ghost_part sh a g * ghost_reference b g = ghost_part_ref sh a b g. -Proof. - intros. - symmetry; apply own_op. - hnf; simpl. - split; auto; constructor. -Qed. - -Lemma ref_sub_gen : forall g sh a b pp, - own(RA := ref_PCM P) g (Some (sh, a), None) pp * own(RA := ref_PCM P) g (None, Some b) pp |-- - !!(if eq_dec sh Tsh then a = b else exists x, join a x b). -Proof. - intros. - eapply derives_trans; [apply own_valid_2|]. - apply prop_left; intros (c & [Hsh Hj] & ?); simpl in *. - apply prop_right. - destruct (fst c); [subst | contradiction]. - inv Hj. - rewrite <- H0 in H. - destruct H as (? & c' & Hsub). - destruct c' as [(?, ?)|]. - - destruct Hsub as (? & ? & Hsh & ?). - if_tac; eauto; subst. - apply join_Tsh in Hsh; tauto. - - inv Hsub. - rewrite eq_dec_refl; auto. -Qed. - -Lemma ref_sub : forall g sh a b, - ghost_part sh a g * ghost_reference b g |-- - !!(if eq_dec sh Tsh then a = b else exists x, join a x b). -Proof. - intros; apply ref_sub_gen. -Qed. - -Lemma self_completable : forall a, completable (Some (Tsh, a)) a. -Proof. - intros; unfold completable. - exists None; constructor. -Qed. - -Lemma part_ref_valid : forall a, valid(Ghost := ref_PCM P) (Some (Tsh, a), Some a). -Proof. - intros; hnf; simpl. - split; auto with share. - apply self_completable. -Qed. - -Lemma ref_update_gen : forall g a r a' pp, - own(RA := ref_PCM P) g (Some (Tsh, a), Some r) pp |-- |==> - own(RA := ref_PCM P) g (Some (Tsh, a'), Some a') pp. -Proof. - intros; apply own_update. - intros (c, ?) ((x, ?) & [J1 J2] & [? Hvalid]); simpl in *. - inv J2; [|contradiction]. - destruct c as [(?, c)|], x as [(shx, x)|]; try contradiction. - - destruct J1 as (? & ? & J & Hx). - apply join_Tsh in J as []; contradiction. - - inv J1. - exists (Some (Tsh, a'), Some a'); repeat split; simpl; auto; try constructor. - apply self_completable. -Qed. - -Lemma ref_update : forall g a r a', - ghost_part_ref Tsh a r g |-- |==> ghost_part_ref Tsh a' a' g. -Proof. - intros; apply ref_update_gen. -Qed. - -Lemma part_ref_update : forall g sh a r a' r' - (Ha' : forall b, join a b r -> join a' b r' /\ (a = r -> a' = r')), - ghost_part_ref sh a r g |-- |==> ghost_part_ref sh a' r' g. -Proof. - intros; apply own_update. - intros (c, ?) ((x, ?) & [J1 J2] & [? Hvalid]); simpl in *. - inv J2; [|contradiction]. - destruct c as [(?, c)|], x as [(shx, x)|]; try contradiction. - - destruct J1 as (? & ? & ? & Hx). - assert (join_sub x r) as [f J]. - { destruct Hvalid as [[(?, ?)|] Hvalid]; hnf in Hvalid. - + destruct Hvalid as (? & ? & ? & ?); eexists; eauto. - + inv Hvalid; apply join_sub_refl. } - destruct (join_assoc Hx J) as (b & Jc & Jb%Ha'). - destruct Jb as [Jb Heq]. - destruct (join_assoc (join_comm Jc) (join_comm Jb)) as (x' & Hx' & Hr'). - exists (Some (shx, x'), Some r'); repeat (split; auto); try constructor; simpl. - + destruct Hvalid as (d & Hvalid); hnf in Hvalid. - destruct d as [(shd, d)|]. - * exists (Some (shd, f)); destruct Hvalid as (? & ? & ? & Hd); repeat (split; auto). - * exists None; hnf. - inv Hvalid; f_equal. - eapply join_eq; [apply Ha'|]; eauto. - - inv J1. - exists (Some (sh, a'), Some r'); repeat split; simpl; auto; try constructor. - unfold completable in *. - destruct Hvalid as (d & Hvalid); hnf in Hvalid. - exists d; destruct d as [(shd, d)|]; hnf. - + destruct Hvalid as (? & ? & ? & Hd); repeat (split; auto). - eapply Ha'; auto. - + inv Hvalid. f_equal. - symmetry; eapply Ha'; auto. - apply join_comm, core_unit. -Qed. - -Corollary ref_add : forall g sh a r b a' r' - (Ha : join a b a') (Hr : join r b r'), - ghost_part_ref sh a r g |-- |==> ghost_part_ref sh a' r' g. -Proof. - intros; apply part_ref_update; intros c J. - destruct (join_assoc (join_comm J) Hr) as (? & ? & ?). - eapply join_eq in Ha; eauto; subst; auto. - split; auto; intros; subst. - eapply join_eq; eauto. -Qed. - -End Reference. - -#[export] Hint Resolve part_ref_valid : init. - -#[export] Hint Resolve self_completable : init. - -Section GVar. - -Context {A : Type}. - -Notation ghost_var_PCM A := (@pos_PCM (discrete_PCM A)). - -Definition ghost_var (sh : share) (v : A) g := - own(RA := @pos_PCM (discrete_PCM A)) g (Some (sh, v)) NoneP. - -Lemma ghost_var_share_join : forall sh1 sh2 sh v p, sepalg.join sh1 sh2 sh -> - sh1 <> Share.bot -> sh2 <> Share.bot -> - ghost_var sh1 v p * ghost_var sh2 v p = ghost_var sh v p. -Proof. - intros; symmetry; apply own_op. - repeat (split; auto). -Qed. - -Lemma ghost_var_share_join_gen : forall sh1 sh2 v1 v2 p, - ghost_var sh1 v1 p * ghost_var sh2 v2 p = EX sh : _, - !!(v1 = v2 /\ sh1 <> Share.bot /\ sh2 <> Share.bot /\ sepalg.join sh1 sh2 sh) && ghost_var sh v1 p. -Proof. - intros; setoid_rewrite own_op'. - apply pred_ext. - - Intros a. - destruct a as [(sh, v')|]; inv H. - destruct H2 as (? & ? & Hv); inv Hv. - Exists sh; entailer!. - - Intros sh; subst. - Exists (Some (sh, v2)); apply andp_right, derives_refl. - apply prop_right; repeat (split; auto); simpl. - intro; subst; apply join_Bot in H2 as []; contradiction. -Qed. - -Lemma ghost_var_inj : forall sh1 sh2 v1 v2 p, sh1 <> Share.bot -> sh2 <> Share.bot -> - ghost_var sh1 v1 p * ghost_var sh2 v2 p |-- !!(v1 = v2). -Proof. - intros; rewrite ghost_var_share_join_gen; Intros sh; entailer!. -Qed. - -Lemma ghost_var_share_join' : forall sh1 sh2 sh v1 v2 p, sh1 <> Share.bot -> sh2 <> Share.bot -> - sepalg.join sh1 sh2 sh -> - ghost_var sh1 v1 p * ghost_var sh2 v2 p = !!(v1 = v2) && ghost_var sh v2 p. -Proof. - intros; rewrite ghost_var_share_join_gen. - apply pred_ext. - - Intros sh'; entailer!. - eapply join_eq in H1; eauto; subst; auto. - - Intros; Exists sh; entailer!. -Qed. - -Lemma ghost_var_update : forall v p v', ghost_var Tsh v p |-- |==> ghost_var Tsh v' p. -Proof. - intros; apply own_update. - intros [[]|] ([[]|] & J & ?); inv J. - - destruct H1 as (? & ?%join_Tsh & ?); tauto. - - exists (Some (Tsh, v')); split; [constructor | auto]. -Qed. - -Lemma ghost_var_update' : forall g (v1 v2 v : A), ghost_var gsh1 v1 g * ghost_var gsh2 v2 g |-- - |==> !!(v1 = v2) && (ghost_var gsh1 v g * ghost_var gsh2 v g). -Proof. - intros; erewrite ghost_var_share_join' by eauto. - Intros; subst; erewrite ghost_var_share_join by eauto. - rewrite -> prop_true_andp by auto; apply ghost_var_update. -Qed. - -Lemma ghost_var_exclusive : forall sh v p, sh <> Share.bot -> exclusive_mpred (ghost_var sh v p). -Proof. - intros; unfold exclusive_mpred. - rewrite ghost_var_share_join_gen. - Intros sh'. - apply join_self, identity_share_bot in H1; contradiction. -Qed. - -End GVar. - -#[export] Hint Resolve ghost_var_exclusive : exclusive. - -Section PVar. -(* Like ghost variables, but the partial values may be out of date. *) - -Global Program Instance nat_PCM: Ghost := { valid a := True; Join_G a b c := c = Nat.max a b }. -Next Obligation. - exists (id _); auto; intros. - - hnf. symmetry; apply Nat.max_id. - - eexists; eauto. -Defined. -Next Obligation. - constructor. - - unfold join; congruence. - - unfold join; eexists; split; eauto. - rewrite Nat.max_assoc; subst; auto. - - unfold join; intros. - rewrite Nat.max_comm; auto. - - unfold join; intros. - apply Nat.le_antisymm; [subst b | subst a]; apply Nat.le_max_l. -Qed. - -Global Instance max_order : PCM_order Peano.le. -Proof. - constructor; auto; intros. - - constructor; auto. intros ???; lia. - - eexists; unfold join; simpl; split; eauto. - apply Nat.max_lub; auto. - - hnf in H; subst. - split; [apply Nat.le_max_l | apply Nat.le_max_r]. - - hnf. - rewrite Nat.max_l; auto. -Qed. - -Lemma ghost_snap_join_N : forall v1 v2 p, ghost_snap v1 p * ghost_snap v2 p = ghost_snap (Nat.max v1 v2) p. -Proof. - intros; apply ghost_snap_join; hnf; auto. -Qed. - -Lemma snap_master_join' : forall v1 v2 p, - ghost_snap v1 p * ghost_master1 v2 p = !!(v1 <= v2)%nat && ghost_master1 v2 p. -Proof. - intros; apply snap_master_join1. -Qed. - -Lemma snap_master_update' : forall (v1 v2 : nat) p v', (v2 <= v')%nat -> - ghost_snap v1 p * ghost_master1 v2 p |-- |==> ghost_snap v' p * ghost_master1 v' p. -Proof. - intros; apply snap_master_update1; auto. -Qed. - -End PVar. - -Section Option. - -Context {P : Ghost}. - -Global Program Instance option_PCM : Ghost := { G := option G; valid a := True }. - -Context `{ORD : PCM_order(P := P)}. - -Definition option_ord (a b : G) : Prop := - match a, b with - | None, _ => True - | Some a, Some b => ord a b - | _, _ => False - end. - -#[export] Instance option_ord_refl : Reflexive option_ord. -Proof. - intros ?. - destruct x; simpl; auto. - reflexivity. -Qed. - -Global Instance option_order : PCM_order option_ord. -Proof. - constructor. - - constructor; [apply option_ord_refl|]. - intros ???. destruct x; simpl in *; auto. - destruct y; [simpl in * | contradiction]. - destruct z; [|contradiction]. - etransitivity; eauto. - - intros. - destruct a; [destruct b|]; simpl in *. - + destruct c; [|contradiction]. - destruct (ord_lub _ _ _ H H0) as (c' & ? & ?); exists (Some c'); split; auto. - constructor; auto. - + exists (Some g); split; auto; constructor. - + exists b; split; auto; constructor. - - inversion 1; subst; try solve [split; simpl; auto; reflexivity]. - apply join_ord in H0 as []; auto. - - destruct b; simpl. - + destruct a; [|contradiction]. - intros; constructor; apply ord_join; auto. - + destruct a; constructor. -Qed. - -End Option. - -Section Maps. - -Context {A} {A_eq : EqDec A} {B : Type}. - -Implicit Types (k : A) (v : B) (m : A -> option B). - -Definition map_add m1 m2 k := match m1 k with Some v' => Some v' | None => m2 k end. - -Definition map_upd m k v k' := if eq_dec k' k then Some v else m k'. - -Lemma map_upd_triv : forall m k v, m k = Some v -> map_upd m k v = m. -Proof. - intros; extensionality; unfold map_upd. - if_tac; subst; auto. -Qed. - -Lemma map_upd_comm : forall m k1 v1 k2 v2, k1 <> k2 -> - map_upd (map_upd m k1 v1) k2 v2 = map_upd (map_upd m k2 v2) k1 v1. -Proof. - intros; unfold map_upd. - extensionality; if_tac; if_tac; auto; subst; contradiction. -Qed. - -Fixpoint map_upd_list m l := - match l with - | [] => m - | (k, v) :: rest => map_upd_list (map_upd m k v) rest - end. - -Definition empty_map k : option B := None. - -Global Instance Inhabitant_map : Inhabitant (A -> option B) := empty_map. - -Definition singleton k v k1 := if eq_dec k1 k then Some v else None. - -Lemma map_add_empty : forall m, map_add m empty_map = m. -Proof. - intros; extensionality; unfold map_add, empty_map. - destruct (m x); auto. -Qed. - -Lemma map_add_single : forall m k v, map_add (singleton k v) m = map_upd m k v. -Proof. - intros; extensionality; unfold map_add, singleton, map_upd; if_tac; auto. -Qed. - -Lemma map_add_assoc : forall m1 m2 m3, map_add (map_add m1 m2) m3 = map_add m1 (map_add m2 m3). -Proof. - intros; extensionality; unfold map_add. - destruct (m1 x); auto. -Qed. - -Lemma map_add_upd : forall m1 m2 k v, map_upd (map_add m1 m2) k v = map_add (map_upd m1 k v) m2. -Proof. - intros. - rewrite <- !map_add_single. - rewrite map_add_assoc; auto. -Qed. - -End Maps. - -Section Maps1. - -Context {A} {A_eq : EqDec A} {P : Ghost}. - -Implicit Types (k : A) (v : G) (m : A -> option G). - -Global Instance map_join : Join (A -> option G) := fun a b c => forall k, join (a k) (b k) (c k). - -Global Program Instance map_PCM : Ghost := { valid a := True; Join_G := map_join }. - -Context `{ORD : PCM_order(P := P)}. - -Definition map_incl m1 m2 := forall k, option_ord(ord := ord) (m1 k) (m2 k). - -Global Instance map_incl_refl : Reflexive map_incl. -Proof. - repeat intro; reflexivity. -Qed. - -Global Instance map_incl_trans : Transitive map_incl. -Proof. - repeat intro; etransitivity; eauto. -Qed. - -#[export] Instance fmap_order : PCM_order map_incl. -Proof. - constructor. - - split; [apply map_incl_refl | apply map_incl_trans]. - - intros ??? Ha Hb. exists (fun k => proj1_sig (ord_lub _ _ _ (Ha k) (Hb k))); split; - intros k; destruct (ord_lub(ord := option_ord) (a k) (b k) (c k) (Ha k) (Hb k)) as (? & ? & ?); auto. - - split; repeat intro; specialize (H k); apply (join_ord(ord := option_ord)) in H as []; auto. - - intros ??? k. - specialize (H k); apply (ord_join(ord := option_ord)); auto. -Qed. - -Lemma map_upd_single : forall m k v, m k = None -> join m (singleton k v) (map_upd m k v). -Proof. - intros; intros k'. - unfold singleton, map_upd; if_tac; subst; [|constructor]. - rewrite H; constructor. -Qed. - -Lemma map_upd_list_app : forall l1 l2 m, map_upd_list m (l1 ++ l2) = map_upd_list (map_upd_list m l1) l2. -Proof. - induction l1; auto; simpl; intros. - destruct a; auto. -Qed. - -Lemma map_upd_list_out : forall l m k, m k = None -> ~In k (map fst l) -> map_upd_list m l k = None. -Proof. - induction l; auto; simpl; intros. - destruct a; apply IHl. - - unfold map_upd; if_tac; auto. - subst; simpl in *; tauto. - - tauto. -Qed. - -Lemma map_upd_incl : forall m1 m2 k v, map_incl m1 m2 -> - m2 k = Some v -> map_incl (map_upd m1 k v) m2. -Proof. - unfold map_upd; repeat intro. - destruct (eq_dec k0 k); [|auto]. - subst; rewrite H0; reflexivity. -Qed. - -Lemma empty_map_incl : forall m, map_incl empty_map m. -Proof. - repeat intro; constructor. -Qed. - -Lemma map_upd2_incl : forall m1 m2 k v, map_incl m1 m2 -> map_incl (map_upd m1 k v) (map_upd m2 k v). -Proof. - unfold map_upd; repeat intro. - if_tac; auto; reflexivity. -Qed. - -End Maps1. - -Section MapsL. - -Context {A B : Type} {A_eq : EqDec A}. - -Implicit Types (k : A) (v : B) (m : A -> option B). - -Global Instance discrete_order : PCM_order(P := discrete_PCM B) eq. -Proof. - constructor. - - constructor. - + constructor. - + intros ???; inversion 1; inversion 1; constructor. - - intros. - assert (a = c) by (inv H; auto). - assert (b = c) by (inv H0; auto). - subst; do 2 eexists; constructor; auto. - - inversion 1; subst; split; constructor. - - inversion 1; constructor; auto. -Qed. - -Local Notation map_incl := (@map_incl A (discrete_PCM B) eq). - -Global Instance map_incl_antisym : Antisymmetric _ eq map_incl. -Proof. - intros x y Hx Hy. - extensionality a. - specialize (Hx a); specialize (Hy a). - destruct (x a), (y a); simpl in *; auto; try contradiction. -Qed. - -Lemma map_add_incl_compat : forall m1 m2 m3, map_incl m1 m2 -> map_incl (map_add m3 m1) (map_add m3 m2). -Proof. - unfold map_add; repeat intro. - destruct (m3 k); auto; simpl. - constructor. -Qed. - -Definition compatible m1 m2 := forall k v1 v2, m1 k = Some v1 -> m2 k = Some v2 -> v1 = v2. - -Global Instance compatible_refl : Reflexive compatible. -Proof. - repeat intro. - congruence. -Qed. - -Global Instance compatible_comm : Symmetric compatible. -Proof. - repeat intro. - symmetry; eauto. -Qed. - -Lemma map_add_comm : forall m1 m2, compatible m1 m2 -> map_add m1 m2 = map_add m2 m1. -Proof. - intros; extensionality x; unfold map_add. - destruct (m1 x) eqn: Hm1, (m2 x) eqn: Hm2; eauto. -Qed. - -Lemma compatible_add_assoc : forall m1 m2 m3, compatible m1 m2 -> - compatible (map_add m1 m2) m3 -> compatible m1 (map_add m2 m3). -Proof. - unfold compatible, map_add; intros. - repeat match goal with H : forall _, _ |- _ => specialize (H k) end. - replace (m1 k) with (Some v1) in *. - destruct (m2 k); auto. -Qed. - -Lemma map_incl_spec : forall m1 m2 k v, map_incl m1 m2 -> m1 k = Some v -> m2 k = Some v. -Proof. - intros; specialize (H k). - rewrite H0 in H; simpl in H. - destruct (m2 k); auto; inv H; auto. -Qed. - -Lemma compatible_incl : forall m1 m2 m (Hcompat : compatible m2 m) (Hincl : map_incl m1 m2), compatible m1 m. -Proof. - repeat intro. - eapply Hcompat; eauto. - eapply map_incl_spec; eauto. -Qed. - -Lemma map_incl_add : forall m1 m2, map_incl m1 (map_add m1 m2). -Proof. - repeat intro; unfold map_add. - destruct (m1 k); simpl; auto. -Qed. - -Lemma map_incl_compatible : forall m1 m2 m3 (Hincl1 : map_incl m1 m3) (Hincl2 : map_incl m2 m3), - compatible m1 m2. -Proof. - intros; intros ??? Hk1 Hk2. - apply (map_incl_spec _ _ _ _ Hincl1) in Hk1; apply (map_incl_spec _ _ _ _ Hincl2) in Hk2. - rewrite Hk1 in Hk2; inv Hk2; auto. -Qed. - -Lemma map_add_incl : forall m1 m2 m3, map_incl m1 m3 -> map_incl m2 m3 -> map_incl (map_add m1 m2) m3. -Proof. - unfold map_add; intros. - intros k. - destruct (m1 k) eqn: Hk1; auto; simpl. - eapply map_incl_spec in Hk1 as ->; eauto; constructor. -Qed. - -Local Notation map_join := (map_join(P := discrete_PCM B)). - -Lemma map_join_spec : forall m1 m2 m3, map_join m1 m2 m3 <-> compatible m1 m2 /\ m3 = map_add m1 m2. -Proof. - unfold join, map_join; simpl; split; intros. - - split. - + repeat intro. - specialize (H k); rewrite H0, H1 in H; inv H. - inv H5; auto. - + extensionality x; unfold map_add. - specialize (H x); inv H; auto. - { destruct (m1 x); auto. } - inv H3; auto. - - destruct H as [Hcompat]; subst; unfold map_add. - destruct (m1 k) eqn: Hm1; simpl; try constructor. - destruct (m2 k) eqn: Hm2; constructor. - eapply Hcompat in Hm2; eauto; subst; constructor; auto. -Qed. - -Lemma map_snap_join : forall m1 m2 p, - ghost_snap(ORD := fmap_order(P := discrete_PCM B)) m1 p * ghost_snap(ORD := fmap_order(P := discrete_PCM B)) m2 p = !!(compatible m1 m2) && ghost_snap(ORD := fmap_order(P := discrete_PCM B)) (map_add m1 m2) p. -Proof. - intros; rewrite ghost_snap_join'. - apply pred_ext. - - Intros m. - apply map_join_spec in H as []; subst; entailer!. - - Intros; Exists (map_add m1 m2). - setoid_rewrite map_join_spec; entailer!. -Qed. - -Lemma compatible_k : forall m1 m2 (Hcompat : compatible m1 m2) k v, m2 k = Some v -> map_add m1 m2 k = Some v. -Proof. - unfold compatible; intros. - unfold map_add. - destruct (m1 k) eqn: Hk; eauto. -Qed. - -Lemma map_join_incl_compat : forall m1 m2 m' m'' (Hincl : map_incl m1 m2) (Hjoin : map_join m2 m' m''), - exists m, map_join m1 m' m /\ map_incl m m''. -Proof. - intros; apply (@join_comm _ _ (@Perm_G map_PCM)) in Hjoin. - apply map_join_spec in Hjoin as [Hjoin]; subst. - do 2 eexists; [|apply map_add_incl_compat; eauto]. - symmetry in Hjoin; eapply compatible_incl in Hjoin; eauto. - rewrite map_join_spec; split; auto. - rewrite <- map_add_comm; auto. -Qed. - -Lemma incl_compatible : forall m1 m2, map_incl m1 m2 -> compatible m1 m2. -Proof. - intros; intros ??? Hk1 Hk2. - eapply map_incl_spec in Hk1; eauto; congruence. -Qed. - -Lemma map_add_redundant : forall m1 m2, map_incl m1 m2 -> map_add m1 m2 = m2. -Proof. - intros; unfold map_add; extensionality k. - destruct (m1 k) eqn: Hk; auto; symmetry; auto. - eapply map_incl_spec; eauto. -Qed. - -Lemma compatible_upd : forall m1 m2 k v, compatible m1 m2 -> m2 k = None -> - compatible (map_upd m1 k v) m2. -Proof. - unfold map_upd; repeat intro. - destruct (eq_dec k0 k); eauto; congruence. -Qed. - -Notation maps_add l := (fold_right map_add empty_map l). - -Lemma in_maps_add : forall l (k : A) (v : B), maps_add l k = Some v -> exists m, In m l /\ m k = Some v. -Proof. - induction l; [discriminate | simpl; intros]. - unfold map_add at 1 in H. - destruct (a k) eqn: Ha. - - inv H; eauto. - - destruct (IHl _ _ H) as (? & ? & ?); eauto. -Qed. - -Definition all_compatible (l : list (A -> option B)) := forall m1 m2, In m1 l -> In m2 l -> compatible m1 m2. - -Lemma all_compatible_cons : forall (m : A -> option B) l, all_compatible (m :: l) -> compatible m (maps_add l) /\ all_compatible l. -Proof. - split; repeat intro. - - eapply in_maps_add in H1 as (m2 & ? & ?). - eapply (H m m2); simpl; eauto. - - eapply (H m1 m2); simpl; eauto. -Qed. - -Lemma maps_add_in : forall l m (k : A) (v : B) (Hcompat : all_compatible l), - In m l -> m k = Some v -> maps_add l k = Some v. -Proof. - induction l; [contradiction | simpl; intros]. - destruct H. - - subst. - unfold map_add. - replace (m k) with (Some v); auto. - - apply all_compatible_cons in Hcompat as []. - rewrite map_add_comm; auto. - unfold map_add. - erewrite IHl; eauto. -Qed. - -Lemma fold_right_maps_add : forall l (e : A -> option B), fold_right map_add e l = map_add (maps_add l) e. -Proof. - induction l; auto; simpl; intros. - rewrite map_add_assoc, IHl; auto. -Qed. - -Section Maps_Disjoint. -(* This map instance requires that maps be disjoint, providing e.g. uniqueness of - timestamps for histories. *) - -Definition disjoint m1 m2 := forall k v1, m1 k = Some v1 -> m2 k = None. - -Global Instance disjoint_comm : Symmetric disjoint. -Proof. - repeat intro. - destruct (x k) eqn: Hx; auto. - specialize (H _ _ Hx); congruence. -Qed. - -Lemma disjoint_compatible : forall m1 m2, disjoint m1 m2 -> compatible m1 m2. -Proof. - repeat intro. - specialize (H _ _ H0); congruence. -Qed. - -Instance map_disj_join : Join (A -> option B) := - fun a b c => forall k, match a k, b k with Some v, None | None, Some v => c k = Some v | None, None => c k = None | _, _ => False end. - -Lemma map_disj_join_spec : forall m1 m2 m3, join m1 m2 m3 <-> disjoint m1 m2 /\ m3 = map_add m1 m2. -Proof. - unfold join, map_disj_join; simpl; split; intros. - - split. - + repeat intro. - specialize (H k); rewrite H0 in H. - destruct (m2 k); auto; contradiction. - + extensionality k; unfold map_add. - specialize (H k). - destruct (m1 k), (m2 k); auto; contradiction. - - destruct H as [Hdisj]; subst; unfold map_add. - specialize (Hdisj k). - destruct (m1 k); [specialize (Hdisj _ eq_refl) as ->; auto|]. - destruct (m2 k); auto. -Qed. - -Lemma disjoint_incl : forall m1 m2 m (Hcompat : disjoint m2 m) (Hincl : map_incl m1 m2), disjoint m1 m. -Proof. - repeat intro; eauto. - eapply map_incl_spec in Hincl; eauto. -Qed. - -Lemma disjoint_add : forall m1 m2 m3, disjoint m1 m2 -> disjoint m1 m3 -> disjoint m1 (map_add m2 m3). -Proof. - unfold disjoint; intros. - unfold map_add. - specialize (H _ _ H1); specialize (H0 _ _ H1). - rewrite H, H0; auto. -Qed. - -Global Program Instance map_disj_PCM : Ghost := { valid a := True; Join_G := map_disj_join }. -Next Obligation. - exists (fun _ => empty_map); auto; repeat intro. - - simpl. - destruct (t k); auto. - - exists empty_map; hnf. - intros; simpl; auto. -Defined. -Next Obligation. - constructor. - - intros. - extensionality k. - specialize (H k); specialize (H0 k). - destruct (x k), (y k); try congruence; contradiction. - - intros. - apply map_disj_join_spec in H as []; apply map_disj_join_spec in H0 as []; subst. - rewrite map_add_assoc. - eexists; rewrite !map_disj_join_spec; repeat split. - + eapply disjoint_incl; eauto. - rewrite map_add_comm by (apply disjoint_compatible; auto); apply map_incl_add. - + apply disjoint_add; auto. - eapply disjoint_incl; eauto. - apply map_incl_add. - - intros ???; rewrite !map_disj_join_spec; intros []; subst. - split; [symmetry | apply map_add_comm, disjoint_compatible]; auto. - - intros. - extensionality k; specialize (H k); specialize (H0 k). - destruct (a k), (b k); auto. - + destruct (a' k); [contradiction | auto]. - + destruct (a' k); [contradiction | auto]. - + destruct (b' k); [contradiction | auto]. -Qed. - -Lemma disj_join_sub : forall m1 m2, map_incl m1 m2 -> exists m3, join m1 m3 m2. -Proof. - intros; exists (fun x => match m2 x, m1 x with Some v, None => Some v | _, _ => None end). - intro k; specialize (H k). - destruct (m1 k); simpl in H. - - destruct (m2 k); [|contradiction]. - inv H; auto. - - destruct (m2 k); auto. -Qed. - -Definition all_disjoint (l : list (A -> option B)) := forall i j, 0 <= i < Zlength l -> 0 <= j < Zlength l -> - i <> j -> disjoint (Znth i l) (Znth j l). - -Lemma all_disjoint_compatible : forall l, all_disjoint l -> all_compatible l. -Proof. - unfold all_disjoint, all_compatible; intros. - apply In_Znth in H0 as (i & ? & ?); apply In_Znth in H1 as (j & ? & ?); subst. - destruct (eq_dec i j); [subst; reflexivity|]. - apply disjoint_compatible; auto. -Qed. - -Lemma all_disjoint_nil : all_disjoint []. -Proof. - repeat intro. - rewrite Zlength_nil in *; lia. -Qed. - -Lemma all_disjoint_cons : forall (m : A -> option B) l, all_disjoint (m :: l) <-> disjoint m (maps_add l) /\ all_disjoint l. -Proof. - split. - - split; repeat intro. - + destruct (maps_add l k) eqn: Hl; auto. - eapply in_maps_add in Hl as (m2 & ? & ?). - apply In_Znth in H1 as (j & ? & ?); subst. - specialize (H 0 (j + 1)). - rewrite Znth_0_cons, Znth_pos_cons, Z.add_simpl_r, Zlength_cons in H by lia. - erewrite H in H2; eauto; lia. - + specialize (H (i + 1) (j + 1)). - rewrite !Znth_pos_cons, !Z.add_simpl_r, Zlength_cons in H by lia. - eapply H; eauto; lia. - - intros []; repeat intro. - rewrite Zlength_cons in H1, H2. - destruct (eq_dec i 0), (eq_dec j 0); subst; try contradiction. - + rewrite Znth_0_cons in H4; rewrite Znth_pos_cons by lia. - specialize (H _ _ H4). - destruct (Znth _ _ _) eqn: Hj; auto. - apply maps_add_in with (l := l) in Hj; try congruence. - * apply all_disjoint_compatible; auto. - * apply Znth_In; lia. - + rewrite Znth_0_cons; rewrite Znth_pos_cons in H4 by lia. - destruct (m k) eqn: Hm; auto. - specialize (H _ _ Hm). - apply maps_add_in with (l := l) in H4; try congruence. - * apply all_disjoint_compatible; auto. - * apply Znth_In; lia. - + rewrite Znth_pos_cons in * by lia. - eapply (H0 (i - 1) (j - 1)); eauto; lia. -Qed. - -Lemma all_disjoint_rev1 : forall l, all_disjoint l -> all_disjoint (rev l). -Proof. - unfold all_disjoint; intros. - rewrite Zlength_rev in *. - rewrite !Znth_rev by auto. - apply H; lia. -Qed. - -Lemma all_disjoint_rev : forall l, all_disjoint l <-> all_disjoint (rev l). -Proof. - split; [apply all_disjoint_rev1|]. - intros H; apply all_disjoint_rev1 in H. - rewrite rev_involutive in H; auto. -Qed. - -Lemma maps_add_rev : forall l, all_compatible l -> maps_add (rev l) = maps_add l. -Proof. - induction l; auto; simpl; intros. - apply all_compatible_cons in H as []. - rewrite map_add_comm; auto. - rewrite fold_right_app; simpl. - rewrite map_add_empty. - rewrite (fold_right_maps_add _ a). - rewrite IHl; auto. -Qed. - -Lemma all_disjoint_snoc : forall m l, all_disjoint (l ++ [m]) <-> disjoint m (maps_add l) /\ all_disjoint l. -Proof. - intros. - replace (l ++ [m]) with (rev (m :: rev l)) by (simpl; rewrite rev_involutive; auto). - rewrite all_disjoint_rev, rev_involutive, all_disjoint_cons, <- all_disjoint_rev. - split; intros []; rewrite ?maps_add_rev in *; auto; apply all_disjoint_compatible; auto. -Qed. - -Lemma empty_map_disjoint : forall m, disjoint empty_map m. -Proof. - repeat intro; discriminate. -Qed. - -Definition map_sub (m : A -> option B) k := fun x => if eq_dec x k then None else m x. - -Lemma map_upd_sub : forall m (k : A) (v : B), m k = Some v -> map_upd (map_sub m k) k v = m. -Proof. - intros; unfold map_upd, map_sub. - extensionality x. - if_tac; subst; auto. -Qed. - -Lemma map_sub_upd : forall m (k : A) (v : B), m k = None -> map_sub (map_upd m k v) k = m. -Proof. - intros; unfold map_upd, map_sub. - extensionality x. - if_tac; subst; auto. -Qed. - -Lemma disjoint_sub : forall (m1 m2 : A -> option B) k, disjoint m1 m2 -> - disjoint (map_sub m1 k) m2. -Proof. - unfold map_sub, disjoint; intros. - destruct (eq_dec _ _); [discriminate | eauto]. -Qed. - -End Maps_Disjoint. - -End MapsL. - -Notation maps_add l := (fold_right map_add empty_map l). - -#[export] Hint Resolve empty_map_incl empty_map_disjoint all_disjoint_nil : core. - -Section GHist. - -(* Ghost histories in the style of Nanevsky *) -Context {hist_el : Type}. - -Notation hist_part := (nat -> option hist_el). - -Local Notation map_incl := (@map_incl _ (discrete_PCM hist_el) eq). - -Definition hist_sub sh (h : hist_part) hr := sh <> Share.bot /\ if eq_dec sh Tsh then h = hr - else map_incl h hr. - -Lemma completable_alt : forall sh h hr, @completable map_disj_PCM (Some (sh, h)) hr <-> hist_sub sh h hr. -Proof. - unfold completable, hist_sub; intros; simpl; split. - - intros ([(?, ?)|] & Hcase). - + destruct Hcase as (? & ? & Hsh & Hj); split; auto. - if_tac. - * subst; apply join_Tsh in Hsh; tauto. - * apply map_disj_join_spec in Hj as []; subst. - apply map_incl_add. - + hnf in Hcase. - inv Hcase. - rewrite eq_dec_refl; auto with share. - - if_tac. - + intros []; subst; exists None; split; auto. - + intros [? Hincl]. - apply disj_join_sub in Hincl as (h' & ?). - exists (Some (Share.comp sh, h')). - split; auto. - split. - { intro Hbot; contradiction H. - rewrite <- Share.comp_inv at 1. - rewrite Hbot; apply comp_bot. } - split; [apply comp_join_top | auto]. -Qed. - -Lemma hist_sub_upd : forall sh h hr t' e (Hsub : hist_sub sh h hr), - hist_sub sh (map_upd h t' e) (map_upd hr t' e). -Proof. - unfold hist_sub; intros. - destruct Hsub; split; auto. - if_tac; subst; auto. - eapply @map_upd2_incl; auto. - apply _. -Qed. - -Definition ghost_hist (sh : share) (h : hist_part) g := - own(RA := ref_PCM map_disj_PCM) g (Some (sh, h), None) NoneP. - -Lemma ghost_hist_join : forall sh1 sh2 sh h1 h2 p (Hsh : sepalg.join sh1 sh2 sh) - (Hsh1 : sh1 <> Share.bot) (Hsh2 : sh2 <> Share.bot), - ghost_hist sh1 h1 p * ghost_hist sh2 h2 p = !!(disjoint h1 h2) && ghost_hist sh (map_add h1 h2) p. -Proof. - intros; unfold ghost_hist. - erewrite own_op_gen. - apply pred_ext; Intros; apply andp_right, derives_refl; apply prop_right. - - destruct H as (? & [] & ?); simpl in *. - destruct (fst x) as [[]|]; [|contradiction]. - erewrite map_disj_join_spec in H; tauto. - - eexists (Some (sh, map_add h1 h2), None); split; [split|]; simpl. - + rewrite map_disj_join_spec; auto. - + constructor. - + split; auto. - intro; subst. - apply join_Bot in Hsh as []; auto. - - intros (? & [] & ?); simpl in *. - destruct (fst x) as [[]|]; [|contradiction]. - split; [simpl | constructor]. - erewrite map_disj_join_spec in *; tauto. -Qed. - -Definition hist_incl (h : hist_part) l := forall t e, h t = Some e -> nth_error l t = Some e. - -Definition hist_list (h : hist_part) l := forall t e, h t = Some e <-> nth_error l t = Some e. - -Lemma hist_list_inj : forall h l1 l2 (Hl1 : hist_list h l1) (Hl2 : hist_list h l2), l1 = l2. -Proof. - unfold hist_list; intros; apply list_nth_error_eq. - intro j; specialize (Hl1 j); specialize (Hl2 j). - destruct (nth_error l1 j). - - symmetry; rewrite <- Hl2, Hl1; auto. - - destruct (nth_error l2 j); auto. - specialize (Hl2 h0); erewrite Hl1 in Hl2; tauto. -Qed. - -Lemma hist_list_nil_inv1 : forall l, hist_list empty_map l -> l = []. -Proof. - unfold hist_list; intros. - destruct l; auto. - specialize (H O h); destruct H as [_ H]; specialize (H eq_refl); discriminate. -Qed. - -Lemma hist_list_nil_inv2 : forall h, hist_list h [] -> h = empty_map. -Proof. - unfold hist_list; intros. - extensionality t. - specialize (H t); destruct (h t); auto. - destruct (H h0) as [H' _]. - specialize (H' eq_refl); rewrite nth_error_nil in H'; discriminate. -Qed. - -Definition ghost_ref l g := EX hr : hist_part, !!(hist_list hr l) && - own(RA := ref_PCM map_disj_PCM) g (None, Some hr) NoneP. - -Lemma hist_next : forall h l (Hlist : hist_list h l), h (length l) = None. -Proof. - intros. - specialize (Hlist (length l)). - destruct (h (length l)); auto. - destruct (Hlist h0) as [H' _]. - pose proof (nth_error_Some l (length l)) as (Hlt & _). - lapply Hlt; [lia|]. - rewrite H' by auto; discriminate. -Qed. - -Definition ghost_hist_ref sh (h r : hist_part) g := - own(RA := ref_PCM map_disj_PCM) g (Some (sh, h), Some r) NoneP. - -Lemma hist_add : forall (sh : share) (h h' : hist_part) e p t' (Hfresh : h' t' = None), - ghost_hist_ref sh h h' p |-- |==> ghost_hist_ref sh (map_upd h t' e) (map_upd h' t' e) p. -Proof. - intros. - erewrite (add_andp (ghost_hist_ref _ _ _ _)) by apply own_valid. - Intros. - destruct H as [? Hcomp]; simpl in *. - erewrite completable_alt in Hcomp; destruct Hcomp as [_ Hcomp]. - apply (ref_add(P := map_disj_PCM)) with (b := fun k => if eq_dec k t' then Some e else None). - - repeat intro. - unfold map_upd. - if_tac; [|destruct (h k); auto]. - subst; destruct (h t') eqn: Hh; auto. - if_tac in Hcomp; [congruence|]. - eapply map_incl_spec in Hh; eauto; congruence. - - repeat intro. - unfold map_upd. - if_tac; [|destruct (h' k); auto]. - subst; rewrite Hfresh; auto. -Qed. - -Lemma hist_incl_nil : forall h, hist_incl empty_map h. -Proof. - repeat intro; discriminate. -Qed. - -Lemma hist_list_nil : hist_list empty_map []. -Proof. - split; [discriminate|]. - rewrite nth_error_nil; discriminate. -Qed. - -Lemma hist_list_snoc : forall h l e, hist_list h l -> - hist_list (map_upd h (length l) e) (l ++ [e]). -Proof. - unfold hist_list, map_upd; split. - - if_tac. - + intro X; inv X. - erewrite nth_error_app2, Nat.sub_diag; auto. - + rewrite H. - intro X; rewrite nth_error_app1; auto. - rewrite <- nth_error_Some, X; discriminate. - - if_tac. - + subst; rewrite nth_error_app2, Nat.sub_diag; auto. - + intro X; apply H; rewrite nth_error_app1 in X; auto. - assert (t < length (l ++ [e]))%nat; [|rewrite app_length in *; simpl in *; lia]. - rewrite <- nth_error_Some, X; discriminate. -Qed. - -Lemma hist_sub_list_incl : forall sh h h' l (Hsub : hist_sub sh h h') (Hlist : hist_list h' l), - hist_incl h l. -Proof. - unfold hist_list, hist_incl; intros. - apply Hlist. - destruct Hsub. - destruct (eq_dec sh Tsh); subst; auto. - eapply map_incl_spec; eauto. -Qed. - -Lemma hist_sub_Tsh : forall h h', hist_sub Tsh h h' <-> (h = h'). -Proof. - intros; unfold hist_sub; rewrite eq_dec_refl; repeat split; auto with share; tauto. -Qed. - -Lemma hist_ref_join : forall sh h l p, sh <> Share.bot -> - ghost_hist sh h p * ghost_ref l p = - EX h' : hist_part, !!(hist_list h' l /\ hist_sub sh h h') && ghost_hist_ref sh h h' p. -Proof. - unfold ghost_hist, ghost_ref; intros; apply pred_ext. - - Intros hr; Exists hr. - erewrite own_op_gen. - + Intros; apply andp_right, derives_refl; apply prop_right. - split; auto. - destruct H1 as ([g] & [H1 H2] & [? Hcompat]); simpl in *. - destruct g as [[]|]; [|contradiction]. - inv H1; inv H2. - apply completable_alt; auto. - + split; simpl; auto; constructor. - - Intros h'; Exists h'; entailer!. - erewrite <- own_op; [apply derives_refl|]. - split; simpl; auto; constructor. -Qed. - -Corollary hist_ref_join_nil : forall sh p, sh <> Share.bot -> - ghost_hist sh empty_map p * ghost_ref [] p = ghost_hist_ref sh empty_map empty_map p. -Proof. - intros; erewrite hist_ref_join by auto. - apply pred_ext; entailer!. - - apply hist_list_nil_inv2 in H0; subst; auto. - - Exists (fun _ : nat => @None hist_el); apply andp_right, derives_refl. - apply prop_right; split; [apply hist_list_nil|]. - split; auto. - if_tac; [auto|]. - reflexivity. -Qed. - -Lemma hist_ref_incl : forall sh h h' p, sh <> Share.bot -> - ghost_hist sh h p * ghost_ref h' p |-- !!hist_incl h h'. -Proof. - intros; erewrite hist_ref_join by auto. - Intros l; eapply prop_right, hist_sub_list_incl; eauto. -Qed. - -Lemma hist_add' : forall sh h h' e p, sh <> Share.bot -> - ghost_hist sh h p * ghost_ref h' p |-- |==> - ghost_hist sh (map_upd h (length h') e) p * ghost_ref (h' ++ [e]) p. -Proof. - intros; erewrite !hist_ref_join by auto. - Intros hr. - eapply derives_trans; [apply hist_add|]. - { apply hist_next; eauto. } - apply bupd_mono. - Exists (map_upd hr (length h') e); apply andp_right, derives_refl. - apply prop_right; split; [apply hist_list_snoc | apply hist_sub_upd]; auto. -Qed. - -Definition newer (l : hist_part) t := forall t', l t' <> None -> (t' < t)%nat. - -Lemma newer_trans : forall l t1 t2, newer l t1 -> (t1 <= t2)%nat -> newer l t2. -Proof. - repeat intro. - specialize (H _ H1); lia. -Qed. - -Corollary newer_upd : forall l t1 e t2, newer l t1 -> (t1 < t2)%nat -> - newer (map_upd l t1 e) t2. -Proof. - unfold newer, map_upd; intros. - destruct (eq_dec t' t1); [lia|]. - eapply newer_trans; eauto; lia. -Qed. - -Lemma newer_over : forall h t t', newer h t -> (t <= t')%nat -> h t' = None. -Proof. - intros. - specialize (H t'). - destruct (h t'); auto. - lapply H; [lia | discriminate]. -Qed. - -Corollary newer_out : forall h t, newer h t -> h t = None. -Proof. - intros; eapply newer_over; eauto. -Qed. - -Lemma add_new_inj : forall h h' t t' v v' (Ht : newer h t) (Ht' : newer h' t'), - map_upd h t v = map_upd h' t' v' -> h = h' /\ t = t' /\ v = v'. -Proof. - intros. - pose proof (equal_f H t) as Hh. - pose proof (equal_f H t') as Hh'. - pose proof (newer_out _ _ Ht) as Hout. - pose proof (newer_out _ _ Ht') as Hout'. - unfold map_upd in Hh, Hh'. - rewrite !eq_dec_refl in Hh, Hh'. - if_tac in Hh. - - inv Hh; clear Hh'. - repeat split; auto. - erewrite <- (map_sub_upd h) by (eapply newer_out; eauto). - erewrite H, map_sub_upd; auto. - - erewrite if_false in Hh' by auto. - lapply (Ht t'); [|rewrite Hh'; discriminate]. - lapply (Ht' t); [|rewrite <- Hh; discriminate]. - lia. -Qed. - -Lemma hist_incl_lt : forall h l, hist_incl h l -> newer h (length l). -Proof. - unfold hist_incl; repeat intro. - specialize (H t'). - destruct (h t'); [|contradiction]. - specialize (H _ eq_refl). - rewrite <- nth_error_Some, H; discriminate. -Qed. - -Corollary hist_list_lt : forall h l, hist_list h l -> newer h (length l). -Proof. - intros; apply hist_incl_lt; repeat intro; apply H; auto. -Qed. - -(* We want to be able to remove irrelevant operations from a history, leading to a slightly weaker - correspondence between history and list of operations. *) -Inductive hist_list' : hist_part -> list hist_el -> Prop := -| hist_list'_nil : hist_list' empty_map [] -| hist_list'_snoc : forall h l t e (Hlast : newer h t) (Hrest : hist_list' h l), - hist_list' (map_upd h t e) (l ++ [e]). -Local Hint Resolve hist_list'_nil : core. - -Lemma hist_list'_in : forall h l (Hl : hist_list' h l) e, (exists t, h t = Some e) <-> In e l. -Proof. - induction 1. - - split; [intros (? & ?); discriminate | contradiction]. - - intro; subst; split. - + unfold map_upd; intros (? & Hin); erewrite in_app in *. - destruct (eq_dec x t); [inv Hin; simpl; auto|]. - rewrite <- IHHl; eauto. - + rewrite in_app; intros [Hin | [Heq | ?]]; [| inv Heq | contradiction]. - * rewrite <- IHHl in Hin; destruct Hin as (? & ?). - apply newer_out in Hlast. - unfold map_upd; exists x; if_tac; auto; congruence. - * unfold map_upd; eexists; apply eq_dec_refl. -Qed. - -Lemma hist_list_weak : forall l h (Hl : hist_list h l), hist_list' h l. -Proof. - induction l using rev_ind; intros. - - apply hist_list_nil_inv2 in Hl; subst; auto. - - destruct (Hl (length l) x) as (_ & H); exploit H. - { rewrite nth_error_app2, Nat.sub_diag by lia; auto. } - intro Hx. - set (h0 := fun k => if eq_dec k (length l) then None else h k). - replace h with (map_upd h0 (length l) x). - constructor. - + pose proof (hist_list_lt _ _ Hl) as Hn. - intro t; specialize (Hn t). - subst h0; simpl; if_tac; [contradiction|]. - intro X; specialize (Hn X); rewrite app_length in Hn; simpl in Hn; lia. - + apply IHl. - intros t e; specialize (Hl t e). - subst h0; simpl; if_tac. - * split; [discriminate|]. - intro X; assert (t < length l)%nat by (rewrite <- nth_error_Some, X; discriminate); lia. - * rewrite Hl; destruct (lt_dec t (length l)). - { erewrite nth_error_app1 by auto; reflexivity. } - split; intro X. - -- assert (t < length (l ++ [x]))%nat by (rewrite <- nth_error_Some, X; discriminate); - rewrite app_length in *; simpl in *; lia. - -- assert (t < length l)%nat by (rewrite <- nth_error_Some, X; discriminate); contradiction. - + unfold map_upd; subst h0; simpl. - extensionality k'; if_tac; subst; auto. -Qed. - -Lemma hist_list'_add : forall h1 h2 (l : list hist_el) (Hdisj : disjoint h1 h2), hist_list' (map_add h1 h2) l -> - exists l1 l2, Permutation l (l1 ++ l2) /\ hist_list' h1 l1 /\ hist_list' h2 l2. -Proof. - intros. - remember (map_add h1 h2) as h. - revert dependent h2; revert h1; induction H; intros. - - exists [], []; split; [reflexivity|]. - assert (h1 = empty_map /\ h2 = empty_map) as []. - { split; extensionality k; apply equal_f with (x := k) in Heqh; unfold map_add in Heqh; - destruct (h1 k); auto; discriminate. } - subst; split; constructor. - - pose proof (equal_f Heqh t) as Ht. - unfold map_upd, map_add in Ht. - erewrite eq_dec_refl in Ht by auto. - destruct (h1 t) eqn: Hh1. - + inv Ht. - destruct (IHhist_list' (map_sub h1 t) h2) as (l1 & l2 & ? & ? & ?). - { apply disjoint_sub; auto. } - { extensionality k. - apply equal_f with (x := k) in Heqh. - unfold map_upd, map_sub, map_add in *. - if_tac; auto; subst. - apply newer_out in Hlast. - apply Hdisj in Hh1; congruence. } - exists (l1 ++ [h0]), l2; repeat split; auto. - * etransitivity; [|apply Permutation_app_comm]. - rewrite app_assoc; apply Permutation_app_tail. - etransitivity; eauto. - apply Permutation_app_comm. - * erewrite <- (map_upd_sub h1 t) by eauto. - constructor; auto. - repeat intro. - unfold map_sub in *. - apply equal_f with (x := t') in Heqh. - unfold map_upd, map_add in Heqh. - apply Hlast. - destruct (eq_dec _ _); [contradiction|]. - destruct (h1 t'); [congruence | contradiction]. - + destruct (IHhist_list' h1 (map_sub h2 t)) as (l1 & l2 & ? & ? & ?). - { symmetry; apply disjoint_sub; symmetry; auto. } - { extensionality k. - apply equal_f with (x := k) in Heqh. - unfold map_upd, map_sub, map_add in *. - if_tac; auto; subst. - apply newer_out in Hlast. - rewrite Hh1; auto. } - exists l1, (l2 ++ [e]); repeat split; auto. - * rewrite app_assoc; apply Permutation_app_tail; auto. - * erewrite <- (map_upd_sub h2 t) by eauto. - constructor; auto. - repeat intro. - unfold map_sub in *. - apply equal_f with (x := t') in Heqh. - unfold map_upd, map_add in Heqh. - apply Hlast. - destruct (eq_dec _ _); [contradiction|]. - destruct (h1 t'); congruence. -Qed. - -Lemma ghost_hist_init : @valid (ref_PCM (@map_disj_PCM nat hist_el)) (Some (Tsh, empty_map), Some empty_map). -Proof. - split; simpl; auto with share. - rewrite completable_alt; split; auto with share. - rewrite eq_dec_refl; auto. -Qed. - -Inductive add_events h : list hist_el -> hist_part -> Prop := -| add_events_nil : add_events h [] h -| add_events_snoc : forall le h' t e (Hh' : add_events h le h') (Ht : newer h' t), - add_events h (le ++ [e]) (map_upd h' t e). -Local Hint Resolve add_events_nil : core. - -Lemma add_events_1 : forall h t e (Ht : newer h t), add_events h [e] (map_upd h t e). -Proof. - intros; apply (add_events_snoc _ []); auto. -Qed. - -Lemma add_events_trans : forall h le h' le' h'' (H1 : add_events h le h') (H2 : add_events h' le' h''), - add_events h (le ++ le') h''. -Proof. - induction 2. - - rewrite app_nil_r; auto. - - rewrite app_assoc; constructor; auto. -Qed. - -Lemma add_events_add : forall h le h', add_events h le h' -> - exists h2, h' = map_add h h2 /\ forall t e, h2 t = Some e -> newer h t /\ In e le. -Proof. - induction 1. - - eexists; erewrite map_add_empty; split; auto; discriminate. - - destruct IHadd_events as (h2 & ? & Hh2); subst. - assert (compatible h h2). - { repeat intro. - destruct (Hh2 _ _ H1) as [Hk _]. - specialize (Hk k); lapply Hk; [lia | congruence]. } - assert (newer h t). - { repeat intro; apply Ht. - unfold map_add. - destruct (h t'); auto. } - erewrite map_add_comm, map_add_upd, map_add_comm; auto. - eexists; split; eauto; intros. - unfold map_upd in *. - rewrite in_app; simpl. - destruct (eq_dec t0 t); [inv H2; auto|]. - destruct (Hh2 _ _ H2); auto. - { apply compatible_upd; [symmetry; auto|]. - specialize (H1 t). - destruct (h t); auto. - lapply H1; [lia | discriminate]. } -Qed. - -Corollary add_events_dom : forall h le h' t e, add_events h le h' -> h' t = Some e -> - h t = Some e \/ In e le. -Proof. - intros; apply add_events_add in H as (? & ? & Hh2); subst. - unfold map_add in H0. - destruct (h t); [inv H0; auto|]. - destruct (Hh2 _ _ H0); auto. -Qed. - -Corollary add_events_incl : forall h le h', add_events h le h' -> map_incl h h'. -Proof. - intros; apply add_events_add in H as (? & ? & ?); subst. - apply map_incl_add. -Qed. - -Corollary add_events_newer : forall h le h' t, add_events h le h' -> newer h' t -> newer h t. -Proof. - repeat intro. - apply H0. - destruct (h t') eqn: Ht'; [|contradiction]. - eapply map_incl_spec in Ht' as ->; eauto. - eapply add_events_incl; eauto. -Qed. - -Lemma add_events_in : forall h le h' e, add_events h le h' -> In e le -> - exists t, newer h t /\ h' t = Some e. -Proof. - induction 1; [contradiction|]. - rewrite in_app; intros [? | [? | ?]]; try contradiction. - - destruct IHadd_events as (? & ? & ?); auto. - do 2 eexists; eauto. - unfold map_upd; if_tac; auto; subst. - specialize (Ht t); rewrite H2 in Ht; lapply Ht; [lia | discriminate]. - - subst; unfold map_upd; do 2 eexists; [|apply eq_dec_refl]. - eapply add_events_newer; eauto. -Qed. - -End GHist. - -#[export] Hint Resolve hist_incl_nil hist_list_nil hist_list'_nil add_events_nil : core. -(*#[export] Hint Resolve ghost_var_precise ghost_var_precise'.*) -#[export] Hint Resolve (*ghost_var_init*) master_init (*ghost_map_init*) ghost_hist_init : init. - -Lemma wand_nonexpansive_l: forall P Q n, - approx n (P -* Q)%logic = approx n (approx n P -* Q)%logic. -Proof. - apply wand_nonexpansive_l. -Qed. - -Lemma wand_nonexpansive_r: forall P Q n, - approx n (P -* Q)%logic = approx n (P -* approx n Q)%logic. -Proof. - apply wand_nonexpansive_r. -Qed. - -Lemma wand_nonexpansive: forall P Q n, - approx n (P -* Q)%logic = approx n (approx n P -* approx n Q)%logic. -Proof. - apply wand_nonexpansive. -Qed. - -Corollary view_shift_nonexpansive : forall P Q n, - approx n (P -* |==> Q)%logic = approx n (approx n P -* |==> approx n Q)%logic. -Proof. - intros. - rewrite wand_nonexpansive, approx_bupd; reflexivity. -Qed. - -Ltac ghost_alloc G := - match goal with |-semax _ (PROPx _ (LOCALx _ (SEPx (?R1 :: _)))) _ _ => - rewrite <- (emp_sepcon R1) at 1; Intros; viewshift_SEP 0 (EX g : _, G g); - [go_lowerx; eapply derives_trans; [|unseal_derives; apply fupd.bupd_fupd]; rewrite ?emp_sepcon; - apply own_alloc; auto; simpl; auto with init share ghost|] end. - -Ltac ghosts_alloc G n := - match goal with |-semax _ (PROPx _ (LOCALx _ (SEPx (?R1 :: _)))) _ _ => - rewrite <- (emp_sepcon R1) at 1; Intros; viewshift_SEP 0 (EX lg : _, !!(Zlength lg = n) && iter_sepcon G lg); - [go_lowerx; eapply derives_trans; [|unseal_derives; apply fupd.bupd_fupd]; rewrite ?emp_sepcon; - apply own_list_alloc'; auto; simpl; auto with init share ghost|] end. diff --git a/concurrency/ghostsI.v b/concurrency/ghostsI.v deleted file mode 100644 index 5daa0825d..000000000 --- a/concurrency/ghostsI.v +++ /dev/null @@ -1,321 +0,0 @@ -Require Import VST.veric.compcert_rmaps. -Require Export VST.concurrency.ghosts. -Require Import VST.concurrency.conclib. -Require Import VST.veric.bi. -Require Import VST.msl.sepalg. -Import List. - -(* Lemmas about ghost state, proved with Iris bupd *) - -#[export] Instance unfash_persistent P : Persistent (alg_seplog.unfash P). -Proof. - change unfash with (@subtypes.unfash rmap _ _). - constructor; intros ??; hnf. - unfold bi_persistently; simpl. - unfold unfash in *; simpl in *. - rewrite level_core; auto. -Qed. - -Section ghost. - -Context {RA: Ghost}. - -Lemma own_alloc_strong : forall P (a : G) (pp : preds), ghost_seplog.pred_infinite P -> valid a -> - emp |-- (|==> EX g : own.gname, !!(P g) && own g a pp)%I. -Proof. - exact own_alloc_strong. -Qed. - -Lemma own_alloc : forall (a : G) (pp : preds), valid a -> emp%I |-- (|==> EX g : own.gname, own g a pp)%I. -Proof. - exact own_alloc. -Qed. - -Global Instance own_dealloc g a pp : Affine (own g a pp). -Proof. - unfold Affine. - apply own_dealloc. -Qed. - -Lemma own_update : forall g a b pp, fp_update a b -> own g a pp |-- (|==> own g b pp)%I. -Proof. - exact own_update. -Qed. - -Lemma own_update_ND : forall g a B pp, fp_update_ND a B -> own g a pp |-- (|==> EX b : G, !! B b && own g b pp)%I. -Proof. - exact own_update_ND. -Qed. - -Lemma own_list_alloc : forall la lp, Forall valid la -> length lp = length la -> - emp |-- (|==> (EX lg : _, !!(Zlength lg = Zlength la) && - iter_sepcon (fun '(g, a, p) => own g a p) (combine (combine lg la) lp)))%I. -Proof. - exact own_list_alloc. -Qed. - -Corollary own_list_alloc' : forall a pp i, 0 <= i -> valid a -> - emp |-- (|==> (EX lg : _, !!(Zlength lg = i) && iter_sepcon (fun g => own g a pp) lg))%I. -Proof. - exact own_list_alloc'. -Qed. - -Lemma own_list_dealloc : forall {A} f (l : list A), - (forall b, exists g a pp, f b |-- own g a pp) -> - iter_sepcon f l |-- (emp)%I. -Proof. - intros; apply own_list_dealloc; auto. -Qed. - -Lemma own_list_dealloc' : forall {A} g a p (l : list A), - iter_sepcon (fun x => own (g x) (a x) (p x)) l |-- (emp)%I. -Proof. - intros; apply own_list_dealloc'. -Qed. - -Lemma core_persistent : forall g a p, a = core a -> Persistent (own g a p). -Proof. - intros; unfold Persistent. - constructor. - intros ??; unfold bi_persistently; simpl. - apply own.own_core; auto. -Qed. - -End ghost. - -Lemma exclusive_update : forall {A} (v v' : A) p, excl p v |-- (|==> excl p v')%I. -Proof. - intros; apply exclusive_update. -Qed. - -Section Snapshot. - -Context `{ORD : PCM_order}. - -Lemma master_update : forall v v' p, ord v v' -> ghost_master Tsh v p |-- (|==> ghost_master Tsh v' p)%I. -Proof. - exact master_update. -Qed. - -Lemma make_snap : forall (sh : share) v p, ghost_master sh v p |-- (|==> ghost_snap v p * ghost_master sh v p)%I. -Proof. - exact make_snap. -Qed. - -Lemma ghost_snap_forget : forall v1 v2 p, ord v1 v2 -> ghost_snap v2 p |-- (|==> ghost_snap v1 p)%I. -Proof. - exact ghost_snap_forget. -Qed. - -Lemma ghost_snap_choose : forall v1 v2 p, ghost_snap v1 p * ghost_snap v2 p |-- (|==> ghost_snap v1 p)%I. -Proof. - exact ghost_snap_choose. -Qed. - -Lemma snap_master_update1 : forall v1 v2 p v', ord v2 v' -> - ghost_snap v1 p * ghost_master1 v2 p |-- (|==> ghost_snap v' p * ghost_master1 v' p)%I. -Proof. - exact snap_master_update1. -Qed. - -Global Instance snap_persistent v p : Persistent (ghost_snap v p). -Proof. - apply core_persistent; auto. -Qed. - -End Snapshot. - -Section Reference. - -Context {P : Ghost}. - -Lemma part_ref_update : forall g sh a r a' r' - (Ha' : forall b, join a b r -> join a' b r' /\ (a = r -> a' = r')), - ghost_part_ref sh a r g |-- (|==> ghost_part_ref sh a' r' g). -Proof. - exact part_ref_update. -Qed. - -Lemma ref_add : forall g sh a r b a' r' - (Ha : join a b a') (Hr : join r b r'), - ghost_part_ref sh a r g |-- (|==> ghost_part_ref sh a' r' g)%I. -Proof. - exact ref_add. -Qed. - -End Reference. - -Section GVar. - -Context {A : Type}. - -Notation ghost_var := (@ghost_var A). - -Lemma ghost_var_update : forall v p v', ghost_var Tsh v p |-- (|==> ghost_var Tsh v' p)%I. -Proof. - exact ghost_var_update. -Qed. - -Lemma ghost_var_update' : forall g (v1 v2 v : A), ghost_var gsh1 v1 g * ghost_var gsh2 v2 g |-- - |==> !!(v1 = v2) && (ghost_var gsh1 v g * ghost_var gsh2 v g). -Proof. - exact ghost_var_update'. -Qed. - -End GVar. - -Section PVar. - -Lemma snap_master_update' : forall (v1 v2 : nat) p v', (v2 <= v')%nat -> - ghost_snap v1 p * ghost_master1 v2 p |-- (|==> ghost_snap v' p * ghost_master1 v' p)%I. -Proof. - intros; apply snap_master_update1; auto. -Qed. - -End PVar. - -Section Reference. - -Context {P : Ghost}. - -Lemma ref_update : forall g a r a', - ghost_part_ref Tsh a r g |-- (|==> ghost_part_ref Tsh a' a' g)%I. -Proof. - exact ref_update. -Qed. - -End Reference. - -Section GHist. - -(* Ghost histories in the style of Nanevsky *) -Context {hist_el : Type}. - -Notation hist_part := (nat -> option hist_el). - -Lemma hist_add : forall (sh : share) (h h' : hist_part) e p t' (Hfresh : h' t' = None), - ghost_hist_ref sh h h' p |-- (|==> ghost_hist_ref sh (map_upd h t' e) (map_upd h' t' e) p)%I. -Proof. - exact hist_add. -Qed. - -Notation ghost_hist := (@ghost_hist hist_el). - -Lemma hist_add' : forall sh h h' e p, sh <> Share.bot -> - ghost_hist sh h p * ghost_ref h' p |-- (|==> - ghost_hist sh (map_upd h (length h') e) p * ghost_ref (h' ++ [e]) p)%I. -Proof. - exact hist_add'. -Qed. - -End GHist. - -(* speed up destructs of the form [% H] *) -#[export] Existing Instance class_instances.into_sep_and_persistent_l. - -Require Import iris.algebra.gmap. - -(* universe inconsistency, reflecting a real difference in expressive power -#[local] Program Instance RA_ghost (A : cmra) : Ghost := { G := cmra_car A; Join_G a b c := cmra_op A a b = c }. -*) - -Section gmap_ghost. - -Context {K} `{Countable K} {A : Ghost}. - -Program Instance gmap_ghost : Ghost := { G := gmap K G; Join_G a b c := forall k, sepalg.join (a !! k) (b !! k) (c !! k); - valid a := True%type }. -Next Obligation. -Proof. - exists (fun m => gmap_fmap _ _ sepalg.core m); intros. - - intros k. - rewrite lookup_fmap. - destruct (t !! k); constructor. - apply core_unit. - - exists (gmap_fmap _ _ sepalg.core c); intros k. - rewrite !lookup_fmap. - specialize (H0 k); inv H0; try constructor. - + destruct (a !! k); constructor. - apply core_duplicable. - + eapply core_sub_join, join_core_sub, H4. - - apply map_eq; intros k. - rewrite !lookup_fmap. - destruct (a !! k); auto; simpl. - rewrite core_idem; auto. -Defined. -Next Obligation. -Proof. - constructor; intros. - - apply map_eq; intros k. - specialize (H0 k); specialize (H1 k). - inv H0; inv H1; auto; try congruence. - rewrite <- H2 in H0; inv H0. - rewrite <- H3 in H6; inv H6. - f_equal; eapply join_eq; eauto. - - exists (map_imap (fun k _ => projT1 (join_assoc (H0 k) (H1 k))) (b ∪ c)). - split; intros k; pose proof (H0 k) as Hj1; pose proof (H1 k) as Hj2; - rewrite map_lookup_imap lookup_union; destruct (join_assoc (H0 k) (H1 k)) as (? & ? & ?); - destruct (b !! k) eqn: Hb; simpl; auto. - + inv j; constructor; auto. - + inv j; [|constructor]. - destruct (c !! k); constructor. - + inv j; auto. - + inv j; auto. - destruct (c !! k); auto. - - intros k; specialize (H0 k). - apply sepalg.join_comm; auto. - - apply map_eq; intros k. - specialize (H0 k); specialize (H1 k). - inv H0; inv H1; try congruence. - rewrite <- H2 in H7; inv H7. - rewrite <- H0 in H4; inv H4. - f_equal; eapply join_positivity; eauto. -Qed. -Next Obligation. -Proof. - auto. -Qed. - -Context `{A_order : PCM_order(P := A)}. - -Lemma map_included_option_ord : forall (a b : gmap K G), map_included ord a b -> forall k, option_ord(ord := ord) (a !! k) (b !! k). -Proof. - intros. - specialize (H0 k); destruct (a !! k), (b !! k); simpl; auto. -Qed. - -#[export] Instance gmap_order : PCM_order (map_included ord). -Proof. - constructor. - - apply (map_included_preorder(M := gmap K)), _. - - intros. - pose proof (map_included_option_ord _ _ H0) as Ha. - pose proof (map_included_option_ord _ _ H1) as Hb. - exists (map_imap (fun k _ => proj1_sig (ord_lub(PCM_order := option_order(ORD := A_order)) _ _ _ (Ha k) (Hb k))) (map_union a b)). - split; intros k; pose proof (H0 k) as Hj1; pose proof (H1 k) as Hj2; - rewrite map_lookup_imap lookup_union; destruct (ord_lub _ _ _ (Ha k) (Hb k)) as (? & ? & ?); simpl; - destruct (a !! k) eqn: Ha1; rewrite Ha1 in j |- *; simpl; auto. - + destruct (b !! k) eqn: Hb1; rewrite Hb1 in j |- *; simpl; auto. - + destruct (b !! k) eqn: Hb1; rewrite Hb1 in j |- *; simpl; auto; constructor. - + destruct (b !! k) eqn: Hb1; rewrite Hb1 in j |- *; - destruct x, (c !! k) eqn: Hc; rewrite Hc in o |- *; simpl; auto. - + destruct (b !! k) eqn: Hb1; rewrite Hb1 in j |- *; - destruct x, (c !! k) eqn: Hc; rewrite Hc in o |- *; simpl; auto. - - split; intros k; specialize (H0 k); inv H0; simpl; auto. - + destruct (b !! k) eqn: Hb; rewrite Hb; auto. - + destruct (a !! k) eqn: Ha; rewrite Ha; simpl; auto. - reflexivity. - + apply join_ord in H4 as []; auto. - + destruct (b !! k) eqn: Hb; rewrite Hb; simpl; auto. - reflexivity. - + destruct (a !! k) eqn: Ha; rewrite Ha; auto. - + apply join_ord in H4 as []; auto. - - intros ??? k. - specialize (H0 k). - destruct (b !! k) eqn: Hb; rewrite Hb in H0 |- *; [|constructor]. - destruct (a !! k) eqn: Ha; rewrite Ha in H0 |- *; [|contradiction]. - constructor; apply ord_join; auto. -Qed. - - -End gmap_ghost. diff --git a/concurrency/invariants.v b/concurrency/invariants.v deleted file mode 100644 index 39cd96c7a..000000000 --- a/concurrency/invariants.v +++ /dev/null @@ -1,211 +0,0 @@ -Require Import stdpp.namespaces. -Require Import VST.veric.invariants. -Require Import VST.msl.ghost_seplog. -Require Import VST.msl.sepalg_generators. -Require Import VST.veric.compcert_rmaps. -Require Import VST.concurrency.conclib. -Require Export VST.concurrency.ghostsI. -Require Import VST.veric.bi. -Require Import VST.msl.sepalg. -Require Import List. -Import Ensembles. - -#[export] Notation iname := iname. - -Lemma coPset_to_Ensemble_minus : forall E1 E2, coPset_to_Ensemble (E1 ∖ E2) = Setminus (coPset_to_Ensemble E1) (coPset_to_Ensemble E2). -Proof. - intros; unfold coPset_to_Ensemble. - apply Extensionality_Ensembles; split; intros ? Hin; unfold In in *. - - apply elem_of_difference in Hin as []; constructor; auto. - - inv Hin. apply elem_of_difference; auto. -Qed. - -Lemma coPset_to_Ensemble_single : forall x, coPset_to_Ensemble {[Pos.of_nat (S x)]} = Singleton x. -Proof. - intros; unfold coPset_to_Ensemble. - apply Extensionality_Ensembles; split; intros ? Hin; unfold In in *. - - apply elem_of_singleton in Hin. - apply (f_equal Pos.to_nat) in Hin. - rewrite -> !Nat2Pos.id in Hin by auto; inv Hin; constructor. - - inv Hin. - apply elem_of_singleton; auto. -Qed. - -(* recapitulating Iris "semantic invariants" so we can use custom namespaces. *) -Definition inv (N : namespace) (P : mpred) : mpred := - □ ∀ E, ⌜↑N ⊆ E⌝ → |={E,E ∖ ↑N}=> ▷ P ∗ (▷ P ={E ∖ ↑N,E}=∗ emp). - -Definition own_inv (N : namespace) (P : mpred) := - ∃ i, ⌜Pos.of_nat (S i) ∈ (↑N:coPset)⌝ ∧ invariant i P. - -Lemma own_inv_acc E N P : - ↑N ⊆ E → own_inv N P |-- |={E,E∖↑N}=> ▷ P ∗ (▷ P ={E∖↑N,E}=∗ emp). -Proof. - intros. - iDestruct 1 as (i) "[% HiP]". - iPoseProof (inv_open (coPset_to_Ensemble E) with "HiP") as "H". - { unfold Ensembles.In, coPset_to_Ensemble; set_solver. } - iAssert (|={E,E ∖ {[Pos.of_nat (S i)]}}=> |> P * (|> P -* |={E ∖ {[Pos.of_nat (S i)]},E}=> emp)) with "[H]" as "H". - { unfold fupd, bi_fupd_fupd; simpl. - rewrite coPset_to_Ensemble_minus coPset_to_Ensemble_single; auto. } - iMod "H"; iApply fupd_mask_intro; first by set_solver. - iIntros "mask". - iDestruct "H" as "[$ H]"; iIntros "?". - iMod "mask"; iMod ("H" with "[$]"); auto. -Qed. - -Lemma fresh_inv_name n N : ∃ i, (n <= i)%nat /\ Pos.of_nat (S i) ∈ (↑N:coPset). -Proof. - pose proof (coPpick_elem_of (↑ N ∖ gset_to_coPset (list_to_set (map (fun i => Z.to_pos (i + 1)) (upto n))))). - rewrite elem_of_difference in H; destruct H as [HN H]. - { apply coPset_infinite_finite, difference_infinite, gset_to_coPset_finite. - apply coPset_infinite_finite, nclose_infinite. } - exists (Pos.to_nat (coPpick (↑ N ∖ gset_to_coPset (list_to_set (map (fun i => Z.to_pos (i + 1)) (upto n))))) - 1)%nat; split. - - match goal with |-(?a <= ?b)%nat => destruct (le_lt_dec a b); auto; exfalso end. - apply H, elem_of_gset_to_coPset, elem_of_list_to_set, elem_of_list_In, in_map_iff. - apply Nat2Z.inj_lt in l. - setoid_rewrite In_upto; eexists; split; [|split; [|apply l]]; lia. - - destruct (eq_dec (coPpick (↑N ∖ gset_to_coPset (list_to_set (map (λ i : Z, Z.to_pos (i + 1)) (upto n))))) 1%positive). - + rewrite e in HN |- *; auto. - + rewrite -> Nat2Pos.inj_succ, Nat2Pos.inj_sub, Pos2Nat.id, Positive_as_OT.sub_1_r, Pos.succ_pred; auto; lia. -Qed. - -Lemma own_inv_alloc N E P : ▷ P |-- |={E}=> own_inv N P. -Proof. - iIntros "HP". - iPoseProof (inv_alloc_strong _ _ (fun i => Pos.of_nat (S i) ∈ (↑N : coPset)) with "HP") as "H"; - auto using fresh_inv_name. -Qed. - -Global Instance agree_persistent g P : Persistent (agree g P : mpred). -Proof. - apply core_persistent; auto. -Qed. - -Lemma own_inv_to_inv M P: own_inv M P |-- inv M P. -Proof. - iIntros "#I !>". iIntros (E H). - iPoseProof (own_inv_acc with "I") as "H"; eauto. -Qed. - -Global Instance inv_persistent N P : Persistent (inv N P). -Proof. - apply _. -Qed. - -Global Instance inv_affine N P : Affine (inv N P). -Proof. - apply _. -Qed. - -Lemma invariant_dup : forall N P, inv N P = (inv N P * inv N P)%logic. -Proof. - intros; apply pred_ext; rewrite <- (bi.persistent_sep_dup (inv N P)); auto. -Qed. - -Lemma agree_join : forall g P1 P2, agree g P1 * agree g P2 |-- (|> P1 -* |> P2) * agree g P1. -Proof. - constructor; apply agree_join. -Qed. - -Lemma agree_join2 : forall g P1 P2, agree g P1 * agree g P2 |-- (|> P1 -* |> P2) * agree g P2. -Proof. - constructor; apply agree_join2. -Qed. - -Lemma inv_alloc : forall N E P, |> P |-- |={E}=> inv N P. -Proof. - intros; iIntros "?"; iApply own_inv_to_inv; iApply own_inv_alloc; auto. -Qed. - -Lemma make_inv : forall N E P Q, (P |-- Q) -> P |-- |={E}=> inv N Q. -Proof. - intros. - eapply derives_trans, inv_alloc; auto. - eapply derives_trans, now_later; auto. -Qed. - -Global Instance into_inv_inv N P : IntoInv (inv N P) N := {}. - -#[export] Instance into_acc_inv N P E: - IntoAcc (X := unit) (inv N P) - (↑N ⊆ E) emp (updates.fupd E (E ∖ ↑N)) (updates.fupd (E ∖ ↑N) E) - (λ _ : (), (▷ P)%I) (λ _ : (), (▷ P)%I) (λ _ : (), None). -Proof. - rewrite /inv /IntoAcc /accessor bi.exist_unit. - intros; iIntros "#I _". - iMod ("I" with "[%]"); auto. -Qed. - -(* up *) -Lemma persistently_nonexpansive : nonexpansive persistently. -Proof. - intros; unfold nonexpansive, persistently. - intros; split; intros ?????; simpl in *; eapply (H (core a'')); eauto; - rewrite level_core; apply necR_level in H1; apply ext_level in H2; lia. -Qed. - -Lemma persistently_nonexpansive2 : forall f, nonexpansive f -> - nonexpansive (fun a => persistently (f a)). -Proof. - intros; unfold nonexpansive. - intros; eapply predicates_hered.derives_trans; [apply H|]. - apply persistently_nonexpansive. -Qed. - -Lemma bupd_nonexpansive : nonexpansive own.bupd. -Proof. - unfold nonexpansive, own.bupd; split; simpl; intros; - apply H3 in H4 as (? & ? & ? & ? & ? & ? & ?); do 2 eexists; eauto; do 2 eexists; eauto; - repeat (split; auto); eapply (H x0); eauto; apply necR_level in H1; apply ext_level in H2; lia. -Qed. - -Lemma bupd_nonexpansive2 : forall f, nonexpansive f -> - nonexpansive (fun a => own.bupd (f a)). -Proof. - intros; unfold nonexpansive. - intros; eapply predicates_hered.derives_trans; [apply H|]. - apply bupd_nonexpansive. -Qed. - -Lemma fupd_nonexpansive1 : forall E1 E2, nonexpansive (fupd.fupd E1 E2). -Proof. - unfold fupd.fupd, nonexpansive; intros. - apply (contractive.wand_nonexpansive (fun _ => wsat * ghost_set g_en E1)%pred - (fun P => (|==> |> predicates_hered.FF || wsat * ghost_set g_en E2 * P)%pred) - (const_nonexpansive _)). - apply bupd_nonexpansive2, @disj_nonexpansive, sepcon_nonexpansive, identity_nonexpansive; apply const_nonexpansive. -Qed. - -Lemma fupd_nonexpansive2 : forall E1 E2 f, nonexpansive f -> - nonexpansive (fun a => fupd.fupd E1 E2 (f a)). -Proof. - intros; unfold nonexpansive. - intros; eapply predicates_hered.derives_trans; [apply H|]. - apply fupd_nonexpansive1. -Qed. - -Lemma later_nonexpansive1 : nonexpansive (box laterM). -Proof. - apply contractive_nonexpansive, later_contractive, identity_nonexpansive. -Qed. - -Lemma inv_nonexpansive : forall N, nonexpansive (inv N). -Proof. - intros; unfold inv. - unfold bi_intuitionistically, bi_affinely, bi_persistently; simpl. - apply @conj_nonexpansive, persistently_nonexpansive2, @forall_nonexpansive; intros. - { apply const_nonexpansive. } - apply @impl_nonexpansive, fupd_nonexpansive2, sepcon_nonexpansive, contractive.wand_nonexpansive, fupd_nonexpansive2; - try apply later_nonexpansive1; apply const_nonexpansive. -Qed. - -Lemma inv_nonexpansive2 : forall N f, nonexpansive f -> - nonexpansive (fun a => inv N (f a)). -Proof. - intros; unfold nonexpansive. - intros; eapply predicates_hered.derives_trans; [apply H|]. - apply inv_nonexpansive. -Qed. - -Global Opaque inv. diff --git a/concurrency/juicy/Clight_safety.v b/concurrency/juicy/Clight_safety.v index 5496f97bc..31f5d4fb0 100644 --- a/concurrency/juicy/Clight_safety.v +++ b/concurrency/juicy/Clight_safety.v @@ -502,55 +502,6 @@ Proof. destruct 1; constructor; auto. Qed. -Instance ClightAxioms : @CoreLanguage.SemAxioms (ClightSem ge). -Proof. - constructor. - - intros. - apply memsem_lemmas.mem_step_obeys_cur_write; auto. - eapply corestep_mem; eauto. - - intros. - apply ev_step_ax2 in H as []. - eapply CLC_step_decay; simpl in *; eauto. - - intros. - apply mem_forward_nextblock, memsem_lemmas.mem_step_forward. - eapply corestep_mem; eauto. - - intros; simpl. - destruct q; auto. - right; repeat intro. - inv H. - - intros. - inv Hstep. - inv H; simpl. - apply memsem_lemmas.mem_step_obeys_cur_write; auto. - (* apply memsem_lemmas.mem_step_refl. *) - eapply mem_step_alloc; eauto. - - intros. - inv H. - inv H0; simpl. - split; intros. - + (*contradiction. *) - eapply juicy_mem.fullempty_after_alloc in H8. - admit. - (* destruct H8; [right|left]. - - should be able to prove that - 1. b = Mem.nextblock m - which satisfies the goal at all offsets. - *) - - + auto. inv H8. - simpl. - Transparent Mem.alloc. - unfold Mem.alloc; simpl. - admit. - - - intros. - inv H. - inv H0; simpl. - erewrite (Mem.nextblock_alloc _ _ _ _ _ H8). - xomega. -Admitted. - Lemma CoreSafe_star: forall n U tr tp m tid (c : @semC (ClightSem ge)) c' tp' m' ev (HschedN: schedPeek U = Some tid) (Htid: containsThread tp tid) diff --git a/concurrency/juicy/JuicyMachineModule.v b/concurrency/juicy/JuicyMachineModule.v index 84cd093aa..cfa923f30 100644 --- a/concurrency/juicy/JuicyMachineModule.v +++ b/concurrency/juicy/JuicyMachineModule.v @@ -1,7 +1,5 @@ Require Import compcert.common.Memory. - -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.juicy_mem. Require Import VST.veric.res_predicates. @@ -13,7 +11,7 @@ Require Export VST.concurrency.common.threadPool. Require Import VST.concurrency.common.scheduler. Require Import VST.concurrency.common.HybridMachineSig. Require Import VST.concurrency.juicy.juicy_machine. Import Concur. -Require Import VST.concurrency.common.HybridMachine. Import Concur. +(*Require Import VST.concurrency.common.HybridMachine. Import Concur. *) Require Import VST.concurrency.common.lksize. Require Import VST.concurrency.common.permissions. @@ -31,22 +29,20 @@ Module THE_JUICY_MACHINE. Context {ge : Clight.genv}. Instance JSem : Semantics := ClightSem ge. - Definition JMachineSem := MachineSemantics(HybridMachine := HybridCoarseMachine.HybridCoarseMachine(machineSig:=JuicyMachineShell)). + Context {Σ : gFunctors}. + Definition JMachineSem := MachineSemantics(HybridMachine := HybridCoarseMachine.HybridCoarseMachine(machineSig:=JuicyMachineShell(Σ := Σ))). Definition jstate := ThreadPool.t(resources := LocksAndResources)(ThreadPool := OrdinalPool.OrdinalThreadPool). Definition jmachine_state := MachState(resources := LocksAndResources)(ThreadPool := OrdinalPool.OrdinalThreadPool). Import threadPool.ThreadPool. - (* safety with ghost updates *) - Definition tp_update (tp : jstate) phi tp' phi' := - level phi' = level phi /\ resource_at phi' = resource_at phi /\ + (* safety with ghost updates? *) + Definition tp_update (tp : jstate) (phi : rmap) tp' phi' := join_all tp' phi' /\ exists (Hiff : forall t, containsThread tp' t <-> containsThread tp t), - (forall t (cnt : containsThread tp t), getThreadC cnt = getThreadC (proj2 (Hiff _) cnt) /\ - level (getThreadR cnt) = level (getThreadR (proj2 (Hiff _) cnt)) /\ - resource_at (getThreadR cnt) = resource_at (getThreadR (proj2 (Hiff _) cnt))) /\ + (forall t (cnt : containsThread tp t), getThreadC cnt = getThreadC (proj2 (Hiff _) cnt)) /\ lockGuts tp' = lockGuts tp /\ lockSet tp' = lockSet tp /\ - lockRes tp' = lockRes tp /\ latestThread tp'= latestThread tp. + lockRes tp' = lockRes tp /\ latestThread tp'= latestThread tp /\ extraRes tp' = extraRes tp. Lemma tp_update_refl : forall tp phi, join_all tp phi -> tp_update tp phi tp phi. Proof. @@ -56,36 +52,54 @@ Module THE_JUICY_MACHINE. replace (proj2 _ _) with cnt by apply proof_irr; auto. Qed. + Print bupd. Definition tp_bupd P (tp : jstate) := (* Without this initial condition, a thread pool could be vacuously safe by being inconsistent with itself or the external environment. Since we want juicy safety to imply dry safety, we need to rule out the vacuous case. *) - (exists phi, join_all tp phi /\ joins (ghost_of phi) (Some (ghost_PCM.ext_ref tt, NoneP) :: nil)) /\ + (exists phi, join_all tp phi) /\ + (* should we provide a level? *) forall phi, join_all tp phi -> - forall c : ghost, join_sub (Some (ghost_PCM.ext_ref tt, NoneP) :: nil) c -> - joins (ghost_of phi) (ghost_fmap (approx (level phi)) (approx (level phi)) c) -> - exists b : ghost, - joins b (ghost_fmap (approx (level phi)) (approx (level phi)) c) /\ - exists phi' tp', tp_update tp phi tp' phi' /\ ghost_of phi' = b /\ P tp'. - -Print juicy_extspec.jm_fupd. (* -(* Should we do a fupd on threadpools, or explicitly represent the wsat the way we represent lock invariants? - Probably the latter, but the former might be easier to write. *) - Definition tp_fupd P (tp : jstate) := - (* Without this initial condition, a thread pool could be vacuously safe by being inconsistent - with itself or the external environment. Since we want juicy safety to imply dry safety, - we need to rule out the vacuous case. *) - exists phi, join_all tp phi /\ joins (ghost_of phi) (Some (ghost_PCM.ext_ref tt, NoneP) :: nil) /\ - forall phi' w z phiz, necR phi phi' -> join_all z phiz -> join phi' w phiz -> - (invariants.wsat * invariants.ghost_set invariants.g_en E1) w -> - tp_bupd (fun z2 => exists tp2 phi2 w2 phiz2, join_all z2 phi2 /\ join phi2 w2 ) z. + forall c, valid(A := resource_map.rmapUR _ _) (phi ⋅ c) -> + exists phi', valid(A := resource_map.rmapUR _ _) (phi' ⋅ c) /\ + exists tp', tp_update tp phi tp' phi' /\ P tp'. - forall phi, join_all tp phi -> - forall c : ghost, join_sub (Some (ghost_PCM.ext_ref tt, NoneP) :: nil) c -> - joins (ghost_of phi) (ghost_fmap (approx (level phi)) (approx (level phi)) c) -> - exists b : ghost, - joins b (ghost_fmap (approx (level phi)) (approx (level phi)) c) /\ - exists phi' tp', tp_update tp phi tp' phi' /\ ghost_of phi' = b /\ P tp'.*) +(* Definition tp_update_weak (tp tp' : jstate) := + exists (Hiff : forall t, containsThread tp' t <-> containsThread tp t), + (forall t (cnt : containsThread tp t), getThreadC cnt = getThreadC (proj2 (Hiff _) cnt) /\ + level (getThreadR cnt) = level (getThreadR (proj2 (Hiff _) cnt))) /\ + lockGuts tp' = lockGuts tp /\ lockSet tp' = lockSet tp /\ + lockRes tp' = lockRes tp /\ latestThread tp'= latestThread tp. + + Lemma tp_update_weak_refl : forall tp, tp_update_weak tp tp. + Proof. + unshelve eexists; [reflexivity|]. + split; auto; intros. + replace (proj2 _ _) with cnt by apply proof_irr; auto. + Qed. + + (* This is the intuitive definition, but it's dubious from a DRF perspective, since it allows + threads to transfer writable permissions without a synchronization operation. + We might instead need to treat each thread as already holding whatever resources it's going + to extract from invariants. Not sure how that will work. *) +(* Definition tp_fupd P (tp : jstate) := app_pred invariants.wsat (extraRes tp) /\ + (tp_level_is 0 tp \/ + tp_bupd (fun tp1 => exists phi tp2, join_all tp1 phi /\ join_all tp2 phi /\ + tp_update_weak tp1 tp2 /\ app_pred invariants.wsat (extraRes tp2) /\ P tp2) tp). *) + + (* Try 2: each thread holds the resources it's going to use from the wsat, while extraRes holds the + shared ghost state. So a fupd really is just a kind of bupd. *) +Definition tp_fupd P (tp : jstate) := exists i (cnti : containsThread tp i), + exists m r w, join m r (getThreadR cnti) /\ join r (extraRes tp) w /\ + app_pred (invariants.wsat * invariants.ghost_set invariants.g_en Ensembles.Full_set)%pred w /\ + (tp_level_is 0 tp \/ + tp_bupd (fun tp2 => exists (cnti2 : containsThread tp2 i) m2 r2 w2, join m2 r2 (getThreadR cnti2) /\ + join r2 (extraRes tp2) w2 /\ app_pred (invariants.wsat * invariants.ghost_set invariants.g_en Ensembles.Full_set)%pred w2 /\ P tp2) tp). + + (* Try 3: actually, getThreadR gives the resources the current assertion holds on, so we'd need + an extraRes for each thread. But this doesn't solve the fundamental problem: how do we know + how to distribute the contents of invariants? *) +*) Existing Instance JuicyMachineShell. Existing Instance HybridMachineSig.HybridCoarseMachine.DilMem. diff --git a/concurrency/juicy/erasure_proof.v b/concurrency/juicy/erasure_proof.v index b6326fab3..1221be0ef 100644 --- a/concurrency/juicy/erasure_proof.v +++ b/concurrency/juicy/erasure_proof.v @@ -17,7 +17,6 @@ Require Import ProofIrrelevance. Require Import compcert.common.Memory. (* VST imports *) -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.juicy_mem. Require Import VST.veric.res_predicates. diff --git a/concurrency/juicy/join_lemmas.v b/concurrency/juicy/join_lemmas.v index c3d99d82e..51b71b6fe 100644 --- a/concurrency/juicy/join_lemmas.v +++ b/concurrency/juicy/join_lemmas.v @@ -7,139 +7,11 @@ Require Import Coq.Sorting.Permutation. Require Import compcert.lib.Coqlib. Require Import VST.msl.Coqlib2. -Require Import VST.msl.seplog. -Require Import VST.msl.sepalg. -Require Import VST.msl.age_to. Require Import VST.veric.coqlib4. Require Import VST.concurrency.common.threadPool. Set Bullet Behavior "Strict Subproofs". -(** * Results on joining lists and the necessary algebras *) - -Fixpoint joinlist {A} {JA : Join A} (l : list A) (x : A) := - match l with - | nil => identity x - | h :: l => exists y, joinlist l y /\ join h y x - end. - -(* joinlist is injective (for non-empty lists) *) -Lemma joinlist_inj {A} {JA : Join A} {PA : Perm_alg A} l r1 r2 : - l <> nil -> - joinlist l r1 -> - joinlist l r2 -> - r1 = r2. -Proof. - revert r1 r2; induction l; intros r1 r2 n j1 j2. tauto. clear n. - destruct j1 as (r1' & j1 & h1). - destruct j2 as (r2' & j2 & h2). - destruct l; simpl in *. - - apply join_comm in h1; apply join_comm in h2. - pose proof join_unit1_e _ _ j1 h1. - pose proof join_unit1_e _ _ j2 h2. - congruence. - - cut (r1' = r2'). - + intros <-. - eapply join_eq; eauto. - + eapply IHl; eauto. - congruence. -Qed. - -Lemma joinlist_permutation {A} {JA : Join A} {PA : Perm_alg A} l1 l2 r : - Permutation l1 l2 -> - joinlist l1 r -> - joinlist l2 r. -Proof. - intros p; revert r; induction p; intros r; auto. - - intros (r' & jl & j). - exists r'; split; auto. - - simpl. - intros (a & (b & jb & ja) & jr). - apply join_comm in jr. - destruct (join_assoc ja jr) as (d & jd & jr'). - eauto. -Qed. - -#[export] Instance Permutation_length' A {JA : Join A} {PA : Perm_alg A} : - Proper (@Permutation A ==> @eq A ==> Logic.iff) joinlist | 10. -Proof. - intros l1 l2 p x y <-; split; apply joinlist_permutation; auto. - apply Permutation_sym, p. -Qed. - -Lemma joinlist_app {A} {JA : Join A} {PA : Perm_alg A} l1 l2 x1 x2 x : - joinlist l1 x1 -> - joinlist l2 x2 -> - join x1 x2 x -> - joinlist (l1 ++ l2) x. -Proof. - revert l2 x1 x2 x; induction l1; intros l2 x1 x2 x j1 j2 j; simpl in *. - - erewrite <-join_unit1_e; eauto. - - destruct j1 as (x1' & jl & jx1). - destruct (join_assoc jx1 j) as (r & ? & ?). - exists r; split; eauto. -Qed. - -(*Lemma app_joinlist {A} {JA : Join A} {SA : Sep_alg A} {PA : Perm_alg A} l1 l2 x : - joinlist (l1 ++ l2) x -> - exists x1 x2, - joinlist l1 x1 /\ - joinlist l2 x2 /\ - join x1 x2 x. -Proof. - revert l2 x; induction l1; intros l2 x j; simpl in *. - - exists (core x), x; split. - + apply core_identity. - + split; auto. apply core_unit. - - destruct j as (y & h & ayx). - destruct (IHl1 _ _ h) as (x1 & x2 & h1 & h2 & j). - apply join_comm in j. - apply join_comm in ayx. - destruct (join_assoc j ayx) as (r & ? & ?). - exists r, x2. eauto. -Qed.*) - -Lemma joinlist_merge {A} {JA : Join A} {PA : Perm_alg A} (a b c x : A) l : - join a b c -> joinlist (a :: b :: l) x <-> joinlist (c :: l) x. -Proof. - intros j; split; intros h; swap 1 2. - - destruct h as (rl & hl & jx). - destruct (join_assoc j jx) as (bl & jbl & jabx). - simpl. eauto. - - rename c into ab, x into abc, j into a_b. - destruct h as (bc & hl & a_bc). - destruct hl as (c & hl & b_c). - exists c; split; auto. - clear hl l. - apply join_comm in b_c. - apply join_comm in a_bc. - destruct (join_assoc b_c a_bc) as (ab' & a_b' & ab_c). - apply join_comm in ab_c. - exact_eq ab_c; f_equal. - eapply join_eq; eauto. -Qed. - -Lemma joinlist_swap {A} {JA : Join A} {PA : Perm_alg A} (a b x : A) l : - joinlist (a :: b :: l) x = - joinlist (b :: a :: l) x. -Proof. - apply prop_ext; split; apply joinlist_permutation; constructor. -Qed. - -Lemma joinlist_join_sub {A} {JA : Join A} {PA : Perm_alg A} (x phi : A) l : - joinlist l phi -> - In x l -> join_sub x phi. -Proof. - revert x phi; induction l; simpl. tauto. - intros x phi (b & jb & ab) [-> | i]. - - exists b; auto. - - specialize (IHl _ _ jb i); auto. - destruct IHl as (c, xc). - apply sepalg.join_comm in ab. - destruct (sepalg.join_assoc xc ab) as (d, H). - exists d; intuition. -Qed. - (** * Other list functions *) Fixpoint listoption_inv {A} (l : list (option A)) : list A := @@ -298,135 +170,7 @@ Proof. apply upd_app_Some. congruence. Qed. -Require Import VST.msl.ageable. -Require Import VST.msl.age_sepalg. - -Lemma age_by_overflow {A} {_ : ageable A} {JA: Join A} (x : A) n : le (level x) n -> age_by n x = age_by (level x) x. -Proof. - intros l. - replace n with ((n - level x) + level x)%nat by lia. - generalize (n - level x)%nat; intros k. clear n l. - revert x; induction k; intros x. reflexivity. - simpl. rewrite IHk. - unfold age1' in *. - destruct (age1 (age_by (level x) x)) eqn:E. 2:reflexivity. exfalso. - eapply age1_level0_absurd. eauto. - rewrite level_age_by. lia. -Qed. - -Lemma age_by_minusminus {A} {_ : ageable A} {JA: Join A} (x : A) n : age_by (level x - (level x - n)) x = age_by n x. -Proof. - assert (D : le (level x) n \/ lt n (level x)). lia. - destruct D as [D|D]. - - replace (level x - (level x - n))%nat with (level x) by lia. - symmetry; apply age_by_overflow, D. - - f_equal; lia. -Qed. - -Lemma age_by_join {A} {JA: Join A} {PA: Perm_alg A} {agA: ageable A} {SA: Sep_alg A} {AgeA: Age_alg A} {EO: predicates_hered.Ext_ord A} : - forall k x1 x2 x3, - join x1 x2 x3 -> - join (age_by k x1) (age_by k x2) (age_by k x3). -Proof. - intros k x1 x2 x3 H. - pose proof age_to_join_eq (level x3 - k) x1 x2 x3 H ltac:(lia) as G. - pose proof join_level _ _ _ H as [e1 e2]. - exact_eq G; f_equal; unfold age_to. - - rewrite <-e1; apply age_by_minusminus. - - rewrite <-e2; apply age_by_minusminus. - - apply age_by_minusminus. -Qed. - -(* this generalizes [age_to_join_eq], but we do use [age_to_join_eq] inside this proof *) -Lemma age_to_join {A} {JA: Join A} {PA: Perm_alg A} {agA: ageable A} {SA: Sep_alg A} {AgeA: Age_alg A} {EO: predicates_hered.Ext_ord A} : - forall k x1 x2 x3, - join x1 x2 x3 -> - join (age_to k x1) (age_to k x2) (age_to k x3). -Proof. - intros k x1 x2 x3 J. - unfold age_to in *. - pose proof age_by_join ((level x1 - k)%nat) _ _ _ J as G. - exact_eq G; do 3 f_equal. - all: apply join_level in J; destruct J; congruence. -Qed. - -Lemma age_by_joins {A} {JA: Join A} {PA: Perm_alg A} {agA: ageable A} {SA: Sep_alg A} {AgeA: Age_alg A} {EO: predicates_hered.Ext_ord A} : - forall k x1 x2, - joins x1 x2 -> - joins (age_by k x1) (age_by k x2). -Proof. - intros k x1 x2 []. - eexists; apply age_by_join; eauto. -Qed. - -Lemma age_to_joins {A} {JA: Join A} {PA: Perm_alg A} {agA: ageable A} {SA: Sep_alg A} {AgeA: Age_alg A} {EO: predicates_hered.Ext_ord A} : - forall k x1 x2, - joins x1 x2 -> - joins (age_to k x1) (age_to k x2). -Proof. - intros k x1 x2 []. - eexists; apply age_to_join; eauto. -Qed. - -Lemma age_to_join_sub {A} {JA: Join A} {PA: Perm_alg A} {agA: ageable A} {SA: Sep_alg A} {AgeA: Age_alg A} {EO: predicates_hered.Ext_ord A} : - forall k x1 x2, - join_sub x1 x2 -> - join_sub (age_to k x1) (age_to k x2). -Proof. - intros k x1 x3 []. - eexists; apply age_to_join; eauto. -Qed. - -Lemma joinlist_level {A} `{agA : ageable A} {J : Join A} {_ : Perm_alg A} {SA: Sep_alg A} {AgeA: Age_alg A} (x : A) l Phi : - joinlist l Phi -> - In x l -> level x = level Phi. -Proof. - intros j i. - destruct (joinlist_join_sub x Phi l j i) as (y, Hy). - apply join_level in Hy. apply Hy. -Qed. - -Lemma joinlist_age1' {A} `{agA : ageable A} {J : Join A} {SA: Sep_alg A} {AgeA: Age_alg A} {_ : Perm_alg A} (l : list A) (x : A) : - joinlist l x -> - joinlist (map age1' l) (age1' x). -Proof. - revert x; induction l; intros x h. - - simpl in *. unfold age1'. - destruct (age1 x) eqn:E; auto. - eapply age_identity. apply E. apply h. - - destruct h as (y & h & j). - exists (age1' y); split. auto. - unfold age1'. - destruct (age1 a) eqn:Ea. - + destruct (age1_join _ j Ea) as (y' & z' & j' & -> & ->). auto. - + rewrite age1_level0 in Ea. - pose proof (join_level _ _ _ j). - assert (Ex : age1 x = None). apply age1_level0. intuition; congruence. - assert (Ey : age1 y = None). apply age1_level0. intuition; congruence. - rewrite Ex, Ey. auto. -Qed. - -Lemma joinlist_age_to {A} `{agA : ageable A} {J : Join A} {SA: Sep_alg A} {AgeA: Age_alg A} {_ : Perm_alg A} n (l : list A) (x : A) : - joinlist l x -> - joinlist (map (age_to n) l) (age_to n x). -Proof. - intros h. - unfold age_to at 2. - replace (map (age_to n) l) with (map (age_by (level x - n)) l). - - generalize (level x - n)%nat; clear n; intros n; induction n. - + exact_eq h; f_equal. - induction l; auto. rewrite IHl at 1. reflexivity. - + apply joinlist_age1' in IHn. - exact_eq IHn; f_equal. clear. - induction l; simpl; auto. f_equal; auto. - - revert x h; induction l; auto; intros y (x & h & j); simpl. - apply join_level in j. - f_equal. - + unfold age_to. do 2 f_equal. intuition. - + rewrite <-IHl with x; auto. do 3 f_equal. intuition. -Qed. - -Require Import VST.veric.compcert_rmaps. +Require Import VST.veric.res_predicates. Require Import VST.concurrency.common.enums_equality. Require Import VST.concurrency.juicy.juicy_machine. Require Import VST.concurrency.common.HybridMachineSig. @@ -446,14 +190,14 @@ Set Bullet Behavior "Strict Subproofs". Section Machine. -Context {ge : Clight.genv}. +Context {ge : Clight.genv} {Σ : gFunctors}. Definition getLocksR (tp : jstate ge) := listoption_inv (map snd (AMap.elements (lset tp))). -Definition maps tp := (getThreadsR tp ++ getLocksR tp)%list. +Definition maps tp := (getThreadsR tp ++ getLocksR tp ++ (extraRes tp :: nil))%list. Lemma all_but_maps i tp (cnti : containsThread tp i) : - all_but i (maps tp) = all_but i (getThreadsR tp) ++ getLocksR tp. + all_but i (maps tp) = all_but i (getThreadsR tp) ++ getLocksR tp ++ (extraRes tp :: nil). Proof. unfold maps. generalize (getLocksR tp); intros l. apply all_but_app. @@ -469,128 +213,6 @@ Proof. inversion H; auto. Qed. -Lemma join_list_joinlist : join_list = joinlist. -Proof. - extensionality l; induction l; extensionality phi; simpl; auto. - f_equal. extensionality r. apply prop_ext. - split; intros []; split; auto; simpl in *; congruence. -Qed. - -Lemma join_list'_None l : join_list' l None <-> listoption_inv l = nil. -Proof. - induction l. simpl. split; auto. - simpl. - split; destruct a as [r|]. - - intros (r' & j & h). inversion j. - - intros (r' & j & h). inversion j; subst; tauto. - - congruence. - - rewrite <-IHl. intro. exists None; split; auto. constructor. -Qed. - -Lemma join_list'_Some l phi : join_list' l (Some phi) -> joinlist (listoption_inv l) phi. -Proof. - revert phi; induction l; intros phi. simpl. congruence. - intros (r & j & h). - simpl. - destruct a. - - inversion j; subst. - + apply join_list'_None in h. - simpl in *; rewrite h. - simpl. - exists (id_core phi). - split. - * apply id_core_identity. - * apply join_comm, id_core_unit. - + inversion j; subst; simpl; eauto. - - inversion j; subst; simpl; eauto. -Qed. - -Lemma join_list'_Some' l phi : listoption_inv l <> nil -> joinlist (listoption_inv l) phi -> join_list' l (Some phi). -Proof. - revert phi; induction l; intros phi. simpl; congruence. - destruct a as [r|]; simpl. - - intros _ (y & h & j). - simpl in *. - assert (D:forall l:list rmap, l = nil \/ l <> nil) - by (intros []; [left|right]; congruence). - destruct (D (listoption_inv l)) as [E|E]. - + rewrite E in *. - rewrite <-join_list'_None in E. - exists None; split; auto. - simpl in h. - pose proof join_unit2_e _ _ h j. subst. - constructor. - + exists (Some y). split; auto. - constructor; auto. - - intros n j; specialize (IHl _ n j). - exists (Some phi); split; eauto. constructor. -Qed. - -Lemma app_join_list {A} {JA : Join A} {SA : Sep_alg A} {PA : Perm_alg A} l1 l2 x : - join_list (l1 ++ l2) x -> - exists x1 x2, - join_list l1 x1 /\ - join_list l2 x2 /\ - join x1 x2 x. -Proof. - revert l2 x; induction l1; intros l2 x j; simpl in *. - - exists (id_core x), x; split. - + apply id_core_identity. - + split; auto. apply id_core_unit. - - destruct j as (y & ayx & h). - destruct (IHl1 _ _ h) as (x1 & x2 & h1 & h2 & j). - apply join_comm in j. - apply join_comm in ayx. - destruct (join_assoc j ayx) as (r & ? & ?). - exists r, x2. eauto. -Qed. - -Lemma join_all_joinlist tp : join_all tp = joinlist (maps tp). -Proof. - extensionality phi. apply prop_ext. split. - - intros J. inversion J as [? rt rl ? jt jl j]; subst. - destruct rl as [rl|]. - + inversion j; subst. - apply joinlist_app with (x1 := rt) (x2 := rl); auto. - * rewrite <-join_list_joinlist. - apply jt. - * apply join_list'_Some. - apply jl. - + inversion j; subst. - rewrite <-join_list_joinlist. - apply join_list'_None in jl. - unfold maps. - cut (join_list (getThreadsR tp ++ nil) phi). - { intro H; exact_eq H. f_equal. f_equal. symmetry. apply jl. } - rewrite app_nil_r. - apply jt. - - intros j. - unfold maps in j. - rewrite <- join_list_joinlist in j. - apply app_join_list in j. - destruct j as (rt & rl & jt & jl & j). - set (l' := getLocksR tp). - assert (D:l' = nil \/ l' <> nil) - by (destruct l'; [left|right]; congruence). - destruct D as [D|D]. - + exists rt None; unfold l' in *; simpl in *. - * hnf. apply jt. - * hnf. unfold l' in D. - rewrite join_list'_None. - simpl in *. - rewrite <-D. - reflexivity. - * rewrite D in jl. - simpl in jl. - pose proof join_unit2_e _ _ jl j. subst. - constructor. - + exists rt (Some rl). - * hnf. apply jt. - * hnf. apply join_list'_Some'; auto. - rewrite <- join_list_joinlist; auto. - * constructor; auto. -Qed. - (** * Results about handling threads' rmaps *) Lemma seq_pmap_decent {A B} (f : A -> option B) l : @@ -615,8 +237,8 @@ Proof. + f_equal. simpl minus in *. revert Hi. - rewrite <-minus_n_O in *. - rewrite <-minus_n_O in *. + rewrite -> Nat.sub_0_r in *. + rewrite -> Nat.sub_0_r in *. intros Hi. simpl. f_equal. @@ -624,7 +246,7 @@ Proof. apply proof_irr. + simpl minus in *. revert Hi. - rewrite <-minus_n_O in *. + rewrite -> Nat.sub_0_r in *. intros Hi. simpl. unshelve erewrite IHn. @@ -636,7 +258,9 @@ Proof. reflexivity. * f_equal. rewrite <- Nat.sub_add_distr. - reflexivity. + simpl. + f_equal. + apply proof_irr. * lia. Qed. @@ -659,7 +283,7 @@ Proof. end. pose proof (ssrbool.elimT ssrnat.leP pr). assert (R : (n - 1 - (n - i - 1) = i)%nat) by lia. - rewrite R in *. + rewrite -> R in *. intros pr'. do 2 f_equal. apply proof_irr. @@ -749,8 +373,8 @@ Proof. apply (ssrbool.elimT ssrnat.leP cnti). } rewrite upd_rev; auto. - 2:now rewrite map_length, length_enum_from; auto. - rewrite List.map_length, length_enum_from. + 2:now rewrite map_length length_enum_from; auto. + rewrite List.map_length length_enum_from. match goal with |- _ = Some (?a ?x) => change (Some (a x)) with (option_map a (Some x)) @@ -774,7 +398,6 @@ Proof. generalize m at 1 2 4 7 13 14; intros n; revert i. induction n; intros i li cnti Hnm. now inversion li. match goal with |- _ = Some (map ?F _) => set (f := F) end. - Unset Printing Implicit. destruct i. - simpl. f_equal. @@ -909,9 +532,8 @@ Lemma maps_getthread i tp cnti : (@getThreadR _ _ _ i tp cnti :: all_but i (maps tp)). Proof. rewrite all_but_maps; auto. - transitivity - ((getThreadR cnti :: all_but i (getThreadsR tp)) ++ getLocksR tp); auto. - rewrite <-getThreadsR_but. reflexivity. + match goal with |-context[?a :: ?b ++ ?c] => change (a :: b ++ c) with ((a :: b) ++ c) end. + rewrite <- getThreadsR_but; reflexivity. Qed. Lemma maps_updthread i tp cnti c phi : @@ -935,7 +557,7 @@ Qed. Lemma maps_updlock1 (tp : jstate ge) addr : maps (updLockSet tp addr None) = maps (remLockSet tp addr). Proof. - unfold maps; f_equal. + unfold maps; do 2 f_equal. apply getLocksR_updLockSet_None. Qed. @@ -980,28 +602,13 @@ Lemma maps_addthread tp v1 v2 phi : (phi :: maps tp). Proof. unfold maps. - change (phi :: getThreadsR tp ++ getLocksR tp) - with ((phi :: getThreadsR tp) ++ getLocksR tp). + match goal with |-context[?a :: ?b ++ ?c] => change (a :: b ++ c) with ((a :: b) ++ c) end. apply Permutation_app_tail. rewrite Permutation_cons_append. rewrite getThreadsR_addThread. apply Permutation_refl. Qed. -Lemma maps_age_to i tp : - maps (age_tp_to i tp) = map (age_to i) (maps tp). -Proof. - destruct tp as [n th ph ls]; simpl. - unfold maps, getThreadsR, getLocksR in *. - rewrite map_app. - f_equal. - - apply map_compose. - - unfold lset. - rewrite AMap_map. - rewrite map_listoption_inv. - reflexivity. -Qed. - Lemma maps_remLockSet_updThread i tp addr cnti c phi : maps (remLockSet (@updThread _ _ _ i tp cnti c phi) addr) = maps (@updThread _ _ _ i (remLockSet tp addr) cnti c phi). @@ -1009,26 +616,4 @@ Proof. reflexivity. Qed. -Lemma getThread_level i tp cnti Phi : - join_all tp Phi -> - level (@getThreadR _ _ _ i tp cnti) = level Phi. -Proof. - intros j. - apply juicy_mem.rmap_join_sub_eq_level, compatible_threadRes_sub, j. -Qed. - -Lemma join_sub_level {A} `{JA : sepalg.Join A} `{_ : ageable A} {_ : Perm_alg A} {_ : Sep_alg A} {_ : Age_alg A} : - forall x y : A, join_sub x y -> level x = level y. -Proof. - intros x y (z, j). - apply (join_level _ _ _ j). -Qed. - -Lemma joins_level {A} `{JA : sepalg.Join A} `{_ : ageable A} {_ : Perm_alg A} {_ : Sep_alg A} {_ : Age_alg A} : - forall x y : A, joins x y -> level x = level y. -Proof. - intros x y (z, j). - destruct (join_level _ _ _ j); congruence. -Qed. - End Machine. diff --git a/concurrency/juicy/juicy_machine.v b/concurrency/juicy/juicy_machine.v index ead93cfd1..826cc528e 100644 --- a/concurrency/juicy/juicy_machine.v +++ b/concurrency/juicy/juicy_machine.v @@ -1,7 +1,8 @@ Require Import compcert.lib.Axioms. -Require Import VST.msl.age_to. Require Import VST.veric.base. +Require Import VST.veric.shared. +Require Import VST.veric.res_predicates. Require Import VST.concurrency.common.sepcomp. Import SepComp. Require Import VST.sepcomp.semantics_lemmas. @@ -16,7 +17,7 @@ Require Import VST.concurrency.common.lksize. Require Import VST.concurrency.common.semantics. Require Import VST.concurrency.common.permjoin. Require Import Coq.Program.Program. -From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun. +From mathcomp.ssreflect Require Import ssrbool. Set Implicit Arguments. (*NOTE: because of redefinition of [val], these imports must appear @@ -31,13 +32,12 @@ Require Import compcert.lib.Coqlib. Require Import List. Require Import Coq.ZArith.ZArith. -(*From msl get the juice! *) -Require Import VST.veric.compcert_rmaps. +Require Import iris.algebra.auth. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. +Require Import VST.veric.mpred. Require Import VST.veric.juicy_extspec. Require Import VST.veric.jstep. - Set Bullet Behavior "Strict Subproofs". Set Nested Proofs Allowed. @@ -47,19 +47,20 @@ Set Nested Proofs Allowed. Require Import (*compcert_linking*) VST.concurrency.common.permissions VST.concurrency.common.threadPool. Import OrdinalPool ThreadPool. -(* There are some overlaping definition conflicting. +Local Open Scope Z. + +(* There are some overlapping definitions conflicting. Here we fix that. But this is obviously ugly and the conflicts should be removed by renaming! *) Notation "x <= y" := (x <= y)%nat. Notation "x < y" := (x < y)%nat. +#[export] Instance LocksAndResources Σ : Resources := { res := iResUR Σ; lock_info := option (iResUR Σ) }. -Instance LocksAndResources : Resources := { res := rmap; lock_info := option rmap }. - -Module ThreadPool. +Module ThreadPool. Section ThreadPool. - Context {Sem: Semantics}. + Context {Sem: Semantics} {Σ : gFunctors}. (** The Lock Resources Set *) @@ -77,7 +78,7 @@ Module Concur. Import event_semantics Events. - Context {Sem: Semantics}. + Context {Sem: Semantics} `{!heapGS Σ}. Notation C:= (semC). Notation G:= (semG). @@ -88,7 +89,7 @@ Module Concur. Notation SNone:= (Some None). (** Memories*) - Definition richMem: Type:= juicy_mem. + Definition richMem: Type:= @juicy_mem Σ. Definition dryMem: richMem -> mem:= m_dry. (** Environment and Threadwise semantics *) @@ -102,29 +103,39 @@ Module Concur. Notation thread_pool := (@ThreadPool.t _ _ OrdinalThreadPool). (** Machine Variables*) - Definition lp_id : tid:= (0)%nat. (*lock pool thread id*) + Definition lp_id : tid := (0)%nat. (*lock pool thread id*) (** Invariants*) (** The state respects the memory*) - Definition access_cohere' m phi:= forall loc, + Definition contents_cohere m phi := forall loc, contents_cohere m loc (phi @ loc). + Definition access_cohere m phi := forall loc, access_cohere m loc (phi @ loc). + Definition access_cohere' m phi := forall loc, Mem.perm_order'' (max_access_at m loc) (perm_of_res (phi @ loc)). + Definition max_access_cohere m phi := forall loc, max_access_cohere m loc (phi @ loc). + Definition alloc_cohere m (phi : juicy_mem.rmap) := forall loc, (loc.1 >= Mem.nextblock m)%positive → phi !! loc = None. (* This is similar to the coherence of juicy memories, * * but for entire machines. It is slighly weaker in one way: * - acc_coh is looser and only talks about maxcoh. - * - alse acc_coh might me redundant with max_coh IDK... x*) - Record mem_cohere' m phi := + * - else acc_coh might be redundant with max_coh IDK... x*) + Record mem_cohere m phi := { cont_coh: contents_cohere m phi; (*acc_coh: access_cohere m phi;*) (*acc_coh: access_cohere' m phi;*) max_coh: max_access_cohere m phi; all_coh: alloc_cohere m phi }. - Definition mem_thcohere (tp : thread_pool) m := - forall tid (cnt: containsThread tp tid), mem_cohere' m (getThreadR cnt). - Definition mem_lock_cohere (ls:lockMap) m:= - forall loc rm, AMap.find loc ls = SSome rm -> mem_cohere' m rm. + Definition heap_frag phi : mpred := own(inG0 := resource_map.resource_map_inG(resource_mapG := gen_heapGpreS_heap(gen_heapGpreS := gen_heap_inG))) + (gen_heap_name _) (◯ phi). + + Definition mem_cohere' n m r := ouPred_holds (∀ phi, heap_frag phi → ⌜mem_cohere m phi⌝) n r. + + Definition mem_thcohere (n : nat) (tp : thread_pool) m := + forall tid (cnt: containsThread tp tid), mem_cohere' n m (getThreadR cnt). + + Definition mem_lock_cohere (n : nat) (ls:lockMap) m:= + forall loc rm, AMap.find loc ls = SSome rm -> mem_cohere' n m rm. Lemma length_enum_from n m pr : List.length (@enums_equality.enum_from n m pr) = n. Proof. @@ -141,13 +152,13 @@ Module Concur. Qed. (*Join juice from all threads *) - Definition getThreadsR (tp : thread_pool):= + Definition getThreadsR (tp : thread_pool) := map (perm_maps tp) (enums_equality.enum (num_threads tp)). - Fixpoint join_list (ls: seq.seq res) r:= +(* Fixpoint join_list (ls: seq.seq res) r:= if ls is phi::ls' then exists r', join phi r' r /\ join_list ls' r' else - identity r. (*Or is is just [amp r]?*) - Definition join_threads (tp : thread_pool) r:= join_list (getThreadsR tp) r. + identity r. (*Or is it just [emp r]?*) *) + Definition join_threads (tp : thread_pool) r := r ≡ [^op list] s ∈ getThreadsR tp, s. Lemma list_nth_error_eq : forall {A} (l1 l2 : list A) (Heq : forall j, nth_error l1 j = nth_error l2 j), l1 = l2. @@ -158,21 +169,40 @@ Module Concur. - intro j; specialize (Heq (S j)); auto. Qed. - Lemma nth_error_enum : forall n m (H : (n <= m)%coq_nat) i, i < n -> - exists Hlt, nth_error (enum_from H) i = Some (@Ordinal m (n - 1 - i)%coq_nat Hlt). + Lemma nth_error_enum : forall n m (H : (n <= m)%nat) i, i < n -> + exists Hlt, nth_error (enum_from H) i = Some (@fintype.Ordinal m (n - 1 - i)%nat Hlt). Proof. intros ??; induction n; simpl; intros; [ssrlia|]. destruct i; simpl. - - replace (n.+1 - 1 - 0)%coq_nat with n by ssrlia; eauto. - - replace (n.+1 - 1 - i.+1)%coq_nat with (n - 1 - i)%coq_nat by abstract ssrlia; eauto. + - replace (n - 0 - 0)%nat with n by lia; eauto. + - replace (n - 0 - S i)%nat with (n - 1 - i)%nat by abstract ssrlia; eauto. + apply IHn; lia. Qed. - Lemma minus_comm : forall a b c, ((a - b)%coq_nat - c = (a - c)%coq_nat - b)%coq_nat. + Lemma minus_comm : forall a b c, ((a - b)%nat - c = (a - c)%nat - b)%nat. Proof. intros. lia. Qed. +(* up *) +Lemma nth_error_rev: + forall T (vl: list T) (n: nat), + (n < length vl)%nat -> + nth_error (rev vl) n = nth_error vl (length vl - n - 1)%nat. +Proof. + induction vl; simpl; intros. apply nth_error_nil. + replace (S (length vl) - n - 1)%nat with (length vl - n)%nat by lia. + destruct (eq_dec n (length vl)). + - subst. + rewrite nth_error_app2; rewrite rev_length //. + rewrite Nat.sub_diag //. + - rewrite nth_error_app1; last by rewrite rev_length; lia. + rewrite IHvl; last by lia. + destruct (length vl - n)%nat eqn: ?; first by lia. + rewrite /= Nat.sub_0_r //. +Qed. + Lemma getThreadsR_addThread tp v1 v2 phi : getThreadsR (addThread tp v1 v2 phi) = getThreadsR tp ++ phi :: nil. Proof. @@ -182,115 +212,107 @@ Module Concur. - apply list_nth_error_eq; intro. rewrite !list_map_nth. destruct (lt_dec j (num_threads tp)). - erewrite !initial_world.nth_error_rev by (rewrite length_enum_from; auto). + erewrite !nth_error_rev by (rewrite length_enum_from; auto). rewrite !length_enum_from. - assert (((num_threads tp - j)%coq_nat - 1)%coq_nat < num_threads tp) by ssrlia. + assert (((num_threads tp - j)%nat - 1)%nat < num_threads tp) by ssrlia. repeat match goal with |-context[nth_error (enum_from ?H) ?i] => - destruct (nth_error_enum H i) as [? ->]; auto end; simpl. - match goal with |-context[unlift ?a ?b] => destruct (@unlift_some _ a b) as [[] ? Heq] end. + destruct (@nth_error_enum _ _ H i) as [? ->]; auto end; simpl. + match goal with |-context[fintype.unlift ?a ?b] => destruct (@fintype.unlift_some _ a b) as [[] ? Heq] end. { apply eq_true_not_negb. rewrite eq_op_false; [discriminate|]. intro X; inv X. - rewrite (Nat.add_sub_eq_l _ _ j) in H1; try lia. - rewrite minus_comm Nat.sub_add; auto; lia. } + rewrite (Nat.add_sub_eq_l _ _ j) in H1; try lia. } rewrite Heq; simpl in *; f_equal; f_equal. - apply ord_inj. + apply fintype.ord_inj. apply unlift_m_inv in Heq; auto. { repeat match goal with |-context[nth_error ?l ?i] => destruct (nth_error_None l i) as [_ H]; erewrite H by (rewrite rev_length length_enum_from; lia); clear H end; auto. } - unfold ordinal_pos_incr; simpl. - replace (introT _ _) with (pos_incr_lt (num_threads tp)) by apply proof_irr. - rewrite unlift_none; auto. + replace (ssrbool.introT _ _) with (pos_incr_lt (num_threads tp)) by apply proof_irr. + rewrite fintype.unlift_none; auto. Qed. (*Join juice from all locks*) - Fixpoint join_list' (ls: seq.seq (option res)) (r:option res):= - if ls is phi::ls' then exists (r':option res), - @join _ (@Join_lower res _) phi r' r /\ join_list' ls' r' else r=None. - Definition join_locks tp r:= join_list' (map snd (AMap.elements (lset tp))) r. + Definition join_locks tp r := r ≡ [^op list] s ∈ map snd (AMap.elements (lset tp)), (s : optionUR (iResUR Σ)). (*Join all the juices*) - Inductive join_all: thread_pool -> res -> Prop:= - AllJuice tp r0 r1 r: + Inductive join_all: thread_pool -> res -> Prop := + AllJuice tp r0 r1 r2 r: join_threads tp r0 -> join_locks tp r1 -> - join (Some r0) r1 (Some r) -> + (Some r0 : optionUR (iResUR Σ)) ⋅ r1 ≡ Some r2 -> + r2 ⋅ (extraRes tp) ≡ r -> join_all tp r. - Definition juicyLocks_in_lockSet (lset : lockMap) (juice: rmap):= - forall loc, - (forall i, 0 <= i < LKSIZE -> exists sh psh P, juice @ (fst loc, snd loc + i) = YES sh psh (LK LKSIZE i) P) -> - AMap.find loc lset. + Definition juicyLocks_in_lockSet (n : nat) (lset : lockMap) r := + ouPred_holds (∀ loc P sh, ( LKspec LKSIZE P sh loc) → ⌜AMap.find loc lset⌝) n r. (* I removed the NO case for two reasons: * - To ensure that lset is "valid" (lr_valid), it needs inherit it from the rmap * - there was no real reason to have a NO other than speculation of the future. *) - Definition lockSet_in_juicyLocks (lset : lockMap) (juice: rmap):= - forall loc, AMap.find loc lset -> - (exists sh, - forall i, 0 <= i < LKSIZE -> exists sh' psh' P, join_sub sh sh' /\ juice @ (fst loc, snd loc + i) = YES sh' psh' (LK LKSIZE i) P). - + Definition lockSet_in_juicyLocks (n : nat) (lset : lockMap) r := + ouPred_holds (∀ loc, ⌜AMap.find loc lset⌝ → ∃ sh P, LKspec LKSIZE P sh loc) n r. - Definition lockSet_in_juicyLocks' (lset : lockMap) (juice: rmap):= +(* Definition lockSet_in_juicyLocks' (lset : lockMap) juice := forall loc, AMap.find loc lset -> - Mem.perm_order'' (Some Nonempty) (perm_of_res (juice @ loc)). - Lemma lockSet_in_juic_weak: forall lset juice, - lockSet_in_juicyLocks lset juice -> lockSet_in_juicyLocks' lset juice. + Mem.perm_order'' (Some Nonempty) (perm_of_res (resource_at juice loc)). + Lemma lockSet_in_juic_weak: forall lset n juice, + lockSet_in_juicyLocks lset n juice -> lockSet_in_juicyLocks' lset juice. Proof. intros lset juice HH loc FIND. apply HH in FIND. destruct FIND as [sh FIND]. specialize (FIND 0). spec FIND. pose proof LKSIZE_pos. lia. replace (loc.1, loc.2+0) with loc in FIND. - destruct FIND as [sh' [psh' [P [? FIND]]]]; rewrite FIND; simpl. - constructor. + destruct FIND as [sh' [psh' [? FIND]]]; rewrite /resource_at FIND; simpl. + rewrite elem_of_to_agree; if_tac; constructor. destruct loc; simpl; f_equal; auto; lia. (*- destruct (eq_dec sh0 Share.bot); constructor.*) - Qed. + Qed.*) Definition lockSet_Writable (lset : lockMap) m := forall b ofs, AMap.find (b,ofs) lset -> - forall ofs0, Intv.In ofs0 (ofs, ofs + LKSIZE)%Z -> - Mem.perm_order'' ((Mem.mem_access m)!! b ofs0 Max) (Some Writable) . - - (*This definition makes no sense. In fact if there is at least one lock in rmap, - *then the locks_writable is false (because perm_of_res(LK) = Some Nonempty). *) - Definition locks_writable (juice: rmap):= - forall loc sh psh P z i, juice @ loc = YES sh psh (LK z i) P -> - Mem.perm_order'' (perm_of_res (juice @ loc)) (Some Writable). - - Record mem_compatible_with' (tp : thread_pool) m all_juice : Prop := - { juice_join : join_all tp all_juice - ; all_cohere : mem_cohere' m all_juice + forall ofs0, Intv.In ofs0 (ofs, ofs + LKSIZE) -> + Mem.perm_order'' (PMap.get b (Mem.mem_access m) ofs0 Max) (Some Writable) . + + Record mem_compatible_with' (n : nat) (tp : thread_pool) m all_juice : Prop := + { juice_valid : ✓{n} all_juice + ; juice_join : join_all tp all_juice + ; all_cohere : mem_cohere' n m all_juice ; loc_writable : lockSet_Writable (lockGuts tp) m - ; jloc_in_set : juicyLocks_in_lockSet (lockGuts tp) all_juice - ; lset_in_juice: lockSet_in_juicyLocks (lockGuts tp) all_juice + ; jloc_in_set : juicyLocks_in_lockSet n (lockGuts tp) all_juice + ; lset_in_juice: lockSet_in_juicyLocks n (lockGuts tp) all_juice }. Definition mem_compatible_with := mem_compatible_with'. - Definition mem_compatible tp m := ex (mem_compatible_with tp m). + Lemma mem_compatible_with_valid : forall n tp m phi, mem_compatible_with n tp m phi -> ✓{n} phi. + Proof. + intros; apply H. + Qed. + + Definition mem_compatible n tp m := ex (mem_compatible_with n tp m). Lemma jlocinset_lr_valid: forall ls juice, lockSet_in_juicyLocks ls juice -> - lr_valid (AMap.find (elt:=lock_info)^~ (ls)). + lr_valid (fun l => AMap.find (elt:=lock_info) l ls). Proof. simpl; repeat intro. destruct (AMap.find (elt:=option rmap) (b, ofs) ls) eqn:MAP; auto. intros ofs0 ineq. destruct (AMap.find (elt:=option rmap) (b, ofs0) ls) eqn:MAP'; try reflexivity. assert (H':=H). - specialize (H (b,ofs) ltac:(rewrite MAP; auto)). + specialize (H (b,ofs) ltac:(rewrite MAP //)). destruct H as [sh H]. - specialize (H' (b,ofs0) ltac:(rewrite MAP'; auto)). + specialize (H' (b,ofs0) ltac:(rewrite MAP' //)). destruct H' as [sh' H']. exfalso. clear - H ineq H'. simpl in *. specialize (H (ofs0 - ofs)). spec H. lia. specialize (H' 0). spec H'. lia. replace (ofs0+0) with (ofs+(ofs0 - ofs)) in H' by lia. - destruct H as [sh0 [psh [P [J H]]]]; destruct H' as [sh0' [psh' [P' [J' H']]]]. + destruct H as [sh0 [psh [J H]]]; destruct H' as [sh0' [psh' [J' H']]]. rewrite H' in H. inv H. lia. Qed. @@ -313,7 +335,7 @@ Module Concur. rewrite getMaxPerm_correct. specialize (H b). (* manual induction *) - assert (forall n, (exists ofs0, Intv.In ofs (ofs0, (ofs0 + Z.of_nat n)%Z) /\ lockRes js (b, ofs0)) \/ + assert (forall n, (exists ofs0, Intv.In ofs (ofs0, (ofs0 + Z.of_nat n)) /\ is_true (lockRes js (b, ofs0))) \/ (forall ofs0, (ofs0 <= ofs < ofs0 + Z.of_nat n)%Z -> lockRes js (b, ofs0) = None)) as Hdec. { clear; induction n. { right; simpl; intros; lia. } @@ -321,7 +343,7 @@ Module Concur. - destruct H as (? & ? & ?); left; eexists; split; eauto. unfold Intv.In, fst, snd in *; zify; lia. - destruct (lockRes js (b, (ofs - Z.of_nat n)%Z)) eqn: Hres. - + left; eexists; split; [|erewrite Hres; auto]. + + left; eexists; split; [|erewrite Hres; done]. unfold Intv.In, fst, snd in *; zify; lia. + right; intro. destruct (eq_dec ofs0 (ofs - Z.of_nat n)%Z); [subst; auto|]. @@ -356,25 +378,25 @@ Module Concur. Lemma compat_lt_m: forall m js, mem_compatible js m -> forall b ofs, - Mem.perm_order'' ((getMaxPerm m) !! b ofs) - ((lockSet js) !! b ofs). + Mem.perm_order'' (PMap.get b (getMaxPerm m) ofs) + (PMap.get b (lockSet js) ofs). Proof. intros. eapply mem_compatible_locks_ltwritable; auto. Qed. - Lemma compatible_lockRes_join: +(* Lemma compatible_lockRes_join: forall (js : thread_pool) (m : mem), mem_compatible js m -> forall (l1 l2 : address) (phi1 phi2 : rmap), l1 <> l2 -> ThreadPool.lockRes js l1 = Some (Some phi1) -> ThreadPool.lockRes js l2 = Some (Some phi2) -> - joins phi1 phi2. + ✓ (phi1 ⋅ phi2). Proof. intros ? ? Hcompat; intros ? ? ? ? Hneq; intros. destruct Hcompat as [allj Hcompat]. inversion Hcompat. inversion juice_join0; subst. unfold join_locks in H2. - clear - Hneq H2 H H0. unfold lockRes,lockGuts in H, H0. + clear - Hneq H2 H H0. apply AMap.find_2 in H. apply AMap.find_2 in H0. assert (forall x e, AMap.MapsTo x e (lset js) <-> SetoidList.InA (@AMap.eq_key_elt lock_info) (x,e) (AMap.elements (lset js))). { @@ -385,9 +407,10 @@ Module Concur. assert (SetoidList.InA (@AMap.eq_key_elt lock_info) (l2, Some phi2) el). apply H1; auto. clear - H2 H3 H4 Hneq. + revert r1 H2 H3 H4; induction el; simpl; intros. inv H3. - destruct H2 as [r2 [? ?]]. destruct a. + destruct a. assert (H8: joins (Some phi1) (Some phi2)); [ | destruct H8 as [x H8]; destruct x; inv H8; eauto]. inv H3; [ | inv H4]. @@ -442,7 +465,7 @@ Qed. Definition disjoint_lock_thread tp := forall i loc r (cnti : containsThread tp i), lockRes tp loc = SSome r -> - joins (getThreadR cnti)r. + joins (getThreadR cnti)r.*) Variant invariant' (tp:t) := True. (* The invariant has been absorbed my mem_compat*) (* { no_race : disjoint_threads tp @@ -457,8 +480,10 @@ Qed. (* What follows is the lemmas needed to construct a "personal" memory That is a memory with the juice and Cur of a particular thread. *) + Local Open Scope maps. + Definition mapmap {A B} (def:B) (f:positive -> A -> B) (m:PMap.t A): PMap.t B:= - (def, PTree.map f m#2). + (def, PTree.map f m.2). (* You need the memory, to make a finite tree. *) Definition juice2Perm (phi:rmap)(m:mem): access_map:= mapmap (fun _ => None) (fun block _ => fun ofs => perm_of_res (phi @ (block, ofs)) ) (getMaxPerm m). @@ -470,11 +495,11 @@ Qed. Proof. unfold isCanonical; reflexivity. Qed. Lemma juice2Perm_nogrow: forall phi m b ofs, Mem.perm_order'' (perm_of_res (phi @ (b, ofs))) - ((juice2Perm phi m) !! b ofs). + (PMap.get b (juice2Perm phi m) ofs). Proof. intros. unfold juice2Perm, mapmap, PMap.get. rewrite PTree.gmap. - destruct (((getMaxPerm m)#2) ! b) eqn: inBounds; simpl. + destruct (((getMaxPerm m).2) !! b) eqn: inBounds; simpl. - destruct ((perm_of_res (phi @ (b, ofs)))) eqn:AA; rewrite AA; simpl; try reflexivity. apply perm_refl. - unfold Mem.perm_order''. @@ -482,11 +507,11 @@ Qed. Qed. Lemma juice2Perm_locks_nogrow: forall phi m b ofs, Mem.perm_order'' (perm_of_res_lock (phi @ (b, ofs))) - ((juice2Perm_locks phi m) !! b ofs). + (PMap.get b (juice2Perm_locks phi m) ofs). Proof. intros. unfold juice2Perm_locks, mapmap, PMap.get. rewrite PTree.gmap. - destruct (((getMaxPerm m)#2) ! b) eqn: inBounds; simpl. + destruct (((getMaxPerm m).2) !! b) eqn: inBounds; simpl. - destruct ((perm_of_res_lock (phi @ (b, ofs)))) eqn:AA; rewrite AA; simpl; try reflexivity. apply perm_refl. - unfold Mem.perm_order''. @@ -517,17 +542,17 @@ Qed. Qed. Lemma Mem_canonical_useful: forall m loc k, - (Mem.mem_access m)#1 loc k = None. + (Mem.mem_access m).1 loc k = None. Proof. intros. destruct m; simpl in *. unfold PMap.get in nextblock_noaccess. - pose (b:= Pos.max (TreeMaxIndex (mem_access#2) + 1 ) nextblock). - assert (H1: ~ Plt b nextblock). - { intros H. assert (HH:= Pos.le_max_r (TreeMaxIndex (mem_access#2) + 1) nextblock). + pose (b:= Pos.max (TreeMaxIndex (mem_access.2) + 1) nextblock). + assert (H1: ~ Plt b nextblock). + { intros H. assert (HH:= Pos.le_max_r (TreeMaxIndex (mem_access.2) + 1) nextblock). clear - H HH. unfold Pos.le in HH. unfold Plt in H. apply HH. eapply Pos.compare_gt_iff. auto. } - assert (H2 :( b > (TreeMaxIndex (mem_access#2)))%positive ). - { assert (HH:= Pos.le_max_l (TreeMaxIndex (mem_access#2) + 1) nextblock). + assert (H2 :( b > (TreeMaxIndex (mem_access.2)))%positive ). + { assert (HH:= Pos.le_max_l (TreeMaxIndex (mem_access.2) + 1) nextblock). apply Pos.lt_gt. eapply Pos.lt_le_trans; eauto. lia. } specialize (nextblock_noaccess b loc k H1). @@ -535,50 +560,61 @@ Qed. assumption. Qed. + Lemma big_opL_In : forall {M : ofe} o {HM : Monoid o} A (f : A -> M) l a, In a l -> exists l', ([^o list] x ∈ l, f x) ≡ o (f a) l'. + Proof. + induction l; simpl; intros; first done. + destruct H as [-> | H]; eauto. + edestruct IHl as (l' & Heq); first done. + exists (o (f a) l'). + rewrite monoid_proper; last apply Heq; last done. + rewrite !monoid_assoc. + apply monoid_proper; last done. + apply monoid_comm. + Qed. + + Lemma join_list_not_none : forall {A : ora} (a : A) (l : list (option A)), In (Some a) l -> ([^op list] x ∈ l, x) <> None. + Proof. + intros. + eapply (big_opL_In id l) in H as (? & H). + rewrite /= Some_op_opM in H. + inversion H as [??? Heq|]; rewrite -Heq //. + Qed. + Lemma juic2Perm_locks_correct: forall r m b ofs, max_access_cohere m r -> - perm_of_res_lock (r @ (b,ofs)) = (juice2Perm_locks r m) !! b ofs. + perm_of_res_lock (r @ (b,ofs)) = PMap.get b (juice2Perm_locks r m) ofs. Proof. intros. unfold juice2Perm_locks, mapmap. unfold PMap.get; simpl. rewrite PTree.gmap. rewrite PTree.gmap1; simpl. - destruct ((snd (Mem.mem_access m)) ! b) eqn:search; simpl. + destruct ((snd (Mem.mem_access m)) !! b) eqn:search; simpl. - auto. - generalize (H (b, ofs)) => /po_trans. move => /(_ (perm_of_res_lock (r @ (b, ofs)))) /(_ (perm_of_res_op2 _)). unfold max_access_at. unfold access_at. unfold PMap.get; simpl. rewrite search. rewrite Mem_canonical_useful. - unfold perm_of_res_lock. destruct ( r @ (b, ofs)); auto. - destruct k; auto. simpl. - destruct (perm_of_sh (Share.glb Share.Rsh sh)) eqn: HH; auto. - intros; exfalso; assumption. + destruct (perm_of_res_lock (r @ (b, ofs))); done. Qed. Lemma juic2Perm_correct: forall r m b ofs, access_cohere' m r -> - perm_of_res (r @ (b,ofs)) = (juice2Perm r m) !! b ofs. + perm_of_res (r @ (b,ofs)) = PMap.get b (juice2Perm r m) ofs. Proof. intros. unfold juice2Perm, mapmap. unfold PMap.get; simpl. rewrite PTree.gmap. rewrite PTree.gmap1; simpl. - destruct ((snd (Mem.mem_access m)) ! b) eqn:search; simpl. + destruct ((snd (Mem.mem_access m)) !! b) eqn:search; simpl. - auto. - generalize (H (b, ofs)). unfold max_access_at. unfold access_at. unfold PMap.get; simpl. rewrite search. rewrite Mem_canonical_useful. - unfold perm_of_res. destruct ( r @ (b, ofs)). - destruct (eq_dec sh Share.bot); auto; simpl. - intros HH. contradiction HH. - destruct k; try solve [intros HH;inversion HH]. - destruct (perm_of_sh sh); auto. - intros HH;inversion HH. - intros HH;inversion HH. + destruct (perm_of_res (r @ (b, ofs))); done. Qed. Definition juicyRestrict {phi:rmap}{m:Mem.mem}(coh:access_cohere' m phi): Mem.mem:= @@ -597,13 +633,13 @@ Qed. Lemma juicyRestrictContentCoh: forall phi m (coh:access_cohere' m phi) (ccoh:contents_cohere m phi), contents_cohere (juicyRestrict coh) phi. Proof. - unfold contents_cohere; intros. rewrite <- juicyRestrictContents. + unfold contents_cohere, juicy_mem.contents_cohere; intros. rewrite <- juicyRestrictContents. eapply ccoh; eauto. Qed. Lemma juicyRestrictMaxCoh: forall phi m (coh:access_cohere' m phi) (ccoh:max_access_cohere m phi), max_access_cohere (juicyRestrict coh) phi. Proof. - unfold max_access_cohere; intros. + unfold max_access_cohere, juicy_mem.max_access_cohere; intros. repeat rewrite <- juicyRestrictMax. repeat rewrite <- juicyRestrictNextblock. apply ccoh. @@ -623,7 +659,7 @@ Qed. Proof. intros. unfold juicyRestrict. unfold access_at. - destruct (restrPermMap_correct (juice2Perm_cohere coh) loc#1 loc#2) as [MAX CUR]. + destruct (restrPermMap_correct (juice2Perm_cohere coh) loc.1 loc.2) as [MAX CUR]. unfold permission_at in *. rewrite CUR. unfold juice2Perm. @@ -631,12 +667,12 @@ Qed. unfold PMap.get. rewrite PTree.gmap; simpl. destruct ((PTree.map1 - (fun f : Z -> perm_kind -> option permission => f^~ Max) - (Mem.mem_access m)#2) ! (loc#1)) as [VALUE|] eqn:THING. + (fun f ofs => f ofs Max) + (Mem.mem_access m).2) !! (loc.1)) as [VALUE|] eqn:THING. - destruct loc; simpl. destruct ((perm_of_res (phi @ (b, z)))) eqn:HH; rewrite HH; reflexivity. - simpl. rewrite PTree.gmap1 in THING. - destruct (((Mem.mem_access m)#2) ! (loc#1)) eqn:HHH; simpl in THING; try solve[inversion THING]. + destruct (((Mem.mem_access m).2) !! (loc.1)) eqn:HHH; simpl in THING; try solve[inversion THING]. unfold access_cohere' in coh. unfold max_access_at, access_at in coh. unfold PMap.get in coh. generalize (coh loc). @@ -650,24 +686,22 @@ Qed. Lemma juicyRestrictAccCoh: forall phi m (coh:access_cohere' m phi), access_cohere (juicyRestrict coh) phi. Proof. - unfold access_cohere; intros. + unfold access_cohere, juicy_mem.access_cohere; intros. rewrite juicyRestrictCurEq. - destruct ((perm_of_res (phi @ loc))) eqn:HH; try rewrite HH; simpl; reflexivity. + apply perm_order''_refl. Qed. Lemma po_perm_of_res: forall r, - Mem.perm_order'' (perm_of_res' r) (perm_of_res r). + Mem.perm_order'' (perm_of_res' r) (perm_of_res r). Proof. - rewrite /perm_of_res /perm_of_res' => r. - destruct r; try solve[ apply po_refl]. - assert (Mem.perm_order'' (perm_of_sh sh) (Some Nonempty)). - { destruct (perm_of_sh sh) eqn:HH; try solve[constructor]. - apply perm_of_empty_inv in HH; subst sh. - exfalso; apply shares.bot_unreadable; eauto. } - destruct k; first[ apply po_refl | assumption]. + rewrite /perm_of_res'; intros (d, r). + destruct (perm_of_res_cases d r) as [(? & ? & ->) | (? & ->)]; first apply po_refl. + if_tac; first apply po_None. + if_tac; first apply po_None. + simpl; destruct (perm_of_dfrac d) eqn:HH; try solve [constructor]. + apply perm_of_dfrac_None in HH as [-> | ->]; done. Qed. - Lemma max_acc_coh_acc_coh: forall m phi, max_access_cohere m phi -> access_cohere' m phi. Proof. @@ -683,215 +717,12 @@ Qed. Lemma juicyRestrictAccCoh': forall phi m (coh:max_access_cohere m phi), access_cohere (juicyRestrict' coh) phi. Proof. - unfold access_cohere; intros. + unfold access_cohere, juicy_mem.access_cohere; intros. rewrite juicyRestrictCurEq. - destruct ((perm_of_res (phi @ loc))) eqn:HH; try rewrite HH; simpl; reflexivity. - Qed. - - (*Move this to veric.juicy_mem_lemmas.v *) - Lemma po_join_sub': forall r1 r2 : resource, - join_sub r2 r1 -> - Mem.perm_order'' (perm_of_res' r1) (perm_of_res' r2). - - intros r1 r2[r J]; inversion J; subst; simpl. - - if_tac. - + subst. - if_tac. - * eauto with *. - * apply join_to_bot_l in RJ; subst; - congruence. - + if_tac; constructor. - - destruct k; try solve [constructor]. - + apply po_join_sub_sh. - eexists; eauto. - + apply po_join_sub_sh. - * eexists; eauto. - + apply po_join_sub_sh. - * eexists; eauto. - - destruct k. - + if_tac. - * hnf. destruct (perm_of_sh _); apply I. - * apply perm_order''_trans with (perm_of_sh sh3). - -- apply po_join_sub_sh. - ++ eexists; eauto. - -- destruct (perm_of_sh sh3) eqn:E. - ++ constructor. - ++ pose proof @perm_of_empty_inv _ E; subst. - apply join_to_bot_l in RJ; subst; congruence. - + if_tac. - * hnf. destruct (perm_of_sh _); apply I. - * apply perm_order''_trans with (perm_of_sh sh1). - -- apply po_join_sub_sh. - ++ eexists; eauto. - -- destruct (perm_of_sh sh1) eqn:E. - ++ constructor. - ++ pose proof @perm_of_empty_inv _ E; subst; congruence. - + if_tac. - * hnf. destruct (perm_of_sh _); apply I. - * apply perm_order''_trans with (perm_of_sh sh1). - -- apply po_join_sub_sh. - ++ eexists; eauto. - -- destruct (perm_of_sh sh1) eqn:E. - ++ constructor. - ++ pose proof @perm_of_empty_inv _ E; subst; congruence. - - destruct k; try constructor. - + apply po_join_sub_sh; eexists; eauto. - + apply po_join_sub_sh; eexists; eauto. - + apply po_join_sub_sh; eexists; eauto. - - constructor. - Qed. - - Lemma mem_access_coh_sub: forall phi1 phi2 m, - max_access_cohere m phi1 -> - join_sub phi2 phi1 -> - max_access_cohere m phi2. - Proof. - rewrite /max_access_cohere => phi1 phi2 m H H0 loc. - eapply po_trans; eauto. - eapply po_join_sub'. - apply resource_at_join_sub; assumption. - Qed. - - Lemma mem_cohere_sub: forall phi1 phi2 m, - mem_cohere' m phi1 -> - join_sub phi2 phi1 -> - mem_cohere' m phi2. - Proof. - intros. constructor. - - unfold contents_cohere; intros. - eapply resource_at_join_sub with (l:= loc) in H0. - rewrite H1 in H0. - inversion H; clear - H0 cont_coh0. - destruct H0 as [X H0]. - inversion H0; subst. - + symmetry in H. apply cont_coh0 in H; assumption. - + symmetry in H; apply cont_coh0 in H; assumption. - (* - intros loc. - eapply resource_at_join_sub with (l:= loc) in H0. - eapply po_join_sub in H0. - eapply po_trans; eauto. - inversion H; auto. *) - - inversion H. - eapply mem_access_coh_sub; eauto. - - unfold alloc_cohere. - inversion H. clear - H0 all_coh0. - intros loc HH; apply all_coh0 in HH. - apply resource_at_join_sub with (l:= loc) in H0. - rewrite HH in H0. - destruct H0 as [X H0]. - inversion H0; auto. - apply split_identity in RJ; auto. - apply identity_share_bot in RJ; subst; auto. - f_equal; apply proof_irr. - Qed. - - - Lemma join_threads_sub: - forall js i (cnt:containsThread js i) r0 - (H0:join_threads js r0), - join_sub (getThreadR cnt) r0. - Proof. - intros. - - unfold getThreadR. unfold join_threads in H0. - unfold getThreadsR in H0. - destruct js; simpl in *. - pose proof (mem_ord_enum (n:= n num_threads0)). - - specialize (H (Ordinal (n:=n num_threads0) (m:=i) cnt)) . - unfold join_list in H0. - - simpl in H0. - - - replace (enums_equality.enum num_threads0) with (ord_enum (n num_threads0)) in H0. - forget (ord_enum (n num_threads0)) as el. - forget ((Ordinal (n:=n num_threads0) (m:=i) cnt)) as j. - revert H H0; clear; revert r0; induction el; intros. inv H. - unfold in_mem in H. unfold pred_of_mem in H. simpl in H. - pose proof @orP. - specialize (H1 (j == a)(mem_seq (T:=ordinal_eqType (n num_threads0)) el j)). - destruct ((j == a) - || mem_seq (T:=ordinal_eqType (n num_threads0)) el j); inv H. - inv H1. destruct H. - pose proof (@eqP _ j a). destruct (j==a); inv H; inv H1. - simpl in H0. destruct H0 as [? [? ?]]. - exists x; auto. - unfold mem_seq in H. - destruct H0 as [? [? ?]]. - apply (IHel x) in H; auto. apply join_sub_trans with x; auto. eexists; eauto. - - (* Lemma ord_enum_enum: - forall n, - ord_enum n = enum n. - Set Printing All. - Ad mitted.*) - apply ord_enum_enum. + apply po_refl. Qed. - Lemma compatible_threadRes_sub: - forall js i (cnt:containsThread js i), - forall all_juice, - join_all js all_juice -> - join_sub (getThreadR cnt) all_juice. - Proof. - intros. inv H. - assert (H9: join_sub (Some (getThreadR cnt)) (Some all_juice)); - [ | destruct H9 as [x H9]; inv H9; [apply join_sub_refl | eexists; eauto]]. - apply join_sub_trans with (Some r0); [ | eexists; eauto]. - clear - H0. - assert (H9: join_sub (getThreadR cnt) r0) by (eapply join_threads_sub; eauto). - destruct H9 as [x H9]; exists (Some x); constructor; auto. - Qed. - - Lemma join_sub_souble_join: - forall (a1 b1 c1 a2 b2 c2: rmap), - join_sub a1 a2 -> - join_sub b1 b2 -> - sepalg.join a1 b1 c1 -> - sepalg.join a2 b2 c2 -> - join_sub c1 c2. - Proof. - intros. - inv H. inv H0. - eapply sepalg.join_comm in H3. - pose proof (sepalg.join_assoc H3 H2) as X. - destruct X as (x1 & ? & ?). - eapply sepalg.join_comm in H. - eapply sepalg.join_comm in H0. - pose proof (sepalg.join_assoc H H0) as X. - destruct X as (x2 & ? & ?). - eapply sepalg.join_comm in H5. - eapply sepalg.join_comm in H4. - eapply sepalg.join_comm in H6. - pose proof (sepalg.join_assoc H6 H4) as X. - destruct X as (x3 & ? & ?). - exists x3. - replace c1 with x2; auto. - eapply sepalg.join_eq; auto. - Qed. - - Lemma join_list_not_none: - forall el l phi x, - join_list' (List.map snd el) x -> - SetoidList.InA (AMap.eq_key_elt (elt:=option rmap)) - (l, Some phi) el -> - exists s, x = Some s. - Proof. - induction el. - - intros. inv H0. - - intros. destruct H as (?&?&?). - inv H0. - + inv H3. simpl in *. - replace a.2 with (Some phi) in H; - inv H; - eexists; reflexivity. - + exploit IHel; eauto. - intros [s HH]. - subst x0. inv H; eexists; reflexivity. - Qed. - - Lemma compatible_lockRes_sub: +(* Lemma compatible_lockRes_sub: forall js l (phi:rmap) all_juice, join_locks js (Some all_juice) -> lockRes(resources:=LocksAndResources) js l = Some (Some phi) -> @@ -920,7 +751,7 @@ Qed. * eapply join_sub_trans. eapply IHel; eauto. eexists; eauto. - Qed. + Qed.*) Lemma lockres_join_locks_not_none: forall js a d_phi, lockRes(resources:=LocksAndResources) @@ -930,26 +761,70 @@ Qed. intros. apply AMap.find_2 in H. unfold OrdinalPool.lockGuts in *. apply AMap.elements_1 in H. simpl in *. - intros HH. + intros HH. unfold join_locks in HH. - exploit join_list_not_none; eauto. - intros [? ?]; discriminate. + symmetry in HH; rewrite None_equiv_eq in HH. + eapply join_list_not_none in HH; first done. + apply SetoidList.InA_alt in H as ((?, ?) & (? & ?) & ?); simpl in *; subst. + rewrite in_map_iff; eexists (_, _); simpl; eauto. Qed. - Lemma lock_thread_sub_all_juice: - forall js all_juice d_phi phi i Hi a, - join_all js all_juice -> - lockRes js a = Some (Some d_phi) -> - sepalg.join (@getThreadR _ _ _ i js Hi) d_phi phi -> - join_sub phi all_juice. + + Lemma mem_cohere_sub: forall (phi1 phi2 : rmap) m, ✓ phi1 -> + mem_cohere' m phi1 -> + phi2 ≼ phi1 -> + mem_cohere' m phi2. + Proof. + intros ??? Hv [???] H; split. + - intros loc. + rewrite gmap.lookup_included in H; specialize (H loc). + eapply contents_cohere_mono, cont_coh0. + by apply resR_le. + - intros loc. + rewrite gmap.lookup_included in H; specialize (H loc). + assert (✓ (phi1 !! loc))%stdpp by done. + eapply max_access_cohere_mono, max_coh0; last by apply resR_le. + rewrite resR_to_resource_fst; destruct (phi1 !! loc)%stdpp eqn: Hl; rewrite Hl in H0 |- *; try done. + by apply dfrac_of'_valid. + - intros ? Hout; specialize (all_coh0 _ Hout). + rewrite gmap.lookup_included in H; specialize (H loc). + apply option_included in H as [? | (? & ? & H1 & ? & ?)]; try done. + rewrite all_coh0 // in H. + Qed. + + Lemma join_threads_sub: + forall js i (cnt:containsThread js i) r0 + (H0:join_threads js r0), + getThreadR cnt ≼ r0. Proof. intros. - inv H. inv H4. - - exfalso; eapply lockres_join_locks_not_none; eauto. - - eapply join_sub_souble_join; eauto. - eapply join_threads_sub; assumption. - eapply compatible_lockRes_sub; eassumption. + unfold getThreadR. unfold join_threads in H0. + unfold getThreadsR in H0. + destruct js; simpl in *. + pose proof (fintype.mem_ord_enum (n:= n num_threads0) (fintype.Ordinal (n:=n num_threads0) (m:=i) cnt)) as H. + rewrite -ord_enum_enum in H0. + eapply (cmra_included_proper(A := resource_map.rmapUR _ _)); [done | apply H0 |]. + edestruct (big_opL_In id (map perm_maps0 (fintype.ord_enum (n num_threads0))) (perm_maps0 (fintype.Ordinal (n:=n num_threads0) (m:=i) cnt))) as (x & ->); last by eexists. + rewrite in_map_iff; eexists; split; first done. + clear - H. + forget (fintype.ord_enum (n num_threads0)) as el. + forget (fintype.Ordinal (n:=n num_threads0) (m:=i) cnt) as j. + clear - H; induction el; simpl in *; try done. + unfold in_mem in H. unfold pred_of_mem in H. simpl in H. + destruct (@eqtype.eqP (fintype.ordinal_eqType (n num_threads0)) j a); auto. Qed. + Lemma compatible_threadRes_sub: + forall js i (cnt:containsThread js i), + forall all_juice, + join_all js all_juice -> + (getThreadR cnt) ≼ all_juice. + Proof. + intros. inv H. + rewrite -(Some_included_total(A := resource_map.rmapUR _ _)). + rewrite -H3 Some_op -H2. + etrans; first by apply Some_included_2, join_threads_sub. + rewrite -assoc; by eexists. + Qed. Lemma mem_compat_thread_max_cohere {tp m} (compat: mem_compatible tp m): forall {i} cnti, @@ -958,11 +833,17 @@ Qed. destruct compat as [x compat] => i cnti loc. apply po_trans with (b:= perm_of_res' (x @ loc)). - inversion compat. inversion all_cohere0. apply max_coh0. - - (*This comes from *) - apply po_join_sub'. - apply resource_at_join_sub. - eapply compatible_threadRes_sub. - inversion compat; inversion all_cohere0; assumption. + - pose proof (mem_compatible_with_valid compat) as Hv. + specialize (Hv loc). + apply perm_of_dfrac_mono. + { rewrite /resource_at resR_to_resource_fst. + destruct (_ !! _)%stdpp; last done. + by apply dfrac_of'_valid. } + inv compat. + apply (compatible_threadRes_sub cnti) in juice_join0. + rewrite gmap.lookup_included in juice_join0. + specialize (juice_join0 loc). + apply resR_le in juice_join0 as (? & ?); done. Qed. Lemma thread_mem_compatible: forall tp m, @@ -971,30 +852,35 @@ Qed. Proof. intros. destruct H as [allj H]. inversion H. unfold mem_thcohere; intros. + assert (✓ allj) by (inv juice_join0; done). eapply compatible_threadRes_sub with (cnt:=cnt)in juice_join0. eapply mem_cohere_sub; eauto. Qed. - Lemma compatible_lockRes_sub_all: forall js l phi, - lockRes js l = Some (Some phi) -> + Lemma join_locks_sub: forall js l phi r0 + (Hl : lockRes js l = Some (Some phi)) (H0 : join_locks js r0), + Some phi ≼ r0. + Proof. + intros. + eapply (cmra_included_proper(A := optionR _)); [done..|]. + apply AMap.find_2 in Hl. unfold OrdinalPool.lockGuts in *. + apply AMap.elements_1 in Hl. + apply SetoidList.InA_alt in Hl as ((?, ?) & (? & ?) & ?); simpl in *; subst. + edestruct (big_opL_In(o := op(A := optionR _)) id (map snd (AMap.elements (elt:=option rmap) (lset js))) (Some phi)) as (x & ->); last by eexists. + rewrite in_map_iff; eexists (_, _); simpl; eauto. + Qed. + + Lemma compatible_lockRes_sub_all: forall js l phi + (Hl : lockRes js l = Some (Some phi)), forall all_juice, join_all js all_juice -> - join_sub phi all_juice. + phi ≼ all_juice. Proof. - intros. - inv H0. - assert (H9: join_sub (Some phi) (Some all_juice)); - [ | destruct H9 as [x H9]; inv H9; [apply join_sub_refl | eexists; eauto]]. - apply join_sub_trans with (b:=r1); [ | eexists; eauto]. - clear - H H2. - hnf in H2. simpl in H. simpl in *. - apply AMap.find_2 in H. unfold OrdinalPool.lockGuts in H. - apply AMap.elements_1 in H. simpl in *. - forget (AMap.elements (elt:= option rmap) (lset js)) as el. - revert r1 H2; induction el; simpl; intros. inv H. - destruct H2 as [? [? ?]]. destruct a; simpl in *. inv H. inv H3. simpl in *; subst. - exists x; auto. apply IHel in H1; auto. - apply join_sub_trans with x; auto. exists o; auto. + intros. inv H. + rewrite -(Some_included_total(A := resource_map.rmapUR _ _)). + rewrite -H3 Some_op -H2. + etrans; first by eapply join_locks_sub. + rewrite (cmra_comm(A := optionR _) _ r1) -assoc; by eexists. Qed. Lemma lock_mem_compatible: forall tp m, @@ -1003,44 +889,41 @@ Qed. Proof. intros. destruct H as [allj H]. inversion H. unfold mem_thcohere; intros. - unfold mem_lock_cohere; intros. - eapply compatible_lockRes_sub_all in juice_join0; [|apply H0]. - eapply mem_cohere_sub; eauto. + unfold mem_lock_cohere; intros. + assert (✓ allj) by (inv juice_join0; done). + eapply compatible_lockRes_sub_all in juice_join0; [|apply H0]. + eapply mem_cohere_sub; eauto. Qed. (* PERSONAL MEM: Is the contents of the global memory, - with the juice of a single thread and the Cur that corresponds to that juice.*) - Definition acc_coh:= fun m phi pr => @max_acc_coh_acc_coh m phi (max_coh pr). - Definition personal_mem {m phi} (pr : mem_cohere' m phi) : juicy_mem:= - mkJuicyMem - (@juicyRestrict phi m (acc_coh pr)) - phi - (juicyRestrictContentCoh (acc_coh pr) (cont_coh pr)) - (juicyRestrictAccCoh (acc_coh pr)) - (juicyRestrictMaxCoh (acc_coh pr) (max_coh pr)) - (juicyRestrictAllocCoh (acc_coh pr) (all_coh pr)). - - Definition juicy_sem := (FSem.F _ _ JuicyFSem.t) _ the_sem. + with the Cur permissions of one thread's rmap.*) + Definition acc_coh := fun m phi pr => @max_acc_coh_acc_coh m phi (max_coh pr). + Definition personal_mem {m phi} (pr : mem_cohere' m phi) : mem := + (@juicyRestrict phi m (acc_coh pr)). + + (*Definition juicy_sem := (FSem.F _ _ JuicyFSem.t) _ the_sem.*) (* Definition juicy_step := (FSem.step _ _ JuicyFSem.t) _ _ the_sem. *) Program Definition first_phi (tp : thread_pool) : rmap := (@getThreadR _ _ _ 0%nat tp _). Next Obligation. - unfold OrdinalPool.containsThread. - destruct num_threads. - simpl. - ssrlia. + intros tp. + hnf. + destruct num_threads; simpl. + apply /ssrnat.leP; lia. Defined. - Program Definition level_tp (tp : thread_pool) := level (first_phi tp). +(* Program Definition level_tp (tp : thread_pool) := level (first_phi tp). Definition tp_level_is_above n tp := (forall i (cnti : containsThread tp i), le n (level (getThreadR cnti))) /\ - (forall i phi, lockRes(resources:=LocksAndResources) tp i = Some (Some phi) -> le n (level phi)). + (forall i phi, lockRes(resources:=LocksAndResources) tp i = Some (Some phi) -> le n (level phi)) /\ + le n (level (extraRes tp)). Definition tp_level_is n tp := (forall i (cnti : containsThread tp i), level (getThreadR cnti) = n) /\ - (forall i phi, lockRes(resources:=LocksAndResources) tp i = Some (Some phi) -> level phi = n). + (forall i phi, lockRes(resources:=LocksAndResources) tp i = Some (Some phi) -> level phi = n) /\ + n = level (extraRes tp).*) (* Lemma mem_compatible_same_level tp m : @@ -1066,20 +949,20 @@ Qed. eapply (DLT _); eauto. Qed. *) - Definition cnt_from_ordinal tp : forall i : ordinal (pos.n (num_threads tp)), containsThread tp i. +(* Definition cnt_from_ordinal tp : forall i : fintype.ordinal (pos.n (num_threads tp)), OrdinalPool.containsThread tp i. intros [i pr]; apply pr. Defined. Definition age_tp_to (k : nat) (tp : thread_pool) : thread_pool := match tp with - mk n pool maps lset => + mk n pool maps lset ex => mk n pool ((age_to k) oo maps) - (AMap.map (option_map (age_to k)) lset) + (AMap.map (option_map (age_to k)) lset) (age_to k ex) end. Lemma level_age_tp_to tp k : tp_level_is_above k tp -> tp_level_is k (age_tp_to k tp). Proof. - intros [T L]; split. + intros (T & L & R); split3. - intros i cnti. destruct tp. apply level_age_to. @@ -1092,6 +975,8 @@ Qed. simpl in E. injection E as ->. apply level_age_to. eapply L, IN'. + - destruct tp; simpl in *. + rewrite level_age_to; auto. Qed. Lemma map_compose {A B C} (g : A -> B) (f : B -> C) l : map (f oo g) l = map f (map g l). @@ -1141,19 +1026,18 @@ Qed. join_all tp Phi -> join_all (age_tp_to k tp) (age_to k Phi). Proof. - intros L J. inversion J as [r rT rL r' JT JL JTL]; subst. + intros L J. inversion J as [r rT rL r' r'' JT JL JTL JJ]; subst. pose (rL' := option_map (age_to k) rL). - destruct tp as [N pool phis lset]; simpl in *. - eapply AllJuice with (age_to k rT) rL'. + destruct tp as [N pool phis lset ex]; simpl in *. + eapply AllJuice with (age_to k rT) rL' (age_to k r'). - { hnf in *; simpl in *. unfold getThreadsR in *; simpl in *. rewrite map_compose. apply join_list_age_to; auto. - assert (E : level rT = level Phi). { - inversion JTL as [ | a H H0 H2 | a1 a2 a3 JJ H H1 H0]; subst. auto. - pose proof join_level _ _ _ JJ. intuition. } - rewrite E; auto. + apply join_level in JJ as []. + inv JTL; try ssrlia. + apply join_level in H4 as []; ssrlia. } - hnf. hnf in JL. simpl in JL. @@ -1161,13 +1045,15 @@ Qed. rewrite AMap_map. apply join_list'_age_to. destruct rL as [rL|]; auto. - assert (E : level rL = level Phi). { - inversion JTL as [ | a H H0 H2 | a1 a2 a3 JJ H H1 H0]; subst. auto. - pose proof join_level _ _ _ JJ. intuition. } - rewrite E; auto. + apply join_level in JJ as []. + inv JTL. + apply join_level in H4 as []; ssrlia. - destruct rL as [rL | ]; unfold rL'. + constructor. apply age_to_join_eq; eauto. inversion JTL; eauto. + apply join_level in JJ as []; ssrlia. + inversion JTL. constructor. + - simpl. + apply age_to_join_eq; auto. Qed. Lemma perm_of_age rm age loc : @@ -1215,7 +1101,7 @@ Qed. destruct js; auto. Qed. - Lemma cnt_age' {js i age} : + Lemma {js i age} : containsThread js i -> containsThread (age_tp_to age js) i. Proof. @@ -1230,25 +1116,23 @@ Qed. destruct tp; simpl. f_equal. f_equal. apply cnt_irr. - Qed. + Qed.*) Inductive juicy_step {tid0 tp m} (cnt: containsThread tp tid0) (Hcompatible: mem_compatible tp m) : thread_pool -> mem -> list mem_event -> Prop := | step_juicy : - forall (tp':thread_pool) c jm jm' m' (c' : C), + forall (tp':thread_pool) c m1 phi' m' (c' : C), forall (Hpersonal_perm: - personal_mem (thread_mem_compatible Hcompatible cnt) = jm) + personal_mem (thread_mem_compatible Hcompatible cnt) = m1) (Hinv : invariant tp) (Hthread: getThreadC cnt = Krun c) - (Hcorestep: corestep juicy_sem c jm c' jm') - (Htp': tp' = @updThread _ _ _ tid0 (age_tp_to (level jm') tp) (cnt_age' cnt) (Krun c') (m_phi jm')) - (Hm': m_dry jm' = m'), - juicy_step cnt Hcompatible tp' m' [::]. + (Hcorestep: corestep the_sem c m1 c' m') + (Htp': tp' = @updThread _ _ _ tid0 tp cnt (Krun c') phi') (* can we leave phi' unconstrained? *), + juicy_step cnt Hcompatible tp' m' nil. - Definition pack_res_inv (R: pred rmap) := SomeP rmaps.Mpred (fun _ => R) . - - Definition lock_at_least sh R phi b ofs := - forall i, 0 <= i < LKSIZE -> exists sh' rsh', join_sub sh sh' /\ phi@(b,ofs+i) = YES sh' rsh' (LK LKSIZE i) (pack_res_inv R). + (* Trying without tracking lock invariants. *) + Definition lock_at_least (sh : dfrac) (phi : rmap) b ofs := + forall i, 0 <= i < LKSIZE -> exists sh', sh ≼ sh' /\ (phi @ (b,ofs+i))%stdpp = (sh', Some (LK LKSIZE i)). Notation Kblocked := (threadPool.Kblocked). @@ -1257,7 +1141,7 @@ Qed. (cnt0:containsThread tp tid0)(Hcompat:mem_compatible tp m): thread_pool -> mem -> sync_event -> Prop := | step_acquire : - forall (tp' tp'' tp''':thread_pool) c m0 m1 b ofs d_phi phi phi' m' pmap_tid', + forall (tp' tp'':thread_pool) c m0 m1 b ofs d_phi phi phi' m' pmap_tid', forall (Hinv : invariant tp) (Hthread: getThreadC cnt0 = Kblocked c) @@ -1266,8 +1150,8 @@ Qed. (*Hpersonal_perm: personal_mem cnt0 Hcompatible = jm*) (Hpersonal_juice: getThreadR cnt0 = phi) - (sh:Share.t)(R:pred rmap) - (HJcanwrite: lock_at_least sh R phi b (Ptrofs.intval ofs)) + sh + (HJcanwrite: lock_at_least sh phi b (Ptrofs.intval ofs)) (Hrestrict_map0: juicyRestrict_locks (mem_compat_thread_max_cohere Hcompat cnt0) = m0) (Hload: Mem.load Mptr m0 b (Ptrofs.intval ofs) = Some (Vptrofs Ptrofs.one)) @@ -1281,15 +1165,14 @@ Qed. (* This following condition is not needed: It should follow from the mem_compat statement... somehow... *) (Hrestrict_pmap: restrPermMap Hlt' = m1) - (Hstore: Mem.store Mptr m1 b (Ptrofs.intval ofs) (Vint Int.zero) = Some m') - (His_unlocked: lockRes tp (b, Ptrofs.intval ofs) = SSome d_phi ) - (Hadd_lock_res: join phi d_phi phi') + (Hstore: Mem.store Mptr m1 b (Ptrofs.intval ofs) (Vptrofs Ptrofs.zero) = Some m') + (His_unlocked: lockRes tp (b, Ptrofs.intval ofs) = SSome d_phi) + (Hadd_lock_res: phi' = phi ⋅ d_phi) (Htp': tp' = updThread cnt0 (Kresume c Vundef) phi') - (Htp'': tp'' = updLockSet tp' (b, Ptrofs.intval ofs) None ) - (Htp''': tp''' = age_tp_to (level phi - 1)%coq_nat tp''), - syncStep' cnt0 Hcompat tp''' m' (acquire (b, Ptrofs.intval ofs) None) + (Htp'': tp'' = updLockSet tp' (b, Ptrofs.intval ofs) None), + syncStep' cnt0 Hcompat tp'' m' (acquire (b, Ptrofs.intval ofs) None) | step_release : - forall (tp' tp'' tp''':thread_pool) c m0 m1 b ofs (phi d_phi :rmap) (R: pred rmap) phi' m' pmap_tid', + forall (tp' tp'':thread_pool) c m0 m1 b ofs (phi d_phi :rmap) phi' m' pmap_tid', forall (Hinv : invariant tp) (Hthread: getThreadC cnt0 = Kblocked c) @@ -1298,8 +1181,8 @@ Qed. (* Hpersonal_perm: personal_mem cnt0 Hcompatible = jm *) (Hpersonal_juice: getThreadR cnt0 = phi) - (sh:Share.t) - (HJcanwrite: lock_at_least sh R phi b (Ptrofs.intval ofs)) + sh + (HJcanwrite: lock_at_least sh phi b (Ptrofs.intval ofs)) (Hrestrict_map0: juicyRestrict_locks (mem_compat_thread_max_cohere Hcompat cnt0) = m0) (Hload: Mem.load Mptr m0 b (Ptrofs.intval ofs) = Some (Vptrofs Ptrofs.zero)) @@ -1315,15 +1198,13 @@ Qed. (Hrestrict_pmap: restrPermMap Hlt' = m1) (Hstore: Mem.store Mptr m1 b (Ptrofs.intval ofs) (Vptrofs Ptrofs.one) = Some m') (His_locked: lockRes tp (b, Ptrofs.intval ofs) = SNone ) - (Hsat_lock_inv: R (age_by 1 d_phi)) - (Hrem_lock_res: join d_phi phi' phi) + (Hrem_lock_res: phi = d_phi ⋅ phi') (Htp': tp' = updThread cnt0 (Kresume c Vundef) phi') (Htp'': tp'' = - updLockSet tp' (b, Ptrofs.intval ofs) (Some d_phi)) - (Htp''': tp''' = age_tp_to (level phi - 1)%coq_nat tp''), - syncStep' cnt0 Hcompat tp''' m' (release (b, Ptrofs.intval ofs) None) + updLockSet tp' (b, Ptrofs.intval ofs) (Some d_phi)), + syncStep' cnt0 Hcompat tp'' m' (release (b, Ptrofs.intval ofs) None) | step_create : - forall (tp_upd tp':thread_pool) c vf arg jm (d_phi phi': rmap) b ofs (* P Q *), + forall (tp_upd tp':thread_pool) c vf arg (d_phi phi': rmap) b ofs (* P Q *), forall (Hinv : invariant tp) (Hthread: getThreadC cnt0 = Kblocked c) @@ -1331,15 +1212,12 @@ Qed. Some (CREATE, vf::arg::nil)) (* (Harg: Val.inject (Mem.flat_inj (Mem.nextblock m)) arg arg) *) (Hfun_sepc: vf = Vptr b ofs) - (Hpersonal_perm: - personal_mem (thread_mem_compatible Hcompat cnt0) = jm) - (Hrem_fun_res: join d_phi phi' (m_phi jm)) + (Hrem_fun_res: getThreadR cnt0 = d_phi ⋅ phi') (Htp': tp_upd = updThread cnt0 (Kresume c Vundef) phi') - (Htp'': tp' = age_tp_to (level (m_phi jm) - 1)%coq_nat (addThread tp_upd vf arg d_phi)), + (Htp'': tp' = addThread tp_upd vf arg d_phi), syncStep' cnt0 Hcompat tp' m (spawn (b, Ptrofs.intval ofs) None None) | step_mklock : - forall (tp' tp'': thread_pool) jm c b ofs R , - let: phi := m_phi jm in + forall (tp' tp'': thread_pool) m c b ofs, forall phi' m' (Hinv : invariant tp) @@ -1348,23 +1226,21 @@ Qed. Some (MKLOCK, Vptr b ofs::nil)) (*Hright_juice: m = m_dry jm*) (Hpersonal_perm: - personal_mem (thread_mem_compatible Hcompat cnt0) = jm) - (Hpersonal_juice: getThreadR cnt0 = phi) + personal_mem (thread_mem_compatible Hcompat cnt0) = m) (*Check I have the right permission to mklock and the right value (i.e. 0) *) (*Haccess: address_mapsto LKCHUNK (Vint Int.zero) sh Share.top (b, Ptrofs.intval ofs) phi*) (Hstore: - Mem.store Mptr (m_dry jm) b (Ptrofs.intval ofs) (Vptrofs Ptrofs.zero) = Some m') + Mem.store Mptr m b (Ptrofs.intval ofs) (Vptrofs Ptrofs.zero) = Some m') (* [Hrmap] replaced: [Hct], [Hlock], [Hj_forward] and [levphi']. This says that phi and phi' coincide everywhere except in adr_range, and specifies how phi and phi' should differ in adr_range (in particular, they have equal shares, pointwise) *) - (Hrmap : rmap_makelock phi phi' (b, Ptrofs.unsigned ofs) R LKSIZE) + (Hrmap : rmap_makelock (getThreadR cnt0) phi' (b, Ptrofs.unsigned ofs) LKSIZE) (Htp': tp' = updThread cnt0 (Kresume c Vundef) phi') - (Htp'': tp'' = age_tp_to (level phi - 1)%coq_nat - (updLockSet tp' (b, Ptrofs.intval ofs) None )), + (Htp'': tp'' = updLockSet tp' (b, Ptrofs.intval ofs) None), syncStep' cnt0 Hcompat tp'' m' (mklock (b, Ptrofs.intval ofs)) | step_freelock : - forall (tp' tp'': thread_pool) c b ofs phi R phi', + forall (tp' tp'': thread_pool) c b ofs phi phi', forall (Hinv : invariant tp) (Hthread: getThreadC cnt0 = Kblocked c) @@ -1374,26 +1250,22 @@ Qed. (*First check the lock is acquired:*) (His_acq: lockRes tp (b, (Ptrofs.intval ofs)) = SNone) (*Relation between rmaps:*) - (Hrmap : rmap_freelock phi phi' m (b, Ptrofs.unsigned ofs) R LKSIZE) + (Hrmap : rmap_freelock phi phi' m (b, Ptrofs.unsigned ofs) LKSIZE) (Htp': tp' = updThread cnt0 (Kresume c Vundef) phi') - (Htp'': tp'' = age_tp_to (level phi - 1)%coq_nat - (remLockSet tp' (b, Ptrofs.intval ofs) )), + (Htp'': tp'' = remLockSet tp' (b, Ptrofs.intval ofs)), syncStep' cnt0 Hcompat tp'' m (freelock (b, Ptrofs.intval ofs)) | step_acqfail : - forall c b ofs jm m1, - let: phi := m_phi jm in + forall c b ofs m1, forall (Hinv : invariant tp) (Hthread: getThreadC cnt0 = Kblocked c) (Hat_external: at_external the_sem c m = Some (LOCK, Vptr b ofs::nil)) - (Hpersonal_perm: - personal_mem (thread_mem_compatible Hcompat cnt0) = jm) (Hrestrict_map: juicyRestrict_locks (mem_compat_thread_max_cohere Hcompat cnt0) = m1) - (sh:Share.t) (R:pred rmap) - (HJcanwrite: lock_at_least sh R phi b (Ptrofs.intval ofs)) + sh + (HJcanwrite: lock_at_least sh (getThreadR cnt0) b (Ptrofs.intval ofs)) (Hload: Mem.load Mptr m1 b (Ptrofs.intval ofs) = Some (Vptrofs Ptrofs.zero)), syncStep' cnt0 Hcompat tp m (failacq (b,Ptrofs.intval ofs)). @@ -1424,23 +1296,17 @@ Qed. - intros [cntj [ q running]]. inversion H; subst. assert (cntj':=cntj). - eapply cnt_age' in cntj'. - eapply (cntUpdate(resources := LocksAndResources) (Krun c') (m_phi jm') (cnt_age' cntj)) in cntj'. + eapply (cntUpdate(resources := LocksAndResources) (Krun c') phi' cntj) in cntj'. exists cntj'. destruct (NatTID.eq_tid_dec i j). + subst j; exists c'. rewrite gssThreadCode; reflexivity. + exists q. rewrite gsoThreadCode; auto. - generalize running; destruct tp; simpl. - intros RUN; rewrite <- RUN. - f_equal. f_equal. - apply cnt_irr. - intros [cntj' [ q' running]]. inversion H; subst. assert (cntj:=cntj'). - eapply cnt_age in cntj. - eapply cntUpdate' with(c:=Krun c')(p:=m_phi jm') in cntj; eauto. + eapply cntUpdate' with(c:=Krun c')(p:=phi') in cntj; eauto. exists cntj. destruct (NatTID.eq_tid_dec i j). + subst j; exists c. @@ -1449,10 +1315,6 @@ Qed. apply cnt_irr. + exists q'. rewrite gsoThreadCode in running; auto. - rewrite <- running. - destruct tp; simpl. - f_equal. f_equal. - apply cnt_irr. Qed. Definition syncStep (isCoarse:bool) : @@ -1480,24 +1342,19 @@ Qed. end. + (*this should be easy to automate or shorten*) inversion H; subst. - * exists (cnt_age' (cntUpdateL _ _ (cntUpdate (Kresume c Vundef) phi' _ cntj))), q. - erewrite <- age_getThreadCode. + * exists ((cntUpdateL _ _ (cntUpdate (Kresume c Vundef) (getThreadR cnt ⋅ d_phi) _ cntj))), q. rewrite gLockSetCode. rewrite gsoThreadCode; assumption. - * exists (cnt_age' (cntUpdateL _ _ (cntUpdate(resources:=LocksAndResources) (Kresume c Vundef) phi' _ cntj))), q. - erewrite <- age_getThreadCode. + * exists ((cntUpdateL _ _ (cntUpdate(resources:=LocksAndResources) (Kresume c Vundef) phi' _ cntj))), q. rewrite gLockSetCode. rewrite gsoThreadCode; assumption. - * exists (cnt_age' (cntAdd _ _ _ (cntUpdate(resources:=LocksAndResources) (Kresume c Vundef) phi' _ cntj))), q. - erewrite <- age_getThreadCode. + * exists ((cntAdd _ _ _ (cntUpdate(resources:=LocksAndResources) (Kresume c Vundef) phi' _ cntj))), q. erewrite gsoAddCode . (*i? *) rewrite gsoThreadCode; assumption. - * exists (cnt_age' (cntUpdateL _ _ (cntUpdate(resources:=LocksAndResources) (Kresume c Vundef) phi' _ cntj))), q. - erewrite <- age_getThreadCode. + * exists ((cntUpdateL _ _ (cntUpdate(resources:=LocksAndResources) (Kresume c Vundef) phi' _ cntj))), q. rewrite gLockSetCode. rewrite gsoThreadCode; assumption. - * exists (cnt_age' (cntRemoveL _ (cntUpdate(resources:=LocksAndResources) (Kresume c Vundef) phi' _ cntj))), q. - erewrite <- age_getThreadCode. + * exists ((cntRemoveL _ (cntUpdate(resources:=LocksAndResources) (Kresume c Vundef) phi' _ cntj))), q. rewrite gRemLockSetCode. rewrite gsoThreadCode; assumption. * exists cntj, q; assumption. @@ -1505,14 +1362,12 @@ Qed. destruct (NatTID.eq_tid_dec i j). + subst j. generalize running; clear running. inversion H; subst; - try erewrite <- age_getThreadCode; try rewrite gLockSetCode; try rewrite gRemLockSetCode; try rewrite gssThreadCode; try solve[intros HH; inversion HH]. { (*addthread*) assert (cntj':=cntj). - eapply cnt_age in cntj'. eapply cntAdd' in cntj'. destruct cntj' as [ [HH HHH] | HH]. * erewrite gsoAddCode; eauto. subst; rewrite gssThreadCode; intros AA; inversion AA. @@ -1523,7 +1378,6 @@ Qed. rewrite Hthread; intros HH; inversion HH. } + generalize running; clear running. inversion H; subst; - try erewrite <- age_getThreadCode; try rewrite gLockSetCode; try rewrite gRemLockSetCode; try (rewrite gsoThreadCode; [|auto]); @@ -1534,20 +1388,18 @@ Qed. end). (*Add thread case*) assert (cntj':=cntj). - eapply cnt_age in cntj'. eapply cntAdd' in cntj'; destruct cntj' as [ [HH HHH] | HH]. * erewrite gsoAddCode; eauto. destruct (NatTID.eq_tid_dec i j); [subst; rewrite gssThreadCode; intros AA; inversion AA|]. rewrite gsoThreadCode; auto. exists HH, q; assumption. - * erewrite gssAddCode . intros AA; inversion AA. + * erewrite gssAddCode. intros AA; inversion AA. assumption. Unshelve. all: eauto. - apply cntAdd. eauto. Qed. @@ -1571,7 +1423,7 @@ Qed. corresponding to global variables, arguments and function specs. *) - (*Lemma onePos: (0<1)%coq_nat. auto. Qed.*) + (*Lemma onePos: (0<1)%nat. auto. Qed.*) Definition initial_machine rmap c:= mk (mkPos (le_n 1)) @@ -1581,7 +1433,7 @@ Qed. Definition init_mach rmap (m:mem) (tp:thread_pool) (m':mem) (v:val) (args:list val) : Prop := exists c, initial_core the_sem 0 m c m' v args /\ - match rmap with Some rmap => tp = initial_machine rmap c | None => False end. + match rmap with Some rmap => tp = initial_machine rmap c (core rmap) | None => False end. Section JuicyMachineLemmas. @@ -1592,19 +1444,26 @@ Qed. forall l r, ThreadPool.lockRes js l = Some (Some r) -> forall b ofs, - Mem.perm_order'' ((getMaxPerm m) !! b ofs) (perm_of_res' (r @ (b, ofs))). + Mem.perm_order'' (PMap.get b (getMaxPerm m) ofs) (perm_of_res' (r @ (b, ofs))). Proof. intros. destruct H as [allj H]. inversion H. cut (Mem.perm_order'' (perm_of_res' (allj @ (b,ofs))) (perm_of_res' (r @ (b, ofs)))). - {intros AA. eapply po_trans; eauto. - inversion all_cohere0. - rewrite getMaxPerm_correct. - specialize (max_coh0 (b,ofs)). - eapply max_coh0. } - { apply po_join_sub'. - apply resource_at_join_sub. - eapply compatible_lockRes_sub_all; eauto; apply H0. } + { intros AA. eapply po_trans; eauto. + inversion all_cohere0. + rewrite getMaxPerm_correct. + specialize (max_coh0 (b,ofs)). + eapply max_coh0. } + { assert (✓ allj) as Hv by (by inv juice_join0). + specialize (Hv (b, ofs)). + apply perm_of_dfrac_mono; try done. + { rewrite /resource_at resR_to_resource_fst. + destruct (_ !! _)%stdpp; last done. + by apply dfrac_of'_valid. } + eapply compatible_lockRes_sub_all in juice_join0; last done. + rewrite gmap.lookup_included in juice_join0. + specialize (juice_join0 (b, ofs)). + apply resR_le in juice_join0 as (? & ?); done. } Qed. @@ -1613,45 +1472,28 @@ Qed. forall l r, ThreadPool.lockRes js l = Some (Some r) -> forall b ofs, - Mem.perm_order'' ((getMaxPerm m) !! b ofs) (perm_of_res (r @ (b, ofs))). + Mem.perm_order'' (PMap.get b (getMaxPerm m) ofs) (perm_of_res (r @ (b, ofs))). Proof. intros. destruct H as [allj H]. inversion H. cut (Mem.perm_order'' (perm_of_res (allj @ (b,ofs))) (perm_of_res (r @ (b, ofs)))). - {intros AA. eapply po_trans; eauto. - inversion all_cohere0. - rewrite getMaxPerm_correct. - eapply max_acc_coh_acc_coh in max_coh0. - specialize (max_coh0 (b,ofs)). - apply max_coh0. } - { apply po_join_sub. - apply resource_at_join_sub. - eapply compatible_lockRes_sub_all; eauto; apply H0. } - Qed. - - Lemma access_cohere_sub': forall phi1 phi2 m, - access_cohere' m phi1 -> - join_sub phi2 phi1 -> - access_cohere' m phi2. - Proof. - unfold access_cohere'; intros. - eapply po_trans. - - apply H. - - apply po_join_sub. - apply resource_at_join_sub; assumption. + { intros AA. eapply po_trans; eauto. + inversion all_cohere0. + rewrite getMaxPerm_correct. + eapply max_acc_coh_acc_coh in max_coh0. + specialize (max_coh0 (b,ofs)). + apply max_coh0. } + { assert (✓ allj) as Hv by (by inv juice_join0). + specialize (Hv (b, ofs)). + eapply perm_of_res_mono', resR_le; try done. + { rewrite /resource_at resR_to_resource_fst. + destruct (_ !! _)%stdpp; last done. + by apply dfrac_of'_valid. } + eapply compatible_lockRes_sub_all in juice_join0; last done. + rewrite gmap.lookup_included in juice_join0; eauto. } Qed. - - - Lemma mem_cohere'_juicy_mem jm : mem_cohere' (m_dry jm) (m_phi jm). - Proof. - destruct jm as [m phi C A M L]; simpl. - constructor; auto. - Qed. - - - - Lemma compatible_threadRes_join: +(* Lemma compatible_threadRes_join: forall js m, mem_compatible js m -> forall i (cnti: containsThread js i) j (cntj: containsThread js j), @@ -1662,7 +1504,7 @@ Qed. simpl. unfold OrdinalPool.getThreadR. destruct H. destruct H as [JJ _ _ _ _]. - inv JJ. clear H1 H2. unfold join_threads in H. + inv JJ. clear - H0 H. unfold join_threads in H. unfold getThreadsR in H. assert (H1 :=mem_ord_enum (n:= n (num_threads js))). generalize (H1 (Ordinal (n:=n (num_threads js)) (m:=j) cntj)); intro. @@ -1746,6 +1588,7 @@ Qed. unfold OrdinalPool.getThreadR. destruct H. destruct H as [JJ _ _ _ _]. inv JJ. unfold join_locks, join_threads in H1. + clear - H H0 H1 H2. simpl in H0. apply AMap.find_2 in H0. unfold OrdinalPool.lockGuts in H0. apply AMap.elements_1 in H0. simpl in H1. @@ -1789,17 +1632,18 @@ Qed. apply IHel in H1; auto. apply join_sub_trans with x; auto. eexists; eauto. } - Qed. + Qed.*) Lemma compatible_lockRes_cohere: forall js m l phi, lockRes js l = Some (Some phi) -> mem_compatible js m -> - mem_cohere' m phi . + mem_cohere' m phi. Proof. intros. inversion H0 as [all_juice M]; inversion M. apply (compatible_lockRes_sub_all _ H ) in juice_join0. - apply (mem_cohere_sub all_cohere0) in juice_join0. + assert (✓ all_juice) as Hv by (by destruct M as [[]]). + apply (mem_cohere_sub Hv all_cohere0) in juice_join0. assumption. Qed. @@ -1811,134 +1655,11 @@ Qed. intros. inversion H as [all_juice M]; inversion M. eapply mem_cohere_sub. + - by destruct M as [[]]. - eassumption. - apply compatible_threadRes_sub. assumption. Qed. - (** *Lemmas about aging*) - Lemma cnt_age_iff {js i n} : - containsThread js i <-> - containsThread (age_tp_to n js) i. - Proof. - destruct js; split; auto. - Qed. - - Lemma gtc_age : forall js i n, - forall (cnt: containsThread js i) - (cnt': containsThread (age_tp_to n js) i), - getThreadC cnt = getThreadC cnt'. - Proof. - intros []. intros; simpl. - repeat f_equal; apply proof_irr. - Qed. - - Lemma getThreadR_age: forall js i age, - forall (cnt: containsThread js i) - (cnt': containsThread (age_tp_to age js) i), - age_to age (getThreadR cnt) = getThreadR cnt'. - Proof. - intros. unfold getThreadR; destruct js; simpl. - unfold containsThread in cnt, cnt'. - simpl in cnt, cnt'. - unfold "oo"; - do 3 f_equal. apply proof_irrelevance. - Qed. - - Lemma LockRes_age: forall js age a, - isSome (lockRes (age_tp_to age js) a) = isSome(lockRes js a). - Proof. - destruct js. - intros; simpl. unfold OrdinalPool.lockRes; simpl. - destruct (AMap.find (elt:=option rmap) a - (AMap.map (option_map (age_to age)) lset0)) eqn:AA; - destruct (AMap.find (elt:=option rmap) a lset0) eqn:BB; - try (reflexivity). - - apply AMap_find_map_inv in AA. destruct AA as [x [BB' rest]]. - rewrite BB' in BB; inversion BB. - - apply AMap_find_map with (f:=(option_map (age_to age))) in BB. - rewrite BB in AA; inversion AA. - Qed. - - Lemma LockRes_age_content1: forall js age a, - lockRes (age_tp_to age js) a = Some None -> - lockRes js a = Some None. - intros js age a. simpl; unfold OrdinalPool.lockRes; destruct js. - simpl. - intros AA. - apply AMap_find_map_inv in AA. destruct AA as [x [map rest]]. - rewrite map. f_equal. - destruct x; inversion rest; try reflexivity. - Qed. - - Lemma LockRes_age_content2: forall js age a rm, - lockRes (age_tp_to age js) a = Some (Some rm) -> - exists r, lockRes js a = Some (Some r) /\ rm = age_to age r. - Proof. - intros js age a rm. simpl; unfold OrdinalPool.lockRes; destruct js. - simpl. - intros AA. - apply AMap_find_map_inv in AA. destruct AA as [x [map rest]]. - destruct x; inversion rest. - exists r; rewrite map; auto. - Qed. - - Lemma access_cohere'_age m : hereditary age (access_cohere' m). - Proof. - intros x y E B. - intros addr. - destruct (age1_levelS _ _ E) as [n L]. - eapply (age_age_to n) in E; auto. - rewrite <-E. - rewrite perm_of_age. - apply B. - Qed. - - Lemma access_cohere'_unage m : hereditary unage (access_cohere' m). - Proof. - intros x y E B. - intros addr. - destruct (age1_levelS _ _ E) as [n L]. - eapply (age_age_to n) in E; auto. - rewrite <-E in B. - specialize (B addr). - rewrite perm_of_age in B. - apply B. - Qed. - - Lemma mem_cohere'_age m : hereditary age (mem_cohere' m). - Proof. - intros x y E. - intros [A B C]; constructor. - - eapply contents_cohere_age; eauto. - (* - eapply access_cohere'_age; eauto.*) - - eapply max_access_cohere_age; eauto. - - eapply alloc_cohere_age; eauto. - Qed. - - Lemma mem_cohere'_unage m : hereditary unage (mem_cohere' m). - Proof. - intros x y E. - intros [A B C]; constructor. - - eapply contents_cohere_unage; eauto. - - eapply max_access_cohere_unage; eauto. - - eapply alloc_cohere_unage; eauto. - Qed. - - Lemma mem_cohere_age_to n m phi : - mem_cohere' m phi -> - mem_cohere' m (age_to n phi). - Proof. - apply age_to_ind, mem_cohere'_age. - Qed. - - Lemma mem_cohere_age_to_opp n m phi : - mem_cohere' m (age_to n phi) -> - mem_cohere' m phi. - Proof. - apply age_by_ind_opp. - intros x y A. apply mem_cohere'_unage, A. - Qed. - End JuicyMachineLemmas. Definition install_perm {tp m tid} (Hcompat : mem_compatible tp m) (cnt : containsThread tp tid) := @@ -1958,4 +1679,3 @@ Qed. End JuicyMachineShell. End Concur. - diff --git a/concurrency/juicy/rmap_locking.v b/concurrency/juicy/rmap_locking.v index 2e3c959cd..0d09a0382 100644 --- a/concurrency/juicy/rmap_locking.v +++ b/concurrency/juicy/rmap_locking.v @@ -12,9 +12,8 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. Require Import VST.veric.shares. -Require Import VST.veric.compcert_rmaps. +Require Import VST.veric.shared. Require Import VST.veric.semax. Require Import VST.veric.semax_ext. Require Import VST.veric.SeparationLogic. @@ -28,7 +27,7 @@ Require Import VST.sepcomp.event_semantics. Require Import VST.veric.coqlib4. Require Import VST.floyd.type_induction. (*Require Import VST.concurrency.permjoin.*) -Require Import VST.concurrency.juicy.sync_preds_defs. +(*Require Import VST.concurrency.juicy.sync_preds_defs.*) Require Import VST.concurrency.juicy.semax_conc_pred. Require Import VST.concurrency.common.lksize. @@ -36,9 +35,9 @@ Require Import Setoid. Local Open Scope Z_scope. -Lemma data_at_unfolding CS sh b ofs phi : +(*Lemma data_at_unfolding CS sh b ofs phi : readable_share sh -> - app_pred (@data_at_ CS sh (Tarray (Tpointer Ctypes.Tvoid noattr) 4 noattr) (Vptr b ofs)) phi -> + app_pred (data_at_ sh (Tarray (Tpointer Ctypes.Tvoid noattr) 4 noattr) (Vptr b ofs)) phi -> forall loc, adr_range (b, Ptrofs.intval ofs) 8%Z loc -> exists p v, @@ -419,36 +418,29 @@ Proof. split; auto. split; auto. rewrite Z2Nat.id; lia. -Qed. +Qed.*) -Definition rmap_makelock phi phi' loc R length := - (level phi = level phi') /\ +Definition rmap_makelock phi phi' loc length := (forall x, ~ adr_range loc length x -> phi @ x = phi' @ x) /\ (forall x, adr_range loc length x -> - exists val sh Psh, - phi @ x = YES sh Psh (VAL val) NoneP /\ + exists val sh, + phi @ x = (DfracOwn (Share sh), Some (VAL val)) /\ writable0_share sh /\ - phi' @ x = - YES sh Psh (LK length (snd x - snd loc)) (pack_res_inv (approx (level phi) R))) - /\ (ghost_of phi = ghost_of phi'). + phi' @ x = (DfracOwn (Share sh), Some (LK length (snd x - snd loc)))). (* rmap_freelock phi phi' is ALMOST rmap_makelock phi' phi but we specify that the VAL will be the dry memory's *) -Definition rmap_freelock phi phi' m loc R length := - (level phi = level phi') /\ +Definition rmap_freelock phi phi' m loc length := (forall x, ~ adr_range loc length x -> phi @ x = phi' @ x) /\ (forall x, adr_range loc length x -> - exists sh Psh, - phi' @ x = YES sh Psh (VAL (contents_at m x)) NoneP /\ + exists sh, + phi' @ x = (DfracOwn (Share sh), Some (VAL (contents_at m x))) /\ writable0_share sh /\ - phi @ x = - - YES sh Psh (LK length (snd x - snd loc)) (pack_res_inv (approx (level phi) R))) /\ - (ghost_of phi = ghost_of phi'). + phi @ x = (DfracOwn (Share sh), Some (LK length (snd x - snd loc)))). -Definition makelock_f phi loc R length : address -> resource := +(*Definition makelock_f phi loc R length : address -> resource := fun x => if adr_range_dec loc length x then match phi @ x with @@ -1055,3 +1047,4 @@ Proof. Abort.*) End simpler_invariant_tentative. +*) \ No newline at end of file diff --git a/concurrency/juicy/semax_conc.v b/concurrency/juicy/semax_conc.v index 8322f992e..f4e042f69 100644 --- a/concurrency/juicy/semax_conc.v +++ b/concurrency/juicy/semax_conc.v @@ -1,91 +1,47 @@ -Require Import VST.msl.msl_standard. -Require Import VST.msl.seplog. -Require Import VST.veric.base. -Require Import VST.veric.compcert_rmaps. -Require Import VST.veric.juicy_mem. -Require Import VST.veric.juicy_mem_lemmas. -Require Import VST.veric.juicy_mem_ops. Require Import VST.veric.juicy_extspec. -Require Import VST.veric.tycontext. -Require Import VST.veric.expr2. -Require Import VST.veric.semax. -Require Import VST.veric.semax_call. -Require Import VST.veric.semax_ext. -Require Import VST.veric.juicy_safety. -Require Import VST.veric.Clight_core. -Require Import VST.veric.res_predicates. Require Import VST.veric.SeparationLogic. -Require Import VST.sepcomp.extspec. -Require Import VST.floyd.reptype_lemmas. -Require Import VST.floyd.field_at. -Require Import VST.floyd.nested_field_lemmas. -Require Import VST.floyd.client_lemmas. -Require Import VST.floyd.jmeq_lemmas. +Require Import compcert.cfrontend.Ctypes. +Require Import VST.veric.expr. Require Import VST.concurrency.common.lksize. Require Import VST.concurrency.juicy.semax_conc_pred. -Require Import VST.concurrency.conclib. +Require Import VST.floyd.client_lemmas. +Require Import VST.floyd.field_at. +(*Require Import VST.concurrency.conclib.*) Import Clightdefs. Import String. -(*(* Variables to be instantiated once the program is known. *) -Definition _f := 1%positive. (* alpha-convertible *) -Definition _args := 2%positive. (* alpha-convertible *) -Definition _lock := 1%positive. (* alpha-convertible *) -Definition _cond := 2%positive. (* alpha-convertible *) -(*Definition _lock_t := 2%positive. (* 2 (* or sometimes 3 -WM *) is the number given by -clightgen when threads.h is included first *)*) -*) - Definition voidstar_funtype := Tfunction (Tcons (tptr tvoid) Tnil) (tptr tvoid) cc_default. (* Definition tlock := Tstruct _lock_t noattr. *) Definition tlock := (Tarray (Tpointer Ctypes.Tvoid noattr) 2 noattr). -(* Notation tlock := tuint (only parsing). *) Goal forall (cenv: compspecs), @sizeof cenv tlock = LKSIZE. Proof. reflexivity. Qed. -Definition selflock_fun Q sh p : (unit -> mpred) -> (unit -> mpred) := - fun R _ => (Q * |>lock_inv sh p (R tt))%logic. +Section mpred. -Definition selflock' Q sh p : unit -> mpred := HORec (selflock_fun Q sh p). -Definition selflock Q sh p : mpred := selflock' Q sh p tt. +Context `{!VSTGS ty_OK Σ}. -Lemma HOnonexpansive_nonexpansive: forall F: mpred -> mpred, nonexpansive F <-> HOnonexpansive (fun P (_ : unit) => F (P tt)). -Proof. - intros. - split; intros; hnf in H |- *. - + intros P Q. - specialize (H (P tt) (Q tt)). - rewrite !allp_unit. - constructor; auto. - + intros P Q. - specialize (H (fun x => P) (fun x => Q)). - rewrite !allp_unit in H. - destruct H; auto. -Qed. +Definition selflock_fun Q sh p : mpred -> mpred := + fun R => (Q ∗ ▷lock_inv sh p R). -Lemma selflock'_eq Q sh p : selflock' Q sh p = - selflock_fun Q sh p (selflock' Q sh p). +#[export] Instance selflock_contractive Q sh p : Contractive (selflock_fun Q sh p). Proof. - apply HORec_fold_unfold, prove_HOcontractive'. - intros P1 P2 u. - apply subp_sepcon; [ apply subp_refl | ]. - apply allp_left with tt. - eapply derives_trans, subp_later1. - apply later_derives. - constructor. - eapply predicates_hered.derives_trans, eqp_subp. - apply nonexpansive_lock_inv. + intros ????. + rewrite /selflock_fun. + f_equiv. (* f_contractive. *) apply later_contractive. + destruct n; first apply dist_later_0. + rewrite -!dist_later_S in H |- *. + f_equiv. done. Qed. -Lemma selflock_eq Q sh p : selflock Q sh p = (Q * |>lock_inv sh p (selflock Q sh p))%logic. +Definition selflock Q sh p : mpred := fixpoint (selflock_fun Q sh p). + +Lemma selflock_eq Q sh p : selflock Q sh p ⊣⊢ (Q ∗ ▷lock_inv sh p (selflock Q sh p)). Proof. - unfold selflock at 1. - rewrite selflock'_eq. - reflexivity. + rewrite {1}/selflock fixpoint_unfold //. Qed. -(* In fact we need locks to two resources: +(*(* In fact we need locks to two resources: 1) the resource invariant, for passing the resources 2) the join resource invariant, for returning all resources, including itself for this we need to define them in a mutually recursive fashion: *) @@ -93,9 +49,9 @@ Qed. Definition res_invariants_fun Q sh1 p1 sh2 p2 : (bool -> mpred) -> (bool -> mpred) := fun R b => if b then - (Q * lock_inv sh2 p2 (|> R false))%logic + (Q * lock_inv sh2 p2 (▷ R false)) else - (Q * lock_inv sh1 p1 (|> R true) * lock_inv sh2 p2 (|> R false))%logic. + (Q * lock_inv sh1 p1 (▷ R true) * lock_inv sh2 p2 (▷ R false)). Definition res_invariants Q sh1 p1 sh2 p2 : bool -> mpred := HORec (res_invariants_fun Q sh1 p1 sh2 p2). Definition res_invariant Q sh1 p1 sh2 p2 : mpred := res_invariants Q sh1 p1 sh2 p2 true. @@ -130,7 +86,7 @@ Qed. Lemma res_invariant_eq Q sh1 p1 sh2 p2 : res_invariant Q sh1 p1 sh2 p2 = (Q * - lock_inv sh2 p2 (|> join_res_invariant Q sh1 p1 sh2 p2))%logic. + lock_inv sh2 p2 (▷ join_res_invariant Q sh1 p1 sh2 p2)). Proof. unfold res_invariant at 1. rewrite res_invariants_eq. @@ -140,50 +96,24 @@ Qed. Lemma join_res_invariant_eq Q sh1 p1 sh2 p2 : join_res_invariant Q sh1 p1 sh2 p2 = (Q * - lock_inv sh1 p1 (|> res_invariant Q sh1 p1 sh2 p2) * - lock_inv sh2 p2 (|> join_res_invariant Q sh1 p1 sh2 p2))%logic. + lock_inv sh1 p1 (▷ res_invariant Q sh1 p1 sh2 p2) * + lock_inv sh2 p2 (▷ join_res_invariant Q sh1 p1 sh2 p2)). Proof. unfold join_res_invariant at 1. rewrite res_invariants_eq. reflexivity. -Qed. +Qed.*) (*+ Specification of each concurrent primitive *) -Lemma nonexpansive2_super_non_expansive: forall (F: mpred -> mpred -> mpred), - (forall P, nonexpansive (fun Q => F P Q)) -> - (forall Q, nonexpansive (fun P => F P Q)) -> - forall P Q n, - approx n (F P Q) = approx n (F (approx n P) (approx n Q)). -Proof. - intros. - apply semax_conc.approx_eq_i'. - intros m ?. - pose proof semax_conc.nonexpansive_entail _ (H P) Q (approx n Q) as H2; cbv beta in H2. - destruct H2 as [H2]; specialize (H2 m). spec H2; [apply (semax_conc.fash_equiv_approx n Q m); auto |]. - pose proof semax_conc.nonexpansive_entail _ (H0 (approx n Q)) P (approx n P) as H3; cbv beta in H3. - destruct H3 as [H3]; specialize (H3 m). spec H3; [apply (semax_conc.fash_equiv_approx n P m); auto |]. - remember (F P Q) as X1. - remember (F P (approx n Q)) as X2. - remember (F (approx n P) (approx n Q)) as X3. - clear - H2 H3. - change ((X1 <=> X2)%pred m) in H2. - change ((X2 <=> X3)%pred m) in H3. - intros y H; specialize (H2 y H); specialize (H3 y H). - destruct H2 as [H2A H2B], H3 as [H3A H3B]. - split; intros z H0. - + specialize (H2A z H0); specialize (H3A z H0); auto. - + specialize (H2B z H0); specialize (H3B z H0); auto. -Qed. +Definition acquire_arg_type: TypeTree := ProdType (ConstType (val * share)) Mpred. -(* -Lemma nonexpansive_2super_non_expansive: forall {A B: Type} (F: (A -> B -> mpred) -> mpred), - (forall a b, nonexpansive (fun Q => F P Q)) -> - (forall Q, nonexpansive (fun P => F P Q)) -> - forall P Q n, - approx n (F P Q) = approx n (F (approx n P) (approx n Q)). -*) -Definition acquire_arg_type: rmaps.TypeTree := rmaps.ProdType (rmaps.ConstType (val * share)) rmaps.Mpred. +(* up *) +#[export] Instance monPred_at_ne : NonExpansive (@monPred_at environ_index mpred : _ -> _ -d> _). +Proof. solve_proper. Qed. + +#[export] Instance monPred_at_args_ne : NonExpansive (@monPred_at argsEnviron_index mpred : _ -> _ -d> _). +Proof. solve_proper. Qed. Program Definition acquire_spec := TYPE acquire_arg_type WITH v : _, sh : _, R : _ @@ -197,306 +127,130 @@ Program Definition acquire_spec := SEP (lock_inv sh v R; R). Next Obligation. Proof. - hnf. - intros. - destruct x as [[v sh] R]; simpl in *. - apply (semax_conc.nonexpansive_super_non_expansive - (fun R => (PROP (readable_share sh) PARAMS (v) SEP (lock_inv sh v R)) gargs)). - apply (PROP_PARAMS_GLOBALS_SEP_nonexpansive - ((fun _ => readable_share sh) :: nil) - (v :: nil) - nil - ((fun R => lock_inv sh v R) :: nil)); - repeat apply Forall_cons; try apply Forall_nil. - + apply const_nonexpansive. - + apply nonexpansive_lock_inv. + intros ? ((v, sh), R) ((?, ?), ?) ([=] & HR); simpl in *; subst. + rewrite HR //. Qed. Next Obligation. Proof. - hnf. - intros. - destruct x as [[v sh] R]; simpl in *. - apply (semax_conc.nonexpansive_super_non_expansive - (fun R => (PROP () LOCAL () SEP (lock_inv sh v R; R)) rho)). - apply (PROP_LOCAL_SEP_nonexpansive - nil - nil - ((fun R => lock_inv sh v R) :: (fun R => R) :: nil)); - repeat apply Forall_cons; try apply Forall_nil. - + apply nonexpansive_lock_inv. - + apply identity_nonexpansive. + intros ? ((v, sh), R) ((?, ?), ?) ([=] & HR); simpl in *; subst. + rewrite HR //. Qed. -Definition release_arg_type: rmaps.TypeTree := rmaps.ProdType (rmaps.ConstType (val * share)) rmaps.Mpred. +Definition release_arg_type: TypeTree := ProdType (ConstType (val * share)) Mpred. Program Definition release_spec := TYPE release_arg_type WITH v : _, sh : _, R : _ PRE [ tptr tvoid ] PROP (readable_share sh) PARAMS (v) - SEP (weak_exclusive_mpred R && emp; lock_inv sh v R; R) + SEP ( exclusive_mpred R; lock_inv sh v R; R) POST [ tvoid ] PROP () LOCAL () SEP (lock_inv sh v R). Next Obligation. Proof. - hnf. - intros. - destruct x as [[v sh] R]; simpl in *. - apply (nonexpansive_super_non_expansive - (fun R => (PROP (readable_share sh) PARAMS (v) SEP (weak_exclusive_mpred R && emp; lock_inv sh v R; R)) gargs)). - apply (PROP_PARAMS_GLOBALS_SEP_nonexpansive - ((fun _ => readable_share sh) :: nil) - (v :: nil) - nil - ((fun R => weak_exclusive_mpred R && emp)%logic :: (fun R => lock_inv sh v R) :: (fun R => R) :: nil)); - repeat apply Forall_cons; try apply Forall_nil. - + apply const_nonexpansive. - + apply (conj_nonexpansive (fun R => weak_exclusive_mpred R)%logic). - - apply exclusive_mpred_nonexpansive. - - apply const_nonexpansive. - + apply nonexpansive_lock_inv. - + apply identity_nonexpansive. + intros ? ((v, sh), R) ((?, ?), ?) ([=] & HR); simpl in *; subst. + rewrite /exclusive_mpred HR //. Qed. Next Obligation. Proof. - hnf. - intros. - destruct x as [[v sh] R]; simpl in *. - apply (nonexpansive_super_non_expansive - (fun R => (PROP () LOCAL () SEP (lock_inv sh v R)) rho)). - apply (PROP_LOCAL_SEP_nonexpansive - nil - nil - ((fun R => lock_inv sh v R) :: nil)); - repeat apply Forall_cons; try apply Forall_nil. - apply nonexpansive_lock_inv. + intros ? ((v, sh), R) ((?, ?), ?) ([=] & HR); simpl in *; subst. + rewrite /exclusive_mpred HR //. Qed. -Program Definition makelock_spec cs: funspec := mk_funspec - (tptr tvoid :: nil, tvoid) - cc_default - (rmaps.ProdType (rmaps.ConstType (val * share)) rmaps.Mpred) - (fun _ x => - match x with - | (v, sh, R) => - PROP (writable_share sh) - PARAMS (v) - SEP (@data_at_ cs sh tlock v) - end) - (fun _ x => - match x with - | (v, sh, R) => - PROP () - LOCAL () - SEP (lock_inv sh v R) - end) - _ - _ -. +Program Definition makelock_spec (cs : compspecs) : funspec := + TYPE ProdType (ConstType (val * share)) Mpred WITH v : _, sh : _, R : _ + PRE [ tptr tvoid ] + PROP (writable_share sh) + PARAMS (v) + SEP (data_at_ sh tlock v) + POST [ tvoid ] + PROP () + LOCAL () + SEP (lock_inv sh v R). Next Obligation. - hnf. - intros. - destruct x as [[v sh] R]; simpl in *. - auto. +Proof. + intros ?? ((v, sh), R) ((?, ?), ?) ([=] & HR); simpl in *; subst. + reflexivity. Qed. Next Obligation. - hnf. - intros. - destruct x as [[v sh] R]; simpl in *. - apply (nonexpansive_super_non_expansive - (fun R => (PROP () LOCAL () SEP (lock_inv sh v R)) rho)). - apply (PROP_LOCAL_SEP_nonexpansive - nil - nil - ((fun R => lock_inv sh v R) :: nil)); - repeat apply Forall_cons; try apply Forall_nil. - apply nonexpansive_lock_inv. + intros ?? ((v, sh), R) ((?, ?), ?) ([=] & HR); simpl in *; subst. + rewrite HR //. Qed. -Program Definition freelock_spec cs: funspec := mk_funspec - (tptr tvoid :: nil, tvoid) - cc_default - (rmaps.ProdType (rmaps.ConstType (val * share)) rmaps.Mpred) - (fun _ x => - match x with - | (v, sh, R) => - PROP (writable_share sh) - PARAMS (v) - SEP (weak_exclusive_mpred R && emp; lock_inv sh v R; R) - end) - (fun _ x => - match x with - | (v, sh, R) => - PROP () - LOCAL () - SEP (@data_at_ cs sh tlock v; R) - end) - _ - _ -. -Next Obligation. - hnf. - intros. - destruct x as [[v sh] R]; simpl in *. - apply (nonexpansive_super_non_expansive - (fun R => (PROP (writable_share sh) +Program Definition freelock_spec (cs : compspecs) : funspec := + TYPE ProdType (ConstType (val * share)) Mpred WITH v : _, sh : _, R : _ + PRE [ tptr tvoid ] + PROP (writable_share sh) PARAMS (v) - SEP (weak_exclusive_mpred R && emp; lock_inv sh v R; R)) gargs)). - apply (PROP_PARAMS_GLOBALS_SEP_nonexpansive - ((fun _ => writable_share sh) :: nil) - (v :: nil) nil - ((fun R => weak_exclusive_mpred R && emp)%logic :: (fun R => lock_inv sh v R) :: (fun R => R) :: nil)); - repeat apply Forall_cons; try apply Forall_nil. - + apply const_nonexpansive. - + apply (conj_nonexpansive weak_exclusive_mpred). - - apply exclusive_mpred_nonexpansive. - - apply const_nonexpansive. - + apply nonexpansive_lock_inv. - + apply identity_nonexpansive. + SEP (exclusive_mpred R; lock_inv sh v R; R) + POST [ tvoid ] + PROP () + LOCAL () + SEP (data_at_ sh tlock v; R). +Next Obligation. +Proof. + intros ?? ((v, sh), R) ((?, ?), ?) ([=] & HR); simpl in *; subst. + rewrite /exclusive_mpred HR //. Qed. Next Obligation. - hnf. - intros. - destruct x as [[v sh] R]; simpl in *. - apply (nonexpansive_super_non_expansive - (fun R => (PROP () LOCAL () SEP (data_at_ sh tlock v; R)) rho)). - apply (PROP_LOCAL_SEP_nonexpansive - nil - nil - ((fun _ => data_at_ sh tlock v) :: (fun R => R) :: nil)); - repeat apply Forall_cons; try apply Forall_nil. - + apply const_nonexpansive. - + apply identity_nonexpansive. +Proof. + intros ?? ((v, sh), R) ((?, ?), ?) ([=] & HR); simpl in *; subst. + rewrite HR //. Qed. (* versions that give away all their resources *) -Lemma selflock_rec : forall sh v R, rec_inv sh v R (selflock R sh v). +Lemma selflock_rec : forall sh v R, ⊢rec_inv sh v R (selflock R sh v). Proof. intros; unfold rec_inv. - apply selflock_eq. + rewrite {1} selflock_eq. + apply bi.wand_iff_refl. Qed. -Program Definition freelock2_spec cs: funspec := mk_funspec - (tptr tvoid :: nil, tvoid) - cc_default - (rmaps.ProdType (rmaps.ProdType (rmaps.ConstType (val * share * share)) rmaps.Mpred) rmaps.Mpred) - (fun _ x => - match x with - | (v, sh, sh', Q, R) => - PROP (writable_share sh) - PARAMS (v) - SEP (weak_exclusive_mpred R && weak_rec_inv sh' v Q R && emp; lock_inv sh v R) - end) - (fun _ x => - match x with - | (v, sh, sh', Q, R) => - PROP () - LOCAL () - SEP (@data_at_ cs sh tlock v) - end) - _ - _ -. +Program Definition freelock2_spec (cs : compspecs) : funspec := + TYPE ProdType (ProdType (ConstType (val * share * share)) Mpred) Mpred + WITH v : _, sh : _, sh' : _, Q : _, R : _ + PRE [ tptr tvoid ] + PROP (writable_share sh) + PARAMS (v) + SEP (exclusive_mpred R; rec_inv sh' v Q R; lock_inv sh v R) + POST [ tvoid ] + PROP () + LOCAL () + SEP (data_at_ sh tlock v). Next Obligation. - hnf. - intros. - destruct x as [[[[v sh] sh'] Q] R]; simpl in *. - apply (nonexpansive2_super_non_expansive - (fun Q R => (PROP (writable_share sh) - PARAMS (v) - SEP (weak_exclusive_mpred R && weak_rec_inv sh' v Q R && emp; lock_inv sh v R)) gargs)); - [ clear Q R; intros Q; - apply (PROP_PARAMS_GLOBALS_SEP_nonexpansive - ((fun _ => writable_share sh) :: nil) - (v :: nil) nil - ((fun R => weak_exclusive_mpred R && weak_rec_inv sh' v Q R && emp)%logic :: (fun R => lock_inv sh v R) :: nil)) - | clear Q R; intros R; - apply (PROP_PARAMS_GLOBALS_SEP_nonexpansive - ((fun _ => writable_share sh) :: nil) - (v :: nil) nil - ((fun Q => weak_exclusive_mpred R && weak_rec_inv sh' v Q R && emp)%logic :: (fun _ => lock_inv sh v R) :: nil))]; - repeat apply Forall_cons; try apply Forall_nil. - + apply const_nonexpansive. - + apply (conj_nonexpansive (fun R => weak_exclusive_mpred R && weak_rec_inv sh' v Q R)%logic); [apply (conj_nonexpansive weak_exclusive_mpred) |]. - - apply exclusive_mpred_nonexpansive. - - apply rec_inv1_nonexpansive. - - apply const_nonexpansive. - + apply nonexpansive_lock_inv. - + apply const_nonexpansive. - + apply (conj_nonexpansive (fun Q => weak_exclusive_mpred R && weak_rec_inv sh' v Q R)%logic); [apply (conj_nonexpansive (fun _ => weak_exclusive_mpred R)) |]. - - apply const_nonexpansive. - - apply rec_inv2_nonexpansive. - - apply const_nonexpansive. - + apply const_nonexpansive. +Proof. + intros ?? ((((v, sh), sh'), Q), R) ((((?, ?), ?), ?), ?) (([=] & HQ) & HR); simpl in *; subst. + rewrite /exclusive_mpred /rec_inv HQ HR //. Qed. Next Obligation. - hnf. - intros. - destruct x as [[[[v sh] sh'] Q] R]; simpl in *. - auto. +Proof. + intros ?? ((((v, sh), sh'), Q), R) ((((?, ?), ?), ?), ?) (([=] & HQ) & HR); simpl in *; subst. + reflexivity. Qed. -Program Definition release2_spec: funspec := mk_funspec - (tptr tvoid :: nil, tvoid) - cc_default - (rmaps.ProdType (rmaps.ProdType (rmaps.ConstType (val * share)) rmaps.Mpred) rmaps.Mpred) - (fun _ x => - match x with - | (v, sh, Q, R) => - PROP (readable_share sh) - PARAMS (v) - SEP (weak_exclusive_mpred R && weak_rec_inv sh v Q R && emp; R) - end) - (fun _ x => - match x with - | (v, sh, Q, R) => - PROP () - LOCAL () - SEP (emp) - end) - _ - _ -. +Program Definition release2_spec: funspec := + TYPE ProdType (ProdType (ConstType (val * share)) Mpred) Mpred + WITH v : _, sh : _, Q : _, R : _ + PRE [ tptr tvoid ] + PROP (readable_share sh) + PARAMS (v) + SEP (exclusive_mpred R; rec_inv sh v Q R; R) + POST [ tvoid ] + PROP () + LOCAL () + SEP (). Next Obligation. - hnf. - intros. - destruct x as [[[v sh] Q] R]; simpl in *. - apply (nonexpansive2_super_non_expansive - (fun Q R => (PROP (readable_share sh) - PARAMS (v) - SEP (weak_exclusive_mpred R && weak_rec_inv sh v Q R && emp; R)) gargs)); - [ clear Q R; intros Q; - apply (PROP_PARAMS_GLOBALS_SEP_nonexpansive - ((fun _ => readable_share sh) :: nil) - (v :: nil) nil - ((fun R => weak_exclusive_mpred R && weak_rec_inv sh v Q R && emp)%logic :: (fun R => R) :: nil)) - | clear Q R; intros R; - apply (PROP_PARAMS_GLOBALS_SEP_nonexpansive - ((fun _ => readable_share sh) :: nil) - (v :: nil) nil - ((fun Q => weak_exclusive_mpred R && weak_rec_inv sh v Q R && emp)%logic :: (fun _ => R) :: nil))]; - repeat apply Forall_cons; try apply Forall_nil. - + apply const_nonexpansive. - + apply (conj_nonexpansive (fun R => weak_exclusive_mpred R && weak_rec_inv sh v Q R)%logic); [apply (conj_nonexpansive (fun R => weak_exclusive_mpred R)%logic) |]. - - apply exclusive_mpred_nonexpansive. - - apply rec_inv1_nonexpansive. - - apply const_nonexpansive. - + apply identity_nonexpansive. - + apply const_nonexpansive. - + apply (conj_nonexpansive (fun Q => weak_exclusive_mpred R && weak_rec_inv sh v Q R)%logic); [apply (conj_nonexpansive (fun Q => weak_exclusive_mpred R)%logic) |]. - - apply const_nonexpansive. - - apply rec_inv2_nonexpansive. - - apply const_nonexpansive. - + apply const_nonexpansive. +Proof. + intros ? (((v, sh), Q), R) (((?, ?), ?), ?) (([=] & HQ) & HR); simpl in *; subst. + rewrite /exclusive_mpred /rec_inv HQ HR //. Qed. Next Obligation. - hnf. - intros. - destruct x as [[[v sh] Q] R]; simpl in *. - auto. +Proof. + intros ? (((v, sh), Q), R) (((?, ?), ?), ?) (([=] & HQ) & HR); simpl in *; subst. + reflexivity. Qed. (* @@ -526,7 +280,7 @@ Definition freecond_spec cs := Program Definition wait_spec cs: funspec := mk_funspec ((_cond OF tptr tcond)%formals :: (_lock OF tptr Tvoid)%formals :: nil, tvoid) cc_default - (rmaps.ProdType (rmaps.ConstType (val * val * share * share)) rmaps.Mpred) + (ProdType (ConstType (val * val * share * share)) Mpred) (fun _ x => match x with | (c, l, shc, shl, R) => @@ -583,7 +337,7 @@ Qed. Program Definition wait2_spec cs: funspec := mk_funspec ((_cond OF tptr tcond)%formals :: (_lock OF tptr Tvoid)%formals :: nil, tvoid) cc_default - (rmaps.ProdType (rmaps.ConstType (val * val * share * share)) rmaps.Mpred) + (ProdType (ConstType (val * val * share * share)) Mpred) (fun _ x => match x with | (c, l, shc, shl, R) => @@ -612,11 +366,11 @@ Next Obligation. apply (PROP_LOCAL_SEP_nonexpansive ((fun _ => readable_share shc) :: nil) (temp _cond c :: temp _lock l :: nil) - ((fun R => lock_inv shl l R) :: (fun R => R && (@cond_var cs shc c * TT))%logic :: nil)); + ((fun R => lock_inv shl l R) :: (fun R => R && (@cond_var cs shc c * TT)) :: nil)); repeat apply Forall_cons; try apply Forall_nil. + apply const_nonexpansive. + apply nonexpansive_lock_inv. - + apply (conj_nonexpansive (fun R => R) (fun _ => (cond_var shc c * TT)%logic)). + + apply (conj_nonexpansive (fun R => R) (fun _ => (cond_var shc c * TT))). - apply identity_nonexpansive. - apply const_nonexpansive. Qed. @@ -672,112 +426,82 @@ using the oracle, as [acquire] is. The postcondition would be [match PrePost with existT ty (w, pre, post) => thread th (post w b) end] *) -Local Open Scope logic. - (* @Qinxiang: it would be great to complete the annotation *) -(*Definition spawn_arg_type := rmaps.ProdType (rmaps.ProdType (rmaps.ProdType (rmaps.ConstType (val * val)) - (rmaps.ArrowType (rmaps.DependentType 0) (rmaps.ConstType globals))) (rmaps.DependentType 0)) - (rmaps.ArrowType (rmaps.DependentType 0) (rmaps.ArrowType (rmaps.ConstType val) rmaps.Mpred)). - -Definition spawn_pre := - (fun (ts: list Type) (x: val * val * (nth 0 ts unit -> globals) * nth 0 ts unit * - (nth 0 ts unit -> val -> mpred)) => - match x with - | (f, b, gv, w, pre) => - PROP (tc_val (tptr Tvoid) b) - PARAMS (f, b) - GLOBALS :: temp _args b :: gvars (gv w) :: nil - (SEP ( - EX _y : ident, - (func_ptr' - (WITH y : val, x : nth 0 ts unit - PRE [ _y OF tptr tvoid ] +Definition spawn_arg_type := ProdType (ConstType (val * val)) (SigType Type (fun A => ProdType (ProdType + (ArrowType (ConstType A) (ConstType globals)) (ConstType A)) + (ArrowType (ConstType A) (ArrowType (ConstType val) Mpred)))). + +Program Definition spawn_spec := + TYPE spawn_arg_type WITH f : _, b : _, fs : _ + PRE [ tptr voidstar_funtype, tptr tvoid ] + PROP (tc_val (tptr Tvoid) b) + PARAMS (f; b) + GLOBALS (let 'existT _ ((gv, w), _) := fs in gv w) + SEP (let 'existT _ ((gv, w), pre) := fs in + (func_ptr ⊤ + (WITH y : val, x : _ + PRE [ tptr tvoid ] PROP () - (LOCALx (temp _y y :: gvars (gv x) :: nil) - (SEP (pre x y))) - POST [tptr tvoid] + PARAMS (y) + GLOBALS (gv w) + SEP (pre x y) + POST [ tptr tvoid ] PROP () LOCAL () SEP ()) f); - valid_pointer b && pre w b))) (* Do we need the valid_pointer here? *) - end). - -Definition spawn_post := - (fun (ts: list Type) (x: val * val * (nth 0 ts unit -> globals) * nth 0 ts unit * - (nth 0 ts unit -> val -> mpred)) => - match x with - | (f, b, w, pre) => - PROP () - LOCAL () - SEP () - end). - -Lemma approx_idem : forall n P, compcert_rmaps.R.approx n (compcert_rmaps.R.approx n P) = - compcert_rmaps.R.approx n P. -Proof. - intros. - transitivity (base.compose (compcert_rmaps.R.approx n) (compcert_rmaps.R.approx n) P); auto. - rewrite compcert_rmaps.RML.approx_oo_approx; auto. -Qed. - -Lemma spawn_pre_nonexpansive: @super_non_expansive spawn_arg_type spawn_pre. + let 'existT _ ((gv, w), pre) := fs in valid_pointer b ∧ pre w b) (* Do we need the valid_pointer here? *) + POST [ tvoid ] + PROP () + LOCAL () + SEP (). +Next Obligation. Proof. - repeat intro. - destruct x as ((((?, ?), ?), ?), ?); simpl. - unfold PROPx; simpl; rewrite !approx_andp; f_equal. - unfold LOCALx; simpl; rewrite !approx_andp; f_equal. - unfold SEPx; simpl; rewrite !sepcon_emp, !approx_sepcon, !approx_andp, ?approx_idem; f_equal. - rewrite !approx_exp; apply f_equal; extensionality y. - rewrite approx_func_ptr'. - setoid_rewrite approx_func_ptr' at 2. - do 3 f_equal. - extensionality a rho'; destruct a. - rewrite !approx_andp, !approx_sepcon, approx_idem; auto. + intros ? ((f, b), (?, ((gv, w), pre))) ((?, ?), (?, ((?, ?), ?))) ([=] & ? & Hfs); simpl in *; subst; simpl in *. + destruct Hfs as ((Hgv & [=]) & Hpre); simpl in *; subst. + rewrite Hgv. + do 5 f_equiv. + constructor; last constructor; last done. + - apply func_ptr_si_nonexpansive; last done. + split3; [done..|]. + exists eq_refl; simpl. + split; intros (?, ?); simpl; last done. + rewrite (Hpre _ _) //. + - rewrite (Hpre _ _) //. Qed. - -Lemma spawn_post_nonexpansive: @super_non_expansive spawn_arg_type spawn_post. +Next Obligation. Proof. - hnf; intros. - destruct x as [[[]] pre]; auto. + intros ? ((f, b), ?) ((?, ?), ?) ?. + reflexivity. Qed. -Definition spawn_spec := mk_funspec - ((_f OF tptr voidstar_funtype)%formals :: (_args OF tptr tvoid)%formals :: nil, tvoid) - cc_default - spawn_arg_type - spawn_pre - spawn_post - spawn_pre_nonexpansive - spawn_post_nonexpansive.*) (*+ Adding the specifications to a void ext_spec *) +Context (Z : Type) `{!externalGS Z Σ}. + Definition concurrent_simple_specs (cs : compspecs) (ext_link : string -> ident) := (ext_link "acquire"%string, acquire_spec) :: (ext_link "release"%string, release_spec) :: nil. -Definition concurrent_simple_ext_spec Z (cs : compspecs) (ext_link : string -> ident) := - add_funspecs_rec +Definition concurrent_simple_ext_spec (cs : compspecs) (ext_link : string -> ident) := + add_funspecs_rec Z ext_link - (ok_void_spec Z).(@OK_ty) - (ok_void_spec Z).(@OK_spec) + (ok_void_spec Z).(OK_spec) (concurrent_simple_specs cs ext_link). -Definition Concurrent_Simple_Espec Z cs ext_link := +Definition Concurrent_Simple_Espec cs ext_link := Build_OracleKind Z - (concurrent_simple_ext_spec Z cs ext_link). + (concurrent_simple_ext_spec cs ext_link). Lemma strong_nat_ind (P : nat -> Prop) (IH : forall n, (forall i, lt i n -> P i) -> P n) n : P n. Proof. apply IH; induction n; intros i li; inversion li; eauto. Qed. -Set Printing Implicit. - Definition concurrent_specs (cs : compspecs) (ext_link : string -> ident) := (ext_link "acquire"%string, acquire_spec) :: (ext_link "release"%string, release_spec) :: @@ -786,14 +510,15 @@ Definition concurrent_specs (cs : compspecs) (ext_link : string -> ident) := (ext_link "spawn"%string, spawn_spec) :: nil. -Definition concurrent_ext_spec Z (cs : compspecs) (ext_link : string -> ident) := - add_funspecs_rec +Definition concurrent_ext_spec (cs : compspecs) (ext_link : string -> ident) := + add_funspecs_rec Z ext_link - (ok_void_spec Z).(@OK_ty) - (ok_void_spec Z).(@OK_spec) + (ok_void_spec Z).(OK_spec) (concurrent_specs cs ext_link). -Definition Concurrent_Espec Z cs ext_link := +Definition Concurrent_Espec cs ext_link := Build_OracleKind Z - (concurrent_ext_spec Z cs ext_link). + (concurrent_ext_spec cs ext_link). + +End mpred. diff --git a/concurrency/juicy/semax_conc_pred.v b/concurrency/juicy/semax_conc_pred.v index 0e2db8d03..9556c2adf 100644 --- a/concurrency/juicy/semax_conc_pred.v +++ b/concurrency/juicy/semax_conc_pred.v @@ -1,207 +1,33 @@ -Require Import VST.msl.msl_standard. -Require Import VST.msl.seplog. -Require Import VST.veric.base. -Require Import VST.veric.compcert_rmaps. -Require Import VST.veric.juicy_mem. -Require Import VST.veric.juicy_mem_lemmas. -Require Import VST.veric.juicy_mem_ops. -Require Import VST.veric.juicy_extspec. -Require Import VST.veric.tycontext. -Require Import VST.veric.expr2. -Require Import VST.veric.semax. -Require Import VST.veric.semax_call. -Require Import VST.veric.semax_ext. -Require Import VST.veric.semax_ext_oracle. -Require Import VST.veric.juicy_safety. -Require Import VST.veric.Clight_core. -Require Import VST.veric.res_predicates. Require Import VST.veric.SeparationLogic. -Require Import VST.sepcomp.extspec. -Require Import VST.floyd.reptype_lemmas. -Require Import VST.floyd.field_at. -Require Import VST.floyd.nested_field_lemmas. -Require Import VST.floyd.client_lemmas. -Require Import VST.floyd.jmeq_lemmas. Require Import VST.concurrency.common.lksize. -Require Import VST.concurrency.conclib. -Definition lock_inv : share -> val -> mpred -> mpred := - fun sh v R => - (EX b : block, EX ofs : _, - !!(v = Vptr b ofs) && - LKspec LKSIZE - R sh (b, Ptrofs.unsigned ofs))%logic. - -Definition rec_inv sh v (Q R: mpred): Prop := - (R = Q * |>lock_inv sh v R)%logic. +Section mpred. -Definition weak_rec_inv sh v (Q R: mpred): mpred := - (! (R <=> Q * |>lock_inv sh v R))%pred. - -Lemma lockinv_isptr sh v R : lock_inv sh v R = (!! isptr v && lock_inv sh v R)%logic. -Proof. - assert (D : isptr v \/ ~isptr v) by (destruct v; simpl; auto). - destruct D. - - rewrite prop_true_andp; auto. - - rewrite prop_false_andp; auto. - apply pred_ext. - + unfold lock_inv. Transparent mpred. Intros b ofs. Opaque mpred. subst; simpl in *; tauto. - + apply FF_left. -Qed. +Context `{heapGS Σ}. -Lemma unfash_fash_equiv: forall P Q: mpred, - (P <=> Q |-- - (subtypes.unfash (subtypes.fash P): mpred) <=> (subtypes.unfash (subtypes.fash Q): mpred))%pred. -Proof. - intros. - constructor; apply eqp_unfash. - rewrite eqp_nat. - apply predicates_hered.andp_right; eapply predicates_hered.derives_trans, subtypes.fash_K; - apply subtypes.fash_derives. - - apply predicates_hered.andp_left1; auto. - - apply predicates_hered.andp_left2; auto. -Qed. +Definition exclusive_mpred R : mpred := ((R ∗ R) -∗ False)%I. -Lemma iffp_equiv: forall P1 Q1 P2 Q2: mpred, - ((P1 <=> Q1) && (P2 <=> Q2) |-- (P1 <--> P2) <=> (Q1 <--> Q2))%pred. -Proof. - intros. - constructor; apply eqp_andp; apply subp_eqp; apply subtypes.subp_imp. - - apply predicates_hered.andp_left1. - rewrite eqp_comm; apply eqp_subp. - - apply predicates_hered.andp_left2. - apply eqp_subp. - - apply predicates_hered.andp_left1. - apply eqp_subp. - - apply predicates_hered.andp_left2. - rewrite eqp_comm; apply eqp_subp. - - apply predicates_hered.andp_left2. - rewrite eqp_comm; apply eqp_subp. - - apply predicates_hered.andp_left1. - apply eqp_subp. - - apply predicates_hered.andp_left2. - apply eqp_subp. - - apply predicates_hered.andp_left1. - rewrite eqp_comm; apply eqp_subp. -Qed. +Definition LKN := nroot .@ "LK". -Lemma sepcon_equiv: forall P1 Q1 P2 Q2: mpred, - ((P1 <=> Q1) && (P2 <=> Q2) |-- (P1 * P2) <=> (Q1 * Q2))%pred. -Proof. - intros. - constructor; apply eqp_sepcon. - - apply predicates_hered.andp_left1; auto. - - apply predicates_hered.andp_left2; auto. -Qed. - -Lemma later_equiv: forall P Q: mpred, - (P <=> Q |-- |> P <=> |> Q)%pred. -Proof. - intros. - constructor; eapply predicates_hered.derives_trans, subtypes.eqp_later1. - apply predicates_hered.now_later. -Qed. - -Lemma nonexpansive_lock_inv : forall sh p, nonexpansive (lock_inv sh p). -Proof. - intros. - unfold lock_inv. - apply @exists_nonexpansive. - intros b. - apply @exists_nonexpansive. - intros y. - apply @conj_nonexpansive. - apply @const_nonexpansive. +Definition lock_inv : share -> val -> mpred -> mpred := + fun sh v R => + (∃ b : block, ∃ ofs : _, ⌜v = Vptr b ofs⌝ ∧ + inv LKN (∃ st, LKspec LKSIZE st sh (b, Ptrofs.unsigned ofs) ∗ if st then emp else R)). - unfold LKspec. - apply forall_nonexpansive; intros. - hnf; intros. - intros n ?. - assert (forall y: rmap, (n >= level y)%nat -> (app_pred P y <-> app_pred Q y)). - { - clear - H. - intros; specialize (H y H0). - destruct H. - split; [eapply H | eapply H1]; eauto. - } - simpl; split; intros. - + if_tac; auto. - destruct H4 as [p0 ?]. - exists p0. - rewrite H4; f_equal. - f_equal. - extensionality ts; clear ts. - clear H4 H5 p0. - apply ext_level in H3. - apply predicates_hered.pred_ext; hnf; intros ? [? ?]; split; auto. - - apply necR_level in H2. - rewrite <- H0 by lia; auto. - - apply necR_level in H2. - rewrite H0 by lia; auto. - + if_tac; auto. - destruct H4 as [p0 ?]. - exists p0. - rewrite H4; f_equal. - f_equal. - extensionality ts; clear ts. - clear H4 H5 p0. - apply ext_level in H3. - apply predicates_hered.pred_ext; hnf; intros ? [? ?]; split; auto. - - apply necR_level in H2. - rewrite H0 by lia; auto. - - apply necR_level in H2. - rewrite <- H0 by lia; auto. -Qed. +Definition rec_inv sh v (Q R: mpred): mpred := (R ∗-∗ Q ∗ ▷ lock_inv sh v R)%I. -Lemma rec_inv1_nonexpansive: forall sh v Q, - nonexpansive (weak_rec_inv sh v Q). +Lemma lockinv_isptr sh v R : lock_inv sh v R ⊣⊢ (⌜isptr v⌝ ∧ lock_inv sh v R). Proof. - intros. - unfold weak_rec_inv. - intros P1 P2. - eapply predicates_hered.derives_trans; [| apply unfash_fash_equiv]. - eapply predicates_hered.derives_trans; [| apply iffp_equiv]. - apply predicates_hered.andp_right; auto. - eapply predicates_hered.derives_trans; [| apply sepcon_equiv]. - apply predicates_hered.andp_right. - { - intros n ?. - split; intros; hnf; intros; auto. - } - eapply predicates_hered.derives_trans, subtypes.eqp_later1. - eapply predicates_hered.derives_trans, predicates_hered.now_later. - apply nonexpansive_lock_inv. + rewrite comm; apply add_andp. + by iIntros "(% & % & -> & ?)". Qed. -Lemma rec_inv2_nonexpansive: forall sh v R, - nonexpansive (fun Q => weak_rec_inv sh v Q R). +#[global] Instance lock_inv_nonexpansive sh v : NonExpansive (lock_inv sh v). Proof. - intros. - unfold weak_rec_inv. - intros P1 P2. - eapply predicates_hered.derives_trans; [| apply unfash_fash_equiv]. - eapply predicates_hered.derives_trans; [| apply iffp_equiv]. - apply predicates_hered.andp_right. - { - intros n ?. - split; intros; hnf; intros; auto. - } - eapply predicates_hered.derives_trans; [| apply sepcon_equiv]. - apply predicates_hered.andp_right; auto. - - intros n ?. - split; intros; hnf; intros; auto. + rewrite /lock_inv /LKspec; intros ??? Heq. + do 9 f_equiv. + simple_if_tac; first done. + rewrite Heq //. Qed. -Lemma rec_inv_weak_rec_inv: forall sh v Q R, - rec_inv sh v Q R -> - TT |-- weak_rec_inv sh v Q R. -Proof. - intros. - constructor. - intros w _. - hnf in H |- *. - intros. - rewrite H at 1 4. - split; intros; hnf; intros; auto. -Qed. +End mpred. diff --git a/concurrency/juicy/semax_initial.v b/concurrency/juicy/semax_initial.v index d70de7a46..69104fdc5 100644 --- a/concurrency/juicy/semax_initial.v +++ b/concurrency/juicy/semax_initial.v @@ -10,17 +10,12 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.msl.age_to. -Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. Require Import VST.veric.semax_prog. -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.Clight_core. Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. -Require Import VST.veric.semax_ext. Require Import VST.veric.juicy_extspec. Require Import VST.veric.initial_world. Require Import VST.veric.juicy_extspec. @@ -36,6 +31,7 @@ Require Import VST.sepcomp.event_semantics. Require Import VST.concurrency.juicy.semax_conc_pred. Require Import VST.concurrency.juicy.semax_conc. Require Import VST.concurrency.juicy.juicy_machine. +Require Import VST.concurrency.compiler.mem_equiv. Require Import VST.concurrency.common.HybridMachineSig. Require Import VST.concurrency.common.scheduler. Require Import VST.concurrency.common.addressFiniteMap. @@ -173,6 +169,7 @@ Section Initial_State. (fun _ => Krun q) (fun _ => m_phi jm) (addressFiniteMap.AMap.empty _) + (wsat_rmap (m_phi jm)) ) ). @@ -196,40 +193,27 @@ Section Initial_State. destruct init_m as [m Hm]; simpl proj1_sig; simpl proj2_sig. set (spr := semax_prog_rule (Concurrent_Espec unit CS ext_link) V G prog m 0 tt (allows_exit ext_link) all_safe Hm). set (q := projT1 (projT2 spr)). - set (jm := proj1_sig (snd (projT2 (projT2 spr)) n)). + destruct (snd (projT2 (projT2 spr))) as (jm & D & H & E & (z & W & Hdry & Hext) & A & NL & MFS & FA). match goal with |- _ _ _ (_, (_, ?TP)) => set (tp := TP) end. (*! compatibility of memories *) - assert (compat : mem_compatible_with tp m (m_phi jm)). + assert (compat : mem_compatible_with tp m (m_phi z)). { constructor. - + apply AllJuice with (m_phi jm) None. - * change (proj1_sig (snd (projT2 (projT2 spr)) n)) with jm. - unfold join_threads. - unfold getThreadsR. - - match goal with |- _ ?l _ => replace l with (m_phi jm :: nil) end. + + apply AllJuice with (m_phi jm) None (m_phi jm). + * unfold join_threads. + unfold getThreadsR; simpl. exists (id_core (m_phi jm)). { split. - apply join_comm. apply id_core_unit. - apply id_core_identity. } - { - simpl. - set (a := m_phi jm). - match goal with |- context [m_phi ?jm] => set (b := m_phi jm) end. - replace b with a by reflexivity. clear. clearbody a. - reflexivity. - (* unfold fintype.ord_enum, eqtype.insub, seq.iota in *. - simpl. - destruct ssrbool.idP as [F|F]. reflexivity. exfalso. auto. *) - } - * reflexivity. * constructor. - + destruct (snd (projT2 (projT2 spr))) as [jm' [D H]]; unfold jm; clear jm; simpl. - subst m. + * apply W. + + subst m. + rewrite Hdry. apply mem_cohere'_juicy_mem. + intros b ofs. match goal with |- context [ssrbool.isSome ?x] => destruct x as [ phi | ] eqn:Ephi end. @@ -238,37 +222,30 @@ Section Initial_State. discriminate. { unfold is_true. simpl. congruence. } + intros loc L. (* sh psh P z *) - destruct (snd (projT2 (projT2 spr))) as (jm' & D & H & E & W & A & NL & MFS). - unfold jm in *; clear jm; simpl in L |- *. pose proof (NL loc) as NL'. specialize (L 0). spec L. pose proof lksize.LKSIZE_pos; lia. destruct L as [sh [psh [P L]]]. specialize (NL' sh psh lksize.LKSIZE 0 P). rewrite fst_snd0 in L. - rewrite L in NL'. contradiction NL'; auto. + simpl in *. + apply rmap_order in Hext as (? & Hr & _); rewrite Hr in *; contradiction. + hnf. simpl. intros ? F. inversion F. } (* end of mcompat *) - assert (En : level (m_phi jm) = n). { - unfold jm; clear. - match goal with - |- context [proj1_sig ?x] => destruct x as (jm' & jmm & lev & S & nolocks) - end; simpl. - rewrite level_juice_level_phi in *. - auto. + assert (En : level (m_phi z) = n). { + clear dependent tp. rewrite level_juice_level_phi in *; apply join_level in W as []; congruence. } - apply state_invariant_c with (PHI := m_phi jm) (mcompat := compat). + apply state_invariant_c with (mcompat := compat). - (*! level *) auto. - (*! env_coherence *) - destruct (snd (projT2 (projT2 spr))) as (jm' & D & H & E & W & A & NL & MFS & FA). - simpl in jm. unfold jm. split. - + apply MFS. - + exists prog, tt, CS, V. auto. + + eapply pred_upclosed, MFS; auto. + + exists prog, tt, CS, V; split3; auto. + eapply pred_upclosed; eauto. (* - clear - Hm. split. pose proof ( Genv.initmem_inject _ Hm). @@ -277,17 +254,16 @@ Section Initial_State. apply Genv.init_mem_genv_next in Hm. rewrite <- Hm. unfold globalenv. simpl. apply Ple_refl. *) - (*! external coherence *) - destruct (snd (projT2 (projT2 spr))) as (jm' & D & H & E & A & NL & MFS & FA). - simpl in jm. unfold jm. - subst jm tp; clear - E. - assert (@ghost.valid (ghost_PCM.ext_PCM unit) (Some (Tsh, Some tt), Some (Some tt))). - { simpl; split; [apply Share.nontrivial|]. - eexists; apply join_comm, core_unit. } - eexists; apply join_comm, own.singleton_join_gen with (k := O). - erewrite nth_error_nth in E by (apply nth_error_Some; rewrite E; discriminate). - inversion E as [Heq]; rewrite Heq. - instantiate (1 := (_, _)); constructor; constructor; simpl; [|repeat constructor]. - unshelve constructor; [| apply H | repeat constructor]. + subst tp; clear - W E. + apply ghost_of_join in W. + unfold wsat_rmap in W; rewrite ghost_of_make_rmap in W. + inv W. + { rewrite <- H0 in E; discriminate. } + assert (a3 = a1) by (inv H3; auto); subst. + rewrite <- H in E; inv E. + unfold ext_compat; rewrite <- H2; eexists; constructor; constructor. + instantiate (1 := (_, _)). + split; simpl; [apply ext_ref_join | split; eauto]. - (*! lock sparsity (no locks at first) *) intros l1 l2. @@ -297,10 +273,9 @@ Section Initial_State. - (*! lock coherence (no locks at first) *) intros lock. rewrite find_empty. - (* split; *) intros (sh & sh' & z & P & E); revert E; unfold jm; - match goal with - |- context [proj1_sig ?x] => destruct x as (jm' & jmm & lev & S & nolocks) - end; simpl; apply nolocks. + clear - Hext NL. + apply rmap_order in Hext as (_ & <- & _). + intros (? & ? & ? & ? & ?); eapply NL; eauto. - (*! safety of the only thread *) intros i cnti ora. @@ -311,20 +286,11 @@ Section Initial_State. { apply juicy_mem_ext; [|reflexivity]. - unfold jm_. - symmetry. - unfold jm. - destruct spr as (b' & q' & Hb & JS); simpl proj1_sig in *; simpl proj2_sig in *. - destruct (JS n) as (jm' & jmm & lev & S & notlock); simpl projT1 in *; simpl projT2 in *. - subst m. - setoid_rewrite personal_mem_of_same_jm; eauto. + subst; symmetry; apply personal_mem_of_same_jm; auto. } - subst jm. rewrite <-Ejm. + rewrite <-Ejm. simpl in Ec. replace c with q in * by congruence. - destruct spr as (b' & q' & Hb & JS); simpl proj1_sig in *; simpl proj2_sig in *. - destruct (JS n) as (jm' & jmm & lev & ? & W & Safe & notlock); simpl projT1 in *; simpl projT2 in *. - subst q. - simpl proj1_sig in *; simpl proj2_sig in *. subst n. - destruct ora; apply Safe. + destruct ora; apply A. - (* well-formedness *) intros i cnti. @@ -332,6 +298,14 @@ Section Initial_State. - (* only one thread running *) intros F; exfalso. simpl in F. lia. + + - (* inv_compatible (wsat is set up) *) + exists (id_core (m_phi jm)), (wsat_rmap (m_phi jm)). + split; [eexists; apply id_core_unit|]. + split; [|apply wsat_rmap_wsat]. + destruct (join_assoc (join_comm (id_core_unit (m_phi jm))) W) as (? & ? & ?). + apply identity_unit; eauto. + apply id_core_identity. Qed. End Initial_State. diff --git a/concurrency/juicy/semax_invariant.v b/concurrency/juicy/semax_invariant.v index c1341cddd..8d158a644 100644 --- a/concurrency/juicy/semax_invariant.v +++ b/concurrency/juicy/semax_invariant.v @@ -10,16 +10,13 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.age_to. -Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. +Require Import VST.veric.external_state. Require Import VST.veric.semax_prog. -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.Clight_core. Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. -Require Import VST.veric.semax_ext. Require Import VST.veric.juicy_extspec. Require Import VST.veric.initial_world. Require Import VST.veric.juicy_extspec. @@ -33,6 +30,7 @@ Require Import VST.sepcomp.event_semantics. Require Import VST.concurrency.juicy.semax_conc_pred. Require Import VST.concurrency.juicy.semax_conc. Require Import VST.concurrency.juicy.juicy_machine. +Require Import VST.concurrency.common.threads_lemmas. Require Import VST.concurrency.common.HybridMachineSig. Require Import VST.concurrency.common.semantics. Require Import VST.concurrency.common.scheduler. @@ -40,7 +38,7 @@ Require Import VST.concurrency.common.addressFiniteMap. Require Import VST.concurrency.common.permissions. Require Import VST.concurrency.common.ClightSemanticsForMachines. Require Import VST.concurrency.juicy.JuicyMachineModule. -Require Import VST.concurrency.juicy.sync_preds_defs. +(*Require Import VST.concurrency.juicy.sync_preds_defs.*) Require Import VST.concurrency.juicy.join_lemmas. Require Import VST.concurrency.common.lksize. Import threadPool Events. @@ -58,28 +56,17 @@ Ltac cleanup := unfold OrdinalPool.lockGuts in *; unfold OrdinalPool.lockSet in *; simpl lock_info in *; simpl res in *. -Ltac join_level_tac := - try - match goal with - cnti : containsThread ?tp _, - compat : mem_compatible_with ?tp ?m ?Phi |- _ => - assert (join_sub (getThreadR cnti) Phi) by (apply compatible_threadRes_sub, compat) - end; - repeat match goal with H : join_sub _ _ |- _ => apply join_sub_level in H end; - repeat match goal with H : join _ _ _ |- _ => apply join_level in H; destruct H end; - cleanup; - try congruence. - Notation event_trace := (seq.seq machine_event). -Lemma allows_exit {CS} ext_link : postcondition_allows_exit (Concurrent_Espec unit CS ext_link) Ctypesdefs.tint. +Lemma allows_exit `{!heapGS Σ} `{!externalGS unit Σ} {CS} ext_link : @postcondition_allows_exit _ (Concurrent_Espec unit CS ext_link) Ctypesdefs.tint. Proof. - repeat intro; apply I. + by constructor. Qed. Section Machine. -Context {ZT : Type} (Jspec : juicy_ext_spec ZT) {ge : genv}. +Context {ZT : Type} `{!heapGS Σ} `{!externalGS ZT Σ} (Jspec : juicy_ext_spec(Σ := Σ) ZT) {ge : genv}. +Definition Espec := {| OK_ty := ZT; OK_spec := Jspec |}. (*+ Description of the invariant *) Definition cm_state := (Mem.mem * (event_trace * schedule * jstate ge))%type. @@ -90,7 +77,7 @@ Inductive state_step : cm_state -> cm_state -> Prop := (m, (tr, nil, jstate)) (m, (tr, nil, jstate)) | state_step_c m m' tr tr' sch sch' jstate jstate': - @JuicyMachine.machine_step _ (ClightSem ge) _ HybridCoarseMachine.DilMem JuicyMachineShell HybridMachineSig.HybridCoarseMachine.scheduler sch tr jstate m sch' tr' jstate' m' -> + @JuicyMachine.machine_step _ (ClightSem ge) _ HybridCoarseMachine.DilMem (JuicyMachineShell(Σ := Σ)) HybridMachineSig.HybridCoarseMachine.scheduler sch tr jstate m sch' tr' jstate' m' -> state_step (m, (tr, sch, jstate)) (m',(tr', sch', jstate')). @@ -98,7 +85,7 @@ Inductive state_step : cm_state -> cm_state -> Prop := (*! Coherence between locks in dry/wet memories and lock pool *) -Inductive cohere_res_lock : forall (resv : option (option rmap)) (wetv : resource) (dryv : memval), Prop := +(*Inductive cohere_res_lock : forall (resv : option (option rmap)) (wetv : resource) (dryv : memval), Prop := | cohere_notlock wetv dryv: (forall sh sh' z P, wetv <> YES sh sh' (LK z 0) P) -> cohere_res_lock None wetv dryv @@ -139,7 +126,7 @@ Definition lock_coherence (lset : AMap.t (option rmap)) (phi : rmap) (m : mem) : | Some p => app_pred R p | None => Logic.True end*) - end. + end.*) Definition far (ofs1 ofs2 : Z) := (Z.abs (ofs1 - ofs2) >= LKSIZE)%Z. @@ -162,20 +149,6 @@ Definition lock_sparsity {A} (lset : AMap.t A) : Prop := fst loc1 <> fst loc2 \/ (fst loc1 = fst loc2 /\ far (snd loc1) (snd loc2)). -Lemma lock_sparsity_age_to (tp : jstate ge) n : - lock_sparsity (lset tp) -> - lock_sparsity (lset (age_tp_to n tp)). -Proof. - destruct tp as [A B C lset0]; simpl. - intros S l1 l2 E1 E2; apply (S l1 l2). - - rewrite AMap_find_map_option_map in E1. - cleanup. - destruct (AMap.find (elt:=option rmap) l1 lset0); congruence || tauto. - - rewrite AMap_find_map_option_map in E2. - cleanup. - destruct (AMap.find (elt:=option rmap) l2 lset0); congruence || tauto. -Qed. - Definition lset_same_support {A} (lset1 lset2 : AMap.t A) := forall loc, AMap.find loc lset1 = None <-> @@ -241,7 +214,7 @@ Definition jm_ {tp m PHI i} (cnti : containsThread tp i) (mcompat : mem_compatible_with tp m PHI) - : juicy_mem := + : mem := personal_mem (thread_mem_compatible (mem_compatible_forget mcompat) cnti). Lemma personal_mem_ext m phi phi' pr pr' : @@ -254,32 +227,17 @@ Qed. (*! Invariant (= above properties + safety + uniqueness of Krun) *) -Definition jsafe_phi ge ora c phi := - forall jm, - m_phi jm = phi -> - @semax.jsafeN ZT Jspec ge ora c jm. +(* Could we move more of this into the logic? *) +(* Since we're moving towards a machine without ghost state, we erase all of the state except + the rmap, and then nondeterministically reconstruct the rest of the state at each step. + Will this work? *) +Definition jsafe_phi ge n ora c phi := + ouPred_holds (semax.jsafeN Espec ge ⊤ ora c) n phi. -Definition jsafe_phi_bupd ge ora c phi := - forall jm, - m_phi jm = phi -> - jm_bupd ora (@semax.jsafeN ZT Jspec ge ora c) jm. - -Definition jsafe_phi_fupd ge ora c phi := - forall jm, - m_phi jm = phi -> - jm_fupd ora Ensembles.Full_set Ensembles.Full_set (@semax.jsafeN ZT Jspec ge ora c) jm. - -Lemma jsafe_phi_jsafeN ora c i (tp : jstate ge) m (cnti : containsThread tp i) Phi compat : - @jsafe_phi ge ora c (getThreadR cnti) -> - @semax.jsafeN ZT Jspec ge ora c (@jm_ tp m Phi i cnti compat). -Proof. - intros S; apply S, eq_refl. -Qed. - -Definition threads_safety m (tp : jstate ge) PHI (mcompat : mem_compatible_with tp m PHI) := +Definition threads_safety m (tp : jstate ge) PHI (mcompat : mem_compatible_with tp m PHI) n := forall i (cnti : containsThread tp i) (ora : ZT), match getThreadC cnti with - | Krun c => semax.jsafeN Jspec ge ora c (jm_ cnti mcompat) + | Krun c => jsafe_phi ge n ora c (getThreadR cnti) | Kblocked c => (* The dry memory will change, so when we prove safety after an external we must only inspect the rmap m_phi part of the juicy @@ -292,12 +250,12 @@ Definition threads_safety m (tp : jstate ge) PHI (mcompat : mem_compatible_with the definition of JuicyMachine.resume_thread'. *) cl_after_external None c = Some c' -> (* same quantification as in Kblocked *) - jsafe_phi_fupd ge ora c' (getThreadR cnti) + jsafe_phi ge n ora c' (getThreadR cnti) | Kinit v1 v2 => (* Val.inject (Mem.flat_inj (Mem.nextblock m)) v2 v2 /\ *) exists q_new, cl_initial_core ge v1 (v2 :: nil) = Some q_new /\ - jsafe_phi ge ora q_new (getThreadR cnti) + jsafe_phi ge n ora q_new (getThreadR cnti) end. Definition threads_wellformed (tp : jstate ge) := @@ -510,7 +468,9 @@ rewrite Z.add_0_r. auto. intros ? ?. unfold maxedmem. unfold Mem.perm; setoid_rewrite restrPermMap_Max; rewrite getMaxPerm_correct. -apply H0; eauto. +eauto. +specialize (H0 _ H1). +apply H0. - apply mi_memval; auto. clear - H0. unfold maxedmem, Mem.perm in *. @@ -521,6 +481,10 @@ eapply perm_order_trans211; eauto. apply (access_cur_max _ (_, _)). Qed. +Definition inv_compatible (tp : jstate ge) := forall i (cnti : containsThread tp i), exists r w, + join_sub r (getThreadR cnti) /\ join r (extraRes tp) w /\ + app_pred (invariants.wsat * invariants.ghost_set invariants.g_en Ensembles.Full_set)%pred w. + Inductive state_invariant Gamma (n : nat) : cm_state -> Prop := | state_invariant_c (m : mem) (tr : event_trace) (sch : schedule) (tp : jstate ge) (PHI : rmap) @@ -528,12 +492,13 @@ Inductive state_invariant Gamma (n : nat) : cm_state -> Prop := (envcoh : env_coherence Jspec ge Gamma PHI) (* (mwellformed: mem_wellformed m) *) (mcompat : mem_compatible_with tp m PHI) - (extcompat : joins (ghost_of PHI) (Some (ext_ref tt, NoneP) :: nil)) + (extcompat : ext_compat tt PHI) (lock_sparse : lock_sparsity (lset tp)) (lock_coh : lock_coherence' tp PHI m mcompat) (safety : threads_safety m tp PHI mcompat) (wellformed : threads_wellformed tp) (uniqkrun : unique_Krun tp sch) + (invcompat : inv_compatible tp) : state_invariant Gamma n (m, (tr, sch, tp)). (* Schedule irrelevance of the invariant *) @@ -542,9 +507,9 @@ Lemma state_invariant_sch_irr Gamma n m i tr sch sch' tp : state_invariant Gamma n (m, (tr, i :: sch', tp)). Proof. intros INV. - inversion INV as [m0 tr0 sch0 tp0 PHI lev envcoh (*mwellformed*) compat extcompat sparse lock_coh safety wellformed uniqkrun H0]; + inversion INV as [m0 tr0 sch0 tp0 PHI lev envcoh (*mwellformed*) compat extcompat sparse lock_coh safety wellformed uniqkrun invcompat H0]; subst m0 tr0 sch0 tp0. - refine (state_invariant_c Gamma n m tr (i :: sch') tp PHI lev envcoh (*mwellformed*) compat extcompat sparse lock_coh safety wellformed _). + refine (state_invariant_c Gamma n m tr (i :: sch') tp PHI lev envcoh (*mwellformed*) compat extcompat sparse lock_coh safety wellformed _ invcompat ). clear -uniqkrun. intros H i0 cnti q H0. destruct (uniqkrun H i0 cnti q H0) as [sch'' E]. @@ -564,15 +529,22 @@ Definition blocked_at_external (state : cm_state) (ef : external_function) := Definition state_bupd P (state : cm_state) := let '(m, (tr, sch, tp)) := state in tp_bupd (fun tp' => P (m, (tr, sch, tp'))) tp. -Lemma state_bupd_intro : forall (P : _ -> Prop) m tr sch tp phi, join_all tp phi -> - joins (ghost_of phi) (Some (ext_ref tt, NoneP) :: nil) -> - P (m, (tr, sch, tp)) -> state_bupd P (m, (tr, sch, tp)). +Lemma tp_bupd_intro : forall (P : _ -> Prop) (tp : jstate ge) phi, join_all tp phi -> + ext_compat tt phi -> P tp -> tp_bupd P tp. Proof. - intros; split; eauto; intros. + unfold tp_bupd; intros. + split; eauto; intros. eexists; split; eauto. eexists _, _; split; [apply tp_update_refl|]; auto. Qed. +Lemma state_bupd_intro : forall (P : _ -> Prop) m tr sch tp phi, join_all tp phi -> + ext_compat tt phi -> + P (m, (tr, sch, tp)) -> state_bupd P (m, (tr, sch, tp)). +Proof. + intros; eapply tp_bupd_intro; eauto. +Qed. + Lemma state_bupd_intro' : forall Gamma n s, state_invariant Gamma n s -> state_bupd (state_invariant Gamma n) s. @@ -582,16 +554,25 @@ Proof. apply mcompat. Qed. -(*Definition state_fupd P (state : cm_state) := let '(m, (tr, sch, tp)) := state in +Definition state_fupd P (state : cm_state) := let '(m, (tr, sch, tp)) := state in tp_fupd (fun tp' => P (m, (tr, sch, tp'))) tp. +Lemma cnt0 (tp : jstate ge) : containsThread tp O. +Proof. + hnf. + destruct (@ssrnat.leP 1 (pos.n (num_threads tp))); auto. + destruct num_threads; simpl in *; lia. +Qed. + Lemma state_fupd_intro : forall (P : _ -> Prop) m tr sch tp phi, join_all tp phi -> - joins (ghost_of phi) (Some (ext_ref tt, NoneP) :: nil) -> + ext_compat tt phi -> inv_compatible tp -> P (m, (tr, sch, tp)) -> state_fupd P (m, (tr, sch, tp)). Proof. - intros; split; eauto; intros. - eexists; split; eauto. - eexists _, _; split; [apply tp_update_refl|]; auto. + intros; unfold state_fupd, tp_fupd. + destruct (H1 _ (cnt0 _)) as (r & w & [m0 ?] & ? & ?). + exists O, (cnt0 _), m0, r, w; repeat (split; auto). + right; eapply tp_bupd_intro; eauto. + exists (cnt0 _), m0, r, w; auto. Qed. Lemma state_fupd_intro' : forall Gamma n s, @@ -601,7 +582,7 @@ Proof. inversion 1; subst. eapply state_fupd_intro; eauto. apply mcompat. -Qed.*) +Qed. Lemma mem_compatible_upd : forall tp m phi tp' phi', mem_compatible_with tp m phi -> tp_update(ge := ge) tp phi tp' phi' -> mem_compatible_with tp' m phi'. @@ -621,12 +602,14 @@ Proof. Qed. Lemma join_all_eq : forall (tp : jstate ge) phi phi', join_all tp phi -> join_all tp phi' -> - (getThreadsR tp = nil /\ getLocksR tp = nil /\ identity phi /\ identity phi') \/ phi = phi'. + phi = phi'. Proof. intros ???; rewrite join_all_joinlist. unfold maps. - destruct (getThreadsR tp); [|intros; right; eapply joinlist_inj; eauto; discriminate]. - destruct (getLocksR tp); [auto | intros; right; eapply joinlist_inj; eauto; discriminate]. + destruct (getThreadsR tp); [|intros; eapply joinlist_inj; eauto; discriminate]. + destruct (getLocksR tp); [auto | intros; eapply joinlist_inj; eauto; discriminate]. + simpl. + intros (? & Hid1 & ?%join_comm%Hid1) (? & Hid2 & ?%join_comm%Hid2); subst; auto. Qed. Lemma funspec_sub_si_fash : forall a b, funspec_sub_si a b |-- !#funspec_sub_si a b. diff --git a/concurrency/juicy/semax_preservation.v b/concurrency/juicy/semax_preservation.v index 2f040011a..d9448f6f4 100644 --- a/concurrency/juicy/semax_preservation.v +++ b/concurrency/juicy/semax_preservation.v @@ -11,20 +11,12 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.msl.age_to. -Require Import VST.veric.aging_lemmas. -Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. Require Import VST.veric.semax_prog. - -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.Clight_core. Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. -Require Import VST.veric.semax_ext. -Require Import VST.veric.juicy_extspec. Require Import VST.veric.juicy_safety. Require Import VST.veric.initial_world. Require Import VST.veric.juicy_extspec. @@ -32,7 +24,6 @@ Require Import VST.veric.tycontext. Require Import VST.veric.semax_ext. Require Import VST.veric.res_predicates. Require Import VST.veric.mem_lessdef. -Require Import VST.veric.age_to_resource_at. Require Import VST.floyd.coqlib3. Require Import VST.sepcomp.step_lemmas. Require Import VST.sepcomp.event_semantics. @@ -48,11 +39,10 @@ Require Import VST.concurrency.common.permissions. Require Import VST.concurrency.juicy.JuicyMachineModule. Require Import VST.concurrency.common.lksize. Require Import VST.concurrency.juicy.sync_preds_defs. -Require Import VST.concurrency.juicy.sync_preds. Require Import VST.concurrency.juicy.join_lemmas. Require Import VST.concurrency.juicy.cl_step_lemmas. -Require Import VST.concurrency.juicy.resource_decay_lemmas. -Require Import VST.concurrency.juicy.resource_decay_join. +(*Require Import VST.concurrency.juicy.resource_decay_lemmas. +Require Import VST.concurrency.juicy.resource_decay_join.*) Require Import VST.concurrency.juicy.sync_preds. Require Import VST.concurrency.juicy.semax_invariant. Require Import VST.concurrency.juicy.semax_simlemmas. diff --git a/concurrency/juicy/semax_preservation_acquire.v b/concurrency/juicy/semax_preservation_acquire.v index 8ca861714..7db7a3ce0 100644 --- a/concurrency/juicy/semax_preservation_acquire.v +++ b/concurrency/juicy/semax_preservation_acquire.v @@ -10,18 +10,12 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.msl.age_to. -Require Import VST.veric.aging_lemmas. -Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. Require Import VST.veric.semax_prog. -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.Clight_core. Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. -Require Import VST.veric.semax_ext. Require Import VST.veric.juicy_extspec. Require Import VST.veric.juicy_safety. Require Import VST.veric.initial_world. @@ -30,8 +24,6 @@ Require Import VST.veric.tycontext. Require Import VST.veric.semax_ext. Require Import VST.veric.res_predicates. Require Import VST.veric.mem_lessdef. -Require Import VST.veric.age_to_resource_at. -Require Import VST.veric.ghost_PCM. Require Import VST.floyd.coqlib3. Require Import VST.sepcomp.step_lemmas. Require Import VST.sepcomp.event_semantics. @@ -46,11 +38,7 @@ Require Import VST.concurrency.common.addressFiniteMap. Require Import VST.concurrency.common.permissions. Require Import VST.concurrency.juicy.JuicyMachineModule. Require Import VST.concurrency.juicy.sync_preds_defs. -Require Import VST.concurrency.juicy.sync_preds. Require Import VST.concurrency.juicy.join_lemmas. -(*Require Import VST.concurrency.cl_step_lemmas. -Require Import VST.concurrency.resource_decay_lemmas. -Require Import VST.concurrency.resource_decay_join.*) Require Import VST.concurrency.juicy.semax_invariant. Require Import VST.concurrency.juicy.semax_simlemmas. Require Import VST.concurrency.juicy.sync_preds. @@ -316,7 +304,7 @@ Proof. (* + inv INV. clear -mwellformed Hstore. eapply mem_wellformed_store; [.. | apply Hstore |]; auto. apply mem_wellformed_restr; auto. *) - + rewrite age_to_ghost_of. + + unfold ext_compat; rewrite age_to_ghost_of. destruct extcompat as [? J]; eapply ghost_fmap_join in J; eexists; eauto. + (* lock sparsity *) @@ -659,7 +647,7 @@ Opaque age_tp_to. Opaque LKSIZE_nat. -- intros c' Ec'; specialize (safety c' Ec'). apply jsafe_phi_fupd_age_to; auto. -- destruct safety as (q_new & Einit & safety). exists q_new; split; auto. - apply jsafe_phi_age_to; auto. + apply jsafe_phi_fupd_age_to; auto. + (* well_formedness *) intros j lj. diff --git a/concurrency/juicy/semax_preservation_jspec.v b/concurrency/juicy/semax_preservation_jspec.v index 3d58306e4..120222e58 100644 --- a/concurrency/juicy/semax_preservation_jspec.v +++ b/concurrency/juicy/semax_preservation_jspec.v @@ -10,18 +10,12 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.veric.aging_lemmas. -Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. Require Import VST.veric.semax_prog. -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.Clight_core. Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. -Require Import VST.veric.semax_ext. -Require Import VST.veric.juicy_extspec. Require Import VST.veric.juicy_safety. Require Import VST.veric.initial_world. Require Import VST.veric.juicy_extspec. diff --git a/concurrency/juicy/semax_preservation_local.v b/concurrency/juicy/semax_preservation_local.v index 5250f11f3..985d5de10 100644 --- a/concurrency/juicy/semax_preservation_local.v +++ b/concurrency/juicy/semax_preservation_local.v @@ -10,18 +10,12 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.msl.age_to. -Require Import VST.veric.aging_lemmas. -Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. Require Import VST.veric.semax_prog. -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.Clight_core. Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. -Require Import VST.veric.semax_ext. Require Import VST.veric.juicy_extspec. Require Import VST.veric.juicy_safety. Require Import VST.veric.initial_world. @@ -30,14 +24,13 @@ Require Import VST.veric.tycontext. Require Import VST.veric.semax_ext. Require Import VST.veric.res_predicates. Require Import VST.veric.mem_lessdef. -Require Import VST.veric.age_to_resource_at. Require Import VST.floyd.coqlib3. Require Import VST.sepcomp.step_lemmas. Require Import VST.sepcomp.mem_lemmas. Require Import VST.sepcomp.event_semantics. Require Import VST.sepcomp.semantics_lemmas. Require Import VST.concurrency.common.permjoin. -Require Import VST.concurrency.semax_conc. +Require Import VST.concurrency.juicy.semax_conc. Require Import VST.concurrency.juicy.juicy_machine. Require Import VST.concurrency.common.HybridMachineSig. Require Import VST.concurrency.common.scheduler. @@ -45,11 +38,10 @@ Require Import VST.concurrency.common.addressFiniteMap. Require Import VST.concurrency.common.permissions. Require Import VST.concurrency.juicy.JuicyMachineModule. Require Import VST.concurrency.juicy.sync_preds_defs. -Require Import VST.concurrency.juicy.sync_preds. Require Import VST.concurrency.juicy.join_lemmas. Require Import VST.concurrency.juicy.cl_step_lemmas. -Require Import VST.concurrency.juicy.resource_decay_lemmas. -Require Import VST.concurrency.juicy.resource_decay_join. +(*Require Import VST.concurrency.juicy.resource_decay_lemmas. +Require Import VST.concurrency.juicy.resource_decay_join.*) Require Import VST.concurrency.juicy.semax_invariant. Require Import VST.concurrency.juicy.semax_simlemmas. Require Import VST.concurrency.juicy.sync_preds. @@ -296,9 +288,10 @@ Lemma invariant_thread_step (safety : threads_safety Jspec m tp Phi compat) (wellformed : threads_wellformed tp) (unique : unique_Krun tp (i :: sch)) + (invcompat : inv_compatible tp) (cnti : containsThread tp i) (stepi : corestep (juicy_core_sem (cl_core_sem ge)) ci (jm_ cnti compat) ci' jmi') - (safei' : forall ora, jm_bupd ora (jsafeN Jspec ge ora ci') jmi') + (safei' : forall ora, jm_fupd ora Ensembles.Full_set Ensembles.Full_set (jsafeN Jspec ge ora ci') jmi') (Eci : getThreadC i tp cnti = Krun ci) (tp' := age_tp_to (level jmi') tp) (tp'' := updThread i tp' (cnt_age' cnti) (Krun ci') (m_phi jmi') : jstate ge) @@ -600,6 +593,8 @@ Proof. changed. *) + (* We somehow need to track the fact that the thread already owns all the resources it would + need to take from invariants in safei'. *) apply state_inv_upd1 with (PHI := Phi'') (mcompat := compat''). - (* level *) assumption. @@ -810,7 +805,7 @@ Proof. REWR. REWR. intros c' Ec'; specialize (safej c' Ec'). - apply jsafe_phi_bupd_age_to; auto. + apply jsafe_phi_fupd_age_to; auto. * destruct safej as (Harg & q_new & Einit & safej); split. { destruct stepi as (stepi & _). apply (corestep_mem (msem (Clight_evsem.CLC_evsem ge))), mem_step_nextblock' diff --git a/concurrency/juicy/semax_progress.v b/concurrency/juicy/semax_progress.v index efb6b5385..60c3e2df8 100644 --- a/concurrency/juicy/semax_progress.v +++ b/concurrency/juicy/semax_progress.v @@ -10,26 +10,18 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.msl.age_to. -Require Import VST.veric.aging_lemmas. -Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. Require Import VST.veric.semax_prog. -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.Clight_core. Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. -Require Import VST.veric.semax_ext. -Require Import VST.veric.juicy_extspec. Require Import VST.veric.initial_world. Require Import VST.veric.juicy_extspec. Require Import VST.veric.tycontext. Require Import VST.veric.semax_ext. Require Import VST.veric.res_predicates. Require Import VST.veric.shares. -Require Import VST.veric.age_to_resource_at. Require Import VST.floyd.coqlib3. Require Import VST.floyd.field_at. Require Import VST.sepcomp.extspec. @@ -46,9 +38,6 @@ Require Import VST.concurrency.juicy.JuicyMachineModule. Require Import VST.concurrency.juicy.sync_preds_defs. Require Import VST.concurrency.juicy.sync_preds. Require Import VST.concurrency.juicy.join_lemmas. -(*Require Import VST.concurrency.cl_step_lemmas. -Require Import VST.concurrency.resource_decay_lemmas. -Require Import VST.concurrency.resource_decay_join.*) Require Import VST.concurrency.juicy.semax_invariant. Require Import VST.concurrency.juicy.semax_simlemmas. Require Import VST.concurrency.juicy.rmap_locking. @@ -223,7 +212,7 @@ Section Progress. state_step(ge := ge) state state'. Proof. intros not_spawn I. - inversion I as [m tr sch tp Phi En envcoh (*mwellformed*) compat extcompat sparse lock_coh safety wellformed unique E]. rewrite <-E in *. + inversion I as [m tr sch tp Phi En envcoh (*mwellformed*) compat extcompat sparse lock_coh safety wellformed unique invcompat E]. rewrite <-E in *. destruct sch as [ | i sch ]. (* empty schedule: we loop in the same state *) @@ -492,7 +481,7 @@ Section Progress. } (* changing value of lock in dry mem *) - assert (Hm' : exists m', Mem.store Mptr (restrPermMap Hlt') b (Ptrofs.intval ofs) (Vint Int.zero) = Some m'). { + assert (Hm' : exists m', Mem.store Mptr (restrPermMap Hlt') b (Ptrofs.intval ofs) (Vptrofs Ptrofs.zero) = Some m'). { Transparent Mem.store. unfold Mem.store in *. destruct (Mem.valid_access_dec _ Mptr b (Ptrofs.intval ofs) Writable) as [N|N]. diff --git a/concurrency/juicy/semax_safety_freelock.v b/concurrency/juicy/semax_safety_freelock.v index cafddb398..7ca6b0fa1 100644 --- a/concurrency/juicy/semax_safety_freelock.v +++ b/concurrency/juicy/semax_safety_freelock.v @@ -10,19 +10,12 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.msl.age_to. -Require Import VST.veric.aging_lemmas. -Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. Require Import VST.veric.semax_prog. -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.Clight_core. Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. -Require Import VST.veric.semax_ext. -Require Import VST.veric.juicy_extspec. Require Import VST.veric.juicy_safety. Require Import VST.veric.initial_world. Require Import VST.veric.juicy_extspec. @@ -31,7 +24,6 @@ Require Import VST.veric.semax_ext. Require Import VST.veric.res_predicates. Require Import VST.veric.mem_lessdef. Require Import VST.veric.shares. -Require Import VST.veric.age_to_resource_at. Require Import VST.floyd.coqlib3. Require Import VST.floyd.field_at. Require Import VST.sepcomp.step_lemmas. @@ -46,11 +38,7 @@ Require Import VST.concurrency.common.addressFiniteMap. Require Import VST.concurrency.common.permissions. Require Import VST.concurrency.juicy.JuicyMachineModule. Require Import VST.concurrency.juicy.sync_preds_defs. -Require Import VST.concurrency.juicy.sync_preds. Require Import VST.concurrency.juicy.join_lemmas. -(*Require Import VST.concurrency.cl_step_lemmas. -Require Import VST.concurrency.resource_decay_lemmas. -Require Import VST.concurrency.resource_decay_join.*) Require Import VST.concurrency.juicy.semax_invariant. Require Import VST.concurrency.juicy.semax_simlemmas. Require Import VST.concurrency.juicy.sync_preds. @@ -467,7 +455,7 @@ Proof. apply env_coherence_pures_eq with Phi; auto. lia. apply pures_same_pures_eq. auto. eapply rmap_freelock_pures_same; eauto. - - rewrite age_to_ghost_of. + - unfold ext_compat; rewrite age_to_ghost_of. destruct Hrmap' as (? & ? & ? & <-). destruct extcompat as [? J]; eapply ghost_fmap_join in J; eexists; eauto. @@ -764,7 +752,7 @@ Proof. -- intros c' Ec'; specialize (safety c' Ec'). apply jsafe_phi_fupd_age_to; auto. -- destruct safety as (q_new & Einit & safety). exists q_new; split; auto. - apply jsafe_phi_age_to; auto. + apply jsafe_phi_fupd_age_to; auto. } - (* threads_wellformed *) diff --git a/concurrency/juicy/semax_safety_makelock.v b/concurrency/juicy/semax_safety_makelock.v index 0ed52acb5..31a5f5f47 100644 --- a/concurrency/juicy/semax_safety_makelock.v +++ b/concurrency/juicy/semax_safety_makelock.v @@ -10,19 +10,12 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.msl.age_to. -Require Import VST.veric.aging_lemmas. -Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. Require Import VST.veric.semax_prog. -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.Clight_core. Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. -Require Import VST.veric.semax_ext. -Require Import VST.veric.juicy_extspec. Require Import VST.veric.juicy_safety. Require Import VST.veric.initial_world. Require Import VST.veric.juicy_extspec. @@ -31,7 +24,6 @@ Require Import VST.veric.semax_ext. Require Import VST.veric.res_predicates. Require Import VST.veric.mem_lessdef. Require Import VST.veric.shares. -Require Import VST.veric.age_to_resource_at. Require Import VST.floyd.coqlib3. Require Import VST.floyd.field_at. Require Import VST.sepcomp.step_lemmas. @@ -47,11 +39,7 @@ Require Import VST.concurrency.common.addressFiniteMap. Require Import VST.concurrency.common.permissions. Require Import VST.concurrency.juicy.JuicyMachineModule. Require Import VST.concurrency.juicy.sync_preds_defs. -Require Import VST.concurrency.juicy.sync_preds. Require Import VST.concurrency.juicy.join_lemmas. -(*Require Import VST.concurrency.cl_step_lemmas. -Require Import VST.concurrency.resource_decay_lemmas. -Require Import VST.concurrency.resource_decay_join.*) Require Import VST.concurrency.juicy.semax_invariant. Require Import VST.concurrency.juicy.semax_simlemmas. Require Import VST.concurrency.juicy.sync_preds. @@ -102,7 +90,7 @@ Proof. assert (Hpos : (0 < LKSIZE)%Z) by reflexivity. intros ismakelock. intros I. - inversion I as [m tr sch_ tp Phi En envcoh (*mwellformed*) compat extcompat sparse lock_coh safety wellformed unique E]. rewrite <-E in *. + inversion I as [m tr sch_ tp Phi En envcoh (*mwellformed*) compat extcompat sparse lock_coh safety wellformed unique invcompat E]. rewrite <-E in *. unfold blocked_at_external in *. destruct ismakelock as (i & cnti & sch & ci & args & -> & Eci & atex). pose proof (safety i cnti tt) as safei. @@ -527,7 +515,7 @@ Proof. unfold juicyRestrict in Hstore; simpl in Hstore. eapply mem_wellformed_store; [.. | apply Hstore |]; auto. apply mem_wellformed_restr; auto. *) - - rewrite age_to_ghost_of. + - unfold ext_compat; rewrite age_to_ghost_of. destruct Hrmap' as (? & ? & ? & <-). destruct extcompat as [? J]; eapply ghost_fmap_join in J; eexists; eauto. @@ -814,7 +802,7 @@ Proof. * intros ? Hc'; apply jsafe_phi_fupd_age_to; auto. * destruct safety as (q_new & Einit & safety). exists q_new; split; auto. - apply jsafe_phi_age_to; auto. } + apply jsafe_phi_fupd_age_to; auto. } - (* threads_wellformed *) intros j lj. @@ -835,4 +823,15 @@ Proof. eapply unique_Krun_no_Krun. eassumption. instantiate (1 := cnti). rewr (getThreadC i tp cnti). congruence. + + - intros j lj; specialize (invcompat _ lj). + rewrite gsoThreadExtra; simpl extraRes. + destruct (eq_dec i j). + + subst; rewrite gssThreadRes. + (* The current phrasing doesn't capture the idea that the correctness proof must not have + used the hidden resources from the invariant. Shoudl we explicitly force the juicy steps + to restrict to or reestablish the available resources? How does this look in a corestep? *) + + erewrite (gsoThreadRes(i := i)(j := j)); eauto. +admit. +Search extraRes updThread. Qed. diff --git a/concurrency/juicy/semax_safety_release.v b/concurrency/juicy/semax_safety_release.v index 92fb2a1fa..6493a4b87 100644 --- a/concurrency/juicy/semax_safety_release.v +++ b/concurrency/juicy/semax_safety_release.v @@ -10,18 +10,12 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.msl.age_to. -Require Import VST.veric.aging_lemmas. -Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. Require Import VST.veric.semax_prog. -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.Clight_core. Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. -Require Import VST.veric.semax_ext. Require Import VST.veric.juicy_extspec. Require Import VST.veric.juicy_safety. Require Import VST.veric.initial_world. @@ -29,7 +23,6 @@ Require Import VST.veric.tycontext. Require Import VST.veric.semax_ext. Require Import VST.veric.res_predicates. Require Import VST.veric.mem_lessdef. -Require Import VST.veric.age_to_resource_at. Require Import VST.floyd.coqlib3. Require Import VST.sepcomp.step_lemmas. Require Import VST.sepcomp.event_semantics. @@ -47,9 +40,6 @@ Require Import VST.concurrency.juicy.JuicyMachineModule. Require Import VST.concurrency.juicy.sync_preds_defs. Require Import VST.concurrency.juicy.sync_preds. Require Import VST.concurrency.juicy.join_lemmas. -(*Require Import VST.concurrency.cl_step_lemmas. -Require Import VST.concurrency.resource_decay_lemmas. -Require Import VST.concurrency.resource_decay_join.*) Require Import VST.concurrency.juicy.semax_invariant. Require Import VST.concurrency.juicy.semax_simlemmas. Require Import VST.concurrency.juicy.sync_preds. @@ -302,7 +292,7 @@ Proof. apply store_access in Hstore. admit. (* Santiago *) *) + (* external coherence *) - rewrite age_to_ghost_of. + unfold ext_compat; rewrite age_to_ghost_of. destruct extcompat as [? J]; eapply ghost_fmap_join in J; eexists; eauto. + (* lock sparsity *) @@ -583,7 +573,7 @@ Proof. -- intros c' Ec'; specialize (safety c' Ec'). apply jsafe_phi_fupd_age_to; auto. -- destruct safety as (q_new & Einit & safety). exists q_new; split; auto. - apply jsafe_phi_age_to; auto. + apply jsafe_phi_fupd_age_to; auto. + (* well_formedness *) rename j into Hj. intros j lj. diff --git a/concurrency/juicy/semax_safety_spawn.v b/concurrency/juicy/semax_safety_spawn.v index 9a75d3e06..12be2aa7b 100644 --- a/concurrency/juicy/semax_safety_spawn.v +++ b/concurrency/juicy/semax_safety_spawn.v @@ -10,18 +10,12 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.msl.age_to. -Require Import VST.veric.aging_lemmas. -Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. Require Import VST.veric.semax_prog. -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.Clight_core. Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. -Require Import VST.veric.semax_ext. Require Import VST.veric.juicy_extspec. Require Import VST.veric.juicy_safety. Require Import VST.veric.initial_world. @@ -30,14 +24,13 @@ Require Import VST.veric.tycontext. Require Import VST.veric.semax_ext. Require Import VST.veric.res_predicates. Require Import VST.veric.mem_lessdef. -Require Import VST.veric.age_to_resource_at. Require Import VST.veric.seplog. Require Import VST.floyd.coqlib3. Require Import VST.sepcomp.step_lemmas. Require Import VST.sepcomp.event_semantics. Require Import VST.sepcomp.semantics_lemmas. Require Import VST.concurrency.common.permjoin. -Require Import VST.concurrency.semax_conc. +Require Import VST.concurrency.juicy.semax_conc. Require Import VST.concurrency.juicy.juicy_machine. Require Import VST.concurrency.common.HybridMachineSig. Require Import VST.concurrency.common.scheduler. @@ -45,11 +38,7 @@ Require Import VST.concurrency.common.addressFiniteMap. Require Import VST.concurrency.common.permissions. Require Import VST.concurrency.juicy.JuicyMachineModule. Require Import VST.concurrency.juicy.sync_preds_defs. -Require Import VST.concurrency.juicy.sync_preds. Require Import VST.concurrency.juicy.join_lemmas. -(*Require Import VST.concurrency.cl_step_lemmas. -Require Import VST.concurrency.resource_decay_lemmas. -Require Import VST.concurrency.resource_decay_join.*) Require Import VST.concurrency.juicy.semax_invariant. Require Import VST.concurrency.juicy.semax_simlemmas. Require Import VST.concurrency.juicy.sync_preds. @@ -173,6 +162,16 @@ Proof. intro p. apply p. Qed. +Lemma set_ghost_join : forall a c w1 w2 w (J : join w1 w2 w) H1 H, + join a (ghost_of w2) c -> + join (set_ghost w1 a H1) w2 (set_ghost w c H). +Proof. + intros. + destruct (join_level _ _ _ J). + apply resource_at_join2; unfold set_ghost; intros; rewrite ?level_make_rmap, ?resource_at_make_rmap, ?ghost_of_make_rmap; auto. + apply resource_at_join; auto. +Qed. + Lemma safety_induction_spawn ge Gamma n state (CS : compspecs) (ext_link : string -> ident) @@ -230,9 +229,10 @@ Proof. (* intros (phix, (ts, ((((xf, xarg), globals), f_with_x), f_with_Pre))) (Hargsty, Pre). *) simpl (and _) in Post. destruct Pre as (phi0 & phi1 & jphi & A). simpl in A. - destruct A as (((PreA & _) & (PreB1 & PreB2 & [phi00 [phi01 [jphi0 [[Func Hphi00] fPRE]]]])) & necr). - simpl in fPRE. - rewrite seplog.sepcon_emp in fPRE. + destruct A as (((PreA & _) & (PreB1 & PreB2 & A)) & necr). + unfold SeparationLogic.argsassert2assert, canon.SEPx, client_lemmas.func_ptr' in A; simpl in A. + rewrite seplog.corable_andp_sepcon1, log_normalize.emp_sepcon, seplog.sepcon_emp in A by apply SeparationLogic.corable_func_ptr. + destruct A as [Func fPre]. clear Heq_name. @@ -242,10 +242,6 @@ Proof. { rewrite <-li. apply join_sub_level. eexists; eauto. } assert (l0 : level phi0 = S n). { rewrite <-li. apply join_sub_level. eexists; eauto. } - assert (l00 : level phi00 = S n). - { rewrite <-l0. apply join_sub_level. eexists; eauto. } - assert (l01 : level phi01 = S n). - { rewrite <-l0. apply join_sub_level. eexists; eauto. } Import SeparationLogic Clight_initial_world Clightdefs. (* Import VericMinimumSeparationLogic.CSHL_Defs *) (* Import SeparationLogicSoundness.VericSound.CSHL_Defs. *) @@ -274,11 +270,10 @@ Proof. set (NEP := NEP_); set (NEQ := NEQ_) end. - assert (gam0 : matchfunspecs ge Gamma phi00). { + assert (gam0 : matchfunspecs ge Gamma phi0). { revert gam. apply pures_same_matchfunspecs. join_level_tac. apply pures_same_sym, join_sub_pures_same. - apply join_sub_trans with phi0. eexists; eassumption. apply join_sub_trans with (getThreadR i tp cnti). exists phi1. auto. join_sub_tac. } @@ -289,10 +284,13 @@ Proof. destruct FAT as (gs & Hsub & FAT'). specialize (gam0 _ _ _ (necR_refl _) (ext_refl _) FAT'). destruct gam0 as (id_fun & fs0 & [? Eid] & Hsub0). + pose proof (funspec_sub_si_trans fs0 gs (mk_funspec fsig cc A P Q NEP NEQ) phi0) as Hsub1. + spec Hsub1. { split; auto. } + clear Hsub Hsub0. destruct fs0 as [sig' cc' A' P' Q' NEP' NEQ']. assert (sig' = fsig /\ cc' = cc) as []; subst. { destruct gs; simpl in *. - destruct Hsub0 as [[] _], Hsub as [[] _]; subst; auto. } + destruct Hsub1 as [[] _]; subst; auto. } pose proof semax_prog_entry_point (Concurrent_Espec unit CS ext_link) V Gamma prog f_b id_fun (tptr tvoid :: nil) (b :: nil) A' P' Q' NEP' NEQ' 0 ora (allows_exit ext_link) semaxprog as HEP. @@ -391,12 +389,12 @@ specialize (all_coh0 (b, Ptrofs.unsigned i0)); spec all_coh0; auto. (Vptr f_b Ptrofs.zero) b phi0) m Phi). { split; try apply compat. - clear -jphi compat. destruct compat as [jj jj']. simpl in jphi. - rewrite join_all_joinlist in *. - rewrite maps_addthread. - rewrite maps_updthread. - rewrite (maps_getthread _ _ cnti) in jj. - rewrite joinlist_merge; eauto. + * clear -jphi compat extcompat. destruct compat as [jj jj']. simpl in jphi. + rewrite join_all_joinlist in *. + rewrite maps_addthread. + rewrite maps_updthread. + rewrite (maps_getthread _ _ cnti) in jj. + rewrite joinlist_merge; eauto. } apply (@mem_compatible_with_age _ n) in compat'. @@ -410,7 +408,7 @@ specialize (all_coh0 (b, Ptrofs.unsigned i0)); spec all_coh0; auto. - (* env_coherence *) apply env_coherence_age_to; auto. - - rewrite age_to_ghost_of. + - unfold ext_compat; rewrite age_to_ghost_of. destruct extcompat as [? J]; eapply ghost_fmap_join in J; eexists; eauto. - (* lock sparsity *) @@ -441,139 +439,87 @@ specialize (all_coh0 (b, Ptrofs.unsigned i0)); spec all_coh0; auto. { destruct (Initcore (jm_ cnti compat)) as [? Hinit]; apply Hinit. } intros jm. REWR. rewrite gssAddRes by reflexivity. - specialize (Safety jm ts). +(* specialize (Safety jm ts). *) intros Ejm. - destruct ora; eapply Safety. - * rewrite Ejm. - (* need to use funspec_sub *) - eapply args_cond_approx_eq_app with (y := (b, f_with_x)). - - (* cond_approx_eq *) - eauto. - - (* level *) - rewrite level_age_to. lia. cleanup. lia. - - (* PROP / LOCAL / SEP *) - simpl. - apply age_to_pred. - split. - - (* nothing in PROP *) - now constructor. - - split. - unfold SeparationLogic.local, lift1. - - split. - - -- (* LOCAL 1 : value of xarg *) - split. - simpl. - unfold liftx, lift. simpl. - unfold eval_id in *. - unfold val_lemmas.force_val in *. - unfold te_of in *. - unfold construct_rho in *. - unfold make_tenv in *. - unfold Map.get in *. - rewrite PTree.gss. - reflexivity. - do 8 red. intro Hx; subst; contradiction PreA. - - - -- (* LOCAL 2 : locald_denote of global variables *) - split3. hnf. - clear - PreB3. destruct PreB3 as [PreB3 _]. - hnf in PreB3. rewrite PreB3; clear PreB3. - unfold Map.get, make_ext_args. unfold env_set. - unfold ge_of. - unfold filter_genv. - extensionality i. unfold Genv.find_symbol. simpl. auto. - - - -- (* SEP: only precondition of spawned condition *) - unfold canon.SEPx in *. - simpl. - rewrite seplog.sepcon_emp. - destruct fPRE; assumption. - * (* funnassert *) - rewrite Ejm. - apply funassert_pures_eq with Phi. + (* do a fupd to satisfy the spawned function's precondition *) + apply (semax_lemmas.assert_safe1_fupd (globalenv prog) _ q_new). + destruct Hsub1 as [_ Hsub1]. + specialize (Hsub1 (age_to n phi0)); spec Hsub1. + { destruct (nec_refl_or_later _ _ (age_to_necR n phi0)) as [Heq | ]; auto. + apply (f_equal level) in Heq; rewrite level_age_to, l0 in Heq; lia. } + specialize (Hsub1 ts (b, f_with_x) (filter_genv (symb2genv (genv_symb_injective (globalenv prog))), b :: nil) _ (le_refl _) _ _ (necR_refl _) (ext_refl _)). + spec Hsub1. + { split. + * repeat constructor; simpl. + destruct b; try contradiction; simpl; auto. + * eapply pred_nec_hereditary; [apply age_to_necR|]. + unfold P; rewrite sepcon_emp; split3; constructor; auto. } + assert (app_pred (fungassert (nofunc_tycontext V Gamma) (filter_genv (globalenv prog), b :: nil)) (age_to n phi0)) as Hfung. + { apply fungassert_pures_eq with Phi. { rewrite level_age_to. lia. cleanup. lia. } - { apply pures_same_eq_l with phi0. 2: now apply pures_eq_age_to; lia. + { apply pures_same_eq_l with phi0, pures_eq_age_to; [|lia]. apply join_sub_pures_same. subst. apply join_sub_trans with (getThreadR i tp cnti). exists phi1; auto. apply compatible_threadRes_sub, compat. } - apply FA. - * rewrite Ejm; simpl. - rewrite age_to_ghost_of. - destruct ora. - eapply join_sub_joins_trans, ext_join_approx, extcompat. - destruct (compatible_threadRes_sub cnti (juice_join compat)). - eapply join_sub_trans. - -- eexists; apply ghost_fmap_join, ghost_of_join; eauto. - -- eexists; apply ghost_fmap_join, ghost_of_join; eauto. + apply FA. } + pose proof (conj Hfung Hsub1) as Hpre; eapply fupd.fupd_andp_corable in Hpre; [|apply corable_fungassert]. + rewrite Ejm; eapply fupd.fupd_mono, Hpre. + intros ? (? & ? & ? & F & HP & _) [] ? Hext ??; subst. + rewrite predicates_sl.sepcon_comm in HP. + destruct ora; eapply jm_fupd_intro', Safety; auto. + eapply predicates_sl.sepcon_derives, HP; eauto. + (* safety of spawning thread *) subst j. REWR. unshelve erewrite (@gsoAddCode _ _ _ _ _ _ _ i); auto. REWR. REWR. unshelve erewrite (@gsoAddRes _ _ _ _ _ _ _ i); auto. REWR. intros c' afterex jm Ejm. - specialize (Post None jm ora n Hargsty Logic.I (le_refl _)). + specialize (Post None jm ora Hargsty Logic.I). spec Post. (* Hrel *) - { split. rewrite <-level_m_phi, Ejm. symmetry. apply level_age_to. cleanup; lia. - rewrite <-!level_m_phi. rewrite m_phi_jm_, Ejm. split. + { unfold Hrel. rewrite <-!level_m_phi. rewrite m_phi_jm_, Ejm. split. rewrite level_age_to. cleanup; lia. cleanup; lia. apply pures_same_eq_l with phi1. apply join_sub_pures_same. exists phi0. auto. apply pures_eq_age_to. lia. } spec Post. (* Postcondition *) - { exists (age_to n phi00), (age_to n phi1); split; [ | split3]. - - rewrite Ejm. apply age_to_join. auto. - - split; auto. split; auto. split. - apply prop_app_pred; auto. - unfold canon.SEPx in *. simpl. - apply age_to_pred. auto. + { exists (core (age_to n phi1)), (age_to n phi1); split3. + - rewrite Ejm. apply core_unit. + - split; auto. split; auto. split; [constructor|]. + setoid_rewrite emp_no; intros ?; apply resource_at_core_identity. - simpl. apply necR_trans with phi1; [ |apply age_to_necR]. destruct necr; auto. - - destruct necr as [? JOINS]. - rewrite Ejm, age_to_ghost_of. - destruct ora. - eapply join_sub_joins_trans; [|apply ext_join_approx, JOINS]. - eexists; apply ghost_fmap_join, ghost_of_join; eauto. } destruct Post as (c'_ & afterex_ & safe'). assert (c'_ = c'). { cut (Some c'_ = Some c'). congruence. rewrite <-afterex, <-afterex_. reflexivity. } subst c'_. - apply safe'. + destruct ora; apply safe'. + assert (cntj : containsThread tp j). { apply cnt_age, cntAdd' in lj. destruct lj as [[lj ?] | lj ]. apply lj. simpl in lj. tauto. } specialize (safety j cntj ora). + destruct ora. REWR. REWR. REWR. REWR. destruct (getThreadC j tp cntj) eqn:Ej. -- edestruct (unique_Krun_neq(ge := globalenv prog) i j); eauto. - -- apply jsafe_phi_age_to; auto. apply jsafe_phi_downward. + -- apply jsafe_phi_age_to; auto. unshelve erewrite gsoAddRes; auto. REWR. -- intros c' Ec'; specialize (safety c' Ec'). - apply jsafe_phi_bupd_age_to; auto. apply jsafe_phi_bupd_downward. + apply jsafe_phi_fupd_age_to; auto. unshelve erewrite gsoAddRes; auto. REWR. - -- destruct safety as (? & c_new & Einit & safety). - split; auto. + -- destruct safety as (c_new & Einit & safety). exists c_new; split; auto. unshelve erewrite gsoAddRes; auto. REWR. - apply jsafe_phi_age_to; auto. apply jsafe_phi_downward, safety. + apply jsafe_phi_fupd_age_to; auto. - (* wellformed *) intros j cntj. destruct (eq_dec j tp.(num_threads).(pos.n)); [ | destruct (eq_dec i j)]. - + subst j. REWR. rewrite gssAddCode. 2:reflexivity. constructor. + + subst j. REWR. rewrite gssAddCode by reflexivity. constructor. + subst j. REWR. REWR. REWR. unfold cl_at_external; simpl. split; congruence. + assert (cntj' : containsThread tp j). @@ -585,7 +531,7 @@ specialize (all_coh0 (b, Ptrofs.unsigned i0)); spec all_coh0; auto. (* rewrite no_Krun_age_tp_to. *) intros j cntj q. destruct (eq_dec j tp.(num_threads).(pos.n)); [ | destruct (eq_dec i j)]. - + subst j. REWR. rewrite gssAddCode. 2:reflexivity. clear; congruence. + + subst j. REWR. rewrite gssAddCode by reflexivity. clear; congruence. + subst j. REWR. REWR. REWR. clear; congruence. + assert (cntj' : containsThread tp j). { apply cnt_age, cntAdd' in cntj. destruct cntj as [[lj ?] | lj ]. apply lj. simpl in lj. tauto. } @@ -593,4 +539,4 @@ specialize (all_coh0 (b, Ptrofs.unsigned i0)); spec all_coh0; auto. eapply unique_Krun_no_Krun. eassumption. instantiate (1 := cnti). rewr (getThreadC i tp cnti). congruence. -Admitted. (* safety_induction_spawn *) +Qed. (* safety_induction_spawn *) diff --git a/concurrency/juicy/semax_simlemmas.v b/concurrency/juicy/semax_simlemmas.v index 36ffa1186..88a03391a 100644 --- a/concurrency/juicy/semax_simlemmas.v +++ b/concurrency/juicy/semax_simlemmas.v @@ -10,19 +10,12 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.msl.age_to. -Require Import VST.veric.aging_lemmas. -Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. Require Import VST.veric.semax_prog. -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.Clight_core. Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. -Require Import VST.veric.semax_ext. -Require Import VST.veric.juicy_extspec. Require Import VST.veric.initial_world. Require Import VST.veric.juicy_extspec. Require Import VST.veric.juicy_safety. @@ -30,7 +23,6 @@ Require Import VST.veric.tycontext. Require Import VST.veric.semax_ext. Require Import VST.veric.res_predicates. Require Import VST.veric.mem_lessdef. -Require Import VST.veric.age_to_resource_at. Require Import VST.veric.seplog. Require Import VST.floyd.coqlib3. Require Import VST.sepcomp.step_lemmas. @@ -49,14 +41,11 @@ Require Import VST.concurrency.juicy.sync_preds_defs. Require Import VST.concurrency.juicy.sync_preds. Require Import VST.concurrency.juicy.join_lemmas. Require Import VST.concurrency.common.lksize. -(*Require Import VST.concurrency.cl_step_lemmas.*) -Require Import VST.concurrency.juicy.resource_decay_lemmas. -Require Import VST.concurrency.juicy.resource_decay_join. +(*Require Import VST.concurrency.juicy.resource_decay_lemmas. +Require Import VST.concurrency.juicy.resource_decay_join.*) Require Import VST.concurrency.juicy.semax_invariant. -Require Import VST.veric.Clight_aging_lemmas. Import Clight_initial_world. Import Clight_seplog. -Import ghost_PCM. Set Bullet Behavior "Strict Subproofs". @@ -369,6 +358,25 @@ Proof. rewrite <-resource_at_approx, SP. reflexivity. Qed. +Lemma fungassert_funassert : forall G rho, fungassert G rho = funassert G (mkEnviron (fst rho) (Map.empty _) (Map.empty _)). +Proof. + reflexivity. +Qed. + +Lemma fungassert_pures_eq G rho phi1 phi2 : + (level phi1 >= level phi2)%nat -> + pures_eq phi1 phi2 -> + app_pred (fungassert G rho) phi1 -> + app_pred (fungassert G rho) phi2. +Proof. + rewrite fungassert_funassert; apply funassert_pures_eq. +Qed. + +Lemma corable_fungassert : forall G rho, corable (fungassert G rho). +Proof. + intros; rewrite fungassert_funassert; apply Clight_assert_lemmas.corable_funassert. +Qed. + Lemma env_coherence_hered Z Jspec ge G : hereditary age (@env_coherence Z Jspec ge G). Proof. @@ -958,17 +966,11 @@ Qed. (lock_sparse : lock_sparsity (lset tp)) (lock_coh : lock_coherence' tp PHI m mcompat) (safety : exists i (cnti : containsThread tp i), let phi := getThreadR cnti in - (exists k, getThreadC cnti = Krun k /\ - forall c, join_sub (Some (ext_ref tt, NoneP) :: nil) c -> - joins (ghost_of phi) (ghost_fmap (approx (level phi)) (approx (level phi)) c) -> - exists b, joins b (ghost_fmap (approx (level phi)) (approx (level phi)) c) /\ - exists phi' (Hr : resource_at phi' = resource_at phi), level phi' = level phi /\ ghost_of phi' = b /\ - forall ora, jsafeN Jspec ge ora k - (personal_mem (mem_cohere'_res _ _ _ (compatible_threadRes_cohere cnti (mem_compatible_forget mcompat)) Hr))) /\ + (exists k, getThreadC cnti = Krun k /\ fupd (semax_lemmas.assert_safe1 ge k) phi) /\ forall j (cntj : containsThread tp j), j <> i -> thread_safety Jspec m ge tp PHI mcompat j cntj) (wellformed : threads_wellformed tp) (uniqkrun : unique_Krun tp sch), - state_bupd (state_invariant Jspec Gamma n) (m, (tr, sch, tp)). + state_fupd (state_invariant Jspec Gamma n) (m, (tr, sch, tp)). Proof. intros; apply state_inv_upd with (mcompat := mcompat); auto; intros. destruct safety as (i & cnti & [(k & Hk & Hsafe) Hrest]). diff --git a/concurrency/juicy/semax_to_dry_machine.v b/concurrency/juicy/semax_to_dry_machine.v new file mode 100644 index 000000000..12435c696 --- /dev/null +++ b/concurrency/juicy/semax_to_dry_machine.v @@ -0,0 +1,713 @@ +(* Instead of deriving a juicy-machine execution from the CSL proof, we derive a dry-machine execution + directly, along the lines of the sequential adequacy proof (veric/SequentialClight). *) +Require Import Coq.Strings.String. + +Require Import compcert.lib.Integers. +Require Import compcert.common.AST. +Require Import compcert.cfrontend.Clight. +Require Import compcert.common.Globalenvs. +Require Import compcert.common.Memory. +Require Import compcert.common.Memdata. +Require Import compcert.common.Values. + +Require Import VST.msl.Coqlib2. +Require Import VST.msl.eq_dec. +Require Import VST.veric.external_state. +Require Import VST.veric.juicy_mem. +Require Import VST.veric.juicy_mem_lemmas. +Require Import VST.veric.semax_prog. +Require Import VST.veric.Clight_core. +Require Import VST.veric.Clightcore_coop. +Require Import VST.veric.semax. +Require Import VST.veric.semax_ext. +Require Import VST.veric.semax_lemmas. +Require Import VST.veric.juicy_extspec. +Require Import VST.veric.initial_world. +Require Import VST.veric.juicy_extspec. +Require Import VST.veric.tycontext. +Require Import VST.veric.res_predicates. +Require Import VST.veric.SequentialClight. +Require Import VST.floyd.coqlib3. +Require Import VST.floyd.canon. +Require Import VST.sepcomp.step_lemmas. +Require Import VST.sepcomp.event_semantics. +Require Import VST.sepcomp.extspec. +Require Import VST.concurrency.juicy.semax_conc_pred. +Require Import VST.concurrency.juicy.semax_conc. +(*Require Import VST.concurrency.juicy.juicy_machine.*) +Require Import VST.concurrency.common.threadPool. +Require Import VST.concurrency.common.HybridMachineSig. +Require Import VST.concurrency.common.HybridMachine. +Require Import VST.concurrency.common.scheduler. +Require Import VST.concurrency.common.addressFiniteMap. +Require Import VST.concurrency.common.permissions. +Require Import VST.concurrency.common.ClightSemanticsForMachines. +(*Require Import VST.concurrency.juicy.JuicyMachineModule. +Require Import VST.concurrency.juicy.sync_preds_defs. +Require Import VST.concurrency.juicy.sync_preds. +Require Import VST.concurrency.juicy.join_lemmas. +Require Import VST.concurrency.juicy.semax_invariant. +Require Import VST.concurrency.juicy.semax_initial. +Require Import VST.concurrency.juicy.semax_progress. +Require Import VST.concurrency.juicy.semax_preservation_jspec. +Require Import VST.concurrency.juicy.semax_safety_makelock. +Require Import VST.concurrency.juicy.semax_safety_spawn. +Require Import VST.concurrency.juicy.semax_safety_release. +Require Import VST.concurrency.juicy.semax_safety_freelock. +Require Import VST.concurrency.juicy.semax_preservation. +Require Import VST.concurrency.juicy.semax_simlemmas.*) +Require Import VST.concurrency.common.dry_machine_lemmas. +Require Import VST.concurrency.common.dry_machine_step_lemmas. +Import ThreadPool. + +Set Bullet Behavior "Strict Subproofs". + +Ltac absurd_ext_link_naming := + exfalso; + match goal with + | H : Some (_ _, _) = _ |- _ => + rewrite <- ?H in * + end; + unfold funsig2signature in *; + match goal with + | H : Some (?ext_link ?a, ?b) <> Some (?ext_link ?a, ?b') |- _ => + simpl in H; [contradiction || congruence] + | H : Some (?ext_link ?a, ?c) = Some (?ext_link ?b, ?d) |- _ => + simpl in H; + match goal with + | ext_link_inj : forall s1 s2, ext_link s1 = ext_link s2 -> s1 = s2 |- _ => + assert (a = b) by (apply ext_link_inj; congruence); congruence + end + end. + +Ltac funspec_destruct s := + simpl (extspec.ext_spec_pre _); simpl (extspec.ext_spec_type _); simpl (extspec.ext_spec_post _); + unfold funspec2pre, funspec2post; + let Heq_name := fresh "Heq_name" in + destruct (oi_eq_dec (Some (_ s, _)) (ef_id_sig _ (EF_external _ _))) + as [Heq_name | Heq_name]; try absurd_ext_link_naming. + +(*+ Final instantiation *) + +Record CSL_proof := { + CSL_Σ : gFunctors; + CSL_prog : Clight.program; + CSL_CS: compspecs; + CSL_V : varspecs; + CSL_G : @funspecs CSL_Σ; + CSL_ext_link : string -> ident; + CSL_ext_link_inj : forall s1 s2, CSL_ext_link s1 = CSL_ext_link s2 -> s1 = s2; + CSL_all_safe : forall (HH : heapGS CSL_Σ) (HE : externalGS unit CSL_Σ) (HL : lockGS CSL_Σ), @semax_prog _ HH (Concurrent_Espec unit CSL_CS CSL_ext_link) + HE CSL_CS CSL_prog tt CSL_V CSL_G; + CSL_init_mem_not_none : Genv.init_mem CSL_prog <> None; + }. + +(* +Definition Clight_init_state (prog:Ctypes.program function) main_symb f_main init_mem := + State Clight_safety.main_handler + (Scall None (Etempvar BinNums.xH (type_of_fundef f_main)) + (List.map (fun x : AST.ident * Ctypes.type => Etempvar (fst x) (snd x)) + (Clight_new.params_of_types (BinNums.xO BinNums.xH) + (Clight_new.params_of_fundef f_main)))) + (Kseq (Sloop Sskip Sskip) Kstop) empty_env + (temp_bindings BinNums.xH (cons main_symb nil)) init_mem. +*) + +Section Safety. + Variable CPROOF: CSL_proof. + Definition Σ := CPROOF.(CSL_Σ). + Definition CS := CPROOF.(CSL_CS). + Definition V := CPROOF.(CSL_V). + Definition G := CPROOF.(CSL_G). + Definition ext_link := CPROOF.(CSL_ext_link). + Definition ext_link_inj := CPROOF.(CSL_ext_link_inj). + Definition prog := CPROOF.(CSL_prog). + Definition all_safe := CPROOF.(CSL_all_safe). + Definition init_mem_not_none := CPROOF.(CSL_init_mem_not_none). + Definition ge := Clight.globalenv CPROOF.(CSL_prog). + + Definition init_mem : {m : mem | Genv.init_mem (CSL_prog CPROOF) = Some m}. + Proof. + pose proof init_mem_not_none. + destruct (Genv.init_mem (CSL_prog CPROOF)); last done. + eauto. + Defined. + + Local Instance CEspec (HH : heapGS Σ) (HE : externalGS unit Σ) (HL : lockGS Σ) : OracleKind := + Concurrent_Espec unit CS ext_link. + + Lemma CEspec_cases : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} e + (x : ext_spec_type (concurrent_ext_spec unit CS ext_link) e), + e = LOCK \/ e = UNLOCK \/ e = MKLOCK \/ e = FREE_LOCK \/ e = CREATE. + Proof. + intros. + simpl in x. + repeat (if_tac in x; [destruct e; try done; inversion H as [H1]; apply ext_link_inj in H1 as <-; auto + | clear H]); last done. + Qed. + + (* funspecs_destruct isn't working well, so prove a spec lemma for each function *) + Ltac next_spec := subst; let Hspecs := fresh "Hspecs" in match goal with |-context[add_funspecs_rec _ _ _ ?l] => + destruct l eqn: Hspecs; first done; + injection Hspecs; clear Hspecs; intros Hspecs <-; simpl; + unfold funspec2pre, funspec2post, ef_id_sig; simpl; if_tac end. + + Ltac solve_spec x := intros; revert x; + unfold ext_spec_post, OK_spec, CEspec, Concurrent_Espec, concurrent_ext_spec; + pose proof ext_link_inj as Hinj; fold ext_link in Hinj; + repeat (next_spec; first absurd_ext_link_naming); next_spec; last done; + intros; split; [|intros (? & Heq & ?)]; eauto; + inversion Heq as [Heq0 Heq']; apply inj_pair2 in Heq'; subst; auto. + + Lemma CEspec_acquire_pre : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} x args z m, + ext_spec_pre OK_spec LOCK x (genv_symb_injective ge) (sig_args (ef_sig LOCK)) args z m <-> + match acquire_spec with mk_funspec _ _ A P _ => exists x'', JMeq.JMeq x x'' /\ funspec2pre' _ A P x'' (genv_symb_injective ge) (sig_args (ef_sig LOCK)) args z m end. + Proof. + solve_spec x. + Qed. + + Lemma CEspec_acquire_post : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} x ret z m, + ext_spec_post OK_spec LOCK x (genv_symb_injective ge) (sig_res (ef_sig LOCK)) ret z m <-> + match acquire_spec with mk_funspec _ _ A _ Q => exists x'', JMeq.JMeq x x'' /\ funspec2post' _ A Q x'' (genv_symb_injective ge) (sig_res (ef_sig LOCK)) ret z m end. + Proof. + solve_spec x. + Qed. + + Lemma CEspec_release_pre : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} x args z m, + ext_spec_pre OK_spec UNLOCK x (genv_symb_injective ge) (sig_args (ef_sig UNLOCK)) args z m <-> + match release_spec with mk_funspec _ _ A P _ => exists x'', JMeq.JMeq x x'' /\ funspec2pre' _ A P x'' (genv_symb_injective ge) (sig_args (ef_sig UNLOCK)) args z m end. + Proof. + solve_spec x. + Qed. + + Lemma CEspec_release_post : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} x ret z m, + ext_spec_post OK_spec UNLOCK x (genv_symb_injective ge) (sig_res (ef_sig UNLOCK)) ret z m <-> + match release_spec with mk_funspec _ _ A _ Q => exists x'', JMeq.JMeq x x'' /\ funspec2post' _ A Q x'' (genv_symb_injective ge) (sig_res (ef_sig UNLOCK)) ret z m end. + Proof. + solve_spec x. + Qed. + + Lemma CEspec_makelock_pre : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} x args z m, + ext_spec_pre OK_spec MKLOCK x (genv_symb_injective ge) (sig_args (ef_sig MKLOCK)) args z m <-> + match makelock_spec CS with mk_funspec _ _ A P _ => exists x'', JMeq.JMeq x x'' /\ funspec2pre' _ A P x'' (genv_symb_injective ge) (sig_args (ef_sig MKLOCK)) args z m end. + Proof. + solve_spec x. + Qed. + + Lemma CEspec_makelock_post : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} x ret z m, + ext_spec_post OK_spec MKLOCK x (genv_symb_injective ge) (sig_res (ef_sig MKLOCK)) ret z m <-> + match makelock_spec CS with mk_funspec _ _ A _ Q => exists x'', JMeq.JMeq x x'' /\ funspec2post' _ A Q x'' (genv_symb_injective ge) (sig_res (ef_sig MKLOCK)) ret z m end. + Proof. + solve_spec x. + Qed. + + Lemma CEspec_freelock_pre : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} x args z m, + ext_spec_pre OK_spec FREE_LOCK x (genv_symb_injective ge) (sig_args (ef_sig FREE_LOCK)) args z m <-> + match freelock_spec CS with mk_funspec _ _ A P _ => exists x'', JMeq.JMeq x x'' /\ funspec2pre' _ A P x'' (genv_symb_injective ge) (sig_args (ef_sig FREE_LOCK)) args z m end. + Proof. + solve_spec x. + Qed. + + Lemma CEspec_freelock_post : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} x ret z m, + ext_spec_post OK_spec FREE_LOCK x (genv_symb_injective ge) (sig_res (ef_sig FREE_LOCK)) ret z m <-> + match freelock_spec CS with mk_funspec _ _ A _ Q => exists x'', JMeq.JMeq x x'' /\ funspec2post' _ A Q x'' (genv_symb_injective ge) (sig_res (ef_sig FREE_LOCK)) ret z m end. + Proof. + solve_spec x. + Qed. + + Lemma CEspec_spawn_pre : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} x args z m, + ext_spec_pre OK_spec CREATE x (genv_symb_injective ge) (sig_args (ef_sig CREATE)) args z m <-> + match spawn_spec with mk_funspec _ _ A P _ => exists x'', JMeq.JMeq x x'' /\ funspec2pre' _ A P x'' (genv_symb_injective ge) (sig_args (ef_sig CREATE)) args z m end. + Proof. + solve_spec x. + Qed. + + Lemma CEspec_spawn_post : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} x ret z m, + ext_spec_post OK_spec CREATE x (genv_symb_injective ge) (sig_res (ef_sig CREATE)) ret z m <-> + match spawn_spec with mk_funspec _ _ A _ Q => exists x'', JMeq.JMeq x x'' /\ funspec2post' _ A Q x'' (genv_symb_injective ge) (sig_res (ef_sig CREATE)) ret z m end. + Proof. + solve_spec x. + Qed. + + Program Definition spr (HH : heapGS Σ) (HE : externalGS unit Σ) (HL : lockGS Σ) := + semax_prog_rule V G prog + (proj1_sig init_mem) 0 tt _ (all_safe HH HE HL) (proj2_sig init_mem). + Next Obligation. + Proof. intros ???????; apply I. Qed. + + Instance Sem : Semantics := ClightSemanticsForMachines.ClightSem (Clight.globalenv CPROOF.(CSL_prog)). + + Existing Instance HybridMachineSig.HybridCoarseMachine.DilMem. + Existing Instance HybridMachineSig.HybridCoarseMachine.scheduler. + + (* If there are enough of these conditions, re-split out into semax_invariant. *) + Definition dtp := t(ThreadPool := @OrdinalPool.OrdinalThreadPool dryResources Sem). + +(* (* We want to enforce additional coherence properties between the rmap and the memory, accounting + for the effects of locks (and other things?). *) + Definition lock_coherent_loc m loc (r : dfrac * option resource) : Prop := + match r.2 with + | Some (LK _ _ b) => Mem.load Mptr m loc.1 loc.2 = Some (Vptrofs (if b then Ptrofs.zero else Ptrofs.one)) + | _ => True + end. + + Definition lock_coherent m σ := forall loc, lock_coherent_loc m loc (σ @ loc). + + Definition mem_auth' `{!heapGS Σ} m := ∃ σ, ⌜coherent m σ ∧ lock_coherent m σ⌝ ∧ resource_map.resource_map_auth(H0 := gen_heapGpreS_heap(gen_heapGpreS := gen_heap_inG)) (gen_heap_name _) 1 σ. + Definition state_interp' {Z} `{!heapGS Σ} `{!externalGS Z Σ} m z := mem_auth' m ∗ ext_auth z.*) + + (* Each thread needs to be safe given only its fragment (access_map) of the shared memory. We use + the starting max permissions as an upper bound on the max permissions of the state_interp. *) + Program Definition jsafe_perm_pre `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} (max : access_map) + (jsafe : coPset -d> OK_ty -d> CC_core -d> access_map -d> iPropO Σ) : coPset -d> OK_ty -d> CC_core -d> access_map -d> iPropO Σ := λ E z c p, + |={E}=> ∀ m (Hlt : permMapLt p (getMaxPerm m)), ⌜permMapLt (getMaxPerm m) max⌝ → state_interp(*'*) m z -∗ + (∃ i, ⌜halted (cl_core_sem ge) c i ∧ ext_spec_exit OK_spec (Some (Vint i)) z m⌝) ∨ + (|={E}=> ∃ c' m', ⌜corestep (cl_core_sem ge) c (restrPermMap Hlt) c' m'⌝ ∧ (∃ p' (Hlt' : permMapLt p' (getMaxPerm m')), state_interp(*'*) (restrPermMap Hlt') z) (* ?? *) ∗ ▷ jsafe E z c' (getCurPerm m')) ∨ + (∃ e args x, ⌜at_external (cl_core_sem ge) c (restrPermMap Hlt) = Some (e, args) ∧ ext_spec_pre OK_spec e x (genv_symb_injective ge) (sig_args (ef_sig e)) args z (restrPermMap Hlt)⌝ ∧ + ▷ (∀ ret m' z', ⌜Val.has_type_list args (sig_args (ef_sig e)) ∧ Builtins0.val_opt_has_rettype ret (sig_res (ef_sig e))⌝ → + ⌜ext_spec_post OK_spec e x (genv_symb_injective ge) (sig_res (ef_sig e)) ret z' m'⌝ → |={E}=> + ∃ c', ⌜after_external (cl_core_sem ge) ret c m' = Some c'⌝ ∧ state_interp(*'*) m' z' ∗ jsafe E z' c' (getCurPerm m'))). + + Local Instance jsafe_perm_pre_contractive `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} max : Contractive (jsafe_perm_pre max). + Proof. + rewrite /jsafe_perm_pre => n jsafe jsafe' Hsafe E z c p. + do 16 f_equiv. + - f_contractive; repeat f_equiv. apply Hsafe. + - f_contractive; repeat f_equiv. apply Hsafe. + Qed. + + Local Definition jsafe_perm_def `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} max : coPset -> unit -> CC_core -> access_map -> mpred := fixpoint (jsafe_perm_pre max). + Local Definition jsafe_perm_aux `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} : seal (jsafe_perm_def). Proof. by eexists. Qed. + Definition jsafe_perm `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} := jsafe_perm_aux.(unseal). + Local Lemma jsafe_perm_unseal `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} : jsafe_perm = jsafe_perm_def. + Proof. rewrite -jsafe_perm_aux.(seal_eq) //. Qed. + + Lemma jsafe_perm_unfold `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} max E z c p : jsafe_perm max E z c p ⊣⊢ jsafe_perm_pre max (jsafe_perm max) E z c p. + Proof. rewrite jsafe_perm_unseal. apply (fixpoint_unfold (@jsafe_perm_pre heapGS0 externalGS0 lockGS0 max)). Qed. + + Lemma jsafe_perm_mono : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} p1 p2 E z c p, permMapLt p2 p1 -> + jsafe_perm p1 E z c p ⊢ jsafe_perm p2 E z c p. + Proof. + intros. + iLöb as "IH" forall (p H z c). + rewrite !jsafe_perm_unfold /jsafe_perm_pre. + iIntros ">H !>" (?? Hmax) "S". + pose proof (PreOrder_Transitive _ _ _ Hmax H). + iDestruct ("H" with "[%] S") as "[H | [H | H]]"; first done. + - iLeft; done. + - iRight; iLeft. + iMod "H" as (???) "(? & ?)". + iIntros "!>"; iExists _, _; iSplit; first done; iFrame. + by iApply "IH". + - iRight; iRight. + iDestruct "H" as (????) "H". + iExists _, _, _; iSplit; first done. + iNext; iIntros (?????). + iMod ("H" with "[%] [%]") as (??) "(? & ?)"; [done..|]. + iIntros "!>"; iExists _; iSplit; first done; iFrame. + by iApply "IH". + Qed. + + Existing Instance mem_equiv.access_map_equiv_Equivalence. + + Lemma jsafe_perm_equiv : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} p E z c p1 p2, mem_equiv.access_map_equiv p1 p2 -> + jsafe_perm p E z c p1 ⊢ jsafe_perm p E z c p2. + Proof. + intros. + iLöb as "IH" forall (p z c p1 p2 H). + rewrite !jsafe_perm_unfold /jsafe_perm_pre. + iIntros ">H !>" (?? Hmax) "S". + assert (permMapLt p1 (getMaxPerm m)) as Hlt1. + { eapply mem_equiv.permMapLt_equiv; done. } + iDestruct ("H" $! _ Hlt1 with "[%] S") as "[H | [H | H]]"; first done. + - iLeft; done. + - iRight; iLeft. + iMod "H" as (???) "(S & Hsafe)". + assert (exists m2', corestep (cl_core_sem ge) c (restrPermMap Hlt) c' m2' /\ mem_equiv.mem_equiv m2' m') as (m2' & ? & Heq') by admit. + iIntros "!>"; iExists _, _; iSplit; first done. + iSplitL "S". + + iDestruct "S" as (??) "S". + assert (permMapLt p' (getMaxPerm m2')) as Hlt2'. + { eapply mem_equiv.permMapLt_equiv; [done | by apply mem_equiv.max_eqv | done]. } + iExists _, Hlt2'. + (* Do I need to add a mem_equiv to jsafe_perm? Can the init step change the shape of the memory? *) + admit. + + iApply ("IH" with "[%] Hsafe"). + by apply mem_equiv.cur_eqv. + - iRight; iRight. + iDestruct "H" as (????) "H". +(* + iExists _, _, _; iSplit; first done. + iNext; iIntros (?????). + iMod ("H" with "[%] [%]") as (??) "(? & ?)"; [done..|]. + iIntros "!>"; iExists _; iSplit; first done; iFrame. + by iApply "IH". + Qed.*) + Admitted. + + Lemma jsafe_jsafe_perm : forall `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} max E z c p, p = max -> + jsafe(genv_symb := genv_symb_injective) (cl_core_sem ge) (concurrent_ext_spec unit CS ext_link) ge E z c ⊢ jsafe_perm max E z c p. + Proof. + intros. + iLöb as "IH" forall (p H z c). + rewrite jsafe_unfold jsafe_perm_unfold /jsafe_pre /jsafe_perm_pre. + iIntros ">H !>" (?? Hmax) "S". + subst; pose proof (partial_order_antisym mem_equiv.permMapLt_order _ _ Hlt Hmax) as Heq. +(* iDestruct "S" as "((% & (% & %Hlock) & Hm) & Hz)". *) + iDestruct ("H" with "S") as "[H | [H | H]]". + - by iLeft. + - iRight; iLeft. + iMod "H" as (???) "(S & Hsafe)". + (* do we need to bring back mem_sub for this? *) + assert (exists m'', corestep (cl_core_sem ge) c (restrPermMap Hlt) c' m'' /\ exists p' (Hlt' : permMapLt p' (getMaxPerm m')), m'' = restrPermMap Hlt') as (? & ? & ? & Hlt' & ->) by admit. + iIntros "!>"; iExists _, _; iSplit; first done. + iSplitL "S". + + assert (permMapLt (getCurPerm m') (getMaxPerm (restrPermMap Hlt'))) as Hltm'. + { rewrite restr_Max_eq; apply cur_lt_max. } + iExists _, Hltm'; rewrite restrPermMap_idem restrPermMap_eq //. + + iNext; iApply ("IH" with "[%] Hsafe"). + admit. (* something about how perms being maxxed carries forward *) + - iRight; iRight. + iDestruct "H" as (??? (? & ?)) "H". + assert (ext_spec_pre (concurrent_ext_spec () CS ext_link) e x (genv_symb_injective ge) + (sig_args (ef_sig e)) args z (restrPermMap Hlt)) by admit. + iExists _, _, _; iSplit; first done. + iIntros "!>" (?????). + iMod ("H" with "[%] [%]") as (??) "(S & Hsafe)"; [done..|]. + iIntros "!>"; iExists _; iSplit; first done. + iFrame; iApply ("IH" with "[%] Hsafe"). + Admitted. + + Definition thread_safe `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} max (tp : dtp) i := + ∃ cnti : containsThread tp i, + match getThreadC cnti with + | Krun c | Kblocked c => jsafe_perm max ⊤ tt c (getThreadR cnti).1 + | Kresume c v => + ∀ c', + (* [v] is not used here. The problem is probably coming from + the definition of JuicyMachine.resume_thread'. *) + ⌜cl_after_external None c = Some c'⌝ → + jsafe_perm max ⊤ tt c' (getThreadR cnti).1 + | Kinit v1 v2 => + ∃ q_new, + ⌜cl_initial_core ge v1 (v2 :: nil) = Some q_new⌝ ∧ + jsafe_perm max ⊤ tt q_new (getThreadR cnti).1 + end%I. + + Definition threads_safe `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} max (tp : dtp) : mpred := + [∗ list] i ∈ seq 0 (pos.n (OrdinalPool.num_threads tp)), thread_safe max tp i. + + Definition threads_wellformed (tp : dtp) := + forall i (cnti : containsThread(ThreadPool := OrdinalPool.OrdinalThreadPool) tp i), + match getThreadC cnti with + | Krun q => Logic.True + | Kblocked q => cl_at_external q <> None + | Kresume q v => cl_at_external q <> None /\ v = Vundef + | Kinit _ _ => Logic.True + end. + + Definition locks_coherent `{!heapGS Σ} (tp : dtp) (m : mem) (ls : gmap address unit) := + forall l, (l ∈ dom ls -> lockRes tp l <> None /\ (Mem.load Mptr m l.1 l.2 = Some (Vptrofs Ptrofs.zero) <-> lockRes tp l = Some (empty_map, empty_map))). + + Existing Instance HybridMachine.DryHybridMachine.DryHybridMachineSig. + + Definition other_threads_safe `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} max tp i : mpred := + ∀ Ψ, □ (∀ k j, ⌜seq 0 (pos.n (OrdinalPool.num_threads tp)) !! k = Some j⌝ → ⌜k ≠ i⌝ → + thread_safe max tp j -∗ Ψ k j) -∗ + Ψ i i -∗ [∗ list] k↦y ∈ seq 0 (pos.n (OrdinalPool.num_threads tp)), Ψ k y. + + Definition post_safe `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} max sig x c args k : mpred := + ∀ (ret : option val) (m' : mem) z', + ⌜Val.has_type_list args (sig_args sig) ∧ Builtins0.val_opt_has_rettype ret (sig_res sig)⌝ → + ⌜ext_spec_post OK_spec LOCK x (genv_symb_injective ge) (sig_res sig) ret z' m'⌝ → + |={⊤}=> ∃ c' : CC_core, ⌜after_external (cl_core_sem ge) ret (Callstate c args k) m' = Some c'⌝ ∧ + state_interp m' z' ∗ jsafe_perm max ⊤ z' c' (getCurPerm m'). + + (* these lemmas could be split off again into semax_acquire_safety, etc. *) + Lemma acquire_safe `{!heapGS Σ} `{!externalGS unit Σ} `{!lockGS Σ} tp m ls i + (Htp_wf : threads_wellformed tp) (Hinvariant : invariant tp) (Hcompat : HybridMachineSig.mem_compatible tp m) + (cnti : containsThread tp i) argsty retty cc k args + (Hi : getThreadC cnti = Kblocked (Callstate (Ctypes.External LOCK argsty retty cc) args k)) + p (Hmax : permMapLt p (getMaxPerm m)) (Hlt0 : permMapLt (getThreadR cnti).1 (getMaxPerm (restrPermMap Hmax))) + x (Hpre : ext_spec_pre OK_spec LOCK x (genv_symb_injective ge) (sig_args (ef_sig LOCK)) args () (restrPermMap Hlt0)) : + ⊢ other_threads_safe (getMaxPerm m) tp i -∗ + ▷ post_safe (getMaxPerm m) (ef_sig LOCK) x (Ctypes.External LOCK argsty retty cc) args k -∗ + lock_set ls -∗ + |={⊤}[∅]▷=> ∃ (tp' : t) (m' : mem) (ev : Events.sync_event), + ⌜threads_wellformed tp' ∧ invariant tp' ∧ mem_compatible tp' m' ∧ locks_coherent tp' m' ls ∧ syncStep true cnti Hcompat tp' m' ev⌝ ∧ + threads_safe (getMaxPerm m') tp' ∗ (∃ (p0 : access_map) (Hlt : permMapLt p0 (getMaxPerm m')), state_interp (restrPermMap Hlt) ()) ∗ lock_set ls. + Proof. + iIntros "Hsafe Hpost locks". + apply CEspec_acquire_pre in Hpre as (x' & Heqx & Hpre). + destruct x' as ((n, phi), ((l, sh), R)); simpl in Hpre. + destruct Hpre as (Hvphi & Hty & Hpre). + set (c := Callstate (Ctypes.External LOCK argsty retty cc) args k). + destruct args as [|arg args]; simpl in Hty; first done. + destruct Hty as (Hty & Htys); destruct args; last done. + clear Htys. + assert (readable_share sh /\ val_lemmas.isptr arg) as (Hsh & Hisptr). + { revert Hpre; rewrite /PROPx /PARAMSx /GLOBALSx /LOCALx /SEPx; monPred.unseal; ouPred.unseal. + intros (? & ? & ? & _ & (? & _) & [=] & _ & ? & ? & ? & Hlock & _). + pose proof (lockinv_isptr sh l R) as [Heq]. + apply Heq in Hlock. + revert Hlock; ouPred.unseal; intros (? & _); subst; done. + { eapply cmra_validN_op_l, ora_validN_orderN; last done. + eapply cmra_validN_op_r, ora_validN_orderN; done. } } + destruct arg as [| | | | | b ofs]; try done. + clear Hty Hisptr. + (* Does the ls ghost state actually work? We don't have that phi is true in the current state. *) + assert (ext_step cnti Hcompat (updLockSet (updThread cnti (Kresume c Vundef) newThreadPerm) (b, Ptrofs.intval ofs) (empty_map, empty_map)) m' (Events.acquire (b, Ptrofs.intval ofs) (Some (build_delta_content virtueThread.1 m')))) as Hstep. + + iMod ("Hpost" with "[%] [%]"). + Admitted. + + Theorem dry_safety `{!VSTGpreS unit Σ} `{!inG Σ (gmap_view.gmap_viewR address unitR)} sch n : exists b c_init, + Genv.find_symbol (globalenv prog) (Ctypes.prog_main prog) = Some b /\ + cl_initial_core (globalenv prog) (Vptr b Ptrofs.zero) [] = Some c_init /\ + HybridMachineSig.HybridCoarseMachine.csafe + (ThreadPool:= threadPool.OrdinalPool.OrdinalThreadPool(Sem:=ClightSem ge)) + (sch, [], + DryHybridMachine.initial_machine(Sem := Sem) (getCurPerm (proj1_sig init_mem)) + c_init) (proj1_sig init_mem) n. + Proof. + eapply ouPred.pure_soundness, (step_fupdN_soundness_no_lc' _ (S n) O); [apply _..|]. + simpl; intros; iIntros "_". + iMod (@init_VST _ _ VSTGpreS0) as "H". + iDestruct ("H" $! Hinv) as (?? HE) "(H & ?)". + iMod (own_alloc(A := gmap_view.gmap_viewR address unit) (gmap_view.gmap_view_auth (dfrac.DfracOwn 1) ∅)) as (γl) "locks". + { apply gmap_view.gmap_view_auth_valid. } + set (HL := Build_lockGS _ _ γl). + destruct (spr (HeapGS _ _ _ _) HE HL) as (b & q & (? & ? & Hinit) & Hsafe); [| done..]. + iMod (Hsafe with "H") as "(S & Hsafe)". + iAssert (|={⊤}[∅]▷=>^n ⌜HybridMachineSig.HybridCoarseMachine.csafe + (ThreadPool:= threadPool.OrdinalPool.OrdinalThreadPool(Sem:=ClightSem ge)) + (sch, [], + DryHybridMachine.initial_machine(Sem := Sem) (getCurPerm (proj1_sig init_mem)) + q) (proj1_sig init_mem) n⌝) with "[S Hsafe locks]" as "Hdry". + 2: { iApply step_fupd_intro; first done. + iNext; iApply (step_fupdN_mono with "Hdry"). + iPureIntro. intros. + eexists. eexists. split; first done; split; first apply Hinit; done. } + clear Hinit Hsafe. + rewrite bi.and_elim_l. + set (tp := initial_machine _ _). + assert (invariant tp) as Hinvariant by apply ThreadPoolWF.initial_invariant0. + assert (HybridMachineSig.mem_compatible tp (`init_mem)) as Hcompat by apply ThreadPoolWF.initial_mem_compatible. + assert (threads_wellformed tp) as Htp_wf by done. + set (HH := HeapGS _ Hinv _ _). + iAssert (threads_safe(heapGS0 := HH) (getMaxPerm (`init_mem)) tp) with "[Hsafe]" as "Hsafe". + { rewrite /threads_safe /=. + iSplit; last done. + unshelve iExists _; first done. + iApply (jsafe_jsafe_perm with "Hsafe"). + admit. (* should be provable, but is this what we need? *) } + assert (locks_coherent tp (`init_mem) ∅) as Hlocks by done. + forget (proj1_sig init_mem) as m. + forget (@nil Events.machine_event) as tr. + clearbody tp. + set (ls := ∅) in Hlocks |- *. + iAssert (lock_set ls) with "locks" as "locks". + clearbody ls. + clear dependent b x q. + (* the machine semantics clobber the curPerm with the most recent thread's curPerm *) + iAssert (∃ p (Hlt : permMapLt p (getMaxPerm m)), state_interp (restrPermMap Hlt) tt) with "[S]" as "S". + { iExists _, (cur_lt_max m); rewrite restrPermMap_eq //. } + iLöb as "IH" forall (sch tr tp m n ls Htp_wf Hinvariant Hcompat Hlocks). + destruct n as [|n]. + { iPureIntro. constructor. } + destruct sch as [|i sch]. + { iApply step_fupdN_intro; first done; iPureIntro. constructor; done. } + simpl; destruct (lt_dec i (pos.n (OrdinalPool.num_threads tp))). + 2: { iApply step_fupd_intro; first done; iNext. + iAssert (|={⊤}[∅]▷=>^n ∀ U'', ⌜HybridMachineSig.HybridCoarseMachine.csafe (U'', tr, tp) m n⌝) with "[-]" as "H". + { rewrite step_fupdN_plain_forall //. + iIntros; iApply ("IH" with "[%] [%] [%] [%] Hsafe locks S"); done. } + iApply (step_fupdN_mono with "H"); iPureIntro. + intros Hsafe. + eapply HybridMachineSig.HybridCoarseMachine.AngelSafe with (tr := []); simpl; rewrite seq.cats0; last apply Hsafe. + eapply HybridMachineSig.schedfail; eauto. + rewrite /containsThread /= /OrdinalPool.containsThread. + intros ?. + pose proof (@ssrnat.leP (S i) (pos.n (OrdinalPool.num_threads tp))) as Hle; inv Hle; [lia | congruence]. } + rewrite {2}/threads_safe. + set (Espec := CEspec _ _). + rewrite big_sepL_lookup_acc_impl; last by apply lookup_seq; eauto. + iDestruct "Hsafe" as "((% & Hsafei) & Hsafe)". + destruct (getThreadC cnti) eqn: Hi. + - (* Krun *) + destruct (cl_halted s) eqn: Hhalt; [|destruct (cl_at_external s) eqn: Hat_ext]. + + (* halted *) + assert (HybridMachineSig.halted_thread cnti Int.zero) as Hhalt'. + { econstructor; eauto. + hnf; rewrite Hhalt //. } + iApply step_fupd_intro; first done; iNext. + iAssert (threads_safe (getMaxPerm m) tp) with "[Hsafei Hsafe]" as "Hsafe". + { iApply "Hsafe". + * iIntros "!>" (????) "H"; iApply "H". + * iExists cnti; rewrite Hi //. } + iAssert (|={⊤}[∅]▷=>^n ∀ U'', ⌜HybridMachineSig.HybridCoarseMachine.csafe (U'', tr, tp) m n⌝) with "[-]" as "H". + { rewrite step_fupdN_plain_forall //. + iIntros; iApply ("IH" with "[%] [%] [%] [%] Hsafe locks S"); done. } + iApply (step_fupdN_mono with "H"); iPureIntro. + intros Hsafe. + eapply HybridMachineSig.HybridCoarseMachine.AngelSafe with (tr := []); simpl; rewrite seq.cats0; last apply Hsafe. + eapply HybridMachineSig.halted_step; eauto. + + (* HybridMachineSig.suspend_step *) + assert (HybridMachineSig.suspend_thread m cnti (updThreadC cnti (Kblocked s))) as Hsuspend. + { eapply (HybridMachineSig.SuspendThread _ _ _ _ _ _ _ _ Hcompat); done. } + iApply step_fupd_intro; first done; iNext. + iAssert (|={⊤}[∅]▷=>^n ∀ U'', ⌜HybridMachineSig.HybridCoarseMachine.csafe (U'', tr, (updThreadC cnti (Kblocked s))) m n⌝) with "[-]" as "H". + { rewrite step_fupdN_plain_forall //. + iIntros; iApply ("IH" with "[%] [%] [%] [%] [Hsafei Hsafe] locks S"). + + intros j cntj. + destruct (eq_dec j i). + * subst; rewrite gssThreadCC Hat_ext //. + * pose proof (cntUpdateC' _ cnti cntj) as cntj0. + rewrite -gsoThreadCC //; apply Htp_wf. + + by apply ThreadPoolWF.updThreadC_invariant. + + by apply StepLemmas.updThreadC_compatible. + + intros ?; rewrite gsoThreadCLPool; apply Hlocks. + + iApply "Hsafe". + * iIntros "!>" (?? (-> & ?)%lookup_seq ?) "(% & Hsafe)". + iExists (cntUpdateC _ _ _); rewrite -gsoThreadCC // gThreadCR //. + * iExists (cntUpdateC _ _ _); rewrite gssThreadCC gThreadCR. + by iApply "Hsafei". } + iApply (step_fupdN_mono with "H"); iPureIntro; intros Hsafe. + eapply HybridMachineSig.HybridCoarseMachine.AngelSafe with (tr := []); simpl; rewrite seq.cats0; last apply Hsafe. + eapply HybridMachineSig.suspend_step; eauto. + + (* corestep: HybridMachineSig.thread_step *) + rewrite jsafe_perm_unfold /jsafe_perm_pre. + iDestruct "S" as (? Hmax) "S". + assert (permMapLt (getThreadR cnti).1 (getMaxPerm (restrPermMap Hmax))) as Hlt0. + { rewrite restr_Max_eq. by apply compat_th. } + iMod ("Hsafei" $! _ Hlt0 with "[%] S") as "[Hhalt | [Hstep | Hext]]". + { rewrite restr_Max_eq //. } + { iDestruct "Hhalt" as %(? & Hhalt' & ?); done. } + 2: { iDestruct "Hext" as (??? (Hext & ?)) "?". + simpl in Hext; congruence. } + iMod "Hstep" as (?? Hstep) "(S & Hsafei)". + rewrite restrPermMap_idem in Hstep. + assert (corestep (cl_core_sem ge) s (restrPermMap (ssrfun.pair_of_and (Hcompat i cnti)).1) c' m') as Hstep'. + { by erewrite restrPermMap_irr. } + iApply step_fupd_intro; first done; iNext. + apply (ev_step_ax2 (Clight_evsem.CLC_evsem ge)) in Hstep' as (? & Hstep'). + iSpecialize ("IH" $! _ _ (updThread cnti (Krun c') (getCurPerm m', (getThreadR cnti).2)) with "[%] [%] [%] [%] [Hsafe Hsafei] locks S"). + * intros j cntj. + destruct (eq_dec j i); first by subst; rewrite gssThreadCode. + pose proof (cntUpdate' _ _ cnti cntj). + rewrite gsoThreadCode //; apply Htp_wf. + * eapply (CoreLanguageDry.corestep_invariant(Sem := Sem)); try done. + by eapply ev_step_ax1. + * by eapply (CoreLanguageDry.corestep_compatible(Sem := Sem)). + * intros ?; rewrite gsoThreadLPool. (*eapply Hlocks. need to know that coresteps don't mess with locks *) admit. + * iApply "Hsafe". + -- iIntros "!>" (?? (-> & ?)%lookup_seq ?) "(% & Hsafe)". + iExists (cntUpdate _ _ cnti cnti0). + rewrite gsoThreadCode //. + rewrite gsoThreadRes //. + admit. (* need to know that any changes to getMaxPerm don't invalidate other threads! *) + -- iExists (cntUpdate _ _ cnti cnti). + rewrite gssThreadCode gssThreadRes. + admit. + * iApply (step_fupdN_mono with "IH"); iPureIntro; intros Hsafe. + eapply HybridMachineSig.HybridCoarseMachine.CoreSafe, Hsafe. + rewrite /HybridMachineSig.MachStep /=. + change (i :: sch) with (HybridMachineSig.yield (i :: sch)) at 2. + change m' with (HybridMachineSig.diluteMem m') at 3. + eapply HybridMachineSig.thread_step; first done. + by eapply step_dry. + - (* Kblocked: HybridMachineSig.sync_step *) + pose proof (Htp_wf _ cnti) as Hwfi; rewrite Hi in Hwfi. + rewrite jsafe_perm_unfold /jsafe_perm_pre. + iDestruct "S" as (? Hmax) "S". + assert (permMapLt (getThreadR cnti).1 (getMaxPerm (restrPermMap Hmax))) as Hlt0. + { rewrite restr_Max_eq. by apply compat_th. } + iMod ("Hsafei" $! _ Hlt0 with "[%] S") as "[Hhalt | [Hstep | Hext]]". + { rewrite restr_Max_eq //. } + { iDestruct "Hhalt" as %(? & Hhalt' & ?). + destruct s; done. } + { iMod "Hstep" as (?? Hstep) "?". + apply cl_corestep_not_at_external in Hstep; done. } + iDestruct "Hext" as (??? (Hat_ext & Hpre)) "Hpost". + iAssert (|={⊤}[∅]▷=> ∃ (tp' : t(ThreadPool := OrdinalPool.OrdinalThreadPool)) m' ev, ⌜threads_wellformed tp' ∧ invariant tp' ∧ mem_compatible tp' m' ∧ + locks_coherent tp' m' ls ∧ syncStep true cnti Hcompat tp' m' ev⌝ ∧ + threads_safe (getMaxPerm m') tp' ∗ (∃ p (Hlt : permMapLt p (getMaxPerm m')), state_interp (restrPermMap Hlt) tt) ∗ lock_set ls) with "[-]" as "Hsafe". + 2: { iMod "Hsafe"; iIntros "!> !>"; iMod "Hsafe" as (??? (? & ? & ? & ? & ?)) "(Hsafe & S & locks)". + iAssert (|={⊤}[∅]▷=>^n ∀ U'', ⌜HybridMachineSig.HybridCoarseMachine.csafe (U'', tr ++ [Events.external i ev], tp') m' n⌝) with "[-]" as "H". + { rewrite step_fupdN_plain_forall //. + iIntros; iApply ("IH" with "[%] [%] [%] [%] Hsafe locks S"); done. } + iApply (step_fupdN_mono with "H"); iPureIntro. + intros Hsafe. + eapply HybridMachineSig.HybridCoarseMachine.AngelSafe; simpl; last apply Hsafe. + eapply HybridMachineSig.sync_step; eauto. } + (* consider each of the concurrency functions *) + clear Hwfi. + destruct s as [|f ? k|]; try done; simpl in Hat_ext. + destruct f as [|ext argsty retty cc]; try done. + destruct (ef_inline ext); inv Hat_ext. + destruct (CEspec_cases _ x) as [-> | [-> | [-> | [-> | ->]]]]. + + (* acquire *) + iApply (acquire_safe with "Hsafe Hpost locks"). + + (* release *) + + (* makelock *) + + (* freelock *) + + (* spawn *) + - (* Kresume: HybridMachineSig.resume_step *) + pose proof (Htp_wf _ cnti) as Hwfi; rewrite Hi in Hwfi; destruct Hwfi as (? & ->). + destruct s; try done. + destruct f; try done. + assert (HybridMachineSig.resume_thread m cnti (updThreadC cnti (Krun (Returnstate Vundef c)))) as Hresume. + { unfold cl_at_external in *; destruct (ef_inline e) eqn: Hinline; try done. + eapply (HybridMachineSig.ResumeThread _ _ _ _ _ _ _ _ _ Hcompat); try done; simpl; by rewrite ?Hinline. } + iApply step_fupd_intro; first done; iNext. + iSpecialize ("IH" $! _ _ (updThreadC cnti (Krun (Returnstate Vundef c))) with "[%] [%] [%] [Hsafei Hsafe] S"). + + intros j cntj. + destruct (eq_dec j i). + * subst; rewrite gssThreadCC //. + * pose proof (cntUpdateC' _ cnti cntj) as cntj0. + rewrite -gsoThreadCC //; apply Htp_wf. + + by apply ThreadPoolWF.updThreadC_invariant. + + by apply StepLemmas.updThreadC_compatible. + + iApply "Hsafe". + * iIntros "!>" (?? (-> & ?)%lookup_seq ?) "(% & Hsafe)". + iExists (cntUpdateC _ _ _); rewrite -gsoThreadCC // gThreadCR //. + * iExists (cntUpdateC _ _ _); rewrite gssThreadCC gThreadCR. + by iApply "Hsafei". + + iApply (step_fupdN_mono with "IH"); iPureIntro; intros Hsafe. + eapply HybridMachineSig.HybridCoarseMachine.CoreSafe with (tr := []); simpl; rewrite seq.cats0; last apply Hsafe. + change (i :: sch) with (HybridMachineSig.yield (i :: sch)) at 2. + eapply HybridMachineSig.resume_step; eauto. + - (* Kinit: HybridMachineSig.start_step *) + iDestruct "Hsafei" as (? Hinit) "Hsafei". + set (m' := restrPermMap (ssrfun.pair_of_and (Hcompat i cnti)).1). + set (tp' := updThread cnti (Krun q_new) (HybridMachineSig.add_block Hcompat cnti m')). + assert (HybridMachineSig.start_thread m cnti tp' m'). + { econstructor; done. } + iApply step_fupd_intro; first done; iNext. + iSpecialize ("IH" $! _ _ tp' m' with "[%] [%] [%] [Hsafei Hsafe] [S]"). + + intros j cntj. + destruct (eq_dec j i). + * subst; rewrite gssThreadCode //. + * pose proof (cntUpdate' _ _ cnti cntj). + rewrite gsoThreadCode //; apply Htp_wf. + + by eapply (CoreLanguageDry.initial_core_invariant(Sem := Sem)). + + eapply InternalSteps.start_compatible; try done. + + iApply "Hsafe". + * iIntros "!>" (?? (-> & ?)%lookup_seq ?) "(% & Hsafe)". + iExists (cntUpdate _ _ cnti cnti0); rewrite gsoThreadCode // gsoThreadRes //. + subst m'; rewrite restr_Max_eq //. + * iExists (cntUpdate _ _ cnti cnti); rewrite gssThreadCode gssThreadRes. + rewrite restr_Max_eq /=. + iApply (jsafe_perm_equiv with "Hsafei"). + symmetry; apply mem_equiv.getCur_restr. + + iDestruct "S" as (??) "S". + iExists _, (mem_equiv.useful_permMapLt_trans _ Hlt). + rewrite restrPermMap_idem. erewrite restrPermMap_irr; done. + + iApply (step_fupdN_mono with "IH"); iPureIntro; intros Hsafe. + eapply HybridMachineSig.HybridCoarseMachine.CoreSafe with (tr := []); simpl; rewrite seq.cats0; last apply Hsafe. + change (i :: sch) with (HybridMachineSig.yield (i :: sch)) at 2. + change m' with (HybridMachineSig.diluteMem m'). + eapply HybridMachineSig.start_step; eauto. + Admitted. + +End Safety. diff --git a/concurrency/juicy/semax_to_juicy_machine.v b/concurrency/juicy/semax_to_juicy_machine.v index 1ccee0958..ba297f5ba 100644 --- a/concurrency/juicy/semax_to_juicy_machine.v +++ b/concurrency/juicy/semax_to_juicy_machine.v @@ -10,15 +10,11 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.veric.aging_lemmas. -Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. Require Import VST.veric.semax_prog. -Require Import VST.veric.compcert_rmaps. -Require Import VST.veric.Clight_new. -Require Import VST.veric.Clightnew_coop. +Require Import VST.veric.Clight_core. +Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. Require Import VST.veric.semax_ext. Require Import VST.veric.semax_lemmas. @@ -41,9 +37,6 @@ Require Import VST.concurrency.juicy.JuicyMachineModule. Require Import VST.concurrency.juicy.sync_preds_defs. Require Import VST.concurrency.juicy.sync_preds. Require Import VST.concurrency.juicy.join_lemmas. -(*Require Import VST.concurrency.cl_step_lemmas. -Require Import VST.concurrency.resource_decay_lemmas. -Require Import VST.concurrency.resource_decay_join.*) Require Import VST.concurrency.juicy.semax_invariant. Require Import VST.concurrency.juicy.semax_initial. Require Import VST.concurrency.juicy.semax_progress. diff --git a/concurrency/juicy/sync_preds.v b/concurrency/juicy/sync_preds.v index cc5f754c8..51bdf2f17 100644 --- a/concurrency/juicy/sync_preds.v +++ b/concurrency/juicy/sync_preds.v @@ -10,28 +10,20 @@ Require Import compcert.common.Values. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.msl.age_to. -Require Import VST.veric.aging_lemmas. Require Import VST.veric.initial_world. Require Import VST.veric.juicy_mem. Require Import VST.veric.juicy_mem_lemmas. Require Import VST.veric.semax_prog. -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.Clight_core. Require Import VST.veric.Clightcore_coop. Require Import VST.veric.semax. -Require Import VST.veric.semax_ext. -Require Import VST.veric.juicy_extspec. Require Import VST.veric.juicy_extspec. Require Import VST.veric.tycontext. Require Import VST.veric.semax_ext. Require Import VST.veric.res_predicates. -Require Import VST.veric.age_to_resource_at. Require Import VST.veric.coqlib4. Require Import VST.sepcomp.step_lemmas. Require Import VST.sepcomp.event_semantics. -Require Import VST.concurrency.conclib. Require Import VST.concurrency.juicy.semax_conc_pred. Require Import VST.concurrency.juicy.semax_conc. Require Import VST.concurrency.juicy.juicy_machine. @@ -61,13 +53,13 @@ Proof. Qed. Lemma interval_adr_range b start length i : - Intv.In i (start, start + length) <-> + Intv.In i (start, start + length)%Z <-> adr_range (b, start) length (b, i). Proof. compute; intuition. Qed. -Lemma join_YES_l {r1 r2 r3 sh1 sh1' k pp} : +(*Lemma join_YES_l {r1 r2 r3 sh1 sh1' k pp} : sepalg.join r1 r2 r3 -> r1 = YES sh1 sh1' k pp -> exists sh3 sh3', @@ -76,7 +68,7 @@ Proof. intros J; inversion J; intros. all:try congruence. all:do 2 eexists; f_equal; try congruence. -Qed. +Qed.*) Local Open Scope nat_scope. @@ -98,7 +90,7 @@ intros. pose proof (LKSIZE_pos). destruct loc; simpl; f_equal; auto. lia. Qed. - +(* Lemma same_locks_juicyLocks_in_lockSet phi phi' lset : same_locks phi phi' -> juicyLocks_in_lockSet lset phi -> @@ -130,33 +122,7 @@ Proof. autospec LW. rewrite (Mem.nextblock_noaccess _ _ ofs Max L) in LW. inversion LW. -Qed. - -Lemma join_all_age_updThread_level (tp : jstate ge) i (cnti : ThreadPool.containsThread tp i) c phi Phi : - join_all (age_tp_to (level phi) (ThreadPool.updThread cnti c phi)) Phi -> - level Phi = level phi. -Proof. - intros J; symmetry. - remember (level phi) as n. - rewrite <- (level_age_to n phi). 2:lia. - apply rmap_join_sub_eq_level. - assert (cnti' : containsThread (updThread cnti c phi) i) by eauto with *. - rewrite (cnt_age_iff (n := n)) in cnti'. - pose proof compatible_threadRes_sub cnti' J as H. - unshelve erewrite <-getThreadR_age in H; eauto with *. - rewrite gssThreadRes in H. - apply H. -Qed. - -Lemma join_all_level_lset (tp : jstate ge) Phi l phi : - join_all tp Phi -> - AMap.find l (lset tp) = Some (Some phi) -> - level phi = level Phi. -Proof. - intros J F. - apply rmap_join_sub_eq_level. - eapply compatible_lockRes_sub_all; eauto; simpl; eauto. -Qed. +Qed.*) Lemma lset_range_perm m (tp : jstate ge) b ofs (compat : mem_compatible tp m) @@ -177,36 +143,12 @@ Proof. + simpl in *. unfold OrdinalPool.lockRes in *. unfold OrdinalPool.lockGuts in *. - simpl in *. + change lock_info with (option rmap). destruct (AMap.find (elt:=option rmap) (b, ofs) (lset tp)). * reflexivity. * tauto. Qed. -Lemma age_to_updThread i (tp : jstate ge) n c phi cnti cnti' : - age_tp_to n (@updThread _ _ _ i tp cnti c phi) = - @updThread _ _ _ i (age_tp_to n tp) cnti' c (age_to n phi). -Proof. - destruct tp; simpl. - unfold OrdinalPool.updThread in *; simpl. - f_equal. extensionality j. - unfold compose. - do 2 match goal with - |- context [if ?a then _ else _] => - let E := fresh "E" in - destruct a eqn:E - end. - all:auto. - all:cut (true = false); [ congruence | ]. - all:rewrite <-E, <-E0; repeat f_equal; apply proof_irr. -Qed. - -Lemma lset_age_tp_to n (tp : jstate ge) : - lset (age_tp_to n tp) = AMap.map (option_map (age_to n)) (lset tp). -Proof. - destruct tp; reflexivity. -Qed. - Lemma getThreadC_fun i (tp : jstate ge) cnti cnti' x y : @getThreadC _ _ _ i tp cnti = x -> @getThreadC _ _ _ i tp cnti' = y -> @@ -229,60 +171,6 @@ Proof. apply proof_irr. Qed. -Lemma lockSet_Writable_age n (tp : jstate ge) m : - lockSet_Writable (lset tp) m -> - lockSet_Writable (lset (age_tp_to n tp)) m. -Proof. - rewrite lset_age_tp_to. - intros L b ofs E ofs0 range. - refine(L b ofs _ ofs0 range). - exact_eq E; f_equal. - apply isSome_find_map. -Qed. - -Lemma lockSet_age_to n (tp : jstate ge) : - lockSet (age_tp_to n tp) = lockSet tp. -Proof. - destruct tp as [num thds phis lset]. - unfold lockSet in *. - simpl. - apply A2PMap_option_map. -Qed. - -Lemma juicyLocks_in_lockSet_age n (tp : jstate ge) phi : - juicyLocks_in_lockSet (lset tp) phi -> - juicyLocks_in_lockSet (lset (age_tp_to n tp)) (age_to n phi). -Proof. - rewrite lset_age_tp_to. - intros L loc E. - specialize (L loc). - spec L. { intros. specialize (E _ H). destruct E as [sh [psh E]]. exists sh, psh. - pattern (age_to n phi) in E. apply age_to_ind_opp in E. auto. - intros. - eapply age1_YES'; eauto. - } - rewrite isSome_find_map; auto. -Qed. - -Lemma lockSet_in_juicyLocks_age n (tp : jstate ge) phi : - lockSet_in_juicyLocks (lset tp) phi -> - lockSet_in_juicyLocks (lset (age_tp_to n tp)) (age_to n phi). -Proof. - rewrite lset_age_tp_to. - intros L loc E. - rewrite isSome_find_map in E. - specialize (L loc E). - destruct L as (sh & L). exists sh. - pattern (age_to n phi). - apply age_to_ind; auto. clear L. - intros ? ? ? ? ? ?. specialize (H0 _ H1). - destruct H0 as [sh2 [psh2 H0]]. exists sh2, psh2. - assert (join_sub sh sh2 /\ exists P, x @ (fst loc, (snd loc + i)%Z) = YES sh2 psh2 (LK LKSIZE i) P). - destruct H0 as [P [? ?]]; split; eauto. clear H0; destruct H2. - assert (H3: exists P, y @ (fst loc, (snd loc + i)%Z) = YES sh2 psh2 (LK LKSIZE i) P); [| destruct H3 as [P ?]; exists P; auto]. - rewrite <- age1_YES'; eauto. -Qed. - Definition same_except_cur (m m' : Mem.mem) := Mem.mem_contents m = Mem.mem_contents m' /\ max_access_at m = max_access_at m' /\ @@ -295,9 +183,9 @@ Lemma mem_cohere_same_except_cur m m' phi : Proof. intros (ECo & EMa & EN) [Co Ma N]; constructor. - hnf in *. - unfold contents_at in *. + unfold juicy_mem.contents_cohere, contents_at in *. rewrite <-ECo. auto. - - unfold max_access_cohere in *. intros loc. + - unfold max_access_cohere, juicy_mem.max_access_cohere in *. intros loc. apply equal_f with (x := loc) in EMa. rewrite <-EMa. apply Ma. @@ -323,24 +211,24 @@ Proof. auto. Qed. -Lemma resource_at_joins phi1 phi2 loc : +(*Lemma resource_at_joins phi1 phi2 loc : joins phi1 phi2 -> joins (phi1 @ loc) (phi2 @ loc). Proof. intros (phi3, j). apply resource_at_join with (loc := loc) in j. hnf; eauto. -Qed. +Qed.*) Lemma juicyRestrict_Max b ofs phi m (coh : access_cohere' m phi): - (Mem.mem_access (juicyRestrict coh)) !! b ofs Max = - (Mem.mem_access m) !! b ofs Max. + PMap.get b (Mem.mem_access (juicyRestrict coh)) ofs Max = + PMap.get b (Mem.mem_access m) ofs Max. Proof. symmetry. apply (juicyRestrictMax coh (b, ofs)). Qed. Lemma juicyRestrict_Cur b ofs phi m (coh : access_cohere' m phi): - (Mem.mem_access (juicyRestrict coh)) !! b ofs Cur = + PMap.get b (Mem.mem_access (juicyRestrict coh)) ofs Cur = perm_of_res (phi @ (b, ofs)). Proof. apply (juicyRestrictCurEq coh (b, ofs)). @@ -360,7 +248,7 @@ Proof. unfold Mem.perm in *. unfold access_at in *. simpl. - destruct ((Mem.mem_access m1) !! b ofs k) as [[]|], ((Mem.mem_access m2) !! b ofs k) as [[]|]. + destruct (PMap.get b (Mem.mem_access m1) ofs k) as [[]|], (PMap.get b (Mem.mem_access m2) ofs k) as [[]|]. all: simpl in *. all: auto || exfalso. all: try specialize (L _ (perm_refl _)). @@ -374,22 +262,6 @@ Proof. auto. Qed. -(*Lemma PTree_xmap_ext (A B : Type) (f f' : positive -> A -> B) t : - (forall a, f a = f' a) -> - PTree.xmap f t = PTree.xmap f' t. -Proof. - intros E. - induction t as [ | t1 IH1 [a|] t2 IH2 ]. - - reflexivity. - - simpl. - extensionality p. - rewrite IH1, IH2, E. - reflexivity. - - simpl. - rewrite IH1, IH2. - reflexivity. -Qed.*) - Lemma juicyRestrictCur_ext m phi phi' (coh : access_cohere' m phi) (coh' : access_cohere' m phi') @@ -409,33 +281,14 @@ Proof. extensionality b a o; auto. Qed. -(*Lemma PTree_xmap_self A f (m : PTree.t A) i : - (forall p a, m ! p = Some a -> f (PTree.prev_append i p) a = a) -> - PTree.xmap f m i = m. -Proof. - revert i. - induction m; intros i E. - - reflexivity. - - simpl. - f_equal. - + apply IHm1. - intros p a; specialize (E (xO p) a). - apply E. - + specialize (E xH). - destruct o eqn:Eo; auto. - + apply IHm2. - intros p a; specialize (E (xI p) a). - apply E. -Qed.*) - Lemma PTree_map_self (A : Type) (f : positive -> A -> A) t : - (forall b a, t ! b = Some a -> f b a = a) -> + (forall b a, t !! b = Some a -> f b a = a) -> PTree.map f t = t. Proof. intros H. apply PTree.extensionality; intros. rewrite PTree.gmap. - specialize (H i); destruct (t ! i); auto; simpl. + specialize (H i); destruct (t !! i); auto; simpl. rewrite H; auto. Qed. @@ -457,7 +310,7 @@ Proof. auto. - apply PTree.extensionality; intros. rewrite PTree.gmap. - destruct (t ! i) eqn: Hi; auto; simpl. + destruct (t !! i) eqn: Hi; auto; simpl. f_equal; extensionality ofs k. destruct k; auto. rewrite <- juic2Perm_correct; auto. @@ -474,7 +327,7 @@ Proof. exists Z0; reflexivity. Qed. -Lemma self_join_pshare_false (psh psh' : pshare) : ~sepalg.join psh psh psh'. +(*Lemma self_join_pshare_false (psh psh' : pshare) : ~sepalg.join psh psh psh'. Proof. intros j; inv j. destruct psh as (sh, n); simpl in *. @@ -482,202 +335,9 @@ Proof. eapply share_joins_self. - exists sh'; auto. constructor; eauto. - auto. -Qed. - -Lemma approx_eq_app_pred {P1 P2 : mpred} x n : - level x < n -> - @approx n P1 = approx n P2 -> - app_pred P1 x -> - app_pred P2 x. -Proof. - intros l E s1. - apply approx_p with n; rewrite <-E. - split; auto. -Qed. - -Lemma exclusive_approx R n : exclusive_mpred R -> exclusive_mpred (approx n R). -Proof. - unfold exclusive_mpred; intros. - eapply seplog.derives_trans, H. - apply seplog.sepcon_derives; apply approx_derives. -Qed. - -Import shares. - -Lemma exclusive_joins_false R phi1 phi2 : - exclusive_mpred R -> - app_pred R phi1 -> - app_pred R phi2 -> - joins phi1 phi2 -> - False. -Proof. - unfold exclusive_mpred; intros. - destruct H2. - eapply H. - do 3 eexists; eauto. -Qed. - -Lemma weak_exclusive_joins_false R phi phi1 phi2 : - level phi = level phi1 -> - app_pred (weak_exclusive_mpred R) phi -> - app_pred R phi1 -> - app_pred R phi2 -> - joins phi1 phi2 -> - False. -Proof. - intros. - unfold weak_exclusive_mpred in H0. - destruct H3 as [phi3 J]. - specialize (H0 phi3). - spec H0; [apply join_level in J as []; lia|]. - specialize (H0 _ _ (necR_refl _) (ext_refl _)). - eapply H0. - do 3 eexists; eauto. -Qed. - -(* -Lemma isLKCT_rewrite r : - (forall sh sh' z P, - r <> YES sh sh' (LK z) P /\ - r <> YES sh sh' (CT z) P) - <-> ~isLK r /\ ~isCT r. -Proof. - unfold isLK, isCT; split. - - intros H; split; intros (sh & sh' & z & P & E); do 4 autospec H; intuition. - - intros (A & B). intros sh sh' z P; split; intros ->; eauto 40. -Qed. -*) - -(* -Lemma isLK_rewrite r : - (forall (sh : Share.t) Psh (z : Z) (P : preds), r <> YES sh Psh (LK z) P) - <-> - ~ isLK r. -Proof. - destruct r as [t0 | t0 p [] p0 | k p]; simpl; unfold isLK in *; split. - all: try intros H ?; intros; breakhyps. - intros E; injection E; intros; subst. - apply H; eauto. -Qed. -*) - -Lemma isLK_age_to n phi loc : isLK (age_to n phi @ loc) = isLK (phi @ loc). -Proof. - unfold isLK in *. - rewrite age_to_resource_at. - destruct (phi @ loc); simpl; auto. - - apply prop_ext; split; - intros (shi & shi' & zi & Pi & Ei); - injection Ei; intros; subst; eauto. - - repeat (f_equal; extensionality). - apply prop_ext; split; congruence. -Qed. - -(* -Lemma isCT_age_to n phi loc : isCT (age_to n phi @ loc) = isCT (phi @ loc). -Proof. - unfold isCT in *. - rewrite age_to_resource_at. - destruct (phi @ loc); simpl; auto. - - apply prop_ext; split; - intros (shi & shi' & zi & Pi & Ei); - injection Ei; intros; subst; eauto. - - repeat (f_equal; extensionality). - apply prop_ext; split; congruence. -Qed. -*) - -Lemma predat_inj {phi loc R1 R2} : - predat phi loc R1 -> - predat phi loc R2 -> - R1 = R2. -Proof. - unfold predat in *. - intros. - breakhyps. - rewr (phi @ loc) in H. - pose proof (YES_inj _ _ _ _ _ _ _ _ H). - assert (snd ((x, LK x1 0, SomeP rmaps.Mpred (fun _ : list Type => R2: pred rmap))) = - snd (x2, LK x4 0, SomeP rmaps.Mpred (fun _ : list Type => R1))) by (f_equal; auto). - simpl in H2. - apply SomeP_inj in H2. - pose proof equal_f_dep H2 nil. - auto. -Qed. - -Lemma predat1 {phi loc} {R: mpred} {z sh psh} : - phi @ loc = YES sh psh (LK z 0) (SomeP rmaps.Mpred (fun _ => R)) -> - predat phi loc (approx (level phi) R). -Proof. - intro E; hnf; eauto. - pose proof resource_at_approx phi loc as M. - rewrite E in M at 1; simpl in M. - rewrite <-M. unfold "oo"; simpl. - eauto. -Qed. - -Lemma predat2 {phi loc R sh } : - LKspec_ext R sh loc phi -> - predat phi loc (approx (level phi) R). -Proof. - intros lk; specialize (lk loc); simpl in lk. - if_tac in lk. 2:range_tac. - hnf. unfold "oo" in *; simpl in *; destruct lk. - exists sh, x, LKSIZE. rewrite Z.sub_diag in H0. auto. -Qed. - -Lemma predat3 {phi loc R sh} : - LK_at R sh loc phi -> - predat phi loc (approx (level phi) R). -Proof. - apply predat2. -Qed. - -Lemma predat4 {phi b ofs sh R} : - app_pred (lock_inv sh (Vptr b ofs) R) phi -> - predat phi (b, Ptrofs.unsigned ofs) (approx (level phi) R). -Proof. - unfold lock_inv in *. - intros (b' & ofs' & E & lk). - injection E as <- <-. - specialize (lk (b, Ptrofs.unsigned ofs)); simpl in lk. - if_tac in lk. 2:range_tac. - hnf. unfold "oo" in *; simpl in *; destruct lk; eauto. - exists sh, x, LKSIZE. rewrite Z.sub_diag in H0. auto. -Qed. - -Lemma predat5 {phi loc R} : - islock_pred R (phi @ loc) -> - predat phi loc R. -Proof. - intros H; apply H. -Qed. - -Lemma predat6 {R loc phi} : lkat R loc phi -> predat phi loc (approx (level phi) R). -Proof. - unfold predat in *. - unfold lkat in *. - intros H. specialize (H loc). - spec H. - { destruct loc. split; auto; pose proof LKSIZE_pos; lia. } - destruct H as (sh & rsh & ->). - do 3 eexists. rewrite Z.sub_diag; - eauto. -Qed. - -Lemma predat_join_sub {phi1 phi2 loc R} : - join_sub phi1 phi2 -> - predat phi1 loc R -> - predat phi2 loc R. -Proof. - intros (phi3, j) (sh & sh' & z & E). pose proof j as J. - apply resource_at_join with (loc := loc) in j. - hnf. - apply join_level in J. - rewrite E in j; inv j; eauto. -Qed. +Qed.*) -Lemma lock_inv_at sh v R phi : +(*Lemma lock_inv_at sh v R phi : app_pred (lock_inv sh v R) phi -> exists b ofs, v = Vptr b ofs /\ exists R, islock_pred R (phi @ (b, Ptrofs.unsigned ofs)). Proof. @@ -699,21 +359,6 @@ Proof. do 3 eexists. rewrite Z.sub_diag. reflexivity. -Qed. - -Lemma lkat_hered R loc : hereditary age (lkat R loc). -Proof. - intros phi phi' A lk a r. specialize (lk a r). - destruct lk as (sh & rsh & E); exists sh, rsh. - erewrite age_resource_at; eauto. - rewrite E. - simpl; f_equal. - unfold sync_preds_defs.pack_res_inv in *. - f_equal. extensionality Ts. - pose proof approx_oo_approx' (level phi') (level phi) as RR. - spec RR. apply age_level in A. lia. - unfold "oo" in *. - apply (equal_f RR R). -Qed. +Qed.*) End Machine. diff --git a/concurrency/juicy/sync_preds_defs.v b/concurrency/juicy/sync_preds_defs.v index acbd888d2..f3dbeed05 100644 --- a/concurrency/juicy/sync_preds_defs.v +++ b/concurrency/juicy/sync_preds_defs.v @@ -2,16 +2,16 @@ Require Import VST.concurrency.common.lksize. Require Import VST.concurrency.common.addressFiniteMap. Require Import VST.msl.Coqlib2. Require Import VST.msl.eq_dec. -Require Import VST.msl.seplog. -Require Import VST.veric.compcert_rmaps. Require Import VST.veric.tycontext. Require Import VST.veric.res_predicates. +Require Import VST.veric.shared. +Require Import VST.veric.juicy_mem. (* Those were overwritten in structured_injections *) Notation join := sepalg.join. Notation join_assoc := sepalg.join_assoc. -Definition islock_pred (R: pred rmap) r := +(*Definition islock_pred (R: mpred) r := exists sh sh' z, r = YES sh sh' (LK z 0) (SomeP rmaps.Mpred (fun _ => R)). Lemma islock_pred_join_sub {r1 r2 R} : join_sub r1 r2 -> islock_pred R r1 -> islock_pred R r2. @@ -20,7 +20,7 @@ Proof. inversion J; subst; eexists; eauto. Qed. -Definition LKspec_ext (R: pred rmap) : spec := +Definition LKspec_ext (R: mpred) : spec := fun (sh: Share.t) (l: AV.address) => allp (jam @@ -36,7 +36,7 @@ the LK, CT, ... have the same share, which might not be true. The following definition has the same structure as rmap_makelock in rmap_locking *) -Definition pack_res_inv (R: pred rmap) := SomeP rmaps.Mpred (fun _ => R). +Definition pack_res_inv (R: mpred) := SomeP rmaps.Mpred (fun _ => R). Definition lkat (R : mpred) loc phi := (forall x, @@ -57,10 +57,10 @@ Definition same_locks phi1 phi2 := Definition lockSet_block_bound lset b := forall loc, isSome (AMap.find (elt:=option rmap) loc lset) -> (fst loc < b)%positive. -Definition predat phi loc (R: pred rmap) := - exists sh sh' z, phi @ loc = YES sh sh' (LK z 0) (SomeP rmaps.Mpred (fun _ => R)). +Definition predat phi loc (R: mpred) := + exists sh sh' z, phi @ loc = YES sh sh' (LK z 0) (SomeP rmaps.Mpred (fun _ => R)).*) -Definition rmap_bound b phi := +(*Definition rmap_bound b phi := (forall loc, (fst loc >= b)%positive -> phi @ loc = NO Share.bot shares.bot_unreadable). (* Constructive version of resource_decay (equivalent to the @@ -79,7 +79,7 @@ Definition resource_decay_aux (nextb: block) (phi1 phi2: rmap) : Type := + (fst l >= nextb)%positive * { v | phi2 @ l = YES Share.top shares.readable_share_top (VAL v) NoneP } - + { v : _ & { pp : _ | phi1 @ l = YES Share.top shares.readable_share_top (VAL v) pp /\ phi2 @ l = NO Share.bot shares.bot_unreadable} })). + + { v : _ & { pp : _ | phi1 @ l = YES Share.top shares.readable_share_top (VAL v) pp /\ phi2 @ l = NO Share.bot shares.bot_unreadable} })).*) Ltac breakhyps := repeat @@ -112,7 +112,7 @@ Ltac sumsimpl := | |- sumbool ?A ?B => check_false B; left end. -Definition resource_decay_at (nextb: block) n (r1 r2 : resource) b := +(*Definition resource_decay_at (nextb: block) n (r1 r2 : resource) b := ((b >= nextb)%positive -> r1 = NO Share.bot shares.bot_unreadable) /\ (resource_fmap (approx (n)) (approx (n)) (r1) = (r2) \/ (exists sh, exists Psh, exists v, exists v', @@ -120,7 +120,7 @@ Definition resource_decay_at (nextb: block) n (r1 r2 : resource) b := r2 = YES sh Psh (VAL v') NoneP /\ shares.writable0_share sh) \/ ((b >= nextb)%positive /\ exists v, r2 = YES Share.top shares.readable_share_top (VAL v) NoneP) - \/ (exists v, exists pp, r1 = YES Share.top shares.readable_share_top (VAL v) pp /\ r2 = NO Share.bot shares.bot_unreadable)). + \/ (exists v, exists pp, r1 = YES Share.top shares.readable_share_top (VAL v) pp /\ r2 = NO Share.bot shares.bot_unreadable)).*) Ltac range_tac := match goal with diff --git a/concurrency/lock_specs.v b/concurrency/lock_specs.v index 07e5b85af..edc2a73ba 100644 --- a/concurrency/lock_specs.v +++ b/concurrency/lock_specs.v @@ -1,63 +1,42 @@ -Require Import VST.veric.rmaps. Require Import VST.concurrency.conclib. Require Import VST.floyd.library. -Import FashNotation. - -(* lock invariants should be exclusive *) -Class lock_impl := { t_lock : type; lock_handle : Type; ptr_of : lock_handle -> val; - lock_inv : share -> lock_handle -> mpred -> mpred; - lock_inv_nonexpansive : forall sh h, nonexpansive (lock_inv sh h); - lock_inv_share_join : forall sh1 sh2 sh3 h R, sh1 <> Share.bot -> sh2 <> Share.bot -> - sepalg.join sh1 sh2 sh3 -> lock_inv sh1 h R * lock_inv sh2 h R = lock_inv sh3 h R; - lock_inv_exclusive : forall sh h R, exclusive_mpred (lock_inv sh h R); - lock_inv_isptr : forall sh h R, lock_inv sh h R |-- !! isptr (ptr_of h) }. Section lock_specs. - Context {LI : lock_impl}. +Context `{!VSTGS OK_ty Σ}. - Lemma lock_inv_nonexpansive2 : forall {A} (P Q : A -> mpred) sh p x, (ALL x : _, |> (P x <=> Q x) |-- - |> lock_inv sh p (P x) <=> |> lock_inv sh p (Q x))%logic. - Proof. - intros. - apply allp_left with x. - eapply derives_trans, eqp_later1; apply later_derives. - apply nonexpansive_entail; apply lock_inv_nonexpansive. - Qed. +(* lock invariants should be exclusive *) +Class lock_impl := { t_lock : type; lock_handle : Type; ptr_of : lock_handle -> val; + lock_inv : Qp -> lock_handle -> mpred -> mpred; + lock_inv_nonexpansive :: forall sh h, NonExpansive (lock_inv sh h); + lock_inv_share_join : forall sh1 sh2 h R, + lock_inv sh1 h R ∗ lock_inv sh2 h R ⊣⊢ lock_inv (sh1 ⋅ sh2) h R; +(* lock_inv_exclusive : forall sh h R, exclusive_mpred (lock_inv sh h R); *) + lock_inv_isptr : forall sh h R, lock_inv sh h R ⊢ ⌜isptr (ptr_of h)⌝ }. - Lemma lock_inv_super_non_expansive : forall sh h R n, - compcert_rmaps.RML.R.approx n (lock_inv sh h R) = compcert_rmaps.RML.R.approx n (lock_inv sh h (compcert_rmaps.RML.R.approx n R)). - Proof. - intros; apply nonexpansive_super_non_expansive, lock_inv_nonexpansive. - Qed. + Context {LI : lock_impl}. Notation InvType := Mpred. (* R should be able to take the lock_handle as an argument, with subspecs for plain and selflock *) Program Definition makelock_spec := - TYPE (ProdType (ConstType globals) (ArrowType (ConstType lock_handle) InvType)) WITH gv: _, R : _ + TYPE (ProdType (ConstType globals) (DiscreteFunType lock_handle InvType)) WITH gv: _, R : _ PRE [ ] PROP () PARAMS () GLOBALS (gv) SEP (mem_mgr gv) - POST [ tptr t_lock ] EX h, + POST [ tptr t_lock ] ∃ h, PROP () RETURN (ptr_of h) - SEP (mem_mgr gv; lock_inv Tsh h (R h)). + SEP (mem_mgr gv; lock_inv 1 h (R h)). Next Obligation. Proof. - repeat intro. - destruct x; simpl. - reflexivity. + intros ? (?, ?) (?, ?) ([=] & HR) ?; simpl in *; subst; done. Qed. Next Obligation. Proof. - repeat intro. - destruct x; simpl. - rewrite !approx_exp; f_equal; extensionality. - unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, argsassert2assert; simpl; rewrite !approx_andp; do 2 f_equal; - rewrite -> !sepcon_emp, ?approx_sepcon, ?approx_idem. - f_equal; apply lock_inv_super_non_expansive. + intros ? (?, ?) (?, ?) ([=] & HR) ?; simpl in *; subst. + by repeat f_equiv. Qed. Program Definition freelock_spec := @@ -66,31 +45,20 @@ Section lock_specs. PRE [ tptr t_lock ] PROP () PARAMS (ptr_of h) - SEP (lock_inv Tsh h R; P; (P * lock_inv Tsh h R * R -* FF) && emp) + SEP (lock_inv 1 h R; P; (P ∗ lock_inv 1 h R ∗ R -∗ False)) POST[ tvoid ] PROP () LOCAL () SEP (P). Next Obligation. Proof. - repeat intro. - destruct x as ((?, ?), ?); simpl. - unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, argsassert2assert; simpl; rewrite !approx_andp; do 3 f_equal; - rewrite -> !sepcon_emp, ?approx_sepcon, ?approx_idem. - f_equal. - { apply lock_inv_super_non_expansive. } - f_equal. - rewrite !approx_andp; f_equal. - setoid_rewrite wand_nonexpansive; rewrite !approx_sepcon; do 2 f_equal; rewrite !approx_idem; auto. - do 2 f_equal; apply lock_inv_super_non_expansive. + intros ? ((?, ?), ?) ((?, ?), ?) (([=] & HR) & HP) ?; simpl in *; subst. + by repeat f_equiv. Qed. Next Obligation. Proof. - repeat intro. - destruct x as ((?, ?), ?); simpl. - unfold PROPx, LOCALx, SEPx; simpl; rewrite !approx_andp; do 2 f_equal; - rewrite -> !sepcon_emp, ?approx_sepcon, ?approx_idem. - reflexivity. + intros ? ((?, ?), ?) ((?, ?), ?) (([=] & HR) & HP) ?; simpl in *; subst. + by repeat f_equiv. Qed. Program Definition freelock_spec_simple := @@ -99,48 +67,43 @@ Section lock_specs. PRE [ tptr t_lock ] PROP () PARAMS (ptr_of h) - SEP (weak_exclusive_mpred R && emp; lock_inv Tsh h R; R) + SEP ( (R ∗ R -∗ False); lock_inv 1 h R; R) POST[ tvoid ] PROP () LOCAL () SEP (R). Next Obligation. Proof. - repeat intro. - destruct x; simpl. - unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, argsassert2assert; simpl; rewrite !approx_andp; do 3 f_equal; - rewrite -> !sepcon_emp, ?approx_sepcon, ?approx_idem. - f_equal. - { rewrite !approx_andp; f_equal. - apply exclusive_mpred_super_non_expansive. } - f_equal. apply lock_inv_super_non_expansive. + intros ? (?, ?) (?, ?) ([=] & HR) ?; simpl in *; subst. + by repeat f_equiv. Qed. Next Obligation. Proof. - repeat intro. - destruct x; simpl. - unfold PROPx, LOCALx, SEPx; simpl; rewrite !approx_andp; do 2 f_equal; - rewrite -> !sepcon_emp, ?approx_sepcon, ?approx_idem. - reflexivity. + intros ? (?, ?) (?, ?) ([=] & HR) ?; simpl in *; subst. + by repeat f_equiv. Qed. Lemma freelock_simple : funspec_sub freelock_spec freelock_spec_simple. Proof. unfold funspec_sub; simpl. - split; auto; intros ? (h, R) ?; Intros. - eapply derives_trans, fupd_intro. - Exists (nil : list Type) (h, R, R) emp; entailer!. - unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, argsassert2assert; simpl; entailer!. - apply andp_right, andp_left2; auto. - rewrite <- wand_sepcon_adjoint; sep_apply weak_exclusive_conflict; auto. - rewrite FF_sepcon; auto. + split; first done; intros (h, R) ?; Intros. + iIntros "(? & ? & H) !>"; iExists (h, R, R), emp. + iSplit; first done. + iSplit; last by iPureIntro; entailer!. + repeat (iSplit; first done). + rewrite /SEPx /= /LOCALx /argsassert2assert /=; monPred.unseal. + repeat (iSplit; first done). + iDestruct "H" as "(? & HR & $ & $ & _)". + repeat (iSplit; last done). + iApply (bi.affinely_mono with "HR"). + iIntros "HR (? & ? & ?)"; iApply ("HR" with "[$]"). Qed. Program Definition acquire_spec := TYPE (ProdType (ConstType _) InvType) WITH sh : _, h : _, R : _ PRE [ tptr t_lock ] - PROP (sh <> Share.bot) + PROP () PARAMS (ptr_of h) SEP (lock_inv sh h R) POST [ tvoid ] @@ -149,102 +112,91 @@ Section lock_specs. SEP (lock_inv sh h R; R). Next Obligation. Proof. - repeat intro. - destruct x as ((?, ?), ?); simpl. - unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, argsassert2assert; simpl; rewrite !approx_andp; do 3 f_equal; - rewrite -> !sepcon_emp, ?approx_sepcon, ?approx_idem. - apply lock_inv_super_non_expansive. + intros ? ((?, ?), ?) ((?, ?), ?) ([=] & HR) ?; simpl in *; subst. + by repeat f_equiv. Qed. Next Obligation. Proof. - repeat intro. - destruct x as ((?, ?), ?); simpl. - unfold PROPx, LOCALx, SEPx; simpl; rewrite !approx_andp; do 2 f_equal; - rewrite -> !sepcon_emp, ?approx_sepcon, ?approx_idem. - f_equal. apply lock_inv_super_non_expansive. + intros ? ((?, ?), ?) ((?, ?), ?) ([=] & HR) ?; simpl in *; subst. + by repeat f_equiv. Qed. Program Definition release_spec := TYPE (ProdType (ProdType (ProdType (ConstType _) InvType) Mpred) Mpred) WITH sh : _, h : _, R : _, P : _, Q : _ PRE [ tptr t_lock ] - PROP (sh <> Share.bot) + PROP () PARAMS (ptr_of h) - SEP (weak_exclusive_mpred R && emp; |> lock_inv sh h R; P; lock_inv sh h R * P -* Q * R) + SEP ( (R ∗ R -∗ False); ▷ lock_inv sh h R; P; lock_inv sh h R ∗ P -∗ Q ∗ R) POST [ tvoid ] PROP () LOCAL () SEP (Q). Next Obligation. Proof. - repeat intro. - destruct x as ((((?, ?), ?), ?), ?); simpl. - unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, argsassert2assert; simpl; rewrite !approx_andp; do 3 f_equal; - rewrite -> !sepcon_emp, ?approx_sepcon, ?approx_idem. - f_equal. - { rewrite !approx_andp; f_equal. - apply exclusive_mpred_super_non_expansive. } - f_equal. - { setoid_rewrite later_nonexpansive; do 2 f_equal. - apply lock_inv_super_non_expansive. } - f_equal. - setoid_rewrite wand_nonexpansive; rewrite !approx_sepcon; do 2 f_equal; rewrite !approx_idem; f_equal. - apply lock_inv_super_non_expansive. + intros ? ((((?, ?), ?), ?), ?) ((((?, ?), ?), ?), ?) ((([=] & HR) & HP) & HQ) ?; simpl in *; subst. + by repeat f_equiv. Qed. Next Obligation. Proof. - repeat intro. - destruct x as ((((?, ?), ?), ?), ?); simpl. - unfold PROPx, LOCALx, SEPx; simpl; rewrite !approx_andp; do 2 f_equal; - rewrite -> !sepcon_emp, ?approx_sepcon, ?approx_idem. - reflexivity. + intros ? ((((?, ?), ?), ?), ?) ((((?, ?), ?), ?), ?) ((([=] & HR) & HP) & HQ) ?; simpl in *; subst. + by repeat f_equiv. Qed. Program Definition release_spec_simple := TYPE (ProdType (ConstType _) InvType) WITH sh : _, h : _, R : _ PRE [ tptr t_lock ] - PROP (sh <> Share.bot) + PROP () PARAMS (ptr_of h) - SEP (weak_exclusive_mpred R && emp; lock_inv sh h R; R) + SEP ( (R ∗ R -∗ False); lock_inv sh h R; R) POST [ tvoid ] PROP () LOCAL () SEP (lock_inv sh h R). Next Obligation. Proof. - repeat intro. - destruct x as ((?, ?), ?); simpl. - unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, argsassert2assert; simpl; rewrite !approx_andp; do 3 f_equal; - rewrite -> !sepcon_emp, ?approx_sepcon, ?approx_idem. - f_equal. - { rewrite !approx_andp; f_equal. - apply exclusive_mpred_super_non_expansive. } - f_equal. - apply lock_inv_super_non_expansive. + intros ? ((?, ?), ?) ((?, ?), ?) ([=] & HR) ?; simpl in *; subst. + by repeat f_equiv. Qed. Next Obligation. Proof. - repeat intro. - destruct x as ((?, ?), ?); simpl. - unfold PROPx, LOCALx, SEPx; simpl; rewrite !approx_andp; do 2 f_equal; - rewrite -> !sepcon_emp, ?approx_sepcon, ?approx_idem. - apply lock_inv_super_non_expansive. + intros ? ((?, ?), ?) ((?, ?), ?) ([=] & HR) ?; simpl in *; subst. + by repeat f_equiv. Qed. Lemma release_simple : funspec_sub release_spec release_spec_simple. Proof. unfold funspec_sub; simpl. - split; auto; intros ? ((sh, h), R) ?; Intros. - eapply derives_trans, fupd_intro. - Exists (nil : list Type) (sh, h, R, R, lock_inv sh h R) emp; entailer!. - unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, argsassert2assert; simpl; entailer!. - apply wand_refl_cancel_right. - Qed. + split; first done; intros ((sh, h), R) ?; Intros. + iIntros "(? & ? & H) !>"; iExists (sh, h, R, R, lock_inv sh h R), emp. + iSplit; first done. + iSplit; last by iPureIntro; entailer!. + repeat (iSplit; first done). + rewrite /SEPx /= /LOCALx /argsassert2assert /=; monPred.unseal. + repeat (iSplit; first done). + iDestruct "H" as "(? & HR & $ & $ & _)". + iFrame; auto. + Qed. + + Definition concurrent_specs (cs : compspecs) (ext_link : string -> ident) := + (ext_link "spawn"%string, spawn_spec) :: + (ext_link "makelock"%string, makelock_spec) :: + (ext_link "freelock"%string, freelock_spec) :: + (ext_link "acquire"%string, acquire_spec) :: + (ext_link "release"%string, release_spec) :: + nil. + + #[export] Instance concurrent_ext_spec (cs : compspecs) (ext_link : string -> ident) : ext_spec OK_ty := + add_funspecs_rec OK_ty + ext_link + (void_spec OK_ty) + (concurrent_specs cs ext_link). End lock_specs. #[export] Hint Resolve lock_inv_isptr : saturate_local. -#[export] Hint Resolve lock_inv_exclusive data_at_exclusive data_at__exclusive field_at_exclusive field_at__exclusive : core. +#[export] Hint Resolve data_at_exclusive data_at__exclusive field_at_exclusive field_at__exclusive : core. -Ltac lock_props := match goal with |-context[weak_exclusive_mpred ?P && emp] => sep_apply (exclusive_weak_exclusive P); [auto with share | try timeout 20 cancel] end. +Ltac lock_props := match goal with |-context[ (?P ∗ ?P -∗ False)] => rewrite -(exclusive_weak_exclusive P); + [rewrite bi.affinely_emp ?bi.emp_sep ?bi.sep_emp | auto with share] end. diff --git a/concurrency/main.v b/concurrency/main.v index 2ae5bf1d9..e9c0d7d2f 100644 --- a/concurrency/main.v +++ b/concurrency/main.v @@ -77,7 +77,7 @@ Module MainTheorem CSL_init_setup C_program src_m src_cpm -> (*Correct entry point Clight (There is inconsistencies with CSL_init_Setup)*) - (* TODO: fix initial state inconsistenciees and unify. *) + (* TODO: fix initial state inconsistencies and unify. *) Clight.entry_point (Clight.globalenv C_program) src_m src_cpm (main_ptr C_program) nil -> (* ASM memory good. *) diff --git a/concurrency/memsem_lemmas.v b/concurrency/memsem_lemmas.v index 0b4fa3ffa..66e1da376 100644 --- a/concurrency/memsem_lemmas.v +++ b/concurrency/memsem_lemmas.v @@ -10,8 +10,9 @@ Require Import compcert.common.AST. Require Import compcert.common.Globalenvs. Require Import VST.msl.Extensionality. +Require Export VST.sepcomp.semantics. Require Import VST.sepcomp.mem_lemmas. -Require Import VST.concurrency.common.core_semantics. +(*Require Import VST.concurrency.common.core_semantics.*) Require Import VST.msl.Coqlib2. @@ -133,9 +134,9 @@ split; intros. destruct (eq_block b0 b); subst. - destruct (zle ofs ofs0). destruct (zlt ofs0 (ofs + Z.of_nat (length l))). - elim H. eapply Mem.perm_max. apply L. omega. - rewrite PMap.gss. apply Mem.setN_other. intros. omega. - rewrite PMap.gss. apply Mem.setN_other. intros. omega. + elim H. eapply Mem.perm_max. apply L. lia. + rewrite PMap.gss. apply Mem.setN_other. intros. lia. + rewrite PMap.gss. apply Mem.setN_other. intros. lia. - rewrite PMap.gso; trivial. Qed. @@ -204,8 +205,8 @@ Proof. induction l; simpl; intros. split; intros. apply (Mem.perm_free_1 _ _ _ _ _ Heqw) in H0; eauto. eapply Mem.perm_free_3; eassumption. split; intros. - eelim (Mem.perm_free_2 _ _ _ _ _ Heqw ofs Max Nonempty); clear Heqw; trivial. omega. - eelim (Mem.perm_free_2 _ _ _ _ _ Heqw ofs Max Nonempty); clear Heqw. omega. + eelim (Mem.perm_free_2 _ _ _ _ _ Heqw ofs Max Nonempty); clear Heqw; trivial. lia. + eelim (Mem.perm_free_2 _ _ _ _ _ Heqw ofs Max Nonempty); clear Heqw. lia. eapply Mem.perm_implies. eapply Mem.perm_max. eassumption. constructor. - split; intros. * eapply (Mem.perm_free_1 _ _ _ _ _ Heqw); trivial. intuition. @@ -354,15 +355,15 @@ Qed. Lemma mem_step_nextblock: memstep_preserve (fun m m' => Mem.nextblock m <= Mem.nextblock m')%positive. constructor. -+ intros. xomega. ++ intros. lia. + induction 1. - apply Mem.nextblock_storebytes in H; - rewrite H; xomega. + rewrite H; lia. - apply Mem.nextblock_alloc in H. - rewrite H. clear. xomega. + rewrite H. clear. lia. - apply nextblock_freelist in H. - rewrite H; xomega. - - xomega. + rewrite H; lia. + - lia. Qed. Lemma mem_step_nextblock': @@ -412,7 +413,7 @@ induction E. destruct (peq b0 b); subst; simpl. 2: intuition. destruct (zle lo ofs); simpl. 2: intuition. destruct (zlt ofs hi); simpl. 2: intuition. - elim H. eapply Mem.perm_max. eapply Mem.perm_implies. apply r. omega. constructor. + elim H. eapply Mem.perm_max. eapply Mem.perm_implies. apply r. lia. constructor. + trivial. + eapply unch_on_loc_not_writable_trans; try eassumption. eapply estep_forward; eassumption. Qed. @@ -432,12 +433,12 @@ Transparent Mem.loadbytes. red; intros. specialize (Mem.perm_drop_1 _ _ _ _ _ _ D ofs0 Cur); intros. destruct (eq_block b' b); subst. destruct H. eapply Mem.perm_drop_3. eassumption. left; trivial. apply r. trivial. - destruct (zlt ofs lo). eapply Mem.perm_drop_3. eassumption. right. omega. apply r. trivial. - destruct H. omega. - destruct (zle hi ofs). eapply Mem.perm_drop_3. eassumption. right. omega. apply r. trivial. - destruct H. omega. - eapply Mem.perm_implies. apply H1. omega. trivial. - eapply Mem.perm_drop_3. eassumption. left; trivial. apply r. omega. + destruct (zlt ofs lo). eapply Mem.perm_drop_3. eassumption. right. lia. apply r. trivial. + destruct H. lia. + destruct (zle hi ofs). eapply Mem.perm_drop_3. eassumption. right. lia. apply r. trivial. + destruct H. lia. + eapply Mem.perm_implies. apply H1. lia. trivial. + eapply Mem.perm_drop_3. eassumption. left; trivial. apply r. lia. destruct (Mem.range_perm_dec m' b' ofs (ofs + 1) Cur Readable); trivial. elim n; clear n. red; intros. eapply Mem.perm_drop_4. eassumption. apply r. trivial. @@ -477,7 +478,7 @@ Opaque Mem.storebytes. destruct (peq b b0). subst b0. rewrite PMap.gss. destruct (zeq ofs0 ofs). subst. - contradiction H0. apply r. simpl. omega. + contradiction H0. apply r. simpl. lia. rewrite ZMap.gso; auto. rewrite PMap.gso; auto. clear - H H1. @@ -499,7 +500,7 @@ Opaque Mem.storebytes. intros [? ?]. subst b0. apply H0. apply Mem.free_range_perm in Heqo. specialize (Heqo ofs). - eapply Mem.perm_implies. apply Heqo. omega. constructor. + eapply Mem.perm_implies. apply Heqo. lia. constructor. clear - H Heqo. unfold Mem.valid_block in *. apply Mem.nextblock_free in Heqo. rewrite Heqo. @@ -554,10 +555,10 @@ revert j H; induction n; intros; simpl; f_equal. apply perm_le_cont. apply (H j). rewrite inj_S. -omega. +lia. apply IHn. rewrite inj_S in H. -intros ofs ?; apply H. omega. +intros ofs ?; apply H. lia. clear - H perm_le_Cur. destruct H; split; auto. intros ? ?. specialize (H ofs H1). @@ -592,19 +593,19 @@ forget (Ptrofs.unsigned i) as z. destruct (eq_block b0 b). subst. rewrite !PMap.gss. forget (encode_val ch v2) as vl. -assert (z <= ofs < z + Z.of_nat (length vl) \/ ~ (z <= ofs < z + Z.of_nat (length vl))) by omega. +assert (z <= ofs < z + Z.of_nat (length vl) \/ ~ (z <= ofs < z + Z.of_nat (length vl))) by lia. destruct H0. clear - H0. forget ((Mem.mem_contents m1) !! b) as mA. forget ((Mem.mem_contents m) !! b) as mB. revert z mA mB H0; induction vl; intros; simpl. -simpl in H0; omega. +simpl in H0; lia. simpl length in H0; rewrite inj_S in H0. destruct (zeq z ofs). subst ofs. -rewrite !Mem.setN_outside by omega. rewrite !ZMap.gss; auto. -apply IHvl; omega. -rewrite !Mem.setN_outside by omega. +rewrite !Mem.setN_outside by lia. rewrite !ZMap.gss; auto. +apply IHvl; lia. +rewrite !Mem.setN_outside by lia. apply perm_le_cont. auto. rewrite !PMap.gso by auto. apply perm_le_cont. auto. @@ -646,7 +647,7 @@ destruct (peq b' b); subst. - left. split; trivial. destruct (zle lo ofs); simpl in *; try discriminate. split; trivial. destruct (zlt ofs hi); simpl in *; try discriminate. split; trivial. - assert (RP: Mem.perm m b ofs Cur Freeable). apply (Mem.free_range_perm _ _ _ _ _ FR ofs); omega. + assert (RP: Mem.perm m b ofs Cur Freeable). apply (Mem.free_range_perm _ _ _ _ _ FR ofs); lia. destruct k. * eapply Mem.perm_max in RP. unfold Mem.perm in RP. destruct ((Mem.mem_access m) !! b ofs Max); simpl in *; try discriminate. @@ -654,7 +655,7 @@ destruct (peq b' b); subst. * unfold Mem.perm in RP. destruct ((Mem.mem_access m) !! b ofs Cur); simpl in *; try discriminate. destruct p; simpl in *; try inv RP; simpl; trivial. contradiction. - right; split; trivial. right. - destruct (zle lo ofs); destruct (zlt ofs hi); simpl in *; try discriminate; try omega. + destruct (zle lo ofs); destruct (zlt ofs hi); simpl in *; try discriminate; try lia. + right; split; trivial. left; trivial. Qed. @@ -688,7 +689,7 @@ Proof. intros. rewrite (Mem.free_result _ _ _ _ _ FL) in *. simpl in *. rewrite PMap.gss in Heqw. remember (zle lo ofs&& zlt ofs hi ) as t; destruct t; simpl in *; try discriminate. - destruct (zle lo ofs); destruct (zlt ofs hi); simpl in *; try discriminate; omega. + destruct (zle lo ofs); destruct (zlt ofs hi); simpl in *; try discriminate; lia. ++ destruct H0 as [? ?]. rewrite H1 in *; simpl in *; contradiction. - specialize (perm_le_Max b0 ofs); clear perm_le_Cur perm_le_cont. remember ((Mem.mem_access mm) !! b0 ofs Max) as q; symmetry in Heqq. @@ -705,7 +706,7 @@ Proof. intros. rewrite (Mem.free_result _ _ _ _ _ FL) in *. simpl in *. rewrite PMap.gss in Heqw. remember (zle lo ofs&& zlt ofs hi ) as t; destruct t; simpl in *; try discriminate. - destruct (zle lo ofs); destruct (zlt ofs hi); simpl in *; try discriminate; omega. + destruct (zle lo ofs); destruct (zlt ofs hi); simpl in *; try discriminate; lia. ++ destruct H0 as [? ?]. rewrite H1 in *; simpl in *; contradiction. - rewrite (Mem.free_result _ _ _ _ _ FL). rewrite (Mem.free_result _ _ _ _ _ MM). simpl. apply perm_le_cont. eapply Mem.perm_free_3; eassumption. @@ -743,16 +744,16 @@ destruct (Mem.range_perm_dec m1 b ofs (ofs + Z.of_nat (length bytes)) Cur Writab * destruct (zlt ofs0 ofs). ++ rewrite Mem.setN_outside. 2: left; trivial. rewrite Mem.setN_outside. 2: left; trivial. apply perm_le_cont. apply H. ++ destruct (zle (ofs+Z.of_nat (length bytes)) ofs0). - rewrite Mem.setN_outside. 2: right; xomega. rewrite Mem.setN_outside. 2: right; xomega. apply perm_le_cont. apply H. + rewrite Mem.setN_outside. 2: right; lia. rewrite Mem.setN_outside. 2: right; lia. apply perm_le_cont. apply H. clear - g g0. remember ((Mem.mem_contents m1) !! b) as mA. clear HeqmA. remember ((Mem.mem_contents m) !! b) as mB. clear HeqmB. revert ofs mA mB g g0; induction bytes; intros; simpl. - -- simpl in *; omega. + -- simpl in *; lia. -- simpl length in g0; rewrite inj_S in g0. destruct (zeq ofs ofs0). - ** subst ofs0. rewrite !Mem.setN_outside by omega. rewrite !ZMap.gss; auto. - ** apply IHbytes; omega. + ** subst ofs0. rewrite !Mem.setN_outside by lia. rewrite !ZMap.gss; auto. + ** apply IHbytes; lia. * apply perm_le_cont. apply H. - assumption . + elim n; clear - PLE r. destruct PLE. @@ -776,7 +777,7 @@ apply loadbytes_D in LD. destruct LD as [RP1 CONT]. destruct PLE. destruct (Mem.range_perm_dec m1 b ofs (ofs + n) Cur Readable). + rewrite CONT; f_equal. eapply Mem.getN_exten. - intros. apply perm_le_cont. apply RP1. rewrite Z2Nat.id in H; omega. + intros. apply perm_le_cont. apply RP1. rewrite Z2Nat.id in H; lia. + elim n0; clear - RP1 perm_le_Cur. red; intros. specialize (RP1 _ H). specialize (perm_le_Cur b ofs0). unfold Mem.perm in *. @@ -796,7 +797,7 @@ rewrite PMap.gsspec in P. destruct (peq b' (Mem.nextblock m)); subst; trivial. + left; split; trivial. remember (zle lo ofs && zlt ofs hi) as q. destruct q; inv P; trivial. - destruct (zle lo ofs); destruct (zlt ofs hi); simpl in *; try discriminate; omega. + destruct (zle lo ofs); destruct (zlt ofs hi); simpl in *; try discriminate; lia. + right; split; trivial. Qed. @@ -806,7 +807,7 @@ Proof. Transparent Mem.alloc. unfold Mem.alloc in ALLOC. Opaque Mem.alloc. inv ALLOC; simpl in *. rewrite PMap.gsspec in P. destruct (peq b' (Mem.nextblock m)); subst; trivial. -apply Mem.nextblock_noaccess. xomega. +apply Mem.nextblock_noaccess. unfold Plt; lia. Qed. Lemma alloc_inc_perm: forall m lo hi m' b diff --git a/concurrency/semax_conc.v b/concurrency/semax_conc.v index 587dfa368..363a5d5f1 100644 --- a/concurrency/semax_conc.v +++ b/concurrency/semax_conc.v @@ -1,392 +1,24 @@ -Require Import VST.msl.msl_standard. -Require Import VST.msl.seplog. -Require Import VST.veric.Clight_base. -Require Import VST.veric.compcert_rmaps. -Require Import VST.veric.juicy_mem. -Require Import VST.veric.juicy_mem_lemmas. -Require Import VST.veric.juicy_mem_ops. +Set Warnings "-notation-overridden,-custom-entry-overridden,-hiding-delimiting-key". Require Import VST.veric.juicy_extspec. -Require Import VST.veric.tycontext. -Require Import VST.veric.expr2. -Require Import VST.veric.semax. -Require Import VST.veric.semax_call. -Require Import VST.veric.semax_ext. -Require Import VST.veric.juicy_safety. -Require Import VST.veric.res_predicates. Require Import VST.veric.SeparationLogic. -Require Import VST.sepcomp.semantics. -Require Import VST.sepcomp.extspec. -Require Import VST.floyd.reptype_lemmas. -Require Import VST.floyd.field_at. -Require Import VST.floyd.nested_field_lemmas. -Require Import VST.floyd.client_lemmas. -Require Import VST.floyd.jmeq_lemmas. +Set Warnings "notation-overridden,custom-entry-overridden,hiding-delimiting-key". +Require Import compcert.cfrontend.Ctypes. +Require Import VST.veric.expr. Require Import VST.concurrency.semax_conc_pred. -Import FashNotation. +Require Import VST.floyd.client_lemmas. +Require Import VST.floyd.field_at. +Import Clightdefs. Import String. Open Scope funspec_scope. Definition spawned_funtype := Tfunction (Tcons (tptr tvoid) Tnil) tint cc_default. -Lemma nonexpansive_entail (F: pred rmap -> pred rmap) : nonexpansive F -> forall P Q, (P <=> Q |-- F P <=> F Q)%logic. -Proof. - intros N P Q. - specialize (N P Q). - eapply derives_trans; [ eapply derives_trans | ]; [ | constructor; apply N | ]; - apply derives_refl. -Qed. - -Lemma HOnonexpansive_nonexpansive: forall F: mpred -> mpred, nonexpansive F <-> HOnonexpansive (fun P (_ : unit) => F (P tt)). -Proof. - intros. - split; intros; hnf in H |- *. - + intros P Q. - specialize (H (P tt) (Q tt)). - rewrite !allp_unit. - constructor; auto. - + intros P Q. - specialize (H (fun x => P) (fun x => Q)). - rewrite !allp_unit in H. - inv H; auto. -Qed. - -Lemma eqp_refl : forall (G : Triv) P, G |-- (P <=> P)%logic. -Proof. - intros; rewrite andp_dup; apply subp_refl. -Qed. - -Lemma eqp_sepcon : forall (G : Triv) (P P' Q Q' : mpred) - (HP : (G |-- P <=> P')%logic) (HQ : (G |-- Q <=> Q')%logic), (G |-- P * Q <=> P' * Q')%logic. -Proof. - intros. - rewrite fash_andp in HP, HQ |- *. - inv HP; rename derivesI into HP. - inv HQ; rename derivesI into HQ. - apply andp_right; apply subp_sepcon; auto; constructor; intros ? Ha; destruct (HP _ Ha), (HQ _ Ha); auto. -Qed. - -Lemma eqp_andp : forall (G : Triv) (P P' Q Q' : mpred) - (HP : (G |-- P <=> P')%logic) (HQ : (G |-- Q <=> Q')%logic), G |-- (P && Q <=> P' && Q')%logic. -Proof. - intros. - rewrite fash_andp in HP, HQ |- *. - inv HP; rename derivesI into HP. - inv HQ; rename derivesI into HQ. - apply andp_right; apply subp_andp; auto; constructor; intros ? Ha; destruct (HP _ Ha), (HQ _ Ha); auto. -Qed. - -Lemma eqp_exp : forall (A : Type) (NA : NatDed A) (IA : Indir A) (RecIndir : RecIndir A) - (G : Triv) (B : Type) (X Y : B -> A), - (forall x : B, (G |-- X x <=> Y x)%logic) -> - G |-- ((EX x : _, X x) <=> (EX x : _, Y x))%logic. -Proof. - intros. - rewrite fash_andp; apply andp_right; apply subp_exp; intro x; specialize (H x); rewrite fash_andp in H; - inv H; rename derivesI into H; constructor; intros ? Ha; destruct (H _ Ha); auto. -Qed. - -(* - -(* In fact we need locks to two resources: - 1) the resource invariant, for passing the resources - 2) the join resource invariant, for returning all resources, including itself - for this we need to define them in a mutually recursive fashion: *) +Section mpred. -Definition res_invariants_fun Q sh1 p1 sh2 p2 : (bool -> mpred) -> (bool -> mpred) := - fun R b => - if b then - (Q * lock_inv sh2 p2 (|> R false))%logic - else - (Q * lock_inv sh1 p1 (|> R true) * lock_inv sh2 p2 (|> R false))%logic. - -Definition res_invariants Q sh1 p1 sh2 p2 : bool -> mpred := HORec (res_invariants_fun Q sh1 p1 sh2 p2). -Definition res_invariant Q sh1 p1 sh2 p2 : mpred := res_invariants Q sh1 p1 sh2 p2 true. -Definition join_res_invariant Q sh1 p1 sh2 p2 : mpred := res_invariants Q sh1 p1 sh2 p2 false. - -Lemma res_invariants_eq Q sh1 p1 sh2 p2 : res_invariants Q sh1 p1 sh2 p2 = - res_invariants_fun Q sh1 p1 sh2 p2 (res_invariants Q sh1 p1 sh2 p2). -Proof. - apply HORec_fold_unfold, prove_HOcontractive. - intros P1 P2 b. - destruct b. - (* resource invariant *) - apply subp_sepcon; try apply subp_refl. - apply allp_left with false. - eapply derives_trans. - apply nonexpansive_entail, nonexpansive_lock_inv. - apply fash_derives, andp_left1, derives_refl. - - (* join resource invariant *) - repeat apply subp_sepcon; try apply subp_refl. - apply allp_left with true. - eapply derives_trans. - apply nonexpansive_entail, nonexpansive_lock_inv. - apply fash_derives, andp_left1, derives_refl. - - apply allp_left with false. - eapply derives_trans. - apply nonexpansive_entail, nonexpansive_lock_inv. - apply fash_derives, andp_left1, derives_refl. -Qed. - -Lemma res_invariant_eq Q sh1 p1 sh2 p2 : - res_invariant Q sh1 p1 sh2 p2 = - (Q * - lock_inv sh2 p2 (|> join_res_invariant Q sh1 p1 sh2 p2))%logic. -Proof. - unfold res_invariant at 1. - rewrite res_invariants_eq. - reflexivity. -Qed. - -Lemma join_res_invariant_eq Q sh1 p1 sh2 p2 : - join_res_invariant Q sh1 p1 sh2 p2 = - (Q * - lock_inv sh1 p1 (|> res_invariant Q sh1 p1 sh2 p2) * - lock_inv sh2 p2 (|> join_res_invariant Q sh1 p1 sh2 p2))%logic. -Proof. - unfold join_res_invariant at 1. - rewrite res_invariants_eq. - reflexivity. -Qed.*) - -(*(* Condition variables *) -Definition tcond := tint. - -(* Does this need to be anything special? *) -Definition cond_var {cs} sh v := @data_at_ cs sh tcond v.*) +Context `{!VSTGS OK_ty Σ}. (*+ Specification of each concurrent primitive *) -Lemma approx_eq_i': - forall (P Q : pred rmap) n, - (|> (P <=> Q))%pred n -> approx n P = approx n Q. -Proof. - intros. -apply pred_ext'; extensionality m'. -unfold approx. -apply and_ext'; auto; intros. -specialize (H (level m')); spec H; [simpl; apply later_nat; auto |]. -specialize (H m'). -spec H; [lia |]. -destruct H. -specialize (H m'). -specialize (H1 m'). -apply prop_ext; split; auto. -Qed. - -Lemma fash_equiv_approx: forall n (R: pred rmap), - (|> (R <=> approx n R))%pred n. -Proof. - intros. - intros m ? x ?; split; intros ? y ? ? ?. - + apply approx_lt; auto. - apply necR_level in H1. apply ext_level in H2. - apply later_nat in H; lia. - + eapply approx_p; eauto. -Qed. - -Lemma nonexpansive_super_non_expansive: forall (F: mpred -> mpred), - nonexpansive F -> - forall R n, - approx n (F R) = approx n (F (approx n R)). -Proof. - intros. - apply approx_eq_i'. - intros m ?. - apply nonexpansive_entail; auto. - clear - H0. - apply (fash_equiv_approx n R m); auto. -Qed. - -Lemma nonexpansive2_super_non_expansive: forall (F: mpred -> mpred -> mpred), - (forall P, nonexpansive (fun Q => F P Q)) -> - (forall Q, nonexpansive (fun P => F P Q)) -> - forall P Q n, - approx n (F P Q) = approx n (F (approx n P) (approx n Q)). -Proof. - intros. - apply approx_eq_i'. - intros m ?. - pose proof nonexpansive_entail _ (H P) Q (approx n Q) as H2. - inv H2; rename derivesI into H2. specialize (H2 m); cbv beta in H2. - spec H2; [apply (fash_equiv_approx n Q m); auto |]. - pose proof nonexpansive_entail _ (H0 (approx n Q)) P (approx n P) as H3. - inv H3; rename derivesI into H3. specialize (H3 m); cbv beta in H3. - spec H3; [apply (fash_equiv_approx n P m); auto |]. - remember (F P Q) as X1. - remember (F P (approx n Q)) as X2. - remember (F (approx n P) (approx n Q)) as X3. - clear - H2 H3. - change ((X1 <=> X2)%pred m) in H2. - change ((X2 <=> X3)%pred m) in H3. - intros y H; specialize (H2 y H); specialize (H3 y H). - destruct H2 as [H2A H2B], H3 as [H3A H3B]. - split; intros z H0. - + specialize (H2A z H0); specialize (H3A z H0); auto. - + specialize (H2B z H0); specialize (H3B z H0); auto. -Qed. - -(* -Lemma nonexpansive_2super_non_expansive: forall {A B: Type} (F: (A -> B -> mpred) -> mpred), - (forall a b, nonexpansive (fun Q => F P Q)) -> - (forall Q, nonexpansive (fun P => F P Q)) -> - forall P Q n, - approx n (F P Q) = approx n (F (approx n P) (approx n Q)). -*) - -(*(* condition variables *) -Definition makecond_spec cs := - WITH v : val, sh : share - PRE [ (*_cond OF*) tptr tcond ] - PROP (writable_share sh) - (*LOCAL (temp _cond v)*) PARAMS (v) GLOBALS () - SEP (@data_at_ cs sh tcond v) - POST [ tvoid ] - PROP () - LOCAL () - SEP (cond_var sh v). - -Definition freecond_spec cs := - WITH v : val, sh : share - PRE [ (*_cond OF*) tptr tcond ] - PROP (writable_share sh) - (*LOCAL (temp _cond v)*) PARAMS (v) GLOBALS () - SEP (@cond_var cs sh v) - POST [ tvoid ] - PROP () - LOCAL () - SEP (@data_at_ cs sh tcond v). - -Program Definition wait_spec cs: funspec := mk_funspec - (* ((_cond OF tptr tcond)%formals :: (_lock OF tptr Tvoid)%formals :: nil, tvoid)*) - ((tptr tcond) :: (tptr Ctypes.Tvoid) :: nil, tvoid) - cc_default - (rmaps.ProdType (rmaps.ConstType (val * val * share * share)) rmaps.Mpred) - (fun _ x => - match x with - | (c, l, shc, shl, R) => - PROP (readable_share shc) - PARAMS (c;l) GLOBALS () - SEP (@cond_var cs shc c; lock_inv shl l R; R) - end)%argsassert - (fun _ x => - match x with - | (c, l, shc, shl, R) => - PROP () - LOCAL () - SEP (cond_var shc c; lock_inv shl l R; R) - end) - _ - _ -. -Next Obligation. - intros cs; hnf. - intros. - destruct x as [[[[c l] shc] shl] R]; simpl in *. - apply (nonexpansive_super_non_expansive - (fun R => (PROP (readable_share shc) - PARAMS (c;l) GLOBALS () - SEP (cond_var shc c; lock_inv shl l R; R))%argsassert gargs)). - apply (PROP_PARAMS_GLOBALS_SEP_nonexpansive - ((fun _ => readable_share shc) :: nil) - (*(temp _cond c :: temp _lock l :: nil)*)(c::l :: nil) nil - ((fun R => cond_var shc c) :: (fun R => lock_inv shl l R) :: (fun R => R) :: nil)); - repeat apply Forall_cons; try apply Forall_nil. - + apply const_nonexpansive. - + apply const_nonexpansive. - + apply nonexpansive_lock_inv. - + apply identity_nonexpansive. -Qed. -Next Obligation. - intros cs; hnf. - intros. - destruct x as [[[[c l] shc] shl] R]; simpl in *. - apply (nonexpansive_super_non_expansive - (fun R => (PROP () - LOCAL () - SEP (cond_var shc c; lock_inv shl l R; R)) rho)). - apply (PROP_LOCAL_SEP_nonexpansive - nil - nil - ((fun R => cond_var shc c) :: (fun R => lock_inv shl l R) :: (fun R => R) :: nil)); - repeat apply Forall_cons; try apply Forall_nil. - + apply const_nonexpansive. - + apply nonexpansive_lock_inv. - + apply identity_nonexpansive. -Qed. - -Program Definition wait2_spec cs: funspec := mk_funspec - (*((_cond OF tptr tcond)%formals :: (_lock OF tptr Tvoid)%formals :: nil, tvoid)*) - ((tptr tcond)%formals :: (tptr Ctypes.Tvoid)%formals :: nil, tvoid) - cc_default - (rmaps.ProdType (rmaps.ConstType (val * val * share * share)) rmaps.Mpred) - (fun _ x => - match x with - | (c, l, shc, shl, R) => - PROP (readable_share shc) - PARAMS (c;l) GLOBALS () - SEP (lock_inv shl l R; R && (@cond_var cs shc c * TT)) - end)%argsassert - (fun _ x => - match x with - | (c, l, shc, shl, R) => - PROP () - LOCAL () - SEP (lock_inv shl l R; R) - end) - _ - _ -. -Next Obligation. - intros cs; hnf. - intros. - destruct x as [[[[c l] shc] shl] R]; simpl in *. - apply (nonexpansive_super_non_expansive - (fun R => (PROP (readable_share shc) - PARAMS (c;l) GLOBALS () - SEP (lock_inv shl l R; R && (@cond_var cs shc c * TT)))%argsassert gargs)). - apply (PROP_PARAMS_GLOBALS_SEP_nonexpansive - ((fun _ => readable_share shc) :: nil) - (c::l::nil) nil - ((fun R => lock_inv shl l R) :: (fun R => R && (@cond_var cs shc c * TT))%logic :: nil)); - repeat apply Forall_cons; try apply Forall_nil. - + apply const_nonexpansive. - + apply nonexpansive_lock_inv. - + apply (conj_nonexpansive (fun R => R) (fun _ => (cond_var shc c * TT)%logic)). - - apply identity_nonexpansive. - - apply const_nonexpansive. -Qed. -Next Obligation. - intros cs; hnf. - intros. - destruct x as [[[[c l] shc] shl] R]; simpl in *. - apply (nonexpansive_super_non_expansive - (fun R => (PROP () - LOCAL () - SEP (lock_inv shl l R; R)) rho)). - apply (PROP_LOCAL_SEP_nonexpansive - nil - nil - ((fun R => lock_inv shl l R) :: (fun R => R) :: nil)); - repeat apply Forall_cons; try apply Forall_nil. - + apply nonexpansive_lock_inv. - + apply identity_nonexpansive. -Qed. - -Definition signal_spec cs := - WITH c : val, shc : share - PRE [ (*_cond OF*) tptr tcond ] - PROP (readable_share shc) - (*LOCAL (temp _cond c)*)PARAMS (c) GLOBALS () - SEP (@cond_var cs shc c) - POST [ tvoid ] - PROP () - LOCAL () - SEP (@cond_var cs shc c). -*) - - (* To enable joinable threads, the postcondition would be [tptr tthread] with a type [tthread] related to the postcondition through a [thread] predicate in the logic. The [join] would then also be implemented @@ -394,143 +26,57 @@ using the oracle, as [acquire] is. The postcondition would be [match PrePost with existT ty (w, pre, post) => thread th (post w b) end] *) -Local Open Scope logic. - -(* @Qinxiang: it would be great to complete the annotation *) - -Definition spawn_arg_type := rmaps.ProdType (rmaps.ProdType (rmaps.ProdType (rmaps.ConstType (val * val)) - (rmaps.ArrowType (rmaps.DependentType 0) (rmaps.ConstType globals))) (rmaps.DependentType 0)) - (rmaps.ArrowType (rmaps.DependentType 0) (rmaps.ArrowType (rmaps.ConstType val) rmaps.Mpred)). - -Definition spawn_pre := - (fun (ts: list Type) (x: val * val * (nth 0 ts unit -> globals) * nth 0 ts unit * - (nth 0 ts unit -> val -> mpred)) => - match x with - | (f, b, gv, w, pre) => - PROP (tc_val (tptr Ctypes.Tvoid) b) - PARAMS (f;b) GLOBALS (gv w) - (SEP ( - (func_ptr' - (WITH y : val, x : nth 0 ts unit +(* If we want the spawned function to itself have a higher-order or dependent spec, + we probably need the DependentType machinery after all. *) +Definition spawn_arg_type := ProdType (ConstType (val * val)) (SigType Type (fun A => ProdType (ProdType + (DiscreteFunType A (ConstType globals)) (ConstType A)) + (DiscreteFunType A (DiscreteFunType val Mpred)))). + +Local Unset Program Cases. + +Program Definition spawn_pre : dtfr (ArgsTT spawn_arg_type) := λne x, + let '(f, b, fs) := x in + PROP (tc_val (tptr Tvoid) b) + PARAMS (f; b) + GLOBALS (let 'existT A ((gv, w), _) := fs in gv w) + SEP (let 'existT A ((gv, w), pre) := fs in + (func_ptr + (WITH y : val, x : A PRE [ tptr tvoid ] PROP () - PARAMS (y) GLOBALS (gv x) - (SEP (pre x y)) + PARAMS (y) + GLOBALS (gv x) + SEP (pre x y) POST [ tint ] PROP () RETURN (Vint Int.zero) (* spawned functions must return 0 for now *) SEP ()) f); - pre w b)) - end)%argsassert. - -Definition spawn_post := - (fun (ts: list Type) (x: val * val * (nth 0 ts unit -> globals) * nth 0 ts unit * - (nth 0 ts unit -> val -> mpred)) => - match x with - | (f, b, w, pre) => - PROP () - LOCAL () - SEP () (* here's where we'd put a join condition *) - end). - -Lemma approx_idem : forall n P, compcert_rmaps.R.approx n (compcert_rmaps.R.approx n P) = - compcert_rmaps.R.approx n P. -Proof. - intros. - transitivity (base.compose (compcert_rmaps.R.approx n) (compcert_rmaps.R.approx n) P); auto. - rewrite compcert_rmaps.RML.approx_oo_approx; auto. -Qed. - -Lemma approx_idem' : forall n P, approx n (approx n P) = - approx n P. -Proof. intros. apply approx_idem. Qed. -(* -Lemma spawn_pre_nonexpansive: @super_non_expansive spawn_arg_type spawn_pre. -Proof. - repeat intro. - destruct x as ((((?, ?), ?), ?), ?); simpl. - unfold PROPx; simpl; rewrite !approx_andp; f_equal. - unfold LOCALx; simpl; rewrite !approx_andp; f_equal. - unfold SEPx; simpl; rewrite !sepcon_emp, !approx_sepcon, ?approx_idem; f_equal. - rewrite !approx_exp; apply f_equal; extensionality y. - rewrite approx_func_ptr'. - setoid_rewrite approx_func_ptr' at 2. - do 3 f_equal. - extensionality a rho'; destruct a. - rewrite !approx_andp, !approx_sepcon, approx_idem; auto. -Qed.*) - -Lemma approx_derives_e {n P Q}: @derives mpred Nveric P Q -> @derives mpred Nveric (approx n P) (approx n Q). -Proof. intros. constructor. apply approx_hered_derives_e. apply H. Qed. - -Lemma funcptr_f_equal' fs fs' v v': fs=fs' -> v=v' -> func_ptr' fs v = func_ptr' fs' v'. -Proof. intros; subst; trivial. Qed. - -Lemma approx_Sn_eq_weaken: - forall n a b, approx (S n) a = approx (S n) b -> approx n a = approx n b. + let 'existT A ((gv, w), pre) := fs in (*valid_pointer b ∧*) pre w b) (* Do we need the valid_pointer here? *). +Next Obligation. Proof. -intros. -apply predicates_hered.pred_ext. -- -intros ? ?. -destruct H0. -split; auto. -assert (approx (S n) b a0). -rewrite <- H. -split; auto. -apply H2. -- -intros ? ?. -destruct H0. -split; auto. -assert (approx (S n) a a0). -rewrite H. -split; auto. -apply H2. -Qed. - -Lemma spawn_pre_nonexpansive: @args_super_non_expansive spawn_arg_type spawn_pre. -Proof. repeat intro. - destruct x as ((((?, ?), ?), ?), ?); simpl. - unfold PROPx; simpl; rewrite !approx_andp; f_equal. - unfold LAMBDAx. rewrite !approx_andp; f_equal. - unfold GLOBALSx, LOCALx; simpl. rewrite !approx_andp. f_equal. - unfold argsassert2assert. simpl. - unfold SEPx; simpl. rewrite !sepcon_emp. - rewrite !approx_sepcon. rewrite approx_idem. - apply pred_ext; apply sepcon_derives; trivial; apply derives_refl'. - (* f_equal.*) - + apply approx_Sn_eq_weaken. - rewrite approx_func_ptr'. - setoid_rewrite approx_func_ptr' at 2. apply f_equal. - apply funcptr_f_equal'; trivial. simpl. - apply semax_prog.funspec_eq; trivial. - extensionality tss a rho'; destruct a. - rewrite !approx_andp, !approx_sepcon, approx_idem; auto. - + apply approx_Sn_eq_weaken. - rewrite approx_func_ptr'. - setoid_rewrite approx_func_ptr' at 2. apply f_equal. - apply funcptr_f_equal'; trivial. simpl. - apply semax_prog.funspec_eq; trivial. - extensionality tss a rho'; destruct a. - rewrite !approx_andp, !approx_sepcon, approx_idem; auto. -Qed. - -Lemma spawn_post_nonexpansive: @super_non_expansive spawn_arg_type spawn_post. + intros ? ((f, b), (?, ((gv, ?), pre))) ((?, ?), (?, ((?, w), ?))) ([=] & ? & Hfs) rho; simpl in *; subst; simpl in *. + destruct Hfs as ((Hgv & [=]) & Hpre); simpl in *; subst. + rewrite (Hgv _). + do 6 f_equiv. + - apply func_ptr_si_nonexpansive; last done. + split; last split; [done..|]. + exists eq_refl; simpl. + split3; intros (?, ?); simpl; try done. + intros ?; rewrite Hgv (Hpre _ _) //. + - rewrite (Hpre _ _) //. +Defined. + +Program Definition spawn_post : @dtfr Σ (AssertTT spawn_arg_type) := λne x, + let '(f, b, fs) := x in PROP () LOCAL () SEP (). +Next Obligation. Proof. - hnf; intros. - destruct x as [[[]] pre]; auto. + intros ? ((f, b), ?) ((?, ?), ?) ?. + reflexivity. Qed. -Definition spawn_spec := mk_funspec - ((tptr spawned_funtype) :: (tptr tvoid) :: nil, tvoid) - cc_default - spawn_arg_type - spawn_pre - spawn_post - spawn_pre_nonexpansive - spawn_post_nonexpansive. +Definition spawn_spec := mk_funspec ([tptr spawned_funtype; tptr tvoid], tvoid) cc_default + spawn_arg_type (λne _, ⊤) spawn_pre spawn_post. (*+ Adding the specifications to a void ext_spec *) @@ -551,23 +97,14 @@ Definition Concurrent_Simple_Espec Z cs ext_link := Z (concurrent_simple_ext_spec Z cs ext_link).*) -Lemma strong_nat_ind (P : nat -> Prop) (IH : forall n, (forall i, lt i n -> P i) -> P n) n : P n. -Proof. - apply IH; induction n; intros i li; inversion li; eauto. -Qed. - Definition concurrent_specs (cs : compspecs) (ext_link : string -> ident) := (ext_link "spawn"%string, spawn_spec) :: nil. -Definition concurrent_ext_spec Z (cs : compspecs) (ext_link : string -> ident) := - add_funspecs_rec +#[export] Instance concurrent_ext_spec (cs : compspecs) (ext_link : string -> ident) : ext_spec OK_ty := + add_funspecs_rec OK_ty ext_link - (ok_void_spec Z).(@OK_ty) - (ok_void_spec Z).(@OK_spec) + (void_spec OK_ty) (concurrent_specs cs ext_link). -Definition Concurrent_Espec Z cs ext_link := - Build_OracleKind - Z - (concurrent_ext_spec Z cs ext_link). +End mpred. diff --git a/concurrency/semax_conc_pred.v b/concurrency/semax_conc_pred.v index 30073ab15..cdcf4952e 100644 --- a/concurrency/semax_conc_pred.v +++ b/concurrency/semax_conc_pred.v @@ -1,40 +1,29 @@ Require Import VST.msl.msl_standard. -Require Import VST.msl.seplog. Require Import VST.veric.Clight_base. -Require Import VST.veric.compcert_rmaps. +Set Warnings "-custom-entry-overridden". Require Import VST.veric.juicy_mem. +Set Warnings "custom-entry-overridden". Require Import VST.veric.juicy_mem_lemmas. -Require Import VST.veric.juicy_mem_ops. Require Import VST.veric.juicy_extspec. Require Import VST.veric.tycontext. Require Import VST.veric.expr2. Require Import VST.veric.semax. Require Import VST.veric.semax_call. Require Import VST.veric.semax_ext. -(*Require Import VST.veric.semax_ext_oracle.*) Require Import VST.veric.juicy_safety. +Set Warnings "-notation-overridden,-custom-entry-overridden,-hiding-delimiting-key". Require Import VST.veric.res_predicates. Require Import VST.veric.SeparationLogic. Require Import VST.sepcomp.semantics. Require Import VST.sepcomp.extspec. Require Import VST.floyd.base VST.floyd.seplog_tactics. +Set Warnings "notation-overridden,custom-entry-overridden,hiding-delimiting-key". Require Import VST.floyd.reptype_lemmas. Require Import VST.floyd.field_at. Require Import VST.floyd.nested_field_lemmas. Require Import VST.floyd.client_lemmas. Require Import VST.floyd.jmeq_lemmas. -Lemma approx_derives_ge : forall n m P, (n <= m)%nat -> approx n P |-- approx m P. -Proof. - intros; constructor. change (predicates_hered.derives (approx n P) (approx m P)). - intros ? []; split; auto; lia. -Qed. - -Lemma approx_derives : forall P n, approx n P |-- P. -Proof. - constructor; intro; apply approx_p. -Qed. - (*Lemma unfash_fash_equiv: forall P Q: mpred, (P <=> Q)%pred |-- ((subtypes.unfash (subtypes.fash P): mpred) <=> (subtypes.unfash (subtypes.fash Q): mpred))%pred.