(* Default settings (from HsToCoq.Coq.Preamble) *)

Generalizable All Variables.

Unset Implicit Arguments.
Set Maximal Implicit Insertion.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Coq.Program.Tactics.
Require Coq.Program.Wf.

(* Preamble *)

(* Converted imports: *)

Require BasicTypes.
Require BinNat.
Require BinNums.
Require Coq.ZArith.BinInt.
Require Data.Bits.
Require FastString.
Require GHC.Base.
Require GHC.Char.
Require GHC.Num.
Import GHC.Base.Notations.
Import GHC.Num.Notations.

(* Converted type declarations: *)

Inductive Unique : Type := MkUnique : BinNums.N -> Unique.

Record Uniquable__Dict a := Uniquable__Dict_Build {
  getUnique__ : a -> Unique }.

Definition Uniquable a :=
  forall r__, (Uniquable__Dict a -> r__) -> r__.

Existing Class Uniquable.

Definition getUnique `{g__0__ : Uniquable a} : a -> Unique :=
  g__0__ _ (getUnique__ a).

(* Midamble *)

Instance Default__Name : GHC.Err.Default Unique
  := GHC.Err.Build_Default _ (MkUnique GHC.Err.default).

Program Instance Uniquable__Word : Uniquable GHC.Num.Word :=
  fun _ k => k {| getUnique__ x := MkUnique x |}.

(* Parameter mkUnique : GHC.Char.Char -> GHC.Num.Word -> Unique. *)

(* Converted value declarations: *)

Definition uNIQUE_BITS : GHC.Num.Int :=
  #56.

Definition uniqueMask : GHC.Num.Int :=
  Data.Bits.shiftL #1 uNIQUE_BITS GHC.Num.- #1.

Definition unpkUnique : Unique -> GHC.Char.Char * GHC.Num.Int :=
  fun '(MkUnique u) =>
    let i := Coq.ZArith.BinInt.Z.land (Coq.ZArith.BinInt.Z.of_N u) uniqueMask in
    let tag :=
      GHC.Char.chr (Data.Bits.shiftR (Coq.ZArith.BinInt.Z.of_N u) uNIQUE_BITS) in
    pair tag i.

Definition stepUnique : Unique -> BinNums.N -> Unique :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | MkUnique i, n => MkUnique (i GHC.Num.+ n)
    end.

Definition nonDetCmpUnique : Unique -> Unique -> comparison :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | MkUnique u1, MkUnique u2 =>
        if u1 GHC.Base.== u2 : bool
        then Eq
        else if u1 GHC.Base.< u2 : bool
             then Lt
             else Gt
    end.

Definition mkUniqueGrimily : BinNums.N -> Unique :=
  MkUnique.

Definition mkUnique : GHC.Char.Char -> GHC.Num.Word -> Unique :=
  fun c i =>
    let bits := Coq.ZArith.BinInt.Z.land (Coq.ZArith.BinInt.Z.of_N i) uniqueMask in
    let tag := Data.Bits.shiftL (GHC.Base.ord c) uNIQUE_BITS in
    MkUnique (Coq.ZArith.BinInt.Z.to_N (Coq.ZArith.BinInt.Z.lor tag bits)).

Definition mkVarOccUnique : FastString.FastString -> Unique :=
  fun fs => mkUnique (GHC.Char.hs_char__ "i") (FastString.uniqueOfFS fs).

Definition mkTvOccUnique : FastString.FastString -> Unique :=
  fun fs => mkUnique (GHC.Char.hs_char__ "v") (FastString.uniqueOfFS fs).

Definition mkTcOccUnique : FastString.FastString -> Unique :=
  fun fs => mkUnique (GHC.Char.hs_char__ "c") (FastString.uniqueOfFS fs).

Definition mkRegSubUnique : BinNums.N -> Unique :=
  mkUnique (GHC.Char.hs_char__ "S").

Definition mkRegSingleUnique : BinNums.N -> Unique :=
  mkUnique (GHC.Char.hs_char__ "R").

Definition mkRegPairUnique : BinNums.N -> Unique :=
  mkUnique (GHC.Char.hs_char__ "P").

Definition mkRegClassUnique : BinNums.N -> Unique :=
  mkUnique (GHC.Char.hs_char__ "L").

Definition mkPseudoUniqueH : BinNums.N -> Unique :=
  fun i => mkUnique (GHC.Char.hs_char__ "H") i.

Definition mkPseudoUniqueE : BinNums.N -> Unique :=
  fun i => mkUnique (GHC.Char.hs_char__ "E") i.

Definition mkPseudoUniqueD : BinNums.N -> Unique :=
  fun i => mkUnique (GHC.Char.hs_char__ "D") i.

Definition mkPrimOpIdUnique : BinNums.N -> Unique :=
  fun op => mkUnique (GHC.Char.hs_char__ "9") op.

Definition mkPreludeTyConUnique : BinNums.N -> Unique :=
  fun i => mkUnique (GHC.Char.hs_char__ "3") (#2 GHC.Num.* i).

Definition mkPreludeMiscIdUnique : BinNums.N -> Unique :=
  fun i => mkUnique (GHC.Char.hs_char__ "0") i.

Definition mkPreludeDataConUnique : BasicTypes.Arity -> Unique :=
  fun i => mkUnique (GHC.Char.hs_char__ "6") (#3 GHC.Num.* BinNat.N.of_nat i).

Definition mkPreludeClassUnique : BinNums.N -> Unique :=
  fun i => mkUnique (GHC.Char.hs_char__ "2") i.

Definition mkPArrDataConUnique : BinNums.N -> Unique :=
  fun a => mkUnique (GHC.Char.hs_char__ ":") (#2 GHC.Num.* a).

Definition mkDataOccUnique : FastString.FastString -> Unique :=
  fun fs => mkUnique (GHC.Char.hs_char__ "d") (FastString.uniqueOfFS fs).

Definition mkCostCentreUnique : BinNums.N -> Unique :=
  mkUnique (GHC.Char.hs_char__ "C").

Definition mkCoVarUnique : BinNums.N -> Unique :=
  fun i => mkUnique (GHC.Char.hs_char__ "g") i.

Definition mkBuiltinUnique : BinNums.N -> Unique :=
  fun i => mkUnique (GHC.Char.hs_char__ "B") i.

Definition mkAlphaTyVarUnique : BinNums.N -> Unique :=
  fun i => mkUnique (GHC.Char.hs_char__ "1") i.

Definition isValidKnownKeyUnique : Unique -> bool :=
  fun u =>
    let 'pair c x := unpkUnique u in
    andb (GHC.Base.ord c GHC.Base.< #255) (x GHC.Base.<= (Data.Bits.shiftL #1 #22)).

Definition initTyVarUnique : Unique :=
  mkUnique (GHC.Char.hs_char__ "t") #0.

Definition initExitJoinUnique : Unique :=
  mkUnique (GHC.Char.hs_char__ "s") #0.

Definition incrUnique : Unique -> Unique :=
  fun '(MkUnique i) => MkUnique (i GHC.Num.+ #1).

Definition tyConRepNameUnique : Unique -> Unique :=
  fun u => incrUnique u.

Definition eqUnique : Unique -> Unique -> bool :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | MkUnique u1, MkUnique u2 => u1 GHC.Base.== u2
    end.

Local Definition Eq___Unique_op_zeze__ : Unique -> Unique -> bool :=
  fun a b => eqUnique a b.

Local Definition Eq___Unique_op_zsze__ : Unique -> Unique -> bool :=
  fun a b => negb (eqUnique a b).

Program Instance Eq___Unique : GHC.Base.Eq_ Unique :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zeze____ := Eq___Unique_op_zeze__ ;
           GHC.Base.op_zsze____ := Eq___Unique_op_zsze__ |}.

Definition hasKey {a} `{Uniquable a} : a -> Unique -> bool :=
  fun x k => getUnique x GHC.Base.== k.

Definition getKey : Unique -> BinNums.N :=
  fun '(MkUnique x) => x.

Definition deriveUnique : Unique -> BinNums.N -> Unique :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | MkUnique i, delta => mkUnique (GHC.Char.hs_char__ "X") (i GHC.Num.+ delta)
    end.

Definition dataConWorkerUnique : Unique -> Unique :=
  fun u => incrUnique u.

Definition dataConRepNameUnique : Unique -> Unique :=
  fun u => stepUnique u #2.

(* Skipping all instances of class `GHC.Show.Show', including
   `Unique.Show__Unique' *)

(* Skipping all instances of class `Outputable.Outputable', including
   `Unique.Outputable__Unique' *)

Local Definition Uniquable__Unique_getUnique : Unique -> Unique :=
  fun u => u.

Program Instance Uniquable__Unique : Uniquable Unique :=
  fun _ k__ => k__ {| getUnique__ := Uniquable__Unique_getUnique |}.

Local Definition Uniquable__N_getUnique : BinNums.N -> Unique :=
  fun i => mkUniqueGrimily i.

Program Instance Uniquable__N : Uniquable BinNums.N :=
  fun _ k__ => k__ {| getUnique__ := Uniquable__N_getUnique |}.

Local Definition Uniquable__FastString_getUnique
   : FastString.FastString -> Unique :=
  fun fs => mkUniqueGrimily (FastString.uniqueOfFS fs).

Program Instance Uniquable__FastString : Uniquable FastString.FastString :=
  fun _ k__ => k__ {| getUnique__ := Uniquable__FastString_getUnique |}.

Definition getWordKey : Unique -> GHC.Num.Word :=
  getKey.

(* External variables:
     Eq Gt Lt andb bool comparison negb op_zt__ pair BasicTypes.Arity BinNat.N.of_nat
     BinNums.N Coq.ZArith.BinInt.Z.land Coq.ZArith.BinInt.Z.lor
     Coq.ZArith.BinInt.Z.of_N Coq.ZArith.BinInt.Z.to_N Data.Bits.shiftL
     Data.Bits.shiftR FastString.FastString FastString.uniqueOfFS GHC.Base.Eq_
     GHC.Base.op_zeze__ GHC.Base.op_zeze____ GHC.Base.op_zl__ GHC.Base.op_zlze__
     GHC.Base.op_zsze____ GHC.Base.ord GHC.Char.Char GHC.Char.chr GHC.Num.Int
     GHC.Num.Word GHC.Num.fromInteger GHC.Num.op_zm__ GHC.Num.op_zp__ GHC.Num.op_zt__
*)


Require Import Privilege.
Require Import Env.

Require Import Ctl.Ctl.
Require Import Glib.Glib.

Open Scope string_scope.
Open Scope env_scope.

(* value types *)

Inductive boot_token_t :=
  | good_boot_token
  | bad_boot_token.
Inductive vm_ev_t :=
  | good_vm_ev
  | bad_vm_ev.
Inductive platam_key_t :=
  | good_platam_key
  | encr_platam_key
  | bad_platam_key.
Inductive useram_key_t :=
  | good_useram_key
  | encr_useram_key
  | bad_useram_key.
Inductive useram_key_decr_key_t :=
  | good_decr_key
  | encr_decr_key
  | bad_decr_key.
Inductive attest_req_t :=
  | attest_req.

(* Transition definitions *)

Inductive platam_label :=
  | platam_init
  | platam_meas_release
  | platam_listen
  | platam_deep_attest.

Definition platam_init_env : env :=
  only "platam" ? (
    "platam_key" ↦ encr_platam_key ;;
    "useram_key_decr_key" ↦ encr_decr_key
  ).

Definition decrypt_platam_key key token : platam_key_t :=
  match (key, token) with
  | (encr_platam_key, good_boot_token) => good_platam_key
  | _ => bad_platam_key
  end.

Definition decrypt_useram_key_decr_key decr_key platam_key : useram_key_decr_key_t :=
  match (decr_key, platam_key) with
  | (encr_decr_key, good_platam_key) => good_decr_key
  | _ => bad_decr_key
  end.

Inductive platam_trans : relation (platam_label × env) :=
  | platam_unlock_key : forall Γ Γ' key token,
      read  Γ "platam" "platam_key" key ->
      read  Γ "platam" "boot_token" token ->
      write Γ "platam" "platam_key" (decrypt_platam_key key token) Γ' ->
      platam_trans
        (platam_init, Γ)
        (platam_meas_release, Γ')
  | platam_measure_release : forall Γ Γ' platam_key decr_key,
      read  Γ "platam" "good_os" true ->
      read  Γ "platam" "useram_key_decr_key" decr_key ->
      read  Γ "platam" "platam_key" platam_key ->
      write Γ "platam" "vmm_dataport" (decrypt_useram_key_decr_key decr_key platam_key) Γ' ->
      platam_trans
        (platam_meas_release, Γ)
        (platam_listen, Γ')
  | platam_get_deep_attest_req : forall Γ,
      read Γ "platam" "vmm_dataport" attest_req ->
      platam_trans
        (platam_listen, Γ)
        (platam_deep_attest, Γ)
  | platam_do_deep_attest : forall Γ Γ' (meas: bool),
      read  Γ "platam" "good_os" meas ->
      write Γ "platam" "vmm_dataport" meas Γ' ->
      platam_trans
        (platam_deep_attest, Γ)
        (platam_listen, Γ').

Inductive useram_label :=
  | useram_wait_key
  | useram_listen
  | useram_shallow_attest
  | useram_deep_attest.

Definition useram_init_env : env :=
  only "useram" ? "useram_key" ↦ encr_useram_key.

Definition decrypt_useram_key key decr_key : useram_key_t :=
  match (key, decr_key) with
  | (encr_useram_key, good_decr_key) => good_useram_key
  | _ => bad_useram_key
  end.

Definition shallow_attest (good_os good_target good_meas: bool) :=
  good_os -> good_target -> good_meas.

Inductive useram_trans : relation (useram_label × env) :=
  | useram_get_key : forall Γ Γ' encr_key decr_key,
      read  Γ "useram" "useram_key" encr_key ->
      read  Γ "useram" "vmm_dataport" decr_key ->
      write Γ "useram" "useram_key" (decrypt_useram_key encr_key decr_key) Γ' ->
      useram_trans
        (useram_wait_key, Γ)
        (useram_listen, Γ')
  | useram_get_shallow_req : forall Γ,
      useram_trans
        (useram_listen, Γ)
        (useram_shallow_attest, Γ)
  | useram_do_shallow_attest : forall Γ Γ' os target meas,
      read  Γ "useram" "good_os" os ->
      read  Γ "useram" "good_target" target ->
      shallow_attest os target meas ->
      write Γ "useram" "shallow_attest_result" meas Γ' ->
      useram_trans
        (useram_shallow_attest, Γ)
        (useram_listen, Γ)
  | useram_get_deep_req : forall Γ Γ',
      write Γ "useram" "vmm_dataport" attest_req Γ' ->
      useram_trans
        (useram_listen, Γ)
        (useram_deep_attest, Γ')
  | useram_wait_deep_attest : forall Γ (meas: bool),
      read Γ "useram" "vmm_dataport" meas ->
      useram_trans
        (useram_deep_attest, Γ)
        (useram_listen, Γ).

Inductive malicious_proc_trans : relation env :=
  | corrupt_os : forall Γ Γ',
      write Γ "malicious_proc" "good_os" false Γ' ->
      malicious_proc_trans Γ Γ'
  | corrupt_target : forall Γ Γ',
      write Γ "malicious_proc" "good_target" false Γ' ->
      malicious_proc_trans Γ Γ'
  | leak_key : forall Γ Γ',
      read Γ "malicious_proc" "good_os" false ->
      changeAcc Γ "useram_key" (λ acc, canRead "malicious_proc" ⊔ acc) Γ' ->
      malicious_proc_trans Γ Γ'.

Definition vm_init_env : env :=
  readable ⊔ canWrite "malicious_proc" ? "good_os" ↦ true;;
  useram_init_env.

Inductive vm_label :=
  | vm_run : useram_label -> vm_label.

Inductive vm_trans : relation (vm_label × env) :=
  | useram_step : forall x y Γ Γ',
      useram_trans (x, Γ) (y, Γ') ->
      vm_trans (vm_run x, Γ) (vm_run y, Γ')
  | malicious_proc_step : forall x Γ Γ',
      malicious_proc_trans Γ Γ' ->
      vm_trans (vm_run x, Γ) (vm_run x, Γ').

Inductive attarch_label :=
  | boot
  | sel4_run : platam_label -> vm_label -> attarch_label
  | attarch_bot.

Definition attarch_state := attarch_label × env.

Inductive attarch_trans : relation attarch_state :=
  | boot_good : forall Γ,
      read Γ "root_of_trust" "good_image" true ->
      attarch_trans
        (boot, Γ)
        (sel4_run platam_init (vm_run useram_wait_key),
          readable ? "boot_token" ↦ good_boot_token;;
          platam_init_env;; vm_init_env;; Γ
        )
  | boot_bad : forall Γ,
      read Γ "root_of_trust" "good_image" false ->
      attarch_trans
        (boot, Γ)
        (sel4_run platam_init (vm_run useram_wait_key),
          readable ? "boot_token" ↦ bad_boot_token;;
          platam_init_env;; vm_init_env;; Γ
        )
  | platam_step : forall x l l' Γ Γ',
      platam_trans (l, Γ) (l', Γ') ->
      attarch_trans
        (sel4_run l x, Γ)
        (sel4_run l' x, Γ')
  | vm_step : forall x l l' Γ Γ',
      vm_trans (l, Γ) (l', Γ') ->
      attarch_trans
        (sel4_run x l, Γ)
        (sel4_run x l', Γ')
 | attarch_diverge : forall l Γ,
      attarch_trans (l, Γ) (attarch_bot, Γ).

Definition attarch_good_init_state : attarch_state :=
  (boot, readable ? "good_image" ↦ true).

Definition attarch_bad_init_state : attarch_state :=
  (boot, readable ? "good_image" ↦ false).

(* Definition is_init_attarch_state (s: attarch_state) : Prop :=
  s = attarch_good_init_state \/
  s = attarch_bad_init_state. *)

Definition is_init_state : tprop attarch_state := <[λ s,
  s = attarch_good_init_state \/
  s = attarch_bad_init_state
]>.

Lemma attarch_trans_serial :
  serial_witness attarch_trans.
Proof using.
  follows cbv.
Defined.

Instance transition__attarch_trans : transition attarch_trans :=
  { trans_serial := attarch_trans_serial }.

Ltac _attarch_step_inv H :=
  lazymatch type of H with
  | attarch_trans _ _ => idtac
  | platam_trans _ _ => idtac
  | vm_trans _ _ => idtac
  | malicious_proc_trans _ _ => idtac
  | useram_trans _ _ => idtac
  end;
  invc H;
  try find _attarch_step_inv.
Ltac attarch_step_inv :=
  find _attarch_step_inv.

Close Scope env_scope.
Close Scope string_scope.


(*
 * © 2020 XXX.
 *
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List
     Lia.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     Keys
     Automation
     Tactics
     Simulation
     AdversaryUniverse

     ModelCheck.UniverseEqAutomation
     ModelCheck.ProtocolAutomation
     ModelCheck.SafeProtocol
     ModelCheck.ModelCheck
     ModelCheck.ProtocolFunctions
     ModelCheck.PartialOrderReduction
     ModelCheck.SilentStepElimination
.

From protocols Require Import GenProto.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

From Frap Require Sets.

Module Foo <: Sets.EMPTY.
End Foo.
Module Import SN := Sets.SetNotations(Foo).

Set Implicit Arguments.

Open Scope protocol_scope.

Module MyProtocolSecure <: AutomatedSafeProtocolSS.

  Import MyProtocol.

  (* Some things may need to change here.  t__hon is where we place the
   * type that the protocol computes.  It is set to Nat now, because we
   * return a natual number.
   *)
  Definition t__hon := Nat.
  Definition t__adv := Unit.
  Definition b    := tt.

  (* These two variables hook up the starting points for both specification and
   * implementation universes.  If you followed the template above, this shouldn't
   * need to be changed.
   *)
  Definition iu0  := ideal_univ_start.
  Definition ru0  := real_univ_start.

  Import Gen Tacs SetLemmas.

  (* These are here to help the proof automation.  Don't change. *)
  #[export] Hint Unfold t__hon t__adv b ru0 iu0 ideal_univ_start real_univ_start : core.
  #[export] Hint Unfold
       mkiU mkiUsr mkrU mkrUsr
       mkKeys
    : core.

  Lemma safe_invariant :
    invariantFor
      {| Initial := {(ru0, iu0, true)}; Step := @stepSS t__hon t__adv  |}
      (fun st => safety st /\ alignment st /\ returns_align st).
  Proof.
    autounfold; eapply invariant_weaken.

    - eapply multiStepClosure_ok; simpl.
      (* Calls to gen1 will need to be addded here until the model checking terminates. *)

      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.
      gen1.

    (* The remaining parts of the proof script shouldn't need to change. *)
    - intros.
      simpl in *.

      sets_invert; split_ex
      ; simpl in *; autounfold with core
      ; subst; simpl
      ; unfold safety, alignment, returns_align
      ; ( repeat simple apply conj
          ; [ solve_honest_actions_safe; clean_map_lookups; eauto 8
            | trivial
            | unfold labels_align; intros; rstep; subst; solve_labels_align
            | try solve [ intros; find_step_or_solve ]
        ]).

      Unshelve.
      all: exact 0 || auto.

  Qed.

  Lemma U_good : @universe_starts_sane _ Unit b ru0.
  Proof.
    autounfold;
      unfold universe_starts_sane; simpl.
    repeat (apply conj); intros; eauto.
    - solve_perm_merges; eauto.
    - econstructor.
    - unfold AdversarySafety.keys_honest; rewrite Forall_natmap_forall; intros.
      unfold mkrUsr; simpl.
      rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty; eauto.
    - unfold lameAdv; simpl; eauto.
  Qed.

  Lemma universe_starts_safe : universe_ok ru0.
  Proof.
    pose proof (adversary_is_lame_adv_univ_ok_clauses U_good).

    unfold universe_ok
    ; autounfold
    ; simpl
    ; intuition eauto
    .

    - econstructor; eauto.
    - unfold keys_and_permissions_good; solve_simple_maps; intuition eauto.
      solve_simple_maps; eauto.

      rewrite Forall_natmap_forall; intros.

      solve_simple_maps; simpl
      ; unfold permission_heap_good; intros;
        solve_simple_maps; solve_concrete_maps; eauto.

    - unfold user_cipher_queues_ok.
      rewrite Forall_natmap_forall; intros.
      focus_user
      ; simpl in *; econstructor; eauto.

    - unfold honest_nonces_ok, honest_user_nonces_ok, honest_nonces_ok
      ; repeat simple apply conj
      ; intros
      ; clean_map_lookups
      ; intros
      ; focus_user
      ; try contradiction; try discriminate; simpl;
        repeat (apply conj); intros; clean_map_lookups; eauto.

    - unfold honest_users_only_honest_keys; intros.
      focus_user;
        subst;
        simpl in *;
        clean_map_lookups;
        unfold mkrUsr; simpl;
          rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty;
          eauto;
          simpl in *;
          solve_perm_merges;
          solve_concrete_maps;
          solve_simple_maps;
          eauto.
  Qed.

End MyProtocolSecure.


Require Import Lia.
Require Import RelationClasses.
Require Import Bool.

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

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

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.

Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import FulfillStep.
Require Import MemoryReorder.

Require Import PromiseConsistent.

Set Implicit Arguments.

Lemma reorder_promise_read
      lc0 mem0
      lc1 mem1
      lc2
      loc1 from1 to1 msg1 kind1
      loc2 to2 val2 released2 ord2
      (STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1 mem1 kind1)
      (STEP2: Local.read_step lc1 mem1 loc2 to2 val2 released2 ord2 lc2)
      (LOCAL0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (LOCTS: (loc1, to1) <> (loc2, to2)):
  exists lc1',
    <<STEP1: Local.read_step lc0 mem0 loc2 to2 val2 released2 ord2 lc1'>> /\
    <<STEP2: Local.promise_step lc1' mem0 loc1 from1 to1 msg1 lc2 mem1 kind1>>.
Proof.
  inv STEP1. inv STEP2.
  hexploit MemoryFacts.promise_get_inv_diff; eauto. i. des.
  esplits; eauto.
Qed.

Lemma reorder_promise_promise_lower_None
      lc0 mem0
      lc1 mem1
      lc2 mem2
      loc1 from1 to1 msg1 kind1
      loc2 from2 to2 val2 kind2
      (STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1 mem1 kind1)
      (STEP2: Local.promise_step lc1 mem1 loc2 from2 to2 (Message.full val2 None) lc2 mem2 kind2)
      (LOCAL0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (KIND1: Memory.op_kind_is_cancel kind1 = false)
      (KIND2: Memory.op_kind_is_lower kind2 = true):
  (loc1 = loc2 /\ from1 = from2 /\ to1 = to2 /\ Message.le (Message.full val2 None) msg1 /\ kind2 = Memory.op_kind_lower msg1 /\
   exists kind1', <<STEP: Local.promise_step lc0 mem0 loc1 from1 to1 (Message.full val2 None) lc2 mem2 kind1'>>) \/
  (exists lc1' mem1' from2' kind1',
      <<STEP1: Local.promise_step lc0 mem0 loc2 from2' to2 (Message.full val2 None) lc1' mem1' kind2>> /\
      <<STEP2: Local.promise_step lc1' mem1' loc1 from1 to1 msg1 lc2 mem2 kind1'>>).
Proof.
  inv STEP1. inv STEP2. ss.
  inv PROMISE0; inv KIND2. des. subst.
  inv PROMISE; ss.
  - exploit MemoryReorder.add_lower; try exact PROMISES0; try exact PROMISES; eauto. i. des.
    + subst.
      exploit MemoryReorder.add_lower; try exact MEM1; try exact MEM; eauto. i. des; [|congr].
      left. esplits; ss.
      * inv MEM. inv LOWER. ss.
      * econs; eauto. econs; eauto; congr.
    + exploit MemoryReorder.add_lower; try exact MEM1; try exact MEM; eauto. i. des; [congr|].
      right. esplits; eauto; econs; eauto.
      * econs; eauto.
        { i. subst. exploit RESERVE; eauto. i. des.
          erewrite Memory.lower_o; eauto. condtac; ss; eauto. }
        { i. revert GET.
          erewrite Memory.lower_o; eauto. condtac; ss.
          - i. des. subst. inv GET.
            exploit Memory.lower_get0; try exact MEM. i. des.
            revert GET. erewrite Memory.add_o; eauto. condtac; ss; eauto.
            des. subst. inv MEM. inv LOWER. timetac.
          - i. exploit Memory.lower_get1; try exact GET; eauto. }
      * eapply Memory.lower_closed_message; eauto.
  - des. subst.
    destruct (classic ((loc1, ts3) = (loc2, to2))).
    { inv H.
      exploit MemoryReorder.split_lower_same; try exact PROMISES0; try exact PROMISES; eauto. i. des.
      exploit MemoryReorder.split_lower_same; try exact MEM1; try exact MEM; eauto. i. des.
      subst. right. esplits; eauto; econs; eauto.
      eapply Memory.lower_closed_message; eauto.
    }
    { exploit MemoryReorder.split_lower_diff; try exact PROMISES0; try exact PROMISES; eauto. i. des.
      - subst. inv x3.
        exploit MemoryReorder.split_lower_diff; try exact MEM1; try exact MEM; eauto. i. des; [|congr].
        left. esplits; eauto. inv MEM. inv LOWER. ss.
      - exploit MemoryReorder.split_lower_diff; try exact MEM1; try exact MEM; eauto. i. des; [congr|].
        right. esplits; eauto; econs; eauto.
        eapply Memory.lower_closed_message; eauto.
    }
  - des. subst.
    exploit MemoryReorder.lower_lower; try exact PROMISES0; try exact PROMISES; eauto. i. des.
    + subst.
      exploit MemoryReorder.lower_lower; try exact MEM1; try exact MEM; eauto. i. des; [|congr].
      left. esplits; eauto. inv MEM. inv LOWER. ss.
    + exploit MemoryReorder.lower_lower; try exact MEM1; try exact MEM; eauto. i. des; [congr|].
      right. esplits; eauto; econs; eauto.
      eapply Memory.lower_closed_message; cycle 1; eauto.
Qed.

Lemma reorder_promise_promise_cancel
      lc0 mem0
      lc1 mem1
      lc2 mem2
      loc1 from1 to1 msg1 kind1
      loc2 from2 to2 msg2 kind2
      (STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1 mem1 kind1)
      (STEP2: Local.promise_step lc1 mem1 loc2 from2 to2 msg2 lc2 mem2 kind2)
      (LOCAL0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (KIND1: Memory.op_kind_is_cancel kind1 = false)
      (KIND2: Memory.op_kind_is_cancel kind2 = true):
  (loc1 = loc2 /\ from1 = from2 /\ to1 = to2 /\ msg1 = Message.reserve /\ kind1 = Memory.op_kind_add /\
   lc0 = lc2 /\ mem0 = mem2) \/
  (loc1 = loc2 /\ from1 = from2 /\ to1 = to2 /\ msg1 = Message.reserve /\ kind1 = Memory.op_kind_lower Message.reserve /\
   <<STEP: Local.promise_step lc0 mem0 loc1 from1 to1 Message.reserve lc2 mem2 kind2>>) \/
  (exists lc1' mem1' from2' kind1',
      <<STEP1: Local.promise_step lc0 mem0 loc2 from2' to2 msg2 lc1' mem1' kind2>> /\
      <<STEP2: Local.promise_step lc1' mem1' loc1 from1 to1 msg1 lc2 mem2 kind1'>>).
Proof.
  inv STEP1. inv STEP2. ss. inv PROMISE0; inv KIND2. inv PROMISE; ss.
  - destruct (classic ((loc1, to1) = (loc2, to2))).
    + inv H.
      exploit MemoryReorder.add_remove_same; try exact PROMISES0; eauto. i. des. subst.
      exploit MemoryReorder.add_remove_same; try exact MEM1; eauto. i. des. subst.
      left. splits; auto. destruct lc0; ss.
    + exploit MemoryReorder.add_remove; try exact PROMISES0; eauto. i. des.
      exploit MemoryReorder.add_remove; try exact MEM1; eauto. i. des.
      right. right. esplits; eauto. econs; eauto.
      * econs; eauto.
        { i. subst.
          exploit RESERVE; eauto. i. des.
          exploit Memory.remove_get1; try exact x; eauto. i. des; eauto.
          subst. exploit Memory.remove_get0; try exact REMOVE0; eauto. i. des. congr. }
        { i. revert GET.
          erewrite Memory.remove_o; eauto. condtac; ss. eauto. }
      * eapply Memory.cancel_closed_message; eauto.
  - destruct (classic ((loc1, ts3) = (loc2, to2))).
    + des. subst. inv H.
      exploit MemoryReorder.split_remove_same; try exact PROMISES0; eauto. i. des. subst.
      exploit MemoryReorder.split_remove_same; try exact MEM1; eauto. i. des. subst.
      right. right. esplits; eauto. econs; eauto.
      * econs 1; eauto; ss.
        i. revert GET.
        erewrite Memory.remove_o; eauto. condtac; ss. i. des; ss.
        exploit Memory.split_get0; try exact MEM1. i. des.
        clear GET0 GET2 GET3.
        exploit Memory.get_ts; try exact GET. i. des.
        { subst. inv ADD2. inv ADD. inv TO. }
        exploit Memory.get_ts; try exact GET1. i. des.
        { subst. inv MEM1. inv SPLIT. inv TS23. }
        exploit Memory.get_disjoint; [exact GET|exact GET1|..]. i. des.
        { subst. inv MEM1. inv SPLIT. timetac. }
        destruct (TimeFacts.le_lt_dec to' to2).
        { apply (x4 to'); econs; ss; try refl.
          inv MEM1. inv SPLIT. etrans; eauto. }
        { apply (x4 to2); econs; ss; try refl.
          - inv MEM1. inv SPLIT. ss.
          - econs. ss. }
      * eapply Memory.cancel_closed_message; eauto.
    + destruct (classic ((loc1, to1) = (loc2, to2))).
      { des. inv H0.
        exploit Memory.split_get0; try exact MEM1. i. des.
        exploit Memory.remove_get0; try exact MEM. i. des. congr. }
      exploit MemoryReorder.split_remove; try exact PROMISES0; eauto. i. des.
      exploit MemoryReorder.split_remove; try exact MEM1; eauto. i. des.
      right. right. esplits; eauto. econs; eauto.
      eapply Memory.cancel_closed_message; eauto.
  - des. subst.
    destruct (classic ((loc1, to1) = (loc2, to2))).
    + inv H.
      exploit MemoryReorder.lower_remove_same; try exact PROMISES0; eauto. i. des. subst.
      exploit MemoryReorder.lower_remove_same; try exact MEM1; eauto. i. des. subst.
      exploit Memory.lower_get0; try exact MEM1. i. des. inv MSG_LE.
    + exploit MemoryReorder.lower_remove; try exact PROMISES0; eauto. i. des.
      exploit MemoryReorder.lower_remove; try exact MEM1; eauto. i. des.
      right. right. esplits; eauto. econs; eauto.
      eapply Memory.cancel_closed_message; eauto.
Qed.

Lemma reorder_promise_promise
      lc0 mem0
      lc1 mem1
      lc2 mem2
      loc1 from1 to1 msg1 kind1
      loc2 from2 to2 val2 released2 kind2
      (STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1 mem1 kind1)
      (STEP2: Local.promise_step lc1 mem1 loc2 from2 to2 (Message.full val2 released2) lc2 mem2 kind2)
      (REL_CLOSED: forall promises1' mem1' kind1'
                     (PROMISE1: Memory.promise (Local.promises lc0) mem0 loc2 from2 to2 (Message.full val2 released2) promises1' mem1' kind1'),
          Memory.closed_opt_view released2 mem1')
      (LOCAL0: Local.wf lc0 mem0)
      (CLOSED0: Memory.closed mem0)
      (KIND1: Memory.op_kind_is_cancel kind1 = false)
      (LOCTS1: forall to1' msg1'
                (LOC: loc1 = loc2)
                (KIND: kind1 = Memory.op_kind_split to1' msg1'),
          to1' <> to2 /\
          (forall msg2', kind2 <> Memory.op_kind_split to1' msg2'))
      (LOCTS2: forall val released
                 (LOC: loc1 = loc2)
                 (KIND1: kind1 = Memory.op_kind_add)
                 (KIND2: kind2 = Memory.op_kind_add)
                 (MSG1: msg1 = Message.full val released),
               Time.lt to2 to1):
  exists lc1' mem1' kind2',
    <<STEP1: Local.promise_step lc0 mem0 loc2 from2 to2 (Message.full val2 released2) lc1' mem1' kind2'>> /\
    <<STEP2: __guard__
               ((lc2, mem2, loc1, from1, to1) = (lc1', mem1', loc2, from2, to2) \/
                (exists from1' kind1',
                    (loc1, to1) <> (loc2, to2) /\
                    (forall to1' msg1'
                       (LOC: loc1 = loc2)
                       (KIND: kind1' = Memory.op_kind_split to1' msg1'),
                        to1' <> to2 /\
                        (forall msg2', kind2 <> Memory.op_kind_split to1' msg2')) /\
                    Local.promise_step lc1' mem1' loc1 from1' to1 msg1 lc2 mem2 kind1'))>> /\
    <<KIND2: kind2 = Memory.op_kind_add -> kind2' = Memory.op_kind_add>>.
Proof.
  inv STEP1. inv STEP2. ss.
  inv PROMISE; ss.
  { inv PROMISE0; ss.
    - (* add/add *)
      exploit MemoryReorder.add_add; try exact PROMISES; try exact PROMISES0; eauto. i. des.
      exploit MemoryReorder.add_add; try exact MEM; try exact MEM0; eauto. i. des.
      esplits.
      + cut (Memory.promise (Local.promises lc0) mem0 loc2 from2 to2 (Message.full val2 released2)
                            mem1' mem1'0 Memory.op_kind_add).
        { i. econs; eauto. }
        econs; eauto; try congr.
        i. exploit Memory.add_get1; try exact MEM; eauto.
      + right. esplits; eauto. econs; eauto.
        * econs; eauto.
          { i. subst.
            erewrite Memory.add_o; eauto. condtac; ss; eauto. }
          { i. revert GET.
            erewrite Memory.add_o; eauto. condtac; ss; eauto.
            i. des. inv GET.
            exploit LOCTS2; eauto. intro x.
            inv ADD0. inv ADD. rewrite x in TO. timetac.
          }
        * eapply Memory.add_closed_message; cycle 1; eauto.
      + auto.
    - (* add/split *)
      exploit MemoryReorder.add_split; try exact PROMISES; try exact PROMISES0; eauto. i. des.
      + subst. inv RESERVE0.
        exploit MemoryReorder.add_split; try exact MEM; try exact MEM0; eauto. i. des; [|congr].
        esplits.
        * cut (Memory.promise (Local.promises lc0) mem0 loc2 from2 to2 (Message.full val' released')
                              mem1' mem1'0 Memory.op_kind_add).
          { i. econs; eauto. }
          econs; eauto; try congr.
          i. exploit Memory.add_get1; try exact GET; try exact MEM. i.
          exploit Memory.add_get0; try exact MEM. i. des.
          clear GET GET0.
          exploit Memory.get_ts; try exact x4. i. des.
          { subst. inv ADD0. inv ADD. inv TO. }
          exploit Memory.get_ts; try exact GET1. i. des.
          { subst. inv ADD3. inv ADD. inv TO. }
          exploit Memory.get_disjoint; [exact x4|exact GET1|..]. i. des.
          { subst. inv ADD0. inv ADD. timetac. }
          destruct (TimeFacts.le_lt_dec to' ts3).
          { apply (x7 to'); econs; ss; try refl.
            inv ADD0. inv ADD. etrans; eauto. }
          { apply (x7 ts3); econs; ss; try refl.
            - inv ADD3. inv ADD. ss.
            - econs. ss. }
        * right. esplits; eauto.
          { ii. inv H. inv ADD3. inv ADD. timetac. }
          { econs.
            - econs; eauto.
              + i. subst.
                erewrite Memory.add_o; eauto. condtac; ss; eauto. des; congr.
              + i. revert GET.
                erewrite Memory.add_o; eauto. condtac; ss; eauto. i. des. inv GET.
                inv ADD0. inv ADD. inv ADD3. inv ADD. rewrite TO in TO0. timetac.
            - eapply Memory.split_closed_message; eauto.
            - auto. }
        * auto.
      + inv RESERVE0.
        exploit MemoryReorder.add_split; try exact MEM; try exact MEM0; eauto. i. des; [congr|].
        esplits.
        * econs.
          { econs 2; eauto. }
          { econs. eapply REL_CLOSED. econs 2; eauto. }
          { auto. }
        * right. esplits; eauto.
          { ii. inv H. exploit Memory.split_get0; try exact MEM0; eauto. i. des.
            revert GET. erewrite Memory.add_o; eauto. condtac; ss. des; congr. }
          { econs; eauto.
            - econs; eauto.
              + i. subst.
                erewrite Memory.split_o; eauto. repeat condtac; ss; eauto.
                guardH o. des. subst. exploit RESERVE; eauto. intro x. des.
                exploit Memory.split_get0; try exact SPLIT0. i. des.
                rewrite x in GET0. inv GET0. esplits; eauto.
              + i. revert GET.
                erewrite Memory.split_o; eauto. repeat condtac; ss; eauto.
                * i. des. inv GET.
                  exploit Memory.split_get0; try exact MEM0. i. des.
                  revert GET0. erewrite Memory.add_o; eauto. condtac; ss; eauto.
                  i. des. inv GET0.
                  inv MEM0. inv SPLIT. rewrite TS12 in TS23. timetac.
                * guardH o. i. des. inv GET.
                  exploit Memory.split_get0; try exact SPLIT0. i. des.
                  exploit Memory.add_get0; try exact ADD0. i. des.
                  exploit Memory.add_get1; try exact GET1; eauto. i.
                  clear GET GET0 GET1 GET2 GET3.
                  exploit Memory.get_ts; try exact GET4. i. des.
                  { subst. inv SPLIT0. inv SPLIT. inv TS12. }
                  exploit Memory.get_ts; try exact x0. i. des.
                  { subst. inv ADD0. inv ADD. inv TO. }
                  exploit Memory.get_disjoint; [exact GET4|exact x0|..]. i. des.
                  { subst. exploit Memory.split_get0; try exact SPLIT0. i. des.
                    inv ADD0. inv ADD.
                    hexploit DISJOINT; try eapply GET1. i.
                    apply (H to1); econs; ss; try refl. }
                  apply (x3 to1); econs; ss; try refl.
            - eapply Memory.split_closed_message; eauto. }
        * auto.
    - (* add/lower *)
      des. subst.
      exploit MemoryReorder.add_lower; try exact PROMISES; try exact PROMISES0; eauto. i. des.
      + subst.
        exploit MemoryReorder.add_lower; try exact MEM; try exact MEM0; eauto. i. des; [|congr].
        esplits.
        * econs; eauto. econs; eauto. congr.
        * left. auto.
        * auto.
      + exploit MemoryReorder.add_lower; try exact MEM; try exact MEM0; eauto. i. des; [congr|].
        esplits.
        * econs; eauto.
          econs. eapply REL_CLOSED; eauto.
        * right. esplits; eauto. econs; eauto.
          { econs; eauto.
            - i. subst.
              erewrite Memory.lower_o; eauto. condtac; ss; eauto.
            - i. revert GET.
              erewrite Memory.lower_o; eauto. condtac; ss; eauto.
              i. des. inv GET.
              exploit Memory.lower_get0; try exact LOWER0. i. des. eauto. }
          { eapply Memory.lower_closed_message; eauto. }
        * auto.
  }
  { des. subst. inv PROMISE0; ss.
    - (* split/add *)
      exploit MemoryReorder.split_add; try exact PROMISES; try exact PROMISES0; eauto. i. des.
      exploit MemoryReorder.split_add; try exact MEM; try exact MEM0; eauto. i. des.
      esplits.
      + cut (Memory.promise (Local.promises lc0) mem0 loc2 from2 to2 (Message.full val2 released2)
                            mem1' mem1'0 Memory.op_kind_add).
        { i. econs; eauto. }
        econs; eauto; try congr.
        i. exploit Memory.split_get1; try exact GET; eauto. i. des.
        dup GET2. revert GET2.
        erewrite Memory.split_o; eauto. repeat condtac; ss.
        * i. des. inv GET2.
          exploit Memory.split_get0; try exact MEM. i. des.
          rewrite GET in *. ss.
        * guardH o. i. des. inv GET2.
          exploit Memory.split_get0; try exact MEM. i. des.
          rewrite GET in *. inv GET2. eauto.
        * i. rewrite GET in *. inv GET2. eauto.
      + right. esplits; eauto. econs; eauto.
        eapply Memory.add_closed_message; eauto.
      + auto.
    - (* split/split *)
      des. inv RESERVE.
      exploit MemoryReorder.split_split; try exact PROMISES; try exact PROMISES0; eauto.
      { ii. inv H. eapply LOCTS1; eauto. }
      i. des.
      + subst. exploit MemoryReorder.split_split; try exact MEM; try exact MEM0; eauto.
        { ii. inv H. inv SPLIT2. inv SPLIT. timetac. }
        i. des; [|congr].
        esplits.
        * econs.
          { econs 2; eauto. }
          { econs. eapply REL_CLOSED. econs 2; eauto. }
          { auto. }
        * right. esplits; eauto.
          { ii. inv H. inv SPLIT2. inv SPLIT. timetac. }
          { econs; eauto.
            eapply Memory.split_closed_message; cycle 1; eauto. }
        * congr.
      + exploit MemoryReorder.split_split; try exact MEM; try exact MEM0; eauto.
        { ii. inv H. eapply LOCTS1; eauto. }
        i. des; [congr|].
        esplits.
        * econs.
          { econs 2; eauto. }
          { econs. eapply REL_CLOSED. econs 2; eauto. }
          { auto. }
        * right. esplits; eauto.
          { ii. inv H. exploit Memory.split_get0; try exact MEM1; eauto. i. des.
            revert GET. erewrite Memory.split_o; eauto. repeat condtac; ss.
            guardH o0. des; congr. }
          { econs; eauto.
            eapply Memory.split_closed_message; cycle 1; eauto. }
        * auto.
    - (* split/lower *)
      des. subst.
      exploit MemoryReorder.split_lower_diff; try exact PROMISES; try exact PROMISES0; eauto.
      { ii. inv H. exploit LOCTS1; eauto. i. des. congr. }
      i. des.
      + subst. inv x3.
        exploit MemoryReorder.split_lower_diff; try exact MEM; try exact MEM0; eauto.
        { ii. inv H. exploit LOCTS1; eauto. i. des. congr. }
        i. des; [|congr].
        esplits.
        * econs.
          { econs 2; eauto. }
          { econs. eapply REL_CLOSED. econs 2; eauto. }
          { auto. }
        * left. auto.
        * congr.
      + subst. exploit MemoryReorder.split_lower_diff; try exact MEM; try exact MEM0; eauto.
        { ii. inv H. exploit LOCTS1; eauto. i. des. congr. }
        i. des; [congr|].
        esplits.
        * econs; eauto. econs; eauto.
        * right. esplits; eauto. econs; eauto.
          eapply Memory.lower_closed_message; eauto.
        * congr.
  }
  { des. subst. inv PROMISE0; ss.
    - (* lower/add *)
      exploit MemoryReorder.lower_add; try exact PROMISES; try exact PROMISES0; eauto. i. des.
      exploit MemoryReorder.lower_add; try exact MEM; try exact MEM0; eauto. i. des.
      esplits.
      + cut (Memory.promise (Local.promises lc0) mem0 loc2 from2 to2 (Message.full val2 released2)
                            mem1' mem1'0 Memory.op_kind_add).
        { i. econs; eauto. }
        econs; eauto; try congr.
        i. exploit Memory.lower_get1; try exact GET; eauto. i. des. eauto.
      + right. esplits; eauto. econs; eauto.
        eapply Memory.add_closed_message; eauto.
      + auto.
    - (* lower/split *)
      des. inv RESERVE.
      exploit MemoryReorder.lower_split; try exact PROMISES; try exact PROMISES0; eauto. i. des.
      exploit MemoryReorder.lower_split; try exact MEM; try exact MEM0; eauto. i. des.
      unguardH FROM1. des.
      + inv FROM1. unguardH FROM0. des; [|congr]. inv FROM0.
        esplits.
        * econs.
          { econs 2; eauto. }
          { econs. eapply REL_CLOSED. econs 2; eauto. }
          { auto. }
        * right. esplits; eauto.
          { ii. inv H. inv SPLIT1. inv SPLIT. timetac. }
          { econs; eauto. eapply Memory.split_closed_message; eauto. }
        * congr.
      + inv FROM2. unguardH FROM0. des; [congr|]. inv FROM2.
        esplits.
        * econs.
          { econs 2; eauto. }
          { econs. eapply REL_CLOSED. econs 2; eauto. }
          { auto. }
        * right. esplits; eauto.
          { ii. inv H. exploit Memory.lower_get0; try exact MEM; eauto.
            exploit Memory.split_get0; try exact SPLIT0; eauto. i. des. congr. }
          { econs; eauto. eapply Memory.split_closed_message; eauto. }
        * auto.
    - (* lower/lower *)
      des. subst.
      exploit MemoryReorder.lower_lower; try exact PROMISES; try exact PROMISES0; eauto. i. des.
      + subst.
        exploit MemoryReorder.lower_lower; try exact MEM; try exact MEM0; eauto. i. des; [|congr].
        esplits.
        * econs; eauto.
        * left. auto.
        * congr.
      + exploit MemoryReorder.lower_lower; try exact MEM; try exact MEM0; eauto. i. des; [congr|].
        esplits.
        * econs; eauto. econs; eauto.
        * right. esplits; eauto. econs; eauto.
          eapply Memory.lower_closed_message; cycle 1; eauto.
        * auto.
  }
Qed.

Lemma reorder_promise_fulfill
      lc0 sc0 mem0
      lc1 mem1
      lc2 sc2
      loc1 from1 to1 msg1 kind1
      loc2 from2 to2 val2 releasedm2 released2 ord2
      (STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1 mem1 kind1)
      (STEP2: fulfill_step lc1 sc0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc2 sc2)
      (LOCAL0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (LOCTS1: (loc1, to1) <> (loc2, to2))
      (LOCTS2: forall to1' msg1'
                 (LOC: loc1 = loc2)
                 (KIND: kind1 = Memory.op_kind_split to1' msg1'),
          to1' <> to2):
  exists lc1',
    <<STEP1: fulfill_step lc0 sc0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc1' sc2>> /\
    <<STEP2: Local.promise_step lc1' mem0 loc1 from1 to1 msg1 lc2 mem1 kind1>>.
Proof.
  inv STEP1. inv STEP2. ss.
  inv PROMISE; ss.
  - exploit MemoryReorder.add_remove; try exact REMOVE; eauto. i. des.
    esplits.
    + econs; eauto.
    + econs; ss. econs; ss.
  - exploit MemoryReorder.split_remove; try exact PROMISES; try exact REMOVE; eauto.
    { ii. inv H. eapply LOCTS2; eauto. }
    i. des.
    esplits.
    + econs; eauto.
    + econs; ss. econs; ss. eauto.
  - des. subst.
    exploit MemoryReorder.lower_remove; try exact REMOVE; eauto. i. des.
    esplits.
    + econs; eauto.
    + econs; ss. econs; eauto.
  - exploit MemoryReorder.remove_remove; try exact PROMISES; eauto. i. des.
    esplits.
    + econs; eauto.
    + econs; ss. econs; ss.
Qed.

Lemma promise_step_nonsynch_loc_inv
      lc1 mem1 loc from to msg lc2 mem2 kind l
      (WF1: Local.wf lc1 mem1)
      (STEP: Local.promise_step lc1 mem1 loc from to msg lc2 mem2 kind)
      (NONPF: Memory.op_kind_is_lower_full kind = false \/ ~ Message.is_released_none msg)
      (NONSYNCH: Memory.nonsynch_loc l (Local.promises lc2)):
  Memory.nonsynch_loc l (Local.promises lc1).
Proof.
  guardH NONPF.
  ii.
  inv STEP. inv PROMISE; ss.
  - exploit Memory.add_get1; try exact GET; eauto. i. des.
    exploit NONSYNCH; eauto.
  - exploit Memory.split_get1; try exact GET; eauto. i. des.
    exploit NONSYNCH; eauto.
  - exploit Memory.lower_o; try exact PROMISES; eauto.
    instantiate (1 := t). instantiate (1 := l). condtac; ss.
    + i. des. subst. exploit NONSYNCH; eauto.
      destruct msg; destruct msg0; ss.
      * i. subst. unguard. des; ss.
      * exploit Memory.lower_get0; try exact PROMISES. i. des.
        rewrite GET in GET0. inv GET0.
        inv MEM. inv LOWER. inv MSG_LE0.
    + rewrite GET. i. exploit NONSYNCH; eauto.
  - exploit Memory.remove_get1; try exact GET; eauto. i. des.
    + subst. exploit Memory.remove_get0; try exact PROMISES. i. des.
      rewrite GET0 in GET. inv GET. ss.
    + exploit NONSYNCH; eauto.
Qed.

Lemma reorder_promise_write
      lc0 sc0 mem0
      lc1 mem1
      lc2 sc2 mem2
      loc1 from1 to1 msg1 kind1
      loc2 from2 to2 val2 releasedm2 released2 ord2 kind2
      (STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1 mem1 kind1)
      (STEP2: Local.write_step lc1 sc0 mem1 loc2 from2 to2 val2 releasedm2 released2 ord2 lc2 sc2 mem2 kind2)
      (NONPF: Memory.op_kind_is_lower_full kind1 = false \/ ~ Message.is_released_none msg1)
      (REL_WF: View.opt_wf releasedm2)
      (REL_CLOSED: Memory.closed_opt_view releasedm2 mem0)
      (LOCAL0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (KIND1: Memory.op_kind_is_cancel kind1 = false)
      (LOCTS1: forall to1' msg1'
                (LOC: loc1 = loc2)
                (KIND: kind1 = Memory.op_kind_split to1' msg1'),
          to1' <> to2 /\
          (forall msg2', kind2 <> Memory.op_kind_split to1' msg2'))
      (LOCTS2: forall val released
                 (LOC: loc1 = loc2)
                 (KIND1: kind1 = Memory.op_kind_add)
                 (KIND2: kind2 = Memory.op_kind_add)
                 (MSG1: msg1 = Message.full val released),
               Time.lt to2 to1):
  exists kind2' lc1' mem1',
    <<STEP1: Local.write_step lc0 sc0 mem0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc1' sc2 mem1' kind2'>> /\
    <<STEP2: __guard__
               ((lc2, mem2, loc1, from1, to1) = (lc1', mem1', loc2, from2, to2) \/
                ((loc1, to1) <> (loc2, to2) /\
                 exists from1' kind1', <<STEP2: Local.promise_step lc1' mem1' loc1 from1' to1 msg1 lc2 mem2 kind1'>>))>> /\
    <<KIND2: kind2 = Memory.op_kind_add -> kind2' = Memory.op_kind_add>>.
Proof.
  guardH NONPF.
  exploit Local.promise_step_future; eauto. i. des.
  exploit write_promise_fulfill; eauto; try by viewtac. i. des.
  exploit reorder_promise_promise; try exact STEP1; eauto.
  { i. subst.
    exploit Memory.promise_op; eauto. i.
    eapply TViewFacts.op_closed_released; try exact x0; eauto.
    inv STEP1. apply LOCAL0.
  }
  i. des.
  unguardH STEP5. des.
  - inv STEP5.
    exploit promise_fulfill_write_exact; try exact STEP4; eauto.
    { i. hexploit ORD; eauto. i.
      eapply promise_step_nonsynch_loc_inv; try exact STEP1; eauto.
    }
    { inv STEP1. ss. }
    i. esplits; eauto. left; eauto.
  - exploit Local.promise_step_future; try exact STEP4; eauto. i. des.
    exploit reorder_promise_fulfill; try exact STEP6; eauto.
    { i. eapply STEP6; eauto. }
    i. des.
    exploit fulfill_step_future; try exact STEP7; try exact WF0; eauto; try by viewtac. i. des.
    exploit promise_fulfill_write_exact; try exact STEP4; eauto; try by viewtac.
    { i. hexploit ORD; eauto. i.
      eapply promise_step_nonsynch_loc_inv; try exact STEP1; eauto.
    }
    { subst. inv STEP1. ss. }
    i. esplits; eauto. right. esplits; eauto.
Qed.

Lemma reorder_promise_write'
      lc0 sc0 mem0
      lc1 mem1
      lc2 sc2 mem2
      loc1 from1 to1 msg1 kind1
      loc2 from2 to2 val2 releasedm2 released2 ord2 kind2
      (STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 msg1 lc1 mem1 kind1)
      (STEP2: Local.write_step lc1 sc0 mem1 loc2 from2 to2 val2 releasedm2 released2 ord2 lc2 sc2 mem2 kind2)
      (NONPF: Memory.op_kind_is_lower_full kind1 = false \/ ~ Message.is_released_none msg1)
      (REL_WF: View.opt_wf releasedm2)
      (REL_CLOSED: Memory.closed_opt_view releasedm2 mem0)
      (LOCAL0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (KIND1: Memory.op_kind_is_cancel kind1 = false):
  (loc1 = loc2 /\ Time.lt to1 to2) \/
  (exists kind2' lc1' mem1',
     <<STEP1: Local.write_step lc0 sc0 mem0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc1' sc2 mem1' kind2'>> /\
     <<STEP2: __guard__
                ((lc2, mem2, loc1, from1, to1) = (lc1', mem1', loc2, from2, to2) \/
                 ((loc1, to1) <> (loc2, to2) /\
                  exists from1' kind1', <<STEP2: Local.promise_step lc1' mem1' loc1 from1' to1 msg1 lc2 mem2 kind1'>>))>> /\
     <<KIND2: kind2 = Memory.op_kind_add -> kind2' = Memory.op_kind_add>>).
Proof.
  guardH NONPF.
  destruct (classic (loc1 = loc2 /\ Time.lt to1 to2)); auto.
  right. eapply reorder_promise_write; eauto. i. subst. splits.
  - ii. subst. apply H. splits; auto.
    inv STEP1. inv PROMISE. inv MEM. inv SPLIT. auto.
  - ii. subst. apply H. splits; auto.
    inv STEP2. inv WRITE. inv PROMISE. exploit Memory.split_get0; eauto. i. des.
    inv STEP1. inv PROMISE. revert GET0. erewrite Memory.split_o; eauto. repeat condtac; ss.
    + i. des. inv GET0. inv MEM1. inv SPLIT. timetac.
    + guardH o. i. des. inv GET0. inv MEM. inv SPLIT. auto.
    + guardH o. des; congr.
  - i. subst. destruct (TimeFacts.le_lt_dec to2 to1); cycle 1.
    { exfalso. apply H; eauto. }
    inv l; ss. inv H0. exfalso.
    inv STEP1. inv PROMISE. inv STEP2. inv WRITE. inv PROMISE. ss.
    exploit Memory.add_get0; try exact MEM. i. des.
    exploit Memory.add_get0; try exact MEM1. i. des. congr.
Qed.

#[export]
Hint Constructors Thread.program_step: core.
#[export]
Hint Constructors Thread.step: core.

Lemma reorder_nonpf_program
      lang
      e1 e2 th0 th1 th2
      (STEP1: @Thread.step lang false e1 th0 th1)
      (STEP2: Thread.program_step e2 th1 th2)
      (CONS2: Local.promise_consistent (Thread.local th2))
      (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
      (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
      (MEMORY: Memory.closed (Thread.memory th0)):
  exists th1',
     <<STEP1: Thread.program_step e2 th0 th1'>> /\
     <<STEP2: __guard__ (th2 = th1' \/ exists pf2' e2', Thread.promise_step pf2' e2' th1' th2)>>.
Proof.
  exploit Thread.step_future; eauto. i. des.
  inv STEP1. inv STEP. ss. inv STEP2. inv LOCAL1; ss.
  - (* silent *)
    esplits; eauto.
    right. esplits. econs; eauto.
  - (* read *)
    exploit reorder_promise_read; try exact LOCAL0; eauto; try by viewtac.
    { ii. inv H.
      inv LOCAL0. exploit Memory.promise_get2; eauto.
      { destruct kind, msg; ss. }
      i. des.
      dup LOCAL2. inv LOCAL0. ss.
      rewrite GET in *. inv GET_MEM.
      hexploit promise_consistent_promise_read; eauto. i. timetac.
    }
    i. des. esplits.
    + econs; eauto.
    + right. esplits. econs; eauto.
  - (* write *)
    exploit reorder_promise_write; try exact LOCAL0; eauto; try by viewtac.
    { destruct kind, msg; ss; eauto. repeat condtac; ss; eauto. }
    { destruct kind, msg; ss. }
    { i. subst. split.
      - ii. subst. ss. inv LOCAL0.
        exploit Memory.promise_get2; eauto. i. des.
        inv PROMISE. des. subst.
        exploit promise_consistent_promise_write; eauto. i.
        inv MEM. inv SPLIT. timetac.
      - ii. subst. ss. inv LOCAL0.
        exploit Memory.promise_get2; eauto. i. des.
        inv PROMISE. des. subst.
        exploit promise_consistent_promise_write; eauto. i.
        exploit Memory.split_get0; try exact PROMISES. i. des.
        inv LOCAL2. ss. inv WRITE. inv PROMISE. des.
        exploit Memory.split_get0; try exact PROMISES0. i. des.
        rewrite GET2 in *. inv GET4.
        inv MEM0. inv SPLIT. timetac. }
    { i. subst. inv LOCAL0. inv PROMISE.
      exploit Memory.add_get0; try exact PROMISES. i. des.
      exploit promise_consistent_promise_write; try exact GET0; eauto. i.
      inv x0; ss. inv H.
      inv LOCAL2. inv WRITE. inv PROMISE. ss.
      exploit Memory.add_get0; try exact MEM. i. des.
      exploit Memory.add_get0; try exact MEM0. i. des. congr. }
    i. des.
    esplits.
    + econs; eauto.
    + unguardH STEP2. des.
      * inv STEP2. left. auto.
      * right. esplits. econs; eauto.
  - (* update *)
    exploit reorder_promise_read; try exact LOCAL1; eauto; try by viewtac.
    { ii. inv H.
      inv LOCAL0. exploit Memory.promise_get2; eauto.
      { destruct kind, msg; ss. }
      i. des.
      dup LOCAL2. inv LOCAL0. ss.
      rewrite GET in *. inv GET_MEM.
      exploit promise_consistent_promise_read; eauto.
      { eapply write_step_promise_consistent; eauto. }
      i. eapply Time.lt_strorder. eauto.
    }
    i. des.
    exploit Local.read_step_future; eauto. i. des.
    exploit reorder_promise_write; try exact LOCAL2; eauto; try by viewtac.
    { destruct kind, msg; ss; eauto. repeat condtac; ss; eauto. }
    { destruct kind, msg; ss. }
    { i. subst. split.
      - ii. subst. ss. inv STEP2.
        exploit Memory.promise_get2; eauto. i. des.
        inv PROMISE. des. subst.
        exploit promise_consistent_promise_write; eauto. i.
        inv MEM. inv SPLIT. timetac.
      - ii. subst. ss. inv STEP2.
        exploit Memory.promise_get2; eauto. i. des.
        inv PROMISE. des. subst.
        exploit promise_consistent_promise_write; eauto. i.
        exploit Memory.split_get0; try exact PROMISES. i. des.
        inv LOCAL3. ss. inv WRITE. inv PROMISE. des.
        exploit Memory.split_get0; try exact PROMISES0. i. des.
        rewrite GET2 in *. inv GET4.
        inv MEM0. inv SPLIT. timetac. }
    { i. subst. inv LOCAL0. inv PROMISE.
      inv LOCAL2. ss.
      exploit Memory.add_get0; try exact PROMISES. i. des.
      exploit promise_consistent_promise_write; try exact GET1; eauto. i.
      inv x0; ss. inv H.
      inv LOCAL3. inv WRITE. inv PROMISE. ss.
      exploit Memory.add_get0; try exact MEM. i. des.
      exploit Memory.add_get0; try exact MEM0. i. des. congr. }
    i. des.
    esplits.
    + econs; eauto.
    + unguardH STEP3. des.
      * inv STEP3. left. auto.
      * right. esplits. econs; eauto.
  - inv LOCAL0. inv LOCAL2.
    esplits; eauto.
    + econs; eauto. econs 5; eauto. econs; eauto. ss.
      intros ORDW l. eapply promise_step_nonsynch_loc_inv; eauto.
      * destruct msg, kind; ss; eauto. repeat condtac; ss; eauto.
      * apply RELEASE. ss.
    + right. esplits. econs; eauto.
  - inv LOCAL0. inv LOCAL2.
    esplits; eauto.
    + econs; eauto. econs 6; eauto. econs; eauto.
      intros ORDW l. eapply promise_step_nonsynch_loc_inv; eauto.
      * destruct msg, kind; ss; eauto. repeat condtac; ss; eauto.
      * apply RELEASE. ss.
    + right. esplits. econs; eauto.
  - inv LOCAL2.
    hexploit promise_step_promise_consistent; eauto. i.
    esplits; eauto.
    right. esplits. econs; eauto.
Qed.

Lemma reorder_nonpf_pf
      lang
      e1 e2 th0 th1 th2
      (STEP1: @Thread.step lang false e1 th0 th1)
      (STEP2: Thread.step true e2 th1 th2)
      (CONS2: Local.promise_consistent (Thread.local th2))
      (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
      (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
      (MEMORY: Memory.closed (Thread.memory th0)):
  (th0 = th2) \/
  (exists pf2' e2',
      <<STEP: Thread.step pf2' e2' th0 th2>> /\
      <<EVENT: __guard__ (e2' = e2 \/ (ThreadEvent.is_promising e2' /\ ThreadEvent.is_promising e2))>>) \/
  (exists e2' pf1' e1' th1',
      <<STEP1: Thread.step true e2' th0 th1'>> /\
      <<STEP2: Thread.promise_step pf1' e1' th1' th2>> /\
      <<EVENT: __guard__ (e2' = e2 \/ (ThreadEvent.is_promising e2' /\ ThreadEvent.is_promising e2))>>).
Proof.
  inv STEP2; ss.
  - inv STEP. ss.
    inv STEP1. inv STEP. ss.
    destruct kind; ss.
    + destruct msg1, msg; ss. destruct released0; ss.
      exploit reorder_promise_promise_lower_None; eauto.
      { destruct kind0; ss. }
      i. des; subst.
      * right. left. esplits.
        { econs 1. econs; eauto. }
        { right. ss. }
      * right. right. esplits.
        { econs 1. econs; eauto. }
        { econs; eauto. }
        { right. ss. }
    + exploit reorder_promise_promise_cancel; eauto.
      { destruct kind0; ss. }
      i. des; subst; eauto.
      * right. left. esplits.
        { econs 1. econs; eauto. }
        { right. ss. }
      * right. right. esplits.
        { econs 1. econs; eauto. }
        { econs; eauto. }
        { right. ss. }
  - exploit reorder_nonpf_program; eauto. i. des.
    unguardH STEP2. des.
    + subst. right. left. esplits; eauto. left. ss.
    + right. right. esplits; eauto. left. ss.
Qed.


Require Import SegmentQueue.lib.thread_queue.thread_queue.
From SegmentQueue.lib.concurrent_linked_list.infinite_array
     Require Import array_spec iterator.iterator_impl.
Require Import SegmentQueue.lib.util.future.
Require Import SegmentQueue.lib.util.forRange.
From iris.heap_lang Require Import notation.

Section impl.

Variable array_interface: infiniteArrayInterface.
Variable limit: positive.

Definition newBarrier: val :=
  λ: <>, (ref #0, newThreadQueue array_interface #()).

Definition barrierResume: val :=
  λ: "d", resume array_interface #(Z.of_nat 300) #true #false #false "d"
                 (λ: <>, #()) #().

Definition arrive : val :=
  λ: "barrier",
  let: "counter" := Fst "barrier" in
  let: "e" := Fst (Snd "barrier") in
  let: "d" := Snd (Snd "barrier") in
  let: "p" := FAA "counter" #1
  in if: "p" = #(Pos.to_nat limit-1)
     then forRange "p" (λ: <>, barrierResume "d") ;; fillThreadQueueFuture #()
     else match: suspend array_interface "e" with
            InjR "v" => "v"
          | InjL "x" => "undefined"
          end.

Definition cancelBarrierFuture : val :=
  λ: "barrier" "f",
  let: "counter" := Fst "barrier" in
  let: "onCancellation" :=
     rec: "loop" <> :=
       let: "c" := !"counter" in
       if: "c" = #(Pos.to_nat limit) then #false
       else if: CAS "counter" "c" ("c" - #1) then #true
            else "loop" #()
  in
  let: "d" := Snd (Snd "barrier") in
  tryCancelThreadQueueFuture' array_interface
                              #false #(Z.of_nat 300) #false #false
                              "d" "onCancellation"
                              (λ: <>, #()) (λ: <>, #()) "f".

End impl.

From SegmentQueue.util Require Import everything big_opL local_updates.
From iris.base_logic.lib Require Import invariants.
From iris.algebra Require Import numbers auth list gset excl csum.
From iris.program_logic Require Import atomic.
From iris.heap_lang Require Import proofmode.

Section proof.

Notation algebra := (authR (prodUR natUR
                                   (optionUR (csumR positiveR positiveR)))).

Class barrierG Σ := BarrierG { barrier_inG :> inG Σ algebra }.
Definition barrierΣ : gFunctors := #[GFunctor algebra].
Instance subG_barrierΣ {Σ} : subG barrierΣ Σ -> barrierG Σ.
Proof. solve_inG. Qed.

Context `{heapG Σ} `{iteratorG Σ} `{threadQueueG Σ} `{futureG Σ} `{barrierG Σ}.
Variable (limit: positive).
Variable (N NFuture: namespace).
Variable (HNDisj: N ## NFuture).
Let NBar := N .@ "Barrier".
Let NTq := N .@ "Tq".
Notation iProp := (iProp Σ).

Definition barrier_entry_piece γ := own γ (◯ (ε, Some (Cinl 1%positive))).
Definition barrier_exit_piece γ := own γ (◯ (ε, Some (Cinr 1%positive))).
Definition barrier_inhabitant_permit γ := own γ (◯ (1, ε)).

Definition barrier_inv (γb γtq: gname) (ℓ: loc) (n: nat): iProp :=
  (⌜n < Pos.to_nat limit⌝ ∧ own γb (● (n, Some (Cinl limit))) ∨
   ⌜n = Pos.to_nat limit⌝ ∧ own γb (● (n, Some (Cinr limit))))
  ∗ ℓ ↦ #n ∗ [∗] replicate (n `mod` Pos.to_nat limit) (barrier_entry_piece γb)
  ∗ thread_queue_state γtq (n `mod` Pos.to_nat limit).

Variable array_interface: infiniteArrayInterface.
Variable array_spec: infiniteArraySpec _ array_interface.

Let tqParams γb :=
  @ThreadQueueParameters Σ false True (barrier_exit_piece γb) True
                         (fun v => ⌜#v = #()⌝)%I False.

Let isThreadQueue γb := is_thread_queue NTq NFuture (tqParams γb) _ array_spec.

Definition is_barrier_future γb :=
  is_thread_queue_future NTq NFuture (tqParams γb) _ array_spec.

Definition is_barrier γb γa γtq γe γd (s: val): iProp :=
  ∃ e d (p: loc), ⌜s = (#p, (e, d))%V⌝ ∧
  inv NBar (∃ n, barrier_inv γb γtq p n)
  ∗ isThreadQueue γb γa γtq γe γd e d.

Theorem newBarrier_spec:
  {{{ inv_heap_inv }}}
    newBarrier array_interface #()
  {{{ γb γa γtq γe γd s, RET s; is_barrier γb γa γtq γe γd s
    ∗ [∗] replicate (Pos.to_nat limit) (barrier_entry_piece γb) }}}.
Proof.
  iIntros (Φ) "#HHeap HΦ".
  iMod (own_alloc (● (0, Some (Cinl limit)) ⋅ ◯ (0, Some (Cinl limit))))
    as (γb) "[H● H◯]"; first by apply auth_both_valid.
  wp_lam. wp_bind (newThreadQueue _ _).
  iApply (newThreadQueue_spec with "HHeap").
  iIntros (γa γtq γe γd e d) "!> [#HTq HThreadState]".
  rewrite -wp_fupd. wp_alloc p as "Hp". wp_pures.
  iMod (inv_alloc NBar _ (∃ n, barrier_inv γb γtq p n) with "[-HΦ H◯]")
    as "#HInv".
  { iExists 0. iFrame "Hp". rewrite Nat.mod_0_l; last lia. simpl.
    iFrame "HThreadState". iLeft. iFrame. iPureIntro. lia. }
  iApply "HΦ". iSplitR.
  { iExists _, _, _. iSplitR; first done. by iFrame "HInv HTq". }
  rewrite big_opL_replicate_irrelevant_element -big_opL_own.
  2: { destruct (Pos.to_nat limit) eqn:E. lia. done. }
  remember (Pos.to_nat limit) as NLim.
  replace limit with (Pos.of_nat NLim) by (subst; apply Pos2Nat.id).
  assert (NLim > 0)%nat as HGt by (subst; lia). move: HGt. clear.
  intros HGt.
  iInduction (NLim) as [|NLim] "IH"; first lia.
  simpl.
  inversion HGt; subst; first by iFrame.
  replace (Pos.of_nat (S NLim)) with (1 + Pos.of_nat NLim)%positive;
    last by rewrite Nat2Pos.inj_succ; lia.
  rewrite Cinl_op Some_op pair_op_2 auth_frag_op own_op.
  move: (big_opL_op_prodR 0)=> /= HBigOpL.
  rewrite -big_opL_auth_frag !HBigOpL !big_opL_op_ucmra_unit.
  rewrite own_op. iDestruct "H◯" as "[$ HFrag]".
  iApply ("IH" with "[//] HFrag").
Qed.

Lemma resumeBarrier_spec R maxWait (wait: bool) γa γtq γe γd e d:
  {{{ isThreadQueue R γa γtq γe γd e d ∗ awakening_permit γtq }}}
    resume array_interface #(Z.of_nat maxWait) #true #false #wait d (λ: <>, #())%V #()
  {{{ RET #true; True }}}.
Proof.
  iIntros (Φ) "[#HTq HAwak] HΦ".
  iApply (resume_spec with "[] [HAwak]").
  5: { by iFrame "HTq HAwak". }
  by solve_ndisj. done. done.
  { simpl. iIntros (Ψ) "!> _ HΨ". wp_pures. by iApply "HΨ". }
  iIntros "!>" (r) "Hr". simpl. destruct r; first by iApply "HΦ".
  iDestruct "Hr" as "[% _]"; lia.
Qed.

Lemma arrive_spec γb γa γtq γe γd s:
  {{{ is_barrier γb γa γtq γe γd s ∗ barrier_entry_piece γb }}}
    arrive array_interface limit s
  {{{ γf v, RET v; is_barrier_future γb γtq γa γf v ∗
                   thread_queue_future_cancellation_permit γf ∗
                   barrier_inhabitant_permit γb }}}.
Proof.
  iIntros (Φ) "[#HBarrier HEntry] HΦ". wp_lam.
  iDestruct "HBarrier" as (e d p ->) "[HInv HTq]". wp_pures.
  wp_bind (FAA _ _).
  iInv "HInv" as (n) "(>[[% H●]|[-> HContra]] & Hℓ & HEntries & HState)".
  2: {
    iDestruct (own_valid_2 with "HContra HEntry") as
        %[[_ HInc]%prod_included _]%auth_both_valid. exfalso.
    move: HInc=> /=. rewrite Some_included. case.
    + intros HContra. inversion HContra.
    + rewrite csum_included. case; first done.
      case; by intros (? & ? & ? & ? & ?).
  }
  iCombine "HEntry" "HEntries" as "HEntries".
  rewrite Nat.mod_small; last lia.
  destruct (decide (n = Pos.to_nat limit - 1)) as [->|HLt].
  - wp_faa.
    iAssert ([∗] replicate (Pos.to_nat limit) (barrier_entry_piece γb))%I
            with "[HEntries]" as "HEntries".
    { iEval (replace (Pos.to_nat limit) with (1 + (Pos.to_nat limit - 1))
              by lia). iFrame. }
    iAssert (own γb (◯ (0, Some (Cinl limit)))) with "[HEntries]" as "H◯".
    {
      clear. remember (Pos.to_nat limit) as limN.
      replace limit with (Pos.of_nat limN) by (subst; apply Pos2Nat.id).
      assert (limN > 0)%nat as HNonZero by lia. clear HeqlimN.
      iInduction limN as [|limN'] "IH" forall (HNonZero); simpl in *. lia.
      inversion HNonZero.
      - by iDestruct "HEntries" as "[$ _]".
      - replace (S limN') with (1 + limN') by lia.
        rewrite Nat2Pos.inj_add; try lia.
        rewrite Cinl_op Some_op pair_op_2 auth_frag_op own_op.
        iDestruct "HEntries" as "[$ HEntries]".
        iApply ("IH" with "[%] HEntries"). lia.
    }
    iMod (own_update_2 with "H● H◯") as "H●".
    apply auth_update_dealloc, prod_local_update_2, ucmra_cancel_local_update, _.
    iAssert (|==> own γb (● (Pos.to_nat limit, Some (Cinr limit))) ∗
                  own γb (◯ (1, ε)) ∗ own γb (◯ (ε, Some (Cinr limit))))%I
            with "[H●]" as ">(H● & HInhabit & H◯)".
    {
      iMod (own_update with "H●") as "($ & $ & $)"; last done.
      apply auth_update_alloc, prod_local_update'=>/=.
      - apply nat_local_update. simpl. rewrite Nat.add_1_r Nat.add_0_r. lia.
      - by apply (alloc_option_local_update (Cinr limit)).
    }
    iAssert ([∗] replicate (Pos.to_nat limit) (barrier_exit_piece γb))%I
      with "[H◯]" as "HExit".
    {
      clear. remember (Pos.to_nat limit) as NLim.
      replace limit with (Pos.of_nat NLim) by (subst; apply Pos2Nat.id).
      assert (NLim > 0)%nat as HGt by (subst; lia). move: HGt. clear.
      intros HGt.
      iInduction (NLim) as [|NLim] "IH"; first lia.
      simpl.
      inversion HGt; first by iFrame. simplify_eq.
      replace (Pos.of_nat (S NLim)) with (1 + Pos.of_nat NLim)%positive;
        last by rewrite Nat2Pos.inj_succ; lia.
      rewrite Cinr_op Some_op pair_op_2 auth_frag_op own_op.
      iDestruct "H◯" as "[$ HFrag]". iApply ("IH" with "[//] HFrag").
    }
    remember (Pos.to_nat limit - 1)%nat as sleepers.
    replace (Pos.to_nat limit) with (S sleepers) by lia.
    simpl. iDestruct "HExit" as "[HMyExit HWakers]".
    iAssert (|={⊤ ∖ ↑NBar}=> thread_queue_state γtq 0 ∗
            [∗] replicate sleepers (awakening_permit γtq))%I
      with "[HState HWakers]" as ">[HState HAwaks]".
    {
      clear. iInduction (sleepers) as [|sleepers] "IH"=>/=. by iFrame.
      iDestruct "HWakers" as "[HWaker HWakers]".
      iMod (thread_queue_register_for_dequeue' with
                "HTq [$] [$]") as "[HState $]". by solve_ndisj.
      lia. rewrite /= Nat.sub_0_r.
      iApply ("IH" with "HState HWakers").
    }
    iSplitR "HΦ HAwaks HMyExit HInhabit".
    { iExists (S sleepers). rewrite /barrier_inv. subst. iSplitL "H●".
      { iRight; iFrame. iPureIntro; lia. }
      rewrite Z.add_1_r -Nat2Z.inj_succ.
      replace (S (_ - _)) with (Pos.to_nat limit) by lia.
      rewrite Nat.mod_same; last lia. simpl. iFrame "HState". done. }
    iModIntro. wp_pures.
    rewrite bool_decide_true; last by congr (fun x => LitV (LitInt x)); lia.
    wp_pures.
    wp_apply (forRange_resource_map
                (fun _ => awakening_permit γtq) (fun _ => True)%I
             with "[] [HAwaks]").
    + iIntros (i Ψ) "!> HAwak HΨ". wp_pures. wp_lam.
      wp_apply (resumeBarrier_spec with "[$]"). iIntros (_).
      by iApply "HΨ".
    + by rewrite -big_sepL_replicate seq_length.
    + iIntros (?) "_". wp_pures.
      iApply (fillThreadQueueFuture_spec with "[HMyExit]").
      2: { iIntros "!>" (γf v') "(H1 & H2 & _)". iApply "HΦ".
           iFrame "HInhabit H1 H2". }
      rewrite /V'. simpl. iExists _. iFrame. by iPureIntro.
  - iMod (thread_queue_append' with "HTq [] HState")
      as "[HState HSus]"=> /=; [by solve_ndisj|done|].
    iAssert (|==> own γb (● (S n, Some (Cinl limit))) ∗
                  own γb (◯ (1, ε)))%I with "[H●]" as ">[H● HInhabit]".
    { iMod (own_update with "H●") as "[$ $]"; last done.
      apply auth_update_alloc, prod_local_update_1, nat_local_update.
      rewrite Nat.add_0_r. lia. }
    wp_faa. iSplitR "HΦ HSus HInhabit".
    { iExists (S n). iModIntro. iSplitL "H●".
      + iLeft. iFrame. iPureIntro. lia.
      + rewrite Nat.mod_small; last lia. iFrame.
        by replace (n + 1)%Z with (Z.of_nat (S n)) by lia. }
    iModIntro. wp_pures. rewrite bool_decide_false; last by case; lia.
    wp_pures. wp_apply (suspend_spec with "[$]")=>/=.
    iIntros (v) "[(_ & _ & %)|Hv]"; first done.
    iDestruct "Hv" as (γf v' ->) "[HFuture HCancPermit]".
    wp_pures. iApply "HΦ". iFrame.
Qed.

Theorem cancelBarrierFuture_spec γb γa γtq γe γd s γf f:
  is_barrier γb γa γtq γe γd s -∗
  is_barrier_future γb γtq γa γf f -∗
  <<< ▷ thread_queue_future_cancellation_permit γf ∗
      barrier_inhabitant_permit γb >>>
    cancelBarrierFuture array_interface limit s f @ ⊤ ∖ ↑NFuture ∖ ↑N
  <<< ∃ (r: bool),
      if r then future_is_cancelled γf
      else (∃ v, ▷ future_is_completed γf v) ∗
           thread_queue_future_cancellation_permit γf ∗
           barrier_inhabitant_permit γb, RET #r >>>.
Proof.
  iIntros "#HIsBar #HFuture" (Φ) "AU".
  iDestruct "HIsBar" as (e d p ->) "[HInv HTq]". wp_lam. wp_pures. wp_lam.
  wp_pures. awp_apply (try_cancel_thread_queue_future with "HTq HFuture");
              first by solve_ndisj.
  iApply (aacc_aupd_commit with "AU"). by solve_ndisj.
  iIntros "[HCancPermit HInhabit]". iAaccIntro with "HCancPermit".
  by iIntros "$ !>"; iFrame; iIntros "$ !>".
  iIntros (r) "Hr". iExists r. destruct r.
  2: { iDestruct "Hr" as "[$ $]". iFrame. iIntros "!> HΦ !>". by wp_pures. }
  iDestruct "Hr" as "[#HFutureCancelled Hr]". iFrame "HFutureCancelled".
  rewrite /is_barrier_future /is_thread_queue_future.
  iDestruct "Hr" as (i f' s ->) "Hr"=> /=.
  iDestruct "Hr" as "(#H↦~ & #HTh & HToken)". iIntros "!> HΦ !>". wp_pures.
  wp_lam. wp_pures. wp_apply derefCellPointer_spec.
  by iDestruct "HTq" as "(_ & $ & _)". iIntros (ℓ) "#H↦". wp_pures.
  iLöb as "IHCancAllowed".
  wp_bind (!_)%E.
  iInv "HInv" as (n) "(>[[% H●]|[-> H●]] & Hℓ & HEntries & HState)" "HClose".
  2: {
    wp_load. rewrite Nat.mod_same; last lia.
    iMod (register_cancellation with "HTq HToken HState")
        as "[HCancToken HState]"; first by solve_ndisj.
    iDestruct "HState" as "(HState & HR & #HInhabited)".
    iMod ("HClose" with "[-HΦ HCancToken HR]") as "_".
    { iExists (Pos.to_nat limit). iSplitL "H●".
      - iRight. by iFrame.
      - rewrite Nat.mod_same; last lia. iFrame. }
    iModIntro. wp_pures. rewrite bool_decide_true; last done. wp_pures.
    wp_bind (getAndSet.getAndSet _ _).
    awp_apply (markRefused_spec with "HTq HInhabited H↦ HCancToken HTh [//]")
              without "HΦ HR".
    iAaccIntro with "[//]"; first done. iIntros (v) "Hv"=>/=.
    iIntros "!> [HΦ HR]". iDestruct "Hv" as "[[-> _]|Hv]"; first by wp_pures.
    iDestruct "Hv" as (? ->) "[_ >%]". simplify_eq. wp_pures.
    iApply "HΦ". (* we are losing the exit barrier piece here. *)
  }
  wp_load.
  iMod ("HClose" with "[-HΦ HToken HInhabit]") as "_".
  { iExists _. iSplitL "H●"; first by iLeft; iFrame. iFrame. }
  iModIntro. wp_pures. rewrite bool_decide_false; last by case; lia.
  wp_pures. wp_bind (CmpXchg _ _ _).
  iInv "HInv" as (n') "(>[[% H●]|[-> H●]] & Hℓ & HEntries & >HState)" "HClose".
  2: {
    wp_cmpxchg_fail. by case; lia.
    iMod ("HClose" with "[-HΦ HToken HInhabit]") as "_".
    { iExists _. iSplitL "H●"; first by iRight; iFrame. iFrame. }
    iModIntro. wp_pures. by iApply ("IHCancAllowed" with "HInhabit HToken HΦ").
  }
  destruct (decide (n = n')) as [<-|HNe].
  2: {
    wp_cmpxchg_fail; first by intro HContra; simplify_eq.
    iMod ("HClose" with "[-HΦ HToken HInhabit]") as "_".
    { iExists _. iSplitL "H●"; first by iLeft; iFrame. iFrame. }
    iModIntro. wp_pures. by iApply ("IHCancAllowed" with "HInhabit HToken HΦ").
  }
  iAssert (⌜(n > 0)%nat⌝)%I with "[-]" as %HN'Gt.
  { iDestruct (own_valid_2 with "H● HInhabit") as
        %[[HOk%nat_included _]%prod_included _]%auth_both_valid.
    iPureIntro; simpl in *; lia. }
  iMod (register_cancellation with "HTq HToken HState")
       as "[HCancToken HState]"; first by solve_ndisj.
  rewrite bool_decide_false Nat.mod_small; try lia. wp_cmpxchg_suc.
  iDestruct "HState" as "(HState & HCancHandle & #HInhabited)".
  iMod (own_update_2 with "H● HInhabit") as "H●".
  { apply auth_update_dealloc, prod_local_update_1.
    apply (nat_local_update _ _ (n - 1)).
    rewrite Nat.add_0_r Nat.add_1_r. lia. }
  destruct n as [|n']; first lia.
  iDestruct "HEntries" as "[HEntry HEntries]".
  iMod ("HClose" with "[-HΦ HCancToken HCancHandle HEntry]") as "_".
  {
    rewrite Nat.sub_1_r=>/=.
    iExists n'. iSplitL "H●". by iLeft; iFrame; iPureIntro; lia.
    rewrite Nat.mod_small; last lia. iFrame.
    by rewrite Z.sub_1_r -Nat2Z.inj_pred/=.
  }
  iModIntro. wp_pures. wp_bind (getAndSet.getAndSet _ _).
  awp_apply (markCancelled_spec with "HTq HInhabited H↦ HCancToken HTh")
            without "HΦ HCancHandle HEntry".
  iAaccIntro with "[//]"; first done. iIntros (v) "Hv"=>/=.
  iIntros "!> (HΦ & HCancHandle & HEntry)". wp_pures.
  iAssert (▷ cell_cancellation_handle _ _ _ _ _ _)%I
          with "[HCancHandle]" as "HCancHandle"; first done.
  awp_apply (onCancelledCell_spec with "[] H↦~") without "Hv HΦ".
  by iDestruct "HTq" as "(_ & $ & _)".
  iAaccIntro with "HCancHandle". by iIntros "$".
  iIntros "#HCancelled !> [Hv HΦ]". wp_pures.
  iDestruct "Hv" as "[[-> _]|Hv]"; first by wp_pures.
  iDestruct "Hv" as (x ->) "(#HInhabited' & HAwak & %)"; simplify_eq.
  wp_pures. wp_apply (resumeBarrier_spec with "[$]").
  iIntros "_". wp_pures. iApply "HΦ".
  (* we are losing the entry barrier piece, but it's not a big deal since the *)
  (* API does not provide a way to learn whether the cancellation succeeded *)
  (* before or after a thread arrived to resume everything. *)
Qed.

End proof.


(* Partial translation From MetaCoqCoq to ITT *)

From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.
From MetaCoq
Require Import Ast utils monad_utils Typing Checker AstUtils uGraph.
From Translation
Require Import util Sorts SAst SLiftSubst SCommon ITyping Quotes
               FinalTranslation.
Import MonadNotation.
Import ListNotations.

Inductive assocn (A : Type) :=
| emptyn
| aconsn (key : string) (n : nat) (data : A) (t : assocn A).

Arguments emptyn {_}.
Arguments aconsn {_} _ _ _.

Fixpoint assocn_at {A} (key : string) (n : nat) (t : assocn A) {struct t}
  : option A :=
  match t with
  | emptyn => None
  | aconsn k m a r =>
    if (ident_eq key k) && (n =? m) then Some a else assocn_at key n r
  end.

Inductive fq_error :=
| NotEnoughFuel
| NotHandled (t : term)
| TypingError (msg : string) (e : type_error) (Γ : context) (t : term)
| WrongType (wanted : string) (got : term)
| UnknownInductive (id : string)
| UnknownConst (id : string)
| UnknownConstruct (id : string) (n : nat)
.

Inductive fq_result A :=
| Success : A -> fq_result A
| Error : fq_error -> fq_result A.

Arguments Success {_} _.
Arguments Error {_} _.

Instance fq_monad : Monad fq_result :=
  {| ret A a := Success a ;
     bind A B m f :=
       match m with
       | Success a => f a
       | Error e => Error e
       end
  |}.

Instance monad_exc : MonadExc fq_error fq_result :=
  { raise A e := Error e;
    catch A m f :=
      match m with
      | Success a => m
      | Error t => f t
      end
  }.

Close Scope s_scope.

Local Existing Instance Sorts.type_in_type.

Open Scope string_scope.

Existing Instance default_fuel.

Fixpoint fullquote (fuel : nat) (Σ : global_env) (G : universes_graph)
  (Γ : context) (t : term) (indt : assoc sterm) (constt : assoc sterm)
  (cot : assocn sterm) {struct fuel}
  : fq_result sterm :=
  match fuel with
  | 0 => raise NotEnoughFuel
  | S fuel =>
    match t with
    | tRel n => ret (sRel n)
    | tSort _ => ret (sSort tt)
    | tProd nx A B =>
      A' <- fullquote fuel Σ G Γ A indt constt cot ;;
      B' <- fullquote fuel Σ G (Γ ,, vass nx A) B indt constt cot ;;
      ret (sProd nx A' B')
    | tLambda nx A t =>
      match infer_hnf Σ G (Γ ,, vass nx A) t with
      | Checked B =>
        A' <- fullquote fuel Σ G Γ A indt constt cot ;;
        B' <- fullquote fuel Σ G (Γ ,, vass nx A) B indt constt cot ;;
        t' <- fullquote fuel Σ G (Γ ,, vass nx A) t indt constt cot ;;
        ret (sLambda nx A' B' t')
      | TypeError e => raise (TypingError "Lambda" e (Γ ,, vass nx A) t)
      end
    | tApp (tConst "Translation.Quotes.candidate" []) [ _ ; _ ; t ] =>
      fullquote fuel Σ G Γ t indt constt cot
    | tInd {| inductive_mind := id ; inductive_ind := _ |} [] =>
      match assoc_at id indt with
      | Some t => ret t
      | None => raise (UnknownInductive id)
      end
    | tConst id [] =>
      match assoc_at id constt with
      | Some t => ret t
      | None => raise (UnknownConst id)
      end
    | tConstruct {| inductive_mind := id ; inductive_ind := _ |} n [] =>
      match assocn_at id n cot with
      | Some t => ret t
      | None => raise (UnknownConstruct id n)
      end
    | tApp (tInd {| inductive_mind := "Coq.Init.Logic.eq"; inductive_ind := 0 |} []) [ A ; u ; v ] =>
      A' <- fullquote fuel Σ G Γ A indt constt cot ;;
      u' <- fullquote fuel Σ G Γ u indt constt cot ;;
      v' <- fullquote fuel Σ G Γ v indt constt cot ;;
      ret (sEq A' u' v')
    | tApp u [] =>
      fullquote fuel Σ G Γ u indt constt cot
    | tApp u [ v ] =>
      match infer_hnf Σ G Γ u with
      | Checked (tProd nx A B) =>
        u' <- fullquote fuel Σ G Γ u indt constt cot ;;
        A' <- fullquote fuel Σ G Γ A indt constt cot ;;
        B' <- fullquote fuel Σ G (Γ ,, vass nx A) B indt constt cot ;;
        v' <- fullquote fuel Σ G Γ v indt constt cot ;;
        ret (sApp u' A' B' v')
      | Checked T => raise (WrongType "Prod" T)
      | TypeError e => raise (TypingError "App1" e Γ u)
      end
    | tApp u (v :: l) =>
      fullquote fuel Σ G Γ (tApp (tApp u [ v ]) l) indt constt cot
    | tCast t _ _ => fullquote fuel Σ G Γ t indt constt cot
    | _ => raise (NotHandled t)
    end
  end.


Require Import os_code_defs.
Require Import code_notations.
Require Import os_ucos_h.

(*os_mutex.c*)

Open Scope code_scope.

Definition OSMutexAccept_impl :=
 Int8u ·OSMutexAccept·(⌞pevent @ OS_EVENT∗⌟)··{
        ⌞
          legal @ Int8u;
          pip @ Int8u
        ⌟;

          If(pevent′ ==ₑ NULL){
              RETURN ′0
          };ₛ
          ENTER_CRITICAL;ₛ
          legal′ =ᶠ OS_EventSearch(·pevent′·);ₛ
          If (legal′ ==ₑ ′0){
              EXIT_CRITICAL;ₛ
              RETURN ′0
          };ₛ
          If (pevent′→OSEventType !=ₑ ′OS_EVENT_TYPE_MUTEX){
            EXIT_CRITICAL;ₛ
            RETURN ′0
          };ₛ
          pip′  =ₑ 〈Int8u〉(pevent′→OSEventCnt ≫ ′8);ₛ
          If ((OSTCBCur′→OSTCBPrio <ₑ pip′) ||ₑ (OSTCBCur′→OSTCBPrio ==ₑ pip′)){
            EXIT_CRITICAL;ₛ
            RETURN ′0
          };ₛ
          If ((pevent′→OSEventCnt &ₑ ′OS_MUTEX_KEEP_LOWER_8) ==ₑ ′OS_MUTEX_AVAILABLE){
            pevent′→OSEventCnt =ₑ pevent′→OSEventCnt &ₑ ′OS_MUTEX_KEEP_UPPER_8;ₛ
            pevent′→OSEventCnt =ₑ pevent′→OSEventCnt |ₑ OSTCBCur′→OSTCBPrio;ₛ
            pevent′→OSEventPtr =ₑ OSTCBCur′;ₛ
            EXIT_CRITICAL;ₛ
            RETURN ′1
          };ₛ
          EXIT_CRITICAL;ₛ
          RETURN ′0
}· .

Definition PlaceHolder:= &ₐ OSPlaceHolder′.

Definition OSMutexCreate_impl :=
OS_EVENT∗ ·OSMutexCreate·(⌞prio @ Int8u⌟)··{
           ⌞pevent @ OS_EVENT∗⌟;

            If (prio′ ≥ ′OS_LOWEST_PRIO) {
                RETURN 〈OS_EVENT ∗〉 NULL
            };ₛ
            ENTER_CRITICAL;ₛ
            If (OSTCBPrioTbl′[prio′] !=ₑ NULL) {
                EXIT_CRITICAL;ₛ
                RETURN 〈OS_EVENT ∗〉 NULL
            };ₛ
            pevent′ =ₑ OSEventFreeList′;ₛ
            If (OSEventFreeList′ !=ₑ NULL){
                OSEventFreeList′ =ₑ  〈OS_EVENT∗〉 OSEventFreeList′→OSEventListPtr
            };ₛ
            IF (pevent′ !=ₑ NULL){
                OS_EventWaitListInit(pevent′);ₛ
                pevent′→OSEventType =ₑ ′OS_EVENT_TYPE_MUTEX;ₛ
                pevent′→OSEventCnt  =ₑ ((〈Int16u〉prio′) ≪ ′8) |ₑ ′OS_MUTEX_AVAILABLE;ₛ
                pevent′→OSEventPtr  =ₑ NULL;ₛ
                pevent ′ → OSEventListPtr =ₑ OSEventList ′;ₛ
                OSTCBPrioTbl′[prio′] =ₑ 〈OS_TCB ∗〉 PlaceHolder;ₛ
                OSEventList′ =ₑ pevent′;ₛ
                EXIT_CRITICAL;ₛ
                RETURN pevent′
            }ELSE{
                EXIT_CRITICAL;ₛ
                RETURN 〈OS_EVENT ∗〉 NULL
            }
 }·.

Definition OSMutexDel_impl :=
 Int8u ·OSMutexDel·(⌞ pevent @ OS_EVENT ∗⌟)··{
        ⌞
         tasks_waiting @ Int8u;
         pip @ Int8u;
         legal @ Int8u
        ⌟;

        If (pevent′ ==ₑ  NULL){
             RETURN ′OS_ERR_PEVENT_NULL
        };ₛ
        ENTER_CRITICAL;ₛ
        legal′ =ᶠ OS_EventSearch(·pevent′·);ₛ
        If (legal′ ==ₑ ′0){
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_PEVENT_NO_EX
        };ₛ
        If (pevent′→OSEventType !=ₑ ′OS_EVENT_TYPE_MUTEX){
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_EVENT_TYPE
        };ₛ
        IF (pevent′→OSEventGrp !=ₑ ′0   ||ₑ ( ( pevent′→OSEventCnt &ₑ ′OS_MUTEX_KEEP_LOWER_8  )!=ₑ  ′OS_MUTEX_AVAILABLE)){
            tasks_waiting′ =ₑ ′1
        }ELSE{
            tasks_waiting′ =ₑ ′0
        };ₛ
        IF (tasks_waiting′ ==ₑ ′0){
            pip′ =ₑ 〈Int8u〉 (pevent′→OSEventCnt ≫ ′8);ₛ
            If ( OSTCBPrioTbl′[pip′]  !=ₑ 〈OS_TCB ∗〉 PlaceHolder){
                EXIT_CRITICAL;ₛ
                RETURN ′OS_ERR_MUTEXPR_NOT_HOLDER
            };ₛ
            OS_EventRemove(pevent′);ₛ
            OSTCBPrioTbl′[pip′] =ₑ NULL;ₛ
            pevent′→OSEventType =ₑ ′OS_EVENT_TYPE_UNUSED;ₛ
            pevent′→OSEventListPtr =ₑ OSEventFreeList′;ₛ
            pevent′→OSEventCnt =ₑ ′0;ₛ
            OSEventFreeList′ =ₑ pevent′;ₛ
            EXIT_CRITICAL;ₛ
            RETURN ′OS_NO_ERR
        }ELSE{
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_TASK_WAITING
        }
 }· .

Require Import ZArith.

Definition OSMutexPend_impl :=
 Int8u ·OSMutexPend·(⌞ pevent @ OS_EVENT ∗; timeout @ Int16u ⌟)··{
         ⌞
           legal @ Int8u;
           pip @ Int8u;
           mprio @ Int8u;
           isrdy @ Int8u;
           ptcb @ (Tptr OS_TCB);
           pevent2 @ (Tptr OS_EVENT)
        ⌟;

        If (pevent′ ==ₑ  NULL){
             RETURN ′OS_ERR_PEVENT_NULL
        };ₛ
        ENTER_CRITICAL;ₛ
        legal′ =ᶠ OS_EventSearch(·pevent′·);ₛ
        If (legal′ ==ₑ ′0){
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_PEVENT_NO_EX
        };ₛ
        If (pevent′→OSEventType !=ₑ ′OS_EVENT_TYPE_MUTEX){
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_EVENT_TYPE
        };ₛ
        If (OSTCBCur′→OSTCBPrio ==ₑ ′OS_IDLE_PRIO){
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_IDLE
        };ₛ
        If ( (OSTCBCur′→OSTCBStat !=ₑ ′OS_STAT_RDY) ||ₑ (OSTCBCur′→OSTCBDly !=ₑ ′0)){
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_STAT
        };ₛ
        If (OSTCBCur′→OSTCBMsg !=ₑ NULL) {
            EXIT_CRITICAL;ₛ
            RETURN  ′OS_ERR_PEVENT_NULL
        };ₛ

        pip′  =ₑ 〈Int8u〉(pevent′→OSEventCnt ≫ ′8);ₛ
        If (OSTCBCur′→OSTCBPrio <ₑ pip′ ||ₑ (OSTCBCur′→OSTCBPrio ==ₑ pip′)){
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_MUTEX_PRIO
        };ₛ
        mprio′ =ₑ 〈Int8u〉(pevent′→OSEventCnt &ₑ ′OS_MUTEX_KEEP_LOWER_8);ₛ
        ptcb′  =ₑ pevent′→OSEventPtr;ₛ

        If (mprio′ ==ₑ ′OS_MUTEX_AVAILABLE) {
            pevent′→OSEventCnt =ₑ pevent′→OSEventCnt &ₑ ′OS_MUTEX_KEEP_UPPER_8;ₛ
            pevent′→OSEventCnt =ₑ pevent′→OSEventCnt |ₑ OSTCBCur′→OSTCBPrio;ₛ
            pevent′→OSEventPtr =ₑ OSTCBCur′;ₛ
            EXIT_CRITICAL;ₛ
            RETURN ′OS_NO_ERR
        };ₛ

        If(ptcb′ ==ₑ OSTCBCur′){
          EXIT_CRITICAL;ₛ
          RETURN ′OS_ERR_MUTEX_DEADLOCK
        };ₛ
        If(ptcb′→OSTCBPrio ==ₑ ′OS_IDLE_PRIO){
          EXIT_CRITICAL;ₛ
          RETURN ′OS_ERR_MUTEX_IDLE
        };ₛ
        If ( (ptcb′→OSTCBStat !=ₑ ′OS_STAT_RDY) ||ₑ (ptcb′→OSTCBDly !=ₑ ′0)){
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_NEST
        };ₛ
        If(mprio′ ==ₑ (OSTCBCur′→OSTCBPrio)){
          EXIT_CRITICAL;ₛ
          RETURN ′OS_ERR_MUTEX_DEADLOCK
        };ₛ

        IF ((ptcb′→OSTCBPrio !=ₑ pip′) &&ₑ (mprio′ >ₑ (OSTCBCur′→OSTCBPrio))){  (*Need to promote prio of owner?*)
            If ( OSTCBPrioTbl′[pip′]  !=ₑ 〈OS_TCB ∗〉 PlaceHolder){
                EXIT_CRITICAL;ₛ
                RETURN ′OS_ERR_MUTEXPR_NOT_HOLDER
            };ₛ

            OSTCBPrioTbl′[ ptcb′→OSTCBPrio ] =ₑ 〈OS_TCB ∗〉 PlaceHolder;ₛ
            OSTCBPrioTbl′[pip′] =ₑ 〈OS_TCB ∗〉 ptcb′;ₛ

                OSRdyTbl′[ptcb′→OSTCBY] =ₑ OSRdyTbl′[ptcb′→OSTCBY]&ₑ(∼ptcb′→OSTCBBitX);ₛ
                If (OSRdyTbl′[ptcb′→OSTCBY] ==ₑ ′0)
                {
                    OSRdyGrp′ =ₑ OSRdyGrp′ &ₑ (∼ptcb′→OSTCBBitY)
                };ₛ
                ptcb′→OSTCBPrio =ₑ pip′;ₛ                             (* Change owner task prio to PIP            *)
                ptcb′→OSTCBY    =ₑ ptcb′→OSTCBPrio ≫ ′3;ₛ
                ptcb′→OSTCBBitY =ₑ OSMapTbl′[ptcb′→OSTCBY];ₛ
                ptcb′→OSTCBX    =ₑ (ptcb′→OSTCBPrio) &ₑ ′7;ₛ
                ptcb′→OSTCBBitX =ₑ OSMapTbl′[ptcb′→OSTCBX];ₛ
                OSRdyGrp′ =ₑ OSRdyGrp′ |ₑ ptcb′→OSTCBBitY;ₛ     (* ... make it ready at new priority.       *)
                OSRdyTbl′[ptcb′→OSTCBY] =ₑ OSRdyTbl′[ptcb′→OSTCBY] |ₑ ptcb′→OSTCBBitX;ₛ

                OSTCBCur′→OSTCBStat =ₑ ′OS_STAT_MUTEX;ₛ
                OSTCBCur′→OSTCBDly =ₑ timeout′;ₛ
                OS_EventTaskWait(pevent′);ₛ
                EXIT_CRITICAL;ₛ
                OS_Sched();ₛ
                ENTER_CRITICAL;ₛ
                If (OSTCBCur′→OSTCBMsg !=ₑ NULL){
                   EXIT_CRITICAL;ₛ
                   RETURN ′OS_NO_ERR
                };ₛ
                EXIT_CRITICAL;ₛ
                RETURN ′OS_TIMEOUT

        } ELSE {
          OSTCBCur′→OSTCBStat =ₑ ′OS_STAT_MUTEX;ₛ
          OSTCBCur′→OSTCBDly =ₑ timeout′;ₛ
          OS_EventTaskWait(pevent′);ₛ
          EXIT_CRITICAL;ₛ
          OS_Sched();ₛ
          ENTER_CRITICAL;ₛ
          If (OSTCBCur′→OSTCBMsg !=ₑ NULL){
              EXIT_CRITICAL;ₛ
              RETURN ′OS_NO_ERR
          };ₛ
          EXIT_CRITICAL;ₛ
          RETURN ′OS_TIMEOUT
        }

}· .

Definition OSMutexPost_impl :=
 Int8u ·OSMutexPost·(⌞pevent @ OS_EVENT∗ ⌟)··{
        ⌞
         x @ Int8u;
         pip @ Int8u;
         prio  @ Int8u;
         legal @ Int8u
        ⌟;

        If (pevent′ ==ₑ NULL){
           RETURN ′OS_ERR_PEVENT_NULL
        };ₛ
        ENTER_CRITICAL;ₛ
        legal′ =ᶠ OS_EventSearch(·pevent′·);ₛ
        If (legal′ ==ₑ ′0){
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_PEVENT_NO_EX
           };ₛ
        If (pevent′→OSEventType !=ₑ ′OS_EVENT_TYPE_MUTEX){
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_EVENT_TYPE
        };ₛ

        pip′  =ₑ 〈Int8u〉(pevent′→OSEventCnt ≫ ′8);ₛ
        prio′ =ₑ 〈Int8u〉(pevent′→OSEventCnt &ₑ ′OS_MUTEX_KEEP_LOWER_8);ₛ
        If (OSTCBCur′ !=ₑ pevent′→OSEventPtr) {   (* See if posting task owns the MUTEX*)
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_NOT_MUTEX_OWNER
        };ₛ
        If (OSTCBCur′→OSTCBPrio <ₑ pip′){         (**)
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_MUTEX_PRIO
        };ₛ
        legal′ =ₑ OSUnMapTbl′[pevent′→OSEventGrp];ₛ
        x′ =ₑ (legal′≪ ′3) +ₑ OSUnMapTbl′[pevent′→OSEventTbl[legal′]];ₛ
        If ( pevent′→OSEventGrp !=ₑ ′0 &&ₑ (x′ <ₑ pip′ ||ₑ  x′ ==ₑ pip′)){
            EXIT_CRITICAL;ₛ
            RETURN ′OS_ERR_MUTEX_WL_HIGHEST_PRIO
        };ₛ
        If(OSTCBCur ′ → OSTCBStat !=ₑ ′OS_STAT_RDY ||ₑ OSTCBCur ′ → OSTCBDly !=ₑ ′0){
                EXIT_CRITICAL;ₛ
                RETURN ′OS_ERR_ORIGINAL_NOT_HOLDER
        };ₛ
        If (OSTCBCur′→OSTCBPrio ==ₑ pip′) {
          (* Did we have to raise current task's priority? *)
          (* Yes, Return to original priority              *)
          (*      Remove owner from ready list at 'pip'    *)
            If ( OSTCBPrioTbl′[prio′]  !=ₑ 〈OS_TCB ∗〉 PlaceHolder){
                EXIT_CRITICAL;ₛ
                RETURN ′OS_ERR_ORIGINAL_NOT_HOLDER
               };ₛ

            OSRdyTbl′[OSTCBCur′→OSTCBY] =ₑ OSRdyTbl′[OSTCBCur′→OSTCBY] &ₑ (∼OSTCBCur′→OSTCBBitX);ₛ
            If ( OSRdyTbl′[OSTCBCur′→OSTCBY] ==ₑ ′0) {
                OSRdyGrp′ =ₑ OSRdyGrp′ &ₑ ∼OSTCBCur′→OSTCBBitY
            };ₛ
            OSTCBCur′→OSTCBPrio         =ₑ prio′;ₛ
            OSTCBCur′→OSTCBY            =ₑ prio′ ≫  ′3;ₛ
            OSTCBCur′→OSTCBBitY         =ₑ OSMapTbl′[OSTCBCur′→OSTCBY];ₛ
            OSTCBCur′→OSTCBX            =ₑ prio′ &ₑ ′7;ₛ
            OSTCBCur′→OSTCBBitX         =ₑ OSMapTbl′[OSTCBCur′→OSTCBX];ₛ
            OSRdyGrp′                    =ₑ OSRdyGrp′ |ₑ OSTCBCur′→OSTCBBitY;ₛ
            OSRdyTbl′[OSTCBCur′→OSTCBY] =ₑ OSRdyTbl′[OSTCBCur′→OSTCBY] |ₑ OSTCBCur′→OSTCBBitX;ₛ
            OSTCBPrioTbl′[prio′]         =ₑ 〈OS_TCB ∗〉 OSTCBCur′;ₛ
            OSTCBPrioTbl′[pip′]          =ₑ 〈OS_TCB ∗〉 PlaceHolder
        };ₛ
        If (pevent′→OSEventGrp !=ₑ ′0) {
            x′ =ₑ ′OS_STAT_MUTEX;ₛ
            prio′ =ᶠ OS_EventTaskRdy(·pevent′, 〈Void ∗〉 pevent′, x′·);ₛ
            pevent′→OSEventCnt =ₑ pevent′→OSEventCnt &ₑ ′OS_MUTEX_KEEP_UPPER_8;ₛ  (*Save priority of mutex's new owner *)
            pevent′→OSEventCnt =ₑ pevent′→OSEventCnt |ₑ prio′;ₛ
            pevent′→OSEventPtr =ₑ OSTCBPrioTbl′[prio′];ₛ     (*Link to mutex owner's OS_TCB*)

            EXIT_CRITICAL;ₛ
            OS_Sched();ₛ
            RETURN ′OS_NO_ERR
        };ₛ
        pevent′→OSEventCnt =ₑ pevent′→OSEventCnt |ₑ ′OS_MUTEX_AVAILABLE;ₛ (* No,  Mutex is now available   *)
        pevent′→OSEventPtr =ₑ NULL;ₛ

        EXIT_CRITICAL;ₛ
        RETURN ′OS_NO_ERR
 }· .

Close Scope code_scope.