(**
  This file is a part of a formalisation of a subset of Core Erlang.

  In this file, we define CIU equivalence for sequential Core Erlang.
  We prove that CIU equivalence coicides with logical relations.
*)

Require Export Compatibility.

Import ListNotations.

Definition CIU (e1 e2 : Exp) : Prop :=
  EXPCLOSED e1 /\ EXPCLOSED e2 /\
  forall F, FSCLOSED F -> | F, e1 | ↓ -> | F, e2 | ↓.

Definition CIU_open (Γ : nat) (e1 e2 : Exp) :=
  forall ξ, SUBSCOPE Γ ⊢ ξ ∷ 0 ->
  CIU (e1.[ξ]) (e2.[ξ]).

Lemma CIU_closed :
  forall e1 e2,
  CIU e1 e2 -> EXPCLOSED e1 /\ EXPCLOSED e2.
Proof.
  intros. unfold CIU in H. intuition.
Qed.

Lemma CIU_closed_l : forall {e1 e2},
    CIU e1 e2 ->
    EXPCLOSED e1.
Proof.
  intros.
  apply CIU_closed in H.
  intuition.
Qed.

Global Hint Resolve CIU_closed_l : core.

Lemma CIU_closed_r : forall {e1 e2},
    CIU e1 e2 ->
    EXPCLOSED e2.
Proof.
  intros.
  apply CIU_closed in H.
  intuition.
Qed.

Global Hint Resolve CIU_closed_r : core.

Lemma CIU_open_scope : forall {Γ e1 e2},
    CIU_open Γ e1 e2 ->
    EXP Γ ⊢ e1 /\ EXP Γ ⊢ e2.
Proof.
  intros.
  unfold CIU_open in H.
  split;
    eapply subst_implies_scope_exp; eauto.
Qed.

Lemma CIU_open_scope_l : forall {Γ e1 e2},
    CIU_open Γ e1 e2 ->
    EXP Γ ⊢ e1.
Proof.
  intros.
  apply CIU_open_scope in H.
  intuition.
Qed.

Global Hint Resolve CIU_open_scope_l : core.

Lemma CIU_open_scope_r : forall {Γ e1 e2},
    CIU_open Γ e1 e2 ->
    EXP Γ ⊢ e2.
Proof.
  intros.
  apply CIU_open_scope in H.
  intuition.
Qed.

Global Hint Resolve CIU_open_scope_r : core.

Lemma Erel_implies_CIU : forall Γ e1 e2,
  Erel_open Γ e1 e2 ->
  CIU_open Γ e1 e2.
Proof.
  intros.
  unfold CIU_open; intros.
  unfold CIU.
  split. 2: split.
  - apply -> (subst_preserves_scope_exp); eauto.
  - apply -> (subst_preserves_scope_exp); eauto.
  - unfold Erel_open, Erel, exp_rel in H. intros. destruct H2.
    specialize (H x ξ ξ (Grel_Fundamental _ _ H0 _)). destruct H, H3.
    eapply H4 in H2; eauto. apply Frel_Fundamental_closed. auto.
Qed.

Lemma Erel_comp_CIU_implies_Erel : forall {Γ e1 e2 e3},
    Erel_open Γ e1 e2 ->
    CIU_open Γ e2 e3 ->
    Erel_open Γ e1 e3.
Proof.
  intros Γ e1 e2 e3 HErel HCIU.
  unfold Erel_open, Erel, exp_rel.
  intros.
  inversion H as [Hξ1 [Hξ2 _]].
  split. 2: split. 1-2: apply -> subst_preserves_scope_exp; eauto.
  intros. eapply HErel in H1; eauto. eapply HCIU in H1; eauto.
Qed.

Lemma CIU_implies_Erel : forall {Γ e1 e2},
    CIU_open Γ e1 e2 ->
    Erel_open Γ e1 e2.
Proof.
  intros.
  eapply Erel_comp_CIU_implies_Erel; eauto.
Qed.

Theorem CIU_iff_Erel : forall {Γ e1 e2},
    CIU_open Γ e1 e2 <->
    Erel_open Γ e1 e2.
Proof.
  intuition (auto using CIU_implies_Erel, Erel_implies_CIU).
Qed.

Theorem CIU_eval : forall e1 v,
  EXPCLOSED e1 ->
  ⟨ [], e1 ⟩ -->* v -> CIU e1 v /\ CIU v e1.
Proof.
  intros. split. split. 2: split. auto.
  apply step_any_closedness in H0; auto. now constructor.
  intros. destruct H2, H0, H3. eapply frame_indep_nil in H3.
  eapply terminates_step_any. 2: exact H3. eexists. exact H2.

  split. 2: split. 2: auto.
  apply step_any_closedness in H0; auto. now constructor.
  intros. destruct H2, H0, H3. eapply frame_indep_nil in H3.
  exists (x + x0).
  eapply term_step_term. exact H3. 2: lia. replace (x + x0 - x0) with x by lia. exact H2.
Qed.

Theorem CIU_list_parts : forall e1 e2 e1' e2',
  VALCLOSED e1 -> VALCLOSED e2 -> VALCLOSED e1' -> VALCLOSED e2' ->
  CIU (ECons e1 e2) (ECons e1' e2')
->
  CIU e1 e1' /\ CIU e2 e2'.
Proof.
  intros. destruct H3 as [? [? ?]].
  split; split.
  1, 3: constructor; auto.
  all: split. 1, 3: constructor; auto.
  * intros. assert (FSCLOSED (FCase (PCons PVar PVar) (EVar 0) inf :: F)). {
       constructor; auto. constructor; auto. 2: repeat constructor.
       simpl. do 2 constructor. auto. inversion H8. inversion H8.
     }
     specialize (H5 (FCase (PCons PVar PVar) (EVar 0) inf :: F) H8).
     destruct H7.
     assert (| FCase (PCons PVar PVar) (EVar 0) inf :: F, ECons e1 e2 | ↓). {
       exists (4 + x). apply term_cons.
       constructor; auto. constructor; auto. eapply term_case_true.
       constructor; auto. reflexivity.
       simpl. auto.
     }
     apply H5 in H9. destruct H9.
     inversion H9; subst; try inversion_is_value.
     inversion H14; subst; try inversion_is_value.
     inversion H16; subst; try inversion_is_value.
     inversion H19; subst; try inversion_is_value.
     - simpl in H23. inversion H23. subst. simpl in H24. eexists; eassumption.
     - apply inf_diverges in H24. contradiction.
  * intros. assert (FSCLOSED (FCase (PCons PVar PVar) (EVar 1) inf :: F)). {
       constructor; auto. constructor; auto.
       do 2 constructor.
       do 2 constructor. auto. intros. inversion H8. inversion H8.
     }
     specialize (H5 (FCase (PCons PVar PVar) (EVar 1) inf :: F) H8).
     destruct H7.
     assert (| FCase (PCons PVar PVar) (EVar 1) inf :: F, ECons e1 e2 | ↓). {
       exists (4 + x). apply term_cons.
       constructor; auto. constructor; auto. eapply term_case_true.
       constructor; auto. reflexivity.
       simpl. auto.
     }
     apply H5 in H9. destruct H9.
     inversion H9; subst; try inversion_is_value.
     inversion H14; subst; try inversion_is_value.
     inversion H16; subst; try inversion_is_value.
     inversion H19; subst; try inversion_is_value.
     - simpl in H23. inversion H23. subst. simpl in H24. eexists; eassumption.
     - apply inf_diverges in H24. contradiction.
Qed.

(* Theorem CIU_implies_Vrel :
  forall e1 e2, VALCLOSED e1 -> VALCLOSED e2 -> CIU e1 e2 -> CIU e2 e1 (* for comfort *)
 ->
  forall n, Vrel n e1 e2.
Proof.
  induction e1; destruct e2; intros; try inversion_is_value; rewrite Vrel_Fix_eq;
    simpl; destruct H1 as [Ecl1 [Ecl2 H1]]; destruct H2 as [Ecl1' [Ecl2' H2]]; try lia.
  * split. 2: split. 1-2: constructor.
    epose proof (H1 [FCase (PLit l) (ELit 0) inf] _ _).
    destruct H3. inversion H3; subst; try inversion_is_value.
    simpl in H11. break_match_hyp. now apply Z.eqb_eq in Heqb. congruence.
    now apply inf_diverges in H12.
  * epose proof (H1 [FCase (PLit l) (ELit 0) inf] _ _).
    destruct H3. inversion H3; subst; try inversion_is_value.
    inversion H11.
    now apply inf_diverges in H12.
  * epose proof (H1 [FCase (PLit l) (ELit 0) inf] _ _).
    destruct H3. inversion H3; subst; try inversion_is_value.
    inversion H11.
    now apply inf_diverges in H12.
  * epose proof (H1 [FCase (PLit l) (ELit 0) inf] _ _).
    destruct H3. inversion H3; subst; try inversion_is_value.
    inversion H11.
    now apply inf_diverges in H12.
  * epose proof (H2 [FCase (PLit l) (ELit 0) inf] _ _).
    destruct H3. inversion H3; subst; try inversion_is_value.
    inversion H11.
    now apply inf_diverges in H12.
  * split. 2: split. 1-2: auto.
    epose proof (H1 (FCase (PLit 0) (ELit 0) (EApp ))).
  * epose proof (H2 [FCase PNil (ELit 0) inf] _ _).
    destruct H3. inversion H3; subst; try inversion_is_value.
    inversion H11.
    now apply inf_diverges in H12.
  * epose proof (H2 [FCase PNil (ELit 0) inf] _ _).
    destruct H3. inversion H3; subst; try inversion_is_value.
    inversion H11.
    now apply inf_diverges in H12.
  * epose proof (H1 [FCase PNil (ELit 0) inf] _ _).
    destruct H3. inversion H3; subst; try inversion_is_value.
    inversion H11.
    now apply inf_diverges in H12.
  * epose proof (H1 [FCase PNil (ELit 0) inf] _ _).
    destruct H3. inversion H3; subst; try inversion_is_value.
    inversion H11.
    now apply inf_diverges in H12.
  * split; constructor; auto.
  * epose proof (H1 [FCase PNil (ELit 0) inf] _ _).
    destruct H3. inversion H3; subst; try inversion_is_value.
    inversion H11.
    now apply inf_diverges in H12.
  * epose proof (H1 [FCase (PCons PVar PVar) (ELit 0) inf] _ _).
    destruct H3. inversion H3; subst; try inversion_is_value.
    inversion H11.
    now apply inf_diverges in H12.
  * epose proof (H1 [FCase (PCons PVar PVar) (ELit 0) inf] _ _).
    destruct H3. inversion H3; subst; try inversion_is_value.
    inversion H11.
    now apply inf_diverges in H12.
  * epose proof (H1 [FCase (PCons PVar PVar) (ELit 0) inf] _ _).
    destruct H3. inversion H3; subst; try inversion_is_value.
    inversion H11.
    now apply inf_diverges in H12.
  * split. 2: split. 1-2: auto. inversion H. inversion H0. subst.
    assert (CIU e1_1 e2_1). {
      apply (CIU_list_parts e1_1 e1_2 e2_1 e2_2); auto.
      split. 2: split. 1-2: do 2 constructor; auto.
      intros. destruct H4.
      inversion H4; subst; try inversion_is_value.
      inversion H13; subst; try inversion_is_value.
      inversion H15; subst; try inversion_is_value.
      assert (exists k, | F, VCons e1_1 e1_2 | k ↓). { eexists; eauto. } apply H1 in H7.
      destruct H7. exists (3 + x). constructor; auto. constructor; auto. constructor; auto.
      auto.
   }
   assert (CIU e1_2 e2_2). {
      apply (CIU_list_parts e1_1 e1_2 e2_1 e2_2); auto.
      split. 2: split. 1-2: do 2 constructor; auto.
      intros. destruct H7.
      inversion H7; subst; try inversion_is_value.
      inversion H14; subst; try inversion_is_value.
      inversion H16; subst; try inversion_is_value.
      assert (exists k, | F, VCons e1_1 e1_2 | k ↓). { eexists; eauto. } apply H1 in H8.
      destruct H8. exists (3 + x). constructor; auto. constructor; auto. constructor; auto.
      auto.
   }
   assert (CIU e2_1 e1_1). {
      apply (CIU_list_parts e2_1 e2_2 e1_1 e1_2); auto.
      split. 2: split. 1-2: do 2 constructor; auto.
      intros. destruct H8.
      inversion H8; subst; try inversion_is_value.
      inversion H15; subst; try inversion_is_value.
      inversion H17; subst; try inversion_is_value.
      assert (exists k, | F, VCons e2_1 e2_2 | k ↓). { eexists; eauto. } apply H2 in H11.
      destruct H11. exists (3 + x). constructor; auto. constructor; auto. constructor; auto.
      auto.
   }
   assert (CIU e2_2 e1_2). {
      apply (CIU_list_parts e2_1 e2_2 e1_1 e1_2); auto.
      split. 2: split. 1-2: do 2 constructor; auto.
      intros. destruct H11.
      inversion H11; subst; try inversion_is_value.
      inversion H16; subst; try inversion_is_value.
      inversion H18; subst; try inversion_is_value.
      assert (exists k, | F, VCons e2_1 e2_2 | k ↓). { eexists; eauto. } apply H2 in H12.
      destruct H12. exists (3 + x). constructor; auto. constructor; auto. constructor; auto.
      auto.
   }
   do 2 rewrite <- Vrel_Fix_eq. split.
   - apply IHe1_1; auto.
   - apply IHe1_2; auto.
Unshelve.

Qed. *)


From mathcomp.ssreflect Require Import ssreflect seq ssrbool ssrfun.
Require Import Coq.Classes.Morphisms.

Require Import compcert.common.Memory.
Require Import compcert.common.AST.     (*for typ*)
Require Import compcert.common.Values. (*for val*)
Require Import compcert.common.Globalenvs.
Require Import compcert.lib.Integers.

Require Import VST.msl.Axioms.
Require Import Coq.ZArith.ZArith.
Require Import VST.concurrency.common.core_semantics.
Require Import VST.sepcomp.event_semantics.
Require Export VST.concurrency.common.semantics.
Require Export VST.concurrency.common.lksize.
Require Import VST.concurrency.common.threadPool.

Require Import VST.concurrency.common.machine_semantics.
Require Import VST.concurrency.common.permissions.
Require Import VST.concurrency.compiler.mem_equiv.
Require Import VST.concurrency.common.bounded_maps.
Require Import VST.concurrency.common.addressFiniteMap.
Require Import VST.concurrency.common.scheduler.
Require Import Coq.Program.Program.
(*Require Import VST.concurrency.common.safety.
Require Import VST.concurrency.common.coinductive_safety.*)

(* Require Import VST.veric.res_predicates. *)
(* Require Import VST.veric.Clight_new. *)

Require Import VST.concurrency.common.HybridMachineSig.
(* Require Import VST.concurrency.CoreSemantics_sum. *)

Module DryHybridMachine.
  Import Events ThreadPool.

  Instance dryResources: Resources:=
    {| res := access_map * access_map;
       lock_info := access_map * access_map |}.

  Section DryHybridMachine.

    (** Assume some threadwise semantics *)
    Context {Sem: Semantics}
            {tpool : @ThreadPool.ThreadPool dryResources Sem}.

    Notation C:= (@semC Sem).
    Notation G:= (@semG Sem).
    Notation semSem:= (@semSem Sem).

    Notation thread_pool := (@t dryResources Sem).
    (** Memories*)
    Definition richMem: Type:= mem.
    Definition dryMem: richMem -> mem:= fun x => x.

    (** The state respects the memory*)

    Record mem_compatible (tp: thread_pool) m : Prop :=
      { compat_th :> forall {tid} (cnt: containsThread tp tid),
            permMapLt (getThreadR cnt).1 (getMaxPerm m) /\
            permMapLt (getThreadR cnt).2 (getMaxPerm m);
        compat_lp : forall l pmaps, lockRes tp l = Some pmaps ->
                               permMapLt pmaps.1 (getMaxPerm m) /\
                               permMapLt pmaps.2 (getMaxPerm m);
        lockRes_blocks: forall l rmap, lockRes tp l = Some rmap ->
                                  Mem.valid_block m l.1}.

      Lemma  mem_compat_restrPermMap:
        forall m perms st
          (permMapLt: permMapLt perms (getMaxPerm m)),
          (mem_compatible st m) ->
          (mem_compatible st (restrPermMap permMapLt)).
      Proof.
        intros.
        inversion H; econstructor.
        - intros; unfold permissions.permMapLt.
          split; intros;
            erewrite getMax_restr;
            eapply compat_th0.
        - intros; unfold permissions.permMapLt.
          split; intros;
            erewrite getMax_restr;
            eapply compat_lp0; eauto.
        - intros. eapply restrPermMap_valid; eauto.
      Qed.

    (* should there be something that says that if something is a lock then
     someone has at least readable permission on it?*)
    Record invariant (tp: thread_pool) :=
      { no_race_thr :
          forall i j (cnti: containsThread tp i) (cntj: containsThread tp j)
            (Hneq: i <> j),
            permMapsDisjoint2 (getThreadR cnti)
                              (getThreadR cntj); (*thread's resources are disjoint *)
        no_race_lr:
          forall laddr1 laddr2 rmap1 rmap2
            (Hneq: laddr1 <> laddr2)
            (Hres1: lockRes tp laddr1 = Some rmap1)
            (Hres2: lockRes tp laddr2 = Some rmap2),
            permMapsDisjoint2 rmap1 rmap2; (*lock's resources are disjoint *)
        no_race:
          forall i laddr (cnti: containsThread tp i) rmap
            (Hres: lockRes tp laddr = Some rmap),
            permMapsDisjoint2 (getThreadR cnti) rmap; (*resources are disjoint
             between threads and locks*)

        (* if an address is a lock then there can be no data
             permission above non-empty for this address*)
        thread_data_lock_coh:
          forall i (cnti: containsThread tp i),
            (forall j (cntj: containsThread tp j),
                permMapCoherence (getThreadR cntj).1 (getThreadR cnti).2) /\
            (forall laddr rmap,
                lockRes tp laddr = Some rmap ->
                permMapCoherence rmap.1 (getThreadR cnti).2);
        locks_data_lock_coh:
          forall laddr rmap
            (Hres: lockRes tp laddr = Some rmap),
            (forall j (cntj: containsThread tp j),
                permMapCoherence (getThreadR cntj).1 rmap.2) /\
            (forall laddr' rmap',
                lockRes tp laddr' = Some rmap' ->
                permMapCoherence rmap'.1 rmap.2);
        lockRes_valid: lr_valid (lockRes tp) (*well-formed locks*)
      }.

    (** Steps*)
    Inductive dry_step {tid0 tp m} (cnt: containsThread tp tid0)
              (Hcompatible: mem_compatible tp m) :
      thread_pool -> mem -> seq.seq mem_event -> Prop :=
    | step_dry :
        forall (tp':thread_pool) c m1 m' (c' : C) ev
          (** Instal the permission's of the thread on non-lock locations*)
          (Hrestrict_pmap: restrPermMap (Hcompatible tid0 cnt).1 = m1)
          (Hinv: invariant tp)
          (Hcode: getThreadC cnt = Krun c)
          (Hcorestep: ev_step semSem c m1 ev c' m')
          (** the new data resources of the thread are the ones on the
           memory, the lock ones are unchanged by internal steps*)
          (Htp': tp' = updThread cnt (Krun c') (getCurPerm m', (getThreadR cnt).2)),
          dry_step cnt Hcompatible tp' m' ev.

    Definition option_function {A B} (opt_f: option (A -> B)) (x:A): option B:=
      match opt_f with
        Some f => Some (f x)
      | None => None
      end.
    Infix "??" := option_function (at level 80, right associativity).

    Definition build_delta_content (dm: delta_map) (m:mem): delta_content :=
      PTree.map (fun b dm_f =>
                   fun ofs =>
                     match dm_f ofs with
                     | None | Some (None)
                     | Some (Some Nonempty) => None
                     | Some _ => Some (ZMap.get ofs (Maps.PMap.get b (Mem.mem_contents m)))
                     end) dm.

    Inductive ext_step {isCoarse:bool} {tid0 tp m}
              (cnt0:containsThread tp tid0)(Hcompat:mem_compatible tp m):
      thread_pool -> mem -> sync_event -> Prop :=
    | step_acquire :
        forall (tp' tp'':thread_pool) marg m0 m1 c m' b ofs
          (pmap : lock_info)
          (pmap_tid' : access_map)
          (virtueThread : delta_map * delta_map)
          (Hbounded: if isCoarse then
                       ( sub_map virtueThread.1 (getMaxPerm m).2 /\
                         sub_map virtueThread.2 (getMaxPerm m).2)
                     else
                       True ),
          let newThreadPerm := (computeMap (getThreadR cnt0).1 virtueThread.1,
                                computeMap (getThreadR cnt0).2 virtueThread.2) in
          forall
            (Hinv : invariant tp)
            (Hcode: getThreadC cnt0 = Kblocked c)
            (* To check if the machine is at an external step and load its arguments install the thread data permissions*)
            (Hrestrict_pmap_arg: restrPermMap (Hcompat tid0 cnt0).1 = marg)
            (Hat_external: semantics.at_external semSem c marg = Some (LOCK, Vptr b ofs::nil))
            (** install the thread's permissions on lock locations*)
            (Hrestrict_pmap0: restrPermMap (Hcompat tid0 cnt0).2 = m0)
            (** To acquire the lock the thread must have [Readable] permission on it*)
            (Haccess: Mem.range_perm m0 b (Ptrofs.intval ofs) ((Ptrofs.intval ofs) + LKSIZE) Cur Readable)
            (** check if the lock is free*)
            (Hload: Mem.load Mint32 m0 b (Ptrofs.intval ofs) = Some (Vint Int.one))
            (** set the permissions on the lock location equal to the max permissions on the memory*)
            (Hset_perm: setPermBlock (Some Writable)
                                     b (Ptrofs.intval ofs) ((getThreadR cnt0).2) LKSIZE_nat = pmap_tid')
            (Hlt': permMapLt pmap_tid' (getMaxPerm m))
            (Hlt_new: if isCoarse then
                       ( permMapLt (fst newThreadPerm) (getMaxPerm m) /\
                         permMapLt (snd newThreadPerm) (getMaxPerm m))
                     else True )
            (Hrestrict_pmap: restrPermMap Hlt' = m1)
            (** acquire the lock*)
            (Hstore: Mem.store Mint32 m1 b (Ptrofs.intval ofs) (Vint Int.zero) = Some m')
            (HisLock: lockRes tp (b, Ptrofs.intval ofs) = Some pmap)
            (Hangel1: permMapJoin pmap.1 (getThreadR cnt0).1 newThreadPerm.1)
            (Hangel2: permMapJoin pmap.2 (getThreadR cnt0).2 newThreadPerm.2)
            (Htp': tp' = updThread cnt0 (Kresume c Vundef) newThreadPerm)
            (** acquiring the lock leaves empty permissions at the resource pool*)
            (Htp'': tp'' = updLockSet tp' (b, Ptrofs.intval ofs) (empty_map, empty_map)),
            ext_step cnt0 Hcompat tp'' m'
                     (acquire (b, Ptrofs.intval ofs)
                              (Some (build_delta_content (fst virtueThread) m')))

    | step_release :
        forall (tp' tp'':thread_pool) marg m0 m1 c m' b ofs virtueThread virtueLP pmap_tid' rmap
          (Hbounded: if isCoarse then
                       ( sub_map virtueThread.1 (getMaxPerm m).2 /\
                         sub_map virtueThread.2 (getMaxPerm m).2)
                     else
                       True )
          (HboundedLP: if isCoarse then
                         ( map_empty_def virtueLP.1 /\
                           map_empty_def virtueLP.2 /\
                           sub_map virtueLP.1.2 (getMaxPerm m).2 /\
                           sub_map virtueLP.2.2 (getMaxPerm m).2)
                       else
                         True ),
          let newThreadPerm := (computeMap (getThreadR cnt0).1 virtueThread.1,
                                computeMap (getThreadR cnt0).2 virtueThread.2) in
          forall
            (Hinv : invariant tp)
            (Hcode: getThreadC cnt0 = Kblocked c)
            (* To check if the machine is at an external step and load its arguments install the thread data permissions*)
            (Hrestrict_pmap_arg: restrPermMap (Hcompat tid0 cnt0).1 = marg)
            (Hat_external: semantics.at_external semSem c marg =
                           Some (UNLOCK, Vptr b ofs::nil))
            (** install the thread's permissions on lock locations *)
            (Hrestrict_pmap0: restrPermMap (Hcompat tid0 cnt0).2 = m0)
            (** To release the lock the thread must have [Readable] permission on it*)
            (Haccess: Mem.range_perm m0 b (Ptrofs.intval ofs) ((Ptrofs.intval ofs) + LKSIZE) Cur Readable)
            (Hload: Mem.load Mint32 m0 b (Ptrofs.intval ofs) = Some (Vint Int.zero))
            (** set the permissions on the lock location equal to [Writable]*)
            (Hset_perm: setPermBlock (Some Writable)
                                     b (Ptrofs.intval ofs) ((getThreadR cnt0).2) LKSIZE_nat = pmap_tid')
            (Hlt': permMapLt pmap_tid' (getMaxPerm m))
            (Hrestrict_pmap: restrPermMap Hlt' = m1)
            (** release the lock *)
            (Hstore: Mem.store Mint32 m1 b (Ptrofs.intval ofs) (Vint Int.one) = Some m')
            (HisLock: lockRes tp (b, Ptrofs.intval ofs) = Some rmap)
            (Hrmap: forall b ofs, rmap.1 !! b ofs = None /\ rmap.2 !! b ofs = None)
            (Hangel1: permMapJoin newThreadPerm.1 virtueLP.1 (getThreadR cnt0).1)
            (Hangel2: permMapJoin newThreadPerm.2 virtueLP.2 (getThreadR cnt0).2)
            (Htp': tp' = updThread cnt0 (Kresume c Vundef)
                                   (computeMap (getThreadR cnt0).1 virtueThread.1,
                                    computeMap (getThreadR cnt0).2 virtueThread.2))
            (Htp'': tp'' = updLockSet tp' (b, Ptrofs.intval ofs) virtueLP),
            ext_step cnt0 Hcompat tp'' m'
                     (release (b, Ptrofs.intval ofs)
                              (Some (build_delta_content (fst virtueThread) m')))
    | step_create :
        forall (tp_upd tp':thread_pool) c marg b ofs arg virtue1 virtue2
          (Hbounded: if isCoarse then
                       ( sub_map virtue1.1 (getMaxPerm m).2 /\
                         sub_map virtue1.2 (getMaxPerm m).2)
                     else
                       True )
          (Hbounded_new: if isCoarse then
                           ( sub_map virtue2.1 (getMaxPerm m).2 /\
                             sub_map virtue2.2 (getMaxPerm m).2)
                         else
                           True ),
          let threadPerm' := (computeMap (getThreadR cnt0).1 virtue1.1,
                              computeMap (getThreadR cnt0).2 virtue1.2) in
          let newThreadPerm := (computeMap empty_map virtue2.1,
                                computeMap empty_map virtue2.2) in
          forall
            (Hinv : invariant tp)
            (Hcode: getThreadC cnt0 = Kblocked c)
            (* To check if the machine is at an external step and load its arguments install the thread data permissions*)
            (Hrestrict_pmap_arg: restrPermMap (Hcompat tid0 cnt0).1 = marg)
            (Hat_external: semantics.at_external semSem c marg = Some (CREATE, Vptr b ofs::arg::nil))
            (Harg: Val.inject (Mem.flat_inj (Mem.nextblock m)) arg arg)
            (** we do not need to enforce the almost empty predicate on thread
           spawn as long as it's considered a synchronizing operation *)
            (Hangel1: permMapJoin newThreadPerm.1 threadPerm'.1 (getThreadR cnt0).1)
            (Hangel2: permMapJoin newThreadPerm.2 threadPerm'.2 (getThreadR cnt0).2)
            (Htp_upd: tp_upd = updThread cnt0 (Kresume c Vundef) threadPerm')
            (Htp': tp' = addThread tp_upd (Vptr b ofs) arg newThreadPerm),
            ext_step cnt0 Hcompat tp' m
                     (spawn (b, Ptrofs.intval ofs)
                            (Some (build_delta_content (fst virtue1) m))
                            (Some (build_delta_content (fst virtue2) m)))

    | step_mklock :
        forall  (tp' tp'': thread_pool) marg m1 c m' b ofs pmap_tid',
          let: pmap_tid := getThreadR cnt0 in
          forall
            (Hinv : invariant tp)
            (Hcode: getThreadC cnt0 = Kblocked c)
            (* To check if the machine is at an external step and load its arguments install the thread data permissions*)
            (Hrestrict_pmap_arg: restrPermMap (Hcompat tid0 cnt0).1 = marg)
            (Hat_external: semantics.at_external semSem c marg = Some (MKLOCK, Vptr b ofs::nil))
            (** install the thread's data permissions*)
            (Hrestrict_pmap: restrPermMap (Hcompat tid0 cnt0).1 = m1)
            (** To create the lock the thread must have [Writable] permission on it*)
            (Hfreeable: Mem.range_perm m1 b (Ptrofs.intval ofs) ((Ptrofs.intval ofs) + LKSIZE) Cur Writable)
            (** lock is created in acquired state*)
            (Hstore: Mem.store Mint32 m1 b (Ptrofs.intval ofs) (Vint Int.zero) = Some m')
            (** The thread's data permissions are set to Nonempty*)
            (Hdata_perm: setPermBlock
                           (Some Nonempty)
                           b
                           (Ptrofs.intval ofs)
                           pmap_tid.1
                           LKSIZE_nat = pmap_tid'.1)
            (** thread lock permission is increased *)
            (Hlock_perm: setPermBlock
                           (Some Writable)
                           b
                           (Ptrofs.intval ofs)
                           pmap_tid.2
                           LKSIZE_nat = pmap_tid'.2)
            (** Require that [(b, Ptrofs.intval ofs)] was not a lock*)
            (HlockRes: lockRes tp (b, Ptrofs.intval ofs) = None)
            (Htp': tp' = updThread cnt0 (Kresume c Vundef) pmap_tid')
            (** the lock has no resources initially *)
            (Htp'': tp'' = updLockSet tp' (b, Ptrofs.intval ofs) (empty_map, empty_map)),
            ext_step cnt0 Hcompat tp'' m' (mklock (b, Ptrofs.intval ofs))

    | step_freelock :
        forall  (tp' tp'': thread_pool) c marg b ofs pmap_tid' m1 pdata rmap
           (Hbounded: if isCoarse then
                        ( bounded_maps.bounded_nat_func' pdata LKSIZE_nat)
                      else
                        True ),
          let: pmap_tid := getThreadR cnt0 in
          forall
            (Hinv: invariant tp)
            (Hcode: getThreadC cnt0 = Kblocked c)
            (* To check if the machine is at an external step and load its arguments install the thread data permissions*)
            (Hrestrict_pmap_arg: restrPermMap (Hcompat tid0 cnt0).1 = marg)
            (Hat_external: semantics.at_external semSem c marg = Some (FREE_LOCK, Vptr b ofs::nil))
            (** If this address is a lock*)
            (His_lock: lockRes tp (b, (Ptrofs.intval ofs)) = Some rmap)
            (** And the lock is taken *)
            (Hrmap: forall b ofs, rmap.1 !! b ofs = None /\ rmap.2 !! b ofs = None)
            (** Install the thread's lock permissions*)
            (Hrestrict_pmap: restrPermMap (Hcompat tid0 cnt0).2 = m1)
            (** To free the lock the thread must have at least Writable on it*)
            (Hfreeable: Mem.range_perm m1 b (Ptrofs.intval ofs) ((Ptrofs.intval ofs) + LKSIZE) Cur Writable)
            (** lock permissions of the thread are dropped to empty *)
            (Hlock_perm: setPermBlock
                           None
                           b
                           (Ptrofs.intval ofs)
                           pmap_tid.2
                           LKSIZE_nat = pmap_tid'.2)
            (** data permissions are computed in a non-deterministic way *)
            (Hneq_perms: forall i,
                (0 <= Z.of_nat i < LKSIZE)%Z ->
                Mem.perm_order'' (pdata (S i)) (Some Writable)
            )
            (*Hpdata: perm_order pdata Writable*)
            (Hdata_perm: setPermBlock_var (*=setPermBlockfunc*)
                           pdata
                           b
                           (Ptrofs.intval ofs)
                           pmap_tid.1
                           LKSIZE_nat = pmap_tid'.1)
            (Htp': tp' = updThread cnt0 (Kresume c Vundef) pmap_tid')
            (Htp'': tp'' = remLockSet tp' (b, Ptrofs.intval ofs)),
            ext_step cnt0 Hcompat  tp'' m (freelock (b, Ptrofs.intval ofs))
    | step_acqfail :
        forall  c b ofs marg m1
           (Hinv : invariant tp)
           (Hcode: getThreadC cnt0 = Kblocked c)
           (* To check if the machine is at an external step and load its arguments install the thread data permissions*)
           (Hrestrict_pmap_arg: restrPermMap (Hcompat tid0 cnt0).1 = marg)
           (Hat_external: semantics.at_external semSem c marg = Some (LOCK, Vptr b ofs::nil))
           (** Install the thread's lock permissions*)
           (Hrestrict_pmap: restrPermMap (Hcompat tid0 cnt0).2 = m1)
           (** To acquire the lock the thread must have [Readable] permission on it*)
           (Haccess: Mem.range_perm m1 b (Ptrofs.intval ofs) ((Ptrofs.intval ofs) + LKSIZE) Cur Readable)
           (** Lock is already acquired.*)
           (Hload: Mem.load Mint32 m1 b (Ptrofs.intval ofs) = Some (Vint Int.zero)),
          ext_step cnt0 Hcompat tp m (failacq (b, Ptrofs.intval ofs)).

    Definition threadStep: forall {tid0 ms m},
        containsThread ms tid0 -> mem_compatible ms m ->
        thread_pool -> mem -> seq.seq mem_event -> Prop:=
      @dry_step.

    Lemma threadStep_at_Krun:
      forall i tp m cnt cmpt tp' m' tr,
        @threadStep i tp m cnt cmpt tp' m' tr ->
        (exists q, @getThreadC _ _ _ i tp cnt = Krun q).
    Proof.
      intros.
      inversion H; subst;
        now eauto.
    Qed.

    Lemma threadStep_equal_run:
      forall i tp m cnt cmpt tp' m' tr,
        @threadStep i tp m cnt cmpt tp' m' tr ->
        forall j,
          (exists cntj q, @getThreadC _ _ _ j tp cntj = Krun q) <->
          (exists cntj' q', @getThreadC _ _ _ j tp' cntj' = Krun q').
    Proof.
      intros. split.
      - intros [cntj [ q running]].
        inversion H; subst.
        assert (cntj':=cntj).
        (* XXX: eapply does not work here. report? *)
        pose proof (cntUpdate (Krun c') (getCurPerm m', (getThreadR cnt)#2) cnt cntj') as cntj''.
        exists cntj''.
        destruct (NatTID.eq_tid_dec i j).
        + subst j; exists c'.
          rewrite gssThreadCode; reflexivity.
        + exists q.
          erewrite gsoThreadCode;
            now eauto.
      - intros [cntj' [ q' running]].
        inversion H; subst.
        assert (cntj:=cntj').
        eapply cntUpdate' with(c0:=Krun c')(p:=(getCurPerm m', (getThreadR cnt)#2)) in cntj; eauto.
        exists cntj.
        destruct (NatTID.eq_tid_dec i j).
        + subst j; exists c.
          rewrite <- Hcode.
          f_equal.
          apply cnt_irr.
        + exists q'.
          rewrite gsoThreadCode in running; auto.
    Qed.

    Definition syncStep (isCoarse:bool) :
      forall {tid0 ms m},
        containsThread ms tid0 -> mem_compatible ms m ->
        thread_pool -> mem -> sync_event -> Prop:=
      @ext_step isCoarse.

    Lemma syncstep_equal_run:
      forall b i tp m cnt cmpt tp' m' tr,
        @syncStep b i tp m cnt cmpt tp' m' tr ->
        forall j,
          (exists cntj q, @getThreadC _ _ _ j tp cntj = Krun q) <->
          (exists cntj' q', @getThreadC _ _ _ j tp' cntj' = Krun q').
    Proof.
      intros b i tp m cnt cmpt tp' m' tr H j; split.
      - intros [cntj [ q running]].
        destruct (NatTID.eq_tid_dec i j).
        + subst j. generalize running; clear running.
          inversion H; subst;
            match goal with
            | [ H: getThreadC ?cnt = Kblocked ?c |- _ ] =>
              replace cnt with cntj in H by apply cnt_irr;
                intros HH; rewrite HH in H; inversion H
            end.
        + (*this should be easy to automate or shorten*)
          inversion H; subst.
          * exists (cntUpdateL _ _
                          (cntUpdate (Kresume c Vundef) _
                                     _ cntj)), q.
            rewrite gLockSetCode.
            apply cntUpdate;
              now auto.
            intros.
            rewrite gsoThreadCode; assumption.
          * exists ( (cntUpdateL _ _
                            (cntUpdate (Kresume c Vundef) _ _ cntj))), q.
            rewrite gLockSetCode.
            apply cntUpdate;
              now auto.
            intros.
            rewrite gsoThreadCode; assumption.
          * exists (cntAdd _ _ _
                      (cntUpdate (Kresume c Vundef) _ _ cntj)), q.
            erewrite gsoAddCode .
            rewrite gsoThreadCode; assumption.
          * exists ( (cntUpdateL _ _
                            (cntUpdate (Kresume c Vundef) _ _ cntj))), q.
            rewrite gLockSetCode.
            apply cntUpdate;
              now auto.
            intros.
            rewrite gsoThreadCode; assumption.
          * exists ( (cntRemoveL _
                            (cntUpdate (Kresume c Vundef) _ _ cntj))), q.
            rewrite gRemLockSetCode.
            apply cntUpdate;
              now auto.
            intros.
            rewrite gsoThreadCode; assumption.
          * exists cntj, q; assumption.
      - intros [cntj [ q running]].
        destruct (NatTID.eq_tid_dec i j).
        + subst j. generalize running; clear running;
          inversion H; subst; intros;
            try (exfalso;
                 erewrite gLockSetCode with (cnti := cntUpdateL' _ _ cntj) in running;
                 rewrite gssThreadCode in running;
                 discriminate).

          { (*addthread*)
            assert (cntj':=cntj).
            eapply cntAdd' in cntj'; destruct cntj' as [ [HH HHH] | HH].
            * exfalso.
              assert (Heq: getThreadC cntj = getThreadC HH)
                by (rewrite gsoAddCode; reflexivity).
              rewrite Heq in running.
              rewrite gssThreadCode in running.
              discriminate.
            * erewrite gssAddCode in running; eauto.
              discriminate. }
          { (*remove lock*)
            pose proof (cntUpdate' _ _ cnt (cntRemoveL' _ cntj)) as cnti.
            erewrite  gRemLockSetCode with (cnti0 := cntRemoveL' _ cntj) in running.
            rewrite gssThreadCode in running.
            discriminate. }
          { (*acquire lock*)
            do 2 eexists; eauto.
          }
        + generalize running; clear running.
          inversion H; subst;
          intros.
          - exists (cntUpdate' _ _ cnt (cntUpdateL' _ _ cntj)), q.
            rewrite <- running.
            rewrite gLockSetCode.
            eapply cntUpdateL'; eauto.
            intros.
            rewrite gsoThreadCode; eauto.
            eapply cntUpdate'; eapply cntUpdateL'; eauto.
            intros.
            erewrite cnt_irr with (cnt1 := Hyp1).
            reflexivity.
          - exists (cntUpdate' _ _ cnt (cntUpdateL' _ _ cntj)), q.
            rewrite <- running.
            rewrite gLockSetCode.
            eapply cntUpdateL'; eauto.
            intros.
            rewrite gsoThreadCode; eauto.
            eapply cntUpdate'; eapply cntUpdateL'; eauto.
            intros.
            erewrite cnt_irr with (cnt1 := Hyp1).
            reflexivity.
          -  (*Add thread case*)
            assert (cntj':=cntj).
            eapply cntAdd' in cntj'; destruct cntj' as [ [HH HHH] | HH].
            * pose proof (cntUpdate' _ _ _ HH) as cntj0.
              exists cntj0, q.
              rewrite <- running.
              erewrite gsoAddCode with (cntj1 := HH).
              rewrite gsoThreadCode;
                now eauto.
            * exfalso.
              erewrite gssAddCode in running; eauto. discriminate.
          - exists (cntUpdate' _ _ cnt (cntUpdateL' _ _ cntj)), q.
            rewrite <- running.
            rewrite gLockSetCode.
            eapply cntUpdateL'; eauto.
            intros.
            rewrite gsoThreadCode; eauto.
            eapply cntUpdate'; eapply cntUpdateL'; eauto.
            intros.
            erewrite cnt_irr with (cnt1 := Hyp1).
            reflexivity.
          -  exists (cntUpdate' _ _ cnt (cntRemoveL' _ cntj)), q.
             rewrite <- running.
             rewrite gRemLockSetCode.
             eapply cntRemoveL'; eauto.
             intros.
             rewrite gsoThreadCode; eauto.
             eapply cntUpdate'; eapply cntRemoveL'; eauto.
             intros.
             erewrite cnt_irr with (cnt1 := Hyp1).
             reflexivity.
          - do 2 eexists;
              now eauto.
            Grab Existential Variables.
            apply cntUpdate;
              now eauto.
    Qed.

    Lemma syncstep_not_running:
      forall b i tp m cnt cmpt tp' m' tr,
        @syncStep b i tp m cnt cmpt tp' m' tr ->
        forall cntj q, ~ @getThreadC _ _ _ i tp cntj = Krun q.
    Proof.
      intros.
      inversion H;
        match goal with
        | [ H: getThreadC ?cnt = _ |- _ ] =>
          erewrite (cnt_irr _ _ _ cnt);
            rewrite H; intros AA; inversion AA
        end.
    Qed.

    Definition initial_machine pmap c := mkPool (Krun c) (pmap, empty_map).

    Definition init_mach (pmap : option res) (m: mem)
               (ms:thread_pool) (m' : mem) (v:val) (args:list val) : Prop :=
      exists c, semantics.initial_core semSem 0 m c m' v args /\
           ms = mkPool (Krun c) (getCurPerm m', empty_map).
    Set Printing All.

    Definition install_perm tp m tid (Hcmpt: mem_compatible tp m) (Hcnt: containsThread tp tid) m' :=
      m' = restrPermMap (Hcmpt tid Hcnt).1.

    Definition add_block tp m tid (Hcmpt: mem_compatible tp m) (Hcnt: containsThread tp tid) m' :=
      (getCurPerm m', (getThreadR Hcnt).2).

    (** The signature of a Dry HybridMachine *)
    (** This can be used to instantiate a Dry CoarseHybridMachine or a Dry
    FineHybridMachine *)

    Instance DryHybridMachineSig: @HybridMachineSig.MachineSig dryResources Sem tpool :=
      (@HybridMachineSig.Build_MachineSig dryResources Sem tpool
                             richMem
                             dryMem
                             mem_compatible
                             invariant
                             install_perm
                             add_block
                             (@threadStep)
                             threadStep_at_Krun
                             threadStep_equal_run
                             (@syncStep)
                             syncstep_equal_run
                             syncstep_not_running
                             init_mach
      ).

  End DryHybridMachine.

  Section HybDryMachineLemmas.

    (* Lemmas that don't need semantics/threadpool*)

      Lemma build_delta_content_restr: forall d m p Hlt,
        build_delta_content d (@restrPermMap p m Hlt) = build_delta_content d m.
      Proof.
        reflexivity.
      Qed.

      (** Assume some threadwise semantics *)
      Context {Sem: Semantics}
            {tpool : @ThreadPool.ThreadPool dryResources Sem}.

      (*TODO: This lemma should probably be moved. *)
      Lemma threads_canonical:
        forall ds m i (cnt:containsThread ds i),
          mem_compatible ds m ->
          isCanonical (getThreadR cnt).1 /\
          isCanonical (getThreadR cnt).2.
        intros.
        destruct (compat_th _ _ H cnt);
          eauto using canonical_lt.
      Qed.
      (** most of these lemmas are in DryMachinLemmas*)

      (** *Invariant Lemmas*)

      (** ** Updating the machine state**)
      (* Many invaraint lemmas were removed from here. *)

    Notation thread_perms st i cnt:= (fst (@getThreadR _ _ _ st i cnt)).
    Notation lock_perms st i cnt:= (snd (@getThreadR  _ _ _ st i cnt)).
    Record thread_compat st i
           (cnt:containsThread st i) m:=
      { th_comp: permMapLt (thread_perms _ _ cnt) (getMaxPerm m);
        lock_comp: permMapLt (lock_perms _ _ cnt) (getMaxPerm m)}.
    Instance thread_compat_proper st i:
        Proper (Logic.eq ==> Max_equiv ==> iff) (@thread_compat st i).
      Proof. setoid_help.proper_iff;
               setoid_help.proper_intros; subst.
             constructor.
             - eapply permMapLt_equiv.
               reflexivity.
               symmetry; apply H0.
               eapply H1.
             - eapply permMapLt_equiv.
               reflexivity.
               symmetry; apply H0.
               eapply H1.
      Qed.
    Lemma mem_compatible_thread_compat:
      forall (st1 : ThreadPool.t) (m1 : mem) (tid : nat)
        (cnt1 : containsThread st1 tid),
        mem_compatible st1 m1 -> thread_compat _ _ cnt1 m1.
    Proof. intros * H; constructor; apply H. Qed.
    Lemma mem_compat_Max:
        forall Sem Tp st m m',
          Max_equiv m m' ->
          Mem.nextblock m = Mem.nextblock m' ->
          @mem_compatible Sem Tp st m ->
          @mem_compatible Sem Tp st m'.
      Proof.
        intros * Hmax Hnb H.
        assert (Hmax':access_map_equiv (getMaxPerm m) (getMaxPerm m'))
          by eapply Hmax.
        constructor; intros;
          repeat rewrite <- Hmax';
          try eapply H; eauto.
        unfold Mem.valid_block; rewrite <- Hnb;
          eapply H; eauto.
      Qed.

  End HybDryMachineLemmas.

End DryHybridMachine.

Export DryHybridMachine.


Require Import RelationClasses.
Require Import Coq.Logic.PropExtensionality.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.
From PromisingLib Require Import Event.

Require Import Time.
Require Import View.
Require Import BoolMap.
Require Import Promises.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Global.
Require Import Local.
Require Import Thread.

Require Import Cover.

Require Import PFConsistent.
Require Import Certify.
Require Import Mapping.

Set Implicit Arguments.

Definition is_cancel (e: ThreadEvent.t): Prop :=
  match e with
  | ThreadEvent.cancel _ _ _ => True
  | _ => False
  end.

Module CurrentCertify.
Section CurrentCertify.
  Variable (lang: language).

  Variant canceled_reserves (dom: list (Loc.t * Time.t)) (rsv rsvc: Memory.t): Prop :=
    | canceled_reserves_intro
        (SOUND: Memory.le rsvc rsv)
        (COMPLETE: forall loc from to msg
                          (GET: Memory.get loc to rsvc = Some (from, msg)),
            List.In (loc, to) dom)
  .

  Variant canceled_local (dom: list (Loc.t * Time.t)) (lc lcc: Local.t): Prop :=
    | canceled_local_intro
        (TVIEW: lcc.(Local.tview) = lc.(Local.tview))
        (PROMISES: lcc.(Local.promises) = lc.(Local.promises))
        (RESERVES: canceled_reserves dom lc.(Local.reserves) lcc.(Local.reserves))
  .

  Variant canceled_memory (rsv rsvc mem memc: Memory.t): Prop :=
    | canceled_memory_intro
        (SOUND: Memory.le memc mem)
        (COMPLETE: Memory.messages_le mem memc)
        (RESERVES: forall loc from to msg
                          (GET: Memory.get loc to rsv = Some (from, msg))
                          (GETC: Memory.get loc to rsvc = None),
            Memory.get loc to memc = None)
  .

  Variant canceled_thread (dom: list (Loc.t * Time.t)) (th thc: Thread.t lang): Prop :=
    | canceled_thread_intro
        (STATE: thc.(Thread.state) = th.(Thread.state))
        (LOCAL: canceled_local dom th.(Thread.local) thc.(Thread.local))
        (SC: th.(Thread.global).(Global.sc) = thc.(Thread.global).(Global.sc))
        (GPROMISES: th.(Thread.global).(Global.promises) = thc.(Thread.global).(Global.promises))
        (MEMORY: canceled_memory th.(Thread.local).(Local.reserves)
                                 thc.(Thread.local).(Local.reserves)
                                 th.(Thread.global).(Global.memory)
                                 thc.(Thread.global).(Global.memory))
  .

  Lemma canceled_thread_refl
        (th: Thread.t lang)
        (LC_WF: Local.wf th.(Thread.local) th.(Thread.global)):
    exists dom,
      canceled_thread dom th th.
  Proof.
    inv LC_WF. inv RESERVES_FINITE.
    exists x. econs; ss.
    { econs; ss. econs; ss. }
    { econs; ss. i. congr. }
  Qed.

  Lemma canceled_thread_step
        loc to dom
        th thc1
        (CANCELED1: canceled_thread ((loc, to)::dom) th thc1)
        (LC_WF: Local.wf thc1.(Thread.local) thc1.(Thread.global)):
    (<<CANCELED2: canceled_thread dom th thc1>>) \/
    exists from thc2,
      (<<CANCEL: Thread.step (ThreadEvent.cancel loc from to) thc1 thc2>>) /\
      (<<CANCELED2: canceled_thread dom th thc2>>).
  Proof.
    destruct th as [st [tview prm rsv] [sc gprm mem]].
    destruct thc1 as [stc1 [tviewc1 prmc1 rsvc1] [scc1 gprmc1 memc1]].
    inv CANCELED1. inv LOCAL. ss. subst.
    destruct (Memory.get loc to rsvc1) as [[from msg]|] eqn:X; cycle 1.
    { left. econs; ss. econs; ss.
      inv RESERVES. econs; ss. i.
      exploit COMPLETE; eauto. i. des; ss.
      inv x0. congr.
    }
    right. inv LC_WF. ss.
    exploit RESERVES_ONLY; eauto. i. subst.
    exploit Memory.remove_exists; try exact X. i. des.
    exploit Memory.remove_exists_le; try exact x0; eauto. i. des.
    hexploit Memory.remove_le; try exact x0. i.
    hexploit Memory.remove_le; try exact x1. i.
    esplits.
    { econs. econs. econs; eauto. }
    { econs; ss.
      { econs; ss.
        inv RESERVES. econs; [etrans; eauto|]. i.
        revert GET. erewrite Memory.remove_o; eauto. condtac; ss. i.
        exploit COMPLETE; eauto. i. des; ss; congr.
      }
      { inv MEMORY. econs; ss.
        { etrans; eauto. }
        { ii. erewrite Memory.remove_o; eauto.
          condtac; ss; eauto. des. subst.
          exploit Memory.remove_get0; try exact x1. i. des.
          exploit SOUND; eauto. i. congr.
        }
        { i. revert GETC.
          erewrite Memory.remove_o; eauto. condtac; ss; i.
          { des. subst.
            exploit Memory.remove_get0; try exact x1. i. des. ss.
          }
          { guardH o.
            exploit RESERVES1; eauto. i.
            erewrite Memory.remove_o; eauto. condtac; ss.
          }
        }
      }
    }
  Qed.

  Lemma canceled_thread_steps
        dom
        th thc1
        (CANCELED1: canceled_thread dom th thc1)
        (LC_WF: Local.wf thc1.(Thread.local) thc1.(Thread.global))
        (GL_WF: Global.wf thc1.(Thread.global)):
    exists thc2,
      (<<CANCEL: rtc (pstep (@Thread.step _) is_cancel) thc1 thc2>>) /\
      (<<CANCELED2: canceled_thread [] th thc2>>).
  Proof.
    revert th thc1 CANCELED1 LC_WF GL_WF.
    induction dom; i; eauto.
    destruct a as [loc to].
    exploit canceled_thread_step; eauto. i. des; eauto.
    exploit Thread.step_future; eauto. i. des.
    exploit IHdom; eauto. i. des.
    esplits; try exact CANCELED0.
    econs 2; eauto. econs; eauto. ss.
  Qed.

  Lemma cancel_reserves
        th
        (LC_WF: Local.wf th.(Thread.local) th.(Thread.global))
        (GL_WF: Global.wf th.(Thread.global)):
    exists thc,
      (<<CANCEL: rtc (pstep (@Thread.step _) is_cancel) th thc>>) /\
      (<<CANCELED: canceled_thread [] th thc>>).
  Proof.
    exploit canceled_thread_refl; eauto. i. des.
    exploit canceled_thread_steps; eauto.
  Qed.

  Lemma canceled_map
        (th thc: Thread.t lang)
        (CANCELED: canceled_thread [] th thc)
        (LC_WF: Local.wf th.(Thread.local) th.(Thread.global))
        (GL_WF: Global.wf th.(Thread.global)):
    exists f,
      (<<F: f = fun loc ts fts =>
                  ts = fts /\
                  exists from to msg,
                    Memory.get loc to th.(Thread.global).(Global.memory) = Some (from, msg) /\
                    __guard__ (ts = from \/ ts = to)>>) /\
      (<<MAP_WF: map_wf f>>) /\
      (<<MAP: thread_map_racy_promise f (Thread.cap_of th) thc>>).
  Proof.
    destruct th as [st [tview prm rsv] [sc gprm mem]].
    destruct thc as [stc [tviewc prmc rsvc] [scc gprmc memc]].
    inv CANCELED. inv LOCAL. ss. subst.
    esplits; try refl.
    { (* map_wf *)
      econs; ii; subst.
      { esplits; ss; try apply GL_WF. left. ss. }
      { exists (List.concat
                  (List.map (fun e => [fst e; fst (snd e)]) (DOMap.elements (Cell.raw (mem loc))))).
        i. des. subst.
        exploit DOMap.elements_correct; eauto. i.
        remember (DOMap.elements (Cell.raw (mem loc))) as l.
        clear - l x0 MAP1.
        revert fts from to msg MAP1 x0.
        induction l; ss; i. des; eauto.
        subst. ss. unguard. des; auto.
      }
      { des. subst. ss. }
      { des. subst. ss. }
      { des. subst. ss. }
      { des. subst. ss. }
    }

    (* thread_map *)
    econs; ss.
    { (* local_map *)
      econs. eapply closed_tview_map; try apply LC_WF. s. i.
      esplits; eauto. right. ss.
    }
    { (* global_map *)
      specialize (@Memory.cap_of_cap mem). intro CAP.
      hexploit Memory.cap_le; eauto. intro LE.
      inv RESERVES. inv MEMORY.
      econs. econs; ss; i.
      { destruct msg; auto. right.
        exploit Memory.cap_inv; eauto. i. des; ss.
        exploit COMPLETE0; eauto. i.
        esplits; unguard; eauto.
        inv GL_WF. inv MEM_CLOSED.
        exploit CLOSED; eauto. s. i. des. inv MSG_CLOSED.
        econs. eapply closed_opt_view_map; eauto. i.
        esplits; eauto.
      }
      { exploit SOUND0; eauto. i.
        esplits; eauto; (try refl); unguard; auto; i.
        { inv CAP. exploit SOUND1; eauto. i.
          econs; eauto.
        }
        { inv LC_WF. ss.
          exploit RESERVES0; eauto. i.
          exploit Memory.get_disjoint; [exact x1|exact x0|]. i. des; ss. subst.
          exploit RESERVES; eauto; try congr.
          destruct (Memory.get loc fto rsvc) as [[]|] eqn:X; ss.
          exploit COMPLETE; eauto. ss.
        }
      }
    }
  Qed.

  Lemma canceled_certify_racy_promise
        th thc loc
        (CANCELED: canceled_thread [] th thc)
        (LC_WF: Local.wf th.(Thread.local) th.(Thread.global))
        (GL_WF: Global.wf th.(Thread.global))
        (LC_WF_C: Local.wf thc.(Thread.local) thc.(Thread.global))
        (GL_WF_C: Global.wf thc.(Thread.global))
        (CERTIFY: certify_racy_promise loc (Thread.cap_of th)):
    @pf_certify_racy_promise lang loc thc.
  Proof.
    exploit Local.cap_wf; try exact CAP; try exact LC_WF. intro LC_WF_CAP.
    exploit Global.cap_wf; try exact GL_WF. intro GL_WF_CAP.
    exploit canceled_map; eauto. i. des.
    eapply map_certify_racy_promise; try exact CERTIFY; eauto.
  Qed.

  Lemma current_certify_racy_promise
        th loc
        (LC_WF: Local.wf th.(Thread.local) th.(Thread.global))
        (GL_WF: Global.wf th.(Thread.global))
        (CERTIFY: certify_racy_promise loc (Thread.cap_of th)):
    @certify_racy_promise lang loc th.
  Proof.
    exploit cancel_reserves; eauto. i. des.
    exploit Thread.rtc_all_step_future;
      try eapply rtc_implies; try exact CANCEL; eauto.
    { i. inv H. econs. eauto. }
    i. des.
    exploit canceled_certify_racy_promise; eauto. i.
    inv x0.
    - econs 1; try exact STEP_FAILURE; eauto.
      etrans.
      + eapply rtc_implies; try exact CANCEL.
        i. inv H. econs; eauto. destruct e0; ss. auto.
      + eapply rtc_implies; try exact STEPS.
        i. inv H. des. econs; eauto. split; ss.
        destruct e0; ss.
    - econs 2; try exact STEP_FULFILL; eauto.
      etrans.
      + eapply rtc_implies; try exact CANCEL.
        i. inv H. econs; eauto. destruct e; ss. auto.
      + eapply rtc_implies; try exact STEPS.
        i. inv H. des. econs; eauto. split; ss.
        destruct e; ss.
  Qed.

  Lemma promise_step_sim_thread
        th1 th2 loc
        (STEP: @Thread.step lang (ThreadEvent.promise loc) th1 th2):
    PFConsistent.sim_thread th1 th2.
  Proof.
    exploit Thread.step_promises_minus; eauto. i.
    inv STEP; inv LOCAL. inv LOCAL0. inv PROMISE; ss.
    econs; ss; try apply PFConsistent.sim_memory_PreOrder.
    eapply BoolMap.add_le; eauto.
  Qed.

  Lemma rtc_step_consistent_ceritfy_racy_promise
        th0 th1 th2 loc
        (LC_WF: Local.wf th0.(Thread.local) th0.(Thread.global))
        (GL_WF: Global.wf th0.(Thread.global))
        (STEP: Thread.step (ThreadEvent.promise loc) th0 th1)
        (STEPS: rtc (@Thread.all_step lang) th1 th2)
        (CONSISTENT: Thread.consistent th2):
    certify_racy_promise loc th0.
  Proof.
    cut (certify_racy_promise loc th1).
    { exploit promise_step_sim_thread; eauto. i. inv H.
      { exploit PFConsistent.sim_thread_rtc_non_sc_step;
          try eapply rtc_implies; try exact STEPS0; eauto.
        { i. inv H. des. econs; eauto. }
        i. des.
        exploit Thread.rtc_all_step_future;
          try eapply rtc_implies; try exact STEPS_SRC; eauto.
        { i. inv H. econs; eauto. }
        i. des.
        exploit PFConsistent.sim_thread_step; try exact STEP_FAILURE; eauto. i. des.
        unguard. des; subst; try by (destruct e; ss).
        inv STEP_SRC; ss.
        econs 1; eauto.
      }
      { exploit PFConsistent.sim_thread_rtc_non_sc_step;
          try eapply rtc_implies; try exact STEPS0; eauto.
        { i. inv H. des. econs; eauto. }
        i. des.
        exploit Thread.rtc_all_step_future;
          try eapply rtc_implies; try exact STEPS_SRC; eauto.
        { i. inv H. econs; eauto. }
        i. des.
        exploit PFConsistent.sim_thread_step; try exact STEP_FAILURE; eauto. i. des.
        unguard. des; subst; ss.
        inv STEP_SRC; ss.
        econs 2; eauto.
        eapply TimeFacts.le_lt_lt; eauto.
        eapply Memory.le_max_ts; try apply GL_WF2. apply SIM2.
      }
    }

    assert (PROMISED: th1.(Thread.local).(Local.promises) loc = true).
    { inv STEP; inv LOCAL. inv LOCAL0. inv PROMISE.
      exploit BoolMap.add_get0; try exact ADD. i. des. ss.
    }
    exploit Thread.step_future; eauto. i. des.
    clear th0 LC_WF GL_WF STEP TVIEW_FUTURE GL_FUTURE.
    exploit PFConsistent.rtc_all_step_rtc_non_sc_step; eauto. i. des; cycle 1.
    { (* failure during rtc step *)
      exploit PFConsistent.sim_thread_rtc_non_sc_step; try exact STEPS1; eauto.
      { apply PFConsistent.sim_thread_PreOrder. }
      i. des.
      exploit Thread.rtc_all_step_future;
        try eapply rtc_implies; try exact STEPS_SRC; eauto.
      { i. inv H. econs. eauto. }
      i. des.
      exploit PFConsistent.sim_thread_step; try exact STEP_FAILURE; eauto. i. des.
      unguard. des; subst; cycle 1.
      { destruct e; ss. }
      inv STEP_SRC; ss.
      econs 1; try exact STEP; eauto.
    }
    { (* sc during rtc step *)
      exploit PFConsistent.sim_thread_rtc_non_sc_step; try exact STEPS1; eauto.
      { apply PFConsistent.sim_thread_PreOrder. }
      i. des.
      exploit rtc_pf_step_certify_racy_promise; try exact STEPS_SRC; eauto.
      destruct (th2_src.(Thread.local).(Local.promises) loc) eqn:GETP; ss.
      inv SIM2. exploit PROMISES0; eauto.
      rewrite PROMISES. ss.
    }
    subst.
    destruct (th2.(Thread.local).(Local.promises) loc) eqn:PROMISED2; cycle 1.
    { (* fulfilled during rtc step *)
      exploit PFConsistent.sim_thread_rtc_non_sc_step; try exact STEPS1; eauto.
      { apply PFConsistent.sim_thread_PreOrder. }
      i. des.
      exploit rtc_pf_step_certify_racy_promise; try exact STEPS_SRC; eauto.
      destruct (th2_src.(Thread.local).(Local.promises) loc) eqn:GETP; ss.
      inv SIM2. exploit PROMISES; eauto.
    }
    (* fulfilled during certification *)
    exploit Thread.rtc_all_step_future; try exact STEPS; eauto. i. des.
    exploit PFConsistent.consistent_pf_consistent; eauto. i.
    exploit pf_consistent_certify_racy_promise; eauto. i.
    exploit current_certify_racy_promise; try exact x1; eauto. i.
    move STEPS1 at bottom. inv x2.
    { exploit PFConsistent.sim_thread_rtc_non_sc_step;
        try exact LC_WF2; try exact GL_WF2; try apply PFConsistent.sim_thread_PreOrder.
      { etrans; [exact STEPS1|].
        eapply rtc_implies; try exact STEPS0.
        i. inv H. des. econs; eauto.
      }
      i. des.
      exploit Thread.rtc_all_step_future;
        try eapply rtc_implies; try exact STEPS_SRC; ss.
      { i. inv H. econs. eauto. }
      i. des.
      exploit PFConsistent.sim_thread_step; try exact SIM2; eauto. i. des.
      unguard. des; subst; try by (destruct e; ss).
      inv STEP_SRC; ss.
      econs 1; eauto.
    }
    { exploit PFConsistent.sim_thread_rtc_non_sc_step;
        try exact LC_WF2; try exact GL_WF2; try apply PFConsistent.sim_thread_PreOrder.
      { etrans; [exact STEPS1|].
        eapply rtc_implies; try exact STEPS0.
        i. inv H. des. econs; eauto.
      }
      i. des.
      exploit Thread.rtc_all_step_future;
        try eapply rtc_implies; try exact STEPS_SRC; ss.
      { i. inv H. econs. eauto. }
      i. des.
      exploit PFConsistent.sim_thread_step; try exact SIM2; eauto. i. des.
      unguard. des; subst; ss.
      inv STEP_SRC; ss.
      econs 2; eauto.
      eapply TimeFacts.le_lt_lt; eauto.
      inv SIM2. inv MEMORY.
      eapply Memory.le_max_ts; try apply GL_WF1. apply SOUND.
    }
  Qed.
End CurrentCertify.
End CurrentCertify.