diff --git a/rocq-brick-libstdcpp/proof/mutex/demo_cpp_proof.v b/rocq-brick-libstdcpp/proof/mutex/demo_cpp_proof.v index b8e21bc..12bd9f9 100644 --- a/rocq-brick-libstdcpp/proof/mutex/demo_cpp_proof.v +++ b/rocq-brick-libstdcpp/proof/mutex/demo_cpp_proof.v @@ -89,69 +89,180 @@ Section with_cpp. #[global] Instance CR_learn : Cbn (Learn (learn_eq ==> any ==> learn_hints.fin) CR). Proof. solve_learnable. Qed. - Lemma tele_app_mk_beta (P : Z -> Z -> mpred) (x y : Z) : - tele_app (TT := TT) (λ a b : Z, P a b) (mk x y) = P x y. - Proof. reflexivity. Qed. + Import recursive_mutex. + + #[global] Instance: `{Proper (equiv ==> equiv) (inv_rmutex γ)}. + Proof. rewrite inv_rmutex.unlock. solve_proper. Qed. + + #[program] + Definition inv_rmutex_iff_C γ := + \cancelx + \preserving{P1} inv_rmutex γ P1 + \proving{P2} inv_rmutex γ P2 + \through [| P1 ⊣⊢@{mpredI} P2 |] + \end. + Next Obligation. work. by setoid_subst. Qed. + (* #[local] Hint Resolve inv_rmutex_iff_C : br_hints. *) - (** "Eta-expand" [∃ xy : TT, ... tele_app P xy ... ] to [∃ (x y : Z), ... tele_app P (mk x y) ...]. - This is useful because [tele_app (λ a b : Z, Q a b) (mk x y)] simplifies to [Q x y] ([tele_app_mk_beta]). *) - #[program] Definition learn_args_C (P : TT -t> mpred) := + #[program] + Definition inv_rmutex_wand_C γ := \cancelx - \bound_existential args - \proving tele_app P args - \exist a b - \instantiate args := mk a b - \through tele_app P (mk a b) + \preserving{P1} inv_rmutex γ P1 + \proving{P2} inv_rmutex γ P2 + \through □ (P1 ∗-∗ P2) \end. - Next Obligation. work. Qed. - #[local] Hint Resolve learn_args_C : br_hints. + Next Obligation. + rewrite inv_rmutex.unlock. + iIntros "%% A %P2 #[? ?]". + iApply (inv_iff with "A"). + iIntros "!> !>"; iSplit; ework with br_erefl; case_match; work. + Qed. + (* #[local] Hint Resolve inv_rmutex_wand_C : br_hints. *) + + Lemma CR'_tele_equiv (this : ptr) : + (∃ a b : Z, this |-> CR' a b) ⊣⊢ + ∃ xs : TT, tele_app (TT := TT) (λ a b : Z, this |-> CR' a b) xs. + Proof. + iSplit. + { iDestruct 1 as (a b) "?"; iExists (mk a b); work. } + iDestruct 1 as ([a [b []]]) "?"; iExists a, b; work. + Qed. + #[local] Hint Resolve CR'_tele_equiv : br_hints. + + Lemma CR'_self_eq (this : ptr) : + (∃ a b : Z, this |-> CR' a b) ⊣⊢ + (∃ a b : Z, this |-> CR' a b). + Proof. done. Qed. + #[local] Hint Resolve CR'_self_eq : br_hints. - #[program] Definition P_unfold_split_args_F this args := + Lemma refl_equiv (P : mpred) : P ⊣⊢ P. + Proof. done. Qed. + #[local] Hint Resolve refl_equiv : br_hints. + + Lemma CR'_P_tele_equiv (this : ptr) : + (∃ a_b : TT, tele_app (TT := TT) (λ a b, this |-> CR' a b) a_b) ⊣⊢ + (∃ a_b : TT, tele_app (P this) a_b). + Proof. by rewrite P.unlock. Qed. + #[local] Hint Resolve CR'_P_tele_equiv : br_hints. + + (* #[local] Hint Resolve inv_rmutex_learn_C | 0 : br_hints. *) + (* #[local] Hint Resolve inv_rmutex_iff_C | 100 : br_hints. *) + #[local] Remove Hints learn_inv_rmutex_TT : typeclass_instances. +(* + #[program] + Definition inv_rmutex_iff_C γ := \cancelx - \consuming tele_app (P this) args - \intro a - \intro b - \deduce tele_app (TT := TT) (fun a b => this |-> CR' a b) (mk a b) - \deduce [| args = mk a b |] + \preserving{P1} +(inv_rmutex γ (∃ xs : tele_arg TT1, tele_app P1 xs)) + \bound TT2 + \proving{P2} + (inv_rmutex γ (∃ xs : tele_arg TT2, tele_app P2 xs)) + \through [| TT1 = TT2 |] + \through [| P1 ⊣⊢@{mpredI} P2 |] \end. - Next Obligation. iIntros (this [a [b []]]) "/= ?". iExists a, b. rewrite P.unlock. work. Qed. + Next Obligation. work. by setoid_subst. Qed. + #[local] Hint Resolve inv_rmutex_iff_C : br_hints. *) + + Lemma update_a_ok : verify[source] "C::update_a(long)". + Proof. + verify_spec; go. + Set SL Debug "@default=3". - #[program] Definition P_unfold_B := + #[program] + Definition inv_rmutex_learn_C := \cancelx - \bound this a b - \proving P this a b - \through this |-> CR' a b + \preserving{γ TT1 P1} inv_rmutex γ (∃ xs : tele_arg TT1, tele_app P1 xs) + \bound_existential TT2 + \bound P2 + \proving inv_rmutex γ (∃ ys : tele_arg TT2, tele_app P2 ys) + \instantiate TT2 := TT1 + (* \instantiate P2 := P1 *) + (* \through inv_rmutex γ (∃ xs : tele_arg TT2, tele_app P2 xs) *) \end. - Next Obligation. rewrite P.unlock. work. Qed. + Next Obligation. + (* work. Qed. *) + Admitted. + Set Printing Coercions. + Set Printing Implicit. + Arguments TT : simpl never. - Section unfold_P. - #[local] Hint Resolve P_unfold_split_args_F : br_hints. - #[local] Hint Resolve P_unfold_B : br_hints. + About learn_inv_rmutex_γ. + rewrite -/TT. + work using inv_rmutex_learn_C. + Print inv_rmutex_learn_C. + (* with_log! work. *) + with_log! sep with {1}sl_opacity* typeclass_instances using inv_rmutex_learn_C. + (* with_log! work. *) + with_log! sep with {1}sl_opacity* {1}br_hints #db_skylabs_syntactic pure typeclass_instances using inv_rmutex_learn_C. + (* Print inv_rmutex_learn_C. + cbn. *) + with_log! step using learn_inv_rmutex_TT. + Print inv_rmutex_learn_C. + (* #[local] Hint Resolve learn_inv_rmutex_TT : typeclass_instances. *) - Lemma update_a_ok : verify[source] "C::update_a(long)". - Proof. - verify_spec; go. - Qed. + iExists TT. + go. + rewrite P.unlock. + destruct args as [a [b []]]; simpl; go. + iExists TT, (P this), _, (mk (trim 64 (a + x)) b). + go. + rewrite P.unlock. + go. + rewrite P.unlock. + go. + all: fail. + Fail Qed. + Admitted. - Lemma update_b_ok : verify[source] "C::update_b(long)". - Proof. - verify_spec; go. - Qed. - End unfold_P. + Lemma update_b_ok : verify[source] "C::update_b(long)". + Proof. + verify_spec; go. + iExists TT. + go. + + rewrite P.unlock. + destruct args as [a [b []]]; simpl; go. + iExists TT, _, _, (mk a (trim 64 (b + x))). + go. + rewrite P.unlock. + go. + rewrite P.unlock. + go. + all: fail. + Fail Qed. + Admitted. cpp.spec "C::transfer(int)" as C_transfer_int from demo_cpp.source with (\this this \arg{x} "x" (Vint x) \prepost{γ q} this |-> CR γ q \prepost{q'} recursive_mutex.token γ.(recursive_mutex.lock_gname) q' - \pre{args th} recursive_mutex.acquireable γ th args (TT:=TT) (P this) - \post recursive_mutex.acquireable γ th (TT:=TT) (recursive_mutex.update (TT:=TT) (fun (a b : Z) => mk (trim 64 (a+x)) (trim 64 (b-x))) args) (P this)). + \pre{args th} recursive_mutex.acquireable γ th args (TT:=TT) (fun a b => this |-> CR' a b) + \post recursive_mutex.acquireable γ th (TT:=TT) (recursive_mutex.update (TT:=TT) (fun (a b : Z) => mk (trim 64 (a+x)) (trim 64 (b-x))) args) (fun a b => this |-> CR' a b)). + + Lemma P_CR'_tele_equiv (this : ptr) : + (∃ a_b : TT, tele_app (P this) a_b) ⊣⊢ + (∃ a_b : TT, tele_app (TT := TT) (λ a b, this |-> CR' a b) a_b). + Proof. by rewrite P.unlock. Qed. + #[local] Hint Resolve P_CR'_tele_equiv : br_hints. Lemma transfer_ok : verify[source] "C::transfer(int)". Proof. verify_spec; go. - destruct args as [a [b []]]; work. - Qed. + iExists TT. + go. + iExists (Held _ args). + destruct args as [a [b []]]; simpl. + go. + rewrite P.unlock. + go. + rewrite P.unlock. + go. + iExists TT. + go. + all: fail. + Fail Qed. + Admitted. Lemma partial_transfer_link : denoteModule source ∗ diff --git a/rocq-brick-libstdcpp/proof/mutex/spec.v b/rocq-brick-libstdcpp/proof/mutex/spec.v index 36db896..92c1ecb 100644 --- a/rocq-brick-libstdcpp/proof/mutex/spec.v +++ b/rocq-brick-libstdcpp/proof/mutex/spec.v @@ -340,7 +340,7 @@ Section with_cpp. \end. Next Obligation. rewrite acquireable.unlock; work. Qed. - #[global] Instance : `{Learnable + #[global] Instance learn_current_thread_acquireable : `{Learnable (current_thread th) (acquireable (TT := TT0) γ th0 args P0) [th0 = th] }.