Require Import VST.floyd.proofauto.
Require Import VST.progs.strlib.
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition strchr_spec :=
 DECLARE _strchr
  WITH sh: share, str : val, s : list byte, c : byte
  PRE  [ tptr tschar, tint ]
    PROP (readable_share sh; c <> Byte.zero)
    PARAMS (str; Vbyte c)
    SEP (cstring sh s str)
  POST [ tptr tschar ]
   EX r : val,
    PROP ((exists i, Znth i s = c /\ Forall (fun d => d<>c) (sublist 0 i s)
                     /\ r = offset_val i str)
       \/ (Forall (fun d => d<>c) s /\ r = nullval))
    RETURN (r)
    SEP (cstring sh s str).

Definition strcat_spec :=
 DECLARE _strcat
  WITH sh: share, sh': share, dest : val, sd : list byte, n : Z, src : val, ss : list byte
  PRE  [ tptr tschar, tptr tschar ]
    PROP (writable_share sh; readable_share sh'; Zlength sd + Zlength ss < n)
    PARAMS (dest; src)
    SEP (cstringn sh sd n dest; cstring sh' ss src)
  POST [ tptr tschar ]
    PROP ()
    RETURN (dest)
    SEP (cstringn sh (sd ++ ss) n dest; cstring sh' ss src).

Definition strcmp_spec :=
 DECLARE _strcmp
  WITH sh1: share, sh2: share, str1 : val, s1 : list byte, str2 : val, s2 : list byte
  PRE [ tptr tschar, tptr tschar ]
    PROP (readable_share sh1; readable_share sh2)
    PARAMS (str1; str2)
    SEP (cstring sh1 s1 str1; cstring sh2 s2 str2)
  POST [ tint ]
   EX i : int,
    PROP (if Int.eq_dec i Int.zero then s1 = s2 else s1 <> s2)
    RETURN (Vint i)
    SEP (cstring sh1 s1 str1; cstring sh2 s2 str2).

Definition strcpy_spec :=
 DECLARE _strcpy
  WITH sh: share, sh': share, dest : val, n : Z, src : val, s : list byte
  PRE [ tptr tschar, tptr tschar ]
    PROP (writable_share sh; readable_share sh'; Zlength s < n)
    PARAMS (dest; src)
    SEP (data_at_ sh (tarray tschar n) dest; cstring sh' s src)
  POST [ tptr tschar ]
    PROP ()
    RETURN (dest)
    SEP (cstringn sh s n dest; cstring sh' s src).

Definition strlen_spec :=
 DECLARE _strlen
  WITH sh: share, s : list byte, str: val
  PRE [ tptr tschar ]
    PROP (readable_share sh)
    PARAMS (str)
    SEP (cstring sh s str)
  POST [ size_t ]
    PROP ()
    RETURN (Vptrofs (Ptrofs.repr (Zlength s)))
    SEP (cstring sh s str).

Definition Gprog : funspecs :=
         ltac:(with_library prog [ strchr_spec; strcat_spec; strcmp_spec ]).

#[export] Hint Rewrite Z.add_simpl_r Z.sub_simpl_r : norm entailer_rewrite.

Lemma body_strlen: semax_body Vprog Gprog f_strlen strlen_spec.
Proof.
start_function.
unfold cstring in *.
rename s into ls.
forward.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls + 1)
  LOCAL (temp _str str; temp _i (Vptrofs (Ptrofs.repr i)))
  SEP (data_at sh (tarray tschar (Zlength ls + 1))
          (map Vbyte (ls ++ [Byte.zero])) str)).
*
Exists 0. entailer!!.
*
Intros i.
forward.
forward_if.
forward.
entailer!!. repeat f_equal. cstring.
forward.
Exists (i+1).
entailer!!. cstring.
Qed.

Lemma body_strchr: semax_body Vprog Gprog f_strchr strchr_spec.
Proof.
start_function.
forward.
unfold cstring in *.
rename s into ls.
Intros.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls + 1; Forall (fun d => d <> c) (sublist 0 i ls))
  LOCAL (temp _str str; temp _c (Vbyte c); temp _i (Vptrofs (Ptrofs.repr i)))
  SEP (data_at sh (tarray tschar (Zlength ls + 1))
          (map Vbyte (ls ++ [Byte.zero])) str)).
  Exists 0; rewrite sublist_nil; entailer!!.
- Intros i.
  assert (Zlength (ls ++ [Byte.zero]) = Zlength ls + 1) by (autorewrite with sublist; auto).
  forward.
  forward. fold_Vbyte.
 forward_if.
  { forward. simpl.
    Exists (offset_val i str).
    entailer!!.
    left. exists i. split3; auto. rewrite app_Znth1; auto. cstring. }
  { forward_if.
    { forward.
      Exists nullval; rewrite !map_app; entailer!.
      right. split; auto.
      assert (i = Zlength ls) by cstring.
      subst i.
     autorewrite with sublist in H2; auto. }
  forward.
  Exists (i+1); entailer!.
  assert (i <> Zlength ls) by cstring.
  split. lia.
  rewrite (sublist_split 0 i) by rep_lia. rewrite Forall_app. split; auto.
  rewrite sublist_len_1 by rep_lia. repeat constructor.
  rewrite app_Znth1 in H4 by rep_lia. auto.
  }
Qed.

Open Scope logic.

Lemma split_data_at_app_tschar:
 forall sh n (al bl: list val) p ,
   n = Zlength (al++bl) ->
   data_at sh (tarray tschar n) (al++bl) p =
         data_at sh (tarray tschar (Zlength al)) al p
        * data_at sh (tarray tschar (n - Zlength al)) bl
                 (field_address0 (tarray tschar n) [ArraySubsc (Zlength al)] p).
Proof.
intros.
apply (split2_data_at_Tarray_app _ n  sh tschar al bl ); auto.
rewrite Zlength_app in H.
change ( Zlength bl = n - Zlength al); lia.
Qed.

Lemma body_strcat: semax_body Vprog Gprog f_strcat strcat_spec.
Proof.
start_function.
unfold cstringn, cstring in *.
rename sd into ld. rename ss into ls.
Intros.
forward.
forward_loop (EX i : Z,
    PROP (0 <= i < Zlength ld + 1)
    LOCAL (temp _i (Vptrofs (Ptrofs.repr i)); temp _dest dest; temp _src src)
    SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ [Byte.zero]) ++
           repeat Vundef (Z.to_nat (n - (Zlength ld + 1)))) dest;
   data_at sh' (tarray tschar (Zlength ls + 1))
     (map Vbyte (ls ++ [Byte.zero])) src))
  break: (PROP ( )
   LOCAL (temp _i (Vptrofs (Ptrofs.repr (Zlength ld))); temp _dest dest;
   temp _src src)
   SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ [Byte.zero]) ++
           repeat Vundef (Z.to_nat (n - (Zlength ld + 1)))) dest;
   data_at sh' (tarray tschar (Zlength ls + 1))
     (map Vbyte (ls ++ [Byte.zero])) src)).
-
  Exists 0; entailer!!.
-
  Intros i.
  forward.
  { entailer!. }
  { entailer!. autorewrite with sublist norm. auto.  }
  autorewrite with sublist norm.
  forward.
  forward_if.
  + forward.
    entailer!!. f_equal. f_equal. cstring.
  +
    forward.
    Exists (i+1); entailer!. cstring.
-
  abbreviate_semax.
  forward.
  forward_loop (EX j : Z,
    PROP (0 <= j < Zlength ls + 1)
    LOCAL (temp _j (Vptrofs (Ptrofs.repr j)); temp _i (Vptrofs (Ptrofs.repr (Zlength ld)));
           temp _dest dest; temp _src src)
    SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ sublist 0 j ls) ++
           repeat Vundef (Z.to_nat (n - (Zlength ld + j)))) dest;
         data_at sh' (tarray tschar (Zlength ls + 1))
           (map Vbyte (ls ++ [Byte.zero])) src)).
  { Exists 0; entailer!.  autorewrite with sublist.
    rewrite !map_app. rewrite <- app_assoc.
    rewrite split_data_at_app_tschar by list_solve.
    rewrite (split_data_at_app_tschar _ n) by list_solve.
    autorewrite with sublist.
    cancel.
   }
  { Intros j.
  assert (Zlength (ls ++ [Byte.zero]) = Zlength ls + 1) by (autorewrite with sublist; auto).
  forward.  autorewrite with norm.
  forward. fold_Vbyte.
  forward.
  entailer!!.
  clear H3.
  rewrite upd_Znth_app2 by list_solve.
  autorewrite with sublist.
  forward_if.
  + forward.
      autorewrite with sublist.
      rewrite prop_true_andp
        by (intro Hx; apply in_app in Hx; destruct Hx; contradiction).
      cancel.
    assert (j = Zlength ls) by cstring; subst.
    autorewrite with sublist.
    apply derives_refl'.
    unfold data_at; f_equal.
    replace (n - (Zlength ld + Zlength ls))
     with (1 + (n - (Zlength ld + Zlength ls+1))) by rep_lia.
    rewrite <- repeat_app' by rep_lia.
    rewrite upd_Znth_app1 by list_solve.
    rewrite app_assoc.
    simpl.
    rewrite !map_app.
    reflexivity.
 +
  forward.
  Exists (j+1).
  destruct (zlt j (Zlength ls)); [ | cstring].
  entailer!!.
  change (field_at Tsh (tarray tschar n) []) with (data_at Tsh (tarray tschar n)).
  rewrite (sublist_split 0 j (j+1)) by rep_lia.
  rewrite (app_assoc ld). rewrite !map_app.
  rewrite <- (app_assoc (_ ++ _)).
  rewrite (split_data_at_app_tschar _ n) by list_solve.
  rewrite (split_data_at_app_tschar _ n) by list_solve.
  replace (n - (Zlength ld + j))
    with (1 + (n - (Zlength ld + (j + 1)))) by rep_lia.
  rewrite <- repeat_app' by rep_lia.
  cancel.
  rewrite upd_Znth_app1 by (autorewrite with sublist; rep_lia).
  rewrite app_Znth1 by list_solve.
  rewrite sublist_len_1 by rep_lia.
  cancel.
  }
Qed.

Lemma body_strcmp: semax_body Vprog Gprog f_strcmp strcmp_spec.
Proof.
start_function.
unfold cstring in *.
rename s1 into ls1. rename s2 into ls2.
forward.
Intros.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls1 + 1; 0 <= i < Zlength ls2 + 1;
        sublist 0 i ls1 = sublist 0 i ls2)
  LOCAL (temp _str1 str1; temp _str2 str2; temp _i (Vptrofs (Ptrofs.repr i)))
  SEP (data_at sh1 (tarray tschar (Zlength ls1 + 1))
          (map Vbyte (ls1 ++ [Byte.zero])) str1;
       data_at sh2 (tarray tschar (Zlength ls2 + 1))
          (map Vbyte (ls2 ++ [Byte.zero])) str2)).
- Exists 0; entailer!!.
- Intros i.
  assert (Zlength (ls1 ++ [Byte.zero]) = Zlength ls1 + 1) by (autorewrite with sublist; auto).
  forward. autorewrite with norm.
  assert (Zlength (ls2 ++ [Byte.zero]) = Zlength ls2 + 1) by (autorewrite with sublist; auto).
  forward. fold_Vbyte.
  assert (Znth i (ls1 ++ [Byte.zero]) = Byte.zero <-> i = Zlength ls1) as Hs1.
  { split; [|intro; subst; rewrite app_Znth2, Zminus_diag by lia; auto].
    destruct (zlt i (Zlength ls1)); [|lia].
    intro X; lapply (Znth_In i ls1); [|lia]. cstring. }
  assert (Znth i (ls2 ++ [Byte.zero]) = Byte.zero <-> i = Zlength ls2) as Hs2.
  { split; [|intro; subst; rewrite app_Znth2, Zminus_diag by lia; auto].
    destruct (zlt i (Zlength ls2)); [|lia].
    intro X; lapply (Znth_In i ls2); [|lia]. cstring. }
  forward.
  forward. fold_Vbyte.
  forward_if (temp _t'1 (bool2val (Z.eqb i (Zlength ls1) && Z.eqb i (Zlength ls2)))).
  { forward.
    simpl force_val.
    rewrite Hs1 in *.
    destruct (Byte.eq_dec (Znth i (ls2 ++ [Byte.zero])) Byte.zero).
    + rewrite e; simpl force_val.
         assert (i = Zlength ls2) by cstring.
        rewrite  (proj2 Hs1 H6).
     rewrite (proj2 (Z.eqb_eq i (Zlength ls1)) H6).
     rewrite (proj2 (Z.eqb_eq i (Zlength ls2)) H7).
     entailer!!.
  +
    entailer!!. unfold bool2val. f_equal. rewrite Z.eqb_refl.
    assert (Zlength ls1 <> Zlength ls2) by list_solve.
    rewrite (proj2 (Z.eqb_neq _ _) H6).
    unfold Int.cmp.
    rewrite (Int.eq_false (Int.repr (Byte.signed _))). reflexivity.
    contradict n.
    apply repr_inj_signed in n; try rep_lia.  autorewrite with norm in n. auto.
 }
  { forward.
    entailer!!.
    destruct (i =? Zlength ls1) eqn: Heq; auto.
    rewrite Z.eqb_eq in Heq; tauto. }
  forward_if.
 +
  rewrite andb_true_iff in H6; destruct H6.
  rewrite Z.eqb_eq in H6,H7.
  forward.
  Exists (Int.repr 0).
  entailer!!. simpl.
  autorewrite with sublist in H3.
  auto.
 +
  rewrite andb_false_iff in H6. rewrite !Z.eqb_neq in H6.
  forward_if.
  *
    forward. Exists (Int.repr (-1)). entailer!!.
    simpl. intro; subst. lia.
 *
   forward_if.
   forward.
   Exists (Int.repr 1). entailer!.

   assert (H17: Byte.signed (Znth i (ls1 ++ [Byte.zero])) =
     Byte.signed (Znth i (ls2 ++ [Byte.zero]))) by lia.
   autorewrite with norm in H17. clear H7 H8.
   forward.
   Exists (i+1).
   entailer!!.
   destruct (zlt i (Zlength ls1)).
  2:{
         rewrite app_Znth2 in Hs1 by rep_lia.
         destruct (zeq i (Zlength ls1)); [ | lia].
         subst.
         destruct H6; [congruence | ].
         assert (Zlength ls1 < Zlength ls2) by lia.
         rewrite app_Znth2 in H17 by rep_lia.
         rewrite app_Znth1 in H17 by rep_lia.
         rewrite Z.sub_diag in H17. contradiction H0.
         change (Znth 0 [Byte.zero]) with Byte.zero in H17. rewrite H17.
         apply Znth_In. lia.
   }
  destruct (zlt i (Zlength ls2)).
  2:{
         rewrite app_Znth2 in Hs2 by rep_lia.
         destruct (zeq i (Zlength ls2)); [ | lia].
         subst.
         destruct H6; [ | congruence].
         assert (Zlength ls1 > Zlength ls2) by lia.
         rewrite app_Znth1 in H17 by rep_lia.
         rewrite app_Znth2 in H17 by rep_lia.
         rewrite Z.sub_diag in H17. contradiction H.
         change (Znth 0 [Byte.zero]) with Byte.zero in H17. rewrite <- H17.
         apply Znth_In. lia.
   }
  rewrite (sublist_split 0 i (i+1)) by lia.
  rewrite (sublist_split 0 i (i+1)) by lia.
  f_equal; auto.
  rewrite !sublist_len_1 by lia.
  rewrite !app_Znth1 in H17 by list_solve.
  split. rep_lia. split. rep_lia.
  f_equal; auto. f_equal. auto.
Qed.

Lemma body_strcpy: semax_body Vprog Gprog f_strcpy strcpy_spec.
Proof.
start_function.
unfold cstring,cstringn in *.
rename s into ls.
forward.
Intros.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls + 1)
  LOCAL (temp _i (Vptrofs (Ptrofs.repr i)); temp _dest dest; temp _src src)
  SEP (data_at sh (tarray tschar n)
        (map Vbyte (sublist 0 i ls) ++ repeat Vundef (Z.to_nat (n - i))) dest;
       data_at sh' (tarray tschar (Zlength ls + 1)) (map Vbyte (ls ++ [Byte.zero])) src)).
*
 Exists 0. rewrite Z.sub_0_r; entailer!; simpl; entailer!.
*
 Intros i.
 assert (Zlength (ls ++ [Byte.zero]) = Zlength ls + 1) by (autorewrite with sublist; auto).
 forward. autorewrite with norm.
 forward. fold_Vbyte.
 forward.
 forward_if.
+ forward.
   entailer!!.
  assert (i = Zlength ls) by cstring. subst i.
  change (field_at Tsh (tarray tschar n) []) with (data_at Tsh (tarray tschar n)).
  rewrite upd_Znth_app2 by list_solve.
  autorewrite with sublist.
  rewrite !map_app.
  rewrite <- app_assoc.
   rewrite (split_data_at_app_tschar _ n) by list_solve.
   rewrite (split_data_at_app_tschar _ n) by list_solve.
   autorewrite with sublist.
   replace (n - Zlength ls) with (1 + (n - (Zlength ls + 1))) at 2 by list_solve.
  rewrite <- repeat_app' by lia.
  rewrite upd_Znth_app1 by list_solve.
  rewrite !split_data_at_app_tschar by list_solve.
  cancel.
+
   assert (i < Zlength ls) by cstring.
  forward.
  Exists (i+1). entailer!!.
  autorewrite with sublist.
  rewrite (sublist_split 0 i (i+1)) by list_solve.
  rewrite !map_app. rewrite <- app_assoc.
  autorewrite with sublist.
  change (field_at Tsh (tarray tschar n) []) with (data_at Tsh (tarray tschar n)).
  rewrite !(split_data_at_app_tschar _ n) by list_solve.
  autorewrite with sublist.
   replace (n - i) with (1 + (n-(i+ 1))) at 2 by list_solve.
  rewrite <- repeat_app' by lia.
  autorewrite with sublist.
  cancel.
  rewrite !split_data_at_app_tschar by list_solve.
  autorewrite with sublist.
  rewrite sublist_len_1 by lia.
  simpl. cancel.
Qed.

Module Alternate.

(* Alternate proofs of these functions, using list solver *)

Lemma body_strlen: semax_body Vprog Gprog f_strlen strlen_spec.
Proof.
start_function.
unfold cstring in *.
rename s into ls.
forward.
forward_loop  (EX i : Z,
  PROP (0 <= i < Zlength ls + 1)
  LOCAL (temp _str str; temp _i (Vptrofs (Ptrofs.repr i)))
  SEP (data_at sh (tarray tschar (Zlength ls + 1))
          (map Vbyte (ls ++ [Byte.zero])) str)).
all: finish.
Qed.

Lemma body_strchr: semax_body Vprog Gprog f_strchr strchr_spec.
Proof.
start_function.
forward.
unfold cstring in *.
rename s into ls.
Intros.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls + 1; Forall (fun d => d <> c) (sublist 0 i ls))
  LOCAL (temp _str str; temp _c (Vbyte c); temp _i (Vptrofs (Ptrofs.repr i)))
  SEP (data_at sh (tarray tschar (Zlength ls + 1))
          (map Vbyte (ls ++ [Byte.zero])) str)).
all: finish.
Qed.

Lemma body_strcat: semax_body Vprog Gprog f_strcat strcat_spec.
Proof.
start_function.
unfold cstringn, cstring in *.
rename sd into ld. rename ss into ls.
forward.
forward_loop (EX i : Z,
    PROP (0 <= i < Zlength ld + 1)
    LOCAL (temp _i (Vptrofs (Ptrofs.repr i)); temp _dest dest; temp _src src)
    SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ [Byte.zero]) ++
           repeat Vundef (Z.to_nat (n - (Zlength ld + 1)))) dest;
   data_at sh' (tarray tschar (Zlength ls + 1))
     (map Vbyte (ls ++ [Byte.zero])) src))
  break: (PROP ( )
   LOCAL (temp _i (Vptrofs (Ptrofs.repr (Zlength ld))); temp _dest dest;
   temp _src src)
   SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ [Byte.zero]) ++
           repeat Vundef (Z.to_nat (n - (Zlength ld + 1)))) dest;
   data_at sh' (tarray tschar (Zlength ls + 1))
     (map Vbyte (ls ++ [Byte.zero])) src)).
- (* before loop1 *)
  finish.
- (* loop1 body *)
  finish!.
-
  fastforward.
  forward_loop (EX j : Z,
    PROP (0 <= j < Zlength ls + 1)
    LOCAL (temp _j (Vptrofs (Ptrofs.repr j)); temp _i (Vptrofs (Ptrofs.repr (Zlength ld)));
           temp _dest dest; temp _src src)
    SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ sublist 0 j ls) ++
           repeat Vundef (Z.to_nat (n - (Zlength ld + j)))) dest;
         data_at sh' (tarray tschar (Zlength ls + 1))
           (map Vbyte (ls ++ [Byte.zero])) src)).
 all: finish.
Qed.

Lemma body_strcmp: semax_body Vprog Gprog f_strcmp strcmp_spec.
Proof.
start_function.
unfold cstring in *.
rename s1 into ls1. rename s2 into ls2.
fastforward.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls1 + 1; 0 <= i < Zlength ls2 + 1;
        forall (j:Z), 0 <= j < i -> Znth j ls1 = Znth j ls2)
  LOCAL (temp _str1 str1; temp _str2 str2; temp _i (Vptrofs (Ptrofs.repr i)))
  SEP (data_at sh1 (tarray tschar (Zlength ls1 + 1))
          (map Vbyte (ls1 ++ [Byte.zero])) str1;
       data_at sh2 (tarray tschar (Zlength ls2 + 1))
          (map Vbyte (ls2 ++ [Byte.zero])) str2)).
- finish.
- fastforward.
  forward_if (temp _t'1 (bool2val (Z.eqb i (Zlength ls1) && Z.eqb i (Zlength ls2)))).
  (* these two parts are not much simplified *)
  { forward. cstring1. entailer!!.
    unfold bool2val; f_equal.
    rewrite (proj2 (Z.eqb_eq _ _)) by auto.
    unfold Int.cmp.
    destruct (Int.eq (Int.repr (Byte.signed (Znth (Zlength ls1) (ls2 ++ [Byte.zero])))) (Int.repr 0)) eqn:Heqb;
    do_repr_inj Heqb. (* utilize this internal tactic *)
    - rewrite (proj2 (Z.eqb_eq _ _)) by cstring.
      auto.
    - rewrite (proj2 (Z.eqb_neq _ _)) by cstring.
      auto.
  }
  {
    forward. entailer!!.
    rewrite (proj2 (Z.eqb_neq _ _)) by cstring.
    auto.
  }
  fastforward.
    finish.
    finish.
    finish.
  assert (HZnth: Byte.signed (Znth i (ls1 ++ [Byte.zero])) =
    Byte.signed (Znth i (ls2 ++ [Byte.zero]))) by lia.
  finish.
Qed.

Lemma body_strcpy: semax_body Vprog Gprog f_strcpy strcpy_spec.
Proof.
start_function.
unfold cstring,cstringn in *.
rename s into ls.
fastforward.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls + 1)
  LOCAL (temp _i (Vptrofs (Ptrofs.repr i)); temp _dest dest; temp _src src)
  SEP (data_at sh (tarray tschar n)
        (map Vbyte (sublist 0 i ls) ++ repeat Vundef (Z.to_nat (n - i))) dest;
       data_at sh' (tarray tschar (Zlength ls + 1)) (map Vbyte (ls ++ [Byte.zero])) src)).
all: finish.
Qed.

End Alternate.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition table_create3_spec (g_rd: Pointer) (map_addr: Z64) (level: Z64) (g_rtt': Pointer) (rtt_addr: Z64) (adt: RData) : option (RData * Z64) :=
    match map_addr, level, rtt_addr with
    | VZ64 map_addr, VZ64 level, VZ64 rtt_addr =>
      rely is_int64 map_addr; rely is_int64 rtt_addr; rely GRANULE_ALIGNED map_addr; rely is_int64 level;
      let idx0 := __addr_to_idx map_addr 0 in
      let idx1 := __addr_to_idx map_addr 1 in
      let idx2 := __addr_to_idx map_addr 2 in
      let idx3 := __addr_to_idx map_addr 3 in
      let ret_idx := (if level =? 1 then idx0 else if level =? 2 then idx1 else if level =? 3 then idx2 else idx3) in
      let rtt_gidx := __addr_to_gidx rtt_addr in
      rely is_gidx rtt_gidx;
      rely (peq (base g_rd) ginfo_loc);
      rely (peq (base g_rtt') ginfo_loc);
      rely (offset g_rtt' =? rtt_gidx);
      rely prop_dec ((buffer (priv adt)) @ SLOT_RD = None);
      rely prop_dec ((buffer (priv adt)) @ SLOT_TABLE = None);
      rely prop_dec ((buffer (priv adt)) @ SLOT_DELEGATED = None);
      let rd_gidx := (offset g_rd) in
      let grd := (gs (share adt)) @ rd_gidx in
      rely (g_tag (ginfo grd) =? GRANULE_STATE_RD);
      rely prop_dec (glock grd = Some CPU_ID);
      let root_gidx := (g_rtt (gnorm grd)) in
      rely is_gidx rd_gidx; rely is_gidx root_gidx;
      when adt == query_oracle adt;
      (* hold root lock *)
      let groot := (gs (share adt)) @ root_gidx in
      rely (tbl_level (gaux groot) =? 0);
      rely prop_dec (glock groot = None);
      if level =? 1 then
        (* walk until root *)
        let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 0) :: log adt} in
        let adt :=  adt {priv: (priv adt) {wi_llt: root_gidx} {wi_index: idx0}} in
        create_table root_gidx idx0 rtt_addr rtt_gidx rd_gidx 1 map_addr adt
      else
        (* walk deeper root *)
        rely (level >? 1);
        rely (g_tag (ginfo groot) =? GRANULE_STATE_TABLE);
        rely (gtype groot =? GRANULE_STATE_TABLE);
        let entry0 := (g_data (gnorm groot)) @ idx0 in
        rely is_int64 entry0;
        let phys0 := __entry_to_phys entry0 3 in
        let lv1_gidx := __addr_to_gidx phys0 in
        if (__entry_is_table entry0) && (GRANULE_ALIGNED phys0) && (is_gidx lv1_gidx) then
          (* level 1 valid, hold level 1 lock *)
          let glv1 := (gs (share adt)) @ lv1_gidx in
          rely prop_dec (glock glv1 = None);
          rely (tbl_level (gaux glv1) =? 1);
          if level =? 2 then
            (* walk until level 1 *)
            let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 1) :: log adt} in
            let adt :=  adt {priv: (priv adt) {wi_llt: lv1_gidx} {wi_index: idx1}} in
            create_table lv1_gidx idx1 rtt_addr rtt_gidx rd_gidx 2 map_addr adt
          else
            (* walk deeper level 1 *)
            rely (level >? 2);
            rely (g_tag (ginfo glv1) =? GRANULE_STATE_TABLE);
            rely (gtype glv1 =? GRANULE_STATE_TABLE);
            let entry1 := (g_data (gnorm glv1)) @ idx1 in
            rely is_int64 entry1;
            let phys1 := __entry_to_phys entry1 3 in
            let lv2_gidx := __addr_to_gidx phys1 in
            if (__entry_is_table entry1) && (GRANULE_ALIGNED phys1) && (is_gidx lv2_gidx) then
              (* level 2 valid, hold level 2 lock *)
              let glv2 := (gs (share adt)) @ lv2_gidx in
              rely (tbl_level (gaux glv2) =? 2);
              rely prop_dec (glock glv2 = None);
              if level =? 3 then
                (* walk until level 2 *)
                let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 2) :: log adt} in
                let adt :=  adt {priv: (priv adt) {wi_llt: lv2_gidx} {wi_index: idx2}} in
                create_table lv2_gidx idx2 rtt_addr rtt_gidx rd_gidx 3 map_addr adt
              else None
            else
              (* level 2 invalid *)
              Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
        else
          (* level 1 invalid *)
          Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
    end.

End Spec.


Require Import Program.

Require Import Sem SimProg Skeleton Mod ModSem SimMod SimModSem SimSymb SimMem Sound SimSymb.
Require Import Cop Ctypes ClightC.
Require Import AsmC.
Require SimMemInjInvC.
Require Import MutrecA MutrecAspec MutrecAproof.
Require Import CoqlibC.
Require Import ValuesC.
Require Import LinkingC.
Require Import MapsC.
Require Import AxiomsC.
Require Import Ord.
Require Import MemoryC.
Require Import SmallstepC.
Require Import Events.
Require Import Preservation.
Require Import Integers.
Require Import LocationsC Conventions.
Require Import Conventions1C.

Require Import AsmregsC.
Require Import MatchSimModSem.
Require Import StoreArguments.
Require Import AsmStepInj IntegersC.
Require Import Coq.Logic.PropExtensionality.
Require Import CtypingC.
Require Import CopC.

Require Import MatchSimModSem ModSemProps.
Require Import Conventions1C.

Require Import IdSimExtra IdSimInvExtra IdSimClightExtra.
Require Import mktac.

Set Implicit Arguments.

Local Opaque Z.mul Z.add Z.sub Z.div.

Inductive match_states_a_internal:
  state -> state -> meminj -> mem -> mem -> Prop :=
| match_Callstate
    i m_src m_tgt j
  :
    match_states_a_internal
      (Callstate i m_src)
      (Callstate i m_tgt)
      j m_src m_tgt
| match_Interstate
    i m_src m_tgt j
  :
    match_states_a_internal
      (Interstate i m_src)
      (Interstate i m_tgt)
      j m_src m_tgt
| match_Returnstate
    i m_src m_tgt j
  :
    match_states_a_internal
      (Returnstate i m_src)
      (Returnstate i m_tgt)
      j m_src m_tgt
.

Section INJINV.

Variable P: SimMemInjInv.memblk_invariant.

Local Instance SimMemP: SimMem.class := SimMemInjInvC.SimMemInjInv SimMemInjInv.top_inv P.
Local Instance SimSymbP: SimSymb.class SimMemP := SimMemInjInvC.SimSymbIdInv P.

Local Existing Instance SoundTop.Top.

Inductive match_states_a_inv
  : unit -> state -> state -> SimMem.t -> Prop :=
| match_states_a_intro
    st_src st_tgt j m_src m_tgt sm0
    (MWFSRC: m_src = sm0.(SimMem.src))
    (MWFTGT: m_tgt = sm0.(SimMem.tgt))
    (MWFINJ: j = sm0.(SimMemInjInv.minj).(SimMemInj.inj))
    (MATCHST: match_states_a_internal st_src st_tgt j m_src m_tgt)
    (MWF: SimMem.wf sm0)
  :
    match_states_a_inv
      tt st_src st_tgt sm0
.

Lemma a_inj_inv_id
      (WF: Sk.wf (MutrecAspec.module))
  :
    exists mp,
      (<<SIM: ModPair.sim mp>>)
      /\ (<<SRC: mp.(ModPair.src) = (MutrecAspec.module)>>)
      /\ (<<TGT: mp.(ModPair.tgt) = (MutrecAspec.module)>>)
.
Proof.
  eexists (ModPair.mk _ _ _); s.
  esplits; eauto. instantiate (1:=SimMemInjInvC.mk bot1 _ _).
  econs; ss; i.
  { econs; ss; i; clarify. }
  eapply match_states_sim with (match_states := match_states_a_inv); ss.
  - apply unit_ord_wf.
  - eapply SoundTop.sound_state_local_preservation.

  - i. ss. exploit SimSymbIdInv_match_globals.
    { inv SIMSKENV. ss. eauto. }
    instantiate (1 := prog). intros GEMATCH.
    inv INITTGT. inv SAFESRC. inv SIMARGS. inv H. ss.
    inv GEMATCH. exploit SYMBLE; eauto. i. des.
    clarify.
    esplits; eauto.
    + econs; eauto.
    + refl.
    + econs; eauto.
      assert (i = i0).
      { subst. inv VALS. inv H2. ss. }
      subst. econs; eauto.
    + ss.

  - i. ss. exploit SimSymbIdInv_match_globals.
    { inv SIMSKENV. ss. eauto. }
    instantiate (1 := prog). intros GEMATCH.
    des. inv SAFESRC. inv SIMARGS.
    inv GEMATCH. exploit SYMBLE; eauto. i. des; eauto.
    esplits. econs; ss; eauto.
    + clear -MWF INJ FPTR FPTR0.
      rewrite FPTR in FPTR0. inv FPTR0; ss.
      rewrite H1 in INJ. clarify.
    + rewrite VS in VALS. inv VALS; ss. inv H3. inv H1. auto.
    + ss.

  - i. ss. inv MATCH; eauto.

  - i. ss. clear SOUND. inv CALLSRC. inv MATCH. inv MATCHST. inversion SIMSKENV; subst. ss.
    i. ss. exploit SimSymbIdInv_match_globals.
    { inv SIMSKENV. ss. eauto. }
    instantiate (2 := prog). intros GEMATCH.
    inv GEMATCH. exploit SYMBLE; eauto. i. des; eauto.
    esplits; eauto.
    + econs; ss; eauto.
    + econs; ss; econs; eauto.
    + refl.
    + instantiate (1:=top4). ss.

  - i. ss. clear SOUND HISTORY.
    exists (SimMemInjInvC.unlift' sm_arg sm_ret).
    inv AFTERSRC. inv MATCH. inv MATCHST.
    esplits; eauto.
    + econs; eauto. inv SIMRET; ss. rewrite INT in *. inv RETV. ss.
    + inv SIMRET; ss. econs; eauto. econs; eauto.
    + refl.

  - i. ss. inv FINALSRC. inv MATCH. inv MATCHST.
    esplits; eauto.
    + econs.
    + econs; eauto. econs.
    + refl.

  - right. ii. des.
    esplits.
    + i. inv MATCH. inv MATCHST.
      * unfold ModSem.is_step. do 2 eexists. ss. econs; eauto.
      * unfold safe_modsem in H.
        exploit H. eapply star_refl. ii. des; clarify. inv EVSTEP.
      * ss. exfalso. eapply NOTRET. econs. ss.
    + ii. inv STEPTGT; inv MATCH; inv MATCHST.
      * esplits; eauto.
        { left. eapply plus_one. econs. }
        refl.
        econs; eauto. econs.
      * esplits; eauto.
        { left. eapply plus_one. econs 2. eauto. }
        refl.
        econs; eauto. econs.
Qed.

End INJINV.


Require Import VST.sepcomp.semantics.

Require Import VST.veric.juicy_base.

Require Import VST.veric.juicy_mem.
Require Import VST.sepcomp.extspec.
Require Import VST.veric.ghost_PCM.
Require Import VST.veric.juicy_extspec.

Require Import VST.veric.res_predicates.
Require Import VST.veric.mpred.
Require Import VST.veric.seplog.

(*********copied from initial_world***********)
Fixpoint find_id (id: ident) (G: funspecs) : option funspec  :=
 match G with
 | (id', f)::G' => if eq_dec id id' then Some f else find_id id G'
 | nil => None
 end.

Definition cond_approx_eq n A P1 P2 :=
  (forall ts,
      fmap (dependent_type_functor_rec ts (AssertTT A)) (approx n) (approx n) (P1 ts) =
      fmap (dependent_type_functor_rec ts (AssertTT A)) (approx n) (approx n) (P2 ts)).

Definition func_at'' fsig cc A P Q :=
  pureat (SomeP (SpecTT A) (packPQ P Q)) (FUN fsig cc).
(*also copy lemmas on these from initial_world? or isolate in general file?*)

(**********************************************)

Module Type GENERAL_SEPARATION_LOGIC_SOUNDNESS.

Parameter F T: Type. (*Clight instantiates := fundef V:=type*)

Definition genv:Type := Genv.t F T.

(*duplicated from tycontext to prevent specialization to Clight*)
Definition filter_genv (ge: genv) : genviron := Genv.find_symbol ge.
Definition empty_environ (ge: genv) := mkEnviron (filter_genv ge) (Map.empty _) (Map.empty _).

Parameter C: Type.
Parameter Sem: genv -> CoreSemantics C Memory.mem.
Parameter genv_symb_injective: genv -> extspec.injective_PTree block.

Definition jsafeN {Z} (Hspec : juicy_ext_spec Z) (ge: genv) :=
  @jsafeN_ genv _ _ genv_symb_injective (*(genv_symb := fun ge: genv => Genv.genv_symb ge)*)
           (Sem ge) Hspec ge.

Definition matchfunspecs (ge : genv) (G : funspecs) (Phi : rmap) :=
forall (b : block) (fsig : compcert_rmaps.funsig)
  (cc : calling_convention) (A : TypeTree)
  (P
   Q : forall ts : list Type,
       (dependent_type_functor_rec ts (AssertTT A)) (pred rmap)),
(func_at'' fsig cc A P Q (b, 0)) Phi ->
exists
  (id : ident) (P'
                Q' : forall ts : list Type,
                     (dependent_type_functor_rec ts (AssertTT A)) mpred)
(P'_ne : super_non_expansive P') (Q'_ne : super_non_expansive Q'),
  Genv.find_symbol ge id = Some b /\
  find_id id G = Some (mk_funspec fsig cc A P' Q' P'_ne Q'_ne) /\
  cond_approx_eq (level Phi) A P P' /\ cond_approx_eq (level Phi) A Q Q'.

Definition EPoint_sound {Espec: OracleKind} FS m (h:nat) (entryPT:ident) (g:genv) :=
     { b : block & { q : C &
       (Genv.find_symbol g entryPT = Some b) *
       (forall jm, m_dry jm = m -> exists jm', semantics.initial_core (juicy_core_sem (Sem g)) h
                    jm q jm' (Vptr b Ptrofs.zero) nil) *
       forall n z,
         { jm |
           m_dry jm = m /\ level jm = n /\
           nth_error (ghost_of (m_phi jm)) 0 = Some (Some (ext_ghost z, NoneP)) /\
           jsafeN (@OK_spec Espec) g n z q jm /\
           res_predicates.no_locks (m_phi jm) /\
           matchfunspecs g FS (m_phi jm) /\
           app_pred (funspecs_assert (make_tycontext_s FS) (empty_environ g))  (m_phi jm) } } }%type.

End GENERAL_SEPARATION_LOGIC_SOUNDNESS.


Require Import
  Hask.Control.Monad
  Hask.Control.Monad.Trans.State
  Pact.Data.Monoid
  Pact.Data.Either
  Pact.Lib
  Pact.Ty
  Pact.Value
  Pact.Exp
  Pact.SemTy
  Pact.Lang
  Pact.Lang.CapabilityType
  Pact.Lang.Capability
  Hask.Control.Lens.

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

Set Equations With UIP.

Generalizable All Variables.
Set Primitive Projections.

Import ListNotations.

Open Scope Ty_scope.

(******************************************************************************
 * Facts about Capabilities
 *)

Lemma get_cap_head `(c : Cap s) cs :
  get_cap c (AToken c :: cs) = Some (valueOf (s:=s) c).
Proof.
  destruct c.
  rewrite /= !eq_dec_refl //.
Qed.

Theorem with_capability_idem
  (n : string) `(c : Cap s)
  (p : Cap s → PactM unit)
  (m : reflectTy (TPair (valueTy s) (valueTy s)) →
       PactM (reflectTy (valueTy s)))
  `(f : PactM a) :
  with_capability n c p m (with_capability n c p m f) =
  with_capability n c p m f.
Proof.
  rewrite /with_capability /__check_capability.
  unravel.
  extensionality st.
  matches.
  - rewrite Heqe //.
    sauto.
  - do 2 matches.
    destruct (p _ _) as [|[? [? ?]]]; auto.
    simpl.
    destruct (__claim_resource _ _ _) as [|[? [? ?]]]; auto.
    simpl.
    rewrite get_cap_head //=.
    sauto.
Qed.

Theorem require_capability_idem (n : string) `(c : Cap s) :
  (require_capability c >> require_capability c) =
   require_capability c.
Proof.
  rewrite /require_capability.
  unravel; extensionality st.
  now repeat matches.
Qed.

Lemma extend_f {A B : Type} (f g : A → B) :
  (λ x, f x) = (λ x, g x) → (∀ x, f x = g x).
Proof.
  intros.
  setoid_rewrite <- eta_expansion in H.
  now rewrite H.
Qed.

Theorem with_require_sometimes_noop
  (n : string) `(c : Cap s)
  (p : Cap s → PactM unit)
  (m : reflectTy (TPair (valueTy s) (valueTy s)) →
       PactM (reflectTy (valueTy s))) :

  (* Assuming we are NOT within a defcap predicate... *)
  getsT __in_defcap = pure[PactM] false →

  (* Assuming we ARE within the defining module... *)
  getsT (__in_module n) = pure[PactM] true →

  (* Assuming the predicate always succeeds and changes nothing... *)
  p c = pure[PactM] tt →

  (* Assuming composed predicates only occur within a defcap: This should be
     true of the system as a whole, but this theorem is quantified over all
     possible states. *)
  (getsT __in_defcap = pure[PactM] false → getsT _to_compose = pure[PactM] []) →

  (* Assuming that the resource type is unit...  *)
  ∀ H, eq_dec (valueTy s) TUnit = left H ->

  (* Then just checking a capability is the same as doing nothing. *)
  with_capability n c p m (require_capability c) = pure[PactM] tt.

Proof.
  rewrite /with_capability /require_capability /__check_capability; intros.
  unravel; extensionality st.
  matches.
  - rewrite Heqe //.
  - matches.
    + exfalso.
      apply extend_f with (x:=st) in H.
      inv H.
      congruence.
    + matches.
      * destruct (p _ _) as [|[? [? ?]]] eqn:Heqe2; auto.
        ** rewrite H1 in Heqe2.
           discriminate.
        ** unfold __claim_resource.
           rewrite H4 /= get_cap_head /=.
           pose proof (H2 H).
           unfold getsT in H5.
           apply extend_f with (x:=st) in H5.
           inv H5.
           rewrite H1 in Heqe2.
           inv Heqe2.
           reflexivity.
      * exfalso.
        unfold getsT in H0.
        apply extend_f with (x:=st) in H0.
        inv H0.
        congruence.
Qed.


Require Import Bool.
Require Import List.

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

From PromisingLib Require Import Basic.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

Require Import Event.
From PromisingLib Require Import Language.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Thread.
Require Import Configuration.
Require Import Progress.

Require Import FulfillStep.
Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import Compatibility.
Require Import SimThread.

Require ReorderTView.
Require Import MemoryReorder.
Require Import MemoryMerge.

Require Import Syntax.
Require Import Semantics.
Require Import ProgressStep.

Set Implicit Arguments.

Lemma future_read_step
      lc1 mem1 mem1' loc ts val released ord lc2
      (WF: Local.wf lc1 mem1)
      (MEM: Memory.closed mem1)
      (FUTURE: Memory.future mem1 mem1')
      (STEP: Local.read_step lc1 mem1 loc ts val released ord lc2):
  exists released' lc2',
    <<STEP: Local.read_step lc1 mem1' loc ts val released' ord lc2'>> /\
    <<REL: View.opt_le released' released>> /\
    <<LOCAL: sim_local lc2' lc2>>.
Proof.
  inv STEP. exploit Memory.future_get1; eauto. i. des.
  esplits.
  - econs; eauto. eapply TViewFacts.readable_mon; eauto; refl.
  - auto.
  - econs; s.
    + apply TViewFacts.read_tview_mon; auto.
      * refl.
      * apply WF.
      * eapply MEM. eauto.
      * refl.
    + apply SimPromises.sem_bot.
Qed.

Lemma future_fulfill_step
      lc1 sc1 sc1' loc from to val releasedm releasedm' released ord lc2 sc2
      (ORD: Ordering.le ord Ordering.relaxed)
      (REL_LE: View.opt_le releasedm' releasedm)
      (STEP: fulfill_step lc1 sc1 loc from to val releasedm released ord lc2 sc2):
  fulfill_step lc1 sc1' loc from to val releasedm' released ord lc2 sc1'.
Proof.
  assert (TVIEW: TView.write_tview (Local.tview lc1) sc1 loc to ord = TView.write_tview (Local.tview lc1) sc1' loc to ord).
  { unfold TView.write_tview. repeat (condtac; viewtac). }
  inversion STEP. subst lc2 sc2.
  rewrite TVIEW. econs; eauto.
  - etrans; eauto. unfold TView.write_released. condtac; econs. repeat apply View.join_spec.
    + rewrite <- View.join_l. apply View.unwrap_opt_le. auto.
    + rewrite <- ? View.join_r. rewrite TVIEW. refl.
  - econs; try apply WRITABLE.
Qed.

Lemma reorder_read_read
      loc1 ts1 val1 released1 ord1
      loc2 ts2 val2 released2 ord2
      lc0 mem0
      lc1
      lc2
      (LOC: loc1 = loc2 -> Ordering.le ord1 Ordering.plain /\ Ordering.le ord2 Ordering.plain)
      (ORD2: Ordering.le ord2 Ordering.relaxed)
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: Local.read_step lc1 mem0 loc2 ts2 val2 released2 ord2 lc2):
  exists lc1',
    <<STEP1: Local.read_step lc0 mem0 loc2 ts2 val2 released2 ord2 lc1'>> /\
    <<STEP2: Local.read_step lc1' mem0 loc1 ts1 val1 released1 ord1 lc2>>.
Proof.
  inv STEP1. inv STEP2. ss.
  esplits.
  - econs; eauto.
    eapply TViewFacts.readable_mon; try apply READABLE0; eauto; try refl.
    apply TViewFacts.read_tview_incr.
  - refine (Local.read_step_intro _ _ _ _ _); eauto.
    + s. unfold View.singleton_ur_if.
      econs; repeat (try condtac; try splits; aggrtac; eauto; try apply READABLE;
                     unfold TimeMap.singleton, LocFun.add in *).
      * specialize (LOC eq_refl). des. viewtac.
      * specialize (LOC eq_refl). des. viewtac.
      * specialize (LOC eq_refl). des. viewtac.
    + apply TView.antisym; apply ReorderTView.read_read_tview;
        (try by apply WF0);
        (try by eapply MEM0; eauto).
Qed.

Lemma reorder_read_promise
      loc1 ts1 val1 released1 ord1
      loc2 from2 to2 val2 released2 kind2
      lc0 mem0
      lc1
      lc2 mem2
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: Local.promise_step lc1 mem0 loc2 from2 to2 val2 released2 lc2 mem2 kind2):
  exists lc1' lc2' released1',
    <<STEP1: Local.promise_step lc0 mem0 loc2 from2 to2 val2 released2 lc1' mem2 kind2>> /\
    <<STEP2: Local.read_step lc1' mem2 loc1 ts1 val1 released1' ord1 lc2'>> /\
    <<REL1: View.opt_le released1' released1>> /\
    <<LOCAL: sim_local lc2' lc2>>.
Proof.
  inv STEP1. inv STEP2. ss.
  exploit Memory.promise_future; try exact PROMISE; try apply WF0; eauto. i. des.
  exploit Memory.promise_get1; eauto. i. des.
  esplits; eauto.
  - econs; eauto.
  - econs; eauto.
    s. eapply TViewFacts.readable_mon; eauto; try refl.
  - s. econs; ss.
    + apply TViewFacts.read_tview_mon; try refl; try apply WF0; eauto.
      eapply MEM0. eauto.
    + apply SimPromises.sem_bot.
Qed.

Lemma reorder_read_promise_diff
      loc1 ts1 val1 released1 ord1
      loc2 from2 to2 val2 released2 kind2
      lc0 mem0
      lc1
      lc2 mem2
      (DIFF: (loc1, ts1) <> (loc2, to2))
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: Local.promise_step lc1 mem0 loc2 from2 to2 val2 released2 lc2 mem2 kind2):
  exists lc1',
    <<STEP1: Local.promise_step lc0 mem0 loc2 from2 to2 val2 released2 lc1' mem2 kind2>> /\
    <<STEP2: Local.read_step lc1' mem2 loc1 ts1 val1 released1 ord1 lc2>>.
Proof.
  inv STEP1. inv STEP2. ss.
  exploit MemoryFacts.promise_get1_diff; eauto. i. des.
  esplits; eauto.
  - econs; eauto.
  - econs; eauto.
Qed.

Lemma reorder_read_fulfill
      loc1 ts1 val1 released1 ord1
      loc2 from2 to2 val2 releasedm2 released2 ord2
      lc0 sc0 mem0
      lc1
      lc2 sc2
      (LOC: loc1 <> loc2)
      (ORD: Ordering.le ord1 Ordering.acqrel \/ Ordering.le ord2 Ordering.acqrel)
      (RELM_WF: View.opt_wf releasedm2)
      (RELM_CLOSED: Memory.closed_opt_view releasedm2 mem0)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: fulfill_step lc1 sc0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc2 sc2):
  exists lc1' lc2',
    <<STEP1: fulfill_step lc0 sc0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc1' sc2>> /\
    <<STEP2: Local.read_step lc1' mem0 loc1 ts1 val1 released1 ord1 lc2'>> /\
    <<LOCAL: sim_local lc2' lc2>>.
Proof.
  guardH ORD.
  exploit Local.read_step_future; eauto. i. des.
  inv STEP1. inv STEP2.
  esplits; eauto.
  - econs; eauto.
    + etrans; eauto. unfold TView.write_released. s.
      condtac; econs. repeat (try condtac; aggrtac; try apply WF0).
    + eapply TViewFacts.writable_mon; eauto; try refl. apply TVIEW_FUTURE.
  - econs; eauto.
    s. inv READABLE.
    econs; repeat (try condtac; aggrtac; try apply WF0; eauto; unfold TimeMap.singleton).
  - s. econs; s.
    + apply ReorderTView.read_write_tview; try apply WF0; auto.
    + apply SimPromises.sem_bot.
Qed.

Lemma reorder_read_write
      loc1 ts1 val1 released1 ord1
      loc2 from2 to2 val2 releasedm2 released2 ord2
      lc0 sc0 mem0
      lc1
      lc2 sc2 mem2
      kind
      (LOC: loc1 <> loc2)
      (ORD: Ordering.le ord1 Ordering.acqrel \/ Ordering.le ord2 Ordering.acqrel)
      (RELM_WF: View.opt_wf releasedm2)
      (RELM_CLOSED: Memory.closed_opt_view releasedm2 mem0)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: Local.write_step lc1 sc0 mem0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc2 sc2 mem2 kind):
  exists released2' mem2' lc1' lc2',
    <<STEP1: Local.write_step lc0 sc0 mem0 loc2 from2 to2 val2 releasedm2 released2' ord2 lc1' sc2 mem2' kind>> /\
    <<STEP2: Local.read_step lc1' mem2' loc1 ts1 val1 released1 ord1 lc2'>> /\
    <<LOCAL: sim_local lc2' lc2>> /\
    <<RELEASED: View.opt_le released2' released2>> /\
    <<MEM: sim_memory mem2' mem2>>.
Proof.
  guardH ORD.
  exploit Local.read_step_future; eauto. i. des.
  exploit write_promise_fulfill; try exact STEP2; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit reorder_read_promise_diff; try exact STEP1; try exact STEP0; eauto.
  { ii. inv H. congr. }
  i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit reorder_read_fulfill; try exact STEP5; try exact STEP3; eauto; try by viewtac. i. des.
  exploit promise_fulfill_write; try exact x4; try exact STEP6; eauto; try by viewtac.
  { i. exploit ORD0; eauto. i. des.
    splits; auto. inv STEP1. auto.
  }
  i. des.
  inv STEP1.
  inversion STEP. inv WRITE. hexploit MemoryFacts.promise_get1_diff; try exact PROMISE; eauto.
  { ii. inv H. congr. }
  i. des.
  esplits; eauto.
  inv STEP7. econs; eauto.
Qed.

Lemma reorder_read_update
      loc1 ts1 val1 released1 ord1
      loc2 ts2 val2 released2 ord2
      from3 to3 val3 released3 ord3
      lc0 sc0 mem0
      lc1
      lc2
      lc3 sc3 mem3
      kind
      (LOC: loc1 <> loc2)
      (ORD2: Ordering.le ord2 Ordering.relaxed)
      (ORD3: Ordering.le ord1 Ordering.acqrel \/ Ordering.le ord3 Ordering.acqrel)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: Local.read_step lc1 mem0 loc2 ts2 val2 released2 ord2 lc2)
      (STEP3: Local.write_step lc2 sc0 mem0 loc2 from3 to3 val3 released2 released3 ord3 lc3 sc3 mem3 kind):
  exists released3' mem3' lc1' lc2' lc3',
    <<STEP1: Local.read_step lc0 mem0 loc2 ts2 val2 released2 ord2 lc1'>> /\
    <<STEP2: Local.write_step lc1' sc0 mem0 loc2 from3 to3 val3 released2 released3' ord3 lc2' sc3 mem3' kind>> /\
    <<STEP3: Local.read_step lc2' mem3' loc1 ts1 val1 released1 ord1 lc3'>> /\
    <<LOCAL: sim_local lc3' lc3>> /\
    <<RELEASED: View.opt_le released3' released3>> /\
    <<MEM: sim_memory mem3' mem3>>.
Proof.
  guardH ORD3.
  exploit Local.read_step_future; try exact STEP1; eauto. i. des.
  exploit Local.read_step_future; try exact STEP2; eauto. i. des.
  exploit reorder_read_read; try exact STEP1; try exact STEP2; eauto; try congr. i. des.
  exploit Local.read_step_future; try exact STEP0; eauto. i. des.
  hexploit reorder_read_write; try exact STEP4; try exact STEP_SRC; eauto. i. des.
  esplits; eauto.
Qed.

Lemma reorder_read_fence
      loc1 ts1 val1 released1 ord1
      ordr2 ordw2
      lc0 sc0 mem0
      lc1
      lc2 sc2
      (ORDR2: Ordering.le ordr2 Ordering.relaxed)
      (ORDW2: Ordering.le ordw2 Ordering.acqrel)
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: Local.fence_step lc1 sc0 ordr2 ordw2 lc2 sc2):
  exists lc1' lc2' sc2',
    <<STEP1: Local.fence_step lc0 sc0 ordr2 ordw2 lc1' sc2'>> /\
    <<STEP2: Local.read_step lc1' mem0 loc1 ts1 val1 released1 ord1 lc2'>> /\
    <<LOCAL: sim_local lc2' lc2>> /\
    <<SC: TimeMap.le sc2' sc2>>.
Proof.
  exploit Local.read_step_future; eauto. i. des.
  inv STEP1. inv STEP2. ss.
  esplits.
  - econs; eauto.
  - econs; eauto. s.
    unfold TView.write_fence_tview, TView.read_fence_tview, TView.write_fence_sc.
    econs; repeat (try condtac; try splits; aggrtac; try apply READABLE).
  - s. econs; s.
    + etrans.
      * apply ReorderTView.read_write_fence_tview; auto.
        eapply TViewFacts.read_fence_future; apply WF0.
      * apply TViewFacts.write_fence_tview_mon; try refl.
        apply ReorderTView.read_read_fence_tview; try apply WF0; auto.
        exploit TViewFacts.read_fence_future; try apply WF0; eauto. i. des.
        eapply TViewFacts.read_future; eauto.
    + apply SimPromises.sem_bot.
  - unfold TView.write_fence_sc, TView.read_fence_tview.
    repeat condtac; aggrtac.
Qed.

Lemma reorder_fulfill_read
      loc1 from1 to1 val1 releasedm1 released1 ord1
      loc2 ts2 val2 released2 ord2
      lc0 sc0 mem0
      lc1 sc1
      lc2
      (LOC: loc1 <> loc2)
      (ORD1: Ordering.le ord1 Ordering.relaxed)
      (ORD2: Ordering.le ord2 Ordering.relaxed)
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: fulfill_step lc0 sc0 loc1 from1 to1 val1 releasedm1 released1 ord1 lc1 sc1)
      (STEP2: Local.read_step lc1 mem0 loc2 ts2 val2 released2 ord2 lc2):
  exists lc1',
    <<STEP1: Local.read_step lc0 mem0 loc2 ts2 val2 released2 ord2 lc1'>> /\
    <<STEP2: fulfill_step lc1' sc0 loc1 from1 to1 val1 releasedm1 released1 ord1 lc2 sc1>>.
Proof.
  inv STEP1. inv STEP2.
  hexploit Memory.remove_future; try apply REMOVE; try apply WF0; eauto. i. des.
  esplits.
  - econs; eauto.
    eapply TViewFacts.readable_mon; try apply READABLE; eauto; try refl.
    apply TViewFacts.write_tview_incr. apply WF0.
  - unfold Local.tview at 2.
    unfold Local.promises at 2.
    rewrite ReorderTView.read_write_tview_eq; eauto; try apply WF0; cycle 1.
    { eapply MEM0. eauto. }
    econs; try exact REMOVE; eauto.
    + etrans; eauto. unfold TView.write_released. s. condtac; econs.
      repeat (try condtac; aggrtac).
    + s. unfold View.singleton_ur_if.
      econs; repeat (try condtac; try splits; aggrtac; eauto; try apply WRITABLE;
                     unfold TimeMap.singleton, LocFun.add in *);
        (try by inv WRITABLE; eapply TimeFacts.le_lt_lt; eauto; aggrtac).
Qed.

Lemma reorder_fulfill_promise
      loc1 from1 to1 val1 releasedm1 released1 ord1
      loc2 from2 to2 val2 released2 kind2
      lc0 sc0 mem0
      lc1 sc1
      lc2 mem2
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: fulfill_step lc0 sc0 loc1 from1 to1 val1 releasedm1 released1 ord1 lc1 sc1)
      (STEP2: Local.promise_step lc1 mem0 loc2 from2 to2 val2 released2 lc2 mem2 kind2):
  exists lc1',
    <<STEP1: Local.promise_step lc0 mem0 loc2 from2 to2 val2 released2 lc1' mem2 kind2>> /\
    <<STEP2: fulfill_step lc1' sc0 loc1 from1 to1 val1 releasedm1 released1 ord1 lc2 sc1>>.
Proof.
  inv STEP1. inv STEP2.
  hexploit Memory.remove_future; try apply WF0; eauto. i. des.
  hexploit Memory.promise_future; eauto. i. des.
  exploit MemoryReorder.remove_promise; try apply WF0; eauto. i. des.
  esplits.
  - econs; eauto.
  - econs; eauto.
Qed.

Lemma reorder_fulfill_fulfill
      loc1 from1 to1 val1 releasedm1 released1 ord1
      loc2 from2 to2 val2 releasedm2 released2 ord2
      lc0 sc0 mem0
      lc1 sc1
      lc2 sc2
      (ORD1: Ordering.le ord1 Ordering.relaxed)
      (LOC: loc1 <> loc2)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (REL1_WF: View.opt_wf releasedm1)
      (REL2_WF: View.opt_wf releasedm2)
      (REL2_CLOSED: Memory.closed_opt_view releasedm2 mem0)
      (STEP1: fulfill_step lc0 sc0 loc1 from1 to1 val1 releasedm1 released1 ord1 lc1 sc1)
      (STEP2: fulfill_step lc1 sc1 loc2 from2 to2 val2 releasedm2 released2 ord2 lc2 sc2):
  exists lc1' lc2' sc1' sc2',
    <<STEP1: fulfill_step lc0 sc0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc1' sc1'>> /\
    <<STEP2: fulfill_step lc1' sc1' loc1 from1 to1 val1 releasedm1 released1 ord1 lc2' sc2'>> /\
    <<LOCAL: sim_local lc2' lc2>> /\
    <<SC: TimeMap.le sc2' sc2>>.
Proof.
  inv STEP1. inv STEP2.
  hexploit Memory.remove_future; try apply WF0; eauto. i. des.
  exploit MemoryReorder.remove_remove; try apply REMOVE; try apply REMOVE0; eauto. i. des.
  unfold Local.promises in REMOVE0.
  esplits.
  - econs; eauto.
    + etrans; eauto. unfold TView.write_released. s. condtac; econs.
      repeat (try condtac; aggrtac; try apply WF0).
    + eapply TViewFacts.writable_mon; eauto; try refl.
      * apply TViewFacts.write_tview_incr. apply WF0.
  - econs; eauto.
    + etrans; eauto. unfold TView.write_released. s. condtac; econs.
      repeat (try condtac; aggrtac; try apply WF0).
    + inv WRITABLE. econs; i.
      * eapply TimeFacts.le_lt_lt; [|apply TS].
        repeat (try condtac; viewtac; unfold TimeMap.singleton in *).
  - s. econs; ss.
    + apply ReorderTView.write_write_tview; auto. apply WF0.
    + apply SimPromises.sem_bot.
  - refl.
Qed.

Lemma reorder_fulfill_write
      loc1 from1 to1 val1 releasedm1 released1 ord1
      loc2 from2 to2 val2 releasedm2 released2 ord2 kind2
      lc0 sc0 mem0
      lc1 sc1
      lc2 sc2 mem2
      (ORD1: Ordering.le ord1 Ordering.relaxed)
      (LOC: loc1 <> loc2)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (REL1_WF: View.opt_wf releasedm1)
      (REL1_CLOSED: Memory.closed_opt_view releasedm1 mem0)
      (REL2_WF: View.opt_wf releasedm2)
      (REL2_CLOSED: Memory.closed_opt_view releasedm2 mem0)
      (STEP1: fulfill_step lc0 sc0 loc1 from1 to1 val1 releasedm1 released1 ord1 lc1 sc1)
      (STEP2: Local.write_step lc1 sc1 mem0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc2 sc2 mem2 kind2):
  exists released2' lc1' lc2' sc1' sc2' mem2',
    <<STEP1: Local.write_step lc0 sc0 mem0 loc2 from2 to2 val2 releasedm2 released2' ord2 lc1' sc1' mem2' kind2>> /\
    <<STEP2: fulfill_step lc1' sc1' loc1 from1 to1 val1 releasedm1 released1 ord1 lc2' sc2'>> /\
    <<RELEASED2: View.opt_le released2' released2>> /\
    <<LOCAL: sim_local lc2' lc2>> /\
    <<SC: TimeMap.le sc2' sc2>> /\
    <<MEM: sim_memory mem2' mem2>>.
Proof.
  exploit fulfill_step_future; eauto. i. des.
  exploit write_promise_fulfill; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit reorder_fulfill_promise; try exact STEP1; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit fulfill_step_future; try exact STEP5; try exact WF3; eauto; try by viewtac. i. des.
  exploit reorder_fulfill_fulfill; try exact STEP5; try exact STEP3; eauto; try by viewtac. i. des.
  exploit promise_fulfill_write; eauto.
  { i. exploit ORD; eauto. i. des. splits; ss.
    ii. unfold Memory.get in GET.
    erewrite fulfill_step_promises_diff in GET; eauto.
  }
  i. des.
  esplits; eauto.
Qed.

Lemma reorder_fulfill_update
      loc1 from1 to1 val1 releasedm1 released1 ord1
      loc2 ts2 val2 released2 ord2
      from3 to3 val3 released3 ord3 kind3
      lc0 sc0 mem0
      lc1 sc1
      lc2
      lc3 sc3 mem3
      (LOC: loc1 <> loc2)
      (ORD1: Ordering.le ord1 Ordering.relaxed)
      (ORD2: Ordering.le ord2 Ordering.relaxed)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (REL1_WF: View.opt_wf releasedm1)
      (REL1_CLOSED: Memory.closed_opt_view releasedm1 mem0)
      (STEP1: fulfill_step lc0 sc0 loc1 from1 to1 val1 releasedm1 released1 ord1 lc1 sc1)
      (STEP2: Local.read_step lc1 mem0 loc2 ts2 val2 released2 ord2 lc2)
      (STEP3: Local.write_step lc2 sc1 mem0 loc2 from3 to3 val3 released2 released3 ord3 lc3 sc3 mem3 kind3):
  exists released3' lc1' lc2' lc3' sc2' sc3' mem2',
    <<STEP1: Local.read_step lc0 mem0 loc2 ts2 val2 released2 ord2 lc1'>> /\
    <<STEP2: Local.write_step lc1' sc0 mem0 loc2 from3 to3 val3 released2 released3' ord3 lc2' sc2' mem2' kind3>> /\
    <<STEP3: fulfill_step lc2' sc2' loc1 from1 to1 val1 releasedm1 released1 ord1 lc3' sc3'>> /\
    <<LOCAL: sim_local lc3' lc3>> /\
    <<RELEASED: View.opt_le released3' released3>> /\
    <<SC: TimeMap.le sc3' sc3>> /\
    <<MEM: sim_memory mem2' mem3>>.
Proof.
  exploit fulfill_step_future; try exact STEP1; eauto. i. des.
  exploit Local.read_step_future; try exact STEP2; eauto. i. des.
  exploit reorder_fulfill_read; try exact STEP1; try exact STEP2; eauto. i. des.
  exploit Local.read_step_future; try exact STEP0; eauto. i. des.
  exploit fulfill_step_future; try exact STEP4; eauto. i. des.
  exploit sim_local_write; try exact STEP3; try exact LOCAL; try refl; eauto. i. des.
  exploit reorder_fulfill_write; try exact STEP4; try exact STEP_SRC; eauto. i. des.
  esplits; eauto.
Qed.

Lemma reorder_update_read
      loc1 ts1 val1 released1 ord1
      from2 to2 val2 released2 ord2
      loc3 ts3 val3 released3 ord3
      lc0 sc0 mem0
      lc1
      lc2 sc2
      lc3
      (LOC: loc1 <> loc3)
      (ORD2: Ordering.le ord2 Ordering.relaxed)
      (ORD3: Ordering.le ord3 Ordering.relaxed)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: fulfill_step lc1 sc0 loc1 from2 to2 val2 released1 released2 ord2 lc2 sc2)
      (STEP3: Local.read_step lc2 mem0 loc3 ts3 val3 released3 ord3 lc3):
  exists lc1' lc2',
    <<STEP1: Local.read_step lc0 mem0 loc3 ts3 val3 released3 ord3 lc1'>> /\
    <<STEP2: Local.read_step lc1' mem0 loc1 ts1 val1 released1 ord1 lc2'>> /\
    <<STEP3: fulfill_step lc2' sc0 loc1 from2 to2 val2 released1 released2 ord2 lc3 sc2>>.
Proof.
  exploit Local.read_step_future; try exact STEP1; eauto. i. des.
  exploit fulfill_step_future; try exact STEP2; eauto. i. des.
  exploit reorder_fulfill_read; try exact STEP2; try exact STEP3; eauto. i. des.
  exploit Local.read_step_future; try exact STEP0; eauto. i. des.
  exploit reorder_read_read; try exact STEP1; try exact STEP0; eauto; try congr. i. des.
  esplits; eauto.
Qed.

Lemma reorder_update_promise
      loc1 ts1 val1 released1 ord1
      from2 to2 val2 released2 ord2
      loc3 from3 to3 val3 released3 kind3
      lc0 sc0 mem0
      lc1
      lc2 sc2
      lc3 mem3
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: fulfill_step lc1 sc0 loc1 from2 to2 val2 released1 released2 ord2 lc2 sc2)
      (STEP3: Local.promise_step lc2 mem0 loc3 from3 to3 val3 released3 lc3 mem3 kind3):
  exists released1' lc1' lc2' lc3' sc3',
    <<STEP1: Local.promise_step lc0 mem0 loc3 from3 to3 val3 released3 lc1' mem3 kind3>> /\
    <<STEP2: Local.read_step lc1' mem3 loc1 ts1 val1 released1' ord1 lc2'>> /\
    <<STEP3: fulfill_step lc2' sc0 loc1 from2 to2 val2 released1' released2 ord2 lc3' sc3'>> /\
    <<RELEASED1: View.opt_le released1' released1>> /\
    <<LOCAL: sim_local lc3' lc3>> /\
    <<SC: TimeMap.le sc3' sc2>>.
Proof.
  exploit Local.read_step_future; try exact STEP1; eauto. i. des.
  exploit fulfill_step_future; try exact STEP2; eauto. i. des.
  exploit reorder_fulfill_promise; try exact STEP2; try exact STEP3; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit reorder_read_promise; try exact STEP1; try exact STEP0; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit Local.read_step_future; eauto. i. des.
  exploit sim_local_fulfill; try exact STEP4; try exact LOCAL; try exact REL1;
    try exact WF3; try exact WF5; try refl; eauto; try by viewtac. i. des.
  esplits; eauto.
Qed.

Lemma reorder_update_promise_diff
      loc1 ts1 val1 released1 ord1
      from2 to2 val2 released2 ord2
      loc3 from3 to3 val3 released3 kind3
      lc0 sc0 mem0
      lc1
      lc2 sc2
      lc3 mem3
      (DIFF: (loc1, ts1) <> (loc3, to3))
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: fulfill_step lc1 sc0 loc1 from2 to2 val2 released1 released2 ord2 lc2 sc2)
      (STEP3: Local.promise_step lc2 mem0 loc3 from3 to3 val3 released3 lc3 mem3 kind3):
  exists lc1' lc2',
    <<STEP1: Local.promise_step lc0 mem0 loc3 from3 to3 val3 released3 lc1' mem3 kind3>> /\
    <<STEP2: Local.read_step lc1' mem3 loc1 ts1 val1 released1 ord1 lc2'>> /\
    <<STEP3: fulfill_step lc2' sc0 loc1 from2 to2 val2 released1 released2 ord2 lc3 sc2>>.
Proof.
  exploit Local.read_step_future; try exact STEP1; eauto. i. des.
  exploit fulfill_step_future; try exact STEP2; eauto. i. des.
  exploit reorder_fulfill_promise; try exact STEP2; try exact STEP3; eauto. i. des.
  exploit reorder_read_promise_diff; try exact STEP1; try exact STEP0; eauto. i. des.
  esplits; eauto.
Qed.

Lemma reorder_update_fulfill
      loc1 ts1 val1 released1 ord1
      from2 to2 val2 released2 ord2
      loc3 from3 to3 val3 releasedm3 released3 ord3
      lc0 sc0 mem0
      lc1
      lc2 sc2
      lc3 sc3
      (LOC: loc1 <> loc3)
      (TIME: ts1 <> to2)
      (ORD2: Ordering.le ord2 Ordering.relaxed)
      (ORD3: Ordering.le ord1 Ordering.acqrel \/ Ordering.le ord3 Ordering.acqrel)
      (REL_WF: View.opt_wf releasedm3)
      (REL_CLOSED: Memory.closed_opt_view releasedm3 mem0)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: fulfill_step lc1 sc0 loc1 from2 to2 val2 released1 released2 ord2 lc2 sc2)
      (STEP3: fulfill_step lc2 sc2 loc3 from3 to3 val3 releasedm3 released3 ord3 lc3 sc3):
  exists lc1' lc2' lc3' sc1' sc3',
    <<STEP1: fulfill_step lc0 sc0 loc3 from3 to3 val3 releasedm3 released3 ord3 lc1' sc1'>> /\
    <<STEP2: Local.read_step lc1' mem0 loc1 ts1 val1 released1 ord1 lc2'>> /\
    <<STEP3: fulfill_step lc2' sc1' loc1 from2 to2 val2 released1 released2 ord2 lc3' sc3'>> /\
    <<LOCAL: sim_local lc3' lc3>> /\
    <<SC: TimeMap.le sc3' sc3>>.
Proof.
  guardH ORD3.
  exploit Local.read_step_future; try exact STEP1; eauto. i. des.
  exploit fulfill_step_future; try exact STEP2; eauto. i. des.
  exploit reorder_fulfill_fulfill; try exact STEP2; try exact STEP3; eauto. i. des.
  exploit fulfill_step_future; try exact STEP0; eauto; try by viewtac. i. des.
  exploit reorder_read_fulfill; try exact STEP1; try exact STEP0; eauto; try by viewtac. i. des.
  exploit fulfill_step_future; try exact STEP5; eauto; try by viewtac. i. des.
  exploit Local.read_step_future; try exact STEP6; eauto; try by viewtac. i. des.
  exploit sim_local_fulfill; try exact STEP4; try exact LOCAL0; try refl; eauto. i. des.
  esplits; eauto.
  - etrans; eauto.
  - etrans; eauto.
Qed.

Lemma reorder_update_write
      loc1 ts1 val1 released1 ord1
      from2 to2 val2 released2 ord2
      loc3 from3 to3 val3 releasedm3 released3 ord3 kind3
      lc0 sc0 mem0
      lc1
      lc2 sc2
      lc3 sc3 mem3
      (LOC: loc1 <> loc3)
      (TIME: ts1 <> to2)
      (ORD2: Ordering.le ord2 Ordering.relaxed)
      (ORD3: Ordering.le ord1 Ordering.acqrel \/ Ordering.le ord3 Ordering.acqrel)
      (REL_WF: View.opt_wf releasedm3)
      (REL_CLOSED: Memory.closed_opt_view releasedm3 mem0)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: fulfill_step lc1 sc0 loc1 from2 to2 val2 released1 released2 ord2 lc2 sc2)
      (STEP3: Local.write_step lc2 sc2 mem0 loc3 from3 to3 val3 releasedm3 released3 ord3 lc3 sc3 mem3 kind3):
  exists released2' released3' lc1' lc2' lc3' sc1' sc3' mem1',
    <<STEP1: Local.write_step lc0 sc0 mem0 loc3 from3 to3 val3 releasedm3 released3' ord3 lc1' sc1' mem1' kind3>> /\
    <<STEP2: Local.read_step lc1' mem1' loc1 ts1 val1 released1 ord1 lc2'>> /\
    <<STEP3: fulfill_step lc2' sc1' loc1 from2 to2 val2 released1 released2' ord2 lc3' sc3'>> /\
    <<LOCAL: sim_local lc3' lc3>> /\
    <<RELEASED2: View.opt_le released2' released2>> /\
    <<RELEASED3: View.opt_le released3' released3>> /\
    <<SC: TimeMap.le sc3' sc3>> /\
    <<MEM: sim_memory mem1' mem3>>.
Proof.
  guardH ORD3.
  exploit Local.read_step_future; eauto. i. des.
  exploit fulfill_step_future; eauto. i. des.
  exploit write_promise_fulfill; eauto. i. des.
  exploit reorder_update_promise_diff; try exact STEP1; try exact STEP2; try exact STEP0; eauto.
  { ii. inv H. congr. }
  i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit Local.read_step_future; eauto. i. des.
  hexploit reorder_update_fulfill; try exact STEP6; try exact STEP7; try exact STEP4; eauto; try by viewtac. i. des.
  exploit fulfill_step_future; try exact STEP8; try exact WF3; eauto; try by viewtac. i. des.
  exploit promise_fulfill_write; eauto.
  { i. exploit ORD; eauto. i. des.
    splits; auto.
    erewrite Local.read_step_promises; [|eauto].
    ii. unfold Memory.get in GET. erewrite fulfill_step_promises_diff in GET; eauto.
  }
  i. des.
  inv STEP1.
  inversion STEP. inv WRITE. hexploit MemoryFacts.promise_get1_diff; try exact PROMISE; eauto.
  { ii. inv H. congr. }
  i. des.
  esplits; try exact STEP10; eauto; try refl.
  inv STEP9. econs; eauto.
Qed.

Lemma reorder_update_update
      loc1 ts1 val1 released1 ord1
      from2 to2 val2 released2 ord2
      loc3 ts3 val3 released3 ord3
      from4 to4 val4 released4 ord4 kind4
      lc0 sc0 mem0
      lc1
      lc2 sc2
      lc3
      lc4 sc4 mem4
      (LOC: loc1 <> loc3)
      (TIME: ts1 <> to2)
      (ORD2: Ordering.le ord2 Ordering.relaxed)
      (ORD3: Ordering.le ord3 Ordering.relaxed)
      (ORD: Ordering.le ord1 Ordering.acqrel \/ Ordering.le ord4 Ordering.acqrel)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: fulfill_step lc1 sc0 loc1 from2 to2 val2 released1 released2 ord2 lc2 sc2)
      (STEP3: Local.read_step lc2 mem0 loc3 ts3 val3 released3 ord3 lc3)
      (STEP4: Local.write_step lc3 sc2 mem0 loc3 from4 to4 val4 released3 released4 ord4 lc4 sc4 mem4 kind4):
  exists released2' released4' lc1' lc2' lc3' lc4' sc2' sc4' mem2',
    <<STEP1: Local.read_step lc0 mem0 loc3 ts3 val3 released3 ord3 lc1'>> /\
    <<STEP2: Local.write_step lc1' sc0 mem0 loc3 from4 to4 val4 released3 released4' ord4 lc2' sc2' mem2' kind4>> /\
    <<STEP3: Local.read_step lc2' mem2' loc1 ts1 val1 released1 ord1 lc3'>> /\
    <<STEP4: fulfill_step lc3' sc2' loc1 from2 to2 val2 released1 released2' ord2 lc4' sc4'>> /\
    <<LOCAL: sim_local lc4' lc4>> /\
    <<RELEASED2: View.opt_le released2' released2>> /\
    <<RELEASED4: View.opt_le released4' released4>> /\
    <<SC: TimeMap.le sc4' sc4>> /\
    <<MEM: sim_memory mem2' mem4>>.
Proof.
  guardH ORD.
  exploit reorder_update_read; try exact STEP2; try exact STEP1; try exact STEP3; eauto. i. des.
  exploit Local.read_step_future; try exact STEP0; eauto. i. des.
  hexploit reorder_update_write; try exact STEP5; try exact STEP6; try exact STEP4; eauto. i. des.
  esplits; eauto.
Qed.

Lemma reorder_fence_read
      ordr1 ordw1
      loc2 to2 val2 released2 ord2
      lc0 sc0 mem0
      lc1 sc1
      lc2
      (ORDR1: Ordering.le ordr1 Ordering.acqrel)
      (ORDW1: Ordering.le ordw1 Ordering.relaxed)
      (ORD2: Ordering.le ord2 Ordering.plain \/ Ordering.le Ordering.acqrel ord2)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.fence_step lc0 sc0 ordr1 ordw1 lc1 sc1)
      (STEP2: Local.read_step lc1 mem0 loc2 to2 val2 released2 ord2 lc2):
  exists lc1' lc2' sc2',
    <<STEP1: Local.read_step lc0 mem0 loc2 to2 val2 released2 ord2 lc1'>> /\
    <<STEP2: Local.fence_step lc1' sc0 ordr1 ordw1 lc2' sc2'>> /\
    <<LOCAL: sim_local lc2' lc2>> /\
    <<SC: TimeMap.le sc2' sc1>>.
Proof.
  guardH ORD2. inv STEP1. inv STEP2.
  esplits.
  - econs; eauto.
    eapply TViewFacts.readable_mon; eauto; try refl.
    etrans.
    + apply TViewFacts.write_fence_tview_incr. apply WF0.
    + apply TViewFacts.write_fence_tview_mon; try refl; try apply WF0.
      apply TViewFacts.read_fence_tview_incr. apply WF0.
  - econs; eauto.
  - s. econs; s.
    + inversion MEM0. exploit CLOSED; eauto. i. des.
      exploit TViewFacts.read_future; try exact GET; try apply WF0; eauto. i. des.
      exploit TViewFacts.read_fence_future; try apply WF0; eauto. i. des.
      etrans; [|etrans].
      * apply TViewFacts.write_fence_tview_mon; [|refl|refl|].
        { apply ReorderTView.read_fence_read_tview; auto. apply WF0. }
        { inversion MEM0. exploit CLOSED; eauto. i. des.
          eapply TViewFacts.read_fence_future; eauto.
        }
      * apply ReorderTView.write_fence_read_tview; eauto.
      * apply TViewFacts.read_tview_mon; auto; try refl.
        eapply TViewFacts.write_fence_future; eauto.
    + apply SimPromises.sem_bot.
  - s. etrans.
    + apply TViewFacts.write_fence_sc_mon; [|refl|refl].
      apply ReorderTView.read_fence_read_tview; auto. apply WF0.
    + eapply ReorderTView.write_fence_read_sc; auto.
      eapply TViewFacts.read_fence_future; eauto; apply WF0.
Qed.

Lemma reorder_fence_promise
      ordr1 ordw1
      loc2 from2 to2 val2 released2
      lc0 sc0 mem0
      lc1 sc1
      lc2 mem2
      kind
      (ORDW1: Ordering.le ordw1 Ordering.relaxed)
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.fence_step lc0 sc0 ordr1 ordw1 lc1 sc1)
      (STEP2: Local.promise_step lc1 mem0 loc2 from2 to2 val2 released2 lc2 mem2 kind):
  exists lc1',
    <<STEP1: Local.promise_step lc0 mem0 loc2 from2 to2 val2 released2 lc1' mem2 kind>> /\
    <<STEP2: Local.fence_step lc1' sc0 ordr1 ordw1 lc2 sc1>>.
Proof.
  inv STEP1. inv STEP2. ss.
  esplits.
  - econs; eauto.
  - econs; eauto. s. i. destruct ordw1; inv ORDW1; inv H.
Qed.

Lemma reorder_fence_fulfill
      ordr1 ordw1
      loc2 from2 to2 val2 releasedm2 released2 ord2
      lc0 sc0 mem0
      lc1 sc1
      lc2 sc2
      (ORDR1: Ordering.le ordr1 Ordering.acqrel)
      (ORDW1: Ordering.le ordw1 Ordering.relaxed)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (REL2_WF: View.opt_wf releasedm2)
      (REL2_CLOSED: Memory.closed_opt_view releasedm2 mem0)
      (STEP1: Local.fence_step lc0 sc0 ordr1 ordw1 lc1 sc1)
      (STEP2: fulfill_step lc1 sc1 loc2 from2 to2 val2 releasedm2 released2 ord2 lc2 sc2):
  exists lc1' lc2' sc1' sc2',
    <<STEP1: fulfill_step lc0 sc0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc1' sc1'>> /\
    <<STEP2: Local.fence_step lc1' sc1' ordr1 ordw1 lc2' sc2'>> /\
    <<LOCAL: sim_local lc2' lc2>> /\
    <<SC: TimeMap.le sc2' sc2>>.
Proof.
  inv STEP1. inv STEP2.
  exploit TViewFacts.read_fence_future; try apply WF0; eauto. i. des.
  hexploit TViewFacts.write_fence_future; eauto. i. des.
  esplits.
  - econs; eauto.
    + etrans; eauto. unfold TView.write_released. condtac; econs.
      repeat apply View.join_spec.
      * rewrite <- View.join_l. refl.
      * rewrite <- ? View.join_r.
        eapply TViewFacts.write_tview_mon; eauto; try refl.
        { etrans.
          - apply TViewFacts.write_fence_tview_incr. apply WF0.
          - apply TViewFacts.write_fence_tview_mon; try refl; try apply WF0.
            apply TViewFacts.read_fence_tview_incr. apply WF0.
        }
    + eapply TViewFacts.writable_mon; eauto; try refl.
      * etrans.
        { apply TViewFacts.read_fence_tview_incr. apply WF0. }
        { apply TViewFacts.write_fence_tview_incr.
          eapply TViewFacts.read_fence_future; apply WF0.
        }
      * apply TViewFacts.write_fence_sc_incr.
  - econs; eauto. ss. ii. revert GET.
    erewrite Memory.remove_o; eauto. condtac; ss. i. eapply RELEASE; eauto.
  - s. econs; s.
    + etrans; [|etrans].
      * apply TViewFacts.write_fence_tview_mon; [|refl|refl|].
        { apply ReorderTView.read_fence_write_tview; auto. apply WF0. }
        { exploit Memory.remove_get0; eauto. s. i.
          inv WF0. exploit PROMISES; eauto. i.
          exploit TViewFacts.write_future_fulfill; try exact SC0; eauto.
          { eapply MEM0. eauto. }
          i. des.
          eapply TViewFacts.read_fence_future; eauto.
        }
      * apply ReorderTView.write_fence_write_tview; auto.
      * apply TViewFacts.write_tview_mon; auto; try refl.
        apply TViewFacts.write_fence_sc_incr.
    + apply SimPromises.sem_bot.
  - etrans.
    + apply TViewFacts.write_fence_sc_mon; [|refl|refl].
      apply ReorderTView.read_fence_write_tview; auto. apply WF0.
    + eapply ReorderTView.write_fence_write_sc; auto.
Grab Existential Variables.
  { apply TimeMap.bot. }
Qed.

Lemma reorder_fence_write
      ordr1 ordw1
      loc2 from2 to2 val2 releasedm2 released2 ord2
      lc0 sc0 mem0
      lc1 sc1
      lc2 sc2 mem2 kind
      (ORDR1: Ordering.le ordr1 Ordering.acqrel)
      (ORDW1: Ordering.le ordw1 Ordering.relaxed)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (REL2_WF: View.opt_wf releasedm2)
      (REL2_CLOSED: Memory.closed_opt_view releasedm2 mem0)
      (STEP1: Local.fence_step lc0 sc0 ordr1 ordw1 lc1 sc1)
      (STEP2: Local.write_step lc1 sc1 mem0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc2 sc2 mem2 kind):
  exists released2' lc1' lc2' sc1' sc2' mem1',
    <<STEP1: Local.write_step lc0 sc0 mem0 loc2 from2 to2 val2 releasedm2 released2' ord2 lc1' sc1' mem1' kind>> /\
    <<STEP2: Local.fence_step lc1' sc1' ordr1 ordw1 lc2' sc2'>> /\
    <<LOCAL: sim_local lc2' lc2>> /\
    <<RELEASED2: View.opt_le released2' released2>> /\
    <<SC: TimeMap.le sc2' sc2>> /\
    <<MEM: sim_memory mem1' mem2>>.
Proof.
  exploit Local.fence_step_future; eauto. i. des.
  exploit write_promise_fulfill; eauto. i. des.
  exploit reorder_fence_promise; try exact STEP1; try exact STEP0; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit reorder_fence_fulfill; try exact STEP5; try exact STEP3; eauto; try by viewtac. i. des.
  exploit promise_fulfill_write; eauto.
  { i. exploit ORD; eauto. i. des.
    splits; auto. inv STEP1. auto.
  }
  i. des.
  esplits; eauto.
Qed.

Lemma reorder_fence_fence
      ordr1 ordw1
      ordr2 ordw2
      lc0 sc0 mem0
      lc1 sc1
      lc2 sc2
      (ORDR1: Ordering.le ordr1 Ordering.acqrel)
      (ORDW1: Ordering.le ordw1 Ordering.relaxed)
      (ORDR2: Ordering.le ordr2 Ordering.relaxed)
      (ORDW2: Ordering.le ordw2 Ordering.acqrel)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.fence_step lc0 sc0 ordr1 ordw1 lc1 sc1)
      (STEP2: Local.fence_step lc1 sc1 ordr2 ordw2 lc2 sc2):
  exists lc1' lc2' sc1' sc2',
    <<STEP1: Local.fence_step lc0 sc0 ordr2 ordw2 lc1' sc1'>> /\
    <<STEP2: Local.fence_step lc1' sc1' ordr1 ordw1 lc2' sc2'>> /\
    <<LOCAL: sim_local lc2' lc2>> /\
    <<SC: TimeMap.le sc2' sc2>>.
Proof.
  inv STEP1. inv STEP2. ss.
  esplits.
  - econs; eauto.
  - econs; eauto.
  - ss. econs; ss.
    + unfold TView.write_fence_tview, TView.write_fence_sc.
      econs; repeat (try condtac; aggrtac; try apply WF0).
    + apply SimPromises.sem_bot.
  - unfold TView.write_fence_sc.
    repeat (try condtac; aggrtac; try apply WF0).
Qed.


Require Import Coq.Program.Basics.

Require Import FinProof.Common.
Require Import FinProof.MonadTransformers21.
Require Import FinProof.ProgrammingWith.
Require Import FinProof.StateMonad21Instances.

Require Import UMLang.UrsusLib.
Require Import UMLang.GlobalClassGenerator.ClassGenerator.

Require Import UrsusTVM.Solidity.tvmFunc.
Require Import UrsusTVM.Solidity.tvmTypes.
Require Import String.

Local Open Scope record.
Local Open Scope program_scope.
Local Open Scope glist_scope.

Inductive LocalFields000I := | ι0000 | ι0001 .
Definition LocalState000L := [( XHMap (string*nat) ( XMaybe  ( address ))) : Type; ( XHMap string nat ) : Type ] .
GlobalGeneratePruvendoRecord LocalState000L LocalFields000I .
Opaque LocalState000LRecord .
Inductive LocalFields001I := | ι0010 | ι0011 .
Definition LocalState001L := [( XHMap (string*nat) ( address)) : Type; ( XHMap string nat ) : Type ] .
GlobalGeneratePruvendoRecord LocalState001L LocalFields001I .
Opaque LocalState001LRecord .
Inductive LocalFields010I := | ι0100 | ι0101 .
Definition LocalState010L := [( XHMap (string*nat) ( XUInteger32)) : Type; ( XHMap string nat ) : Type ] .
GlobalGeneratePruvendoRecord LocalState010L LocalFields010I .
Opaque LocalState010LRecord .
Inductive LocalFields011I := | ι0110 | ι0111 .
Definition LocalState011L := [( XHMap (string*nat) ( cell_)) : Type; ( XHMap string nat ) : Type ] .
GlobalGeneratePruvendoRecord LocalState011L LocalFields011I .
Opaque LocalState011LRecord .
Inductive LocalFields100I := | ι1000 | ι1001 .
Definition LocalState100L := [( XHMap (string*nat) ( builder_)) : Type; ( XHMap string nat ) : Type ] .
GlobalGeneratePruvendoRecord LocalState100L LocalFields100I .
Opaque LocalState100LRecord .
Inductive LocalFields101I := | ι1010 | ι1011 .
Definition LocalState101L := [( XHMap (string*nat) ( XUInteger256)) : Type; ( XHMap string nat ) : Type ] .
GlobalGeneratePruvendoRecord LocalState101L LocalFields101I .
Opaque LocalState101LRecord .
Inductive LocalFields110I := | ι1100 | ι1101 .
Definition LocalState110L := [( XHMap (string*nat) ( XHMap  ( XUInteger256 )( XBool ))) : Type; ( XHMap string nat ) : Type ] .
GlobalGeneratePruvendoRecord LocalState110L LocalFields110I .
Opaque LocalState110LRecord .
(**************** LocalState Tree ***************.
  /\
 /\/\
/\/\/\\
**************** LocalState Tree ***************)

Inductive LocalFields00I := | ι000 | ι001 .
Definition LocalState00L := [ LocalState000LRecord ; LocalState001LRecord ] .
GlobalGeneratePruvendoRecord LocalState00L LocalFields00I .
Opaque LocalState00LRecord .

Inductive LocalFields01I := | ι010 | ι011 .
Definition LocalState01L := [ LocalState010LRecord ; LocalState011LRecord ] .
GlobalGeneratePruvendoRecord LocalState01L LocalFields01I .
Opaque LocalState01LRecord .

Inductive LocalFields10I := | ι100 | ι101 .
Definition LocalState10L := [ LocalState100LRecord ; LocalState101LRecord ] .
GlobalGeneratePruvendoRecord LocalState10L LocalFields10I .
Opaque LocalState10LRecord .

Inductive LocalFields0I := | ι00 | ι01 .
Definition LocalState0L := [ LocalState00LRecord ; LocalState01LRecord ] .
GlobalGeneratePruvendoRecord LocalState0L LocalFields0I .
Opaque LocalState0LRecord .

Inductive LocalFields1I := | ι10 | ι11 .
Definition LocalState1L := [ LocalState10LRecord ; LocalState110LRecord ] .
GlobalGeneratePruvendoRecord LocalState1L LocalFields1I .
Opaque LocalState1LRecord .

Inductive LocalFieldsI := | ι0 | ι1 .
Definition LocalStateL := [ LocalState0LRecord ; LocalState1LRecord ] .
GlobalGeneratePruvendoRecord LocalStateL LocalFieldsI .
Opaque LocalStateLRecord .

Transparent

LocalState000LRecord
LocalState001LRecord
LocalState010LRecord
LocalState011LRecord
LocalState100LRecord
LocalState101LRecord
LocalState110LRecord

LocalState00LRecord
LocalState01LRecord
LocalState10LRecord
LocalState1LRecord
LocalState0LRecord.

Transparent LocalStateLRecord.

(* #[global]Program Instance ledgerClass : LedgerClass XBool LedgerLRecord ContractLRecord
                                LocalStateLRecord VMStateLRecord MessagesAndEventsLRecord
                                GlobalParamsLRecord OutgoingMessageParamsLRecord .
Next Obligation.
refine ( VMStateLEmbeddedType VMState_ι_isCommitted ).
Defined.
Next Obligation.
refine ( MessagesAndEventsLEmbeddedType _GlobalParams ) .
Defined.
Next Obligation.
refine ( MessagesAndEventsLEmbeddedType _OutgoingMessageParams ).
Defined.
Fail Next Obligation. *)

#[local]
Obligation Tactic := idtac.

Notation LocalStateField := (LocalStateField XHMap LocalStateLRecord).

        #[global, program] Instance LocalStateField000 : LocalStateField ( XMaybe  ( address )).
        Next Obligation.

eapply TransEmbedded. eapply (_ ι0).
eapply TransEmbedded. eapply (_ ι00).
eapply TransEmbedded. eapply (_ ι000).
        eapply (LocalState000LEmbeddedType ι0001).
        Defined.
        Next Obligation.

eapply TransEmbedded. eapply (_ ι0).
eapply TransEmbedded. eapply (_ ι00).
eapply TransEmbedded. eapply (_ ι000).
        eapply (LocalState000LEmbeddedType ι0000).
        Defined.
        Fail Next Obligation.
        #[local]
        Remove Hints LocalStateField000 : typeclass_instances.

        #[global, program] Instance LocalStateField001 : LocalStateField ( address).
        Next Obligation.

eapply TransEmbedded. eapply (_ ι0).
eapply TransEmbedded. eapply (_ ι00).
eapply TransEmbedded. eapply (_ ι001).
        eapply (LocalState001LEmbeddedType ι0011).
        Defined.
        Next Obligation.

eapply TransEmbedded. eapply (_ ι0).
eapply TransEmbedded. eapply (_ ι00).
eapply TransEmbedded. eapply (_ ι001).
        eapply (LocalState001LEmbeddedType ι0010).
        Defined.
        Fail Next Obligation.
        #[local]
        Remove Hints LocalStateField001 : typeclass_instances.

        #[global, program] Instance LocalStateField010 : LocalStateField ( XUInteger32).
        Next Obligation.

eapply TransEmbedded. eapply (_ ι0).
eapply TransEmbedded. eapply (_ ι01).
eapply TransEmbedded. eapply (_ ι010).
        eapply (LocalState010LEmbeddedType ι0101).
        Defined.
        Next Obligation.

eapply TransEmbedded. eapply (_ ι0).
eapply TransEmbedded. eapply (_ ι01).
eapply TransEmbedded. eapply (_ ι010).
        eapply (LocalState010LEmbeddedType ι0100).
        Defined.
        Fail Next Obligation.
        #[local]
        Remove Hints LocalStateField010 : typeclass_instances.

        #[global, program] Instance LocalStateField011 : LocalStateField ( cell_).
        Next Obligation.

eapply TransEmbedded. eapply (_ ι0).
eapply TransEmbedded. eapply (_ ι01).
eapply TransEmbedded. eapply (_ ι011).
        eapply (LocalState011LEmbeddedType ι0111).
        Defined.
        Next Obligation.

eapply TransEmbedded. eapply (_ ι0).
eapply TransEmbedded. eapply (_ ι01).
eapply TransEmbedded. eapply (_ ι011).
        eapply (LocalState011LEmbeddedType ι0110).
        Defined.
        Fail Next Obligation.
        #[local]
        Remove Hints LocalStateField011 : typeclass_instances.

        #[global, program] Instance LocalStateField100 : LocalStateField ( builder_).
        Next Obligation.

eapply TransEmbedded. eapply (_ ι1).
eapply TransEmbedded. eapply (_ ι10).
eapply TransEmbedded. eapply (_ ι100).
        eapply (LocalState100LEmbeddedType ι1001).
        Defined.
        Next Obligation.

eapply TransEmbedded. eapply (_ ι1).
eapply TransEmbedded. eapply (_ ι10).
eapply TransEmbedded. eapply (_ ι100).
        eapply (LocalState100LEmbeddedType ι1000).
        Defined.
        Fail Next Obligation.
        #[local]
        Remove Hints LocalStateField100 : typeclass_instances.

        #[global, program] Instance LocalStateField101 : LocalStateField ( XUInteger256).
        Next Obligation.

eapply TransEmbedded. eapply (_ ι1).
eapply TransEmbedded. eapply (_ ι10).
eapply TransEmbedded. eapply (_ ι101).
        eapply (LocalState101LEmbeddedType ι1011).
        Defined.
        Next Obligation.

eapply TransEmbedded. eapply (_ ι1).
eapply TransEmbedded. eapply (_ ι10).
eapply TransEmbedded. eapply (_ ι101).
        eapply (LocalState101LEmbeddedType ι1010).
        Defined.
        Fail Next Obligation.
        #[local]
        Remove Hints LocalStateField101 : typeclass_instances.

        #[global, program] Instance LocalStateField110 : LocalStateField ( XHMap  ( XUInteger256 )( XBool )).
        Next Obligation.

eapply TransEmbedded. eapply (_ ι1).
eapply TransEmbedded. eapply (_ ι11).

        eapply (LocalState110LEmbeddedType ι1101).
        Defined.
        Next Obligation.

eapply TransEmbedded. eapply (_ ι1).
eapply TransEmbedded. eapply (_ ι11).

        eapply (LocalState110LEmbeddedType ι1100).
        Defined.
        Fail Next Obligation.
        #[local]
        Remove Hints LocalStateField110 : typeclass_instances.


(** Erasure Safety *)

(** Derive safety from the simulations.
    Erasure proven in [erasure_proof.v] and [erasure_signature.v]
    is stated as a simulation. Here we prove that the simulation
    implies safety.
 *)

(** *Imports*)

(* This file uses Proof Irrelevance:
   forall (P : Prop) (p1 p2 : P), p1 = p2. *)
Require Import ProofIrrelevance.

(* CompCert imports*)
Require Import compcert.common.Memory.

(* VST imports *)
Require Import VST.veric.compcert_rmaps.
Require Import VST.veric.juicy_mem.
Require Import VST.veric.res_predicates.

(* Concurrency Imports *)
Require Import VST.concurrency.common.HybridMachineSig.
Require Import VST.concurrency.juicy.juicy_machine. Import Concur.
Require Import VST.concurrency.common.HybridMachine.
Require Import VST.concurrency.common.lksize.
Require Import VST.concurrency.common.permissions.
(*Erasure simulation*)
Require Import VST.concurrency.juicy.erasure_signature.
Require Import VST.concurrency.juicy.erasure_proof.
Require Import VST.concurrency.juicy.Clight_safety.
Import addressFiniteMap.

(*SSReflect*)
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat eqtype seq.
Require Import Coq.ZArith.ZArith.
Require Import PreOmega.
Require Import VST.concurrency.common.ssromega. (*omega in ssrnat *)
From mathcomp.ssreflect Require Import ssreflect seq.

(*The simulations*)
(* Require Import VST.concurrency.common.machine_simulation.*)

Set Bullet Behavior "Strict Subproofs".

Module ErasureSafety.

  Module ErasureProof := erasure_proof.Parching.
  Module Erasure := ErasureFnctr ErasureProof.
  Import ErasureProof.
  Import Erasure.

  Section ErasureSafety.

  Context (initU: HybridMachineSig.schedule).
  Context (init_rmap : @res JR).
  Context (init_pmap : @res DR).
  Context (init_rmap_perm:  match_rmap_perm init_rmap init_pmap).

  (*Definition local_erasure:= erasure initU init_rmap init_pmap init_rmap_perm.*)
  Definition step_diagram:= ErasureProof.core_diagram.

  Import JuicyMachineModule.THE_JUICY_MACHINE.
  Import ClightMachine.Clight_newMachine.DMS.

  Existing Instance DMS.

  Lemma erasure_safety': forall n ge sch js jtr ds dtr m,
      ErasureProof.match_st ge js ds ->
      DryHybridMachine.invariant ds ->
    jm_csafe (sch, jtr, js) m n ->
    HybridMachineSig.HybridCoarseMachine.csafe (sch, dtr, ds) m n.
  Proof.
    induction n.
    intros. constructor.
    intros. inversion H1.
    - constructor; simpl. unfold HybridMachineSig.halted_machine; simpl.
      unfold JuicyMachine.halted_machine in H2; simpl in H2.
      change JuicyMachine.schedPeek with
      HybridMachineSig.schedPeek in H2.
      destruct ( HybridMachineSig.schedPeek sch ) eqn:AA;
      inversion H; auto.
    - { simpl in Hstep.
        unfold JuicyMachine.MachStep in Hstep; simpl in Hstep.
        assert (step_diagram:=step_diagram).
        specialize (step_diagram ge m initU sch sch (Some init_rmap) (Some init_pmap)).
        specialize (step_diagram ds dtr js tp' jtr tr' m').
        unfold corestep in step_diagram; simpl in step_diagram.
        unfold JuicyMachine.MachStep in step_diagram; simpl in step_diagram.
        eapply step_diagram in Hstep; try eassumption.
        destruct Hstep as [ds' [dinv' [MATCH' [dtr' stp']]]].
        destruct Hsafe as [[? [Hphi Hext]] Hsafe].
        specialize (Hsafe _ Hphi [:: Some (ghost_PCM.ext_ref tt, NoneP)])
          as (? & ? & ? & ? & Hr & ? & Hsafe); auto.
        { apply join_sub_refl. }
        eapply MTCH_tp_update in MATCH'; eauto.
        eapply IHn in Hsafe; eauto.
        econstructor 3; eauto.
        apply stp'. }
    - { simpl in Hstep.
        unfold JuicyMachine.MachStep in Hstep; simpl in Hstep.
        assert (step_diagram:=step_diagram).
        specialize (step_diagram ge m initU sch (HybridMachineSig.schedSkip sch) (Some init_rmap) (Some init_pmap)).
        specialize (step_diagram ds dtr js tp' jtr tr' m').
        unfold corestep in step_diagram; simpl in step_diagram.
        unfold JuicyMachine.MachStep in step_diagram; simpl in step_diagram.
        eapply step_diagram in Hstep; try eassumption.
        destruct Hstep as [ds' [dinv' [MATCH' [dtr' stp']]]].
        econstructor 4; eauto.
        { apply stp'. }
        intro U''; specialize (Hsafe U'').
        destruct Hsafe as [[? [Hphi Hext]] Hsafe].
        specialize (Hsafe _ Hphi [:: Some (ghost_PCM.ext_ref tt, NoneP)])
          as (? & ? & ? & ? & Hr & ? & Hsafe); auto.
        { apply join_sub_refl. }
        eapply MTCH_tp_update in MATCH'; eauto. }
Qed.

  Theorem erasure_safety: forall ge cd j js ds m n,
      Erasure.match_state ge cd j js m ds m ->
      jm_csafe js m n ->
      HybridMachineSig.HybridCoarseMachine.csafe ds m n.
  Proof.
    intros ? ? ? ? ? ? ? MATCH jsafe.
    inversion MATCH. subst.
    eapply erasure_safety'; eauto.
  Qed.

  (*there is something weird about this theorem.*)
  (*The injection is trivial... but it shouldn't*)
(*  Theorem initial_safety:
    forall genv (U : HybridMachineSig.schedule) (js : jstate genv)
      (vals : seq Values.val) m
      (rmap0 : rmap) (pmap : access_map * access_map) main h,
      match_rmap_perm rmap0 pmap ->
      no_locks_perm rmap0 ->
      initial_core (JMachineSem U (Some rmap0)) h
         m (U, [::], js) main vals  ->
      exists (ds : dstate genv),
        initial_core (ClightMachineSem U (Some pmap)) h
                     m (U, [::], ds) main vals /\
        invariant ds /\ match_st genv js ds.
  Proof.
    intros ? ? ? ? ? ? ? ? ? mtch_perms no_locks init.
    destruct (init_diagram genv (fun _ => None) U js vals m rmap0 pmap main h)
    as [ds [dinit [dinv MTCH]]]; eauto.
    unfold init_inj_ok; intros b b' ofs H. inversion H.
  Qed.*)

  End ErasureSafety.

End ErasureSafety.

Require Import VST.concurrency.juicy.semax_to_juicy_machine.

Lemma no_locks_no_locks_perm : forall r, Parching.no_locks_perm r <-> initial_world.no_locks r.
Proof.
  unfold Parching.no_locks_perm, initial_world.no_locks, perm_of_res_lock; split; intros.
  - destruct addr as (b, ofs); specialize (H b ofs).
    destruct (r @ (b, ofs)); try discriminate.
    destruct (perm_of_sh (Share.glb Share.Rsh sh0)) eqn: Hsh.
    destruct k; discriminate.
    { contradiction r0.
      apply perm_of_empty_inv in Hsh as ->; auto. }
  - specialize (H (b, ofs)).
    destruct (r @ (b, ofs)); auto.
    specialize (H sh r0).
    destruct k; auto. specialize (H n i p).  contradiction; auto.
Qed.

(* unused *)
Lemma juice2Perm_match : forall m r, access_cohere' m r ->
  Parching.match_rmap_perm r (juice2Perm r m, empty_map).
Proof.
  split; auto; simpl.
  intros; apply juic2Perm_correct; auto.
Qed.

Section DrySafety.
(* combining results from semax_to_juicy_machine and erasure_proof *)

  Variable (CPROOF : CSL_proof).

  Instance Sem : Semantics := ClightSemanticsForMachines.Clight_newSem (Clight.globalenv CPROOF.(CSL_prog)).
  Definition ge := Clight.globalenv CPROOF.(CSL_prog).
  Instance DTP : threadPool.ThreadPool.ThreadPool := Parching.DTP ge.
  Instance DMS : HybridMachineSig.MachineSig := Parching.DMS ge.
  Definition init_mem := proj1_sig (init_mem CPROOF).
  Definition init_rmap n := m_phi (initial_jm CPROOF n).

  Lemma init_match n : Parching.match_rmap_perm (init_rmap n) (getCurPerm init_mem, empty_map).
  Proof.
    split; auto; simpl.
    unfold init_rmap, initial_jm, spr.
    destruct (semax_prog.semax_prog_rule' _ _ _ _ _ _ _ _) as (? & ? & ? & s); simpl.
    destruct (s n tt) as (jm & ? & ? & ? & ? & ? & ?); simpl.
    destruct jm; simpl in *; subst; intros.
    rewrite <- (JMaccess (b, ofs)).
    unfold access_at, PMap.get; simpl.
    rewrite PTree.gmap1.
    fold init_mem; destruct ((snd (Mem.mem_access init_mem)) ! b); auto.
  Qed.

  Lemma init_no_locks n : Parching.no_locks_perm (init_rmap n).
  Proof.
    apply no_locks_no_locks_perm.
    unfold init_rmap, initial_jm, spr.
    destruct (semax_prog.semax_prog_rule' _ _ _ _ _ _ _ _) as (? & ? & ? & s); simpl.
    destruct (s n tt) as (jm & ? & ? & ? & ? & ? & ?); auto.
  Qed.

  (**  Theorem to export.
       Explanation:

   *)
  Theorem dry_safety_initial_state (sch : HybridMachineSig.schedule) (n : nat) :
    HybridMachineSig.HybridCoarseMachine.csafe
      (sch, [::],
      DryHybridMachine.initial_machine(Sem := Sem) (getCurPerm init_mem)
        (initial_corestate CPROOF)) init_mem n.
  Proof.
    eapply (ErasureSafety.erasure_safety sch (init_rmap n)
      (juice2Perm (init_rmap n) init_mem, empty_map)) with (cd := tt)(j := fun _ => None),
      (* Note that any injection will work here. *)
      safety_initial_state.
    constructor.
    { apply dry_machine_lemmas.ThreadPoolWF.initial_invariant0. }
    apply Parching.MTCH_initial with (pmap := (getCurPerm init_mem, empty_map)).
    - apply init_match.
    - apply init_no_locks.
  Qed.

  Context {SW : spawn_wrapper CPROOF}.

  Notation ClightSem:= ClightSemanticsForMachines.ClightSem.
  Theorem Clight_initial_safe (sch : HybridMachineSig.schedule) (n : nat) :
    HybridMachineSig.HybridCoarseMachine.csafe
      (Sem := ClightSem ge)
      (ThreadPool:= threadPool.OrdinalPool.OrdinalThreadPool(Sem:=ClightSem ge))
      (machineSig:= HybridMachine.DryHybridMachine.DryHybridMachineSig)
      (sch, nil,
       DryHybridMachine.initial_machine(Sem := ClightSem ge)
                                       (permissions.getCurPerm init_mem)
                                       (initial_Clight_state CPROOF)) init_mem n.
  Proof.
    apply Clight_new_Clight_safety; auto.
    apply dry_safety_initial_state.
  Qed.

  (*Print Assumptions Clight_initial_safe.*)
End DrySafety.