Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.
Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import VerdiRaft.SpecLemmas.
Require Import VerdiRaft.RefinementSpecLemmas.

Require Import VerdiRaft.RequestVoteMaxIndexMaxTermInterface.
Require Import VerdiRaft.RequestVoteTermSanityInterface.

Section RequestVoteMaxIndexMaxTerm.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.
  Context {rvrtsi : requestVote_term_sanity_interface}.

  Lemma requestVote_maxIndex_maxTerm_append_entries :
    refined_raft_net_invariant_append_entries requestVote_maxIndex_maxTerm.
  Proof using.
    red. unfold requestVote_maxIndex_maxTerm. intros. simpl in *.
    subst. repeat find_higher_order_rewrite.
    assert (In p0 (nwPackets net)) by
        (find_apply_hyp_hyp; repeat find_rewrite; intuition; [in_crush|];
         exfalso; subst; simpl in *; subst;
         unfold handleAppendEntries in *;
           repeat break_match; find_inversion).
    repeat find_rewrite.
    destruct_update; simpl in *; eauto;
    try rewrite votesWithLog_same_append_entries; eauto;
    find_apply_lem_hyp handleAppendEntries_log_term_type.
    break_or_hyp; try congruence.
    break_and; repeat find_rewrite; eauto.
  Qed.

  Lemma requestVote_maxIndex_maxTerm_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply requestVote_maxIndex_maxTerm.
  Proof using.
    red. unfold requestVote_maxIndex_maxTerm. intros. simpl in *.
    assert (In p0 (nwPackets net)) by
        (repeat find_rewrite;
         find_apply_lem_hyp handleAppendEntriesReply_packets;
         subst; simpl in *; find_apply_hyp_hyp; intuition; in_crush).
    repeat find_rewrite.
    find_copy_apply_lem_hyp handleAppendEntriesReply_log_term_type.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    break_or_hyp; try congruence; break_and; repeat find_rewrite; eauto.
  Qed.

  Lemma requestVote_maxIndex_maxTerm_request_vote :
    refined_raft_net_invariant_request_vote requestVote_maxIndex_maxTerm.
  Proof using.
    red. unfold requestVote_maxIndex_maxTerm. intros. simpl in *.
    assert (In p0 (nwPackets net)) by
        (find_apply_hyp_hyp; repeat find_rewrite; intuition; [in_crush|];
         exfalso; subst; simpl in *; subst;
         unfold handleRequestVote in *;
           repeat break_match; find_inversion).
    find_copy_apply_lem_hyp handleRequestVote_log_term_type.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    break_or_hyp; try congruence; break_and; repeat find_rewrite; eauto.
  Qed.

  Lemma requestVote_maxIndex_maxTerm_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply requestVote_maxIndex_maxTerm.
  Proof using.
    red. unfold requestVote_maxIndex_maxTerm. intros. simpl in *.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_eapply_lem_hyp handleRequestVoteReply_log_term_type; eauto.
    break_and; repeat find_rewrite; eauto.
  Qed.

  Lemma requestVote_maxIndex_maxTerm_timeout :
    refined_raft_net_invariant_timeout requestVote_maxIndex_maxTerm.
  Proof using rvrtsi.
    red. unfold requestVote_maxIndex_maxTerm. intros. simpl in *.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    - find_apply_hyp_hyp. break_or_hyp.
      + exfalso.
        find_eapply_lem_hyp update_elections_data_timeout_votesWithLog_votesReceived; eauto.
        intuition; try congruence.
        find_apply_lem_hyp requestVote_term_sanity_invariant.
        eapply_prop_hyp requestVote_term_sanity pBody; eauto.
        unfold raft_data in *; simpl in *; unfold raft_data in *; simpl in *.
        lia.
      + do_in_map. remember (pSrc p). subst p.
        simpl in *.
        intuition; eapply handleTimeout_messages; eauto.
    - find_apply_hyp_hyp. break_or_hyp; eauto.
      do_in_map. subst. simpl in *. intuition.
  Qed.

  Lemma requestVote_maxIndex_maxTerm_client_request :
    refined_raft_net_invariant_client_request requestVote_maxIndex_maxTerm.
  Proof using.
    red. unfold requestVote_maxIndex_maxTerm. intros. simpl in *.
    find_copy_apply_lem_hyp handleClientRequest_packets.
    subst. simpl in *.
    find_apply_hyp_hyp. break_or_hyp.
    repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    try rewrite votesWithLog_same_client_request; eauto;
    find_apply_lem_hyp handleClientRequest_candidate; subst; eauto.
    intuition.
  Qed.

  Lemma requestVote_maxIndex_maxTerm_do_leader :
    refined_raft_net_invariant_do_leader requestVote_maxIndex_maxTerm.
  Proof using.
    red. unfold requestVote_maxIndex_maxTerm. intros. simpl in *.
    assert (In p (nwPackets net)) by
        (find_apply_hyp_hyp; intuition;
         do_in_map; subst;
         unfold doLeader, replicaMessage in *;
           repeat break_match; find_inversion; subst; simpl in *; intuition;
         do_in_map; subst; simpl in *; congruence).
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    find_apply_lem_hyp doLeader_candidate; subst; eauto.
  Qed.

  Lemma requestVote_maxIndex_maxTerm_do_generic_server :
    refined_raft_net_invariant_do_generic_server requestVote_maxIndex_maxTerm.
  Proof using.
    red. unfold requestVote_maxIndex_maxTerm. intros. simpl in *.
    find_copy_apply_lem_hyp doGenericServer_packets. subst. simpl in *.
    find_apply_hyp_hyp. break_or_hyp.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    find_apply_lem_hyp doGenericServer_log_type_term_votesReceived;
    break_and; repeat find_rewrite; eauto. intuition.
  Qed.

  Lemma requestVote_maxIndex_maxTerm_reboot :
    refined_raft_net_invariant_reboot requestVote_maxIndex_maxTerm.
  Proof using.
    red. unfold requestVote_maxIndex_maxTerm. intros. simpl in *.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto; congruence.
  Qed.

  Lemma requestVote_maxIndex_maxTerm_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset requestVote_maxIndex_maxTerm.
  Proof using.
    red. unfold requestVote_maxIndex_maxTerm. intros. simpl in *.
    subst. repeat find_reverse_higher_order_rewrite.
    eauto.
  Qed.

  Lemma requestVote_maxIndex_maxTerm_init :
    refined_raft_net_invariant_init requestVote_maxIndex_maxTerm.
  Proof using.
    red. unfold requestVote_maxIndex_maxTerm. intros. simpl in *.
    intuition.
  Qed.

  Instance rvmimti : requestVote_maxIndex_maxTerm_interface.
  split.
  intros.
  apply refined_raft_net_invariant; auto.
  - apply requestVote_maxIndex_maxTerm_init.
  - apply requestVote_maxIndex_maxTerm_client_request.
  - apply requestVote_maxIndex_maxTerm_timeout.
  - apply requestVote_maxIndex_maxTerm_append_entries.
  - apply requestVote_maxIndex_maxTerm_append_entries_reply.
  - apply requestVote_maxIndex_maxTerm_request_vote.
  - apply requestVote_maxIndex_maxTerm_request_vote_reply.
  - apply requestVote_maxIndex_maxTerm_do_leader.
  - apply requestVote_maxIndex_maxTerm_do_generic_server.
  - apply requestVote_maxIndex_maxTerm_state_same_packet_subset.
  - apply requestVote_maxIndex_maxTerm_reboot.
  Qed.

End RequestVoteMaxIndexMaxTerm.


(* This file is generated by Why3's Coq 8.4 driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.ComputerDivision.
Require int.Power.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(@ref a a_WT)): a :=
  match v with
  | (mk_ref x) => x
  end.

Import int.ComputerDivision.
Import Power.

(* Why3 goal *)
Theorem WP_parameter_fast_exp_imperative : forall (x:Z) (n:Z),
  (0%Z <= n)%Z -> forall (e:Z) (p:Z) (r:Z), ((0%Z <= e)%Z /\
  ((r * (int.Power.power p e))%Z = (int.Power.power x n))) -> ((0%Z < e)%Z ->
  (((ZArith.BinInt.Z.rem e 2%Z) = 1%Z) -> forall (r1:Z), (r1 = (r * p)%Z) ->
  forall (p1:Z), (p1 = (p * p)%Z) -> forall (e1:Z),
  (e1 = (ZArith.BinInt.Z.quot e 2%Z)) -> ((r1 * (int.Power.power p1
  e1))%Z = (int.Power.power x n)))).
(* Why3 intros x n h1 e p r (h2,h3) h4 h5 r1 h6 p1 h7 e1 h8. *)
intros x n h1 e p r (h2,h3) h4 h5 r1 h6 p1 h7 e1 h8.
subst.
assert (h: (2 <> 0)%Z) by omega.
generalize (Div_mod e 2 h). clear h.
assert (h: (0 < 2)%Z) by omega.
generalize (Div_bound e 2 (conj h2 h)). clear h.
rewrite h5; clear h5.
intros.
rewrite <- h3; clear h3.
rewrite H0 at 2. clear H0.
rewrite Power_sum by omega.
replace (2 * (Z.quot e 2))%Z with (Z.quot e 2 + Z.quot e 2)%Z by ring.
rewrite Power_sum by apply H.
rewrite Power_mult2 by apply H.
rewrite Power_1.
ring.
Qed.


From SkipList.atomic Require Import proofmode weakestpre.
From SkipList.lazy_list Require Import code.
From SkipList.lazy_list.rw_client Require Import spec.

From iris.heap_lang Require Import par notation.

Module Params <: LAZY_LIST_PARAMS.
  Local Open Scope Z.
  Definition INT_MIN := -1000.
  Definition INT_MAX := 1000.
  Lemma HMIN_MAX : INT_MIN < INT_MAX.
  Proof. unfold INT_MIN, INT_MAX; lia. Qed.
End Params.

Module Import Spec := RWSpec Params.

Definition exampleN := nroot .@ "example".

Definition example_client : expr :=
  let: "p" := new #() in
    ((add "p" #0;; add "p" #1) ||| (add "p" #1;; add "p" #2));;
    (contains "p" #2 ||| contains "p" #0).

Section Proofs.
  Context `{!heapGS Σ, !rwG Σ, !spawnG Σ}.

  Lemma example_client_spec :
    {{{ True }}}
      example_client
    {{{ RET (#true, #true); True }}}.
  Proof.
    iIntros (Φ) "_ HΦ".

    unfold example_client.
    wp_apply new_spec; first done.
    iIntros (p Γl) "Hset".
    iDestruct (rw_inv_alloc_mut exampleN with "Hset") as ">Hinv".
    iDestruct "Hinv" as (Γ) "[#Hinv Hmut]".

    wp_let.
    rewrite -(Qp.div_2 1); iDestruct (mut_set_sep with "Hmut") as "[Hmut1 Hmut2]".
    wp_smart_apply (wp_par (λ _, mut_set _ _ _) (λ _, mut_set _ _ _) with "[Hmut1] [Hmut2]").
    {
      awp_apply (write_spec with "Hinv"); first rewrite /Params.INT_MIN/Params.INT_MAX//.
      iAaccIntro with "Hmut1"; first (iIntros "?"; iModIntro; iFrame).
      iIntros "Hmut1". iModIntro. iExists _, _. iFrame "Hmut1".
      iIntros "Hmut1 _". iModIntro. wp_pures.

      awp_apply (write_spec with "Hinv"); first rewrite /Params.INT_MIN/Params.INT_MAX//.
      iAaccIntro with "Hmut1"; first (iIntros "?"; iModIntro; iFrame).
      iIntros "Hmut1". iModIntro. iExists _, _. iFrame "Hmut1".
      by iIntros.
    }
    {
      awp_apply (write_spec with "Hinv"); first rewrite /Params.INT_MIN/Params.INT_MAX//.
      iAaccIntro with "Hmut2"; first (iIntros "?"; iModIntro; iFrame).
      iIntros "Hmut2". iModIntro. iExists _, _. iFrame "Hmut2".
      iIntros "Hmut2 _". iModIntro. wp_pures.

      awp_apply (write_spec with "Hinv"); first rewrite /Params.INT_MIN/Params.INT_MAX//.
      iAaccIntro with "Hmut2"; first (iIntros "?"; iModIntro; iFrame).
      iIntros "Hmut2". iModIntro. iExists _, _. iFrame "Hmut2".
      by iIntros.
    }
    iIntros (? ?) "Hmut". rewrite ?left_id_L.
    iDestruct (mut_set_join with "Hmut") as "Hmut".

    iNext; wp_pure; wp_pure.
    rewrite Qp.div_2; iDestruct (mut_to_const with "Hinv Hmut") as ">Hconst".
    rewrite -(Qp.div_2 1); iDestruct (const_set_sep with "Hconst") as "[Hconst1 Hconst2]".
    wp_smart_apply (wp_par (λ v, ⌜ v = #true ⌝%I) (λ v, ⌜ v = #true ⌝%I) with "[Hconst1] [Hconst2]").
    {
      awp_apply (read_spec with "Hinv"); first rewrite /Params.INT_MIN/Params.INT_MAX//.
      iAaccIntro with "Hconst1"; first (iIntros "?"; iModIntro; iFrame).
      iIntros (b) "[Hconst1 %Hif]". iModIntro. iExists _, _. iFrame "Hconst1".
      iIntros; iPureIntro. destruct (b); first done; last set_solver.
    }
    {
      awp_apply (read_spec with "Hinv"); first rewrite /Params.INT_MIN/Params.INT_MAX//.
      iAaccIntro with "Hconst2"; first (iIntros "?"; iModIntro; iFrame).
      iIntros (b) "[Hconst2 %Hif]". iModIntro. iExists _, _. iFrame "Hconst2".
      iIntros; iPureIntro. destruct (b); first done; last set_solver.
    }
    iIntros (? ?) "[-> ->]"; iNext; by iApply "HΦ".
  Qed.
End Proofs.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Maps.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Axioms.

Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import compcert.common.Events.
Require Import compcert.common.AST.
Require Import compcert.common.Globalenvs.

Require Import VST.sepcomp.mem_lemmas.

(** * Interaction Semantics *)

(** NOTE: In the code, we call interaction semantics [CoreSemantics]. *)

(** The [G] type parameter is the type of global environments, the type
   [C] is the type of core states, and the type [E] is the type of
   extension requests. *)

(** [at_external] gives a way to determine when the sequential
   execution is blocked on an extension call, and to extract the
   data necessary to execute the call. *)

(** [after_external] give a way to inject the extension call results
   back into the sequential state so execution can continue. *)

(** [initial_core] produces the core state corresponding to an entry
   point of a module.  The arguments are the genv, a pointer to the
   function to run, and the arguments for that function. *)

(** [halted] indicates when a program state has reached a halted state,
   and what it's exit code/return value is when it has reached such
   a state. *)

(** [corestep] is the fundamental small-step relation for the
   sequential semantics. *)

(** The remaining properties give basic sanity properties which constrain
   the behavior of programs. *)
(** -1 a state cannot be both blocked on an extension call and also step, *)
(** -2 a state cannot both step and be halted, and *)
(** -3 a state cannot both be halted and blocked on an external call. *)

Record CoreSemantics {G C M : Type} : Type :=
  { initial_core : nat -> G -> val -> list val -> option C
  ; at_external : C -> option (external_function * list val)
  ; after_external : option val -> C -> option C
  ; halted : C -> option val
  ; corestep : G -> C -> M -> C -> M -> Prop

  ; corestep_not_at_external:
      forall ge m q m' q', corestep ge q m q' m' -> at_external q = None
  ; corestep_not_halted:
      forall ge m q m' q', corestep ge q m q' m' -> halted q = None
  ; at_external_halted_excl:
      forall q, at_external q = None \/ halted q = None }.

Arguments CoreSemantics : clear implicits.

Inductive mem_step m m' : Prop :=
    mem_step_storebytes: forall b ofs bytes,
       Mem.storebytes m b ofs bytes = Some m' -> mem_step m m'
  | mem_step_alloc: forall lo hi b',
       Mem.alloc m lo hi = (m',b') -> mem_step m m'
  | mem_step_freelist: forall l,
       Mem.free_list m l = Some m' -> mem_step m m'
  (*Some non-observable external calls are not a single alloc/free/store-step*)
  | mem_step_trans: forall m'',
       mem_step m m'' -> mem_step m'' m' -> mem_step m m'.

Local Notation "a # b" := (PMap.get b a) (at level 1).
Record perm_lesseq (m m': mem):= {
  perm_le_Cur:
    forall b ofs, Mem.perm_order'' ((Mem.mem_access m')#b ofs Cur) ((Mem.mem_access m)#b ofs Cur)
; perm_le_Max:
    forall b ofs, Mem.perm_order'' ((Mem.mem_access m')#b ofs Max) ((Mem.mem_access m)#b ofs Max)
; perm_le_cont:
    forall b ofs, Mem.perm m b ofs Cur Readable ->
     ZMap.get ofs (Mem.mem_contents m') !! b= ZMap.get ofs (Mem.mem_contents m) !! b
; perm_le_nb: Mem.nextblock m = Mem.nextblock m'
}.

(* Memory semantics are CoreSemantics that are specialized to CompCert memories
   and evolve memory according to mem_step. Previous notion CoopCoreSem is deprecated,
   but for now retained in file CoopCoreSem.v *)
Record MemSem {G C} :=
  { csem :> @CoreSemantics G C mem

  ; corestep_mem : forall g c m c' m' (CS: corestep csem g c m c' m'), mem_step m m'
  (*later, we'll want to add the following constraint
  ; corestep_incr_perm: forall g c m c' m' (CS: corestep csem g c m c' m')  m1 (PLE: perm_lesseq m m1),
         exists m1', corestep csem g c m1 c' m1' /\ perm_lesseq m' m1'*)
  }.

Arguments MemSem : clear implicits.


From Bits Require Import spec.

From Coq Require Import Vectors.Vector.

From CryptolToCoq Require Import CryptolPrimitivesForSAWCore.
From CryptolToCoq Require Import CryptolPrimitivesForSAWCoreExtra.
From CryptolToCoq Require Import SAWCorePrelude.
From CryptolToCoq Require Import SAWCorePrelude_proofs.
From CryptolToCoq Require Import SAWCoreScaffolding.
From CryptolToCoq Require Import SAWCoreVectorsAsCoqVectors.

From Lift Require Import S2N.

From Ornamental Require Import Ornaments.

From S2N Require Import S2N.

Set DEVOID search prove equivalence.
Set DEVOID lift type.

Import CryptolPrimitives.

Module Handshake.

  (** [cry_handshake] is the [handshake] type as it comes out of the translation
from Cryptol to Coq.  The fields have been inlined into a nested tuple type.

This is what the original [handshake] type looked like:

type handshake = {handshake_type : [32]
                 ,message_number : [32]
                 }
   *)
  Definition handshake : Type := (seq 32 bool * seq 32 bool).

  (** We can define more convenient types for [handshake] and [connection] in Coq.
Ideally, we'd like the translation to generate those, but in its current state,
it goes through an intermediate language that does not support records and
record types.
   *)
  Record Handshake :=
    MkHandshake
      {
        handshakeType : seq 32 bool;
        messageNumber : seq 32 bool;
      }.

  Scheme Induction for Handshake Sort Prop.
  Scheme Induction for Handshake Sort Type.
  Scheme Induction for Handshake Sort Set.

  Definition get_handshake_type (h : handshake) : seq 32 bool :=
    fst h.

  Definition get_message_number (h : handshake) : seq 32 bool :=
    snd h.

End Handshake.

Preprocess Module Handshake
  as HandshakePP
       { opaque
           PArithSeqBool
           PCmpSeq
           PCmpSeqBool
           PLiteralSeqBool
           ecAt
           ecGt
           ecLt
           ecMinus
           ecNotEq
           ecNumber
           ecPlus
           handshakes_fn
           natToNat
           seq
       }.

Lift HandshakePP.handshake
     HandshakePP.Handshake
  in HandshakePP.get_handshake_type
  as getHandshakeType.

Lift HandshakePP.handshake
     HandshakePP.Handshake
  in HandshakePP.get_message_number
  as getMessageNumber.

Configure Lift HandshakePP.handshake HandshakePP.Handshake
          { opaque
              PArithSeqBool
              PCmpSeq
              PCmpSeqBool
              PLiteralSeqBool
              ecAt
              ecGt
              ecLt
              ecMinus
              ecNotEq
              ecNumber
              ecPlus
              handshakes_fn
              natToNat
              seq
          }.

Lift HandshakePP.handshake
     HandshakePP.Handshake
  in S2N'.ACTIVE_MESSAGE
  as ActiveMessage0.

Lift HandshakePP.handshake
     HandshakePP.Handshake
  in S2N'.valid_handshake
  as validHandshake.


From iris.heap_lang Require Import notation lang.

Definition addConditionally: val :=
  rec: "addConditionally" "loc" "delta" "condition" :=
    let: "cur" := !"loc" in
    if: "condition" "cur"
    then if: CAS "loc" "cur" ("cur" + "delta")
         then #true
         else "addConditionally" "loc" "delta" "condition"
    else #false.

From iris.program_logic Require Import atomic.
From iris.heap_lang Require Import proofmode.

Section proof.

Context `{heapG}.

Theorem addConditionally_spec (pred: Z → bool) (ℓ: loc) (Δ: Z) (condition: val):
  ⊢ (∀ (k: Z), {{{ True }}}
                 condition #k
               {{{ RET #(pred k); True }}}) →
    <<< ∀ (k: Z), ▷ ℓ ↦ #k >>>
      addConditionally #ℓ #Δ condition @ ⊤
    <<< if pred k then ℓ ↦ #(k + Δ) else ℓ ↦ #k, RET #(pred k) >>>.
Proof.
  iIntros "#HCond" (Φ) "AU". iLöb as "IH". wp_lam. wp_pures.
  wp_bind (!_)%E. iMod "AU" as (k) "[Hℓ HClose]".
  wp_load.
  destruct (pred k) eqn:E; wp_pures.
  - iDestruct "HClose" as "[HClose _]".
    iMod ("HClose" with "Hℓ") as "AU". iModIntro. wp_pures.
    wp_apply ("HCond" with "[$]"). iIntros (_).
    rewrite E. wp_pures.
    wp_bind (CmpXchg _ _ _). iMod "AU" as (k') "[Hℓ HClose]".
    destruct (decide (k = k')) as [<-|HContra].
    + wp_cmpxchg_suc. iDestruct "HClose" as "[_ HClose]".
      iMod ("HClose" with "[Hℓ]") as "HΦ".
      { rewrite E. iFrame. }
      iModIntro. wp_pures. rewrite E. iAssumption.
    + wp_cmpxchg_fail. iDestruct "HClose" as "[HClose _]".
      iMod ("HClose" with "Hℓ") as "AU".
      iModIntro. wp_pures. iApply ("IH" with "AU").
  - iDestruct "HClose" as "[_ HClose]".
    iMod ("HClose" with "[Hℓ]") as "AU"; first by iFrame.
    iModIntro. wp_pures.
    wp_apply ("HCond" with "[$]"). iIntros (_).
    rewrite E. wp_pures.
    iAssumption.
Qed.

End proof.


Set Implicit Arguments.

Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.BinInt.
Require Import Coq.Lists.SetoidList.

Require Import HJ.Tid.
Require Import HJ.Vars.
Require Import HJ.Phasers.Lang.
Require Import HJ.Phasers.PhaseDiff.
Require Import HJ.Phasers.LEDec.

Require Import HJ.Phasers.TransDiff.
Require Import HJ.Phasers.Typesystem.

Require Coq.FSets.FMapFacts.

Require HJ.Phasers.PhaseDiff.
Require HJ.Phasers.Rel.
Require HJ.Phasers.SubjectReduction.
Require HJ.Phasers.Typesystem.
Require HJ.Phasers.WellFormed.

Require Import Phasers.SubjectReduction.

Module S := HJ.Phasers.Lang.

Open Scope Z.

Section SIMPLE.

Lemma progress_unblocking_simple:
  forall pm t i,
  Valid pm ->
  Op.Valid pm t i ->
  i <> WAIT_ALL ->
  exists m, Reduces pm t i m.
Proof.
  intros.
  exists (run (get_impl i) t pm).
  apply reduces.
  destruct i; simpl; inversion H0; auto.
  contradiction H1.
  trivial.
Qed.

End SIMPLE.

Section HAS_SMALLEST.
Variable pm: phasermap.
Let IsA t := In t pm.

Let wtid_le (t1:tid) (t2:tid) := LE pm t1 t2.

Let wtid_le_inv := LE_inv pm.

Let wtid_le_trans:
  forall t1 t2 t3,
  wtid_le t1 t2 ->
  wtid_le t2 t3 ->
  wtid_le t1 t3.
Proof.
  unfold wtid_le in *.
  apply LE_trans.
Qed.

Let wtid_has_smallest :=
  Rel.has_smallest tid IsA wtid_le (LE_inv pm) (LE_dec pm)
  (LE_refl pm) wtid_le_trans.

Definition Smallest (t:tid) (ts:list tid)  :=
  List.In t ts /\
  forall t', List.In t' ts -> (~ LE pm t t' /\ ~ LE pm t' t) \/ LE pm t t'.

Let has_smallest:
  forall ts,
  ts <> nil ->
  Forall IsA ts ->
  exists t,
  Smallest t ts.
Proof.
  intros.
  destruct (wtid_has_smallest H H0) as (x, Hx).
  unfold Rel.Smallest in *.
  unfold Rel.Unrelated in *.
  unfold wtid_le in *.
  exists x.
  auto.
Qed.

Let tids := pm_tids pm.

Let smallest_inv:
  forall t,
  Smallest t tids ->
  List.In t tids.
Proof.
  intros.
  unfold Smallest in *.
  intuition.
Qed.

Let in_tids:
  forall p ph t,
  Map_PHID.MapsTo p ph pm ->
  Map_TID.In t ph ->
  List.In t tids.
Proof.
  intros.
  unfold tids.
  rewrite pm_tids_spec.
  eauto using in_def.
Qed.

Let Smallest_to_LE :
  forall t t' p ph,
  Smallest t tids ->
  Map_PHID.MapsTo p ph pm ->
  Map_TID.In t ph ->
  Map_TID.In t' ph ->
  LE pm t t'.
Proof.
  intros.
  unfold Smallest in *.
  destruct H as (Hin, H).
  assert (Hx := H t'); clear H.
  assert (Hin' : List.In t' tids) by eauto using in_tids.
  apply Hx in Hin'; clear Hx.
  destruct Hin' as [(?,?)|?].
  - destruct (LE_total _ _ _ _ _ H0 H1 H2); repeat contradiction. (* absurd *)
  - assumption.
Qed.

Let diff := pm_diff pm.

Variable check : Valid pm.

Let diff_det : TransDiffFun diff.
Proof.
  unfold Valid in *.
  intuition.
Qed.

Lemma Smallest_to_WaitPhase :
  forall t t' v v' p ph,
  Smallest t tids ->
  Map_PHID.MapsTo p ph pm ->
  Map_TID.MapsTo t v ph ->
  Map_TID.MapsTo t' v' ph ->
  (wait_phase v <= wait_phase v') % nat.
Proof.
  intros.
  assert (Hin: Map_TID.In t ph) by eauto using Map_TID_Extra.mapsto_to_in.
  assert (Hin': Map_TID.In t' ph) by eauto using Map_TID_Extra.mapsto_to_in.
  assert (Hle: LE pm t t') by eauto using Smallest_to_LE.
  remember ((Z.of_nat (wait_phase v)) - (Z.of_nat (wait_phase v'))) as z.
  assert (Hdiff : ph_diff ph (t, t') z). {
    subst.
    auto using ph_diff_def.
  }
  assert (Hz: (z <= 0 \/ -z <= 0) % Z) by omega.
  destruct Hz.
  - omega.
  - subst.
    remember (Z.of_nat (wait_phase v) - Z.of_nat (wait_phase v')) as z.
    assert (Hd: pm_diff pm (t, t') z) by eauto using pm_diff_def.
    assert ((z <= 0) % Z) by eauto using LE_to_pm_diff.
    intuition.
Qed.

Open Scope nat.

(**
  A crucial precondition to the wait-all working is that all tasks must have
  performed a signal prior to waiting.
*)

Import HJ.Phasers.WellFormed.

Import Phasermap.

Variable WF : WellFormed pm.

  Section Unblocked.
  Variable check_def:
    forall t,
    List.In t tids ->
    Op.Valid pm t WAIT_ALL.

  Theorem has_unblocked:
    Nonempty pm ->
    exists t,
    List.In t tids /\ exists m, Reduces pm t WAIT_ALL m.
  Proof.
    intros.
    apply pm_tids_nonempty in H.
    assert (Hisa : Forall IsA tids). {
      apply Forall_forall.
      intros.
      unfold IsA, tids in *.
      auto using pm_tids_spec_1.
    }
    assert (Hsmall := has_smallest H Hisa).
    destruct Hsmall as (t, Hsmall).
    exists t.
    split; auto.
    exists (Phasermap.wait_all t pm).
    apply reduces.
    simpl.
    apply wait_all_pre.
    intros.
    assert (i := H1).
    apply Map_TID_Extra.in_to_mapsto in H1.
    destruct H1 as (v, mt).
    assert (v_wf:Taskview.WellFormed v). {
      inversion WF.
      assert (Phaser.WellFormed ph) by eauto.
      inversion H2.
      eauto.
    }
    destruct (can_wait_so (mode v)). {
      apply try_wait_pre_can_wait.
      apply wait_pre_def with (v:=v); auto. {
        inversion c;
        symmetry in H2.
        - apply Taskview.wait_pre_sw; auto.
          apply Taskview.tv_well_formed_inv_sw in H2; auto.
          destruct H2; auto.
          assert (wait_phase v <> signal_phase v). {
            assert (Hk : Op.Valid pm t WAIT_ALL) by eauto.
            inversion Hk.
            assert (wait_phase v < signal_phase v) by eauto.
            intuition.
          }
          contradiction.
        - apply Taskview.wait_pre_wo; auto.
      }
      assert (Hs := mt).
      (* -- *)
      apply phase_def.
      intros x w; intros.
      assert (wait_phase w < signal_phase w). {
        assert (Hk : Op.Valid pm x WAIT_ALL). {
          eauto using in_tids, Map_TID_Extra.mapsto_to_in.
        }
        inversion Hk.
        eauto.
      }
      assert (wait_phase v <= wait_phase w). {
        eauto using Smallest_to_WaitPhase.
      }
      auto with *.
    }
    eauto using try_wait_pre_so.
  Qed.
  End Unblocked.

  Let both_cases:
    forall l,
    (forall x, List.In x l -> In x pm) ->
    (exists x, List.In x l /\ ~ Op.Valid pm x WAIT_ALL) \/
    (forall x, List.In x l -> Op.Valid pm x WAIT_ALL).
  Proof.
    induction l; intros. {
      right.
      intros.
      inversion H0.
    }
    assert (i: In a pm) by eauto using in_eq.
    destruct (Op.valid_dec pm a WAIT_ALL). {
      assert (j: forall x, List.In x l -> In x pm) by eauto using in_cons.
      apply IHl in j.
      destruct j as [(?,(?,?))|?]. {
        eauto using in_cons.
      }
      right.
      intros.
      destruct H1; subst; auto.
    }
    eauto using in_eq.
  Qed.

  Theorem progress:
    Nonempty pm ->
    exists t,
    In t pm /\
    forall o,
    (Op.Valid pm t o ->
    exists m, Reduces pm t o m).
  Proof.
    intros.
    edestruct (both_cases) as [(?,(?,?))|?]; eauto using pm_tids_spec_1. {
      exists x.
      split; auto using pm_tids_spec_1.
      intros.
      assert (o <> WAIT_ALL). {
        unfold not; intros; subst.
        contradiction.
      }
      eauto using progress_unblocking_simple.
    }
    destruct (has_unblocked) as (x,(?,?)); auto.
    apply pm_tids_nonempty in H.
    exists x.
    split; auto using pm_tids_spec_1.
    intros.
    assert (Ho: o = WAIT_ALL \/ o <> WAIT_ALL). {
      destruct o; auto; right; unfold not; intros N; inversion N.
    }
    destruct Ho. {
      subst.
      auto.
    }
    auto using progress_unblocking_simple.
  Qed.

End HAS_SMALLEST.

Section ProgressEmpty.
  Lemma progress_empty:
    forall t o pm l,
    Trace.ReducesN pm l ->
    pm_tids pm = nil ->
    Op.Valid pm t o ->
    exists pm', Reduces pm t o pm'.
  Proof.
    intros.
    assert (O: o = WAIT_ALL \/ o <> WAIT_ALL). {
      destruct o; auto; right; unfold not; intros N; inversion N.
    }
    destruct O as [?|?]. {
      exists (run (get_impl o) t pm).
      apply reduces.
      subst; simpl.
      apply wait_all_pre.
      intros.
      assert (i: In t pm) by eauto using in_def.
      apply pm_tids_spec_2 in i.
      rewrite H0 in *.
      inversion i.
    }
    eauto using progress_unblocking_simple, reduces_n_to_valid.
  Qed.

End ProgressEmpty.

Section ProgressEx.
  Corollary progress_ex:
    forall pm l,
    Trace.ReducesN pm l ->
    Nonempty pm ->
    exists t,
    In t pm /\
    forall o,
    (Op.Valid pm t o ->
    exists m, Reduces pm t o m).
  Proof.
    intros.
    eauto using progress, reduces_n_to_valid, WellFormed.Phasermap.well_formed_to_reduces_n.
  Qed.

End ProgressEx.


(* Continuation-Passing Style language for the CertiCoq project.
 *   Initial design, Andrew W. Appel, June 2014
 *)
From Coq Require Import ZArith.ZArith Lists.List.
From CertiCoq.Common Require Import AstCommon.
From CertiCoq.LambdaANF Require Import List_util map_util.
From compcert.lib Require Export  Maps.
From CertiCoq.LambdaANF Require Export map_util.
From MetaCoq.Template Require Import BasicAst. (* For identifier names *)

Import ListNotations.

(* We will use several maps from identifiers to types, values, etc.
 * For now we'll use Xavier Leroy's efficient polymorphic maps from
 * positive numbers to _. When the MMaps module of the Coq stdlib is
 * created, we'll use that. *)

Module M := Maps.PTree.

Definition var      := M.elt. (* value variables *)
Definition fun_tag  := M.elt. (* discrimination tags for functions *)
Definition ind_tag  := M.elt. (* discrimination tags for inductive types *)
Definition ctor_tag := M.elt. (* discrimination tags for constructors *)
Definition prim     := M.elt. (* primitive operators *)

(* Remark.  It sure would be nice if we could use abstraction here,
   so that M was instantiated differently for vars, types, and tags,
   such that [var] was not beta-eta equal to [type].  But then the
   type of maps [M.t] would have to be abstract, and that in turn
   would mean that Coq could not determine that [M.t(A)] is covariant
   in A.  Which, in turn, would make impossible the inductive definition
   of [val], below.
 *)

(* To describe the [i]th field of a record, we use type BinNat,
   that is, [N].  This has a more efficient representation than [nat],
   which is a consideration for programs that process large
   abstract syntax trees.
 *)

(* Given a list of tagged variants, return the one with the matching tag. *)
Fixpoint findtag {A} (cl: list (ctor_tag * A)) (c: ctor_tag) : option A :=
  match cl with
  | (c',a)::cl' => if M.elt_eq c' c then Some a else findtag cl' c
  | nil => None
  end.

(** * LambdaANF Expressions *)

(* Expressions [exp] of the LambdaANF language. *)
Inductive exp : Type :=
| Econstr: var -> ctor_tag -> list var -> exp -> exp
| Ecase: var -> list (ctor_tag * exp) -> exp
| Eproj: var -> ctor_tag -> N -> var -> exp -> exp
| Eletapp: var -> var -> fun_tag -> list var -> exp -> exp
| Efun: fundefs -> exp -> exp
| Eapp: var -> fun_tag -> list var -> exp
| Eprim_val : var -> primitive -> exp -> exp
| Eprim: var -> prim -> list var -> exp -> exp (* where prim is id *)
| Ehalt : var -> exp
with fundefs : Type :=
| Fcons: var -> fun_tag -> list var -> exp -> fundefs -> fundefs
| Fnil: fundefs.

(* [Econstr x t c ys e] applies a data constructor with tag [c] to
           a list of values denoted by variables [ys].   The resulting
           value is bound to variable [x] of type [t], and then execution
           continues with expression [e].  Static typing requires that
           the typeinfo bound to [t] has a variant consistent with [c]
           and the types of [ys].
   [Ecase v cl] does case-discrimination on value [v], which
          must be a [Vconstr t c vs] value. One of the elements of
          [cl] must be the pair [(c,e)], where [e] a expression
          that uses [v] (and makes necessary projections).
   [Eproj v t n y e] projects the record value [y] by selecting
          the [n]th element of the record.   This is bound to [v] of type [t]
          and execution continues with [e].  Typechecking requires
          that the type of [y] be a Tdata with a single variant, whose
          data list has length at least n.
   [Efun x f ft ys e] applies the function f to arguments ys and binds the result
         to x in e.
   [Efun fl e]  binds the set of mutually recursive functions [fl]
          into the environment, and continues with [e].
   [Eapp f ys]   applies the function [f] to arguments [ys]
   [Eprim x t f ys e] applies primop [f] to arguments [ys]
          and binds the result to [x] of type [t], continues with [e].
          The primop [f] is a primitive operator, whose type is equivalent to
          the CPS transform of [ts->t], where [ts] are the type of the [ys].

   [Fdef f t ys e]   defines a function [f] of type [t] with parameters [ys]
          and body [e].  We do not syntactically distinguish continuations
          from other functions, as Andrew Kennedy does [Compiling with
          Continuations, Continued, 2007].  Instead, we rely on the type
          system to do it; see below.  This mechanism also permits
          classifying functions into different calling conventions, even
          if they have the same source-language type.
*)

(* Remark.  It is conventional in LambdaANF representations to guarantee
   that no two binding occurrences bind the same variable-name.
   However, neither the static (typing) semantics nor the dynamic
   (small-step) semantics requires this.  Some of the transformation
   (optimization, rewrite) algorithms may require it.
*)

(** Induction principles for exp anf fundefs *)

Lemma exp_ind' :
  forall P : exp -> Type,
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var), P (Ecase v nil)) ->
    (forall (v : var) (l : list (ctor_tag * exp)) (c : ctor_tag) (e : exp),
        P e -> P (Ecase v l) -> P (Ecase v ((c, e) :: l))) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall (f2 : fundefs) (e : exp), P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var)  (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    forall e : exp, P e.
Proof.
  intros P H1 H2 H3 H4 H5 H6 H7 H8 H9 H10. fix exp_ind' 1.
  destruct e; try (now clear exp_ind'; eauto).
  - eapply H1. eapply exp_ind'; eauto.
  - induction l as [ | [c e] xs IHxs].
    + eapply H2.
    + eapply H3. apply exp_ind'. eauto.
  - eapply H4. eapply exp_ind'; eauto.
  - eapply H5. eapply exp_ind'; eauto.
  - eapply H6. eapply exp_ind'; eauto.
  - eapply H8. eapply exp_ind'; eauto.
  - eapply H9. eapply exp_ind'; eauto.
Qed.

(** Mutual induction scheme for exp and fundefs *)
Lemma exp_mut :
  forall (P : exp -> Type) (P0 : fundefs -> Type),
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var), P (Ecase v nil)) ->
    (forall (v : var) (l : list (ctor_tag * exp)) (c : ctor_tag) (e : exp),
        P e -> P (Ecase v l) -> P (Ecase v ((c, e) :: l))) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall f2 : fundefs, P0 f2 -> forall e : exp, P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var) (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    (forall (v : var) (t : fun_tag) (l : list var) (e : exp),
        P e -> forall f5 : fundefs, P0 f5 -> P0 (Fcons v t l e f5)) ->
    P0 Fnil -> forall e : exp, P e
with fundefs_mut :
  forall (P : exp -> Type) (P0 : fundefs -> Type),
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var), P (Ecase v nil)) ->
    (forall (v : var) (l : list (ctor_tag * exp)) (c : ctor_tag) (e : exp),
        P e -> P (Ecase v l) -> P (Ecase v ((c, e) :: l))) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall f2 : fundefs, P0 f2 -> forall e : exp, P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var) (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    (forall (v : var) (t : fun_tag) (l : list var) (e : exp),
        P e -> forall f5 : fundefs, P0 f5 -> P0 (Fcons v t l e f5)) ->
    P0 Fnil -> forall f7 : fundefs, P0 f7.
Proof.
  - intros P1 P2 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12.
    destruct e; eauto.
    + eapply H1. eapply exp_mut; eauto.
    + induction l as [ | [c e] xs IHxs].
      * eapply H2.
      * eapply H3; eauto. eapply exp_mut; eauto.
    + eapply H4. eapply exp_mut; eauto.
    + eapply H5. eapply exp_mut; eauto.
    + eapply H6. eapply fundefs_mut; eauto.
      eapply exp_mut; eauto.
    + eapply H8. eapply exp_mut; eauto.
    + eapply H9. eapply exp_mut; eauto.
  - intros P1 P2 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 defs.
    destruct defs; eauto.
    eapply H11. eapply exp_mut; eauto.
    eapply fundefs_mut; eauto.
Qed.

Lemma exp_mut_alt :
  forall (P : exp -> Prop) (P0 : fundefs -> Prop),
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var) (l : list (ctor_tag * exp)),
       Forall (fun x => P (snd x)) l -> P (Ecase v l)) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall f2 : fundefs, P0 f2 -> forall e : exp, P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var) (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    (forall (v : var) (t : fun_tag) (l : list var) (e : exp),
        P e -> forall f5 : fundefs, P0 f5 -> P0 (Fcons v t l e f5)) ->
    P0 Fnil -> forall e : exp, P e
with fundefs_mut_alt :
  forall (P : exp -> Prop) (P0 : fundefs -> Prop),
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var) (l : list (ctor_tag * exp)),
        Forall (fun x => P (snd x)) l -> P (Ecase v l)) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall f2 : fundefs, P0 f2 -> forall e : exp, P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var) (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    (forall (v : var) (t : fun_tag) (l : list var) (e : exp),
        P e -> forall f5 : fundefs, P0 f5 -> P0 (Fcons v t l e f5)) ->
    P0 Fnil -> forall f7 : fundefs, P0 f7.
Proof.
  - intros P1 P2 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11.
    destruct e; eauto.
    + eapply H1. eapply exp_mut_alt; eauto.
    + eapply H2. induction l as [ | [c e] xs IHxs].
      now constructor.
      constructor; [| eassumption ]. eapply exp_mut_alt; eauto.
    + eapply H3. eapply exp_mut_alt; eauto.
    + eapply H4. eapply exp_mut_alt; eauto.
    + eapply H5. eapply fundefs_mut_alt; eauto.
      eapply exp_mut_alt; eauto.
    + eapply H7. eapply exp_mut_alt; eauto.
    + eapply H8. eapply exp_mut_alt; eauto.
  - intros P1 P2 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 defs.
    destruct defs; eauto.
    eapply H10. eapply exp_mut_alt; eauto.
    eapply fundefs_mut_alt; eauto.
Qed.

(* to do proofs simultaneously. *)
Lemma exp_def_mutual_ind :
  forall (P : exp -> Prop) (P0 : fundefs -> Prop),
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var), P (Ecase v nil)) ->
    (forall (v : var) (l : list (ctor_tag * exp)) (c : ctor_tag) (e : exp),
        P e -> P (Ecase v l) -> P (Ecase v ((c, e) :: l))) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall f2 : fundefs, P0 f2 -> forall e : exp, P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var) (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    (forall (v : var) (t : fun_tag) (l : list var) (e : exp),
        P e -> forall f5 : fundefs, P0 f5 -> P0 (Fcons v t l e f5)) ->
    P0 Fnil -> (forall e : exp, P e) /\ (forall f : fundefs, P0 f).
Proof.
  intros. split.
  apply (exp_mut P P0); assumption.
  apply (fundefs_mut P P0); assumption.
Qed.

Lemma exp_def_mutual_ind' :
  forall (P : exp -> Prop) (P0 : fundefs -> Prop),
    (forall (v : var) (t : ctor_tag) (l : list var) (e : exp),
        P e -> P (Econstr v t l e)) ->
    (forall (v : var) (l : list (ctor_tag * exp)),
        Forall (fun x => P (snd x)) l -> P (Ecase v l)) ->
    (forall (v : var) (t : ctor_tag) (n : N) (v0 : var) (e : exp),
        P e -> P (Eproj v t n v0 e)) ->
    (forall (x f : var) (ft : fun_tag) (ys : list var) (e : exp),
        P e -> P (Eletapp x f ft ys e)) ->
    (forall f2 : fundefs, P0 f2 -> forall e : exp, P e -> P (Efun f2 e)) ->
    (forall (v : var) (t : fun_tag) (l : list var), P (Eapp v t l)) ->
    (forall v p e, P e -> P (Eprim_val v p e)) ->
    (forall (v : var) (p : prim) (l : list var) (e : exp),
        P e -> P (Eprim v p l e)) ->
    (forall (v : var), P (Ehalt v)) ->
    (forall (v : var) (t : fun_tag) (l : list var) (e : exp),
        P e -> forall f5 : fundefs, P0 f5 -> P0 (Fcons v t l e f5)) ->
    P0 Fnil -> (forall e : exp, P e) /\ (forall f : fundefs, P0 f).
Proof.
  intros. split.
  apply (exp_mut_alt P P0); assumption.
  apply (fundefs_mut_alt P P0); assumption.
Qed.

(** name the induction hypotheses only *)
Ltac exp_defs_induction IH1 IHl IH2 :=
  apply exp_def_mutual_ind;
  [ intros ? ? ? ? IH1
  | intros ?
  | intros ? ? ? ? IH1 IHl
  | intros ? ? ? ? ? IH1
  | intros ? ? ? ? ? IH1
  | intros ? IH2 ? IH1
  | intros ? ? ?
  | intros ? ? ? IH1
  | intros ? ? ? ? IH1
  | intros ?
  | intros ? ? ? ? IH1 ? IH2
  | ].

(** * CPS Values *)

Inductive val : Type :=
| Vconstr : ctor_tag -> list val -> val
| Vfun : M.t val -> fundefs -> var -> val
(* [Vfun env fds f]
     where env is the environment at the function binding site
     fds is the list of mutually recursive functions including f *)
| Vprim : primitive -> val
| Vint : Z -> val.

(** Induction principle for values. *)
Lemma val_ind' :
  forall P : val -> Prop,
    (forall (t : ctor_tag), P (Vconstr t nil)) ->
    (forall (t : ctor_tag) (v : val) (l : list val),
        P v -> P (Vconstr t l) -> P (Vconstr t (v :: l))) ->
    (forall (t : M.t val) (f0 : fundefs) (v : var), P (Vfun t f0 v)) ->
    (forall p, P (Vprim p)) ->
    (forall z : Z, P (Vint z)) ->
    forall v : val, P v.
Proof.
  intros P H1 H2 H3 H4 H5.
  fix val_ind' 1.
  destruct v; try (now clear val_ind'; eauto).
  - induction l as [ | x xs IHxs].
    eapply H1. eapply H2. apply val_ind'. eauto.
Qed.

Fixpoint def_funs (fl0 fl: fundefs) (rho0 rho: M.t val) : M.t val :=
  match fl with
  | Fcons f t xs e fl' => M.set f (Vfun rho0 fl0 f) (def_funs fl0 fl' rho0 rho)
  | Fnil => rho
  end.

Fixpoint find_def (f: var) (fl:  fundefs) :=
  match fl with
  | Fcons f' t ys e fl' => if M.elt_eq f f' then Some (t,ys,e)
                           else find_def f fl'
  | Fnil => None
  end.

(** * Information associated with identifiers **)

(* The info of a constructor. *)
Record ctor_ty_info : Set :=
  Build_ctor_ty_info
    { ctor_name     : name    (* the name of the constructor *)
    ; ctor_ind_name : name    (* the name of its inductive type *)
    ; ctor_ind_tag  : ind_tag (* ind_tag of corresponding inductive type *)
    ; ctor_arity    : N       (* the arity of the constructor *)
    ; ctor_ordinal  : N       (* the [ctor_tag]s ordinal in inductive defn starting at zero *)
    }.

(* The info of an inductive type is list of the ctags of its constructors *)
Definition ind_ty_info : Set := list (ctor_tag * N).

Definition unknown_ctor_ty_info : ctor_ty_info :=
  {| ctor_name     := nAnon
   ; ctor_ind_name := nAnon
   ; ctor_ind_tag  := 1%positive
   ; ctor_arity    := 0%N
   ; ctor_ordinal  := 0%N
  |}.

Definition unknown_ind_ty_info : ind_ty_info := nil.

(* An constructor environment maps [ctor_tag]s to their information *)
Definition ctor_env : Set := M.tree ctor_ty_info.

(* An inductive type environment maps [ind_tag]s to their constructors with their arities *)
Definition ind_env : Set := M.tree ind_ty_info.

(* Every calling convention requires knowing
   how many arguments in which slots of the arg array *)
Definition fun_ty_info : Set := N * list N.

Definition fun_env : Set := M.tree fun_ty_info.

(** Register the tag used for closures **)
Definition add_closure_tag (c i : positive) (cenv : ctor_env) : ctor_env :=
  let info := {| ctor_name     := nAnon
               ; ctor_ind_name := nAnon
               ; ctor_ind_tag  := i
               ; ctor_arity    := 2%N
               ; ctor_ordinal  := 0%N
              |}
  in M.set c info cenv.


From refinedc.typing Require Import typing.
From refinedc.project.learning.src.circuit Require Import generated_code.
From refinedc.project.learning.src.circuit Require Import generated_spec.
Set Default Proof Using "Type".

(* Generated from [src/circuit.c]. *)
Section proof_set_one.
  Context `{!typeG Σ} `{!globalG Σ}.

  (* Typing proof for [set_one]. *)
  Lemma type_set_one :
    ⊢ typed_function impl_set_one type_of_set_one.
  Proof.
    Open Scope printing_sugar.
    start_function "set_one" ([[[a b] x] p]) => arg_c arg_v.
    prepare_parameters (a b x p).
    split_blocks ((
      ∅
    )%I : gmap label (iProp Σ)) ((
      ∅
    )%I : gmap label (iProp Σ)).
    - repeat liRStep; liShow.
      all: print_typesystem_goal "set_one" "#0".
    Unshelve. all: li_unshelve_sidecond; sidecond_hook; prepare_sideconditions; normalize_and_simpl_goal; try solve_goal; unsolved_sidecond_hook.
    all: print_sidecondition_goal "set_one".
    Unshelve. all: try done; try apply: inhabitant; print_remaining_shelved_goal "set_one".
  Qed.
End proof_set_one.


Require Import Category.Lib.
Require Import Category.Instance.Lambda.Ltac.
Require Import Category.Instance.Lambda.Ty.
Require Import Category.Instance.Lambda.Exp.
Require Import Category.Instance.Lambda.Value.
Require Import Category.Instance.Lambda.Ren.
Require Import Category.Instance.Lambda.Sub.
Require Import Category.Instance.Lambda.Log.
Require Import Category.Instance.Lambda.Sem.
Require Import Category.Instance.Lambda.Multi.
Require Import Category.Instance.Lambda.Sound.
Require Import Category.Instance.Lambda.Step.

From Equations Require Import Equations.
Set Equations With UIP.

Generalizable All Variables.

Section Norm.

#[local] Hint Constructors ValueP Step : core.

#[local] Hint Extern 7 (_ ---> _) => repeat econstructor : core.

Definition normalizing `(R : crelation X) : Type :=
  ∀ t, ∃ t', multi R t t' ∧ normal_form R t'.

Definition halts {Γ τ} (e : Exp Γ τ) : Type :=
  ∃ e', e --->* e' ∧ ValueP e'.

Notation " e '⇓' " := (halts e) (at level 11).

Definition normal_form_of {Γ τ} (e e' : Exp Γ τ) : Type :=
  (e --->* e' ∧ normal_form Step e').

Ltac normality :=
  exfalso;
  lazymatch goal with
    | [ H1 : ValueP ?X, H2 : ?X ---> ?Y |- False ] =>
        apply value_is_nf in H1; destruct H1;
        now exists Y
    | [ H1 : normal_form ?R ?X, H2 : ?R ?X ?Y |- False ] =>
        exfalso; now apply (H1 Y)
  end.

Ltac invert_step :=
  try lazymatch goal with
  | [ H : _ ---> _ |- _ ] => now inv H
  end;
  try solve [ f_equal; intuition eauto | normality ].

Lemma value_halts {Γ τ} (v : Exp Γ τ) : ValueP v → halts v.
Proof.
  intros X.
  unfold halts.
  now induction X; eexists; repeat constructor.
Qed.

Theorem normal_forms_unique Γ τ :
  deterministic (normal_form_of (Γ:=Γ) (τ:=τ)).
Proof.
  unfold deterministic, normal_form_of.
  intros x y1 y2 P1 P2.
  destruct P1 as [P11 P12].
  destruct P2 as [P21 P22].
  generalize dependent y2.
  induction P11; intros.
  - inversion P21; auto.
    now einduction P12; eauto.
  - apply IHP11; auto.
    inv P21.
    + now edestruct P22; eauto.
    + assert (y = y0) by now apply Step_deterministic with x.
      now subst.
Qed.

Lemma step_preserves_halting {Γ τ} (e e' : Exp Γ τ) :
  (e ---> e') → (halts e ↔ halts e').
Proof.
  intros.
  unfold halts.
  split.
  - intros [e'' [H1 H2]].
    + destruct H1.
      * apply value_is_nf in H2.
        now edestruct H2; eauto.
      * rewrite (Step_deterministic _ _ _ _ _ H s).
        now intuition eauto.
  - intros [e'0 [H1 H2]].
    + exists e'0.
      split; auto.
      now eapply multi_step; eauto.
Qed.

Definition SN {Γ τ} : Γ ⊢ τ → Type := ExpP (@halts Γ).
Arguments SN {Γ τ} _ /.

Definition SN_Sub {Γ Γ'} : Sub Γ' Γ → Type := SubP (@halts Γ').
Arguments SN_Sub {Γ Γ'} /.

Definition SN_halts {Γ τ} {e : Γ ⊢ τ} : SN e → halts e := ExpP_P _.

#[local] Transparent ExpP.

Lemma step_preserves_SN {Γ τ} {e e' : Γ ⊢ τ} :
  (e ---> e') → SN e → SN e'.
Proof.
  intros.
  induction τ; simpl in *;
  pose proof H as H2;
  apply step_preserves_halting in H2;
  firstorder.
Qed.

Lemma multistep_preserves_SN {Γ τ} {e e' : Γ ⊢ τ} :
  (e --->* e') → SN e → SN e'.
Proof.
  intros.
  induction X; auto.
  apply IHX.
  now eapply step_preserves_SN; eauto.
Qed.

Lemma step_preserves_SN' {Γ τ} {e e' : Γ ⊢ τ} :
  (e ---> e') → SN e' → SN e.
Proof.
  intros.
  induction τ; simpl in *;
  pose proof H as H2;
  apply step_preserves_halting in H2;
  firstorder.
Qed.

Lemma multistep_preserves_SN' {Γ τ} {e e' : Γ ⊢ τ} :
  (e --->* e') → SN e' → SN e.
Proof.
  intros.
  induction X; auto.
  now eapply step_preserves_SN'; eauto.
Qed.

Lemma SubExp_SN {Γ Γ'} (env : Sub Γ' Γ) {τ} (e : Exp Γ τ) :
  SN_Sub env →
  SN (SubExp env e).
Proof.
  generalize dependent env.
  induction e; intros; simpl.
  - now eexists; repeat constructor.
  - split.
    + destruct (SN_halts (IHe1 env X)) as [v1 [P1 Q1]].
      destruct (SN_halts (IHe2 env X)) as [v2 [P2 Q2]].
      exists (Pair v1 v2).
      split.
      * now apply multistep_Pair.
      * now repeat constructor.
    + split.
      * destruct (SN_halts (IHe1 env X)) as [v1 [P1 Q1]].
        destruct (SN_halts (IHe2 env X)) as [v2 [P2 Q2]].
        apply (multistep_preserves_SN' (e':=v1)); auto.
        ** rewrite (multistep_Fst1 (p':=Pair v1 v2)).
           *** now apply multi_R; eauto.
           *** erewrite multistep_Pair1; eauto.
               erewrite multistep_Pair2; eauto.
               now apply multi_refl.
        ** apply (multistep_preserves_SN (e:=SubExp env e1));
           now intuition.
      * destruct (SN_halts (IHe1 env X)) as [v1 [P1 Q1]].
        destruct (SN_halts (IHe2 env X)) as [v2 [P2 Q2]].
        apply (multistep_preserves_SN' (e':=v2)); auto.
        ** rewrite (multistep_Snd1 (p':=Pair v1 v2)).
           *** now apply multi_R; eauto.
           *** erewrite multistep_Pair1; eauto.
               erewrite multistep_Pair2; eauto.
               now apply multi_refl.
        ** apply (multistep_preserves_SN (e:=SubExp env e2));
           now intuition.
  - now apply IHe.
  - now apply IHe.
  - induction env.
    + now inv v.
    + dependent elimination X.
      now dependent elimination v; simpl in *; simp SubVar.
  - split.
    + now eexists; repeat constructor.
    + intros.
      destruct (SN_halts X0) as [v [P Q]].
      apply (multistep_preserves_SN' (e':=SubExp (Push v env) e)); auto.
      * eapply multi_trans; eauto.
        ** now eapply multistep_AppR; eauto.
        ** apply multi_R; auto.
           now rewrite SubExp_Push; eauto 6.
      * apply IHe.
        constructor; auto.
        now eapply multistep_preserves_SN; eauto.
  - now apply IHe1, IHe2.
Qed.

Theorem Exp_SN {τ} (e : Exp nil τ) : SN e.
Proof.
  intros.
  replace e with (SubExp (Γ:=nil) NoSub e).
  - apply SubExp_SN.
    now constructor.
  - now rewrite NoSub_idSub, SubExp_idSub.
Qed.

Corollary strong_normalization {τ} (e : Exp nil τ) : e ⇓.
Proof.
  pose proof (Exp_SN e) as X.
  now apply SN_halts.
Qed.

End Norm.


(** * Similar states after first rising edge  *)

Require Import sitpn.SitpnLib.

Require Import hvhdl.HVhdlCoreLib.
Require Import hvhdl.HVhdlElaborationLib.
Require Import hvhdl.HVhdlSimulationLib.
Require Import hvhdl.HVhdlHilecopLib.

Require Import transformation.Sitpn2HVhdl.

Require Import soundness.SemanticPreservationDefs.

Lemma first_rising_edge_full :
  forall sitpn b d γ E__c E__p Δ σ__e σ0 τ σ__r σ,

    (* sitpn translates into (d, γ). *)
    sitpn2hvhdl sitpn b = (inl (d, γ)) ->

    (* Environments are similar. *)
    SimEnv sitpn γ E__c E__p ->

    (* [Δ, σ__e] are the results of the elaboration of [d]. *)
    EDesign hdstore (NatMap.empty value) d Δ σ__e ->

    (* [σ0] is the initial state of [d]. *)
    Init hdstore Δ σ__e (AbstractSyntax.beh d) σ0 ->

    (* From [σ0] to [σ] after [↑]. *)
    VConc hdstore Δ (inj σ0 (E__p τ)) rising (AbstractSyntax.beh d) σ__r ->
    Stabilize hdstore Δ σ__r (AbstractSyntax.beh d) σ ->

    (* States [s] and [σ] are similar. *)
    FullSimStateAfterRE sitpn γ E__c τ (s0 sitpn) σ.
Admitted.

(* Tries to apply the [first_rising_edge_full] lemma when the goal is of the form
   [SimStateAfterFE _ _ _ _] or [_ ⊢ _ ∼ _]. *)
#[export] Hint Resolve first_rising_edge_full : hilecop.
#[export] Hint Extern 1 ( _ ⊢ _ ∼ _ ) => eapply first_rising_edge_full; eauto : hilecop.

Lemma first_rising_edge :
  forall sitpn b d γ E__c E__p Δ σ__e σ0 τ σ__r σ,

    (* sitpn translates into (d, γ). *)
    sitpn2hvhdl sitpn b = (inl (d, γ)) ->

    (* Environments are similar. *)
    SimEnv sitpn γ E__c E__p ->

    (* [Δ, σ__e] are the results of the elaboration of [d]. *)
    EDesign hdstore (NatMap.empty value) d Δ σ__e ->

    (* [σ0] is the initial state of [d]. *)
    Init hdstore Δ σ__e (AbstractSyntax.beh d) σ0 ->

    (* From [σ0] to [σ] after [↑]. *)
    VConc hdstore Δ (inj σ0 (E__p τ)) rising (AbstractSyntax.beh d) σ__r ->
    Stabilize hdstore Δ σ__r (AbstractSyntax.beh d) σ ->

    (* States [s] and [σ] are similar. *)
    SimStateAfterRE sitpn γ (s0 sitpn) σ.
Proof. eapply first_rising_edge_full; eauto. Qed.

(* Tries to apply the [first_rising_edge] lemma when the goal is of the form
   [SimStateAfterFE _ _ _ _] or [_ ⊢ _ ∼ _]. *)
#[export] Hint Resolve first_rising_edge : hilecop.
#[export] Hint Extern 1 ( _ ⊢ _ ∼ _ ) => eapply first_rising_edge; eauto : hilecop.

(** States that, for all SITPN [sitpn] passed as input to the HM2T and
    resulting design [d], if [σ0] is the initial state of [d] then a
    rising edge phase can be computed from [σ0], and thus ends in
    state [σ], such that [σ] is similar to the initial state [s0] of
    [sitpn]. *)

Lemma first_rising_edge_lock_step_full :
  forall sitpn b d γ E__c E__p Δ σ__e σ0,

    (* sitpn translates into (d, γ). *)
    sitpn2hvhdl sitpn b = (inl (d, γ)) ->

    (* Environments are similar. *)
    SimEnv sitpn γ E__c E__p ->

    (* [Δ, σ__e] are the results of the elaboration of [d]. *)
    EDesign hdstore (NatMap.empty value) d Δ σ__e ->

    (* [σ0] is the initial state of [d]. *)
    Init hdstore Δ σ__e (AbstractSyntax.beh d) σ0 ->

    forall τ,
    exists σ__r σ,
      (* From [σ0] to [σ] after [↑]. *)
      VConc hdstore Δ (inj σ0 (E__p τ)) rising (AbstractSyntax.beh d) σ__r
      /\ Stabilize hdstore Δ σ__r (AbstractSyntax.beh d) σ

      (* States [s] and [σ] are "fully" similar. *)
      /\ FullSimStateAfterRE sitpn γ E__c τ (s0 sitpn) σ.
Admitted.

#[export] Hint Resolve first_rising_edge_lock_step_full : hilecop.

Lemma first_rising_edge_lock_step :
  forall sitpn b d γ E__c E__p Δ σ__e σ0,

    (* sitpn translates into (d, γ). *)
    sitpn2hvhdl sitpn b = (inl (d, γ)) ->

    (* Environments are similar. *)
    SimEnv sitpn γ E__c E__p ->

    (* [Δ, σ__e] are the results of the elaboration of [d]. *)
    EDesign hdstore (NatMap.empty value) d Δ σ__e ->

    (* [σ0] is the initial state of [d]. *)
    Init hdstore Δ σ__e (AbstractSyntax.beh d) σ0 ->

    forall τ,
    exists σ__r σ,
      (* From [σ0] to [σ] after [↑]. *)
      VConc hdstore Δ (inj σ0 (E__p τ)) rising (AbstractSyntax.beh d) σ__r
      /\ Stabilize hdstore Δ σ__r (AbstractSyntax.beh d) σ

      (* States [s] and [σ] are similar. *)
      /\ SimStateAfterRE sitpn γ (s0 sitpn) σ.
Proof.
  intros until τ.
  edestruct first_rising_edge_lock_step_full as (σ__r, (σ, (HVConc, (Hstab, Hfsim)))); eauto.
  exists σ__r, σ; eauto with hilecop.
Qed.

#[export] Hint Resolve first_rising_edge_lock_step : hilecop.