Require Import Bool.
Require Import List.

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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.

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

Require Import SimMemory.
Require Import MemorySplit.
Require Import MemoryMerge.

Require Import Syntax.
Require Import Semantics.

Set Implicit Arguments.

Inductive fulfill_step (lc1:Local.t) (sc1:TimeMap.t) (loc:Loc.t) (from to:Time.t) (val:Const.t) (releasedm released:option View.t) (ord:Ordering.t): forall (lc2:Local.t) (sc2:TimeMap.t), Prop :=
| step_fulfill
    promises2
    (REL_LE: View.opt_le (TView.write_released lc1.(Local.tview) sc1 loc to releasedm ord) released)
    (REL_WF: View.opt_wf released)
    (WRITABLE: TView.writable lc1.(Local.tview).(TView.cur) sc1 loc to ord)
    (REMOVE: Memory.remove lc1.(Local.promises) loc from to val released promises2)
    (TIME: Time.lt from to):
    fulfill_step lc1 sc1 loc from to val releasedm released ord
                 (Local.mk (TView.write_tview lc1.(Local.tview) sc1 loc to ord) promises2)
                 sc1
.

Lemma fulfill_step_future lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2
      (STEP: fulfill_step lc1 sc1 loc from to val releasedm released ord lc2 sc2)
      (REL: Memory.closed_opt_view releasedm mem1)
      (WF1: Local.wf lc1 mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (CLOSED1: Memory.closed mem1):
  <<WF2: Local.wf lc2 mem1>> /\
  <<SC2: Memory.closed_timemap sc2 mem1>> /\
  <<SC_FUTURE: TimeMap.le sc1 sc2>>.
Proof.
  inv STEP.
  hexploit Memory.remove_future; try apply REMOVE; try apply WF1; eauto. i. des.
  exploit Memory.remove_get0; eauto. i.
  inversion WF1. exploit PROMISES; eauto. i.
  exploit TViewFacts.write_future_fulfill; try apply x; try apply SC1; try apply WF1; eauto.
  { eapply CLOSED1. eauto. }
  i. des.
  esplits; eauto.
  - econs; eauto.
  - refl.
Qed.

Lemma write_promise_fulfill
      lc0 sc0 mem0 loc from to val releasedm released ord lc2 sc2 mem2 kind
      (WRITE: Local.write_step lc0 sc0 mem0 loc from to val releasedm released ord lc2 sc2 mem2 kind)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem0)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0):
  exists lc1,
    <<STEP1: Local.promise_step lc0 mem0 loc from to val released lc1 mem2 kind>> /\
    <<STEP2: fulfill_step lc1 sc0 loc from to val releasedm released ord lc2 sc2>> /\
    <<REL: released = TView.write_released lc0.(Local.tview) sc0 loc to releasedm ord>> /\
    <<ORD: Ordering.le Ordering.strong_relaxed ord ->
           Memory.nonsynch_loc loc lc0.(Local.promises) /\
           kind = Memory.op_kind_add>>.
Proof.
  exploit Local.write_step_future; eauto. i. des.
  inv WRITE. inv WRITE0. esplits; eauto.
  - econs; eauto.
  - refine (step_fulfill _ _ _ _ _ _ _); auto.
    + refl.
    + eapply MemoryFacts.promise_time_lt. eauto.
Qed.

Lemma fulfill_write
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2
      (FULFILL: fulfill_step lc1 sc1 loc from to val releasedm released ord lc2 sc2)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem1)
      (ORD: Ordering.le ord Ordering.relaxed)
      (WF1: Local.wf lc1 mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (MEM1: Memory.closed mem1):
  exists released' mem2',
    <<STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released' ord lc2 sc2 mem2' (Memory.op_kind_lower released)>> /\
    <<REL_LE: View.opt_le released' released>> /\
    <<MEM: sim_memory mem2' mem1>>.
Proof.
  inv FULFILL.
  exploit TViewFacts.write_future_fulfill;
    try exact REL_CLOSED; try exact SC1; eauto; try by apply WF1.
  { apply WF1. eapply Memory.remove_get0. eauto. }
  i. des.
  exploit MemorySplit.remove_promise_remove;
    try exact REMOVE; eauto; try apply WF1; try refl.
  { eapply MEM1. apply WF1. eapply Memory.remove_get0. eauto. }
  i. des.
  esplits; eauto.
  - econs; eauto.
    + econs; eauto.
    + i. destruct ord; inv ORD; inv H.
  - eapply promise_lower_sim_memory. eauto.
Qed.

Lemma promise_fulfill_write
      lc0 sc0 mem0 loc from to val releasedm released ord lc1 lc2 sc2 mem2 kind
      (PROMISE: Local.promise_step lc0 mem0 loc from to val released lc1 mem2 kind)
      (FULFILL: fulfill_step lc1 sc0 loc from to val releasedm released ord lc2 sc2)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem0)
      (ORD: Ordering.le Ordering.strong_relaxed ord ->
            Memory.nonsynch_loc loc lc0.(Local.promises) /\
            kind = Memory.op_kind_add)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0):
  exists released' mem2',
    <<STEP: Local.write_step lc0 sc0 mem0 loc from to val releasedm released' ord lc2 sc2 mem2' kind>> /\
    <<REL_LE: View.opt_le released' released>> /\
    <<MEM: sim_memory mem2' mem2>> /\
    <<REL: released' = TView.write_released lc0.(Local.tview) sc0 loc to releasedm ord>>.
Proof.
  exploit Local.promise_step_future; eauto. i. des.
  inv PROMISE. inv FULFILL. ss.
  exploit TViewFacts.write_future_fulfill; try exact REL_WF; eauto; try by apply WF2.
  { eapply Memory.future_closed_opt_view; eauto. }
  { apply WF2. eapply Memory.promise_get2. eauto. }
  s. i. des.
  exploit MemorySplit.remove_promise_remove;
    try exact REMOVE; eauto; try apply WF2; try refl. i. des.
  esplits; eauto.
  - econs; eauto. econs; eauto.
    eapply MemoryMerge.promise_promise_promise; eauto.
  - eapply promise_lower_sim_memory. eauto.
Qed.

Lemma promise_fulfill_write_exact
      lc0 sc0 mem0 loc from to val releasedm released ord lc1 lc2 sc2 mem2 kind
      (PROMISE: Local.promise_step lc0 mem0 loc from to val released lc1 mem2 kind)
      (FULFILL: fulfill_step lc1 sc0 loc from to val releasedm released ord lc2 sc2)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem0)
      (ORD: Ordering.le Ordering.strong_relaxed ord ->
            Memory.nonsynch_loc loc lc0.(Local.promises) /\
            kind = Memory.op_kind_add)
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (REL: released = TView.write_released lc0.(Local.tview) sc0 loc to releasedm ord):
  Local.write_step lc0 sc0 mem0 loc from to val releasedm released ord lc2 sc2 mem2 kind.
Proof.
  exploit Local.promise_step_future; eauto. i. des.
  inv PROMISE. inv FULFILL.
  exploit MemorySplit.remove_promise_remove;
    try exact REMOVE; eauto; try apply WF2; try refl. i. des.
  refine (Local.write_step_intro _ _ _ _ _ _); eauto.
  econs; eauto.
Qed.

Lemma fulfill_step_promises_diff
      lc1 sc1 loc1 from to val releasedm released ord lc2 sc2 loc2
      (LOC: loc1 <> loc2)
      (FULFILL: fulfill_step lc1 sc1 loc1 from to val releasedm released ord lc2 sc2):
  lc1.(Local.promises) loc2 = lc2.(Local.promises) loc2.
Proof.
  inv FULFILL. inv REMOVE. unfold LocFun.add. s.
  condtac; [congr|]. auto.
Qed.


Require Import Coqlib.
Require Import ITreelib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.
Require Import HoareDef STB.
Require Import ProofMode.

Set Implicit Arguments.

Let _memRA: URA.t := (mblock ==> Z ==> (Excl.t val))%ra.
Compute (URA.car (t:=_memRA)).
Instance memRA: URA.t := Auth.t _memRA.
Compute (URA.car).

Local Arguments Z.of_nat: simpl nomatch.

Section PROOF.
  Context `{@GRA.inG memRA Σ}.

  Definition _points_to (loc: mblock * Z) (vs: list val): _memRA :=
    let (b, ofs) := loc in
    (fun _b _ofs => if (dec _b b) && ((ofs <=? _ofs) && (_ofs <? (ofs + Z.of_nat (List.length vs))))%Z
                    then (List.nth_error vs (Z.to_nat (_ofs - ofs))) else ε)
  .

  (* Opaque _points_to. *)
  Lemma unfold_points_to loc vs:
    _points_to loc vs =
    let (b, ofs) := loc in
    (fun _b _ofs => if (dec _b b) && ((ofs <=? _ofs) && (_ofs <? (ofs + Z.of_nat (List.length vs))))%Z
                    then (List.nth_error vs (Z.to_nat (_ofs - ofs))) else ε)
  .
  Proof. refl. Qed.

  Definition points_to (loc: mblock * Z) (vs: list val): memRA := Auth.white (_points_to loc vs).

  Definition var_points_to (skenv: SkEnv.t) (var: gname) (v: val): memRA :=
    match (skenv.(SkEnv.id2blk) var) with
    | Some  blk => points_to (blk, 0%Z) [v]
    | None => ε
    end.

  Lemma points_to_split
        blk ofs hd tl
    :
      (points_to (blk, ofs) (hd :: tl)) = (points_to (blk, ofs) [hd]) ⋅ (points_to (blk, (ofs + 1)%Z) tl)
  .
  Proof.
    ss. unfold points_to. unfold Auth.white. repeat (rewrite URA.unfold_add; ss).
    f_equal.
    repeat (apply func_ext; i).
    des_ifs; bsimpl; des; des_sumbool; subst; ss;
      try rewrite Z.leb_gt in *; try rewrite Z.leb_le in *; try rewrite Z.ltb_ge in *; try rewrite Z.ltb_lt in *; try lia.
    - clear_tac. subst. rewrite Zpos_P_of_succ_nat in *. rewrite <- Zlength_correct in *.
      assert(x0 = ofs). { lia. } subst.
      rewrite Z.sub_diag in *. ss.
    - clear_tac. rewrite Zpos_P_of_succ_nat in *. rewrite <- Zlength_correct in *.
      destruct (Z.to_nat (x0 - ofs)) eqn:T; ss.
      { exfalso. lia. }
      rewrite Z.sub_add_distr in *. rewrite Z2Nat.inj_sub in Heq1; ss. rewrite T in *. ss. rewrite Nat.sub_0_r in *. ss.
    - clear_tac. rewrite Zpos_P_of_succ_nat in *. rewrite <- Zlength_correct in *.
      destruct (Z.to_nat (x0 - ofs)) eqn:T; ss.
      { exfalso. lia. }
      rewrite Z.sub_add_distr in *. rewrite Z2Nat.inj_sub in Heq1; ss. rewrite T in *. ss. rewrite Nat.sub_0_r in *. ss.
    - clear_tac. rewrite Zpos_P_of_succ_nat in *. rewrite <- Zlength_correct in *.
      assert(x0 = ofs). { lia. } subst.
      rewrite Z.sub_diag in *. ss.
    - clear_tac. rewrite Zpos_P_of_succ_nat in *. rewrite <- Zlength_correct in *.
      destruct (Z.to_nat (x0 - ofs)) eqn:T; ss.
      { exfalso. lia. }
      rewrite Z.sub_add_distr in *. rewrite Z2Nat.inj_sub in Heq1; ss. rewrite T in *. ss. rewrite Nat.sub_0_r in *. ss.
    - clear_tac. rewrite Zpos_P_of_succ_nat in *. rewrite <- Zlength_correct in *.
      assert(x0 = ofs). { lia. } subst.
      rewrite Z.sub_diag in *. ss.
  Qed.

  Definition initial_mem_mr (csl: gname -> bool) (sk: Sk.t): _memRA :=
    fun blk ofs =>
      match List.nth_error sk blk with
      | Some (g, gd) =>
        match gd with
        | Sk.Gfun => ε
        | Sk.Gvar gv => if csl g then if (dec ofs 0%Z) then Some (Vint gv) else ε else ε
        end
      | _ => ε
      end.

(* Lemma points_tos_points_to *)
(*       loc v *)
(*   : *)
(*     (points_to loc v) = (points_tos loc [v]) *)
(* . *)
(* Proof. *)
(*   apply func_ext. i. *)
(*   apply prop_ext. *)
(*   ss. split; i; r. *)
(*   - des_ifs. ss. eapply Own_extends; et. rp; try refl. repeat f_equal. repeat (apply func_ext; i). *)
(*     des_ifs; bsimpl; des; des_sumbool; ss; clarify. *)
(*     + rewrite Z.sub_diag; ss. *)
(*     + rewrite Z.leb_refl in *; ss. *)
(*     + rewrite Z.ltb_ge in *. lia. *)
(*     + rewrite Z.ltb_lt in *. lia. *)
(*   - des_ifs. ss. eapply Own_extends; et. rp; try refl. repeat f_equal. repeat (apply func_ext; i). *)
(*     des_ifs; bsimpl; des; des_sumbool; ss; clarify. *)
(*     + rewrite Z.sub_diag; ss. *)
(*     + rewrite Z.ltb_lt in *. lia. *)
(*     + rewrite Z.leb_refl in *; ss. *)
(*     + rewrite Z.ltb_ge in *. lia. *)
(* Qed. *)

End PROOF.

Notation "loc |-> vs" := (points_to loc vs) (at level 20).

Section AUX.
  Context `{@GRA.inG memRA Σ}.

  Lemma points_to_disj
        ptr x0 x1
    :
      (OwnM (ptr |-> [x0]) -∗ OwnM (ptr |-> [x1]) -* ⌜False⌝)
  .
  Proof.
    destruct ptr as [blk ofs].
    iIntros "A B". iCombine "A B" as "A". iOwnWf "A" as WF0.
    unfold points_to in WF0. rewrite ! unfold_points_to in *. repeat (ur in WF0); ss.
    specialize (WF0 blk ofs). des_ifs; bsimpl; des; des_sumbool; zsimpl; ss; try lia.
  Qed.

  Fixpoint is_list (ll: val) (xs: list val): iProp :=
    match xs with
    | [] => (⌜ll = Vnullptr⌝: iProp)%I
    | xhd :: xtl =>
      (∃ lhd ltl, ⌜ll = Vptr lhd 0⌝ ** (OwnM ((lhd,0%Z) |-> [xhd; ltl]))
                             ** is_list ltl xtl: iProp)%I
    end
  .

  Lemma unfold_is_list: forall ll xs,
      is_list ll xs =
      match xs with
      | [] => (⌜ll = Vnullptr⌝: iProp)%I
      | xhd :: xtl =>
        (∃ lhd ltl, ⌜ll = Vptr lhd 0⌝ ** (OwnM ((lhd,0%Z) |-> [xhd; ltl]))
                               ** is_list ltl xtl: iProp)%I
      end
  .
  Proof.
    i. destruct xs; auto.
  Qed.

  Lemma unfold_is_list_cons: forall ll xhd xtl,
      is_list ll (xhd :: xtl) =
      (∃ lhd ltl, ⌜ll = Vptr lhd 0⌝ ** (OwnM ((lhd,0%Z) |-> [xhd; ltl]))
                             ** is_list ltl xtl: iProp)%I.
  Proof.
    i. eapply unfold_is_list.
  Qed.

  Lemma is_list_wf
        ll xs
    :
      (is_list ll xs) -∗ (⌜(ll = Vnullptr) \/ (match ll with | Vptr _ 0 => True | _ => False end)⌝)
  .
  Proof.
    iIntros "H0". destruct xs; ss; et.
    { iPure "H0" as H0. iPureIntro. left. et. }
    iDestruct "H0" as (lhd ltl) "[[H0 H1] H2]".
    iPure "H0" as H0. iPureIntro. right. subst. et.
  Qed.

  (* Global Opaque is_list. *)
End AUX.

Section PROOF.
  Context `{@GRA.inG memRA Σ}.

  Definition alloc_spec: fspec :=
    (mk_simple (fun sz => (
                    (ord_pure 0),
                    (fun varg => (⌜varg = [Vint (Z.of_nat sz)]↑ /\ (8 * (Z.of_nat sz) < modulus_64)%Z⌝: iProp)%I),
                    (fun vret => (∃ b, (⌜vret = (Vptr b 0)↑⌝)
                                         ** OwnM ((b, 0%Z) |-> (List.repeat Vundef sz))): iProp)%I
    ))).

  Definition free_spec: fspec :=
    (mk_simple (fun '(b, ofs) => (
                    (ord_pure 0),
                    (fun varg => (∃ v, (⌜varg = ([Vptr b ofs])↑⌝) ** OwnM ((b, ofs) |-> [v]))%I),
                    fun vret => ⌜vret = (Vint 0)↑⌝%I
    ))).

  Definition load_spec: fspec :=
    (mk_simple (fun '(b, ofs, v) => (
                    (ord_pure 0),
                    (fun varg => (⌜varg = ([Vptr b ofs])↑⌝) ** OwnM(((b, ofs) |-> [v]))),
                    (fun vret => OwnM((b, ofs) |-> [v]) ** ⌜vret = v↑⌝)
    ))).

  Definition store_spec: fspec :=
    (mk_simple
       (fun '(b, ofs, v_new) => (
            (ord_pure 0),
            (fun varg => (∃ v_old, (⌜varg = ([Vptr b ofs ; v_new])↑⌝) ** OwnM((b, ofs) |-> [v_old]))%I),
            (fun vret => OwnM((b, ofs) |-> [v_new]) ** ⌜vret = (Vint 0)↑⌝
    )))).

  Definition cmp_spec: fspec :=
    (mk_simple
       (fun '(result, resource) => (
            (ord_pure 0),
            (fun varg =>
               ((∃ b ofs v, ⌜varg = [Vptr b ofs; Vnullptr]↑⌝ ** ⌜resource = ((b, ofs) |-> [v])⌝ ** ⌜result = false⌝) ∨
                (∃ b ofs v, ⌜varg = [Vnullptr; Vptr b ofs]↑⌝ ** ⌜resource = ((b, ofs) |-> [v])⌝ ** ⌜result = false⌝) ∨
                (∃ b0 ofs0 v0 b1 ofs1 v1, ⌜varg = [Vptr b0 ofs0; Vptr b1 ofs1]↑⌝ ** ⌜resource = (((b0, ofs0) |-> [v0])) ⋅ ((b1, ofs1) |-> [v1])⌝ ** ⌜result = false⌝) ∨
                (∃ b ofs v, ⌜varg = [Vptr b ofs; Vptr b  ofs]↑⌝ ** ⌜resource = ((b, ofs) |-> [v])⌝ ** ⌜result = true⌝) ∨
                (⌜varg = [Vnullptr; Vnullptr]↑ /\ result = true⌝))
                 ** OwnM(resource)
            ),
            (fun vret => OwnM(resource) ** ⌜vret = (if result then Vint 1 else Vint 0)↑⌝)
    ))).

  Definition MemStb: list (gname * fspec).
    eapply (Seal.sealing "stb").
    apply [("alloc", alloc_spec) ; ("free", free_spec) ; ("load", load_spec) ; ("store", store_spec) ; ("cmp", cmp_spec)].
  Defined.

  Definition MemSbtb: list (gname * fspecbody) :=
    [("alloc", mk_specbody alloc_spec (fun _ => trigger (Choose _)));
    ("free",   mk_specbody free_spec (fun _ => trigger (Choose _)));
    ("load",   mk_specbody load_spec (fun _ => trigger (Choose _)));
    ("store",  mk_specbody store_spec (fun _ => trigger (Choose _)));
    ("cmp",    mk_specbody cmp_spec (fun _ => trigger (Choose _)))
    ]
  .

  Variable csl: gname -> bool.

  Definition SMemSem (sk: Sk.t): SModSem.t := {|
    SModSem.fnsems := MemSbtb;
    SModSem.mn := "Mem";
    SModSem.initial_mr := (GRA.embed (Auth.black (initial_mem_mr csl sk)));
    SModSem.initial_st := tt↑;
  |}
  .

  Definition SMem: SMod.t := {|
    SMod.get_modsem := SMemSem;
    SMod.sk := Sk.unit;
  |}
  .

  Definition Mem: Mod.t := (SMod.to_tgt (fun _ => to_stb [])) SMem.

End PROOF.
Global Hint Unfold MemStb: stb.

Global Opaque _points_to.


Require Import Coq.Strings.String.

From mathcomp Require Import
  ssreflect ssrfun ssrbool ssrnat eqtype choice seq ssrnum ssrint ssralg bigop.

From deriving Require Import deriving.
From extructures Require Import ord fset fmap fperm.

From CoqUtils Require Import nominal.

From memsafe Require Import basic.

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

Section Cast.

Local Open Scope fset_scope.

Lemma eval_com_domm safe ls h ls' h' c k :
  fsubset (vars_c c) (domm ls) ->
  eval_com safe c (ls, h) k = Done (ls', h') ->
  domm ls' = domm ls.
Proof.
elim: k ls ls' h h' c => [|k IH] //= ls ls' h h'.
case=> [x e|x e|e e'|x e|e| |c1 c2|e c1 c2|e c] //=.
- rewrite fsubU1set=> /andP [Px Pe] [<- _]; rewrite domm_set.
  apply/eqP; rewrite eqEfsubset; apply/andP; split.
    by rewrite fsubU1set Px fsubsetxx.
  by rewrite fsubsetUr.
- case: eval_expr => // p sz; case: (h p)=> [v|] //=.
  rewrite fsubU1set=> /andP [Px Pe] [<- _]; rewrite domm_set.
  apply/eqP; rewrite eqEfsubset; apply/andP; split.
    by rewrite fsubU1set Px fsubsetxx.
  by rewrite fsubsetUr.
- case: eval_expr => // p sz; rewrite /updm; case: (h p)=> [v|] //=.
  by rewrite fsubUset=> /andP [Pe Pe'] [<- _].
- case: eval_expr => // - [n|] //.
  rewrite fsubU1set=> /andP [Px Pe] [<- _]; rewrite domm_set.
  apply/eqP; rewrite eqEfsubset; apply/andP; split.
    by rewrite fsubU1set Px fsubsetxx.
  by rewrite fsubsetUr.
- case: eval_expr => // p sz.
  by case: ifP=> //= _; case: ifP=> //= _ _ [<-].
- congruence.
- case eval_c1: eval_com=> [[ls'' h'']| | ] //.
  rewrite fsubUset=> /andP [vars_c1 vars_c2] eval_c2.
  rewrite -(IH _ _ _ _ _ vars_c1 eval_c1) in vars_c2 *.
  by rewrite (IH _ _ _ _ _ vars_c2 eval_c2).
- case: eval_expr=> // - b.
  by rewrite 2!fsubUset -andbA => /and3P [_ vars_c1 vars_c2]; case: b; eauto.
case: eval_expr=> // - [] P; apply: IH.
  by rewrite /= fsetUC -fsetUA fsetUid.
by rewrite fsub0set.
Qed.

Let namesm_set (T S : nominalType) (m : {fmap T -> S}) (k : T) (x : S) :
  fsubset (names (setm m k x)) (names m :|: names k :|: names x).
Proof. eapply nom_finsuppP; finsupp. Qed.

Theorem weak_frame ls1 h1 ls2 h2 ls' h' safe c k :
  fsubset (vars_c c) (domm ls1) ->
  fdisjoint (domm ls1) (domm ls2) ->
  fdisjoint (names (ls1, h1)) (names (domm h2)) ->
  eval_com safe c (unionm ls1 ls2, unionm h1 h2) k =
  Done (ls', h') ->
  exists ls1' h1',
    [/\ ls' = unionm ls1' ls2,
        h'  = unionm h1' h2,
        fdisjoint (domm ls1') (domm ls2) &
        fsubset (names (ls1', h1') :&: (names h2))
                (names (ls1, h1))].
Proof.
elim: k ls1 h1 ls' h' c=> [//=|k IH] ls1 h1 ls' h' c.
case: c=> [x e|x e|e e'|x e|e| |c1 c2|e c1 c2|e c] //=.
- (* Assn *)
  rewrite fsubU1set=> /andP [Px sub] disl dish [<- <-].
  rewrite setm_union; do 3!eexists; eauto.
    by rewrite domm_set; apply/fdisjointP=> x' /fsetU1P [->|];
    move/fdisjointP: disl; apply.
  rewrite fsetIUl fsetUSS //= 1?fsubsetIl //.
  rewrite (fsubset_trans (fsetSI _ (namesm_set _ _ _))) // fsetU0.
  rewrite eval_expr_unionm // fsetIUl fsubUset fsubsetIl /=.
  rewrite (fsubset_trans (fsubsetIl _ _)) //.
  by rewrite (fsubset_trans (eval_expr_names _ _ _)) // fsubsetxx.
- (* Load *)
  rewrite fsubU1set=> /andP [Px sub] disl dish.
  rewrite eval_expr_unionm //.
  case eval_e: eval_expr=> [| |p|] //.
  rewrite unionmE; case get_p: (h1 p)=> [v|] /=.
    move=> [<- <-]; rewrite setm_union; do 3!eexists; eauto.
      by rewrite domm_set; apply/fdisjointP=> x' /fsetU1P [->|];
      move/fdisjointP: disl; apply.
    rewrite fsetIUl /= fsubUset; apply/andP; split.
      apply: (fsubset_trans (fsubsetIl _ _)).
      apply: (fsubset_trans (namesm_set _ _ _)).
      rewrite fsetU0 fsetUSS // ?fsubsetxx //=.
      apply/fsubsetP=> n Pn; apply/namesmP.
      by eapply PMFreeNamesVal; eauto.
    by apply: fsubIset; rewrite fsubsetUr.
  move: (eval_expr_names safe ls1 e); rewrite eval_e namesvE fsub1set=> Pp.
  move/fdisjointP/(_ p.1): dish; rewrite in_fsetU /= Pp /= => /(_ erefl).
  case get_p': (h2 p) => [v|] //= /namesfsPn/(_ p).
  by rewrite mem_domm get_p'=> /(_ erefl); rewrite in_fsetU in_fset1 eqxx.
- (* Store *)
  rewrite fsubUset=> /andP [sub1 sub2] disl dish.
  rewrite !eval_expr_unionm //.
  case eval_e: eval_expr=> [| |p| ] //.
  rewrite /updm unionmE setm_union.
  case get_p: (h1 p)=> [v|] //=.
    move=> [<- <-]; do 3!eexists; eauto.
    apply: (fsubset_trans (fsubsetIl _ _)).
    rewrite fsubUset; apply/andP; split; first by rewrite fsubsetUl.
    apply/(fsubset_trans (namesm_set _ _ _)); rewrite 2!fsubUset.
    rewrite fsubsetUr /=; apply/andP; split.
      apply/fsubsetU/orP; right; apply/fsubsetP=> i Pi /=.
      by apply/namesmP; eapply PMFreeNamesKey; eauto.
    by apply/(fsubset_trans (eval_expr_names _ _ _))/fsubsetUl.
  move: (eval_expr_names safe ls1 e); rewrite eval_e namesvE fsub1set=> Pp.
  move/fdisjointP/(_ p.1): dish; rewrite in_fsetU /= Pp /= => /(_ erefl).
  case get_p': (h2 p) => [v|] //= /namesfsPn/(_ p).
  by rewrite mem_domm get_p'=> /(_ erefl); rewrite in_fsetU in_fset1 eqxx.
- (* Alloc *)
  rewrite fsubU1set=> /andP [Px sub] disl dish; rewrite eval_expr_unionm //.
  case eval_e: eval_expr=> [|[n|]| |] //= [<- <-].
  rewrite setm_union /= unionmA.
  have dis': fdisjoint (domm h1) (domm h2).
    apply/fdisjoint_names_domm/fdisjointP=> i Pi'.
    by move/fdisjointP: dish; apply; apply/fsetUP; right; apply/fsetUP; left.
  have F := (freshP (names (unionm ls1 ls2, unionm h1 h2))).
  do 3!eexists; eauto.
    by rewrite domm_set; apply/fdisjointP=> x' /fsetU1P [->|];
    move/fdisjointP: disl; apply.
  rewrite fsetIUl fsubUset; apply/andP; split=> /=.
    apply/(fsubset_trans _ (fsubsetUl _ _)).
    apply/(fsubset_trans (fsetSI _ (namesm_set _ _ _))).
    rewrite /= 2!fsetIUl 2!fsubUset fsubsetIl fset0I fsub0set /=.
    rewrite namesvE /=.
    apply/fsubsetP=> i /fsetIP [/namesnP -> {i} /= Pi].
    move: F; rewrite in_fsetU negb_or=> /andP [_] /=.
    by rewrite namesm_union_disjoint // in_fsetU negb_or Pi andbF.
  apply/fsubsetU/orP; right=> /=.
  move: (fresh _) F => i.
  rewrite namespE /= (namesm_union_disjoint dis').
  rewrite in_fsetU negb_or in_fsetU negb_or.
  case/and3P=> Fl Fh1 Fh2.
  rewrite namesm_union_disjoint 1?fsetIUl ?fdisjoint_names_domm //.
    rewrite fsubUset fsubsetIl andbT names_mkblock names_nseq if_same.
    by rewrite fun_if if_arg fsetU0 fset1I fset0I (negbTE Fh2) if_same fsub0set.
  rewrite names_domm_mkblock.
  case: ifP => _; first by rewrite fdisjoint0s.
  rewrite fdisjointC fdisjoints1.
  by apply: contra Fh1; rewrite in_fsetU => ->.
- (* Free *)
  move=> sub disl dish; rewrite eval_expr_unionm //.
  case eval_e: eval_expr=> [| |p|] //=.
  have [|] := altP eqP=> // _.
  rewrite domm_curry; case: ifP=> [/imfsetP [/= p' inD Pp]|] //=.
  move: inD; rewrite mem_domm unionmE.
  have dish': fdisjoint (names (domm h1)) (names (domm h2)).
    apply/fdisjointP=> i Pi'.
    by move/fdisjointP: dish; apply; apply/fsetUP; right; apply/fsetUP; left.
  case get_p': (h1 p') => [v|] /=.
    move=> _ [<- <-]; exists ls1, (filterm (fun p'' _ => p''.1 != p.1) h1).
    split=> //.
      rewrite filterm_union; last by apply fdisjoint_names_domm.
      congr unionm; apply/eq_fmap=> p''; rewrite filtermE.
      case get_p'': (h2 p'')=> [v'|] //=.
      have [Pp'|] //= := altP eqP.
      have names_p: p.1 \in names (domm h1).
        apply/namesfsP; exists p'; first by rewrite mem_domm get_p'.
        by rewrite Pp; rewrite in_fsetU; apply/orP; left; apply/namesnP.
      move/fdisjointP: dish'=> /(_ _ names_p).
      suff ->: p.1 \in names (domm h2) by [].
      apply/namesfsP; exists p''; first by rewrite mem_domm get_p''.
      by rewrite -Pp'; rewrite in_fsetU; apply/orP; left; apply/namesnP.
    rewrite fsetIUl fsetUSS //= ?fsubsetIl //.
    by apply/(fsubset_trans (fsubsetIl _ _))/namesm_filter.
  case get_p'': (h2 p') => [v'|] //= _.
  move: (eval_expr_names safe ls1 e); rewrite eval_e namesvE.
  move=> /fsubsetP/(_ p.1); rewrite in_fset1 eqxx=> /(_ erefl) Pp'.
  rewrite fdisjointC in dish; move/fdisjointP/(_ p.1): dish.
  have h: p.1 \in names (domm h2).
    apply/namesfsP; exists p'; first by rewrite mem_domm get_p''.
    by rewrite Pp in_fsetU; apply/orP; left; apply/namesnP.
  by rewrite in_fsetU Pp' /= => /(_ h).
- (* Skip *)
  move=> _ ? ? [<- <-]; do 3!eexists; eauto; exact: fsubsetIl.
- (* Seq *)
  case eval_c1: eval_com=> [[ls'' h'']| |] //=.
  rewrite fsubUset=> /andP [sub1 sub2] disl dish eval_c2.
  have [ls1' [h1' [? ? disl' sub']]] := IH _ _ _ _ _ sub1 disl dish eval_c1.
  subst ls'' h''.
  have dish': fdisjoint (names (ls1', h1')) (names (domm h2)).
    move/eqP in dish.
    rewrite /fdisjoint -fsubset0 -dish fsubsetI fsubsetIr andbT.
    by rewrite (fsubset_trans _ sub') // fsetIS // fsubsetUl.
  have sub1': fsubset (vars_c c1) (domm (unionm ls1 ls2)).
    by rewrite domm_union (fsubset_trans sub1) // fsubsetUl.
  have sub2' : fsubset (vars_c c2) (domm ls1').
    apply/fsubsetP=> x x_in.
    move/fsubsetP/(_ x x_in): (sub2)=> sub2'.
    have: x \in domm (unionm ls1' ls2).
      by rewrite (eval_com_domm sub1' eval_c1) domm_union in_fsetU sub2'.
    move/fdisjointP/(_ _ sub2') in disl.
    by rewrite domm_union in_fsetU (negbTE disl) orbF.
  have [ls1'' [h1'' [? ? disl'' sub'']]] :=
    IH _ _ _ _ _ sub2' disl' dish' eval_c2.
  subst; do 3!eexists; eauto.
  by apply/(fsubset_trans _ sub'); rewrite fsubsetI fsubsetIr andbT.
- (* If *)
  rewrite 2!fsubUset=> /andP [/andP [sub1 sub2] sub3].
  rewrite eval_expr_unionm //.
  case eval_e: eval_expr=> [b| | |] //= disl dish eval_c.
  have [|ls1' [h1' [? ? disl' sub']]] := IH _ _ _ _ _ _ disl dish eval_c.
    by case: b {eval_e eval_c}.
  by subst ls' h'; do 3!eexists; eauto.
(* While *)
rewrite fsubUset=> /andP [sub1 sub2]; rewrite eval_expr_unionm //.
case eval_e: eval_expr=> [b| | |] //= disl dish eval_c.
have [|ls1' [h1' [? ? sub']]] := IH _ _ _ _ _ _ disl dish eval_c.
  case: (b); last by rewrite fsub0set.
  by rewrite /= fsetUC -fsetUA fsetUid fsubUset sub1.
by subst ls' h'; do 3!eexists; eauto.
Qed.

End Cast.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

(* Import SolidityNotations. *)
Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.
(*Set Typeclasses Strict Resolution. *)
(* Set Typeclasses Debug.  *)
(* Set Typeclasses Unique Instances.
Unset Typeclasses Unique Solutions. *)

(* Existing Instance monadStateT.
Existing Instance monadStateStateT. *)
(* Module MultiSigWalletSpecSig := MultiSigWalletSpecSig XTypesSig StateMonadSig. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.
Require Import depoolContract.Lib.CommonStateProofs.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope solidity_scope.

(* Require Import MultiSigWallet.Specifications._validatelimit_inlineSpec.
Module _validatelimit_inlineSpec := _validatelimit_inlineSpec MultiSigWalletSpecSig.
Import _validatelimit_inlineSpec. *)

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

(* function generateRound() internal returns (Round) {
        DePoolLib.Request req;
        Round r = Round({                      (*<<< порядок <<<<<*)
            id: m_roundQty,
            supposedElectedAt: 0, // set when round in elections phase
            unfreeze: DePoolLib.MAX_TIME, // set when round in unfreeze phase
            stakeHeldFor: 0,                    (*<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<*)
            vsetHashInElectionPhase: 0, // set when round in elections phase
            step: RoundStep.PrePooling,
            completionReason: CompletionReason.Undefined,

            stake: 0,
            recoveredStake: 0,                 (*<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<*)
            unused: 0,
            isValidatorStakeCompleted: false,  (*<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<*)
            rewards: 0,
            participantQty : 0,
            validatorStake: 0,                 (*<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<*)
            validatorRemainingStake: 0,        (*<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<*)
            handledStakesAndRewards: 0,        (*<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<*)

            validatorRequest: req,
            elector: address(0), // set when round in elections phase
            proxy: getProxy(m_roundQty)
       });
        ++m_roundQty;
        return r;
    }
*)

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo.

Lemma DePoolContract_Ф_generateRound_exec : forall (l: Ledger) ,
exec_state ( ↓ DePoolContract_Ф_generateRound ) l =

let m_roundQty1 := ( eval_state ( ↑11 ε RoundsBase_ι_m_roundQty ) l ) + 1 in

    {$ l With ( RoundsBase_ι_m_roundQty , m_roundQty1 ) $} .
 Proof.
   intros. destruct l. auto.
 Qed.

Lemma DePoolContract_Ф_generateRound_eval : forall (l: Ledger) ,
eval_state ( ↓ DePoolContract_Ф_generateRound ) l =

let req (* : DePoolLib_ι_RequestP *) := default in
let r := ( RoundsBase_ι_RoundC
  ( eval_state ( ↑11 ε RoundsBase_ι_m_roundQty ) l )
 	0
 	( eval_state ( ↑9 ε DePoolLib_ι_MAX_TIME ) l )
 	 RoundsBase_ι_RoundStepP_ι_PrePooling
 	 RoundsBase_ι_CompletionReasonP_ι_Undefined
 	 0 0 default req 0 0 0
 	( eval_state ( ↓ ( ProxyBase_Ф_getProxy ( eval_state ( ↑11 ε RoundsBase_ι_m_roundQty ) l ) ) ) l )
	0 0 0 false 0 0 0 ) in r .
 Proof.
   intros. destruct l. auto.
Qed.


(** * SLOT: a formally verified model checker *)

(** SLOT is a collection of definitions and tactics for verification
of safety properties of concurrent and distributed functional programs
doing I/O, based on Hoare logic. SLOT models have the following
properties:

- Verified systems are written in a shallow-embedded DSL, and take
  advantage of most Gallina features. They can be extracted to CPS
  programs in Ocaml or Haskell via Coq's extraction feature

- Users can define their own I/O operations (called syscalls from now
  on)

- Syscall definitions can be composed together, and all theorems about
  the individual syscall types hold for the combined system

- Syscalls can be nondeterminisic

- Current version of SLOT doesn't support verification of liveness
  properties

Some notes on the naming: originally SLOT stood for Separation Logic
Of Traces, but the current implementation has nothing to do with
separation logic. However this name was catchy, so it stuck.

* Motivation

Before diving into lengthy description of the model, let me first
motivate a skeptical reader:

** Q: Why not TLA+?

A: In SLOT the verified system is clearly separated from the I/O
model, and therefore its definition looks much like conventional
functional program. It makes extraction of the verified code easier
(at least in theory). Model of the non-deterministic I/O is
separated. This leads to much more structured definitions and proofs.

Another obvious difference is that SLOT is entirely based on Coq and
makes heavy use of inductive datatypes and symbolic evaluation under
the hood. This has both advantages and disadvantages:

- SLOT is much less automated, but it can work with inductive
  definitions and anything that can be expressed in Coq

- SLOT model checker outputs Coq proofs, ultimately it means that it
  needs to store all execution histories. Given that the number of
  histories grows exponentially, solving large proofs by pure
  bruteforce is impossible. Although this disadvantage is partially
  mitigated by several formally-verified branch-pruning algorithms, it
  means proofs about large systems should be split to lemmas

- Verified program can be extracted

- While TLA+ model checker is top notch, its proof language is not

** Q: Why not (insert model checker name)?

A: Model checkers show why the code _fails_, which is suitable for
verifying algorithms, but structured formal proofs show why the code
_works_ (via tree of assumptions). It allows to reason about
algorithms and, in particular, to predict the outcome of
optimizations. Also model checkers typically can't work with infinite
state space, while SLOT can do it to some extend via magic of Coq.

** Q: Why not Verdi?

https://github.com/uwplse/verdi

- Nondeterminisic part of Verdi is hardcoded, while SLOT allows user
  to define custom IO handlers

- Verdi models are low level: think UDP packets and disk iops. SLOT
  can work with higher-level I/O handlers: think databases and pubsub
  services.

** Q: Why not disel?

https://github.com/DistributedComponents/disel

A: disel models are closer to what I need, but implementation itself
is an incomprehensible, impenetrable wall of ssreflect. Proofs are
only as useful as their premises: "garbage in - garbage out". Good
model should be well documented and well understood.

** Q: Why not iris/aneris?

https://gitlab.mpi-sws.org/iris/iris

A: iris allows user to define semantics of their very own programming
language. SLOT is focused on proving properties of _regular pure
functinal programs_ that do IO from time to time. Hence it defines
actors in regular Gallina language, rather than some DSL, and frees
the user from reinventing basic control flow constructions.

* Navigating the code

** Core definitions

 - [LibTx.SLOT.Hoare] module contains definitions used to describe a
   single execution history

*)

From LibTx Require Export
     SLOT.EventTrace
     SLOT.Hoare
     SLOT.Handler
     SLOT.Process
     SLOT.Ensemble.

From Coq Require Import
     String
     List.

(*Module Model.
  Section defn.
    Context {PID} {SUT : Type} {Handler : @Handler.t PID}.

    Record t : Type :=
      mkModel
        { model_sut : SUT;
          model_handler : h_state Handler;
        }.

   Context `{Runnable  SUT}.

    Definition model_state_transition m m' te : Prop :=
      match m, m' with
      | mkModel s h, mkModel s' h' => (h_state_transition Handler) h h' te /\
                                     runnable_step s s' te
      end.

    Global Instance modelStateSpace : StateSpace t (@TraceElem ctx) :=
      {| state_transition := model_state_transition; |}.
  End defn.

  (* Helper function for infering type of model: *)
  Definition model_t {SUT} {PID} (sut : SUT) (h : @Handler.t PID) : Type :=
    @t PID SUT h.
End Model. *)

Ltac bruteforce Ht Hls :=
  let Ht' := type of Ht in
  match eval lazy in Ht' with
  | ThreadGenerator _ _ _ =>
    unfold_thread Ht
  | Parallel ?e1 ?e2 ?t =>
    let t1 := fresh "t_l" in
    let t2 := fresh "t_r" in
    let H1 := fresh "H" t1 in
    let H2 := fresh "H" t2 in
    let t := fresh "t" in
    let Hint := fresh "Hint_" t in
    destruct Ht as [t1 t2 t H1 H2 Hint];
    bruteforce H1 Hls; subst; bruteforce H2 Hls;
    unfold_interleaving Hint with trace_step Hls
  end.

Require Import
        Handlers.Mutex
        Handlers.Deterministic.

(*
Module ExampleModelDefn.
  Section handler.
    Context {PID : Type}.

    Definition Handler := AtomicVar.t nat <+> mutexHandler PID.
  End handler.

  Let req := get_handler_req (@Handler).
  Let ret := get_handler_ret (@Handler).

  Section defs.
    (* Let req : Type := (@avar_req_t nat + req_t).     *)
    Context {PID : Type}.

    Definition put (val : nat) : req :=
      inl (AtomicVar.write val).

    Definition get : req :=
      inl (AtomicVar.read).

    Definition grab : req :=
      inr (Mutex.grab).

    Definition release : req :=
      inr (Mutex.release).

    Let Thread := @Thread req ret.

    (* Just a demonstration how to define a program that loops
    indefinitely, as long as it does IO: *)

    CoFixpoint infinite_loop (self : PID) : Thread :=
      do _ <- put 0;
      infinite_loop self.

    (* Data race example: *)
    Definition inc (n : nat) ret : Thread :=
      do v <- get;
      do _ <- put (v + n);
      ret (v + n).

    (* Fixed example: *)
    Definition counter_correct (self : PID) :=
      do _ <- grab;
      call x <- inc 1;
      done release.

    (* Definition nop (self : PID) : Thread := *)
    (*   @throw ctx "Exception".  TODO *)
  End defs.

  Section simple.
    Let PID := bool.

    Let SUT := counter_correct I.
    Let Handler := @Handler PID.

    Let mk_counter (pid : PID) := ThreadGenerator pid (counter_correct pid).
    Let SingletonEnsemble := mk_counter true.
    Let PairEnsemble := (mk_counter true) -|| (mk_counter false).
    Let InfLoopEnsemble := ThreadGenerator true (infinite_loop true).

    Goal EnsembleInvariant (fun _ => True) SingletonEnsemble.
    Proof.
      intros t Ht.
      unfold_thread Ht. subst.
      now repeat constructor.
    Qed.

    Goal EnsembleInvariant (fun _ => True) SingletonEnsemble.
    Proof.
      intros t Ht.
      unfold_thread Ht. subst.
      now repeat constructor.
    Qed.

    Goal forall v1 v2,
      {{ fun s  => True }}
        [true @ v1 <~ get;
         true @ I <~ grab;
         true @ v2 <~ get;
         false @ I <~ grab;
         true @ I <~ grab]
      {{ fun s => False }}.
    Proof.
      intros v1 v2.
      unfold_ht.
      repeat trace_step Hls.
    Qed.

    Goal -{{ fun (s : h_state Handler) => fst s = 0 }} PairEnsemble {{ fun s => fst s = 2 }}.
    Proof.
      intros t Ht.
      unfold_ht.
      cbn in Hpre.
      bruteforce Ht Hls;
      cbn in *; repeat match goal with
                         [ H : _ /\ _ |- _] => destruct H
                       end; subst; auto.
    Qed.

    (*Let counter_invariant (sys : Model) : Prop :=
      match sys with
        mkModel sut (M, l) =>
        match l with
        | Some _ => True
        | None =>
          let n_alive := match sut with
                         | t_dead => 0
                         | t_cont _ _ => 1
                         end
          in n_alive + M = 1
        end
      end.*)
  End simple.
End ExampleModelDefn.
*)


(**
SimSoC-Cert, a toolkit for generating certified processor simulators.

See the COPYRIGHTS and LICENSE files.

Notations and coercions for C programs.
*)

Set Implicit Arguments.

Require Import List BinInt String.
Require Export Integers AST Values Csyntax Ascii.

(****************************************************************************)
(** notations for Coq data structures *)

Notation "[ ]" := nil.
Notation "[ a ; .. ; b ]" := (a :: .. (b :: nil) ..).

(****************************************************************************)
(** convert Coq strings into lists of Values.init_data *)

Definition init_data_of_ascii a := Init_int8 (Int.repr (Z_of_N (N_of_ascii a))).

Definition list_init_data_of_list_ascii := List.map init_data_of_ascii.

Fixpoint list_init_data_of_string s :=
  match s with
    | EmptyString => []
    | String a s => init_data_of_ascii a :: list_init_data_of_string s
  end.

Definition null_termin_string s := (s ++ String "000" "")%string.

(****************************************************************************)
(** coercions *)

Coercion Int.repr : Z >-> int.
Coercion Vint : int >-> val.
Coercion Sdo : expr >-> statement.
Coercion init_data_of_ascii : ascii >-> init_data.
Coercion list_init_data_of_string : string >-> list.

(****************************************************************************)
(* notations *)

Notation "a -: b" := (pair a b) (at level 60).

Notation "` x" := (Int.repr x) (at level 9).
Notation "`` x" := (Init_int8 ` x) (at level 9).

Notation int8 := (Tint I8 Signed).
Notation uint8 := (Tint I8 Unsigned).
Notation int16 := (Tint I16 Signed).
Notation uint16 := (Tint I16 Unsigned).
Notation int32 := (Tint I32 Signed).
Notation uint32 := (Tint I32 Unsigned).
Notation float32 := (Tfloat F32).
Notation float64 := (Tfloat F64).

Notation void := Tvoid.
Notation "`*` t" := (Tpointer t) (at level 20).

Notation "a :T: b" := (Tcons a b) (at level 70, right associativity).
Notation "T[ ]" := Tnil.
Notation "T[ a ; .. ; b ]" := (a :T: .. (b :T: Tnil) ..).

Definition fcons a := Fcons (fst a) (snd a).
Notation "a :F: b" := (fcons a b) (at level 70, right associativity).
Notation "F[ ]" := Fnil.
Notation "F[ a ; .. ; b ]" := (a :F: .. (b :F: Fnil) ..).

Notation "a :E: b" := (Econs a b) (at level 70, right associativity).
Notation "E[ ]" := Enil.
Notation "E[ a ; .. ; b ]" := (a :E: .. (b :E: Enil) ..).

Notation "! x `: t" := (Eunop Onotbool x t) (at level 10).
Notation "`~ x `: t" := (Eunop Onotint x t) (at level 10).
Notation "`- x `: t" := (Eunop Oneg x t) (at level 10).

Notation "x + y `: t" := (Ebinop Oadd x y t) (at level 20).
Notation "x - y `: t" := (Ebinop Osub x y t) (at level 20).
Notation "x * y `: t" := (Ebinop Omul x y t) (at level 20).
Notation "x / y `: t" := (Ebinop Odiv x y t) (at level 20).
Notation "x % y `: t" := (Ebinop Omod x y t) (at level 20).
Notation "x & y `: t" := (Ebinop Oand x y t) (at level 20).
Notation "x `| y `: t" := (Ebinop Oor x y t) (at level 20).
Notation "x ^ y `: t" := (Ebinop Oxor x y t) (at level 20).
Notation "x << y `: t" := (Ebinop Oshl x y t) (at level 20).
Notation "x >> y `: t" := (Ebinop Oshr x y t) (at level 20).

Notation "x == y `: t" := (Ebinop Oeq x y t) (at level 20).
Notation "x != y `: t" := (Ebinop One x y t) (at level 20).
Notation "x < y `: t" := (Ebinop Olt x y t) (at level 20).
Notation "x > y `: t" := (Ebinop Ogt x y t) (at level 20).
Notation "x <= y `: t" := (Ebinop Ole x y t) (at level 20).
Notation "x >= y `: t" := (Ebinop Oge x y t) (at level 20).

Notation "x += y `: t1 `: t2" := (Eassignop Oadd x y t1 t2) (at level 8).
Notation "x -= y `: t1 `: t2" := (Eassignop Osub x y t1 t2) (at level 8).
Notation "x *= y `: t1 `: t2" := (Eassignop Omul x y t1 t2) (at level 8).
Notation "x /= y `: t1 `: t2" := (Eassignop Odiv x y t1 t2) (at level 8).
Notation "x %= y `: t1 `: t2" := (Eassignop Omod x y t1 t2) (at level 8).
Notation "x &= y `: t1 `: t2" := (Eassignop Oand x y t1 t2) (at level 8).
Notation "x `|= y `: t1 `: t2" := (Eassignop Oor x y t1 t2) (at level 8).
Notation "x ^= y `: t1 `: t2" := (Eassignop Oxor x y t1 t2) (at level 8).
Notation "x <<= y `: t1 `: t2" := (Eassignop Oshl x y t1 t2) (at level 8).
Notation "x >>= y `: t1 `: t2" := (Eassignop Oshr x y t1 t2) (at level 8).

Notation "`* e `: t" := (Ederef e t) (at level 20).
Notation "# v `: t" := (Eval v t) (at level 20).
Notation "$ id `: t" := (Evar id t) (at level 20).
Notation "\ id `: t" := (Evalof (Evar id t) t) (at level 20).
Notation "& e `: t" := (Eaddrof e t) (at level 20).
Notation "e1 ? e2 `: e3 `: t" := (Econdition e1 e2 e3 t) (at level 20).
Notation "e -- `: t" := (Epostincr Decr e t) (at level 20).
Notation "e ++ `: t" := (Epostincr Incr e t) (at level 20).
Notation "e1 `= e2 `: t" := (Eassign e1 e2 t) (at level 8).
Notation "e | id `: t" := (Efield e id t) (at level 20).
Notation "'call'" := (Ecall).
Notation "'sizeof'" := (Esizeof).
Notation "'valof'" := (Evalof).

Notation "a ;; b" := (Ssequence a b) (at level 51, right associativity).
Notation "`if a 'then' b 'else' c" := (Sifthenelse a b c) (at level 9).
Notation "'while' a `do b" := (Swhile a b) (at level 19).
Notation "`do a 'while' b" := (Sdowhile b a) (at level 19).
Notation "'label' l `: s" := (Slabel l s) (at level 5).
Notation "'for' ( s1 , e , s2 ) { s3 }" := (Sfor s1 e s2 s3) (at level 19).

Notation "'return'" := (Sreturn) (at level 10).
Notation "'goto'" := (Sgoto).
Notation "'continue'" := (Scontinue).
Notation "'break'" := (Sbreak).
Notation "'skip'" := (Sskip).
Notation "'switch'" := (Sswitch).

Notation "`case i `: s :L: ls" := (LScase i s ls) (at level 70).
Notation "'default' `: s" := (LSdefault s) (at level 80).


Require Export
        Fiat.CertifiedExtraction.Extraction.Extraction.

Require Import
        Fiat.CertifiedExtraction.Extraction.BinEncoders.Basics
        Fiat.CertifiedExtraction.Extraction.BinEncoders.Wrappers
        Fiat.CertifiedExtraction.Extraction.BinEncoders.Properties.

Require Import
        Coq.Program.Program
        Coq.Lists.List.

Unset Implicit Arguments.

Lemma CompileCompose :
  forall {av} E B B' (transformer: Transformer.Transformer B) enc1 enc2
    (vstream: NameTag av B') (stream: B) (cache: E)
    (tenv t1 t2: Telescope av) f (g: B -> B') ext env p1 p2,
    (forall a1 a2 b, f (a1, b) = f (a2, b)) ->
    {{ [[ vstream  ->> g stream as _ ]]
         :: tenv }}
      p1
    {{ TelAppend ([[ NTNone ->> enc1 cache as encoded1 ]]
                    :: [[ vstream ->> g (Transformer.transform stream (fst encoded1)) as _ ]]
                    :: f encoded1)
                 t1 }}
    ∪ {{ ext }} // env ->
    (let encoded1 := enc1 cache in
     let stream1 := Transformer.transform stream (fst encoded1) in
     {{ TelAppend ([[ vstream ->> g stream1 as _ ]] :: f encoded1) t1 }}
       p2
     {{ TelAppend ([[ NTNone ->> enc2 (snd encoded1) as encoded2 ]]
                     :: [[ vstream ->> g (Transformer.transform stream1 (fst encoded2)) as _ ]]
                     :: f encoded2) t2 }}
     ∪ {{ ext }} // env) ->
    {{ [[ vstream ->> g stream as _ ]] :: tenv }}
      (Seq p1 p2)
    {{ TelAppend ([[ NTNone ->> @Compose.compose E B transformer enc1 enc2 cache as composed ]]
                    :: [[ vstream ->> g (Transformer.transform stream (fst composed)) as _ ]]
                    :: f composed) t2 }}
    ∪ {{ ext }} // env.
Proof.
  intros.
  repeat hoare.
  setoid_rewrite Compose_compose_acc.
  unfold compose_acc, encode_continue.
  cbv zeta in *.
  setoid_rewrite Propagate_anonymous_ret.
  setoid_rewrite Propagate_anonymous_ret in H0.
  setoid_rewrite Propagate_anonymous_ret in H1.
  destruct (enc1 _); simpl in *.
  destruct (enc2 _); simpl in *.
  erewrite (H (Transformer.transform _ _)); rewrite Transformer.transform_assoc; eassumption.
Qed.

Lemma CompileCompose_init :
  forall {av} E B B' (transformer: Transformer.Transformer B) enc1 enc2
    (vstream: NameTag av B') (cache: E)
    (tenv t1 t2: Telescope av) f (g : B -> B') ext env p1 p2 pAlloc,
    (forall a1 a2 b, f (a1, b) = f (a2, b)) ->
    {{ tenv }}
      pAlloc
    {{ [[ vstream ->> g Transformer.transform_id as _ ]] :: tenv }} ∪ {{ ext }} // env ->
    {{ [[ vstream ->> g Transformer.transform_id as _ ]] :: tenv }}
      p1
    {{ TelAppend ([[ NTNone ->> enc1 cache as encoded1 ]]
                    :: [[ vstream ->> g (Transformer.transform (Transformer.transform_id) (fst encoded1)) as _ ]]
                    :: f encoded1)
                 t1 }} ∪ {{ ext }} // env ->
    (let encoded1 := enc1 cache in
     let stream1 := Transformer.transform Transformer.transform_id (fst encoded1) in
     {{ TelAppend ([[ vstream ->> g stream1 as _ ]] :: f encoded1) t1 }}
       p2
     {{ TelAppend ([[ NTNone ->> enc2 (snd encoded1) as encoded2 ]]
                     :: [[ vstream ->> g (Transformer.transform stream1 (fst encoded2)) as _ ]]
                     :: f encoded2) t2 }} ∪ {{ ext }} // env) ->
    {{ tenv }}
      (Seq pAlloc (Seq p1 p2))
    {{ TelAppend ([[ NTNone ->> @Compose.compose E B transformer enc1 enc2 cache as composed ]]
                    :: [[ vstream ->> g (fst composed) as _ ]]
                    :: f composed) t2 }}
    ∪ {{ ext }} // env.
Proof.
  intros; hoare.
  setoid_rewrite <- (Transformer.transform_id_left (fst _)).
  eauto using CompileCompose.
Qed.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import RealmSyncHandlerAux.Specs.handle_icc_el1_sysreg_trap.
Require Import RealmSyncHandlerAux.LowSpecs.handle_icc_el1_sysreg_trap.
Require Import RealmSyncHandlerAux.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       ESR_EL2_SYSREG_ISS_RT_spec
       ESR_EL2_SYSREG_IS_WRITE_spec
       set_rec_regs_spec
    .

  Lemma handle_icc_el1_sysreg_trap_spec_exists:
    forall habd habd'  labd rec esr
      (Hspec: handle_icc_el1_sysreg_trap_spec rec esr habd = Some habd')
      (Hrel: relate_RData habd labd),
    exists labd', handle_icc_el1_sysreg_trap_spec0 rec esr labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    Local Opaque ptr_eq.
    intros. destruct Hrel. destruct rec.
    unfold handle_icc_el1_sysreg_trap_spec, handle_icc_el1_sysreg_trap_spec0 in *.
    repeat autounfold in *. simpl in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; bool_rel; simpl in *; srewrite; repeat simpl_update_reg;
        repeat (simpl_htarget; grewrite; simpl in * );
        try solve[repeat (solve_bool_range; grewrite); eexists; split; [reflexivity|constructor; reflexivity]].
  Qed.

End Refine.


From caml5 Require Import
  prelude.
From caml5.lang Require Import
  notations
  proofmode.
From caml5.std Require Export
  base.

Section heapGS.
  Context `{!heapGS Σ}.
  Implicit Types l : loc.

  Definition record3_make : val :=
    λ: "v₀" "v₁" "v₂",
      let: "l" := AllocN #3 "v₀" in
      "l".(1) <- "v₁" ;;
      "l".(2) <- "v₂" ;;
      "l".

  Definition record3_model l dq v₀ v₁ v₂ : iProp Σ :=
    l.(0) ↦{dq} v₀ ∗
    l.(1) ↦{dq} v₁ ∗
    l.(2) ↦{dq} v₂.

  #[global] Instance record3_model_timeless l dq v₀ v₁ v₂ :
    Timeless (record3_model l dq v₀ v₁ v₂).
  Proof.
    apply _.
  Qed.
  #[global] Instance record3_model_persistent l v₀ v₁ v₂ :
    Persistent (record3_model l DfracDiscarded v₀ v₁ v₂).
  Proof.
    apply _.
  Qed.

  #[global] Instance record3_model_fractional l v₀ v₁ v₂ :
    Fractional (λ q, record3_model l (DfracOwn q) v₀ v₁ v₂).
  Proof.
    apply _.
  Qed.
  #[global] Instance record3_model_as_fractional l q v₀ v₁ v₂ :
    AsFractional (record3_model l (DfracOwn q) v₀ v₁ v₂) (λ q, record3_model l (DfracOwn q) v₀ v₁ v₂) q.
  Proof.
    split; done || apply _.
  Qed.

  Lemma record3_model_persist l dq v₀ v₁ v₂ :
    record3_model l dq v₀ v₁ v₂ ==∗
    record3_model l DfracDiscarded v₀ v₁ v₂.
  Proof.
    iIntros "(Hv₀ & Hv₁ & Hv₂)".
    iMod (mapsto_persist with "Hv₀") as "$".
    iMod (mapsto_persist with "Hv₁") as "$".
    iMod (mapsto_persist with "Hv₂") as "$".
    done.
  Qed.

  Lemma record3_model_valid l dq v₀ v₁ v₂ :
    record3_model l dq v₀ v₁ v₂ -∗
    ⌜✓ dq⌝.
  Proof.
    iIntros "(Hv₀ & Hv₁ & Hv₂)". iApply (mapsto_valid with "Hv₀").
  Qed.
  Lemma record3_model_combine l dq1 v₀1 v₁1 v₂1 dq2 v₀2 v₁2 v₂2 :
    record3_model l dq1 v₀1 v₁1 v₂1 -∗
    record3_model l dq2 v₀2 v₁2 v₂2 -∗
      record3_model l (dq1 ⋅ dq2) v₀1 v₁1 v₂1 ∗
      ⌜v₀1 = v₀2 ∧ v₁1 = v₁2 ∧ v₂1 = v₂2⌝.
  Proof.
    iIntros "(Hv₀1 & Hv₁1 & Hv₂1) (Hv₀2 & Hv₁2 & Hv₂2)".
    iDestruct (mapsto_combine with "Hv₀1 Hv₀2") as "(Hv₀ & <-)".
    iDestruct (mapsto_combine with "Hv₁1 Hv₁2") as "(Hv₁ & <-)".
    iDestruct (mapsto_combine with "Hv₂1 Hv₂2") as "(Hv₂ & <-)".
    iSplit; last done. iFrame.
  Qed.
  Lemma record3_model_valid_2 l dq1 v₀1 v₁1 v₂1 dq2 v₀2 v₁2 v₂2 :
    record3_model l dq1 v₀1 v₁1 v₂1 -∗
    record3_model l dq2 v₀2 v₁2 v₂2 -∗
    ⌜✓ (dq1 ⋅ dq2) ∧ v₀1 = v₀2 ∧ v₁1 = v₁2 ∧ v₂1 = v₂2⌝.
  Proof.
    iIntros "Hl1 Hl2".
    iDestruct (record3_model_combine with "Hl1 Hl2") as "(Hl & %)".
    iDestruct (record3_model_valid with "Hl") as %?.
    done.
  Qed.
  Lemma record3_model_agree l dq1 v₀1 v₁1 v₂1 dq2 v₀2 v₁2 v₂2 :
    record3_model l dq1 v₀1 v₁1 v₂1 -∗
    record3_model l dq2 v₀2 v₁2 v₂2 -∗
    ⌜v₀1 = v₀2 ∧ v₁1 = v₁2 ∧ v₂1 = v₂2⌝.
  Proof.
    iIntros "Hl1 Hl2".
    iDestruct (record3_model_valid_2 with "Hl1 Hl2") as %?. naive_solver.
  Qed.
  Lemma record3_model_dfrac_ne l1 dq1 v₀1 v₁1 v₂1 l2 dq2 v₀2 v₁2 v₂2 :
    ¬ ✓ (dq1 ⋅ dq2) →
    record3_model l1 dq1 v₀1 v₁1 v₂1 -∗
    record3_model l2 dq2 v₀2 v₁2 v₂2 -∗
    ⌜l1 ≠ l2⌝.
  Proof.
    iIntros "% Hl1 Hl2" (->).
    iDestruct (record3_model_valid_2 with "Hl1 Hl2") as %?. naive_solver.
  Qed.
  Lemma record3_model_ne l1 v₀1 v₁1 v₂1 l2 dq2 v₀2 v₁2 v₂2 :
    record3_model l1 (DfracOwn 1) v₀1 v₁1 v₂1 -∗
    record3_model l2 dq2 v₀2 v₁2 v₂2 -∗
    ⌜l1 ≠ l2⌝.
  Proof.
    iApply record3_model_dfrac_ne. intros []%exclusive_l. apply _.
  Qed.
  Lemma record3_model_exclusive l v₀1 v₁1 v₂1 v₀2 v₁2 v₂2 :
    record3_model l (DfracOwn 1) v₀1 v₁1 v₂1 -∗
    record3_model l (DfracOwn 1) v₀2 v₁2 v₂2 -∗
    False.
  Proof.
    iIntros "Hl1 Hl2".
    iDestruct (record3_model_ne with "Hl1 Hl2") as %?. naive_solver.
  Qed.

  Lemma record3_dfrac_relax dq l v₀ v₁ v₂ :
    ✓ dq →
    record3_model l (DfracOwn 1) v₀ v₁ v₂ ==∗
    record3_model l dq v₀ v₁ v₂.
  Proof.
    iIntros "% (Hv₀ & Hv₁ & Hv₂)".
    iMod (mapsto_dfrac_relax with "Hv₀") as "Hv₀"; first done.
    iMod (mapsto_dfrac_relax with "Hv₁") as "Hv₁"; first done.
    iMod (mapsto_dfrac_relax with "Hv₂") as "Hv₂"; first done.
    iFrame. done.
  Qed.

  Lemma record3_make_spec v₀ v₁ v₂ :
    {{{ True }}}
      record3_make v₀ v₁ v₂
    {{{ l, RET #l; record3_model l (DfracOwn 1) v₀ v₁ v₂ ∗ meta_token l ⊤ }}}.
  Proof.
    iIntros "%Φ _ HΦ".
    wp_rec. wp_pures.
    wp_apply (wp_allocN with "[//]"); first done. iIntros "%l (Hl & Hmeta & _)". rewrite loc_add_0.
    wp_pures.
    iDestruct (array_cons with "Hl") as "(Hv₀ & Hl)".
    iEval (setoid_rewrite <- loc_add_0) in "Hv₀".
    iDestruct (array_cons with "Hl") as "(Hv₁ & Hl)".
    iDestruct (array_singleton with "Hl") as "Hv₂".
    rewrite loc_add_assoc Z.add_1_r -Z.two_succ.
    wp_store. wp_store.
    iApply "HΦ". iFrame. done.
  Qed.

  Lemma record3_get0_spec l dq v₀ v₁ v₂ :
    {{{ record3_model l dq v₀ v₁ v₂ }}}
      !#l.(0)
    {{{ RET v₀; record3_model l dq v₀ v₁ v₂ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂) HΦ".
    wp_load.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂]").
  Qed.
  Lemma record3_get1_spec l dq v₀ v₁ v₂ :
    {{{ record3_model l dq v₀ v₁ v₂ }}}
      !#l.(1)
    {{{ RET v₁; record3_model l dq v₀ v₁ v₂ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂) HΦ".
    wp_load.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂]").
  Qed.
  Lemma record3_get2_spec l dq v₀ v₁ v₂ :
    {{{ record3_model l dq v₀ v₁ v₂ }}}
      !#l.(2)
    {{{ RET v₂; record3_model l dq v₀ v₁ v₂ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂) HΦ".
    wp_load.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂]").
  Qed.

  Lemma record3_set0_spec l v₀ v₁ v₂ v :
    {{{ record3_model l (DfracOwn 1) v₀ v₁ v₂ }}}
      #l.(0) <- v
    {{{ RET #(); record3_model l (DfracOwn 1) v v₁ v₂ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂) HΦ".
    wp_store.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂]").
  Qed.
  Lemma record3_set1_spec l v₀ v₁ v₂ v :
    {{{ record3_model l (DfracOwn 1) v₀ v₁ v₂ }}}
      #l.(1) <- v
    {{{ RET #(); record3_model l (DfracOwn 1) v₀ v v₂ }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂) HΦ".
    wp_store.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂]").
  Qed.
  Lemma record3_set2_spec l v₀ v₁ v₂ v :
    {{{ record3_model l (DfracOwn 1) v₀ v₁ v₂ }}}
      #l.(2) <- v
    {{{ RET #(); record3_model l (DfracOwn 1) v₀ v₁ v }}}.
  Proof.
    iIntros "%Φ (Hv₀ & Hv₁ & Hv₂) HΦ".
    wp_store.
    iApply ("HΦ" with "[$Hv₀ $Hv₁ $Hv₂]").
  Qed.
End heapGS.

#[global] Opaque record3_make.

#[global] Opaque record3_model.


Require Import VST.floyd.proofauto.
Require Import mk_acc.
From SSL_VST Require Import core.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition malloc_spec :=
  DECLARE _malloc
        WITH t: type
        PRE [ tuint ]
        PROP()
        PARAMS(Vint (Int.repr (sizeof t)))
        SEP()
        POST [tptr tvoid] EX p:_,
        PROP()
        RETURN(p)
        SEP(data_at_ Tsh t p).

Inductive account_card : Set :=
    | account_card_0 : account_card.

Fixpoint account (x: val) (id: Z) (bal: Z) (self_card: account_card) {struct self_card} : mpred := match self_card with
    | account_card_0  =>  !!(is_true true) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr id)) : val)); (inl ((Vint (Int.repr bal)) : val))] (x : val))
end.

Definition mk_acc_spec :=
  DECLARE _mk_acc
   WITH r: val, id: val, bal: Z
   PRE [ (tptr (Tunion _sslval noattr)), tint ]
   PROP( is_pointer_or_null((r : val)); ssl_is_valid_int((id : val)) )
   PARAMS(r; id)
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inl ((Vint (Int.repr bal)) : val))] (r : val)))
   POST[ tvoid ]
   EX x: val,
   EX _alpha_513: account_card,
   PROP( is_pointer_or_null((x : val)) )
   LOCAL()
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (x : val))] (r : val)); (account (x : val) (force_signed_int (id : val)) (bal : Z) (_alpha_513 : account_card))).

Lemma account_x_valid_pointerP x id bal self_card: account x id bal self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve account_x_valid_pointerP : valid_pointer.
Lemma account_local_factsP x id bal self_card :
  account x id bal self_card|-- !!((((is_true true)) -> (self_card = account_card_0))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve account_local_factsP : saturate_local.
Lemma unfold_account_card_0  (x: val) (id: Z) (bal: Z) : account x id bal (account_card_0 ) =  !!(is_true true) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr id)) : val)); (inl ((Vint (Int.repr bal)) : val))] (x : val)). Proof. auto. Qed.
Definition Gprog : funspecs :=
  ltac:(with_library prog [mk_acc_spec; malloc_spec]).

Lemma body_mk_acc : semax_body Vprog Gprog f_mk_acc mk_acc_spec.
Proof.
start_function.
ssl_open_context.
assert_PROP (isptr r). { entailer!. }
try rename bal into bal2.
forward.
forward_call (tarray (Tunion _sslval noattr) 2).
Intros x2.
assert_PROP (isptr x2). { entailer!. }
forward.
forward.
forward.
forward; entailer!.
Exists (x2 : val).
Exists (account_card_0  : account_card).
ssl_entailer.
rewrite (unfold_account_card_0 ) at 1.
ssl_entailer.

Qed.


Require Import MirrorCharge.ModularFunc.ILogicFunc.
Require Import MirrorCharge.ModularFunc.BILogicFunc.
Require Import MirrorCharge.SynSepLog.
Require Import MirrorCharge.SepLogFold.
Require Export MirrorCore.RTac.RTac.
Require Export MirrorCore.RTac.Core.
(*Require Import MirrorCore.STac.STac.*)
Require Export mc_reify.bool_funcs.
Require MirrorCore.syms.SymEnv.
Require MirrorCore.syms.SymSum.
Require Import MirrorCore.Subst.FMapSubst.
(*Require Import MirrorCharge.RTac.ReifyLemma.*)
Require Import floyd_funcs.
Require Export MirrorCore.Lambda.Expr.
Require Export mc_reify.types.
Require Export mc_reify.func_eq.
Require Export mc_reify.funcs.

Definition typeof_func_opt t := Some (typeof_func t).

Definition eqb_sym a b := match func_beq a b with
                        | true => Some true
                        | false => None
end.

Global Instance RSym_Func' : SymI.RSym func' := {
   typeof_sym := typeof_func_opt;
   symD := funcD;
   sym_eqb := eqb_sym
}.

Global Instance RSymOk_Func' : SymI.RSymOk RSym_Func'.
constructor.
intros. unfold sym_eqb. simpl. unfold eqb_sym. simpl.
destruct (func_beq a b) eqn :?. apply func_beq_sound. auto.
auto.
Qed.

Definition appR (e1 : func') e2 :=
App (@Inj typ func (inr e1)) (e2).
Definition injR (e1 : func') := @Inj typ func (inr e1).

Instance ILogicOps_mpred : ILogic.ILogicOps expr.mpred := {
lentails := derives;
ltrue := TT;
lfalse := FF;
land := andp;
lor := orp;
limpl := imp;
lforall := @allp mpred _;
lexists := @exp mpred _
}.

Instance ILogic_mpred : ILogic.ILogic mpred.
Proof.
split; intros.
+ split.
  * intro x; apply derives_refl.
  * intros x y z Hxy Hyz; apply derives_trans with y; assumption.
+ apply prop_right. apply I.
+ apply prop_left. intro H; destruct H.
+ apply allp_left with x; assumption.
+ apply allp_right; apply H.
+ apply exp_left; apply H.
+ apply exp_right with x; apply H.
+ apply andp_left1; apply H.
+ apply andp_left2; apply H.
+ apply orp_right1; apply H.
+ apply orp_right2; apply H.
+ apply andp_right; [apply H | apply H0].
+ apply orp_left; [apply H | apply H0].
+ apply imp_andp_adjoint. apply H.
+ apply imp_andp_adjoint. apply H.
Qed.

Instance BILOperators_mpred : BILogic.BILOperators mpred := {
  empSP := emp;
  sepSP := sepcon;
  wandSP := wand
}.

Instance BILogic_mpred : BILogic.BILogic mpred.
Proof.
split; intros.
+ apply _.
+ unfold BILogic.sepSP; simpl; rewrite sepcon_comm; apply derives_refl.
+ unfold BILogic.sepSP; simpl; rewrite sepcon_assoc; apply derives_refl.
+ apply wand_sepcon_adjoint.
+ apply sepcon_derives; [apply H | apply derives_refl].
+ unfold BILogic.sepSP; simpl; rewrite sepcon_emp; reflexivity.
Qed.

Definition ilops : @logic_ops _ RType_typ :=
fun t =>
  match t
          return option (ILogic.ILogicOps (typD t))
  with
  | tympred => Some _
  | typrop => Some _
  | _ => None
end.

Definition bilops : @bilogic_ops _ RType_typ :=
fun t =>
  match t
          return option (BILogic.BILOperators (typD t))
  with
  | tympred => Some _
  | _ => None
end.

Instance RSym_ilfunc : RSym (@ilfunc typ) :=
	RSym_ilfunc _ _ ilops.
Instance RSym_bilfunc : RSym (@bilfunc typ) :=
	RSym_bilfunc _ bilops.

Existing Instance SymSum.RSym_sum.
Existing Instance SymSum.RSymOk_sum.

Definition subst : Type :=
  FMapSubst.SUBST.raw (expr typ func).
Instance SS : SubstI.Subst subst (expr typ func) :=
  @FMapSubst.SUBST.Subst_subst _.
(*Instance SU : SubstI.SubstUpdate subst (expr typ func) :=
  FMapSubst.SUBST.SubstUpdate_subst (@instantiate typ func).
Instance SO : SubstI.SubstOk SS :=
  @FMapSubst.SUBST.SubstOk_subst typ RType_typ (expr typ func) _ _.
*)

Definition RSym_sym fs := SymSum.RSym_sum
  (SymSum.RSym_sum (SymSum.RSym_sum (SymEnv.RSym_func fs) RSym_ilfunc) RSym_bilfunc)
  RSym_Func'.

SearchAbout Expr.
Definition Expr_expr_fs fs: ExprI.Expr _ (ExprCore.expr typ func) := @ExprD.Expr_expr typ func _ _ (RSym_sym fs).
Definition Expr_ok_fs fs: @ExprI.ExprOk typ RType_typ (ExprCore.expr typ func) (Expr_expr_fs fs) := ExprD.ExprOk_expr.

Definition reflect ft tus tvs e (ty : typ)
 := @exprD _ _ _ (Expr_expr_fs ft) tus tvs e ty.

Definition reflect_prop tbl e := reflect tbl nil nil e (typrop).

Definition reflect_prop' tbl e := match (reflect tbl nil nil e typrop) with
| Some p => p
| None => False
end.

Definition node l o r t : expr typ func :=
(App (App (App (Inj (inr (Data (fnode t)))) l) o) r).

Definition leaf t : expr typ func:=
(Inj (inr (Data (fleaf t)))).

Definition some_reif e t : expr typ func :=
(App (Inj (inr (Other (fsome t)))) e).

Definition none_reif t : expr typ func :=
(Inj (inr (Other (fnone t)))).

Instance MA : MentionsAny (expr typ func) := {
  mentionsAny := ExprCore.mentionsAny
}.

Let elem_ctor : forall x : typ, typD x -> @SymEnv.function typ _ :=
  @SymEnv.F _ _.

Let Ext x := @ExprCore.Inj typ func (inl (inl (inl x))).

Section tbled.

Variable tbl : SymEnv.functions RType_typ.

Let RSym_sym := RSym_sym tbl.
Existing Instance RSym_sym.
Let Expr_expr := Expr_expr_fs tbl.
Existing Instance Expr_expr.
Existing Instance Expr_ok_fs.

Definition exprD_Prop (uvar_env var_env : EnvI.env) (e : expr typ func) :=
  match exprD uvar_env var_env e typrop with
    | Some e' => e'
    | None => True
  end.

Definition goalD_Prop (uvar_env var_env : EnvI.env) goal :=
  let (tus, us) := split_env uvar_env in
  let (tvs, vs) := split_env var_env in
  match goalD tus tvs goal with
    | Some e => e us vs
    | None => False
  end.

Definition goalD_aux tus tvs goal (us : HList.hlist typD tus) (vs : HList.hlist typD tvs) :=
  match goalD tus tvs goal with
    | Some e => Some (e us vs)
    | None => None
  end.

End tbled.


Require Import msl.msl_standard.
Require Import Maps.
Require Import FuncListMachine.
Require Import lemmas.
Require Import hoare_total.
Require Import wp.

(* This is some tentative work-in-progress *)

Fixpoint list_nat (n:nat) (x:value) {struct n} :=
  match n, x with
  | 0, value_label 1%positive => True
  | S n', value_cons (value_label 1%positive) x' => list_nat n' x'
  | _, _ => False
  end.

Fixpoint list_length (x:value) :=
  match x with
  | value_cons _ x' => S (list_length x')
  | _ => 0
  end.

Definition list_nat_var (n:nat) (v:var) (r:store) :=
  match r#v with
  | None => False
  | Some x => list_nat n x
  end.

Program Definition add_term_measure : termMeas :=
  fun r n =>
  match r#(V 1) with
  | Some x => list_length x = n
  | None => False
  end.
Next Obligation.
 destruct x as [ | x o0 x1] ; [contradiction H | ].
 destruct x; [ contradiction H | simpl in *] .
 destruct o; simpl in *;  [congruence | contradiction].
Qed.

Definition add_P' n m st :=
    list_nat_var n (V 1) st /\
    list_nat_var m (V 2) st.

Definition add_Q' n m st := list_nat_var (n+m) (V 2) st.

Definition add_P (nm:nat*nat) := store_op (add_P' (fst nm) (snd nm)).
Definition add_Q (nm:nat*nat) := store_op (add_Q' (fst nm) (snd nm)).

Definition valueTermMeas :=
  { R: value -> nat -> Prop |
    forall v n n', R v n -> R v n' -> n = n' }.

Record stdFunspec A :=
  { sfs_t     : valueTermMeas
  ; sfs_P     : A -> value -> pred prog
  ; sfs_Q     : A -> value -> pred prog
  }.

Implicit Arguments sfs_t.
Implicit Arguments sfs_P.
Implicit Arguments sfs_Q.

Program Definition value_to_store_termMeas (vt:valueTermMeas) : termMeas :=
  fun s n => match s#(V 0) with
             | Some v => proj1_sig vt v n
             | None   => False
             end.
Next Obligation.
  destruct x; simpl in *; intuition.
  destruct o; simpl in *; intuition.
  destruct vt; simpl in *.
  eauto.
Qed.

(* Define a simple calling convention for "standard"
   functions.  register 0 is for arguments and results.
   registers 1 2 3 and 4 are callee-saves registers,
   and registers >= 5 are caller-saves.

   It is not specified, but register 1 is usually
   used as a value stack.
 *)
Definition stdfun (l:label) (fs:{A:Type & stdFunspec A}) :=
  funptr l (projT1 fs * (value*value*value*value))
         (value_to_store_termMeas (sfs_t (projT2 fs)))
         (fun avs =>
           match avs with
             (a,(v1,v2,v3,v4)) =>
             EX v0:_,
             world_op
               (sfs_P (projT2 fs) a v0)
               (fun s =>
                 s#(V 0) = Some v0 /\
                 s#(V 1) = Some v1 /\
                 s#(V 2) = Some v2 /\
                 s#(V 3) = Some v3 /\
                 s#(V 4) = Some v4)
           end)
         (fun avs =>
           match avs with
             (a,(v1,v2,v3,v4)) =>
             EX v0:_,
             world_op
                (sfs_Q (projT2 fs) a v0)
                (fun s =>
                  s#(V 0) = Some v0 /\
                  s#(V 1) = Some v1 /\
                  s#(V 2) = Some v2 /\
                  s#(V 3) = Some v3 /\
                  s#(V 4) = Some v4)
           end).

Definition apply_P (fs:{ A:Type & stdFunspec A}) (x:projT1 fs) (v:value) : pred prog :=
  match v with
  | value_cons (value_label l) v' =>
       stdfun l fs && sfs_P (projT2 fs) x v'
  | _ => FF
  end.

Definition apply_Q (fs:{A :Type & stdFunspec A}) (x:projT1 fs) (v:value) : pred prog :=
  sfs_Q (projT2 fs) x v.

Program Definition apply_tm (fs:{A:Type & stdFunspec A}) : valueTermMeas :=
  fun v n =>
  match v, n with
  | value_cons (value_label l) v', S n' =>
      sfs_t (projT2 fs) v' n'
  | _, _ => False
  end.
Next Obligation.
  destruct v; simpl in *; intuition.
  discriminate.
  destruct v1; simpl in *; intuition; discriminate.
Qed.
Next Obligation.
 intros [? ?].
 inv H.
Qed.
Next Obligation.
 destruct v; simpl in *; try contradiction.
 destruct v1; simpl in *; try contradiction.
 destruct n; simpl in *; try contradiction.
 destruct n'; simpl in *; try contradiction.
 destruct fs; simpl in *.
 destruct s; simpl in *.
 destruct sfs_t0; simpl in *.
 f_equal; eapply e; eauto.
Qed.

Definition apply_fs (fs:{A:Type & stdFunspec A}) : {A:Type & stdFunspec A} :=
  existT _ (projT1 fs)
     (Build_stdFunspec (projT1 fs) (apply_tm fs) (apply_P fs) (apply_Q fs)).

Program Definition phi : map instruction :=
  set _ (set _ (set _ (set _ (set _ (set _ (empty _)

  (* The "map" wrapper function *)
  (L 5)
    ( (* push the values of V2 and V3 *)
      instr_cons (V 2) (V 1) (V 1) ;;
      instr_cons (V 3) (V 1) (V 1) ;;
      (* load the function pointer into V2 *)
      instr_fetch_field (V 0) 0 (V 2) ;;
      (* load the remainder of the list into V3 *)
      instr_fetch_field (V 0) 1 (V 3) ;;
      (* call the map worker function *)
      instr_getlabel (L 4) (V 5) ;;
      instr_call (V 5) ;;
      (* restore V3 *)
      instr_fetch_field (V 1) 0 (V 3) ;;
      instr_fetch_field (V 1) 1 (V 1) ;;
      (* restore V2 *)
      instr_fetch_field (V 1) 0 (V 2) ;;
      instr_fetch_field (V 1) 1 (V 1) ;;
      instr_return
    ))

  (* The "map" worker function *)
  (L 4)
    ( instr_if_nil (V 3)
       (*if nil, return nil *)
        ( instr_getlabel (L 0) (V 0) ;;
          instr_return )
       (*otherwise, recursive call*)
        ( (* get the head of the list *)
          instr_fetch_field (V 3) 0 (V 0) ;;
          (* call the mapping function *)
          instr_call (V 2) ;;
          (* push the mapped value *)
          instr_cons (V 0) (V 1) (V 1) ;;
          (* pop the head of the list *)
          instr_fetch_field (V 3) 1 (V 3) ;;
          (* recursive "map" call *)
          instr_getlabel (L 4) (V 5) ;;
          instr_call (V 5) ;;
          (* add the new list head *)
          instr_fetch_field (V 1) 0 (V 5) ;;
          instr_cons (V 5) (V 0) (V 0) ;;
          (* pop the stack *)
          instr_fetch_field (V 1) 1 (V 1) ;;
          instr_return
         )
       (* endif *)
    ))

  (* The "succ" function *)
  (L 3)
    ( instr_getlabel (L 0) (V 5) ;;
      instr_cons (V 5) (V 0) (V 0) ;;
      instr_return
    ))

  (* Set up a double-indirect call to succ.
     Call apply, which indirectly calls apply to
     call succ.
  *)
  (L 2)
    ( instr_getlabel (L 0) (V 0) ;;
      instr_getlabel (L 3) (V 1) ;;
      instr_getlabel (L 0) (V 2) ;;
      instr_getlabel (L 0) (V 3) ;;
      instr_getlabel (L 0) (V 4) ;;
      instr_cons (V 2) (V 0) (V 0) ;;
      instr_cons (V 2) (V 0) (V 0) ;;
      instr_cons (V 1) (V 0) (V 0) ;;
      instr_getlabel (L 1) (V 1) ;;
      instr_cons (V 1) (V 0) (V 0) ;;
      instr_call (V 1) ;;
      instr_return
    ))

  (* The "apply" function *)
  (L 1)
    ( instr_fetch_field (V 0) 0 (V 5) ;;
      instr_fetch_field (V 0) 1 (V 0) ;;
      instr_call (V 5) ;;
      instr_return
    ))

  (* An addition function *)
  (L 0)
    ( instr_assert (EX nm:_, add_P nm) ;;
      instr_if_nil (V 1)
        (*then *) (
          instr_return
        ) (*else *) (
          (instr_fetch_field (V 1) 0 (V 3) ;;
          instr_fetch_field (V 1) 1 (V 1) ;;
          instr_cons (V 3) (V 2) (V 2)) ;;
          instr_getlabel (L 0) (V 0) ;;
          (instr_call (V 0) ;;
           instr_return)
        )
    ).

Program Definition succ_fs : stdFunspec nat :=
  Build_stdFunspec nat
    (fun _ n => n = 0)
    (fun n v => !!(list_nat n v))
    (fun n v => !!(list_nat (S n) v)).

Definition succ_fs' : {A:Type & stdFunspec A} :=
  existT (fun X => stdFunspec X) nat succ_fs.

Lemma succ_verify : forall G,
  verify_prog phi G ->
  verify_prog
    phi
    (stdfun (L 3) succ_fs' && G).
Proof.
  intros.
  eapply verify_func_simple; auto.
  simpl. reflexivity.
  clear H.
Opaque get set funptr.
  simpl; intros.
  apply hoare_wp. simpl.
  intros [? ?].
  simpl. intuition.
  destruct a as [x [[[v1 v2] v3] v4]].
  destruct H0 as [v0 [? ?]].
  intuition.
  rewrite H7 in H5.
  inv H5.
  inv H3.
  simpl in H0.
  rewrite get_set_same.
  rewrite get_set_other. 2: discriminate.
  do 2 econstructor. intuition; eauto.
  inv H3.
  econstructor; split.
  2: repeat split;
    repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  simpl. auto.
Qed.

Section map_tm.
  Variable (f_tm : valueTermMeas).

  Fixpoint map_inner_tm (v:value) : nat -> Prop :=
    fun n =>
    match v with
      | value_label _ => n = 0
      | value_cons v1 v2 =>
          exists x1, exists x2,
           proj1_sig f_tm v1 x1 /\
           map_inner_tm v2 x2  /\
           n = 1 + x1 + 1 + x2
    end.

  Lemma map_inner_tm_fun : forall v x1 x2,
    map_inner_tm v x1 ->
    map_inner_tm v x2 ->
    x1 = x2.
  Proof.
    induction v; simpl; intros. congruence.
    destruct H as [a1 [a2 [? [? ?]]]].
    destruct H0 as [b1 [b2 [? [? ?]]]].
    subst.
    cut (a1 = b1 /\ a2 = b2).
    intuition congruence.
    split; auto.
    eapply (proj2_sig f_tm); eauto.
  Qed.
End map_tm.

Program Definition map_worker_tm (fs:{A:Type & stdFunspec A}) : termMeas :=
  fun s n =>
  match s#(V 3) with
  | Some v => map_inner_tm (sfs_t (projT2 fs)) v n
  | _ => False
  end.
Next Obligation.
 congruence.
Qed.
Next Obligation.
 simpl in *.
  destruct (x#4); simpl in *; intuition.
  eapply map_inner_tm_fun; eauto.
Qed.

Program Definition map_tm (fs:{A:Type & stdFunspec A}) : valueTermMeas :=
  fun v n =>
  match v, n with
  | value_cons _ v, S n'  =>
     map_inner_tm (sfs_t (projT2 fs)) v n'
  | _, _ => False
  end.
Next Obligation.
intros [? ?]. inv H.
Qed.
Next Obligation.
  destruct v. elim H.
  destruct n; destruct n'; try tauto.
  f_equal.
  eapply map_inner_tm_fun; eauto.
Qed.

Section map_pre_post.
  Variable A:Type.
  Variable P:A->value->pred prog.

  Fixpoint list_val_match (l:list A) (v:value) {struct l} : pred prog :=
    match l, v with
    | nil, value_label 1%positive => TT
    | x::l', value_cons v1 v2 => P x v1 && list_val_match l' v2
    | _, _ => FF
    end.
End map_pre_post.

Definition map_worker_pre (fs:{A:Type & stdFunspec A}) (x:value*label*list (projT1 fs)*value) :=
  match x with
    (v1,lab,l,v4) =>
    EX v3:_,
    world_op
      (stdfun lab fs &&
       list_val_match (projT1 fs) (sfs_P (projT2 fs)) l v3)
      (fun s =>
         s#(V 1) = Some v1 /\
         s#(V 2) = Some (value_label lab) /\
         s#(V 3) = Some v3 /\
         s#(V 4) = Some v4)
  end.

Definition map_worker_post (fs:{A:Type & stdFunspec A}) (x:value*label*list (projT1 fs)*value) :=
  match x with
    (v1,lab,l,v4) =>
    EX v0:_,
    world_op
      (stdfun lab fs &&
        list_val_match (projT1 fs) (sfs_Q (projT2 fs)) l v0)
      (fun s =>
         s#(V 0) = Some v0 /\
         s#(V 1) = Some v1 /\
         s#(V 2) = Some (value_label lab) /\
         s#(V 4) = Some v4)
  end.

Definition map_pre
  (fs:{A:Type & stdFunspec A})
  l
  (x:value) :=
  match x with
  | value_cons (value_label lab) v =>
      stdfun lab fs &&
      list_val_match (projT1 fs) (sfs_P (projT2 fs)) l v
  | _ => FF
  end.

Definition map_post
  (fs:{A:Type & stdFunspec A})
  l
  (x:value) :=
  list_val_match (projT1 fs) (sfs_Q (projT2 fs)) l x.

Definition map_spec (fs:{A:Type & stdFunspec A}) : {A:Type & stdFunspec A} :=
  existT (fun X => stdFunspec X) (list (projT1 fs))
    (Build_stdFunspec _ (map_tm fs) (map_pre fs) (map_post fs)).

Lemma map_worker_verify : forall G,
  verify_prog phi G ->
  verify_prog
    phi
    ((ALL fs:{A:Type & stdFunspec A},
         funptr (L 4) _ (map_worker_tm fs) (map_worker_pre fs) (map_worker_post fs)) && G).
Proof.
  intros.
Transparent get set.
  eapply verify_func; auto.
  simpl. reflexivity.
  clear H.
Opaque get set funptr.
  simpl; intros.
  apply hoare_wp. simpl.
  intros [? ?].
  simpl. intuition.
  destruct a as [[[v1 lab] l] v4].
  clear H2. unfold map_worker_pre in H0.
  destruct H0 as [v3 [[? ?] ?]].
  intuition.
  clear H.
  econstructor. intuition.
  eauto.
  destruct l; simpl in H2; [ left | right ].
  destruct v3; try (elim H2; fail).
  destruct l; try (elim H2; fail).
  split; auto.
  intros. inv H.
  unfold map_worker_post.
  simpl. exists (value_label 1%positive).
  intuition;
    repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  destruct v3; try (elim H2; fail).
  destruct H2.
  split. eauto.
  do 2 econstructor; intuition.
  eauto.
  hnf in H5.
  unfold map_worker_tm in H5.
  simpl in H7.
  rewrite H7 in H5. simpl in H5.
  destruct H5 as [n0 [n1 [? [? ?]]]].
  subst n.
  exists (1+n0). exists (1+n1).
  split. 2: omega.
  inv H8.
  do 5 econstructor; intuition.
  exists n0.
  econstructor.
  intuition.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  eauto.
  2: apply H0.
  simpl.
  rewrite get_set_same; auto.
  simpl.
  instantiate (1:=(p0,(v1,(value_label lab),value_cons v3_1 v3_2,v4))).
  simpl. econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  eauto.
  simpl in H12.
  destruct a'.
  hnf in H8. simpl in H8. subst.
  destruct a'0.
  rewrite worldNec_unfold in H11.
  destruct H11; subst.
  destruct H12; intuition.
  do 2 econstructor; intuition; eauto.
  inv H16.
  do 2 econstructor. intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  eauto.
  inv H16. inv H18.
  do 5 econstructor. exists n1.
  exists (value_cons x v1,lab,l,v4).
  intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  2: eapply pred_nec_hereditary; [ | apply H1 ]; auto.
  unfold map_worker_tm. simpl.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  simpl. split.
  econstructor; intuition; auto.
  eapply pred_nec_hereditary; eauto.
  eapply pred_nec_hereditary; eauto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  split. auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  simpl.
  exists n1. split. auto.
  omega.
  destruct a'. destruct a'0.
  inv H16. rewrite worldNec_unfold in H18.
  destruct H18; simpl in *; subst.
  destruct H19 as [? [? ?] ?]; intuition.
  do 2 econstructor; intuition; eauto.
  inv H23.
  do 2 econstructor; intuition;
    repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H23.
  do 2 econstructor; intuition;
    repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H23.
  exists (value_cons x x0); intuition.
  split; auto.
  eapply pred_nec_hereditary; eauto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
    repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
Qed.

Lemma map_verify : forall G,
    verify_prog phi G ->
    verify_prog
    phi
    ((ALL fs:{A:Type & stdFunspec A}, stdfun (L 5) (map_spec fs)) &&
    ((ALL fs:{A:Type & stdFunspec A},
         funptr (L 4) _ (map_worker_tm fs) (map_worker_pre fs) (map_worker_post fs))
        && G)).
Proof.
  intros.
Transparent get set.
  eapply verify_func.
  simpl. auto.
  2: apply map_worker_verify; auto.
  clear H.
Opaque get set funptr.
  simpl; intros.
  apply hoare_wp. simpl.
  intros [? ?].
  simpl. intuition.
  destruct a as [x [[[v1 v2] v3] v4]].
  destruct H0 as [v0 [? ?]]. intuition.
  rewrite H7 in H5.
  clear H H2.
  unfold map_pre in H0.
  destruct v0; try (elim H0; fail).
  destruct v0_1; try (elim H0; fail).
  destruct H0.
  do 2 econstructor; intuition; eauto.
  inv H2.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H2.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H2.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H2; inv H10.
  simpl in H5.
  destruct n; try tauto.
  do 5 econstructor.
  exists n.
  exists (value_cons v3 (value_cons v2 v1),l,x,v4).
  intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  unfold map_worker_tm. simpl.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  simpl. econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  eauto.
  destruct a'; destruct a'0.
  rewrite worldNec_unfold in H10.
  destruct H10; subst.
  destruct H12 as [? [? ?] ?]; intuition.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H16.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H16.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H16.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H16.
  destruct H2. simpl in *; subst.
  econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
Qed.

Lemma apply_verify : forall G,
  verify_prog phi G ->
  verify_prog
    phi
    ((ALL fs:{A:Type & stdFunspec A}, stdfun (L 1) (apply_fs fs)) && G).
Proof.
  intros.
Transparent get set.
  eapply verify_func; auto.
  simpl. reflexivity.
  clear H.
Opaque get set funptr.
  simpl; intros.
  apply hoare_wp. simpl.
  intros [? ?].
  simpl. intuition.
  destruct a as [x [[[v1 v2] v3] v4]].
  destruct H0 as [v0 [? ?]]. intuition.
  rewrite H6 in H5.
  unfold apply_tm in H5.
  destruct v0; try tauto.
  destruct v0_1; try tauto.
  destruct n; try tauto.
  do 2 econstructor.
  intuition; eauto.
  inv H9.
  do 2 econstructor.
  intuition; eauto.
  rewrite get_set_other. 2: discriminate.
  eauto.
  inv H9.
  do 5 econstructor.
  exists n.
  exists (x,(v1,v2,v3,v4)).
  econstructor.
  intuition.
  destruct H0.
  3: apply H0.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  simpl.
  simpl. rewrite get_set_same. auto.
  simpl.
  destruct H0.
  econstructor. split. eauto.
  repeat split;
  repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  simpl. intros. auto.
Qed.

Lemma add_verify : forall G,
  verify_prog phi G ->
  verify_prog phi (funptr (L 0) _ add_term_measure add_P add_Q && G).
Proof.
  intros. eapply verify_func_simple; auto.

Transparent get set.
  simpl. reflexivity.
  intros.
Opaque get set funptr.
  intros. apply hoare_wp.
  subst Pr Pr'. simpl.
  intros [? ?].
  destruct a as [n1 m1]; simpl in *.
  simpl; intuition.
  exists (n1,m1). simpl; split; auto.
  intuition; subst; auto.
  destruct H6.
  hnf in H4, H6. simpl V in *.
  case_eq (s#2); intros;
    rewrite H8 in H4; try tauto.
  case_eq (s#3); intros;
    rewrite H9 in H6; try tauto.
  unfold add_term_measure in H7.
  simpl in H7; rewrite H8 in H7.
  inv H7.
  exists v; intuition.
  destruct n1; simpl in H4;
    destruct v; try tauto.
  destruct l; try tauto.
  left; simpl; intuition.
  hnf. simpl. rewrite H9. auto.
  destruct v1; try tauto.
  destruct l; try tauto.
  simpl in *.
  right; simpl; intuition.
  eauto.
  do 2 econstructor; intuition.
  inv H7.
  do 2 econstructor; intuition.
  rewrite get_set_other. 2: discriminate. eauto.
  inv H7.
  do 2 econstructor; intuition.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_other. 2: discriminate.
  eauto.
  inv H7. inv H10.
  exists (L 0). exists (nat * nat)%type.
  exists add_term_measure.
  do 2 econstructor.
  exists (list_length v2).
  exists (n1, S m1).
  intuition.
  rewrite get_set_same. auto.
  unfold add_term_measure; simpl.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  apply H2.
  simpl; intuition.
  split; hnf; simpl.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  exists (list_length v2).
  unfold add_term_measure. simpl.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  destruct a' as [? ?].
  inv H7. simpl in *.
  destruct a'0 as [? ?].
  intuition; subst.
  apply worldNec_unfold in H10. destruct H10; subst.
  hnf in H13. hnf.
  simpl V in *.
  destruct (s1#3).
  replace (S n1 + m1) with (n1 + S m1) by omega. auto.
  auto.
Qed.

Program Definition main_tm : termMeas :=
  fun _ n => n = 5.

Let PROG_G :=
  (funptr (L 2) unit main_tm
                     (fun _ => TT)
                     (fun _ => store_op (fun r => exists v, r#(V 0) = Some v /\ list_nat 3 v))) &&
  ((stdfun (L 3) succ_fs') &&
   ((ALL fs:{A:Type & stdFunspec A}, stdfun (L 1) (apply_fs fs)) &&
    ((funptr (L 0) _ add_term_measure add_P add_Q) && TT))).

Lemma main_verify :
  verify_prog phi PROG_G.
Proof.
  unfold PROG_G.
  eapply verify_func_simple.
Transparent get set.
  simpl. reflexivity.
  2: apply succ_verify.
  2: apply apply_verify.
  2: apply add_verify.
  2: repeat intro; hnf; auto.
  intros.
Opaque get set funptr list_nat.
  apply hoare_wp; subst.
  simpl. intros [? ?]. subst Pr Pr'.
  simpl; intuition.
  inv H5.
  inv H7; inv H9; inv H10; inv H11; inv H12.
  clear H H0 H2 H8.
  do 2 econstructor; intuition;
      repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  inv H.
  do 2 econstructor; intuition;
      repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  inv H.
  do 2 econstructor; intuition;
      repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  inv H. inv H0.
  do 2 econstructor; intuition;
      repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  inv H.
  repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  do 5 econstructor.
  exists 2.
  evar (x1:value).
  evar (x2:value).
  evar (x3:value).
  evar (x4:value).
  exists (2,(x1,x2,x3,x4)).
  subst x1 x2 x3 x4.
  intuition.
  2: apply (H4 (apply_fs succ_fs')).
  simpl.
  repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  simpl.
  repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  econstructor; split.
  2: repeat split;
   repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  unfold apply_P.
  simpl. intuition.
Transparent list_nat.
  simpl. auto.
Opaque list_nat.
  simpl in H2.
  destruct H2.
  hnf in H. simpl in H. subst.
  destruct a'0.
  intuition.
  exists x. split; auto.
Qed.

Lemma main_totally_correct :
  forall r c,
    phi#(L 2) = Some c ->
    exists n', exists p', exists r',
      stepstar (K.squash (n',phi)) p'
        r ((c ;; instr_assert FF)::nil)
        r' nil /\
        exists v, r'#(V 0) = Some v /\ list_nat 3 v.
Proof.
  intros.
  generalize (verify_totally_correct PROG_G unit (fun _ => TT)
    (fun _ => store_op (fun r => exists v, r#(V 0) = Some v /\ list_nat 3 v))
    phi (L 2) main_tm tt); intros.
  spec H0. apply main_verify.
  spec H0. unfold PROG_G. hnf; simpl; intuition.
  spec H0 r. spec H0. intros; hnf. auto.
  spec H0 5.
  spec H0 c.
  spec H0. simpl; auto.
  spec H0. auto.
  destruct H0 as [p' [r' [? ?]]].
  econstructor.
  exists p'. exists r'.
  split; eauto.
  destruct H1; auto.
Qed.

(* For every store satisfying the addition precondition,
   calling the addition function will halt with a store
   satisfing the postcondition.
 *)

Transparent list_nat.
Lemma addition_totally_correct :
  forall r n m c,
    add_P' n m r ->
    phi#(L 0) = Some c ->
    exists n', exists p', exists r',
      stepstar (K.squash (n',phi)) p'
        r ((c ;; instr_assert FF)::nil)
        r' nil /\
      add_Q' n m r'.
Proof.
  intros.
  generalize (verify_totally_correct (funptr (L 0) _ add_term_measure add_P add_Q && TT) _ add_P add_Q phi (L 0) add_term_measure (n,m)); intros.
  spec H1. apply add_verify.
  repeat intro; hnf; auto.
  spec H1. hnf; simpl; intuition.
  spec H1 r. spec H1.
  simpl; intuition.
  spec H1 n c.
  spec H1.
  destruct H. simpl.
  unfold list_nat_var in *.
  simpl in *.
  destruct (r#2); auto.

  clear - H.
  revert v H; induction n; simpl; intros;
    destruct v; try tauto.
  destruct v1; try tauto.
  destruct l; try tauto.
  simpl. f_equal. auto.
  spec H1; auto.
  destruct H1 as [p' [r' [? ?]]].
  do 3 econstructor; split; eauto.
  destruct H2; auto.
Qed.


From iris_c.clang Require Import notations lang logic tactics.
From iris_c.lib Require Import int.

Section proof.
  Context `{clangG Σ}.

  Definition f : expr :=
    if: (!"x"@Tint8 != 0)
    then: (
      "x" <- !"x"@Tint8 - 1 ;;
      Ecall Tvoid "g" (Epair (Evar "x") (Evalue Vvoid)) ;;
      return: void)
    else: ( return: void ).

  Definition g : expr :=
    if: (!"x"@Tint8 != 0)
    then: (
      "x" <- !"x"@Tint8 - 1 ;;
      Ecall Tvoid "f" (Epair (Evar "x") (Evalue Vvoid));;
      return: void)
    else: ( return: void ).

  Definition rec_env n : env := (sset "x" (Tptr Tint8, Vptr n) semp).

  Definition Pn : Prop :=
    (∀ n: nat, Byte.repr n = ((Z.pos (Pos.of_succ_nat n) - 1%Z)%int)) ∧
    (∀ n: nat, evalbop oneq (Z.pos (Pos.of_succ_nat n)) 0%Z = Some vtrue).

  Lemma rec_example (ln: addr) (n: nat) k ks Φ:
    Pn →
    ln ↦ n @ Tint8 ∗
    "f" T↦ Function Tvoid [("x", Tptr Tint8)] f ∗
    "g" T↦ Function Tvoid [("x", Tptr Tint8)] g ∗ (WP (fill_ectxs void k, ks) {{ Φ }})
    ⊢ WP (fill_ectxs (Ecall Tvoid "f"
                            (Evalue (Vpair ln void))) k, ks) {{ Φ }}.
  Proof.
    iIntros (Hn) "[Hn [#? [#? HΦ]]]".
    iLöb as "IH" forall (n k ks Φ Hn). destruct ks.
    iApply (wp_call (rec_env ln) e _ (Vpair ln Vvoid) [("x", Tptr Tint8)])=>//.
    destruct n eqn:?; subst; iFrame "#"; iNext.
    - unfold f. wp_var. by wp_run.
    - unfold f. wp_var. wp_run=>//.
      { destruct Hn as [H1 H2].
        specialize H2 with n0. done. }
      wp_step. iNext. wp_var. wp_var. wp_run.
      wp_unfill (Ecall _ _ _).
      rewrite (fill_app (Evar "x")
                        [EKcall Tvoid "g"; EKpairl void]).
      iApply wp_bind=>//.
      wp_var. iApply wp_value=>//.
      wp_unfill (Ecall _ _ _).
      rewrite (fill_app (Epair ln void)
                        [EKcall Tvoid "g"]).
      iApply wp_bind=>//. wp_pair.
      iApply wp_value=>//.
      replace ((Z.pos (Pos.of_succ_nat n0) - 1%Z)%int)
        with (Byte.repr n0).
      iApply (wp_call (rec_env ln) (rec_env ln)
                         [EKseq (return: void)] (Vpair ln void)
                         [("x", Tptr Tint8)]);
        last iFrame "#"; first done.
      iNext. unfold g. wp_var. wp_load.
      destruct n0 eqn:Heqn; subst.
      + wp_run. simpl. wp_run. done.
      + simpl.
        wp_op=>//.
        { destruct Hn as [H1 H2]. simpl. apply H2. }
        wp_step. iApply wp_seq=>//. wp_run.
        wp_unfill (Ecall _ _ _)%E.
        rewrite (fill_app (Evar "x")
                          [EKcall Tvoid "f"; EKpairl void]).
        iApply wp_bind=>//.
        wp_var. iApply wp_value=>//.
        wp_unfill (Ecall _ _ _).
        rewrite (fill_app (Epair ln void) [EKcall Tvoid "f"]).
        iApply wp_bind=>//. wp_pair.
        iApply wp_value=>//.
        wp_unfill (Ecall _ _ _).
        replace (Z.pos (Pos.of_succ_nat n) - 1%Z)%int
        with (Byte.repr n).
        iDestruct ("IH" $! n) as "IH'".
        iDestruct ("IH'" $! _ _ _ with "[]") as "?"=>//.
        iApply ("~2" with "[-HΦ]")=>//.
        simpl. wp_run. simpl. wp_run.
        { by destruct Hn as [? ?]. }
        { by destruct Hn as [? ?]. }
      + by destruct Hn as [? ?].
  Qed.

End proof.