From Coq Require Import ssreflect.
From stdpp Require Import base gmap.
From iris.proofmode Require Import tactics.
From aneris.prelude Require Import time.
From aneris.aneris_lang.lib.serialization Require Import serialization_proof.
From aneris.aneris_lang Require Import aneris_lifting proofmode.
From aneris.examples.crdt.spec Require Import crdt_base crdt_time crdt_events crdt_denot crdt_resources.
From aneris.examples.crdt.oplib Require Import oplib_code.
From aneris.examples.crdt.oplib.spec Require Import model spec.
From aneris.examples.crdt.oplib.examples.lwwreg Require Import lwwreg_code.
From aneris.aneris_lang.lib Require Import inject list_proof.
From aneris.aneris_lang.lib.vector_clock Require Import vector_clock_proof.
From aneris.examples.crdt.oplib.proof Require Import time.

(** Last-writer-wins register. Ties broken by Lamport timestamp plus origin id. *)
Section LWWRegister.

  Context `{PayloadT : Type}.
  Context `{!EqDecision PayloadT, !Countable PayloadT}.

  Inductive LWWOp : Type :=
  | Write (v : PayloadT) : LWWOp.

  Definition lww_payload (op : LWWOp) : PayloadT :=
    match op with
    | Write v => v
    end.

  Global Instance lww_op_eqdecision : EqDecision LWWOp.
  Proof. solve_decision. Qed.

  Global Instance lww_op_countable : Countable LWWOp.
  Proof.
    refine {|
      encode op := match op with Write v => encode v end;
      decode n := Write <$> @decode _ _ _ n;
    |}.
    intros []. rewrite decode_encode /=. done.
  Qed.

  (* TODO: make the denotation more generic by not depending on vector clocks.
     (Needed if we want to implement with state-based CRDTs). *)

  Fixpoint to_lamport (vc : vector_clock) : nat :=
    match vc with
    | nil => 0
    | h :: t => h + to_lamport t
    end.

  Lemma vector_clock_le_to_lamport_le vc vc' :
    vector_clock_le vc vc' -> to_lamport vc <= to_lamport vc'.
  Proof.
    intros Hle.
    rewrite /vector_clock_le in Hle.
    induction Hle; [done | simpl; lia].
  Qed.

  Lemma vector_clock_lt_to_lamport_lt vc vc' :
    vector_clock_lt vc vc' -> to_lamport vc < to_lamport vc'.
  Proof.
    intros [Hle Hlt].
    induction Hle; [by inversion Hlt |].
    simpl.
    destruct (decide (x = y)) as [-> | Hne].
    - simpl in Hlt.
      inversion Hlt as [ | ? ? Htail]; subst; [exfalso; simpl in *; lia |].
      apply IHHle in Htail; lia.
    - assert (x < y) as ? by lia.
      apply vector_clock_le_to_lamport_le in Hle; lia.
  Qed.

  Definition lww_lt (e e' : Event LWWOp) : Prop :=
    let ts := to_lamport (EV_Time e) in
    let ts' := to_lamport (EV_Time e') in
    (ts < ts') ∨ (ts = ts' ∧ (EV_Orig e) < (EV_Orig e')).

  Global Instance lwwlt_strict : StrictOrder lww_lt.
  Proof.
    constructor.
    - intros e [Hl | [_ Hr]]; [lia | destruct e; lia].
    - intros a b c [Hlt | [Heq Ho]] [Hlt' | [Heq' Ho']]; try (left; lia).
      right; split; lia.
  Qed.

  Definition lww_max (e : Event LWWOp) (s : gset (Event LWWOp)) : Prop :=
    e ∈ s ∧ (∀ e', e' ∈ s -> e' ≠ e -> lww_lt e' e).

  Definition LWWSt : Type := option (Event LWWOp).

  Definition lww_denot (s : gset (Event LWWOp)) (st : LWWSt) : Prop :=
    (s = ∅ ∧ st = None) ∨ (∃ e, st = Some e ∧ events_ext s ∧ lww_max e s).

  Global Instance lww_denot_fun : Rel2__Fun lww_denot.
  Proof.
    constructor; unfold lww_denot.
    intros s b b'.
    intros [[-> ->] |[e [Hbeq [Hext [Hein Hmax]]]]] [[Heq Hb] | [e' (-> & _ & [Hein' Hmax'])]].
    - done.
    - exfalso; set_solver.
    - exfalso.
      rewrite Heq in Hein.
      set_solver.
    - destruct (decide (e = e')) as [-> | Hne]; [done|].
      assert (e' ≠ e) as Hne'; [done|].
      pose proof Hein as Hlwwlt.
      pose proof Hein' as Hlwwlt'.
      apply Hmax in Hlwwlt'; auto.
      apply Hmax' in Hlwwlt; auto.
      destruct Hlwwlt as [He1 | He2]; destruct Hlwwlt' as [He1' | He2'].
     + exfalso; lia.
     + destruct He2' as [Heqt _].
       exfalso; lia.
     + destruct He2 as [? ?].
       exfalso; lia.
     + destruct He2 as [_ Horig].
       destruct He2' as [_ Horig'].
       exfalso; lia.
  Qed.

  Global Instance lww_denot_instance : CrdtDenot LWWOp LWWSt :=
    { crdt_denot := lww_denot }.

End LWWRegister.

Global Arguments LWWOp : clear implicits.

Section OpLWWRegister.

  Context (PT : Type). (* payload type *)
  Context `{!EqDecision PT, !Countable PT}.

  Definition op_lww_register_effect (st : LWWSt) (ev : Event (LWWOp PT)) (st' : LWWSt) : Prop :=
    (st = None ∧ st' = Some ev) ∨
      (∃ e, st = Some e ∧
            ((st' = Some e ∧ lww_lt ev e) ∨
             (st' = Some ev ∧ lww_lt e ev))).

  Lemma op_lww_register_effect_fun st : Rel2__Fun (op_lww_register_effect st).
  Proof.
    constructor.
    unfold op_lww_register_effect.
    intros a b b' [Hl | Hr] [Hl' | Hr'].
    - destruct Hl as [_ ->].
      destruct Hl' as [_ ->].
      done.
    - destruct Hl as [-> ->].
      destruct Hr' as [e [Heq _]].
      exfalso.
      inversion Heq.
    - destruct Hr as [e [-> Hlt]].
      destruct Hl' as [Heq _].
      exfalso.
      inversion Heq.
    - destruct Hr as [e [-> [[-> Hltl] | [Heq Hlt]]]];
      destruct Hr' as [e' [Heqe [[-> Hltl'] | [Heq' Hlt']]]].
      + done.
      + assert (e = e') as ->; [inversion Heqe; done|].
        exfalso.
        apply (irreflexivity lww_lt a).
        eapply transitivity; eauto.
      + assert (e = e') as ->; [inversion Heqe; done|].
        exfalso.
        apply (irreflexivity lww_lt a).
        eapply transitivity; eauto.
      + rewrite Heq Heq'; done.
  Qed.

  Lemma lww_max_singleton (ev : Event (LWWOp PT)) : lww_max ev {[ev]}.
  Proof.
    split; [set_solver|].
    intros e' ->%elem_of_singleton Hne.
    exfalso.
    by apply Hne.
  Qed.

  Lemma lww_max_singleton' (e e' : Event (LWWOp PT)) : lww_max e {[e']} -> e = e'.
  Proof.
    intros [->%elem_of_singleton _]; done.
  Qed.

  Hint Resolve lww_max_singleton : core.
  Hint Resolve events_ext_singleton : core.

  Instance op_lww_register_effect_coh : OpCrdtEffectCoh op_lww_register_effect.
  Proof.
    intros s ev st st' [[-> ->] | [e [Heq [_ Hlww]]]] Hnotin Hmax Hevs_ext Htot.
    - split.
      + intros [[_ ->] | [e [He _]]].
        * right; exists ev.
          assert (∅ ∪ {[ev]} = {[ev]}) as ->; [set_solver|].
          eauto.
        * exfalso; inversion He.
      + intros [[Heq _] | [e [Heq [Hext Hmax']]]].
        * exfalso; set_solver.
        * left.
          rewrite Heq.
          assert (∅ ∪ {[ev]} = ({[ev]} : gset (Event (LWWOp PT)))) as Hset.
          { set_solver. }
          rewrite Hset in Hmax'.
          apply lww_max_singleton' in Hmax' as ->.
          done.
    - split.
      + intros [[-> ->] | [e' [-> [[-> Hlt] | [-> Hlt]]]]].
        * exfalso.
          inversion Heq.
        * inversion Heq; subst.
          right.
          assert (lww_max e (s ∪ {[ev]})) as ?; [ | by eauto].
          destruct Hlww as [Hein Hemax].
          split; [set_solver|].
          intros e' [Hein' | ->%elem_of_singleton]%elem_of_union Hne; [|done].
          apply Hemax; done.
        * right.
          assert (lww_max ev (s ∪ {[ev]})) as ?; [ | by eauto].
          split; [set_solver|].
          intros e'' [Hein' | ->%elem_of_singleton]%elem_of_union Hne; [|done].
          inversion Heq; subst.
          destruct (decide (e'' = e)) as [-> | Hne']; [done|].
          destruct Hlww as [_ Hemax].
          apply Hemax in Hein'; [|done].
          eapply transitivity; eauto.
      + intros [[Hnone _] | Hsome]; [set_solver|].
        destruct Hsome as [e' (-> & Hext' & Hmax')].
        rewrite Heq.
        destruct Hmax' as [[Hein' | ->%elem_of_singleton]%elem_of_union Hmax'].
        * destruct (decide (e = e')) as [-> | Hne].
          ** right.
             exists e'. split; [done|].
             left; split; [done|].
             apply Hmax'; [set_solver|].
             intros ->.
             apply Hnotin; done.
          ** exfalso.
             apply (irreflexivity lww_lt e).
             destruct Hlww as [Hin Hlww].
             apply Hlww in Hein'; [|done].
             assert (e ∈ s ∪ {[ev]}) as Hein; [set_solver|].
             apply Hmax' in Hein; [|done].
             eapply transitivity; eauto.
        * right; exists e.
          split; [done|].
          right.
          destruct Hlww as [Hin Hlww].
          assert (e ∈ s ∪ {[ev]}) as Hein; [set_solver|].
          split; [done|].
          apply Hmax'; [set_solver|].
          intros ->.
          apply Hnotin; done.
  Qed.

  Definition op_lww_register_init_st : @LWWSt PT := None.

  Lemma op_lww_register_init_st_coh : ⟦ (∅ : gset (Event (LWWOp PT))) ⟧ ⇝ op_lww_register_init_st.
  Proof. by left. Qed.

  Global Instance op_lww_register_model_instance : OpCrdtModel (LWWOp PT) LWWSt := {
    op_crdtM_effect := op_lww_register_effect;
    op_crdtM_effect_fun := op_lww_register_effect_fun;
    op_crdtM_effect_coh := op_lww_register_effect_coh;
    op_crdtM_init_st := op_lww_register_init_st;
    op_crdtM_init_st_coh := op_lww_register_init_st_coh
  }.

End OpLWWRegister.

Section LWWreg_proof.
  Context `{PayloadT : Type}.
  Context `{!EqDecision PayloadT, !Countable PayloadT}.
  Context `{!Inject PayloadT val}.
  Context `{!∀ p : PayloadT, Serializable vl_serialization $ p}.
  Context `{!anerisG M Σ}.

  (* TODO: generalize the payload type *)
  Notation LWWOp' := (LWWOp PayloadT).
  Notation LWWSt' := (@LWWSt PayloadT).
  Notation Event' := (Event LWWOp').

  Context `{!CRDT_Params, !OpLib_Res LWWOp'}.

  Definition lww_register_OpLib_Op_Coh := λ (op : LWWOp') v, match op with Write z => v = $z end.

  Lemma lww_register_OpLib_Op_Coh_Inj (o1 o2 : LWWOp') (v : val) :
    lww_register_OpLib_Op_Coh o1 v → lww_register_OpLib_Op_Coh o2 v → o1 = o2.
  Proof. destruct o1; destruct o2; simpl; intros ? ?; simplify_eq; done. Qed.

  Lemma lww_register_OpLib_Coh_Ser (op : LWWOp') (v : val) :
    lww_register_OpLib_Op_Coh op v → Serializable vl_serialization v.
  Proof.
    destruct op; rewrite /lww_register_OpLib_Op_Coh; intros ?; simplify_eq; apply _.
  Qed.

  (* TODO: move to the right place. *)
  Global Instance vector_clock_inject : Inject vector_clock val :=
    { inject := vector_clock_to_val }.

  Definition lww_register_OpLib_State_Coh (st : LWWSt') (v : val) : Prop :=
    (v = NONEV ∧ st = None) ∨
    (∃ w ev, v = SOMEV w ∧
             st = Some ev ∧
             w = PairV (PairV $(lww_payload (EV_Op ev)) $(EV_Time ev)) #(EV_Orig ev)).

  Global Instance LWW_OpLib_Params : OpLib_Params LWWOp' LWWSt' :=
  {|
    OpLib_Serialization := vl_serialization;
    OpLib_State_Coh := lww_register_OpLib_State_Coh;
    OpLib_Op_Coh := lww_register_OpLib_Op_Coh;
    OpLib_Op_Coh_Inj := lww_register_OpLib_Op_Coh_Inj;
    OpLib_Coh_Ser := lww_register_OpLib_Coh_Ser
  |}.

  Lemma lww_register_init_st_fn_spec : ⊢ init_st_fn_spec lwwreg_init_st.
  Proof.
    iIntros (addr).
    iIntros "!#" (Φ) "_ HΦ".
    rewrite /lwwreg_init_st.
    wp_pures.
    iApply "HΦ".
    iPureIntro.
    left; done.
  Qed.

  Lemma wp_vc_to_lamport addr vcv vc :
    {{{ ⌜is_vc vcv vc⌝ }}}
      vc_to_lamport vcv @[ip_of_address addr]
    {{{ l, RET #l; ⌜l = to_lamport vc⌝ }}}.
  Proof.
    generalize dependent vcv.
    induction vc as [ | h t IH]; iIntros (vcv Φ) "%Hvc HΦ"; rewrite /vc_to_lamport;
      inversion Hvc; subst.
    - wp_pures; iApply ("HΦ" $! 0); done.
    - match goal with
      | [ H : vcv = _ ∧ _ |- _ ] => destruct H as [-> Hislist]
      end.
      do 10 wp_pure _.
      wp_apply IH; [done|].
      iIntros (l) "%Htolamp"; wp_pures.
      assert ((Z.add (Z.of_nat h) (Z.of_nat l)) = Z.of_nat (h + l)) as -> by lia.
      iApply "HΦ"; iPureIntro.
      rewrite Htolamp; simpl; done.
  Qed.

  (* TODO: move to vector clock file *)
  Lemma wp_vect_eq vcv1 vcv2 vc1 vc2 addr :
    {{{ ⌜is_vc vcv1 vc1⌝ ∗ ⌜is_vc vcv2 vc2⌝ }}}
      vect_eq vcv1 vcv2 @[ip_of_address addr]
    {{{ (b : bool), RET #b; ⌜b = true <-> vc1 = vc2⌝}}}.
  Proof.
    iIntros (Φ) "[%Hvc1 %Hvc2] HΦ"; rewrite /vect_eq; wp_pures.
    wp_apply wp_vect_leq; [done|].
    iIntros (v) "->".
    destruct (bool_decide_reflect (vector_clock_le vc1 vc2)) as [Hle | Hne]; wp_pures.
    - wp_apply wp_vect_leq; [done|].
      iIntros (v') "->".
      destruct (bool_decide_reflect (vector_clock_le vc2 vc1)) as [Hle' | Hne'];
        wp_pures; iApply "HΦ"; iPureIntro; split; intros Heq; [| done | done | ].
      + apply (@anti_symm _ _ vector_clock_le); [apply _| done | done].
      + exfalso; apply Hne'; rewrite Heq; apply reflexivity.
    - iApply "HΦ"; iPureIntro; split; [done|];
        intros Heq; exfalso; apply Hne; rewrite Heq; apply reflexivity.
  Qed.

  Lemma wp_vect_lt vcv1 vcv2 vc1 vc2 addr :
    {{{ ⌜is_vc vcv1 vc1⌝ ∗ ⌜is_vc vcv2 vc2⌝ }}}
      vect_lt vcv1 vcv2 @[ip_of_address addr]
    {{{ (b : bool), RET #b; ⌜b = true <-> vector_clock_lt vc1 vc2⌝ }}}.
  Proof.
    iIntros (Φ) "[%Hvc1 %Hvc2] HΦ"; rewrite /vect_lt; wp_pures.
    wp_apply wp_vect_leq; [done |].
    iIntros (v) "->".
    destruct (bool_decide_reflect (vector_clock_le vc1 vc2)) as [Hle | Hne]; wp_pures.
    - wp_apply wp_vect_eq; [done|].
      iIntros (b) "%Hb".
      destruct b; wp_pures; iApply "HΦ"; iPureIntro; split; intros Harg.
      + inversion Harg.
      + pose proof ((iffLR Hb) eq_refl) as ->.
        apply vector_clock_lt_irreflexive in Harg; done.
      + apply vector_clock_le_eq_or_lt in Hle as [-> | Hne]; [ | done].
        exfalso; pose proof ((iffRL Hb) eq_refl) as ?; done.
      + done.
    - iApply "HΦ"; iPureIntro; split; [done| intros Hlt].
      exfalso; apply Hne; by apply vector_clock_lt_le.
  Qed.

  Definition is_ts (vc : vector_clock) (orig : nat) (v : val) :=
    ∃ vcv, v = PairV vcv #orig ∧ is_vc vcv vc.

  Definition ts_lt vc1 orig1 vc2 orig2 :=
    let l1 := to_lamport vc1 in
    let l2 := to_lamport vc2 in
    (l1 < l2) ∨ (l1 = l2 ∧ orig1 < orig2).

  Lemma ts_lt_lww_lt (ev1 ev2 : Event') :
    ts_lt (EV_Time ev1) (EV_Orig ev1) (EV_Time ev2) (EV_Orig ev2) -> lww_lt ev1 ev2.
  Proof.
    intros [Hlt1 | Hlt2]; [left | right]; done.
  Qed.

  Lemma wp_tstamp_lt vc1 orig1 vc2 orig2 tsv1 tsv2 addr :
    {{{ ⌜is_ts vc1 orig1 tsv1⌝ ∗ ⌜is_ts vc2 orig2 tsv2⌝ }}}
      tstamp_lt tsv1 tsv2 @[ip_of_address addr]
    {{{ b, RET #b; ⌜b = true <-> ts_lt vc1 orig1 vc2 orig2⌝ }}}.
  Proof.
    iIntros (Φ) "[%Hvc1 %Hvc2] HΦ"; rewrite /tstamp_lt; wp_pures.
    destruct Hvc1 as [vcv1 [-> Hvc1]]; destruct Hvc2 as [vcv2 [-> Hvc2]]; wp_pures.
    wp_apply wp_vc_to_lamport; [done |]; iIntros (l1) "%Hl1"; wp_pures.
    wp_apply wp_vc_to_lamport; [done |]; iIntros (l2) "%Hl2"; wp_pures.
    destruct (bool_decide_reflect (l1 < l2)%Z) as [Hle | Hnle]; wp_pures.
    - iApply "HΦ"; iPureIntro; split; [ | done].
      intros _; left; lia.
    - destruct (bool_decide_reflect (@eq Z l1 l2)%Z) as [Heq | Hne]; wp_pures.
      + destruct (bool_decide_reflect (orig1 < orig2)%Z) as [Hlo | Hnlo]; iApply "HΦ";
          iPureIntro.
        * split; [|done].
          intros _; right.
          rewrite <- Hl1, <- Hl2; auto with lia.
        * split; [done| intros [Hlt1 | [_ Hlt2]]]; lia.
      + iApply "HΦ"; iPureIntro; split; [done | intros [Hlt1 | Hlt2]]; lia.
  Qed.

  Lemma lww_register_effect_spec : ⊢ effect_spec lwwreg_effect.
  Proof.
    iIntros (addr ev st s log_ev log_st).
    iIntros "!#" (Φ) "(%Hev & %Hst & %Hs & %Hevs) HΦ".
    rewrite /lwwreg_effect.
    destruct log_ev as [[op] orig vc].
    destruct Hev as (evpl&evvc&evorig&?&Hevpl&Hisvc&?).
    destruct Hevs as (Hev & Hmax & Hext & Htot).
    simplify_eq/=.
    wp_pures.
    destruct Hst as [[-> ->] | Hsome].
    - wp_pures.
      iApply "HΦ".
      iPureIntro.
      set ev := (@Build_Event vc_time LWWOp' (Write op) orig vc).
      exists (Some ev).
      split.
      + right.
        eexists _, ev.
        split; [eauto|].
        apply is_vc_vector_clock_to_val in Hisvc.
        assert (time {| EV_Op := Write op; EV_Orig := orig; EV_Time := vc |} = vc) as Heq.
        { compute. done. }
        rewrite Heq in Hisvc.
        rewrite <- Hisvc.
        done.
      + by left.
    - destruct Hsome as [w [ev (-> & -> & ->)]].
      wp_pures.
      rewrite /assert.
      wp_apply wp_tstamp_lt; [iPureIntro|].
      { split; last first.
        + rewrite /is_ts; eexists; eauto.
        +  rewrite /is_ts; eexists; split; [eauto| eapply vector_clock_to_val_is_vc]. }
      iIntros (b) "%Hts".
      destruct b; wp_pures.
      + iApply "HΦ"; iPureIntro.
        set new_ev := (@Build_Event vc_time LWWOp' (Write op) orig vc).
        exists (Some new_ev).
        split.
        * right.
          exists (PairV (PairV $op evvc) #orig), new_ev.
          repeat split; try eauto.
          subst new_ev; simpl.
          apply is_vc_vector_clock_to_val in Hisvc.
          assert (time {| EV_Op := Write op; EV_Orig := orig; EV_Time := vc |} = vc) as Heq.
          { compute; done. }
          rewrite Heq in Hisvc; rewrite Hisvc; done.
        * right; exists ev; split; [done|]; right; split; [done|].
          apply ts_lt_lww_lt.
          apply Hts; done.
      + wp_apply wp_tstamp_lt; [iPureIntro|].
        { split; last first.
          +  rewrite /is_ts; eexists; split; [eauto| eapply vector_clock_to_val_is_vc].
          + rewrite /is_ts; eexists; eauto. }
        iIntros (b') "%Hts'".
        destruct b'; wp_pures.
        * iApply "HΦ".
          iPureIntro. exists (Some ev); split.
          ** right. exists (PairV (PairV $(lww_payload (EV_Op ev)) (vector_clock_to_val (EV_Time ev))) #(EV_Orig ev)).
             eauto.
          ** right. exists ev. split; [done|]. left. split; [done|].
             apply ts_lt_lww_lt.
             simpl in *.
             assert (time {| EV_Op := Write op; EV_Orig := orig; EV_Time := vc |} = vc) as Heq.
             { compute; done. }
             rewrite Heq in Hts'.
             by apply Hts'.
        * exfalso.
          assert (time {| EV_Op := Write op; EV_Orig := orig; EV_Time := vc |} = vc) as Heq.
          { compute; done. }
          rewrite Heq in Hts. rewrite Heq in Hts'.
          destruct (decide (to_lamport (EV_Time ev) < to_lamport vc)) as [Hlt | Hnlt].
          ** assert (ts_lt (EV_Time ev) (EV_Orig ev) vc orig) as Hcontra.
             { left; done. }
             apply Hts in Hcontra.
             inversion Hcontra.
          ** destruct (decide (to_lamport vc < to_lamport (EV_Time ev))) as [Hlt' | Hnlt'].
             { assert (ts_lt vc orig (EV_Time ev) (EV_Orig ev)) as Hcontra.
               { left; done. }
               apply Hts' in Hcontra.
               inversion Hcontra. }
             assert (to_lamport (EV_Time ev) = to_lamport vc) as Hleq by lia.
             destruct (decide (orig < (EV_Orig ev))) as [Holt | Honlt].
             { assert (ts_lt vc orig (EV_Time ev) (EV_Orig ev)) as Hcontra.
               { right; done. }
               apply Hts' in Hcontra.
               inversion Hcontra. }
             destruct (decide ((EV_Orig ev) < orig)) as [Holt' | Honlt'].
             { assert (ts_lt (EV_Time ev) (EV_Orig ev) vc orig ) as Hcontra.
               { right; done. }
               apply Hts in Hcontra.
               inversion Hcontra. }
             assert (orig = (EV_Orig ev)) as Hoeq by lia.
             set new_ev := (@Build_Event vc_time LWWOp' (Write op) orig vc).
             destruct Hs as [[_ Hnone] | [e [Heeq [_ [Hein Hemax]]]]]; [inversion Hnone; done|].
             simplify_eq /=.
             assert (e ∈ s ∪ {[{| EV_Op := Write op; EV_Orig := EV_Orig e; EV_Time := vc |}]}) as Hin1; [set_solver|].
             assert (new_ev ∈ s ∪ {[{| EV_Op := Write op; EV_Orig := EV_Orig e; EV_Time := vc |}]}) as Hin2; [set_solver|].
             assert (e ≠ new_ev) as Hne.
             { intros contra.
               apply Hev.
               subst new_ev. rewrite <- contra.
               done. }
             pose proof (Htot e new_ev Hin1 Hin2 Hne eq_refl) as
               [Hlt1%vector_clock_lt_to_lamport_lt | Hlt2%vector_clock_lt_to_lamport_lt].
             *** rewrite /time /Event_Timed in Hlt1; simpl in Hlt1; done.
             *** rewrite /time /Event_Timed in Hlt2; simpl in Hlt2; done.
  Qed.

  Lemma lww_register_crdt_fun_spec : ⊢ crdt_fun_spec lwwreg_crdt.
  Proof.
    iIntros (addr).
    iIntros "!#" (Φ) "_ HΦ".
    rewrite /lwwreg_crdt.
    wp_pures.
    iApply "HΦ".
    iExists _, _; iSplit; first done.
    iSplit; [iApply lww_register_init_st_fn_spec|iApply lww_register_effect_spec].
  Qed.

  Lemma lww_init_spec :
    init_spec (oplib_init
               (s_ser (s_serializer OpLib_Serialization))
               (s_deser (s_serializer OpLib_Serialization))) -∗
    init_spec_for_specific_crdt
    (lwwreg_init (s_ser (s_serializer vl_serialization)) (s_deser (s_serializer vl_serialization))).
  Proof.
    iIntros "#Hinit" (repId addr addrs_val).
    iIntros (Φ) "!# (%Haddrs & %Hrepid & Hprotos & Hskt & Hfr & Htoken) HΦ".
    rewrite /lwwreg_init.
    wp_pures.
    wp_apply ("Hinit" with "[$Hprotos $Htoken $Hskt $Hfr]").
    { do 2 (iSplit; first done). iApply lww_register_crdt_fun_spec; done. }
    iIntros (get update) "(HLS & #Hget & #Hupdate)".
    wp_pures.
    iApply "HΦ"; eauto.
  Qed.

End LWWreg_proof.


(** * Theorems for [ITree.Interp.Handler] *)

(* begin hide *)
From Coq Require Import
     Setoid
     Morphisms
     RelationClasses.

From Paco Require Import paco.

From ITree Require Import
     Basics.Basics
     Basics.Category
     Core.ITreeDefinition
     Eq.Eq
     Eq.UpToTaus
     Indexed.Sum
     Interp.Interp
     Interp.Handler
     Interp.TranslateFacts
     Interp.InterpFacts
     Interp.RecursionFacts.

Import ITreeNotations.
Import ITree.Basics.Basics.Monads.

Local Open Scope itree_scope.

(* end hide *)

Section HandlerCategory.

Local Opaque eutt ITree.bind interp ITree.trigger.

Instance Proper_Cat_Handler {A B C}
  : @Proper (Handler A B -> Handler B C -> Handler A C)
            (eq2 ==> eq2 ==> eq2)
            cat.
Proof.
  cbv; intros.
  apply eutt_interp; auto.
Qed.

Instance CatIdR_Handler : CatIdR Handler.
Proof.
  cbv; intros.
  rewrite interp_trigger_h. reflexivity.
Qed.

Instance CatIdL_Handler : CatIdL Handler.
Proof.
  cbv; intros.
  rewrite interp_trigger.
  reflexivity.
Qed.

Instance CatAssoc_Handler : CatAssoc Handler.
Proof.
  cbv; intros.
  rewrite interp_interp.
  reflexivity.
Qed.

Global Instance Category_Handler : Category Handler.
Proof.
  split; typeclasses eauto.
Qed.

Global Instance InitialObject_Handler : InitialObject Handler void1.
Proof.
  cbv; contradiction.
Qed.

Instance Proper_Case_Handler {A B C}
  : @Proper (Handler A C -> Handler B C -> Handler (A +' B) C)
            (eq2 ==> eq2 ==> eq2)
            case_.
Proof.
  cbv; intros.
  destruct (_ : sum1 _ _ _); auto.
Qed.

Instance CaseInl_Handler : CaseInl Handler sum1.
Proof.
  cbv; intros.
  rewrite interp_trigger.
  reflexivity.
Qed.

Instance CaseInr_Handler : CaseInr Handler sum1.
Proof.
  cbv; intros.
  rewrite interp_trigger.
  reflexivity.
Qed.

Instance CaseUniversal_Handler : CaseUniversal Handler sum1.
Proof.
  cbv; intros.
  destruct (_ : sum1 _ _ _).
  - rewrite <- H, interp_trigger. reflexivity.
  - rewrite <- H0, interp_trigger. reflexivity.
Qed.

Global Instance Coproduct_Handler : Coproduct Handler sum1.
Proof.
  split; typeclasses eauto.
Qed.

Local Opaque Recursion.interp_mrec.

Instance Proper_Iter_Handler {A B}
  : @Proper (Handler A (A +' B) -> Handler A B)
            (eq2 ==> eq2)
            iter.
Proof.
  repeat intro.
  apply Proper_interp_mrec; auto.
Qed.

Instance IterUnfold_Handler : IterUnfold Handler sum1.
Proof.
  cbv; intros.
  rewrite interp_mrec_as_interp.
  reflexivity.
Qed.

Instance IterNatural_Handler : IterNatural Handler sum1.
Proof.
  cbv; intros.
  pattern f.
  match goal with
  | [ |- ?G ?f ] =>
    enough (HHH : G (fun T e => Tau (f T e))); cbn in *
  end.
  { etransitivity; [etransitivity; [|eapply HHH] |]; clear.
    - symmetry. apply euttge_sub_eutt, euttge_interp.
      + reflexivity.
      + apply euttge_interp_mrec; repeat intro; apply tau_euttge.
    - apply euttge_sub_eutt, euttge_interp_mrec.
      + intros ? ?. apply euttge_interp.
        * reflexivity.
        * apply tau_euttge.
      + rewrite tau_euttge. reflexivity.
  }
  match goal with
  | [ |- _ _ (_ _ _ (_ ?h0 _ _)) ] =>
    remember h0 as h eqn:EQh
    (* h is pretty big and duplicating it slows down the display of the goal,
       so we try to rewrite with EQh only when necessary. *)
  end.
  remember (Tau (f T a0)) as t eqn:tmp_t. clear tmp_t.
  revert t; einit; ecofix CIH; intros t.
  rewrite (itree_eta t).
  destruct (observe t).
  - rewrite unfold_interp_mrec; cbn.
    rewrite 2 interp_ret.
    rewrite unfold_interp_mrec.
    reflexivity.
  - rewrite unfold_interp_mrec; cbn.
    rewrite 2 interp_tau.
    rewrite (unfold_interp_mrec _ _ (Tau _)); cbn.
    estep.
  - rewrite unfold_interp_mrec; cbn.
    rewrite interp_vis.
    destruct e; cbn.
    + rewrite interp_tau.
      rewrite 2 interp_mrec_bind, interp_bind.
      subst h; cbn.
      rewrite interp_trigger.
      rewrite unfold_interp_mrec; cbn.
      rewrite interp_mrec_trigger; cbn.
      unfold Recursion.mrec.
      rewrite !interp_tau.
      rewrite (unfold_interp_mrec _ _ (Tau _)); cbn.
      rewrite !bind_tau.
      etau. rewrite tau_euttge, <- interp_bind, <- 2 interp_mrec_bind.
      setoid_rewrite (tau_euttge (interp _ _)).
      rewrite <- interp_bind.
      auto with paco.
    + rewrite interp_vis.
      rewrite interp_mrec_bind.
      subst h; cbn.
      Local Transparent eutt.
      ebind. apply (pbc_intro_h _ _ _ _ _ eq).
      { rewrite interp_mrec_as_interp, interp_interp.
        rewrite <- interp_id_h at 1.
        eapply eutt_interp; try reflexivity.
        intros ? ?.
        rewrite interp_trigger; cbn.
        reflexivity. }
      intros ? _ [].
      rewrite (unfold_interp_mrec _ _ (Tau _)); cbn.
      etau.
      rewrite tau_euttge.
      auto with paco.
Qed.

Section DinatSimulation.

Context {A B C : Type -> Type}.
Context (f0 : A ~> itree (B +' C)) (g0 : B ~> itree (A +' C)).
Context {R : Type}.

Context (f := fun T e => Tau (f0 T e)) (g := fun T e => Tau (g0 T e)).

Inductive interleaved
  : itree (A +' C) R -> itree (B +' C) R -> Prop :=
| interleaved_Ret r : interleaved (Ret r) (Ret r)
| interleaved_Left {U} (t : itree _ U) k1 k2 :
    (forall (x : U), interleaved (k1 x) (k2 x)) ->
    interleaved (interp (handle (case_ g inr_)) t >>= k1) (t >>= k2)
| interleaved_Right {U} (t : itree _ U) k1 k2 :
    (forall (x : U), interleaved (k1 x) (k2 x)) ->
    interleaved (t >>= k1) (interp (handle (case_ f inr_)) t >>= k2)
.
Hint Constructors interleaved: core.

Let hg := @case_ _ Handler _ _ _ _ _ g inr_.
Let hf := @case_ _ Handler _ _ _ _ _ f inr_.

Theorem interleaved_mrec : forall t1 t2,
    interleaved t1 t2 ->
    Recursion.interp_mrec (cat f (case_ g inr_)) t1
  ≈ Recursion.interp_mrec (cat g (case_ f inr_)) t2.
Proof.
  einit; ecofix CIH; intros.
  induction H0.
  - rewrite 2 unfold_interp_mrec; cbn. estep.
  - rewrite (itree_eta t); destruct (observe t).
    + rewrite interp_ret, 2 bind_ret_l. auto.
    + rewrite interp_tau, 2 bind_tau, 2 unfold_interp_mrec; cbn.
      estep.
    + rewrite interp_vis, bind_vis.
      rewrite bind_bind.
      rewrite (unfold_interp_mrec _ _ (Vis _ _)); cbn.
      destruct e; cbn. setoid_rewrite (tau_euttge (interp _ _)).
      * unfold cat at 3, Cat_Handler at 3, Handler.cat.
        change (g X b) with (Tau (g0 X b)).
        rewrite bind_tau, unfold_interp_mrec; cbn.
        etau. rewrite tau_euttge. ebase.
      * unfold inr_, Inr_sum1_Handler, Handler.inr_, Handler.htrigger.
        rewrite bind_trigger.
        rewrite unfold_interp_mrec; cbn.
        evis; intros; etau. rewrite tau_euttge. ebase.
  - rewrite (itree_eta t); destruct (observe t).
    + rewrite interp_ret, 2 bind_ret_l. auto.
    + rewrite interp_tau, 2 bind_tau, 2 unfold_interp_mrec; cbn.
      estep.
    + rewrite interp_vis, bind_vis.
      rewrite bind_bind.
      rewrite (unfold_interp_mrec _ _ (Vis _ _)); cbn.
      destruct e; cbn. setoid_rewrite (tau_euttge (interp _ _)).
      * unfold cat at 2, Cat_Handler at 2, Handler.cat.
        change (f X a) with (Tau (f0 X a)).
        rewrite !bind_tau, (unfold_interp_mrec _ _ (Tau _)); cbn.
        etau. rewrite tau_euttge. ebase.
      * unfold inr_, Inr_sum1_Handler, Handler.inr_, Handler.htrigger.
        rewrite bind_trigger.
        rewrite unfold_interp_mrec; cbn.
        evis; intros; etau. rewrite tau_euttge. ebase.
Qed.

End DinatSimulation.

Local Opaque eutt.
Local Transparent ITree.trigger.

Instance IterDinatural_Handler : IterDinatural Handler sum1.
Proof.
  cbv; intros a b c f0 g0 T a0.
  pose (f := fun T e => Tau (f0 T e)). pose (g := fun T e => Tau (g0 T e)).
  enough (
      Recursion.interp_mrec (cat f (case_ g inr_))
                            (interp (case_ g inr_) (f _ a0))
    ≈ interp (mrecursive (cat g (case_ f inr_))) (f _ a0)).
  { cbv in H. etransitivity; [etransitivity; [|apply H]|]; clear H.
    - symmetry. apply euttge_sub_eutt, euttge_interp_mrec.
      1: intros ? ?.
      1,2: rewrite tau_euttge; apply euttge_interp; try reflexivity.
      1,2: intros ? []; [apply tau_euttge| reflexivity].
    - apply euttge_sub_eutt, euttge_interp; [ | apply tau_euttge].
      intros ? []; try reflexivity.
      rewrite tau_euttge. apply euttge_interp_mrec.
      intros ? ?.
      rewrite tau_euttge.
      all: apply euttge_interp; try reflexivity.
      all: intros ? []; [apply tau_euttge | reflexivity].
  }
  rewrite <- interp_mrec_as_interp.

  rewrite <- (bind_ret_r (interp _ _)).
  rewrite <- (bind_ret_r (f _ a0)) at 2.

  apply interleaved_mrec.
  do 2 constructor.
Qed.

Local Opaque ITree.trigger.

Import Recursion.

Instance IterCodiagonal_Handler : IterCodiagonal Handler sum1.
Proof.
  cbv; intros a b f0 T x.
  remember (f0 T x) as t eqn:EQt; clear.
  pose (f := fun T e => Tau (f0 T e)).
  enough (interp_mrec (fun _ d => interp_mrec f (f _ d))
                      (interp_mrec f t)
          ≈ interp_mrec (fun _ e => interp (fun _ ab =>
                                              match ab with
                                              | inl1 x => ITree.trigger (inl1 x)
                                              | inr1 y => ITree.trigger y
                                              end) (f _ e))
                        (interp (fun _ ab =>
                                   match ab with
                                   | inl1 x => ITree.trigger (inl1 x)
                                   | inr1 y => ITree.trigger y
                                   end) t)).
  { subst f. etransitivity; [etransitivity; [| apply H] |]; clear H.
    - symmetry. apply euttge_sub_eutt, euttge_interp_mrec.
      + intros ? ?. apply euttge_interp_mrec; try apply tau_euttge.
        intros ? ?. apply tau_euttge.
      + apply euttge_interp_mrec; repeat intro; reflexivity + rewrite tau_euttge.
        reflexivity.
    - apply euttge_sub_eutt, euttge_interp_mrec; repeat intro;
        apply euttge_interp; try reflexivity.
      apply tau_euttge.
  }
  revert t. einit; ecofix CIH. intros.
  rewrite (itree_eta t); destruct (observe t); cbn.
  all: rewrite (unfold_interp_mrec _ _ (go _)), unfold_interp; cbn.
  1,2: rewrite unfold_interp_mrec; cbn.
  1,2: rewrite (unfold_interp_mrec _ _ (go _)); estep.
  destruct e.
  - rewrite (interp_mrec_bind _ (ITree.trigger _)).
    rewrite interp_mrec_trigger; cbn.
    unfold Recursion.mrec.
    remember (f X a0) as fxa eqn:Hfxa; unfold f in Hfxa; subst fxa.
    rewrite interp_tau, unfold_interp_mrec; cbn.
    rewrite (unfold_interp_mrec _ _ (Tau _)); cbn.
    rewrite !bind_tau.
    etau.
    rewrite tau_euttge. setoid_rewrite tau_euttge.
    rewrite <- interp_mrec_bind, <- interp_bind.
    auto with paco.
  - rewrite bind_trigger.
    setoid_rewrite tau_euttge.
    rewrite 2 unfold_interp_mrec; cbn.
    destruct s; estep.
    rewrite <- interp_mrec_bind, <- interp_bind.
    auto with paco.
Qed.

Global Instance Iterative_Handler : Iterative Handler sum1.
Proof.
  split; typeclasses eauto.
Qed.

End HandlerCategory.


Require Import VST.floyd.proofauto.
Require Import qsort3.
Require Import spec_qsort3.
Require Import float_lemmas.
Require Import Permutation.
Require Import qsort3_aux.
Require Import verif_qsort3_part1.
Require Import verif_qsort3_part2.

Lemma body_quicksort_while_part2:
forall (Espec : OracleKind) (base : val) (al : list val)
  (lo mid hi : Z) (bl : list val),
Forall def_float al ->
let N := Zlength al in
0 < N <= Z.min Int.max_signed (Ptrofs.max_signed / 8) ->
isptr base ->
0 <= lo <= mid ->
mid < hi < N ->
f_cmp Cle (Znth lo bl) (Znth mid bl) ->
f_cmp Cle (Znth mid bl) (Znth hi bl) ->
Permutation al bl ->
sorted (f_cmp Cle) (sublist 0 lo bl) ->
sorted (f_cmp Cle) (sublist (hi + 1) N bl) ->
(0 < lo ->
 Forall (f_cmp Cle (Znth (lo - 1) bl)) (sublist lo N bl)) ->
(hi + 1 < N ->
 Forall (f_cmp Cge (Znth (hi + 1) bl))
   (sublist 0 (hi + 1) bl)) ->
semax (func_tycontext f_quicksort Vprog Gprog [])
  (PROP ( )
   LOCAL (temp _mid (dnth base mid); temp _lo (dnth base lo);
   temp _hi (dnth base hi))
   SEP (data_at Ews (tarray tdouble N) bl base))
  quicksort_while_body_part2
  (normal_ret_assert
     (EX a : Z * Z * list val,
      PROP (0 <= fst (fst a) < N; 0 <= snd (fst a) < N;
      Permutation al (snd a);
      sorted (f_cmp Cle) (sublist 0 (fst (fst a)) (snd a));
      sorted (f_cmp Cle)
        (sublist (snd (fst a) + 1) N (snd a));
      0 < fst (fst a) ->
      Forall (f_cmp Cle (Znth (fst (fst a) - 1) (snd a)))
        (sublist (fst (fst a)) N (snd a));
      snd (fst a) + 1 < N ->
      Forall (f_cmp Cge (Znth (snd (fst a) + 1) (snd a)))
        (sublist 0 (snd (fst a) + 1) (snd a));
      fst (fst a) <= snd (fst a) + 1)
      LOCAL (temp _lo (dnth base (fst (fst a)));
      temp _hi (dnth base (snd (fst a))))
      SEP (data_at Ews (tarray tdouble N) (snd a) base))%assert).
Proof.
intros.
assert_PROP (field_compatible (tarray tdouble N) [] base) as FC by entailer!.
set (s := quicksort_while_body_part2); hnf in s; subst s.
abbreviate_semax.
set (M := Z.min _ _) in H0; compute in M; subst M.
pose_dnth_base lo.
pose_dnth_base mid.
pose_dnth_base hi.
pose proof (Permutation_Zlength H6).
forward.
forward.
rewrite dbase_add by (auto; rep_lia).
rewrite dbase_sub by (auto; rep_lia).
apply f_cmp_swap in H4; simpl in H4.
eapply semax_seq'.
apply forward_quicksort_do_loop; auto.
destruct H2 as [H2 H2'].
destruct H3 as [H3' H3].
clear dependent mid.
clear dependent bl.
Intros left mid right bl.
subst MORE_COMMANDS; unfold abbreviate.
assert (Hlen := Permutation_Zlength H10).
assert (Hdef_bl: Forall def_float bl) by (apply Forall_perm with al; auto).
forward_if.
-
apply andp_right; apply denote_tc_samebase_dnth; auto.
-
clear H17.  (* we don't actually care! *)
forward_call (dnth base left, hi-left+1, sublist left (hi+1) bl).
rewrite (sum_sub_pp_base N) by (try assumption; lia).
apply andp_right.
apply prop_right; prove_it_now.
apply denote_tc_samebase_dnth; auto.
apply prop_right; simpl.
rewrite (sum_sub_pp_base N) by (try assumption; lia).
simpl. f_equal. f_equal. normalize.
{
erewrite (split3_data_at_Tarray Ews tdouble (Zlength al) left (hi+1) bl bl);
 try reflexivity;
 change (@reptype CompSpecs tdouble) with val in *;
  try rep_lia.
2: compute; auto.
2: autorewrite with sublist; auto.
sep_apply data_at_dnth; try lia.
set (s := Ptrofs.max_signed / 8) in *; compute in s; subst s.
rep_lia.
sep_apply data_at_dnth; try lia.
set (s := Ptrofs.max_signed / 8) in *; compute in s; subst s.
rep_lia.
unfold tarray.
replace (hi-left+1) with (hi+1-left) by lia.
cancel.
}
set (M := Z.min _ _); compute in M; subst M.
autorewrite with sublist.
split3; try lia.
apply Forall_sublist; auto.
Intros bl'.
assert (Hlen_bl' := Permutation_Zlength H17);
  autorewrite with sublist in Hlen_bl'.
forward.
replace base with (dnth base 0) at 1
 by (make_Vptr base; unfold dnth; simpl; normalize).
rewrite dbase_add by (auto; rep_lia). rewrite Z.add_0_l.
Exists (lo, right,
       (sublist 0 left bl ++ bl' ++ sublist (hi+1) N bl)).
unfold fst, snd.
entailer!.
+
clear H31 H30 H29 H28 H27 H26 H25 H24 H23 H22 H21 H20 H19.
clear Delta_specs FC H1 H11 H13 base.
clear H0 Espec.
split.
eapply Permutation_trans; [apply H10|].
apply Permutation_trans with
 (sublist 0 left bl ++ sublist left (hi+1) bl ++ sublist (hi+1) N bl).
autorewrite with sublist. auto.
apply Permutation_app_head.
apply Permutation_app_tail.
auto.
subst N; rewrite Hlen in *; set (N := Zlength bl) in *.
clear al H H10 Hlen.
eapply justify_quicksort_call1; eassumption.
+
erewrite (split3_data_at_Tarray Ews tdouble N left (hi+1));
 try reflexivity; try lia.
2: compute; auto.
3:{ rewrite (sublist_same 0 N). reflexivity. lia. list_solve. }
2: list_solve.
autorewrite with sublist.
replace (hi-left+1) with (hi+1-left) by (clear; lia).
fold N.
fold (tarray tdouble N).
rewrite <- !dnth_base_field_address0 by (auto; lia).
replace  (hi + 1 - left - Zlength bl' + (hi + 1))
  with (hi+1) by lia.
replace (N - left - Zlength bl' + (hi + 1)) with N by lia.
cancel.
autorewrite with sublist.
cancel.
-
clear H17.  (* we don't actually care! *)
forward_call (dnth base lo, right-lo+1, sublist lo (right+1) bl).
rewrite (sum_sub_pp_base N) by (try assumption; lia).
apply andp_right.
apply prop_right; prove_it_now.
apply denote_tc_samebase_dnth; auto.
apply prop_right; simpl.
rewrite (sum_sub_pp_base N) by (try assumption; lia).
simpl. f_equal. f_equal. normalize.
{
erewrite (split3_data_at_Tarray Ews tdouble (Zlength al) lo (right+1) bl bl);
 try reflexivity;
 change (@reptype CompSpecs tdouble) with val in *;
  try rep_lia.
2: compute; auto.
2: autorewrite with sublist; auto.
sep_apply data_at_dnth; try lia.
set (s := Ptrofs.max_signed / 8) in *; compute in s; subst s.
rep_lia.
sep_apply data_at_dnth; try lia.
set (s := Ptrofs.max_signed / 8) in *; compute in s; subst s.
rep_lia.
unfold tarray.
replace (right-lo+1) with (right+1-lo) by lia.
cancel.
}
set (M := Z.min _ _); compute in M; subst M.
autorewrite with sublist.
split3; try lia.
apply Forall_sublist; auto.
Intros bl'.
assert (Hlen_bl' := Permutation_Zlength H17);
  autorewrite with sublist in Hlen_bl'.
forward.
replace base with (dnth base 0) at 1
 by (make_Vptr base; unfold dnth; simpl; normalize).
rewrite dbase_add by (auto; rep_lia). rewrite Z.add_0_l.
Exists (left, hi,
       (sublist 0 lo bl ++ bl' ++ sublist (right+1) N bl)).
unfold fst, snd.
entailer!.
+
clear H31 H30 H29 H28 H27 H26 H25 H24 H23 H22 H21 H20 H19.
clear Delta_specs FC H1 H11 H13 base.
clear H0 Espec.
split.
eapply Permutation_trans; [apply H10|].
apply Permutation_trans with
 (sublist 0 lo bl ++ sublist lo (right+1) bl ++ sublist (right+1) N bl).
autorewrite with sublist. auto.
apply Permutation_app_head.
apply Permutation_app_tail.
auto.
subst N; rewrite Hlen in *; set (N := Zlength bl) in *.
clear al H H10 Hlen.
eapply justify_quicksort_call2; eassumption.
+
erewrite (split3_data_at_Tarray Ews tdouble N lo (right+1));
 try reflexivity; try lia.
2: compute; auto.
3:{ rewrite (sublist_same 0 N). reflexivity. lia. list_solve. }
2: list_solve.
autorewrite with sublist.
replace (right-lo+1) with (right+1-lo) by (clear; lia).
fold N.
fold (tarray tdouble N).
rewrite <- !dnth_base_field_address0 by (auto; lia).
replace  (right + 1 - lo - Zlength bl' + (right + 1))
  with (right+1) by lia.
replace (N - lo - Zlength bl' + (right + 1)) with N by lia.
cancel.
autorewrite with sublist.
cancel.
Qed.

Lemma calculate_midpoint:
  forall N base lo hi,
0 < N <= 268435455 ->
isptr base ->
0 <= lo < N ->
0 <= hi < N ->
lo < hi ->
force_val
  (sem_binary_operation' Oadd (tptr tdouble) tint
     (dnth base lo)
     (eval_binop Oshr tint tint
        (eval_binop Osub (tptr tdouble) (tptr tdouble)
           (dnth base hi) (dnth base lo))
        (Vint (Int.repr 1)))) = dnth base (lo + (hi - lo) / 2).
Proof.
intros.
 symmetry.
 simpl. unfold dnth, sem_shift_ii, sem_sub_pp, sem_add_ptr_int. simpl.
    unfold sem_add_ptr_int, Cop.sem_add_ptr_int. simpl.
    make_Vptr base; simpl. rewrite if_true by auto. simpl.
    f_equal. rewrite Ptrofs.add_assoc. f_equal.
    normalize. f_equal.
    rewrite <- Z.mul_add_distr_l. f_equal.
    unfold Int.shr.
    rewrite !(Ptrofs.add_commut i), Ptrofs.sub_shifted.
    normalize.
    unfold Ptrofs.divs. normalize.
    rewrite <- Z.mul_sub_distr_l.
    rewrite (Int.signed_repr hi) by rep_lia.
    rewrite (Int.signed_repr lo) by rep_lia.
    rewrite (Ptrofs.signed_repr 8) by rep_lia.
    rewrite (Ptrofs.signed_repr) by rep_lia.
    rewrite Z.mul_comm, Z.quot_mul by lia.
    rewrite Int.signed_repr. f_equal.
    rewrite (Int.signed_repr (hi-lo)) by rep_lia.
    rewrite Z.shiftr_div_pow2 by lia. change (2^1) with 2.
    rewrite Int.signed_repr. auto.
    split.
    assert (0 <= (hi-lo)/2); [|rep_lia].
    apply Z.div_pos; rep_lia.
    apply Z.div_le_upper_bound; rep_lia.
    split.
    assert (0 <= (hi-lo)/2); [|rep_lia].
    apply Z.div_pos; rep_lia.
    pose proof (mid_in_range lo hi); rep_lia.
Qed.

Lemma body_quicksort_while:
forall (Espec : OracleKind) (base : val) (al : list val)
  (lo hi : Z) (bl : list val),
Forall def_float al ->
let N := Zlength al in
0 < N <= Z.min Int.max_signed (Ptrofs.max_signed/8) ->
isptr base ->
0 <= lo < N ->
0 <= hi < N ->
Permutation al bl ->
sorted (f_cmp Cle) (sublist 0 lo bl) ->
sorted (f_cmp Cle) (sublist (hi + 1) N bl) ->
(0 < lo -> Forall (f_cmp Cle (Znth (lo - 1) bl)) (sublist lo N bl)) ->
(hi + 1 < N ->
 Forall (f_cmp Cge (Znth (hi + 1) bl)) (sublist 0 (hi + 1) bl)) ->
lo < hi ->
lo <= hi+1 ->
semax (func_tycontext f_quicksort Vprog Gprog [])
  (PROP ( )
   LOCAL (temp _lo (dnth base lo); temp _hi (dnth base hi))
   SEP (data_at Ews (tarray tdouble N) bl base))
  quicksort_while_body
  (normal_ret_assert
     (EX a : Z * Z * list val,
      PROP (0 <= fst (fst a) < N; 0 <= snd (fst a) < N;
      Permutation al (snd a);
      sorted (f_cmp Cle) (sublist 0 (fst (fst a)) (snd a));
      sorted (f_cmp Cle) (sublist (snd (fst a) + 1) N (snd a));
      0 < fst (fst a) ->
      Forall (f_cmp Cle (Znth (fst (fst a) - 1) (snd a)))
        (sublist (fst (fst a)) N (snd a));
      snd (fst a) + 1 < N ->
      Forall (f_cmp Cge (Znth (snd (fst a) + 1) (snd a)))
        (sublist 0 (snd (fst a) + 1) (snd a));
      fst (fst a) <= snd (fst a) + 1)
      LOCAL (temp _lo (dnth base (fst (fst a)));
      temp _hi (dnth base (snd (fst a))))
      SEP (data_at Ews (tarray tdouble N) (snd a) base))).
Proof.
intros.
abbreviate_semax.
set (M := Z.min _ _) in H0.
compute in M. subst M.
assert (Hdef_bl: Forall def_float bl) by (apply Forall_perm with al; auto).
unfold quicksort_while_body.
simpl.
abbreviate_semax.
forward.
entailer!.
auto.
rewrite (calculate_midpoint N) by assumption.
pose proof (mid_in_range lo hi). spec H11; [lia|].
forget (lo+(hi-lo)/2) as mid.
pose_dnth_base mid.
assert (Hlen := Permutation_Zlength H4).
forward.
apply tc_val_tdouble_Znth; auto; lia.
pose_dnth_base lo.
forward.
apply tc_val_tdouble_Znth; auto; lia.
forward_if (EX bl: list val,
   PROP (f_cmp Cle (Znth lo bl) (Znth mid bl); Permutation al bl;
   sorted (f_cmp Cle) (sublist 0 lo bl);
   sorted (f_cmp Cle) (sublist (hi + 1) N bl);
   0 < lo -> Forall (f_cmp Cle (Znth (lo - 1) bl)) (sublist lo N bl);
   hi + 1 < N -> Forall (f_cmp Cge (Znth (hi + 1) bl))  (sublist 0 (hi + 1) bl))
   LOCAL (temp _mid (dnth base mid); temp _lo (dnth base lo);
   temp _hi (dnth base hi))
   SEP (data_at Ews (tarray tdouble N) bl base)).
- (* then-clause *)
match goal with |- semax _ ?Pre _ ?Post =>
forward_loop Pre continue:Post.(RA_normal) end;
  [solve [auto] | | forward; apply ENTAIL_refl ].
apply typed_true_cmp in H14.
assert (lo<mid). {
 destruct (zeq lo mid); try lia.
 clear - H14 e. subst lo. apply f_lt_irrefl in H14. contradiction.
}
forward.
forward.
forward.
forward.
rewrite !def_float_f2f by (apply Forall_Znth; auto; lia).
change (upd_Znth lo _ _) with (swap_in_list lo mid bl).
Exists (swap_in_list lo mid bl).
entailer!.
clear H22 H21 H20 H19 H18.
autorewrite with sublist.
split.
rewrite Znth_swap_in_list1 by lia.
rewrite Znth_swap_in_list2 by lia.
rewrite f_cmp_le_lt_eq. auto.
split.
eapply Permutation_trans; [eassumption| apply Permutation_swap2; lia].
rewrite !sublist_swap_in_list by lia.
split3; auto.
split; intro.
+
rewrite Znth_swap_in_list_other by lia.
eapply Forall_perm; [ | apply (H7 H18)].
rewrite sublist_swap_in_list' by lia.
apply Permutation_swap2; try list_solve.
+
rewrite Znth_swap_in_list_other by lia.
eapply Forall_perm; [ | apply (H8 H18)].
rewrite sublist_swap_in_list' by lia.
apply Permutation_swap2; try list_solve.
-
forward.
Exists bl.
entailer!.
apply typed_false_cmp in H14.
simpl in H14.
apply f_cmp_swap in H14. auto.
apply Forall_Znth; auto; lia.
apply Forall_Znth; auto; lia.
-
clear dependent bl.
Intros bl.
assert (Hdef_bl: Forall def_float bl) by (apply Forall_perm with al; auto).
pose proof (Permutation_Zlength H5).
pose_dnth_base hi.
forward.
apply tc_val_tdouble_Znth; auto; lia.
forward.
apply tc_val_tdouble_Znth; auto; lia.
forward_if (EX bl: list val,
   PROP (f_cmp Cle (Znth lo bl) (Znth mid bl);
             f_cmp Cle (Znth mid bl) (Znth hi bl);
             Permutation al bl;
   sorted (f_cmp Cle) (sublist 0 lo bl);
   sorted (f_cmp Cle) (sublist (hi + 1) N bl);
   0 < lo -> Forall (f_cmp Cle (Znth (lo - 1) bl)) (sublist lo N bl);
   hi + 1 < N -> Forall (f_cmp Cge (Znth (hi + 1) bl))  (sublist 0 (hi + 1) bl))
   LOCAL (temp _mid (dnth base mid); temp _lo (dnth base lo);
   temp _hi (dnth base hi))
   SEP (data_at Ews (tarray tdouble N) bl base)).
+
apply typed_true_cmp in H17.
apply semax_seq' with (EX bl: list val,
   PROP (f_cmp Cle (Znth mid bl) (Znth hi bl);
             f_cmp Cle (Znth lo bl) (Znth mid bl) \/
             f_cmp Cle (Znth lo bl) (Znth hi bl);
             Permutation al bl;
   sorted (f_cmp Cle) (sublist 0 lo bl);
   sorted (f_cmp Cle) (sublist (hi + 1) N bl);
   0 < lo -> Forall (f_cmp Cle (Znth (lo - 1) bl)) (sublist lo N bl);
   hi + 1 < N -> Forall (f_cmp Cge (Znth (hi + 1) bl))  (sublist 0 (hi + 1) bl))
   LOCAL (temp _mid (dnth base mid); temp _lo (dnth base lo);
   temp _hi (dnth base hi))
   SEP (data_at Ews (tarray tdouble N) bl base)).
*
abbreviate_semax.
match goal with |- semax _ ?Pre _ ?Post =>
forward_loop Pre continue:Post.(RA_normal) end;
  [solve [auto] | | forward; apply ENTAIL_refl ].
forward.
forward.
forward.
forward.
rewrite !def_float_f2f by (apply Forall_Znth; auto; lia).
Exists (swap_in_list hi mid bl).
entailer!.
clear H24 H23 H22 H21 H20 H19 H18.
split3.
rewrite Znth_swap_in_list1 by lia.
rewrite Znth_swap_in_list2 by lia.
rewrite f_cmp_le_lt_eq. auto.
rewrite Znth_swap_in_list1 by lia.
rewrite Znth_swap_in_list2 by lia.
destruct (zeq lo mid).
subst.
rewrite Znth_swap_in_list2 by lia.
left.
apply f_le_refl; auto. apply Forall_Znth; auto; lia.
rewrite Znth_swap_in_list_other by lia.
auto.
split3; [ | | split]; auto.
eapply Permutation_trans; [eassumption| ].
apply Permutation_swap2; lia.
rewrite sublist_swap_in_list by lia; auto.
rewrite sublist_swap_in_list by lia; auto.
split; intro.
rewrite Znth_swap_in_list_other by lia.
eapply Forall_perm; try apply (H8 H18).
rewrite sublist_swap_in_list' by lia.
apply Permutation_swap2; try list_solve.
rewrite Znth_swap_in_list_other by lia.
eapply Forall_perm; try apply (H14 H18).
rewrite sublist_swap_in_list' by lia.
apply Permutation_swap2; try list_solve.
*
clear dependent bl.
Intros bl.
rename H5 into H4'.
rename H6 into H5. rename H7 into H6. rename H8 into H7.
assert (Hdef_bl: Forall def_float bl) by (apply Forall_perm with al; auto).
pose proof (Permutation_Zlength H5).
abbreviate_semax.
forward.
apply tc_val_tdouble_Znth; auto; lia.
forward.
apply tc_val_tdouble_Znth; auto; lia.
forward_if.
--
apply typed_true_cmp in H17.
match goal with |- semax _ ?Pre _ ?Post =>
forward_loop Pre continue:Post.(RA_normal) end;
  [solve [auto] | | forward; apply ENTAIL_refl ].
forward.
forward.
forward.
forward.
rewrite !def_float_f2f by (apply Forall_Znth; auto; lia).
Exists (swap_in_list lo mid bl).
entailer!.
clear H24 H23 H22 H21 H20 H18 H19.
assert (lo<mid). {
 destruct (zeq lo mid); try lia.
 clear - H17 e. subst lo. apply f_lt_irrefl in H17. contradiction.
}
rewrite Znth_swap_in_list1 by lia.
rewrite Znth_swap_in_list2 by lia.
rewrite Znth_swap_in_list_other by lia.
split3; auto.
rewrite f_cmp_le_lt_eq. auto.
destruct H4'; auto.
eapply f_cmp_le_trans; try eassumption.
split3; [ | | split]; auto.
eapply Permutation_trans; [eassumption| ].
apply Permutation_swap2; try lia.
rewrite sublist_swap_in_list by lia; auto.
rewrite sublist_swap_in_list by lia; auto.
split; intro.
++
rewrite Znth_swap_in_list_other by lia.
eapply Forall_perm; try apply (H14 H19).
rewrite sublist_swap_in_list' by lia.
apply Permutation_swap2; try list_solve.
++
rewrite Znth_swap_in_list_other by lia.
eapply Forall_perm; try apply (H15 H19).
rewrite sublist_swap_in_list' by lia.
apply Permutation_swap2; try list_solve.
--
forward.
Exists bl.
entailer!.
apply typed_false_cmp in H17.
simpl in H17.
apply f_cmp_swap in H17. auto.
apply Forall_Znth; auto; lia.
apply Forall_Znth; auto; lia.
+
forward.
Exists bl.
entailer!.
apply typed_false_cmp in H17.
simpl in H17.
apply f_cmp_swap in H17. auto.
apply Forall_Znth; auto; lia.
apply Forall_Znth; auto; lia.
+
clear dependent bl.
Intros bl.
apply body_quicksort_while_part2; auto; lia.
Qed.

Lemma body_quicksort:  semax_body Vprog Gprog f_quicksort quicksort_spec.
Proof.
start_function.
rename H0 into H0''.
assert (H0' := Z.min_glb_r _ _ _ H0'').
assert (H0 := Z.min_glb_l _ _ _ H0'').
forward_if.
forward.
Exists al.
entailer!.
destruct al; autorewrite with sublist in H2; try rep_lia.
constructor.
assert (0 < N <= Int.max_signed) by rep_lia.
clear H0 H2.
assert_PROP (isptr base) by entailer!.
forward.
forward.
replace  (force_val
               (sem_binary_operation' Osub (tptr tdouble) tint
                  (eval_binop Oadd (tptr tdouble) tint base
                     (Vint (Int.repr N))) (Vint (Int.repr 1))))
  with (dnth base (N-1)).
2:{
  make_Vptr base.
  unfold dnth.
  simpl. f_equal. rewrite ptrofs_of_ints_unfold.
  rewrite Ptrofs.sub_add_opp.
  normalize.
  rewrite Ptrofs.add_assoc. f_equal.
  change (Ptrofs.neg (Ptrofs.repr 8)) with (Ptrofs.repr (-8)).
  normalize. f_equal. lia.
}
deadvars!.
subst N.
set (N := Zlength al) in *.
forward_while (EX lo:Z, EX hi:Z, EX bl: list val,
                       PROP(0 <= lo < N; 0 <= hi < N;Permutation al bl;
                                sorted (f_cmp Cle) (sublist 0 lo bl);
                                sorted (f_cmp Cle) (sublist (hi+1) N bl);
                                0<lo -> Forall (f_cmp Cle (Znth (lo-1) bl))
                                                    (sublist lo N bl);
                                hi+1<N -> Forall (f_cmp Cge (Znth (hi+1) bl))
                                                    (sublist 0 (hi+1) bl);
                                lo <= hi+1)
                       LOCAL(temp _lo (dnth base lo); temp _hi (dnth base hi))
                       SEP(data_at Ews (tarray tdouble N) bl base)).
-
Exists 0 (N-1) al.
entailer!.
autorewrite with sublist.
split3.
constructor.
constructor.
unfold dnth. clear - H0. make_Vptr base. simpl. f_equal.
  rewrite ptrofs_of_ints_unfold. normalize.
-
entailer!.
assert (0 <= lo <= Zlength al) by lia.
assert (0 <= hi <= Zlength al) by lia.
auto with valid_pointer.
-
pose_dnth_base lo. rename H10 into Hlo.
pose_dnth_base hi. rename H10 into Hhi.
rewrite <- (force_sem_cmp_pp Clt) in HRE
  by (apply isptr_dnth; auto).
eapply typed_true_pp with (N:=N) in HRE;
  eauto; try split; try assumption; try lia; simpl in HRE.
rename HRE into H10.
change Delta with (func_tycontext f_quicksort Vprog Gprog nil).
change (Ssequence _ _) with quicksort_while_body.
make_sequential.
subst POSTCONDITION; unfold abbreviate.
autorewrite with ret_assert.
apply body_quicksort_while; auto.
split. lia.
apply Z.min_glb; auto. lia.
-
forward.
assert_PROP (lo >= hi). {
entailer!.
unfold compare_pp, dnth in HRE.
destruct base; simpl in HRE; try solve [inv HRE].
rewrite if_true in HRE by auto.
rewrite !ptrofs_of_ints_unfold in HRE.
normalize in HRE.
unfold Ptrofs.ltu in HRE.
destruct (zlt _ _) in HRE; inv HRE.
rewrite <- H13 in *.
clear H13 al H1 H4 H13 H9 H10 H7 H8 H5 H6 H0.
rewrite <- (Ptrofs.repr_unsigned i) in g.
normalize in g.
destruct H12 as [? [? [? [? ?]]]].
red in H4.
simpl  sizeof in H4.
rewrite Z.max_r in H4 by rep_lia.
rewrite !Ptrofs.unsigned_repr in g by rep_lia.
lia.
} clear HRE.
Exists bl.
entailer!.
assert (lo=hi \/ lo=hi+1) by lia.
assert (Zlength al = Zlength bl)
  by (rewrite !Zlength_correct; f_equal; apply Permutation_length; auto).
rewrite H17 in *.
assert (Hdef_bl: Forall def_float bl). {eapply Forall_perm; try eassumption. }
clear - H16 H7 H8 H5 H6 H H2 Hdef_bl.
destruct H16; subst.
+
assert (hi=0 \/ 0<hi) by lia.
destruct H0.
 *
subst.
autorewrite with sublist in *.
destruct (zlt 1 (Zlength bl)).
specialize (H8 l).
rewrite sublist_one in H8 by lia.
inv H8.
rewrite <- (sublist_same 0 (Zlength bl) bl) by lia.
rewrite (sublist_split _ 1) by lia.
rewrite sublist_one by lia.
apply sorted_app with (Znth 1 bl); auto.
apply f_cmp_le_trans.
constructor.
constructor.
apply (f_cmp_swap _ _ _ H3).
constructor.
{
 clear - H6 l Hdef_bl.
 destruct bl. inv l.
 inv Hdef_bl. clear H1.
 rewrite Zlength_cons in *. change (v::bl) with ([v]++bl) in *.
 autorewrite with sublist in *.
 assert (0 < Zlength bl) by lia. clear l.
 revert H H2; induction H6; intros.
 constructor. repeat constructor. inv H2.  apply f_le_refl; auto.
 change (Znth 0 (x::y::l)) with x. inv H2.
 constructor.  apply f_le_refl; auto.
 spec IHsorted.
 rewrite Zlength_cons. rep_lia.
 spec IHsorted; auto.
 change (Znth 0 (y::l)) with y in IHsorted.
 clear - H IHsorted.
 forget (y::l) as zl.
 induction IHsorted. constructor. constructor; auto.
 eapply f_cmp_le_trans; eassumption.
}
destruct bl.
constructor.
destruct bl.
constructor.
rewrite !Zlength_cons in g.
rep_lia.
 *
specialize (H7 H0).
destruct (zlt (hi+1) (Zlength bl)).
2:{ assert (hi=Zlength bl \/ hi+1 = Zlength bl) by lia.
    destruct H1. subst. autorewrite with sublist in *. auto.
    autorewrite with sublist in *.
    clear g H6 H2 H H8.
    rewrite sublist_one in H7 by lia. inv H7. clear H4.
    rewrite (sublist_split 0 (hi-1)) in H5 by lia.
    rewrite (sublist_one (hi-1)) in H5 by lia.
    rewrite <- (sublist_same 0 (hi+1)) by lia.
    rewrite (sublist_split 0 (hi-1)) by lia.
    rewrite (sublist_split (hi-1) hi) by lia.
    rewrite (sublist_one (hi-1)) by lia.
    rewrite (sublist_one hi) by lia.
    clear - H5 H3.
    induction (sublist 0 (hi-1) bl). constructor; auto. constructor; auto.
    inv H5. destruct l; inv H1. destruct l; inv H0.
    simpl in IHl. spec IHl; auto. constructor; auto.
    simpl in *. spec IHl; auto. constructor; auto.
}
specialize (H8 l).
rewrite <- (sublist_same 0 (Zlength bl) bl) by lia.
rewrite (sublist_split 0 (hi-1)) by lia.
apply sorted_app with (Znth (hi-1) bl); auto.
apply f_cmp_le_trans.
{
clear - H0 l H5.
rewrite (sublist_split 0 (hi-1)) in H5 by list_solve.
forget (sublist 0 (hi - 1) bl) as al.
induction al. constructor.
simpl in H5.
inv H5.
destruct al. constructor.
inv H2.
destruct al; inv H1.
constructor.
constructor; auto.
}
{
rewrite (sublist_split (hi-1) hi) by rep_lia.
rewrite sublist_one by lia.
rewrite (sublist_split hi (hi+1)) by rep_lia.
rewrite sublist_one by lia.
simpl.
constructor.
rewrite (sublist_split hi (hi+1)) in H7 by rep_lia.
rewrite sublist_one in H7 by rep_lia.
inv H7.
auto.
rewrite (sublist_split 0 (hi-1)) in H8 by lia.
rewrite Forall_app in H8. destruct H8.
rewrite (sublist_split _ hi) in H3 by lia.
rewrite Forall_app in H3. destruct H3.
rewrite sublist_one in H4 by lia.
inv H4. clear H11.
apply f_cmp_swap in H10. simpl in H10.
rewrite (sublist_split _ (hi+2)) in H6|-* by lia.
rewrite sublist_one in * by lia.
clear - H10 H6.
simpl in *.
constructor; auto.
}
rewrite (sublist_split 0 (hi-1)) in H8 by lia.
{
clear - H5 H0 l Hdef_bl.
rewrite (sublist_split 0 (hi-1)) in H5 by lia.
rewrite (sublist_one (hi-1)) in H5 by lia.
clear - H5.
induction (sublist 0 (hi - 1) bl). constructor.
inv H5. destruct l; inv H1.
destruct l; inv H0.
constructor; auto.
constructor; auto.
spec IHl; auto. inv IHl; auto.
apply f_cmp_le_trans with v; auto.
}
rewrite (sublist_split _ hi) by lia.
rewrite Forall_app. split; auto.
rewrite sublist_one by lia. repeat constructor.
apply f_le_refl.
apply Forall_Znth; auto. lia.
+
spec H7; [ lia|].
rewrite Z.add_simpl_r in H7.
destruct (zlt (hi+1) (Zlength bl)).
specialize (H8 l).
rewrite <- (sublist_same 0 (Zlength bl) bl) by lia.
rewrite (sublist_split 0 (hi+1)) by lia.
apply sorted_app with (Znth (hi+1) bl); auto.
apply f_cmp_le_trans.
eapply Forall_impl; try apply H8.
clear; intros; apply (f_cmp_swap _ _ _ H).
{
clear - H6 l H2 Hdef_bl.
rewrite (sublist_split (hi+1) (hi+2)) in H6|-* by lia.
rewrite sublist_one in H6|-* by lia.
induction (sublist (hi + 2) (Zlength bl) bl).
constructor; auto.
apply f_le_refl.
apply Forall_Znth; try lia.
apply Hdef_bl.
constructor.
apply f_le_refl.
apply Forall_Znth; auto. lia.
inv H6.
spec IHl0.
destruct l0; inv H4; constructor; auto.
eapply f_cmp_le_trans; eassumption.
constructor; auto.
inv IHl0; auto.
}
assert (hi+1=Zlength bl) by lia.
autorewrite with sublist in *.
auto.
Qed.


Require Import Coq.Strings.String.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.String.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.Ptrns.
Require Import MirrorCore.Views.FuncView.
Require Import MirrorCore.Views.Ptrns.

Set Implicit Arguments.
Set Strict Implicit.
Set Maximal Implicit Insertion.

Inductive stringFunc : Set  :=
| pString  : string -> stringFunc%type.

Section StringFuncInst.
  Context {typ func : Set} {RType_typ : RType typ}.
  Context {Heq : RelDec (@eq typ)} {HC : RelDec_Correct Heq}.

  Context {Typ0_tyString : Typ0 _ string}.

  Let tyString : typ := @typ0 _ _ _ Typ0_tyString.

  Definition typeofStringFunc (nf : stringFunc) : option typ :=
    match nf with
    | pString _ => Some tyString
    end.

  Definition stringFuncEq (a b : stringFunc) : option bool :=
    match a , b with
    | pString s, pString t => Some (s ?[ eq ] t)
    end.

  Definition stringR (s : string) : typD tyString :=
    castR id string s.

  Definition string_func_symD bf :=
    match bf as bf return match typeofStringFunc bf return Type with
			  | Some t => typD t
			  | None => unit
			  end with
    | pString s => stringR s
    end.

  Global Instance RSym_StringFunc
  : SymI.RSym stringFunc :=
  { typeof_sym := typeofStringFunc;
    symD := string_func_symD ;
    sym_eqb := stringFuncEq
  }.

  Global Instance RSymOk_StringFunc : SymI.RSymOk RSym_StringFunc.
  Proof.
    split; intros.
    destruct a, b; simpl; try reflexivity.
    consider (s ?[ eq ] s0); intros; subst; congruence.
  Qed.

End StringFuncInst.

Section MakeString.
  Polymorphic Context {func : Set}.
  Polymorphic Context {FV : PartialView func stringFunc}.

  Polymorphic Definition fString s := f_insert (pString s).

  Polymorphic Definition fptrnString@{V L R} {T : Type@{V}} (p : Ptrns.ptrn@{Set V L R} string T)
  : ptrn@{Set V L R} stringFunc T :=
    fun f U good bad =>
      match f with
      | pString s => p s U good (fun x => bad f)
      end.

  Global Polymorphic Instance fptrnString_ok {T : Type} {p : ptrn string T} {Hok : ptrn_ok p} :
    ptrn_ok (fptrnString p).
  Proof.
    red; intros; try (right; unfold Fails; reflexivity).
    destruct x; simpl; destruct (Hok s).
    { left. destruct H; exists x. revert H. compute; intros.
      rewrite H. reflexivity. }
    { right; unfold Fails in *; intros; simpl; rewrite H; reflexivity. }
  Qed.

  Polymorphic Lemma Succeeds_fptrnString {T : Type} (f : stringFunc) (p : ptrn string T) (res : T)
        {pok : ptrn_ok p} (H : Succeeds f (fptrnString p) res) :
    exists s, Succeeds s p res /\ f = pString s.
  Proof.
    unfold Succeeds, fptrnString in H.
    unfold ptrn_ok in pok.
    specialize (H (option T) Some (fun _ => None)).
    destruct f; try congruence.
    specialize (pok s).
    destruct pok; [|rewrite H0 in H; congruence].
    destruct H0.
    rewrite H0 in H; inv_all; subst.
    exists s; split; [assumption | reflexivity].
  Qed.

  Global Polymorphic Instance fptrnString_SucceedsE {T : Type} {f : stringFunc}
         {p : ptrn string T} {res : T} {pok : ptrn_ok p}
  : SucceedsE f (fptrnString p) res :=
  { s_result := exists s, Succeeds s p res /\ f = pString s;
    s_elim := @Succeeds_fptrnString T f p res pok
  }.

End MakeString.

Section mkString.
  Polymorphic Context {typ func : Set}.
  Polymorphic Context {FV : PartialView func stringFunc}.

  Polymorphic Definition mkString (s : string) := Inj (typ:=typ) (fString s).

End mkString.

Section PtrnString.
  Context {typ func : Set}.
  Context {FV : PartialView func stringFunc}.

(* Putting this in the previous sectioun caused universe inconsistencies
  when calling '@mkString typ func' in JavaFunc (with typ and func instantiated) *)

  Definition ptrnString@{V L R} {T : Type@{V}} (p : ptrn@{Set V L R} string T)
  : ptrn@{Set V L R} (expr typ func) T :=
    inj (ptrn_view FV (fptrnString p)).

End PtrnString.

Require Import MirrorCore.Reify.ReifyClass.

Section ReifyString.
  Context {typ func : Set} {FV : PartialView func stringFunc}.

  Definition reify_cstring : Command (expr typ func) :=
    CPattern (ls := (string:Type)::nil) (RHasType string (RGet 0 RIgnore)) (fun x => Inj (fString x)).

  Definition reify_string : Command (expr typ func) :=
    CFirst (reify_cstring :: nil).

End ReifyString.

Arguments reify_string _ _ {_}.


Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import Integers.
Require Import Floats.
Require Import AST.
Require Import Cltypes.
Require Import Cop.
Require Import Lident.

Inductive expr : Type :=
  | Econst_int: int -> type -> expr       (**r integer literal *)
  | Econst_float: float -> type -> expr   (**r float literal *)
  | Econst_single: float32 -> type -> expr (**r single float literal *)
  | Evar: ident -> type -> expr           (**r variable *)
  | Etempvar: ident -> type -> expr       (**r temporary variable *)
  | Ederef: expr -> type -> expr          (**r pointer dereference (unary [*]) *)
  | Eaddrof: expr -> type -> expr         (**r address-of operator ([&]) *)
  | Eunop: unary_operation -> expr -> type -> expr  (**r unary operation *)
  | Ebinop: binary_operation -> expr -> expr -> type -> expr (**r binary operation *)
  | Ecast: expr -> type -> expr   (**r type cast ([(ty) e]) *)
  | Efield: expr -> ident -> type -> expr. (**r access to a member of a struct or union *)

Definition typeof (e: expr) : type :=
  match e with
  | Econst_int _ ty => ty
  | Econst_float _ ty => ty
  | Econst_single _ ty => ty
  | Evar _ ty => ty
  | Etempvar _ ty => ty
  | Ederef _ ty => ty
  | Eaddrof _ ty => ty
  | Eunop _ _ ty => ty
  | Ebinop _ _ _ ty => ty
  | Ecast _ ty => ty
  | Efield _ _ ty => ty
  end.

Inductive statement : Type :=
  | Sskip : statement                   (**r do nothing *)
  | Sassign : expr -> expr -> statement (**r assignment [lvalue = rvalue] *)
  | Sset : ident -> expr -> statement   (**r assignment [tempvar = rvalue] *)
  | Scall: option ident  -> expr -> list expr -> statement (**r function call *)
  | Ssequence : statement -> statement -> statement  (**r sequence *)
  | Sifthenelse : expr  -> statement -> statement -> statement (**r conditional *)
  | Swhile : expr -> statement -> statement (* while *)
.

Record function : Type := mkfunction {
  fn_return: type;
  fn_params: list (ident * type);
  fn_vars: list (ident * type);
  fn_temps: list (ident * type);
  fn_body: statement
}.

Definition type_of_function (f: function) : type :=
  Tfunction (type_of_params (fn_params f)) (fn_return f).

Inductive fundef : Type :=
  | Internal: function -> fundef
  | External: external_function -> typelist -> type -> fundef.

Definition type_of_fundef (f: fundef) : type :=
  match f with
  | Internal fd => type_of_function fd
  | External id args res => Tfunction args res
  end.

Definition program : Type := AST.program fundef type.


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

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

From PromisingLib Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import SimMemory.

Set Implicit Arguments.

Section Simulation.
  Definition SIM :=
    forall (ths1_src:Threads.t) (sc0_src:TimeMap.t) (mem0_src:Memory.t)
      (ths1_tgt:Threads.t) (sc0_tgt:TimeMap.t) (mem0_tgt:Memory.t), Prop.

  Definition _sim
             (sim: SIM)
             (ths1_src:Threads.t) (sc0_src:TimeMap.t) (mem0_src:Memory.t)
             (ths1_tgt:Threads.t) (sc0_tgt:TimeMap.t) (mem0_tgt:Memory.t): Prop :=
    forall sc1_src mem1_src
      sc1_tgt mem1_tgt
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEMORY1: sim_memory mem1_src mem1_tgt)
      (WF_SRC: Configuration.wf (Configuration.mk ths1_src sc1_src mem1_src))
      (WF_TGT: Configuration.wf (Configuration.mk ths1_tgt sc1_tgt mem1_tgt))
      (SC_FUTURE_SRC: TimeMap.le sc0_src sc1_src)
      (SC_FUTURE_TGT: TimeMap.le sc0_tgt sc1_tgt)
      (MEM_FUTURE_SRC: Memory.future mem0_src mem1_src)
      (MEM_FUTURE_TGT: Memory.future mem0_tgt mem1_tgt),
      <<TERMINAL:
        forall (TERMINAL_TGT: Threads.is_terminal ths1_tgt),
          <<FAILURE: Configuration.steps_failure (Configuration.mk ths1_src sc1_src mem1_src)>> \/
          exists ths2_src sc2_src mem2_src,
            <<STEPS_SRC: rtc Configuration.tau_step (Configuration.mk ths1_src sc1_src mem1_src) (Configuration.mk ths2_src sc2_src mem2_src)>> /\
            <<SC: TimeMap.le sc2_src sc1_tgt>> /\
            <<MEMORY: sim_memory mem2_src mem1_tgt>> /\
            <<TERMINAL_SRC: Threads.is_terminal ths2_src>>>> /\
      <<STEP:
        forall e tid_tgt ths3_tgt sc3_tgt mem3_tgt
          (STEP_TGT: Configuration.step e tid_tgt (Configuration.mk ths1_tgt sc1_tgt mem1_tgt) (Configuration.mk ths3_tgt sc3_tgt mem3_tgt)),
          <<FAILURE: Configuration.steps_failure (Configuration.mk ths1_src sc1_src mem1_src)>> \/
          exists tid_src ths2_src sc2_src mem2_src ths3_src sc3_src mem3_src,
            <<STEPS_SRC: rtc Configuration.tau_step (Configuration.mk ths1_src sc1_src mem1_src) (Configuration.mk ths2_src sc2_src mem2_src)>> /\
            <<STEP_SRC: Configuration.opt_step e tid_src (Configuration.mk ths2_src sc2_src mem2_src) (Configuration.mk ths3_src sc3_src mem3_src)>> /\
            <<SC3: TimeMap.le sc3_src sc3_tgt>> /\
            <<MEMORY3: sim_memory mem3_src mem3_tgt>> /\
            <<SIM: sim ths3_src sc3_src mem3_src ths3_tgt sc3_tgt mem3_tgt>>>>.

  Lemma _sim_mon: monotone6 _sim.
  Proof.
    ii. exploit IN; try apply SC1; eauto. i. des.
    splits; eauto. i.
    exploit STEP; eauto. i. des; eauto.
    right. esplits; eauto.
  Qed.
  Hint Resolve _sim_mon: paco.

  Definition sim: SIM := paco6 _sim bot6.
End Simulation.
#[export] Hint Resolve _sim_mon: paco.

Lemma sim_future
      ths_src sc1_src sc2_src mem1_src mem2_src
      ths_tgt sc1_tgt sc2_tgt mem1_tgt mem2_tgt
      (SIM: sim ths_src sc1_src mem1_src ths_tgt sc1_tgt mem1_tgt)
      (SC_FUTURE_SRC: TimeMap.le sc1_src sc2_src)
      (SC_FUTURE_TGT: TimeMap.le sc1_tgt sc2_tgt)
      (MEM_FUTURE_SRC: Memory.future mem1_src mem2_src)
      (MEM_FUTURE_TGT: Memory.future mem1_tgt mem2_tgt):
  sim ths_src sc2_src mem2_src ths_tgt sc2_tgt mem2_tgt.
Proof.
  pfold. ii.
  punfold SIM. exploit SIM; (try by etrans; eauto); eauto.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** This file defines a number of data types and operations used in
  the abstract syntax trees of many of the intermediate languages. *)

Require Import Coqlib.
Require String.
Require Import Errors.
Require Import Integers.
Require Import Floats.

Set Implicit Arguments.

(** * Syntactic elements *)

(** Identifiers (names of local variables, of global symbols and functions,
  etc) are represented by the type [positive] of positive integers. *)

Definition ident := positive.

Definition ident_eq := peq.

Parameter ident_of_string : String.string -> ident.

(** The intermediate languages are weakly typed, using the following types: *)

Inductive typ : Type :=
  | Tint                (**r 32-bit integers or pointers *)
  | Tfloat              (**r 64-bit double-precision floats *)
  | Tsingle.             (**r 32-bit single-precision floats *)

Lemma typ_eq: forall (t1 t2: typ), {t1=t2} + {t1<>t2}.
Proof. decide equality. Defined.
Global Opaque typ_eq.

Definition opt_typ_eq: forall (t1 t2: option typ), {t1=t2} + {t1<>t2}
                     := option_eq typ_eq.

Definition list_typ_eq: forall (l1 l2: list typ), {l1=l2} + {l1<>l2}
                     := list_eq_dec typ_eq.

Definition typesize (ty: typ) : Z :=
  match ty with
  | Tint => 8
  | Tfloat => 8
  | Tsingle => 4
  end.

Lemma typesize_pos: forall ty, typesize ty > 0.
Proof. destruct ty; simpl; omega. Qed.

(** All values of size 32 bits are also of type [Tany32].  All values
  are of type [Tany64].  This corresponds to the following subtyping
  relation over types. *)

Definition subtype (ty1 ty2: typ) : bool :=
  match ty1, ty2 with
  | Tint, Tint => true
  | Tfloat, Tfloat => true
  | Tsingle, Tsingle => true
  | _, _ => false
  end.

Fixpoint subtype_list (tyl1 tyl2: list typ) : bool :=
  match tyl1, tyl2 with
  | nil, nil => true
  | ty1::tys1, ty2::tys2 => subtype ty1 ty2 && subtype_list tys1 tys2
  | _, _ => false
  end.

(** Additionally, function definitions and function calls are annotated
  by function signatures indicating:
- the number and types of arguments;
- the type of the returned value, if any;
- additional information on which calling convention to use.

These signatures are used in particular to determine appropriate
calling conventions for the function. *)

Record calling_convention : Type := mkcallconv {
  cc_vararg: bool;
  cc_structret: bool
}.

Definition cc_default :=
  {| cc_vararg := false; cc_structret := false |}.

Record signature : Type := mksignature {
  sig_args: list typ;
  sig_res: option typ;
  sig_cc: calling_convention
}.

Definition proj_sig_res (s: signature) : typ :=
  match s.(sig_res) with
  | None => Tint
  | Some t => t
  end.

Definition signature_eq: forall (s1 s2: signature), {s1=s2} + {s1<>s2}.
Proof.
  generalize opt_typ_eq, list_typ_eq; intros; decide equality.
  generalize bool_dec; intros. decide equality.
Defined.
Global Opaque signature_eq.

Definition signature_main :=
  {| sig_args := nil; sig_res := Some Tint; sig_cc := cc_default |}.

(** Memory accesses (load and store instructions) are annotated by
  a ``memory chunk'' indicating the type, size and signedness of the
  chunk of memory being accessed.
  fixed: signedness is not used in vellvm *)

Inductive memory_chunk : Type :=
  | Mint: nat -> memory_chunk    (**r integer or pointer *)
  | Mfloat32                     (**r 32-bit single-precision float *)
  | Mfloat64                     (**r 64-bit double-precision float *)
.

Definition memory_chunk_eq (c1 c2: memory_chunk) : bool :=
  match c1, c2 with
  | Mint n1, Mint n2 => beq_nat n1 n2
  | Mfloat32, Mfloat32 => true
  | Mfloat64, Mfloat64 => true
  | _, _ => false
  end.

Definition chunk_eq: forall (c1 c2: memory_chunk), {c1=c2} + {c1<>c2}.
Proof. decide equality. apply eq_nat_dec. Defined.
Global Opaque chunk_eq.

(** The type (integer/pointer or float) of a chunk. *)

Definition type_of_chunk (c: memory_chunk) : typ :=
  match c with
  | Mint _ => Tint
  | Mfloat32 => Tsingle
  | Mfloat64 => Tfloat
  end.

(** The chunk that is appropriate to store and reload a value of
  the given type, without losing information. *)

Definition chunk_of_type (ty: typ) :=
  match ty with
  | Tint => Mint 31
  | Tfloat => Mfloat64
  | Tsingle => Mfloat32
  end.

(** Initialization data for global variables. *)

Inductive init_data: Type :=
  | Init_int8: int32 -> init_data
  | Init_int16: int32 -> init_data
  | Init_int32: int32 -> init_data
  | Init_int64: int64 -> init_data
  | Init_float32: float32 -> init_data
  | Init_float64: float -> init_data
  | Init_space: Z -> init_data
  | Init_addrof: ident -> int32 -> init_data.  (**r address of symbol + offset *)

(** Information attached to global variables. *)

Record globvar (V: Type) : Type := mkglobvar {
  gvar_info: V;                    (**r language-dependent info, e.g. a type *)
  gvar_init: list init_data;       (**r initialization data *)
  gvar_readonly: bool;             (**r read-only variable? (const) *)
  gvar_volatile: bool              (**r volatile variable? *)
}.

(** Whole programs consist of:
- a collection of global definitions (name and description);
- the name of the ``main'' function that serves as entry point in the program.

A global definition is either a global function or a global variable.
The type of function descriptions and that of additional information
for variables vary among the various intermediate languages and are
taken as parameters to the [program] type.  The other parts of whole
programs are common to all languages. *)

Inductive globdef (F V: Type) : Type :=
  | Gfun (f: F)
  | Gvar (v: globvar V).

Implicit Arguments Gfun [F V].
Implicit Arguments Gvar [F V].

Record program (F V: Type) : Type := mkprogram {
  prog_defs: list (ident * globdef F V);
  prog_main: ident
}.

Definition prog_defs_names (F V: Type) (p: program F V) : list ident :=
  List.map (@fst ident (globdef F V)) p.(prog_defs).

(** * Generic transformations over programs *)

(** We now define a general iterator over programs that applies a given
  code transformation function to all function descriptions and leaves
  the other parts of the program unchanged. *)

Section TRANSF_PROGRAM.

Variable A B V: Type.
Variable transf: A -> B.

Definition transform_program_globdef (idg: ident * globdef A V) : ident * globdef B V :=
  match idg with
  | (id, Gfun f) => (id, Gfun (transf f))
  | (id, Gvar v) => (id, Gvar v)
  end.

Definition transform_program (p: program A V) : program B V :=
  mkprogram
    (List.map transform_program_globdef p.(prog_defs))
    p.(prog_main).

Lemma transform_program_function:
  forall p i tf,
  In (i, Gfun tf) (transform_program p).(prog_defs) ->
  exists f, In (i, Gfun f) p.(prog_defs) /\ transf f = tf.
Proof.
  simpl. unfold transform_program. intros.
  exploit list_in_map_inv; eauto.
  intros [[i' gd] [EQ IN]]. simpl in EQ. destruct gd; inv EQ.
  exists f; auto.
Qed.

End TRANSF_PROGRAM.

(** The following is a more general presentation of [transform_program] where
  global variable information can be transformed, in addition to function
  definitions.  Moreover, the transformation functions can fail and
  return an error message. *)

Open Local Scope error_monad_scope.
Open Local Scope string_scope.

Section TRANSF_PROGRAM_GEN.

Variables A B V W: Type.
Variable transf_fun: A -> res B.
Variable transf_var: V -> res W.

Definition transf_globvar (g: globvar V) : res (globvar W) :=
  do info' <- transf_var g.(gvar_info);
  OK (mkglobvar info' g.(gvar_init) g.(gvar_readonly) g.(gvar_volatile)).

Fixpoint transf_globdefs (l: list (ident * globdef A V)) : res (list (ident * globdef B W)) :=
  match l with
  | nil => OK nil
  | (id, Gfun f) :: l' =>
      match transf_fun f with
      | Error msg => Error (MSG "In function " :: CTX id :: MSG ": " :: msg)
      | OK tf =>
          do tl' <- transf_globdefs l'; OK ((id, Gfun tf) :: tl')
      end
  | (id, Gvar v) :: l' =>
      match transf_globvar v with
      | Error msg => Error (MSG "In variable " :: CTX id :: MSG ": " :: msg)
      | OK tv =>
          do tl' <- transf_globdefs l'; OK ((id, Gvar tv) :: tl')
      end
  end.

Definition transform_partial_program2 (p: program A V) : res (program B W) :=
  do gl' <- transf_globdefs p.(prog_defs); OK(mkprogram gl' p.(prog_main)).

Lemma transform_partial_program2_function:
  forall p tp i tf,
  transform_partial_program2 p = OK tp ->
  In (i, Gfun tf) tp.(prog_defs) ->
  exists f, In (i, Gfun f) p.(prog_defs) /\ transf_fun f = OK tf.
Proof.
  intros. monadInv H. simpl in H0.
  revert x EQ H0. induction (prog_defs p); simpl; intros.
  inv EQ. contradiction.
  destruct a as [id [f|v]].
  destruct (transf_fun f) as [tf1|msg] eqn:?; monadInv EQ.
  simpl in H0; destruct H0. inv H. exists f; auto.
  exploit IHl; eauto. intros [f' [P Q]]; exists f'; auto.
  destruct (transf_globvar v) as [tv1|msg] eqn:?; monadInv EQ.
  simpl in H0; destruct H0. inv H.
  exploit IHl; eauto. intros [f' [P Q]]; exists f'; auto.
Qed.

Lemma transform_partial_program2_variable:
  forall p tp i tv,
  transform_partial_program2 p = OK tp ->
  In (i, Gvar tv) tp.(prog_defs) ->
  exists v,
     In (i, Gvar(mkglobvar v tv.(gvar_init) tv.(gvar_readonly) tv.(gvar_volatile))) p.(prog_defs)
  /\ transf_var v = OK tv.(gvar_info).
Proof.
  intros. monadInv H. simpl in H0.
  revert x EQ H0. induction (prog_defs p); simpl; intros.
  inv EQ. contradiction.
  destruct a as [id [f|v]].
  destruct (transf_fun f) as [tf1|msg] eqn:?; monadInv EQ.
  simpl in H0; destruct H0. inv H.
  exploit IHl; eauto. intros [v' [P Q]]; exists v'; auto.
  destruct (transf_globvar v) as [tv1|msg] eqn:?; monadInv EQ.
  simpl in H0; destruct H0. inv H.
  monadInv Heqr. simpl. exists (gvar_info v). split. left. destruct v; auto. auto.
  exploit IHl; eauto. intros [v' [P Q]]; exists v'; auto.
Qed.

Lemma transform_partial_program2_succeeds:
  forall p tp i g,
  transform_partial_program2 p = OK tp ->
  In (i, g) p.(prog_defs) ->
  match g with
  | Gfun fd => exists tfd, transf_fun fd = OK tfd
  | Gvar gv => exists tv, transf_var gv.(gvar_info) = OK tv
  end.
Proof.
  intros. monadInv H.
  revert x EQ H0. induction (prog_defs p); simpl; intros.
  contradiction.
  destruct a as [id1 g1]. destruct g1.
  destruct (transf_fun f) eqn:TF; try discriminate. monadInv EQ.
  destruct H0. inv H. econstructor; eauto. eapply IHl; eauto.
  destruct (transf_globvar v) eqn:TV; try discriminate. monadInv EQ.
  destruct H0. inv H. monadInv TV. econstructor; eauto. eapply IHl; eauto.
Qed.

Lemma transform_partial_program2_main:
  forall p tp,
  transform_partial_program2 p = OK tp ->
  tp.(prog_main) = p.(prog_main).
Proof.
  intros. monadInv H. reflexivity.
Qed.

(** Additionally, we can also "augment" the program with new global definitions
  and a different "main" function. *)

Section AUGMENT.

Variable new_globs: list(ident * globdef B W).
Variable new_main: ident.

Definition transform_partial_augment_program (p: program A V) : res (program B W) :=
  do gl' <- transf_globdefs p.(prog_defs);
  OK(mkprogram (gl' ++ new_globs) new_main).

Lemma transform_partial_augment_program_main:
  forall p tp,
  transform_partial_augment_program p = OK tp ->
  tp.(prog_main) = new_main.
Proof.
  intros. monadInv H. reflexivity.
Qed.

End AUGMENT.

Remark transform_partial_program2_augment:
  forall p,
  transform_partial_program2 p =
  transform_partial_augment_program nil p.(prog_main) p.
Proof.
  unfold transform_partial_program2, transform_partial_augment_program; intros.
  destruct (transf_globdefs (prog_defs p)); auto.
  simpl. f_equal. f_equal. rewrite <- app_nil_end. auto.
Qed.

End TRANSF_PROGRAM_GEN.

(** The following is a special case of [transform_partial_program2],
  where only function definitions are transformed, but not variable definitions. *)

Section TRANSF_PARTIAL_PROGRAM.

Variable A B V: Type.
Variable transf_partial: A -> res B.

Definition transform_partial_program (p: program A V) : res (program B V) :=
  transform_partial_program2 transf_partial (fun v => OK v) p.

Lemma transform_partial_program_main:
  forall p tp,
  transform_partial_program p = OK tp ->
  tp.(prog_main) = p.(prog_main).
Proof.
  apply transform_partial_program2_main.
Qed.

Lemma transform_partial_program_function:
  forall p tp i tf,
  transform_partial_program p = OK tp ->
  In (i, Gfun tf) tp.(prog_defs) ->
  exists f, In (i, Gfun f) p.(prog_defs) /\ transf_partial f = OK tf.
Proof.
  apply transform_partial_program2_function.
Qed.

Lemma transform_partial_program_succeeds:
  forall p tp i fd,
  transform_partial_program p = OK tp ->
  In (i, Gfun fd) p.(prog_defs) ->
  exists tfd, transf_partial fd = OK tfd.
Proof.
  unfold transform_partial_program; intros.
  exploit transform_partial_program2_succeeds; eauto.
Qed.

End TRANSF_PARTIAL_PROGRAM.

Lemma transform_program_partial_program:
  forall (A B V: Type) (transf: A -> B) (p: program A V),
  transform_partial_program (fun f => OK(transf f)) p = OK(transform_program transf p).
Proof.
  intros.
  unfold transform_partial_program, transform_partial_program2, transform_program; intros.
  replace (transf_globdefs (fun f => OK (transf f)) (fun v => OK v) p.(prog_defs))
     with (OK (map (transform_program_globdef transf) p.(prog_defs))).
  auto.
  induction (prog_defs p); simpl.
  auto.
  destruct a as [id [f|v]]; rewrite <- IHl.
    auto.
    destruct v; auto.
Qed.

(** The following is a relational presentation of
  [transform_partial_augment_preogram].  Given relations between function
  definitions and between variable information, it defines a relation
  between programs stating that the two programs have appropriately related
  shapes (global names are preserved and possibly augmented, etc)
  and that identically-named function definitions
  and variable information are related. *)

Section MATCH_PROGRAM.

Variable A B V W: Type.
Variable match_fundef: A -> B -> Prop.
Variable match_varinfo: V -> W -> Prop.

Inductive match_globdef: ident * globdef A V -> ident * globdef B W -> Prop :=
  | match_glob_fun: forall id f1 f2,
      match_fundef f1 f2 ->
      match_globdef (id, Gfun f1) (id, Gfun f2)
  | match_glob_var: forall id init ro vo info1 info2,
      match_varinfo info1 info2 ->
      match_globdef (id, Gvar (mkglobvar info1 init ro vo)) (id, Gvar (mkglobvar info2 init ro vo)).

Definition match_program (new_globs : list (ident * globdef B W))
                         (new_main : ident)
                         (p1: program A V)  (p2: program B W) : Prop :=
  (exists tglob, list_forall2 match_globdef p1.(prog_defs) tglob /\
                 p2.(prog_defs) = tglob ++ new_globs) /\
  p2.(prog_main) = new_main.

End MATCH_PROGRAM.

Lemma transform_partial_augment_program_match:
  forall (A B V W: Type)
         (transf_fun: A -> res B)
         (transf_var: V -> res W)
         (p: program A V)
         (new_globs : list (ident * globdef B W))
         (new_main : ident)
         (tp: program B W),
  transform_partial_augment_program transf_fun transf_var new_globs new_main p = OK tp ->
  match_program
    (fun fd tfd => transf_fun fd = OK tfd)
    (fun info tinfo => transf_var info = OK tinfo)
    new_globs new_main
    p tp.
Proof.
  unfold transform_partial_augment_program; intros. monadInv H.
  red; simpl. split; auto. exists x; split; auto.
  revert x EQ. generalize (prog_defs p). induction l; simpl; intros.
  monadInv EQ. constructor.
  destruct a as [id [f|v]].
  (* function *)
  destruct (transf_fun f) as [tf|?] eqn:?; monadInv EQ.
  constructor; auto. constructor; auto.
  (* variable *)
  unfold transf_globvar in EQ.
  destruct (transf_var (gvar_info v)) as [tinfo|?] eqn:?; simpl in EQ; monadInv EQ.
  constructor; auto. destruct v; simpl in *. constructor; auto.
Qed.

(** * External functions *)

(** For most languages, the functions composing the program are either
  internal functions, defined within the language, or external functions,
  defined outside.  External functions include system calls but also
  compiler built-in functions.  We define a type for external functions
  and associated operations. *)

Inductive external_function : Type :=
  | EF_external (name: ident) (sg: signature)
     (** A system call or library function.  Produces an event
         in the trace. *)
  | EF_builtin (name: ident) (sg: signature)
     (** A compiler built-in function.  Behaves like an external, but
         can be inlined by the compiler. *)
  | EF_vload (chunk: memory_chunk)
     (** A volatile read operation.  If the adress given as first argument
         points within a volatile global variable, generate an
         event and return the value found in this event.  Otherwise,
         produce no event and behave like a regular memory load. *)
  | EF_vstore (chunk: memory_chunk)
     (** A volatile store operation.   If the adress given as first argument
         points within a volatile global variable, generate an event.
         Otherwise, produce no event and behave like a regular memory store. *)
  | EF_vload_global (chunk: memory_chunk) (id: ident) (ofs: int32)
     (** A volatile load operation from a global variable.
         Specialized version of [EF_vload]. *)
  | EF_vstore_global (chunk: memory_chunk) (id: ident) (ofs: int32)
     (** A volatile store operation in a global variable.
         Specialized version of [EF_vstore]. *)
  | EF_malloc
     (** Dynamic memory allocation.  Takes the requested size in bytes
         as argument; returns a pointer to a fresh block of the given size.
         Produces no observable event. *)
  | EF_free
     (** Dynamic memory deallocation.  Takes a pointer to a block
         allocated by an [EF_malloc] external call and frees the
         corresponding block.
         Produces no observable event. *)
  | EF_memcpy (sz: Z) (al: Z)
     (** Block copy, of [sz] bytes, between addresses that are [al]-aligned. *)
  | EF_annot (text: ident) (targs: list annot_arg)
     (** A programmer-supplied annotation.  Takes zero, one or several arguments,
         produces an event carrying the text and the values of these arguments,
         and returns no value. *)
  | EF_annot_val (text: ident) (targ: typ)
     (** Another form of annotation that takes one argument, produces
         an event carrying the text and the value of this argument,
         and returns the value of the argument. *)
  | EF_inline_asm (text: ident)
     (** Inline [asm] statements.  Semantically, treated like an
         annotation with no parameters ([EF_annot text nil]).  To be
         used with caution, as it can invalidate the semantic
         preservation theorem.  Generated only if [-finline-asm] is
         given. *)

with annot_arg : Type :=
  | AA_arg (ty: typ)
  | AA_int (n: int32)
  | AA_float (n: float).

(** The type signature of an external function. *)

Fixpoint annot_args_typ (targs: list annot_arg) : list typ :=
  match targs with
  | nil => nil
  | AA_arg ty :: targs' => ty :: annot_args_typ targs'
  | _ :: targs' => annot_args_typ targs'
  end.

Definition ef_sig (ef: external_function): signature :=
  match ef with
  | EF_external name sg => sg
  | EF_builtin name sg => sg
  | EF_vload chunk => mksignature (Tint :: nil) (Some (type_of_chunk chunk)) cc_default
  | EF_vstore chunk => mksignature (Tint :: type_of_chunk chunk :: nil) None cc_default
  | EF_vload_global chunk _ _ => mksignature nil (Some (type_of_chunk chunk)) cc_default
  | EF_vstore_global chunk _ _ => mksignature (type_of_chunk chunk :: nil) None cc_default
  | EF_malloc => mksignature (Tint :: nil) (Some Tint) cc_default
  | EF_free => mksignature (Tint :: nil) None cc_default
  | EF_memcpy sz al => mksignature (Tint :: Tint :: nil) None cc_default
  | EF_annot text targs => mksignature (annot_args_typ targs) None cc_default
  | EF_annot_val text targ => mksignature (targ :: nil) (Some targ) cc_default
  | EF_inline_asm text => mksignature nil None cc_default
  end.

(** Whether an external function should be inlined by the compiler. *)

Definition ef_inline (ef: external_function) : bool :=
  match ef with
  | EF_external name sg => false
  | EF_builtin name sg => true
  | EF_vload chunk => true
  | EF_vstore chunk => true
  | EF_vload_global chunk id ofs => true
  | EF_vstore_global chunk id ofs => true
  | EF_malloc => false
  | EF_free => false
  | EF_memcpy sz al => true
  | EF_annot text targs => true
  | EF_annot_val text targ => true
  | EF_inline_asm text => true
  end.

(** Whether an external function must reload its arguments. *)

Definition ef_reloads (ef: external_function) : bool :=
  match ef with
  | EF_annot text targs => false
  | _ => true
  end.

(** Equality between external functions.  Used in module [Allocation]. *)

Definition external_function_eq: forall (ef1 ef2: external_function), {ef1=ef2} + {ef1<>ef2}.
Proof.
  generalize ident_eq signature_eq chunk_eq typ_eq zeq Int.eq_dec; intros.
  decide equality.
  apply list_eq_dec. decide equality. apply Float.eq_dec.
Defined.
Global Opaque external_function_eq.

(** Function definitions are the union of internal and external functions. *)

Inductive fundef (F: Type): Type :=
  | Internal: F -> fundef F
  | External: external_function -> fundef F.

Implicit Arguments External [F].

Section TRANSF_FUNDEF.

Variable A B: Type.
Variable transf: A -> B.

Definition transf_fundef (fd: fundef A): fundef B :=
  match fd with
  | Internal f => Internal (transf f)
  | External ef => External ef
  end.

End TRANSF_FUNDEF.

Section TRANSF_PARTIAL_FUNDEF.

Variable A B: Type.
Variable transf_partial: A -> res B.

Definition transf_partial_fundef (fd: fundef A): res (fundef B) :=
  match fd with
  | Internal f => do f' <- transf_partial f; OK (Internal f')
  | External ef => OK (External ef)
  end.

End TRANSF_PARTIAL_FUNDEF.