(******************************************************************************)
(** * A compilation correctness proof from the Promising2 memory model to
      the IMM memory model. *)
(******************************************************************************)
Require Import Omega.
From hahn Require Import Hahn.
Require Import PromisingLib.
From Promising2 Require Import TView View Time Event Cell Thread Memory Configuration Local.
From imm Require Import Prog.
From imm Require Import ProgToExecution.
From imm Require Import Events.
From imm Require Import Execution.
From imm Require Import imm_s.
From imm Require Import CombRelations.
From imm Require Import ProgToExecutionProperties.
From imm Require Import RMWinstrProps.
From imm Require Import AuxRel2.

Require Import SimulationRel.
Require Import PlainStepBasic.
Require Import SimulationPlainStep.
Require Import MaxValue.
Require Import SimState.
Require Import Event_imm_promise.
Require Import PromiseOutcome.
Require Import CertGraphInit.
Require Import MemoryAux.
Require Import PromiseLTS.
From imm Require Import Traversal.
From imm Require Import TraversalConfig.
Require Import ExtSimTraversal.
Require Import ExtSimTraversalProperties.
Require Import ExtTraversalConfig.
Require Import ExtTraversal.
Require Import ExtTraversalCounting.
Require Import SimulationPlainStepAux.
Require Import FtoCoherent.
Require Import AuxTime.

Set Implicit Arguments.
Remove Hints plus_n_O.

Lemma istep_nil_eq_silent thread :
  istep thread nil ≡
  lts_step thread ProgramEvent.silent.
Proof using.
  unfold lts_step. unfold lab_imm_promise.
  split; [|basic_solver].
  unfolder. ins. exists nil. eauto.
Qed.

(* TODO: move *)
Lemma InAE A x (l : list A) : SetoidList.InA eq x l <-> In x l.
Proof using.
  split; [by induction 1; desf; ins; eauto|].
  induction l; ins; desf; eauto using SetoidList.InA.
Qed.

(* TODO: move *)
Lemma NoDupAE A (l : list A) : SetoidList.NoDupA eq l <-> NoDup l.
Proof using.
  split; induction 1; constructor; eauto; rewrite InAE in *; eauto.
Qed.

(* TODO: move *)
Lemma NoDup_map_NoDupA A B (f : A -> B) l :
  SetoidList.NoDupA (fun p p' => f p = f p') l ->
  NoDup (map f l).
Proof using.
  induction 1; ins; constructor; eauto.
  clear -H; intro M; destruct H; induction l; ins; desf;
    eauto using SetoidList.InA.
Qed.

(* TODO: move to to imm/RMWinstrProps.v. *)
Lemma dom_rmw_in_rex_thread_steps thread s s'
      (RMWREX : rmw_is_rex_instrs s.(instrs))
      (WF : wf_thread_state thread s)
      (STEPS : (step thread)^* s s')
      (SS : dom_rmw_in_rex s) :
  dom_rmw_in_rex s'.
Proof using.
  apply clos_rt_rtn1_iff in STEPS.
  induction STEPS; auto.
  apply clos_rt_rtn1_iff in STEPS.
  eapply dom_rmw_in_rex_thread_step with (s:=y); eauto.
  { erewrite steps_preserve_instrs; eauto. }
  eapply wf_thread_state_steps; eauto.
Qed.

Definition execution_final_memory (G : execution) final_memory :=
  forall l,
    (⟪ NO : forall e (EE : acts_set G e), loc G.(lab) e <> Some l ⟫ /\
     ⟪ ZERO : final_memory l = 0 ⟫) \/
    exists w,
      ⟪ ACTS : G.(acts_set) w ⟫ /\
      ⟪ WW   : is_w G.(lab) w ⟫ /\
      ⟪ LOC  : loc  G.(lab) w = Some l ⟫ /\
      ⟪ VAL  : val  G.(lab) w = Some (final_memory l) ⟫ /\
      ⟪ LAST : ~ (exists w', G.(co) w w') ⟫.

Notation "'NTid_' t" := (fun x => tid x <> t) (at level 1).
Notation "'Tid_' t"  := (fun x => tid x =  t) (at level 1).

Lemma cert_sim_step G sc thread PC T T' f_to f_from smode
      (WF : Wf G) (IMMCON : imm_consistent G sc)
      (STEP : ext_isim_trav_step G sc thread T T')
      (SIMREL : simrel_thread G sc PC (etc_TC T) (reserved T) f_to f_from thread smode)
      (NCOV : NTid_ thread ∩₁ G.(acts_set) ⊆₁ ecovered T) :
    exists PC' f_to' f_from',
      ⟪ PSTEP : (plain_step MachineEvent.silent thread)＊ PC PC' ⟫ /\
      ⟪ SIMREL : simrel_thread G sc PC' (etc_TC T') (reserved T') f_to' f_from' thread smode ⟫.
Proof using.
  destruct T as [T S].
  destruct T' as [T' S'].
  unfold ecovered in *. simpls.
  eapply plain_sim_step in STEP; eauto.
  desf. eexists. eexists. eexists. splits; eauto.
Qed.

Lemma cert_sim_steps G sc thread PC T T' f_to f_from smode
      (WF : Wf G) (IMMCON : imm_consistent G sc)
      (STEPS : (ext_isim_trav_step G sc thread)⁺ T T')
      (SIMREL : simrel_thread G sc PC (etc_TC T) (reserved T) f_to f_from thread smode)
      (NCOV : NTid_ thread ∩₁ G.(acts_set) ⊆₁ ecovered T) :
    exists PC' f_to' f_from',
      ⟪ PSTEP : (plain_step MachineEvent.silent thread)＊ PC PC' ⟫ /\
      ⟪ SIMREL : simrel_thread G sc PC' (etc_TC T') (reserved T') f_to' f_from' thread  smode ⟫.
Proof using.
  generalize dependent f_from.
  generalize dependent f_to.
  generalize dependent PC.
  induction STEPS.
  { ins. eapply cert_sim_step in H; eauto. }
  ins.
  apply IHSTEPS1 in SIMREL; auto.
  desf.
  apply IHSTEPS2 in SIMREL0; auto.
  { desf. eexists. eexists. eexists. splits.
    2: by eauto.
    eapply rt_trans; eauto. }
  etransitivity; eauto.
  eapply ext_sim_trav_steps_covered_le with (G:=G) (sc:=sc).
  apply inclusion_t_rt.
  generalize STEPS1. clear.
  generalize dependent y. generalize dependent x.
  apply inclusion_t_t.
  unfold ext_sim_trav_step.
  basic_solver.
Qed.

Lemma cert_simulation G sc thread PC T S f_to f_from
      (WF : Wf G) (IMMCON : imm_consistent G sc)
      (SIMREL : simrel_thread G sc PC T S f_to f_from thread sim_certification)
      (NCOV : NTid_ thread ∩₁ G.(acts_set) ⊆₁ covered T) :
  exists T' S' PC' f_to' f_from',
    ⟪ FINALT : G.(acts_set) ⊆₁ covered T' ⟫ /\
    ⟪ PSTEP  : (plain_step MachineEvent.silent thread)＊ PC PC' ⟫ /\
    ⟪ SIMREL : simrel_thread G sc PC' T' S' f_to' f_from' thread sim_certification⟫.
Proof using.
  assert (etc_coherent G sc (mkETC T S)) as ETCCOH.
  { apply SIMREL. }
  generalize (sim_step_cov_full_traversal WF IMMCON ETCCOH NCOV); intros H.
  destruct H as [T'].
  1,2: by apply SIMREL.
  desc.
  destruct T' as [T' S'].
  exists T', S'. apply rtE in H.
  destruct H as [H|H].
  { red in H. desf.
    eexists. eexists. eexists.
    splits; eauto.
    apply rtE. left. red. eauto. }
  eapply cert_sim_steps in H; auto.
  2: by eauto.
  desf. eexists. eexists. eexists. splits; eauto.
Qed.

Lemma simrel_thread_bigger_sc_memory G sc T S thread f_to f_from threads memory
      sc_view memory' sc_view'
      lang state local
      (WF : Wf G) (IMMCON : imm_consistent G sc)
      (THREAD     : IdentMap.find thread threads = Some (existT _ lang state, local))
      (INHAB      : Memory.inhabited memory' )
      (CLOSED_MEM : Memory.closed memory')
      (MEM_LE : Memory.le memory memory')
      (SС_CLOSED  : Memory.closed_timemap sc_view' memory')
      (SIMREL : simrel_thread G sc (Configuration.mk threads sc_view memory )
                              T S f_to f_from thread  sim_certification) :
  simrel_thread G sc (Configuration.mk threads sc_view' memory') T S f_to f_from
                thread sim_certification.
Proof using.
  cdes SIMREL. cdes COMMON. cdes LOCAL.
  red; splits; red; splits; eauto; ins.
  { ins. etransitivity.
    { eapply PROM_IN_MEM; eauto. }
    done. }
  eexists. eexists. eexists; eauto. splits; eauto.
  3: by eapply memory_close_le; eauto.
  2: { red. ins. edestruct SIM_RES_MEM as [rel_opt H]; eauto. }
  red. ins.
  edestruct SIM_MEM as [rel_opt H]; eauto.
  simpls. desf.
  exists rel_opt; splits; eauto.
  { eapply memory_closed_timemap_le; eauto. }
  ins. destruct H1; eauto. unnw. desc.
  splits; auto.
  exists p_rel. splits; auto.
  desf; [by left| right].
  apply MEM_LE in H5.
  exists p; splits; auto.
  exists p_v; splits; auto.
Qed.

Section PromiseToIMM.

Variable prog : Prog.t.
Hypothesis TNONULL : ~ IdentMap.In tid_init prog.

Variable G : execution.
Variable final_memory : location -> value.

Hypothesis ALLRLX  : G.(acts_set) \₁ is_init ⊆₁ (fun a => is_true (is_rlx G.(lab) a)).
Hypothesis FRELACQ : G.(acts_set) ∩₁ (fun a => is_true (is_f G.(lab) a)) ⊆₁ (fun a => is_true (is_ra G.(lab) a)).

Hypothesis EFM : execution_final_memory G final_memory.

Hypothesis PROG_EX : program_execution prog G.
Hypothesis RMWREX  : forall thread linstr
                            (IN : Some linstr = IdentMap.find thread prog),
    rmw_is_rex_instrs linstr.
Hypothesis WF : Wf G.
Variable sc : relation actid.
Hypothesis IMMCON : imm_consistent G sc.

Lemma conf_steps_preserve_thread tid PC PC'
      (STEPS : (plain_step MachineEvent.silent tid)＊ PC PC') :
  forall lang state local
         (THREAD  : IdentMap.find tid PC.(Configuration.threads) =
                    Some (existT _ lang  state , local)),
  exists lang' state' local',
    IdentMap.find tid PC'.(Configuration.threads) =
    Some (existT _ lang' state', local').
Proof using.
  induction STEPS.
  2: { ins. eauto. }
  { destruct H.
    simpls. rewrite IdentMap.gss. eauto. }
  ins. edestruct IHSTEPS1; eauto. desc.
  eapply IHSTEPS2; eauto.
Qed.

Lemma conf_steps_preserve_lang tid PC PC'
      (STEPS : (plain_step MachineEvent.silent tid)＊ PC PC') :
  forall lang  state  local lang' state' local'
         (THREAD  : IdentMap.find tid PC.(Configuration.threads) =
                    Some (existT _ lang  state , local))
         (THREAD' : IdentMap.find tid PC'.(Configuration.threads) =
                    Some (existT _ lang' state', local')),
    lang = lang'.
Proof using.
  induction STEPS.
  2: { ins. rewrite THREAD' in THREAD. inv THREAD. }
  { destruct H.
    simpls. rewrite IdentMap.gss.
    ins. desf. }
  ins.
  edestruct conf_steps_preserve_thread with (PC':=y); eauto. desc.
  etransitivity.
  { eapply IHSTEPS1; eauto. }
  eapply IHSTEPS2; eauto.
Qed.

Lemma conf_steps_to_thread_steps tid PC PC'
      (STEPS : (plain_step MachineEvent.silent tid)＊ PC PC') :
  forall lang state local
         state' local' ts ts'
         (THREAD  : IdentMap.find tid PC.(Configuration.threads) =
                    Some (existT _ lang state, local))
         (THREAD' : IdentMap.find tid PC'.(Configuration.threads) =
                    Some (existT _ lang state', local'))
         (TS  : ts  = Thread.mk lang state local
                                PC.(Configuration.sc) PC.(Configuration.memory))
         (TS' : ts' = Thread.mk lang state' local'
                                PC'.(Configuration.sc) PC'.(Configuration.memory)),
    rtc (Thread.tau_step (lang:=lang)) ts ts'.
Proof using.
  induction STEPS.
  2: { ins. apply rtc_refl.
       rewrite TS, TS'.
       rewrite THREAD' in THREAD. inv THREAD. }
  { set (pe := MachineEvent.silent) in H.
    assert (pe = MachineEvent.silent) as HH.
    { done. }
    destruct H.
    simpls. rewrite IdentMap.gss.
    ins. desf. eapply rtc_n1; eauto.
    red. econstructor.
    { econstructor; eauto. }
    done. }
  ins.
  edestruct conf_steps_preserve_thread with (PC':=y); eauto. desc.
  assert (x0 = lang); subst.
  { eapply conf_steps_preserve_lang; eauto. }
  etransitivity.
  { eapply IHSTEPS1; eauto. }
  eapply IHSTEPS2; eauto.
Qed.

Lemma event_to_prog_thread e (ACT : acts_set G e) (NINIT : ~ is_init e) :
  IdentMap.In (tid e) prog.
Proof using PROG_EX.
  red in PROG_EX.
  destruct PROG_EX as [HH OO].
  destruct (HH e ACT) as [|AA]; [by desf|done].
Qed.

Lemma dom_rmw_in_R_ex : dom_rel (rmw G) ⊆₁ (fun a : actid => R_ex (lab G) a).
Proof using PROG_EX RMWREX WF.
  red in PROG_EX.
  intros x H.
  destruct H as [y RMW].
  assert (acts_set G x) as EX.
  { apply (dom_l WF.(wf_rmwE)) in RMW.
    apply seq_eqv_l in RMW. desf. }
  rename PROG_EX into HH. destruct HH as [PROG_EX PEX].
  specialize (PROG_EX x EX).
  destruct PROG_EX as [INIT|TH].
  { exfalso. apply (rmw_from_non_init WF) in RMW.
    apply seq_eqv_l in RMW. desf. }
  apply IdentMap.Facts.in_find_iff in TH.
  destruct (IdentMap.find (tid x) prog) eqn: INP.
  2: done.
  symmetry in INP.
  set (PP:=INP).
  apply PEX in PP. desc. subst.
  red in PP. desc.
  rewrite <- PEQ in *.
  assert (acts_set s.(ProgToExecution.G) x) as SX.
  { apply PP0.(tr_acts_set). by split. }
  unfold R_ex.
  assert (lab G x = lab (ProgToExecution.G s) x) as LL.
  { eapply lab_thread_eq_thread_restricted_lab; eauto. }
  assert (s.(ProgToExecution.G).(rmw) x y) as SRMW.
  { apply PP0.(tr_rmw).
    simpls. apply seq_eqv_l; split; auto.
    apply seq_eqv_r. split; auto.
    apply WF.(wf_rmwt) in RMW. symmetry. apply RMW. }
  assert (dom_rmw_in_rex s) as YY.
  2: { specialize (YY x). rewrite LL.
       apply YY. by exists y. }
  apply RMWREX in INP.
  eapply dom_rmw_in_rex_thread_steps; eauto.
  { unfold init; simpls. }
  { apply wf_thread_state_init. }
  red. unfold init. simpls. clear. basic_solver.
Qed.

Lemma simrel_init :
  simrel G sc (conf_init prog)
         (init_trav G) (is_init ∩₁ acts_set G)
         (fun _ => tid_init) (fun _ => tid_init).
Proof using ALLRLX IMMCON PROG_EX TNONULL WF FRELACQ RMWREX.
  red; splits; red; splits; auto.
  { by apply ext_init_trav_coherent. }
  { simpls. basic_solver. }
  { ins. split; intros [INIT GG]; exfalso.
    { apply WF.(init_w) in INIT.
      apply (dom_l WF.(wf_rmwD)) in RMW.
      apply seq_eqv_l in RMW.
      type_solver. }
    apply WF.(rmw_in_sb) in RMW.
    apply no_sb_to_init in RMW.
    apply seq_eqv_r in RMW. desf. }
  { ins.
    unfold Threads.init.
    rewrite IdentMap.Facts.map_o.
    unfold init_threads.
    rewrite IdentMap.gmapi.
    assert (IdentMap.In (tid e) prog) as INE.
    { by apply event_to_prog_thread. }
    assert (exists linstr, IdentMap.find (tid e) prog = Some linstr)
      as [linstr LI].
    { apply IdentMap.Facts.in_find_iff in INE.
      destruct (IdentMap.find (tid e) prog) eqn: H; desf.
      eauto. }
    rewrite LI. simpls. eauto. }
  { ins. unfold init_threads, Threads.init in *.
    rewrite IdentMap.Facts.map_o in TID.
    rewrite IdentMap.gmapi in TID.
    destruct (IdentMap.find thread' prog) eqn: HH; simpls.
    inv TID. unfold Local.init. simpls.
    apply Memory.bot_le. }
  { assert (complete G) as CG.
    { apply IMMCON. }
    assert (Execution_eco.sc_per_loc G) as ESC.
    { apply imm_s_hb.coherence_sc_per_loc. apply IMMCON. }
    red. splits; simpls.
    { ins. destruct H. desf. }
    all: ins; exfalso.
    apply Execution_eco.no_co_to_init in H1; auto.
    apply seq_eqv_r in H1.
    destruct H0. desf. }
  { ins. }
  { ins.
    unfold LocFun.find, TimeMap.bot.
    apply max_value_empty.
    unfold S_tm, S_tmr.
    ins. intros HH.
    destruct HH as [y HH].
    apply seq_eqv_l in HH. destruct HH as [_ HH].
    destruct HH as [z [_ HH]].
    destruct HH as [w [_ HH]].
    apply seq_eqv_r in HH. destruct HH as [HH [AA BB]].
    red in HH. destruct HH as [CC [HH _]]. subst.
    apply WF.(init_w) in AA.
    type_solver. }
  { apply dom_rmw_in_R_ex. }
  { red. splits; ins.
    3: { match goal with
         | H : co _ _ _ |- _ => rename H into CO
         end.
         apply Execution_eco.no_co_to_init in CO; auto.
         2: { apply imm_s_hb.coherence_sc_per_loc.
              apply IMMCON. }
         unfolder in *. desf. }
    2: { red. ins. apply memory_init_o in MSG. desf. }
    red; ins. unfold Memory.init in MSG.
    unfold Memory.get in MSG.
    unfold Cell.init in MSG.
    unfold Cell.get in MSG; simpls.
    unfold Cell.Raw.init in MSG.
    destruct (classic (to = Time.bot)) as [|NEQ]; subst.
    2: { rewrite DenseOrder.DOMap.singleton_neq in MSG; auto.
         inv MSG. }
    rewrite DenseOrder.DOMap.singleton_eq in MSG. inv MSG.
    left. by split. }
  { unfold conf_init, Configuration.init.
    simpls.
    edestruct TView.bot_closed.
    unfold TView.bot, View.bot in *; simpls.
    destruct CUR. simpls. }
  { simpls. apply Memory.init_closed. }
  simpls.
  apply IdentMap.Facts.in_find_iff in TP.
  destruct (IdentMap.find thread (Threads.init (init_threads prog))) eqn: HH; simpls.
  clear TP.
  unfold Threads.init in *.
  rewrite IdentMap.Facts.map_o in *.
  unfold init_threads in *.
  rewrite IdentMap.gmapi in *.
  destruct (IdentMap.find thread prog) eqn: UU; simpls.
  inv HH. clear HH.
  simpls.
  exists (init l), (Local.init); splits; auto.
  { red; ins; desf; apply TNONULL, IdentMap.Facts.in_find_iff; congruence. }
  { apply wf_thread_state_init. }
  { symmetry in UU. apply RMWREX in UU. unfold init. simpls. }
  { ins. left. apply Memory.bot_get. }
  { red. ins.
    unfold Local.init in *. simpls.
    rewrite Memory.bot_get in PROM. inv PROM. }
  { red. ins. rewrite Memory.bot_get in RES. inv RES. }
  { red; simpls.
    unfold Memory.init. unfold Memory.get. unfold Cell.init.
    unfold Cell.get; simpls. unfold Cell.Raw.init.
    rewrite DenseOrder.DOMap.singleton_eq.
    exists None. splits; ins.
    { unfold Message.elt.
      assert (v = 0); [|by desf].
      destruct ISSB as [II _].
      destruct b.
      2: by inv II.
      unfold val in VAL.
      rewrite WF.(wf_init_lab) in VAL.
      inv VAL. }
    { red. splits; auto.
      { right. splits; auto. apply ISSB. }
      red. ins. unfold LocFun.find, TimeMap.bot.
      apply max_value_bot_f. }
    red. unfold View.unwrap, View.bot, TimeMap.bot. simpls.
    ins. eexists. eexists. eexists.
    unfold Memory.get, Cell.get. simpls. }
  { red; simpls. }
  { unfold Local.init. simpls.
    unfold TView.bot. red; simpls.
    unfold View.bot.
    splits; simpls; red.
    all: unfold LocFun.find, TimeMap.bot; simpls.
    all: ins.
    all: apply max_value_bot_f. }
  { unfold Local.init. simpls. }
  { unfold Local.init. simpls. red.
    unfold TView.bot; simpls. splits; ins.
    all: apply Memory.closed_timemap_bot.
    all: red; ins. }
  red. splits.
  { ins. split; ins; [|omega].
    destruct H as [H _]. simpls. }
  unfold sim_state_helper.
  red in PROG_EX. destruct PROG_EX as [HH YY].
  symmetry in UU. apply YY in UU.
  desc. red in UU. desc.
  eexists. splits; eauto. by subst.
Qed.

Definition thread_is_terminal ths tid :=
  forall (lang : Language.t ProgramEvent.t) st lc
         (LLH : IdentMap.find tid ths =
                Some (existT (fun lang => Language.state lang) lang st, lc)),
    ⟪ NOTS : Language.is_terminal lang st ⟫ /\
    ⟪ NOPROM : Local.is_terminal lc ⟫.

Lemma sim_thread_covered_exists_terminal PC thread T S f_to f_from
      (FINALT : Tid_ thread ∩₁ acts_set G ⊆₁ covered T)
      (SIMREL : simrel G sc PC T S f_to f_from) :
  exists PC',
    ⟪ STEP : (conf_step)^? PC PC' ⟫ /\
    ⟪ SIMREL : simrel G sc PC' T S f_to f_from ⟫ /\
    ⟪ SAMENUM : Permutation (map fst (IdentMap.elements (Configuration.threads PC)))
                            (map fst (IdentMap.elements (Configuration.threads PC'))) ⟫ /\
    ⟪ TERMINAL  : thread_is_terminal PC'.(Configuration.threads) thread ⟫ /\
    ⟪ PTERMINAL :
      forall thread' (TT : thread_is_terminal PC.(Configuration.threads) thread'),
        thread_is_terminal PC'.(Configuration.threads) thread' ⟫.
Proof using All.
  cdes SIMREL.
  destruct (IdentMap.find thread (Configuration.threads PC)) as [j|] eqn: QQ.
  2: { exists PC. splits; auto.
       red. ins.
       clear -QQ LLH.
       (* This trick is needed due to an implicit parameter which could be seen
          by `Set Printing All.` *)
       match goal with
       | H1 : ?A = None,
         H2 : ?B = Some _ |- _ =>
         assert (A = B) as AA
       end.
       { unfold language. done. }
       rewrite AA in QQ.
       destruct (IdentMap.find thread (Configuration.threads PC)); desf. }
  assert (IdentMap.In thread (Configuration.threads PC)) as YY.
  { apply IdentMap.Facts.in_find_iff. by rewrite QQ. }
  apply THREADS in YY. cdes YY.
  cdes STATE. cdes STATE1.
  assert (Local.promises local = Memory.bot) as PBOT.
  { red in SIM_PROM.
    eapply Memory.ext. ins.
    rewrite Memory.bot_get.
    destruct (Memory.get loc ts (Local.promises local)) eqn: H; auto.
    destruct p as [from msg].
    destruct msg as [v msg|].
    { eapply SIM_PROM in H; eauto.
      desc.
      exfalso. apply NCOV. by apply FINALT. }
    eapply SIM_RPROM in H; eauto. desc.
    exfalso.
    apply NOISS. eapply w_covered_issued.
    { apply COMMON. }
    split.
    { eapply reservedW; auto.
      { apply COMMON. }
      done. }
    apply FINALT. by split. }
  assert (Local.is_terminal local) as LCTR by (constructor; auto).
  assert (wf_thread_state thread state') as GPC'.
  { eapply wf_thread_state_steps; eauto. }
  assert (acts_set (ProgToExecution.G state') ⊆₁
          acts_set (ProgToExecution.G state)) as PP.
  { intros x HH. set (HH' := HH).
    apply GPC'.(acts_rep) in HH'.
    desc. rewrite REP in *. clear x REP.
    assert (covered T (ThreadEvent thread index)) as CC.
    { apply FINALT. split; auto.
      apply TEH in HH. apply HH. }
    apply PCOV in CC. by apply GPC.(acts_clos). }
  assert ((istep thread nil)＊ state state') as KK.
  { apply steps_same_E_empty_in; auto. }
  assert ((lts_step thread ProgramEvent.silent)＊ state state') as HH.
  { by hahn_rewrite <- istep_nil_eq_silent. }
  assert (state'.(eindex) = state.(eindex)) as EII.
  { eapply steps_same_eindex; eauto. }
  rename STEPS into STEPSAA.
  rename HH into STEPS.

  assert (forall A (a b : A), Some a = Some b -> a = b) as XBB.
  { ins. inv H. }
  assert (forall A (a b : A) B (c : B), (a, c) = (b, c) -> a = b) as XBB1.
  { ins. inv H. }

  apply rtE in STEPS. destruct STEPS as [EQ|STEPS].
  { red in EQ. desf. exists PC. splits; auto.
    red. ins.
    destruct (IdentMap.find thread (Configuration.threads PC)) eqn: HH.
    2: { clear -LLH0 LLH HH.
         unfold language in *.
         desf. }
    inv LLH.
    unfold language in *; simpls.
    rewrite HH in LLH0. inv LLH0.
    assert (state' = st); subst.
    { clear -LLH0 XBB XBB1. simpl in *.
      apply XBB in LLH0.
      apply XBB1 in LLH0. desf. }
    splits; auto. red. simpls.
      by apply TERMINAL. }
  assert
  (thread_is_terminal
     (IdentMap.add thread (existT (@Language.state ProgramEvent.t) (thread_lts thread) state', local)
                   (Configuration.threads PC)) thread) as TT.
  { red. ins. rewrite IdentMap.gss in LLH0. inv LLH0.
    assert (state' = st); subst.
    { clear -LLH0 XBB XBB1. simpl in *.
      apply XBB in LLH0.
      apply XBB1 in LLH0. desf. }
    splits; auto. red. simpls.
      by apply TERMINAL. }

  eexists. splits.
  { apply r_step. eexists. exists thread.
    apply ct_end in STEPS.
    destruct STEPS as [state'' [STEPS STEP]].
    eapply Configuration.step_normal.
    { eauto. }
    { eapply rtc_lang_tau_step_rtc_thread_tau_step.
      unfold Language.Language.step. simpls.
      apply clos_rt_rt1n. apply STEPS. }
    { apply Thread.step_program.
      constructor. simpls.
      2: by apply Local.step_silent.
      apply STEP. }
    { done. }
    red. ins. splits; eauto. }
  2: { ins; clear - QQ.
       apply NoDup_Permutation; eauto using NoDup_map_NoDupA, IdentMap.elements_3w.
       ins; rewrite !in_map_iff; split; intros ([i v] & <- & IN); ins;
         apply IdentMap.elements_complete in IN;
       destruct (positive_eq_dec i thread); desf; rewrite ?IdentMap.gss, ?IdentMap.gso in *; ins; desf.
         by eexists (_, _); split; ins; apply IdentMap.elements_correct, IdentMap.gss.
         eby eexists (_, _); split; ins; apply IdentMap.elements_correct; rewrite IdentMap.gso.
       all: eexists (_, _); split; ins; eauto using IdentMap.elements_correct.
     }
  2: done.
  2: { ins. red. destruct (classic (thread' = thread)) as [|NEQ]; subst; ins.
       rewrite IdentMap.gso in *; auto. }
  cdes COMMON. simpls.
  red. splits; red; splits; auto.
  { ins. destruct (classic (thread = tid e)); subst.
    2: by rewrite IdentMap.gso; auto.
    rewrite IdentMap.gss. eauto. }
  { ins. destruct (classic (thread' = thread)); subst.
    { rewrite IdentMap.gss in *. inv TID.
      eapply PROM_IN_MEM; eauto. }
    rewrite IdentMap.gso in *; auto.
    eapply PROM_IN_MEM; eauto. }
  simpls.
  destruct (classic (thread0 = thread)) as [|NEQ]; subst.
  { rewrite IdentMap.gss.
    eexists; eexists. splits.
    1,4: done.
    all: eauto.
    { erewrite steps_preserve_instrs; eauto. }
    { ins. left. rewrite PBOT. apply Memory.bot_get. }
    red. splits.
    { by rewrite EII. }
    eexists. red. splits; eauto. apply rt_refl. }
  apply IdentMap.Facts.in_find_iff in TP.
  rewrite IdentMap.gso in *; auto.
  destruct (IdentMap.find thread0 (Configuration.threads PC)) as [k|] eqn:AA; [|done].
  assert (IdentMap.In thread0 (Configuration.threads PC)) as BB.
  { apply IdentMap.Facts.in_find_iff. by rewrite AA. }
  apply THREADS in BB.
  destruct k.  destruct s.
  cdes BB. eexists. eexists. splits; eauto.
  { by rewrite <- AA. }
  ins. destruct (classic (thread' = thread)) as [|NN].
  { subst. rewrite IdentMap.gss in *. inv TID'.
    right. rewrite PBOT. apply Memory.bot_get. }
  rewrite IdentMap.gso in TID'; auto.
  eapply PROM_DISJOINT0; eauto.
Qed.

Lemma sim_covered_exists_terminal T S PC f_to f_from
      (FINALT : acts_set G ⊆₁ covered T)
      (SIMREL : simrel G sc PC T S f_to f_from) :
  exists PC',
    ⟪ STEPS : conf_step＊ PC PC' ⟫ /\
    ⟪ SIMREL : simrel G sc PC' T S f_to f_from ⟫ /\
    ⟪ TERMINAL : Configuration.is_terminal PC' ⟫.
Proof using All.
  assert
    (exists l,
         length (filterP (fun x => ~ thread_is_terminal (PC.(Configuration.threads)) x)
                   (map fst (IdentMap.elements PC.(Configuration.threads))))
         = l)
     as [l LL] by eauto.
  generalize dependent PC.
  induction l using (well_founded_ind lt_wf); ins; desf.
  destruct (classic (
      forall x (ELEM: In x (IdentMap.elements PC.(Configuration.threads))),
        Language.is_terminal (projT1 (fst (snd x))) (projT2 (fst (snd x))) /\
        Local.is_terminal (snd (snd x))
    )) as [Y|Y].
     eexists; splits; eauto using rt_refl.
     by repeat red; ins; apply IdentMap.elements_correct, Y in FIND; ins.
  apply not_all_ex_not in Y; destruct Y as ([i v] & Y).
  apply imply_to_and in Y; destruct Y as (FIND & Y); ins.
  assert (IN:=FIND); apply IdentMap.elements_complete in FIND.
  forward eapply sim_thread_covered_exists_terminal with (thread := i) as X; desc; eauto.
    by rewrite FINALT; unfolder; ins; desf.
  eapply H in SIMREL0; ins; desc.
    by eexists; splits; eauto; apply cr_rt; red; eauto.

  clear - STEP SAMENUM IN FIND Y TERMINAL PTERMINAL.
  assert (L: forall l, length (filterP (fun x => ~ thread_is_terminal (Configuration.threads PC') x) l)
          <= length (filterP (fun x => ~ thread_is_terminal (Configuration.threads PC) x) l)).
    clear - PTERMINAL; induction l; ins; desf; ins; eauto; try omega.
    exfalso; specialize (PTERMINAL a); tauto.
  rewrite SAMENUM.
  apply in_split_perm in IN; desc; rewrite IN in SAMENUM; ins; rewrite <- SAMENUM; ins.
  desf; ins.
  2: by destruct v as ((lang,st),lc); destruct Y; apply NNPP in n0; apply n0 in FIND; ins.
  clear Y.
  auto using le_lt_n_Sm, plus_le_compat.
Qed.

Lemma same_final_memory T S PC f_to f_from
      (FINALT : acts_set G ⊆₁ covered T)
      (SIMREL : simrel G sc PC T S f_to f_from) :
  forall l,
    final_memory_state (Configuration.memory PC) l = Some (final_memory l).
Proof using All.
  assert (etc_coherent G sc (mkETC T S)) as ETCCOH by apply SIMREL.
  assert (tc_coherent G sc T) as TCCOH by apply ETCCOH.
  ins. unfold final_memory_state.
  cdes SIMREL. cdes COMMON.
  edestruct (Memory.max_ts_spec l) as [AA _].
  { apply INHAB. }
  red in AA. desc.
  rewrite AA. simpls.
  destruct msg as [val msg|].
  2: { desc. eapply HMEM in AA. desc.
       exfalso.
       apply NOISS. eapply w_covered_issued; eauto.
       split.
       { by apply (reservedW WF ETCCOH). }
         by apply FINALT. }
  assert (val = final_memory l); [|by subst].
  desc. red in MEM.
  set (BB := AA).
  apply MEM in BB.
  destruct BB as [[BB YY]|].
  { rewrite BB in *. specialize (INHAB l).
    rewrite INHAB in AA. inv AA.
    destruct (EFM l); desc; auto.
    assert (is_init w) as II.
    2: { unfold val in VAL.
         destruct w; [|by desf].
         rewrite WF.(wf_init_lab) in VAL.
         inv VAL. }
    assert (issued T w) as WISS.
    { eapply w_covered_issued; eauto.
      split; auto. }
    assert (S w) as WS.
    { by apply ETCCOH.(etc_I_in_S). }
    destruct (classic (is_init w)) as [|NINIT]; auto.
    exfalso.
    destruct (THREAD w) as [langst TT]; auto.
    assert (IdentMap.In (tid w) (Configuration.threads PC)) as NN.
    { destruct (THREAD w); auto.
      apply IdentMap.Facts.in_find_iff.
        by rewrite H. }
    apply THREADS in NN. cdes NN.
    assert (SS := SIM_MEM).
    edestruct SS as [rel_opt]; eauto.
    simpls. desc.
    destruct (classic (f_to w = Time.bot)) as [FEQ|FNEQ].
    { rewrite FEQ in *. rewrite INMEM in INHAB.
      inv INHAB. cdes FCOH.
      apply TTOFROM in NINIT; auto.
      rewrite FEQ in NINIT. rewrite H0 in NINIT.
        by apply Time.lt_strorder in NINIT. }
    apply Memory.max_ts_spec in INMEM.
    destruct INMEM as [_ CC].
    rewrite BB in CC. apply Time.le_lteq in CC.
    destruct CC as [CC|]; [|by desf].
      by apply time_lt_bot in CC. }
  desc. edestruct (@EFM l); desc.
  { by apply NO in LOC. }
  destruct (classic (is_init w)) as [INIT|NINIT].
  { assert (f_to w = Time.bot) as BB.
    { apply FCOH. by split. }
    destruct (classic (b = w)) as [|NEQ]; subst.
    2: { edestruct WF.(wf_co_total) as [CO|CO]; eauto.
         1,2: split; [split|]; auto.
         { apply TCCOH in ISS. apply ISS. }
         { by rewrite LOC. }
         { exfalso. apply Execution_eco.no_co_to_init in CO; auto.
           2: { apply imm_s_hb.coherence_sc_per_loc. apply IMMCON. }
           apply seq_eqv_r in CO. desf. }
         exfalso. apply LAST. eauto. }
    rewrite BB in *. rewrite <- TO in *.
    rewrite INHAB in AA. inv AA.
    destruct w; simpls.
    unfold val in VAL. rewrite WF.(wf_init_lab) in VAL.
    inv VAL. }
  assert (IdentMap.In (tid w) (Configuration.threads PC)) as NN.
  { destruct (THREAD w); auto.
    apply IdentMap.Facts.in_find_iff.
      by rewrite H. }
  apply THREADS in NN. cdes NN.
  assert (SS := SIM_MEM).
  assert (issued T w) as IIW.
  { eapply w_covered_issued; eauto. split; auto. }
  edestruct SS with (b:=w) as [rel_opt]; eauto.
  simpls. desc. clear H1.
  destruct (classic (b = w)) as [|NEQ]; subst.
  { rewrite <- TO in *. rewrite INMEM in AA. inv AA. }
  edestruct WF.(wf_co_total) as [CO|CO]; eauto.
  1,2: split; [split|]; auto.
  { apply TCCOH in ISS. apply ISS. }
  { by rewrite LOC. }
  2: { exfalso. apply LAST. eauto. }
  assert (S b) as BS.
  { by apply ETCCOH.(etc_I_in_S). }
  assert (S w) as WS.
  { by apply ETCCOH.(etc_I_in_S). }
  eapply f_to_co_mon with (I:=S) in CO; eauto.
  apply Memory.max_ts_spec in INMEM.
  destruct INMEM as [_ CC].
  rewrite <- TO in CC.
  exfalso. eapply Time.lt_strorder.
  eapply TimeFacts.lt_le_lt; eauto.
Qed.

Lemma sim_step PC T S T' S' f_to f_from
      (STEP : ext_sim_trav_step G sc (mkETC T S) (mkETC T' S'))
      (SIMREL : simrel G sc PC T S f_to f_from) :
    exists PC' f_to' f_from',
      ⟪ PSTEP : (conf_step)^? PC PC' ⟫ /\
      ⟪ SIMREL : simrel G sc PC' T' S' f_to' f_from' ⟫.
Proof using All.
  destruct STEP as [thread STEP].
  cdes SIMREL. cdes COMMON.
  eapply plain_sim_step in STEP; eauto.
  2: { split; eauto. apply THREADS.
       assert (exists e, thread = tid e /\ acts_set G e /\ ~ is_init e) as [e].
       { apply ext_sim_trav_step_to_step in STEP.
         desc. exists e.
         assert (acts_set G e) as EE.
         { eapply ext_itrav_stepE; eauto. }
         splits; auto.
         eapply ext_itrav_step_ninit; eauto. }
       cdes COMMON. subst.
       destruct (THREAD e); auto.
       apply IdentMap.Facts.in_find_iff.
         by rewrite H. }
  desf. exists PC'. exists f_to'. exists f_from'. splits.
  2: { apply SIMREL0; eauto. }

  apply rtE in PSTEP.
  destruct PSTEP as [[HH]|PSTEP]; subst.
  { by constructor. }
  apply plain_step_ct_in_plain_step in PSTEP.
  right.
  red. exists MachineEvent.silent. exists thread.
  destruct PSTEP. econstructor; eauto.
  red; simpls. ins. right.

  edestruct cert_graph_init as [G' [sc'' [T'' [S'' HH]]]]; eauto.
  desc.

  set (PC := (Configuration.mk (IdentMap.add
                                  tid (existT _ lang st3, lc3)
                                  (Configuration.threads c1))
                               sc1 mem1)).

  edestruct (@cert_simulation G' sc'' tid PC T'' S'' f_to' f_from') as [T''' HH].
  all: try by desf; eauto.
  { unfold PC. eapply simrel_thread_bigger_sc_memory; eauto.
    { rewrite IdentMap.gss; eauto. }
    { eapply inhabited_le.
      { apply CAP. }
      apply SIMREL_THREAD. }
    { eapply Memory.cap_closed; eauto. apply SIMREL_THREAD. }
    { apply CAP. }
      by apply Memory.max_full_timemap_closed. }
  desc.

  assert
    (exists langst local,
        ⟪ THREAD :
            Basic.IdentMap.find tid PC'.(Configuration.threads) =
            Some (langst, local)
        ⟫ /\
        ⟪ EMPTY : Local.promises local = Memory.bot ⟫)
    as HH.
  { cdes SIMREL2. cdes LOCAL.
    exists (existT _ (thread_lts tid) state). exists local.
    splits; auto.
    red in SIM_PROM. apply Memory.ext.
    ins. rewrite Memory.bot_get.
    destruct (Memory.get loc ts (Local.promises local)) eqn: HH; auto.
    exfalso.
    destruct p as [from msg]. destruct msg.
    { eapply SIM_PROM in HH; eauto.
      desc. apply NCOV. by apply FINALT. }
    eapply SIM_RPROM in HH; eauto.
    desc.
    apply NOISS. eapply w_covered_issued.
    { apply COMMON0. }
    split.
    { eapply reservedW; auto.
      { apply COMMON0. }
      done. }
    apply FINALT. eapply etc_S_in_E.
    { apply COMMON0. }
    done. }

  desc.
  destruct langst as [lang' state'].
  assert (lang' = lang); subst.
  { symmetry.
    eapply conf_steps_preserve_lang; eauto.
    unfold PC.
    simpls. rewrite IdentMap.gss. eauto. }
  eapply conf_steps_to_thread_steps in PSTEP; eauto.
  2: { unfold PC. simpls. rewrite IdentMap.gss. eauto. }
  eexists. splits.
  { apply PSTEP. }
  simpls.
Qed.

Lemma sim_steps PC TS TS' f_to f_from
      (TCSTEPS : (ext_sim_trav_step G sc)⁺ TS TS')
      (SIMREL  : simrel G sc PC (etc_TC TS) (reserved TS) f_to f_from) :
    exists PC' f_to' f_from',
      ⟪ PSTEP : conf_step＊ PC PC' ⟫ /\
      ⟪ SIMREL : simrel G sc PC' (etc_TC TS') (reserved TS') f_to' f_from' ⟫.
Proof using All.
  generalize dependent f_from.
  generalize dependent f_to.
  generalize dependent PC.
  induction TCSTEPS.
  { ins. desf.
    destruct x as [T S].
    destruct y as [T' S'].
    eapply sim_step in H; eauto. desf.
    do 3 eexists. splits; eauto. by eapply inclusion_r_rt; eauto. }
  ins.
  eapply IHTCSTEPS1 in SIMREL.
  desc.
  eapply IHTCSTEPS2 in SIMREL0.
  desf. eexists. eexists. eexists. splits.
  2: eauto.
  eapply rt_trans; eauto.
Qed.

Lemma simulation :
  exists T S PC f_to f_from,
    ⟪ FINALT : G.(acts_set) ⊆₁ covered T ⟫ /\
    ⟪ PSTEP  : conf_step＊ (conf_init prog) PC ⟫ /\
    ⟪ SIMREL : simrel G sc PC T S f_to f_from ⟫.
Proof using All.
  generalize (sim_traversal WF IMMCON); ins; desc.
  destruct T as [T S].
  exists T, S. apply rtE in H.
  destruct H as [H|H].
  { red in H. desf.
    eexists. eexists. eexists.
    splits; auto.
    { apply rtE. left. red. eauto. }
    unfold ext_init_trav in *. inv H.
    apply simrel_init. }
  eapply sim_steps in H.
  2: by apply simrel_init.
  desf.
  eexists. eexists. eexists.
  splits; eauto.
Qed.

Theorem promise2imm : promise_allows prog final_memory.
Proof using All.
  red.
  destruct simulation as [T [PC H]]. desc.
  edestruct sim_covered_exists_terminal as [PC']; eauto.
  desc.
  exists PC'. splits; eauto.
  { eapply rt_trans; eauto. }
  eapply same_final_memory; eauto.
Qed.

End PromiseToIMM.


From iris.algebra Require Import
  proofmode_classes.

From caml5 Require Import
  prelude.
From caml5.algebra Require Export
  base.
From caml5.algebra Require Import
  Z_max
  lib.auth_option.

Implicit Types n m p : Z.

Definition auth_Z_max :=
  auth_option Z_max_R.
Definition auth_Z_max_R :=
  auth_option_R Z_max_R.
Definition auth_Z_max_UR :=
  auth_option_UR Z_max_R.

Definition auth_Z_max_auth dq n : auth_Z_max_UR :=
  ●O{dq} Build_Z_max n ⋅ ◯O Build_Z_max n.
Definition auth_Z_max_frag n : auth_Z_max_UR :=
  ◯O Build_Z_max n.

#[global] Instance auth_Z_max_cmra_discrete :
  CmraDiscrete auth_Z_max_R.
Proof.
  apply _.
Qed.

#[global] Instance auth_Z_max_auth_core_id n :
  CoreId (auth_Z_max_auth DfracDiscarded n).
Proof.
  apply _.
Qed.
#[global] Instance auth_Z_max_frag_core_id n :
  CoreId (auth_Z_max_frag n).
Proof.
  apply _.
Qed.

Lemma auth_Z_max_auth_dfrac_op dq1 dq2 n :
  auth_Z_max_auth (dq1 ⋅ dq2) n ≡ auth_Z_max_auth dq1 n ⋅ auth_Z_max_auth dq2 n.
Proof.
  rewrite /auth_Z_max_auth auth_option_auth_dfrac_op.
  rewrite (comm _ (●O{dq2} _)) -!assoc (assoc _ (◯O _)) -core_id_dup (comm _ (◯O _)) //.
Qed.
#[global] Instance auth_Z_max_auth_dfrac_is_op dq dq1 dq2 n :
  IsOp dq dq1 dq2 →
  IsOp' (auth_Z_max_auth dq n) (auth_Z_max_auth dq1 n) (auth_Z_max_auth dq2 n).
Proof.
  rewrite /IsOp' /IsOp => ->. rewrite auth_Z_max_auth_dfrac_op //.
Qed.

Lemma auth_Z_max_frag_op n1 n2 :
  auth_Z_max_frag (n1 `max` n2) = auth_Z_max_frag n1 ⋅ auth_Z_max_frag n2.
Proof.
  rewrite -auth_option_frag_op Z_max_op_eq //.
Qed.
#[global] Instance auth_Z_max_frag_is_op n n1 n2 :
  IsOp (Build_Z_max n) (Build_Z_max n1) (Build_Z_max n2) →
  IsOp' (auth_Z_max_frag n) (auth_Z_max_frag n1) (auth_Z_max_frag n2).
Proof.
  rewrite /IsOp' /IsOp /auth_Z_max_frag => -> //.
Qed.

Lemma auth_Z_max_auth_frag_op dq n :
  auth_Z_max_auth dq n ≡ auth_Z_max_auth dq n ⋅ auth_Z_max_frag n.
Proof.
  rewrite -!assoc -auth_option_frag_op -core_id_dup //.
Qed.

Lemma auth_Z_max_frag_op_le n n' :
  (n' ≤ n)%Z →
  auth_Z_max_frag n = auth_Z_max_frag n' ⋅ auth_Z_max_frag n.
Proof.
  intros. rewrite -auth_Z_max_frag_op Z.max_r //.
Qed.

Lemma auth_Z_max_auth_dfrac_valid dq n :
  ✓ auth_Z_max_auth dq n ↔
  ✓ dq.
Proof.
  rewrite auth_option_both_dfrac_valid_discrete /=. naive_solver.
Qed.
Lemma auth_Z_max_auth_valid n :
  ✓ auth_Z_max_auth (DfracOwn 1) n.
Proof.
  rewrite auth_Z_max_auth_dfrac_valid //.
Qed.

Lemma auth_Z_max_auth_dfrac_op_valid dq1 n1 dq2 n2 :
  ✓ (auth_Z_max_auth dq1 n1 ⋅ auth_Z_max_auth dq2 n2) ↔
  ✓ (dq1 ⋅ dq2) ∧ n1 = n2.
Proof.
  rewrite /auth_Z_max_auth (comm _ (●O{dq2} _)) -!assoc (assoc _ (◯O _)).
  rewrite -auth_option_frag_op (comm _ (◯O _)) assoc. split.
  - move => /cmra_valid_op_l /auth_option_auth_dfrac_op_valid. naive_solver.
  - intros [? ->]. rewrite -core_id_dup -auth_option_auth_dfrac_op.
    apply auth_option_both_dfrac_valid_discrete. naive_solver.
Qed.
Lemma auth_Z_max_auth_op_valid n1 n2 :
  ✓ (auth_Z_max_auth (DfracOwn 1) n1 ⋅ auth_Z_max_auth (DfracOwn 1) n2) ↔
  False.
Proof.
  rewrite auth_Z_max_auth_dfrac_op_valid. naive_solver.
Qed.

Lemma auth_Z_max_both_dfrac_valid dq n m :
  ✓ (auth_Z_max_auth dq n ⋅ auth_Z_max_frag m) ↔
  ✓ dq ∧ (m ≤ n)%Z.
Proof.
  rewrite -assoc -auth_option_frag_op auth_option_both_dfrac_valid_discrete.
  rewrite Z_max_included Z_max_op_eq /=. naive_solver lia.
Qed.
Lemma auth_Z_max_both_valid n m :
  ✓ (auth_Z_max_auth (DfracOwn 1) n ⋅ auth_Z_max_frag m) ↔
  (m ≤ n)%Z.
Proof.
  rewrite auth_Z_max_both_dfrac_valid dfrac_valid_own. naive_solver.
Qed.

Lemma auth_Z_max_frag_mono n1 n2 :
  (n1 ≤ n2)%Z →
  auth_Z_max_frag n1 ≼ auth_Z_max_frag n2.
Proof.
  intros. apply auth_option_frag_mono, Z_max_included. done.
Qed.

Lemma auth_Z_max_included dq n :
  auth_Z_max_frag n ≼ auth_Z_max_auth dq n.
Proof.
  apply cmra_included_r.
Qed.

Lemma auth_Z_max_auth_persist dq n :
  auth_Z_max_auth dq n ~~> auth_Z_max_auth DfracDiscarded n.
Proof.
  eapply cmra_update_op_proper; last done.
  eapply auth_option_auth_persist.
Qed.
Lemma auth_Z_max_auth_update {n} n' :
  (n ≤ n')%Z →
  auth_Z_max_auth (DfracOwn 1) n ~~> auth_Z_max_auth (DfracOwn 1) n'.
Proof.
  intros. apply auth_option_both_update, Z_max_local_update. done.
Qed.

#[global] Opaque auth_Z_max_auth.
#[global] Opaque auth_Z_max_frag.


Require Import Rupicola.Lib.Api.
Require Import Ensembles.

Module ND.
  Definition M A := A -> Prop.

  Ltac s :=
    apply Extensionality_Ensembles; unfold Same_set, Included, In;
    firstorder congruence.

  Global Program Instance MonadM : Monad M :=
    {| mret {A} (a: A) := fun a' => a' = a;
       mbind {A B} (ma: M A) (k: A -> M B) :=
         fun b => exists a, ma a /\ k a b |}.
  Obligation 1. Proof. s. Qed.
  Obligation 2. Proof. s. Qed.
  Obligation 3. Proof. s. Qed.

  Definition pick {A} (P: A -> Prop) : M A := P.
End ND.

Import ND.

Notation "'let/+' x 'as' nm := val 'in' body" :=
  (mbindn [nm] val (fun x => body))
    (at level 200, x name, body at level 200,
     format "'[hv' 'let/+'  x  'as'  nm  :=  val  'in' '//' body ']'").

Notation "'let/+' x := val 'in' body" :=
  (mbindn [IdentParsing.TC.ident_to_string x] val (fun x => body))
    (at level 200, x name, body at level 200,
     only parsing).

Notation "%{ x | P }" :=
  (pick (fun x => P))
    (at level 0, x pattern at level 99).

Notation "%{ x : A | P }" :=
  (pick (A := A) (fun x => P))
    (at level 0, x pattern at level 99).

Definition ndbind {A} (c: M A) (pred: A -> Prop) :=
  exists a, c a /\ pred a.

Notation ndspec := ndbind.

Lemma ndbind_bindn {A B} pred vars (c: M A) a (k : A -> M B):
  c a ->
  ndbind (k a) pred ->
  ndbind (mbindn vars c k) pred.
Proof. unfold ndspec, mbindn, mbind. simpl. firstorder idtac. Qed.

Section with_parameters.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  Definition ndspec_k {A} (pred: A -> predicate) (c: M A) : predicate :=
    fun tr mem locals => ndspec c (fun a => pred a tr mem locals).

  Lemma WeakestPrecondition_ndspec_k_bindn {A B} funcs prog t m l post
        vars (c: M A) a (k: A -> M B) :
    c a ->
    WeakestPrecondition.program funcs prog t m l (ndspec_k post (k a)) ->
    WeakestPrecondition.program funcs prog t m l (ndspec_k post (mbindn vars c k)).
  Proof.
    unfold ndspec_k; intros.
    eapply WeakestPrecondition_weaken; [ | eauto].
    eauto using ndbind_bindn.
  Qed.

  Lemma compile_setup_ndspec_k : forall {tr mem locals functions},
    forall {A} {pred: A -> _ -> predicate}
      {spec: M A} {cmd}
      retvars,

      (let pred a := wp_bind_retvars retvars (pred a) in
       <{ Trace := tr;
          Memory := mem;
          Locals := locals;
          Functions := functions }>
       cmd
       <{ ndspec_k pred spec }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd
      <{ (fun spec =>
            wp_bind_retvars
              retvars
              (fun rets tr' mem' locals' =>
                 ndspec spec (fun a => pred a rets tr' mem' locals')))
           spec }>.
  Proof.
    intros; unfold ndbind, wp_bind_retvars in *.
    use_hyp_with_matching_cmd; cbv beta in *.
    clear - H0; firstorder.
  Qed.
End with_parameters.

#[export] Hint Resolve compile_setup_ndspec_k : compiler_setup_post.
#[export] Hint Unfold ndspec_k ndspec ndbind: compiler_cleanup_post.
#[export] Hint Extern 1 (mret _ _) => reflexivity : compiler_side_conditions.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of VM: UCtxtIntro                               *)
(*                                                                     *)
(*          Provide the abstraction of user contex                     *)
(*                                                                     *)
(*          Haozhong Zhang <haozhong.zhang@yale.edu>                   *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file defines the abstract data and the primitives for the UCtxtIntro layer,
which will introduce the primtives of thread*)
Require Import Coqlib.
Require Import Maps.
Require Import ASTExtra.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Stacklayout.
Require Import Globalenvs.
Require Import AsmX.
Require Import Smallstep.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import FlatMemory.
Require Import CommonTactic.
Require Import AuxLemma.
Require Import RealParams.
Require Import PrimSemantics.
Require Import LAsm.
Require Import LoadStoreSem2.
Require Import XOmega.

Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.

Require Import CalRealPTPool.
Require Import CalRealPT.
Require Import CalRealIDPDE.
Require Import CalRealInitPTE.
Require Import CalRealSMSPool.
Require Import CalRealProcModule.

Require Import INVLemmaMemory.
Require Import INVLemmaThread.
Require Import INVLemmaProc.

Require Import AbstractDataType.
Require Export PIPC.
Require Export PUCtxtIntroDef.

(** * Abstract Data and Primitives at this layer*)
Section WITHMEM.

  Local Open Scope Z_scope.

  Context `{real_params: RealParams}.

  (** **Definition of the raw data at MPTBit layer*)
  (*Record RData :=
    mkRData {
        HP: flatmem; (**r we model the memory from 1G to 3G as heap*)
        ti: trapinfo; (**r abstract of CR2, stores the address where page fault happens*)
        pe: bool; (**r abstract of CR0, indicates whether the paging is enabled or not*)
        ikern: bool; (**r pure logic flag, shows whether it's in kernel mode or not*)
        ihost: bool; (**r logic flag, shows whether it's in the host mode or not*)
        AT: ATable; (**r allocation table*)
        nps: Z; (**r number of the pages*)

        PT: Z; (**r the current page table index*)
        ptpool: PTPool; (**r page table pool*)
        ipt: bool; (**r pure logic flag, shows whether it's using the kernel's page table*)
        pb : PTBitMap; (**r [page table bit map], indicating which page table has been used*)

        kctxt: KContextPool; (**r kernel context pool*)
        abtcb: AbTCBPool; (**r thread control blocks pool*)
        abq: AbQueuePool; (**r thread queue pool*)
        cid: Z; (**r current thread id*)

        chpool : ChanPool; (**r the channel pool for IPC*)
        uctxt : UContextPool (**r user context pool*)
      }.*)

  Context `{Hstencil: Stencil}.
  Context `{Hmem: Mem.MemoryModel}.
  Context `{Hmwd: UseMemWithData mem}.

  (** * Proofs that the primitives satisfies the invariants at this layer *)
  Section INV.

    Global Instance uctx_set_inv: PreservesInvariants uctx_set_spec.
    Proof.
      preserves_invariants_simpl low_level_invariant high_level_invariant; eauto 2.
      eapply uctxt_inject_neutral_gss; eauto.
      eapply uctxt_inject_neutral0_gss; eauto.
      eapply uctxt_inject_neutral0_Vint.
    Qed.

    Global Instance uctx_set_eip_inv: UCTXSetEIPInvariants uctx_set_eip_spec.
    Proof.
      constructor; intros.
      - (* low level inv *)
        inv H1. functional inversion H; inv H.
        constructor; trivial.
        eapply uctxt_inject_neutral_gss; eauto.
        eapply uctxt_inject_neutral0_gss; eauto.
        eapply uctxt_inject_neutral0_Vptr_flat; eauto.
      - (* high level inv *)
        inv H0. functional inversion H; inv H.
        constructor; trivial.
      - (* kernel mode *)
        functional inversion H; inv H.
        constructor; trivial.
    Qed.

    Global Instance save_uctx_inv: SaveUCtxInvariants save_uctx_spec.
    Proof.
      constructor; intros.
      - (* low level inv *)
        inv H0. functional inversion H; inv H.
        constructor; trivial.
        eapply uctxt_inject_neutral_gss; eauto.
        repeat eapply uctxt_inject_neutral0_gss;
          try eapply uctxt_inject_neutral0_Vint.
        apply uctxt_inject_neutral0_init; eauto.
      - (* high level inv *)
        inv H0. functional inversion H; inv H.
        constructor; trivial.
      - (* kernel mode *)
        functional inversion H; inv H.
        constructor; trivial.
    Qed.

    Global Instance restore_uctx_inv: RestoreUCtxInvariants restore_uctx_spec.
    Proof.
      constructor; intros.
      - (* low level inv *)
        inv H0. functional inversion H; inv H.
        constructor; trivial.
      - (* high level inv *)
        inv H0. functional inversion H; inv H.
        subst. constructor; auto; simpl in *; intros; try congruence.
    Qed.

  End INV.

  (** * Layer Definition *)
  Definition puctxtintro_fresh_c : compatlayer (cdata RData) :=
    uctx_get ↦ gensem uctx_get_spec
             ⊕ uctx_set ↦ gensem uctx_set_spec
             ⊕ uctx_set_eip ↦ uctx_set_eip_compatsem uctx_set_eip_spec
             ⊕ save_uctx ↦ save_uctx_compatsem save_uctx_spec.

  Definition puctxtintro_fresh_asm : compatlayer (cdata RData) :=
    restore_uctx ↦ primcall_restoreuctx_compatsem restore_uctx_spec cid
                 ⊕ elf_load ↦ elf_load_compatsem.

  Definition puctxtintro_passthrough : compatlayer (cdata RData) :=
    fload ↦ gensem fload_spec
          ⊕ fstore ↦ gensem fstore_spec
          ⊕ vmxinfo_get ↦ gensem vmxinfo_get_spec
          ⊕ device_output ↦ gensem device_output_spec
          ⊕ pfree ↦ gensem pfree_spec
          ⊕ set_pt ↦ gensem setPT_spec
          ⊕ pt_read ↦ gensem ptRead_spec
          ⊕ pt_resv ↦ gensem ptResv_spec
          ⊕ shared_mem_status ↦ gensem shared_mem_status_spec
          ⊕ offer_shared_mem ↦ gensem offer_shared_mem_spec

          ⊕ get_curid ↦ gensem get_curid_spec
          ⊕ thread_spawn ↦ dnew_compatsem thread_spawn_spec
          ⊕ thread_wakeup ↦ gensem thread_wakeup_spec
          (*⊕ is_chan_ready ↦ gensem is_chan_ready_spec
          ⊕ sendto_chan ↦ gensem sendto_chan_spec
          ⊕ receive_chan ↦ gensem receive_chan_spec*)
          ⊕ syncreceive_chan ↦ gensem syncreceive_chan_spec
          ⊕ syncsendto_chan_pre ↦ gensem syncsendto_chan_pre_spec
          ⊕ syncsendto_chan_post ↦ gensem syncsendto_chan_post_spec

          ⊕ proc_init ↦ gensem proc_init_spec

          ⊕ pt_in ↦ primcall_general_compatsem' ptin_spec (prim_ident:= pt_in)
          ⊕ pt_out ↦ primcall_general_compatsem' ptout_spec (prim_ident:= pt_out)
          ⊕ container_get_nchildren ↦ gensem container_get_nchildren_spec
          ⊕ container_get_quota ↦ gensem container_get_quota_spec
          ⊕ container_get_usage ↦ gensem container_get_usage_spec
          ⊕ container_can_consume ↦ gensem container_can_consume_spec
          ⊕ container_alloc ↦ gensem alloc_spec
          ⊕ trap_in ↦ primcall_general_compatsem trapin_spec
          ⊕ host_in ↦ primcall_general_compatsem hostin_spec
          ⊕ host_out ↦ primcall_general_compatsem hostout_spec
          ⊕ trap_get ↦ primcall_trap_info_get_compatsem trap_info_get_spec
          ⊕ trap_set ↦ primcall_trap_info_ret_compatsem trap_info_ret_spec

          ⊕ thread_yield ↦ primcall_thread_schedule_compatsem thread_yield_spec (prim_ident:= thread_yield)
          ⊕ thread_sleep ↦ primcall_thread_transfer_compatsem thread_sleep_spec

          ⊕ accessors ↦ {| exec_load := (@exec_loadex _ _ Hmwd);
                           exec_store := (@exec_storeex _ _ Hmwd) |}.

  Definition puctxtintro : compatlayer (cdata RData) :=
    (puctxtintro_fresh_c ⊕ puctxtintro_fresh_asm) ⊕ puctxtintro_passthrough.

(*Definition puctxtintro_impl : compatlayer (cdata RData) :=
    thread_spawn ↦ dnew_compatsem (dnew := thread_spawn_spec)
      ⊕ uctx_set ↦ gensem uctx_set_spec
      ⊕ uctx_set_eip ↦ uctx_set_eip_compatsem
      ⊕ elf_load ↦ elf_load_compatsem.
  Definition puctxtintro_rest : compatlayer (cdata RData) :=
    uctx_get ↦ gensem uctx_get_spec
      ⊕ save_uctx ↦ save_uctx_compatsem
      ⊕ restore_uctx ↦ primcall_restoreuctx_compatsem
      ⊕ palloc ↦ gensem palloc_spec
      ⊕ pfree ↦ gensem pfree_spec
      ⊕ set_pt ↦ gensem setPT_spec
      ⊕ pt_read ↦ gensem ptRead_spec
      ⊕ pt_resv ↦ gensem ptResv_spec
      ⊕ pt_in ↦ primcall_general_compatsem' (prim_generic:= ptin_spec) (prim_ident:= pt_in)
      ⊕ pt_out ↦ primcall_general_compatsem' (prim_generic:= ptout_spec) (prim_ident:= pt_out)
      ⊕ trap_in ↦ primcall_general_compatsem (prim_generic:= trapin_spec)
      ⊕ host_in ↦ primcall_general_compatsem (prim_generic:= hostin_spec)
      ⊕ host_out ↦ primcall_general_compatsem (prim_generic:= hostout_spec)
      ⊕ trap_get ↦ primcall_trap_info_get_compatsem (trap_info_get:= trap_info_get_spec)
      ⊕ trap_set ↦ primcall_trap_info_ret_compatsem (trap_info_ret:= trap_info_ret_spec)
      ⊕ get_curid ↦ gensem get_curid_spec
      ⊕ thread_kill ↦ gensem thread_kill_spec
      ⊕ thread_wakeup ↦ gensem thread_wakeup_spec
      ⊕ thread_yield ↦ primcall_thread_schedule_compatsem (thread_schedule:= thread_yield_spec) (prim_ident:= thread_yield)
      ⊕ thread_sleep ↦ primcall_thread_transfer_compatsem (thread_transfer:= thread_sleep_spec)
      ⊕ is_chan_ready ↦ gensem is_chan_ready_spec
      ⊕ sendto_chan ↦ gensem sendto_chan_spec
      ⊕ receive_chan ↦ gensem receive_chan_spec
      ⊕ proc_init ↦ gensem proc_init_spec
      ⊕ accessors ↦ {| exec_load := @exec_loadex; exec_store := @exec_storeex |}.

  Lemma puctxtintro_impl_eq : puctxtintro ≡ puctxtintro_impl ⊕ puctxtintro_rest.
  Proof. reflexivity. Qed.

  Definition semantics := LAsm.Lsemantics puctxtintro.*)

End WITHMEM.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** * Abstract domain (context-sen) *)

Set Implicit Arguments.

Require Import UserProofType.
Require DomCon.
Require Import SemCommon.

Module Make (Import PInput : PINPUT).

Local Open Scope type.

Definition index_t : Type := InterNode.t * mem_pos * list InterNode.t.

Definition state_t : Type := index_t -> Mem.t.

Definition node_of_index (idx : index_t) : InterNode.t := fst (fst idx).

Definition pos_of_index (idx : index_t) : mem_pos := snd (fst idx).

Definition call_nodes_of_index (idx : index_t) : list InterNode.t := snd idx.

Section Wf.

Variable pgm : InterCfg.t.

Definition wf_call (calln : InterNode.t) : Prop :=
  exists retn, Some retn = InterCfg.returnof pgm calln.

Definition wf_calls (calls : list InterNode.t) : Prop :=
  List.Forall wf_call calls.

Definition wf_index (idx : index_t) : Prop :=
  wf_calls (call_nodes_of_index idx).

Definition wf_state (s : state_t) : Prop :=
  forall idx (Hidx : not (wf_index idx)), Mem.eq (s idx) Mem.bot.

End Wf.

Local Close Scope type.

End Make.


Require Coq.Structures.Equalities.
Require Coq.FSets.FSetAVL.
Require Coq.FSets.FSetWeakList.
Require Coq.FSets.FMapFacts.

Require Genevan.ProtoIdentifier.
Require Genevan.ProtoName.
Require Genevan.ProtoPeer.Peer.
Require Genevan.ProtoPeer.Collection.

Record t := {
  supports : ProtoIdentifier.t
}.

Module ClientHandlerPeer : Peer.T with Definition t := t.
  Definition t        := t.
  Definition eq       := @Logic.eq t.
  Definition eq_refl  := @Logic.eq_refl t.
  Definition eq_sym   := @Logic.eq_sym t.
  Definition eq_trans := @Logic.eq_trans t.

  #[local]
  Instance eq_equiv : RelationClasses.Equivalence eq := { }.

  Theorem eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
  Proof.
    intros x y.
    destruct x as [xi].
    destruct y as [yi].
    destruct (ProtoIdentifier.Dec.eq_dec xi yi) as [HL|HR]. {
      left; rewrite HL; reflexivity.
    } {
      right.
      intro H_contra.
      assert (xi = yi) by congruence.
      contradiction.
    }
  Qed.

  Definition supports (c : t) : ProtoIdentifier.t := supports c.
End ClientHandlerPeer.

Module Sets : FSetInterface.WS
  with Definition E.t  := t
  with Definition E.eq := ClientHandlerPeer.eq
:= FSetWeakList.Make ClientHandlerPeer.

Module ClientHandlerCollection :=
  ProtoPeer.Collection.Make ClientHandlerPeer Sets.


From iris.proofmode Require Import coq_tactics reduction.
From iris.proofmode Require Export tactics.
From iris.program_logic Require Import atomic.
From iris.heap_lang Require Export tactics derived_laws.
From iris.heap_lang Require Import notation.
From iris Require Import options.
Import uPred.

Lemma tac_wp_expr_eval `{!heapG Σ} Δ s E Φ e e' :
  (∀ (e'':=e'), e = e'') →
  envs_entails Δ (WP e' @ s; E {{ Φ }}) → envs_entails Δ (WP e @ s; E {{ Φ }}).
Proof. by intros ->. Qed.
Lemma tac_twp_expr_eval `{!heapG Σ} Δ s E Φ e e' :
  (∀ (e'':=e'), e = e'') →
  envs_entails Δ (WP e' @ s; E [{ Φ }]) → envs_entails Δ (WP e @ s; E [{ Φ }]).
Proof. by intros ->. Qed.

Tactic Notation "wp_expr_eval" tactic3(t) :=
  iStartProof;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    eapply tac_wp_expr_eval;
      [let x := fresh in intros x; t; unfold x; reflexivity|]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    eapply tac_twp_expr_eval;
      [let x := fresh in intros x; t; unfold x; reflexivity|]
  | _ => fail "wp_expr_eval: not a 'wp'"
  end.

Lemma tac_wp_pure `{!heapG Σ} Δ Δ' s E K e1 e2 φ n Φ :
  PureExec φ n e1 e2 →
  φ →
  MaybeIntoLaterNEnvs n Δ Δ' →
  envs_entails Δ' (WP (fill K e2) @ s; E {{ Φ }}) →
  envs_entails Δ (WP (fill K e1) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ??? HΔ'. rewrite into_laterN_env_sound /=.
  rewrite HΔ' -lifting.wp_pure_step_later //.
Qed.
Lemma tac_twp_pure `{!heapG Σ} Δ s E K e1 e2 φ n Φ :
  PureExec φ n e1 e2 →
  φ →
  envs_entails Δ (WP (fill K e2) @ s; E [{ Φ }]) →
  envs_entails Δ (WP (fill K e1) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=> ?? ->. rewrite -total_lifting.twp_pure_step //.
Qed.

Lemma tac_wp_value `{!heapG Σ} Δ s E Φ v :
  envs_entails Δ (Φ v) → envs_entails Δ (WP (Val v) @ s; E {{ Φ }}).
Proof. rewrite envs_entails_eq=> ->. by apply wp_value. Qed.
Lemma tac_twp_value `{!heapG Σ} Δ s E Φ v :
  envs_entails Δ (Φ v) → envs_entails Δ (WP (Val v) @ s; E [{ Φ }]).
Proof. rewrite envs_entails_eq=> ->. by apply twp_value. Qed.

Ltac wp_expr_simpl := wp_expr_eval simpl.

Ltac wp_value_head :=
  first [eapply tac_wp_value || eapply tac_twp_value].

Ltac wp_finish :=
  wp_expr_simpl;      (* simplify occurences of subst/fill *)
  try wp_value_head;  (* in case we have reached a value, get rid of the WP *)
  pm_prettify.        (* prettify ▷s caused by [MaybeIntoLaterNEnvs] and
                         λs caused by wp_value *)

Ltac solve_vals_compare_safe :=
  (* The first branch is for when we have [vals_compare_safe] in the context.
     The other two branches are for when either one of the branches reduces to
     [True] or we have it in the context. *)
  fast_done || (left; fast_done) || (right; fast_done).

(** The argument [efoc] can be used to specify the construct that should be
reduced. For example, you can write [wp_pure (EIf _ _ _)], which will search
for an [EIf _ _ _] in the expression, and reduce it.

The use of [open_constr] in this tactic is essential. It will convert all holes
(i.e. [_]s) into evars, that later get unified when an occurences is found
(see [unify e' efoc] in the code below). *)
Tactic Notation "wp_pure" open_constr(efoc) :=
  iStartProof;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    let e := eval simpl in e in
    reshape_expr e ltac:(fun K e' =>
      unify e' efoc;
      eapply (tac_wp_pure _ _ _ _ K e');
      [iSolveTC                       (* PureExec *)
      |try solve_vals_compare_safe    (* The pure condition for PureExec -- handles trivial goals, including [vals_compare_safe] *)
      |iSolveTC                       (* IntoLaters *)
      |wp_finish                      (* new goal *)
      ])
    || fail "wp_pure: cannot find" efoc "in" e "or" efoc "is not a redex"
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    let e := eval simpl in e in
    reshape_expr e ltac:(fun K e' =>
      unify e' efoc;
      eapply (tac_twp_pure _ _ _ K e');
      [iSolveTC                       (* PureExec *)
      |try solve_vals_compare_safe    (* The pure condition for PureExec *)
      |wp_finish                      (* new goal *)
      ])
    || fail "wp_pure: cannot find" efoc "in" e "or" efoc "is not a redex"
  | _ => fail "wp_pure: not a 'wp'"
  end.

(* TODO: do this in one go, without [repeat]. *)
Ltac wp_pures :=
  iStartProof;
  repeat (wp_pure _; []). (* The `;[]` makes sure that no side-condition
                             magically spawns. *)

(** Unlike [wp_pures], the tactics [wp_rec] and [wp_lam] should also reduce
lambdas/recs that are hidden behind a definition, i.e. they should use
[AsRecV_recv] as a proper instance instead of a [Hint Extern].

We achieve this by putting [AsRecV_recv] in the current environment so that it
can be used as an instance by the typeclass resolution system. We then perform
the reduction, and finally we clear this new hypothesis. *)
Tactic Notation "wp_rec" :=
  let H := fresh in
  assert (H := AsRecV_recv);
  wp_pure (App _ _);
  clear H.

Tactic Notation "wp_if" := wp_pure (If _ _ _).
Tactic Notation "wp_if_true" := wp_pure (If (LitV (LitBool true)) _ _).
Tactic Notation "wp_if_false" := wp_pure (If (LitV (LitBool false)) _ _).
Tactic Notation "wp_unop" := wp_pure (UnOp _ _).
Tactic Notation "wp_binop" := wp_pure (BinOp _ _ _).
Tactic Notation "wp_op" := wp_unop || wp_binop.
Tactic Notation "wp_lam" := wp_rec.
Tactic Notation "wp_let" := wp_pure (Rec BAnon (BNamed _) _); wp_lam.
Tactic Notation "wp_seq" := wp_pure (Rec BAnon BAnon _); wp_lam.
Tactic Notation "wp_proj" := wp_pure (Fst _) || wp_pure (Snd _).
Tactic Notation "wp_case" := wp_pure (Case _ _ _).
Tactic Notation "wp_match" := wp_case; wp_pure (Rec _ _ _); wp_lam.
Tactic Notation "wp_inj" := wp_pure (InjL _) || wp_pure (InjR _).
Tactic Notation "wp_pair" := wp_pure (Pair _ _).
Tactic Notation "wp_closure" := wp_pure (Rec _ _ _).

Lemma tac_wp_bind `{!heapG Σ} K Δ s E Φ e f :
  f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
  envs_entails Δ (WP e @ s; E {{ v, WP f (Val v) @ s; E {{ Φ }} }})%I →
  envs_entails Δ (WP fill K e @ s; E {{ Φ }}).
Proof. rewrite envs_entails_eq=> -> ->. by apply: wp_bind. Qed.
Lemma tac_twp_bind `{!heapG Σ} K Δ s E Φ e f :
  f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
  envs_entails Δ (WP e @ s; E [{ v, WP f (Val v) @ s; E [{ Φ }] }])%I →
  envs_entails Δ (WP fill K e @ s; E [{ Φ }]).
Proof. rewrite envs_entails_eq=> -> ->. by apply: twp_bind. Qed.

Ltac wp_bind_core K :=
  lazymatch eval hnf in K with
  | [] => idtac
  | _ => eapply (tac_wp_bind K); [simpl; reflexivity|reduction.pm_prettify]
  end.
Ltac twp_bind_core K :=
  lazymatch eval hnf in K with
  | [] => idtac
  | _ => eapply (tac_twp_bind K); [simpl; reflexivity|reduction.pm_prettify]
  end.

Tactic Notation "wp_bind" open_constr(efoc) :=
  iStartProof;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' => unify e' efoc; wp_bind_core K)
    || fail "wp_bind: cannot find" efoc "in" e
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' => unify e' efoc; twp_bind_core K)
    || fail "wp_bind: cannot find" efoc "in" e
  | _ => fail "wp_bind: not a 'wp'"
  end.

(** Heap tactics *)
Section heap.
Context `{!heapG Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val → iProp Σ.
Implicit Types Δ : envs (uPredI (iResUR Σ)).
Implicit Types v : val.
Implicit Types z : Z.

Lemma tac_wp_allocN Δ Δ' s E j K v n Φ :
  (0 < n)%Z →
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  (∀ l,
    match envs_app false (Esnoc Enil j (array l 1 (replicate (Z.to_nat n) v))) Δ' with
    | Some Δ'' =>
       envs_entails Δ'' (WP fill K (Val $ LitV $ LitLoc l) @ s; E {{ Φ }})
    | None => False
    end) →
  envs_entails Δ (WP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ? ? HΔ.
  rewrite -wp_bind. eapply wand_apply; first exact: wp_allocN.
  rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
  specialize (HΔ l).
  destruct (envs_app _ _ _) as [Δ''|] eqn:HΔ'; [ | contradiction ].
  rewrite envs_app_sound //; simpl.
  apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r.
Qed.
Lemma tac_twp_allocN Δ s E j K v n Φ :
  (0 < n)%Z →
  (∀ l,
    match envs_app false (Esnoc Enil j (array l 1 (replicate (Z.to_nat n) v))) Δ with
    | Some Δ' =>
       envs_entails Δ' (WP fill K (Val $ LitV $ LitLoc l) @ s; E [{ Φ }])
    | None => False
    end) →
  envs_entails Δ (WP fill K (AllocN (Val $ LitV $ LitInt n) (Val v)) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=> ? HΔ.
  rewrite -twp_bind. eapply wand_apply; first exact: twp_allocN.
  rewrite left_id. apply forall_intro=> l.
  specialize (HΔ l).
  destruct (envs_app _ _ _) as [Δ'|] eqn:HΔ'; [ | contradiction ].
  rewrite envs_app_sound //; simpl.
  apply wand_intro_l. by rewrite (sep_elim_l (l ↦∗ _)%I) right_id wand_elim_r.
Qed.

Lemma tac_wp_alloc Δ Δ' s E j K v Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  (∀ l,
    match envs_app false (Esnoc Enil j (l ↦ v)) Δ' with
    | Some Δ'' =>
       envs_entails Δ'' (WP fill K (Val $ LitV l) @ s; E {{ Φ }})
    | None => False
    end) →
  envs_entails Δ (WP fill K (Alloc (Val v)) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ? HΔ.
  rewrite -wp_bind. eapply wand_apply; first exact: wp_alloc.
  rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
  specialize (HΔ l).
  destruct (envs_app _ _ _) as [Δ''|] eqn:HΔ'; [ | contradiction ].
  rewrite envs_app_sound //; simpl.
  apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r.
Qed.
Lemma tac_twp_alloc Δ s E j K v Φ :
  (∀ l,
    match envs_app false (Esnoc Enil j (l ↦ v)) Δ with
    | Some Δ' =>
       envs_entails Δ' (WP fill K (Val $ LitV $ LitLoc l) @ s; E [{ Φ }])
    | None => False
    end) →
  envs_entails Δ (WP fill K (Alloc (Val v)) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=> HΔ.
  rewrite -twp_bind. eapply wand_apply; first exact: twp_alloc.
  rewrite left_id. apply forall_intro=> l.
  specialize (HΔ l).
  destruct (envs_app _ _ _) as [Δ''|] eqn:HΔ'; [ | contradiction ].
  rewrite envs_app_sound //; simpl.
  apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r.
Qed.

Lemma tac_wp_free Δ Δ' s E i K l v Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦ v)%I →
  (let Δ'' := envs_delete false i false Δ' in
   envs_entails Δ'' (WP fill K (Val $ LitV LitUnit) @ s; E {{ Φ }})) →
  envs_entails Δ (WP fill K (Free (LitV l)) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ? Hlk Hfin.
  rewrite -wp_bind. eapply wand_apply; first exact: wp_free.
  rewrite into_laterN_env_sound -later_sep envs_lookup_split //; simpl.
  rewrite -Hfin wand_elim_r (envs_lookup_sound' _ _ _ _ _ Hlk).
  apply later_mono, sep_mono_r, wand_intro_r. rewrite right_id //.
Qed.
Lemma tac_twp_free Δ s E i K l v Φ :
  envs_lookup i Δ = Some (false, l ↦ v)%I →
  (let Δ' := envs_delete false i false Δ in
   envs_entails Δ' (WP fill K (Val $ LitV LitUnit) @ s; E [{ Φ }])) →
  envs_entails Δ (WP fill K (Free (LitV l)) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=> Hlk Hfin.
  rewrite -twp_bind. eapply wand_apply; first exact: twp_free.
  rewrite envs_lookup_split //; simpl.
  rewrite -Hfin wand_elim_r (envs_lookup_sound' _ _ _ _ _ Hlk).
  apply sep_mono_r, wand_intro_r. rewrite right_id //.
Qed.

Lemma tac_wp_load Δ Δ' s E i K l q v Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦{q} v)%I →
  envs_entails Δ' (WP fill K (Val v) @ s; E {{ Φ }}) →
  envs_entails Δ (WP fill K (Load (LitV l)) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ???.
  rewrite -wp_bind. eapply wand_apply; first exact: wp_load.
  rewrite into_laterN_env_sound -later_sep envs_lookup_split //; simpl.
  by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_twp_load Δ s E i K l q v Φ :
  envs_lookup i Δ = Some (false, l ↦{q} v)%I →
  envs_entails Δ (WP fill K (Val v) @ s; E [{ Φ }]) →
  envs_entails Δ (WP fill K (Load (LitV l)) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=> ??.
  rewrite -twp_bind. eapply wand_apply; first exact: twp_load.
  rewrite envs_lookup_split //; simpl.
  by apply sep_mono_r, wand_mono.
Qed.

Lemma tac_wp_store Δ Δ' s E i K l v v' Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦ v)%I →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ v')) Δ' with
  | Some Δ'' => envs_entails Δ'' (WP fill K (Val $ LitV LitUnit) @ s; E {{ Φ }})
  | None => False
  end →
  envs_entails Δ (WP fill K (Store (LitV l) (Val v')) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ???.
  destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  rewrite -wp_bind. eapply wand_apply; first by eapply wp_store.
  rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl.
  rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_twp_store Δ s E i K l v v' Φ :
  envs_lookup i Δ = Some (false, l ↦ v)%I →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ v')) Δ with
  | Some Δ' => envs_entails Δ' (WP fill K (Val $ LitV LitUnit) @ s; E [{ Φ }])
  | None => False
  end →
  envs_entails Δ (WP fill K (Store (LitV l) v') @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq. intros.
  destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  rewrite -twp_bind. eapply wand_apply; first by eapply twp_store.
  rewrite envs_simple_replace_sound //; simpl.
  rewrite right_id. by apply sep_mono_r, wand_mono.
Qed.

Lemma tac_wp_cmpxchg Δ Δ' s E i K l v v1 v2 Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦ v)%I →
  vals_compare_safe v v1 →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ' with
  | Some Δ'' =>
     v = v1 →
     envs_entails Δ'' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E {{ Φ }})
  | None => False
  end →
  (v ≠ v1 →
   envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E {{ Φ }})) →
  envs_entails Δ (WP fill K (CmpXchg (LitV l) (Val v1) (Val v2)) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ??? Hsuc Hfail.
  destruct (envs_simple_replace _ _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  destruct (decide (v = v1)) as [Heq|Hne].
  - rewrite -wp_bind. eapply wand_apply.
    { eapply wp_cmpxchg_suc; eauto. }
    rewrite into_laterN_env_sound -later_sep /= {1}envs_simple_replace_sound //; simpl.
    apply later_mono, sep_mono_r. rewrite right_id. apply wand_mono; auto.
  - rewrite -wp_bind. eapply wand_apply.
    { eapply wp_cmpxchg_fail; eauto. }
    rewrite into_laterN_env_sound -later_sep /= {1}envs_lookup_split //; simpl.
    apply later_mono, sep_mono_r. apply wand_mono; auto.
Qed.
Lemma tac_twp_cmpxchg Δ s E i K l v v1 v2 Φ :
  envs_lookup i Δ = Some (false, l ↦ v)%I →
  vals_compare_safe v v1 →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ with
  | Some Δ' =>
     v = v1 →
     envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E [{ Φ }])
  | None => False
  end →
  (v ≠ v1 →
   envs_entails Δ (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E [{ Φ }])) →
  envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=> ?? Hsuc Hfail.
  destruct (envs_simple_replace _ _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  destruct (decide (v = v1)) as [Heq|Hne].
  - rewrite -twp_bind. eapply wand_apply.
    { eapply twp_cmpxchg_suc; eauto. }
    rewrite /= {1}envs_simple_replace_sound //; simpl.
    apply sep_mono_r. rewrite right_id. apply wand_mono; auto.
  - rewrite -twp_bind. eapply wand_apply.
    { eapply twp_cmpxchg_fail; eauto. }
    rewrite /= {1}envs_lookup_split //; simpl.
    apply sep_mono_r. apply wand_mono; auto.
Qed.

Lemma tac_wp_cmpxchg_fail Δ Δ' s E i K l q v v1 v2 Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦{q} v)%I →
  v ≠ v1 → vals_compare_safe v v1 →
  envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E {{ Φ }}) →
  envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ?????.
  rewrite -wp_bind. eapply wand_apply; first exact: wp_cmpxchg_fail.
  rewrite into_laterN_env_sound -later_sep envs_lookup_split //; simpl.
  by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_twp_cmpxchg_fail Δ s E i K l q v v1 v2 Φ :
  envs_lookup i Δ = Some (false, l ↦{q} v)%I →
  v ≠ v1 → vals_compare_safe v v1 →
  envs_entails Δ (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E [{ Φ }]) →
  envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq. intros. rewrite -twp_bind.
  eapply wand_apply; first exact: twp_cmpxchg_fail.
  rewrite envs_lookup_split //=. by do 2 f_equiv.
Qed.

Lemma tac_wp_cmpxchg_suc Δ Δ' s E i K l v v1 v2 Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦ v)%I →
  v = v1 → vals_compare_safe v v1 →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ' with
  | Some Δ'' =>
     envs_entails Δ'' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E {{ Φ }})
  | None => False
  end →
  envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ?????; subst.
  destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  rewrite -wp_bind. eapply wand_apply.
  { eapply wp_cmpxchg_suc; eauto. }
  rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl.
  rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_twp_cmpxchg_suc Δ s E i K l v v1 v2 Φ :
  envs_lookup i Δ = Some (false, l ↦ v)%I →
  v = v1 → vals_compare_safe v v1 →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ with
  | Some Δ' =>
     envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E [{ Φ }])
  | None => False
  end →
  envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=>????; subst.
  destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  rewrite -twp_bind. eapply wand_apply.
  { eapply twp_cmpxchg_suc; eauto. }
  rewrite envs_simple_replace_sound //; simpl.
  rewrite right_id. by apply sep_mono_r, wand_mono.
Qed.

Lemma tac_wp_faa Δ Δ' s E i K l z1 z2 Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦ LitV z1)%I →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ LitV (LitInt (z1 + z2)))) Δ' with
  | Some Δ'' => envs_entails Δ'' (WP fill K (Val $ LitV z1) @ s; E {{ Φ }})
  | None => False
  end →
  envs_entails Δ (WP fill K (FAA (LitV l) (LitV z2)) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ???.
  destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  rewrite -wp_bind. eapply wand_apply; first exact: (wp_faa _ _ _ z1 z2).
  rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl.
  rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_twp_faa Δ s E i K l z1 z2 Φ :
  envs_lookup i Δ = Some (false, l ↦ LitV z1)%I →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ LitV (LitInt (z1 + z2)))) Δ with
  | Some Δ' => envs_entails Δ' (WP fill K (Val $ LitV z1) @ s; E [{ Φ }])
  | None => False
  end →
  envs_entails Δ (WP fill K (FAA (LitV l) (LitV z2)) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=> ??.
  destruct (envs_simple_replace _ _ _) as [Δ'|] eqn:HΔ'; [ | contradiction ].
  rewrite -twp_bind. eapply wand_apply; first exact: (twp_faa _ _ _ z1 z2).
  rewrite envs_simple_replace_sound //; simpl.
  rewrite right_id. by apply sep_mono_r, wand_mono.
Qed.
End heap.

(** Evaluate [lem] to a hypothesis [H] that can be applied, and then run
[wp_bind K; tac H] for every possible evaluation context.  [tac] can do
[iApplyHyp H] to actually apply the hypothesis.  TC resolution of [lem] premises
happens *after* [tac H] got executed. *)
Tactic Notation "wp_apply_core" open_constr(lem) tactic3(tac) :=
  wp_pures;
  iPoseProofCore lem as false (fun H =>
    lazymatch goal with
    | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
      reshape_expr e ltac:(fun K e' =>
        wp_bind_core K; tac H) ||
      lazymatch iTypeOf H with
      | Some (_,?P) => fail "wp_apply: cannot apply" P
      end
    | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
      reshape_expr e ltac:(fun K e' =>
        twp_bind_core K; tac H) ||
      lazymatch iTypeOf H with
      | Some (_,?P) => fail "wp_apply: cannot apply" P
      end
    | _ => fail "wp_apply: not a 'wp'"
    end).
Tactic Notation "wp_apply" open_constr(lem) :=
  wp_apply_core lem (fun H => iApplyHyp H; try iNext; try wp_expr_simpl).
(** Tactic tailored for atomic triples: the first, simple one just runs
[iAuIntro] on the goal, as atomic triples always have an atomic update as their
premise.  The second one additionaly does some framing: it gets rid of [Hs] from
the context, which is intended to be the non-laterable assertions that iAuIntro
would choke on.  You get them all back in the continuation of the atomic
operation. *)
Tactic Notation "awp_apply" open_constr(lem) :=
  wp_apply_core lem (fun H => iApplyHyp H);
  last iAuIntro.
Tactic Notation "awp_apply" open_constr(lem) "without" constr(Hs) :=
  wp_apply_core lem (fun H => iApply wp_frame_wand_l; iSplitL Hs; [iAccu|iApplyHyp H]);
  last iAuIntro.

Tactic Notation "wp_alloc" ident(l) "as" constr(H) :=
  let Htmp := iFresh in
  let finish _ :=
    first [intros l | fail 1 "wp_alloc:" l "not fresh"];
    pm_reduce;
    lazymatch goal with
    | |- False => fail 1 "wp_alloc:" H "not fresh"
    | _ => iDestructHyp Htmp as H; wp_finish
    end in
  wp_pures;
  (** The code first tries to use allocation lemma for a single reference,
     ie, [tac_wp_alloc] (respectively, [tac_twp_alloc]).
     If that fails, it tries to use the lemma [tac_wp_allocN]
     (respectively, [tac_twp_allocN]) for allocating an array.
     Notice that we could have used the array allocation lemma also for single
     references. However, that would produce the resource l ↦∗ [v] instead of
     l ↦ v for single references. These are logically equivalent assertions
     but are not equal. *)
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    let process_single _ :=
        first
          [reshape_expr e ltac:(fun K e' => eapply (tac_wp_alloc _ _ _ _ Htmp K))
          |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
        [iSolveTC
        |finish ()]
    in
    let process_array _ :=
        first
          [reshape_expr e ltac:(fun K e' => eapply (tac_wp_allocN _ _ _ _ Htmp K))
          |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
        [idtac|iSolveTC
         |finish ()]
    in (process_single ()) || (process_array ())
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    let process_single _ :=
        first
          [reshape_expr e ltac:(fun K e' => eapply (tac_twp_alloc _ _ _ Htmp K))
          |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
        finish ()
    in
    let process_array _ :=
        first
          [reshape_expr e ltac:(fun K e' => eapply (tac_twp_allocN _ _ _ Htmp K))
          |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
        [idtac
        |finish ()]
    in (process_single ()) || (process_array ())
  | _ => fail "wp_alloc: not a 'wp'"
  end.

Tactic Notation "wp_alloc" ident(l) :=
  wp_alloc l as "?".

Tactic Notation "wp_free" :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_free: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_free _ _ _ _ _ K))
      |fail 1 "wp_free: cannot find 'Free' in" e];
    [iSolveTC
    |solve_mapsto ()
    |pm_reduce; wp_finish]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_twp_free _ _ _ _ K))
      |fail 1 "wp_free: cannot find 'Free' in" e];
    [solve_mapsto ()
    |pm_reduce; wp_finish]
  | _ => fail "wp_free: not a 'wp'"
  end.

Tactic Notation "wp_load" :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_load: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_load _ _ _ _ _ K))
      |fail 1 "wp_load: cannot find 'Load' in" e];
    [iSolveTC
    |solve_mapsto ()
    |wp_finish]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_twp_load _ _ _ _ K))
      |fail 1 "wp_load: cannot find 'Load' in" e];
    [solve_mapsto ()
    |wp_finish]
  | _ => fail "wp_load: not a 'wp'"
  end.

Tactic Notation "wp_store" :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_store: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_store _ _ _ _ _ K))
      |fail 1 "wp_store: cannot find 'Store' in" e];
    [iSolveTC
    |solve_mapsto ()
    |pm_reduce; first [wp_seq|wp_finish]]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_twp_store _ _ _ _ K))
      |fail 1 "wp_store: cannot find 'Store' in" e];
    [solve_mapsto ()
    |pm_reduce; first [wp_seq|wp_finish]]
  | _ => fail "wp_store: not a 'wp'"
  end.

Tactic Notation "wp_cmpxchg" "as" simple_intropattern(H1) "|" simple_intropattern(H2) :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_cmpxchg: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_cmpxchg _ _ _ _ _ K))
      |fail 1 "wp_cmpxchg: cannot find 'CmpXchg' in" e];
    [iSolveTC
    |solve_mapsto ()
    |try solve_vals_compare_safe
    |pm_reduce; intros H1; wp_finish
    |intros H2; wp_finish]
  | |- envs_entails _ (twp ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_twp_cmpxchg _ _ _ _ K))
      |fail 1 "wp_cmpxchg: cannot find 'CmpXchg' in" e];
    [solve_mapsto ()
    |try solve_vals_compare_safe
    |pm_reduce; intros H1; wp_finish
    |intros H2; wp_finish]
  | _ => fail "wp_cmpxchg: not a 'wp'"
  end.

Tactic Notation "wp_cmpxchg_fail" :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_cmpxchg_fail: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_cmpxchg_fail _ _ _ _ _ K))
      |fail 1 "wp_cmpxchg_fail: cannot find 'CmpXchg' in" e];
    [iSolveTC
    |solve_mapsto ()
    |try (simpl; congruence) (* value inequality *)
    |try solve_vals_compare_safe
    |wp_finish]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_twp_cmpxchg_fail _ _ _ _ K))
      |fail 1 "wp_cmpxchg_fail: cannot find 'CmpXchg' in" e];
    [solve_mapsto ()
    |try (simpl; congruence) (* value inequality *)
    |try solve_vals_compare_safe
    |wp_finish]
  | _ => fail "wp_cmpxchg_fail: not a 'wp'"
  end.

Tactic Notation "wp_cmpxchg_suc" :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_cmpxchg_suc: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_cmpxchg_suc _ _ _ _ _ K))
      |fail 1 "wp_cmpxchg_suc: cannot find 'CmpXchg' in" e];
    [iSolveTC
    |solve_mapsto ()
    |try (simpl; congruence) (* value equality *)
    |try solve_vals_compare_safe
    |pm_reduce; wp_finish]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_twp_cmpxchg_suc _ _ _ _ K))
      |fail 1 "wp_cmpxchg_suc: cannot find 'CmpXchg' in" e];
    [solve_mapsto ()
    |try (simpl; congruence) (* value equality *)
    |try solve_vals_compare_safe
    |pm_reduce; wp_finish]
  | _ => fail "wp_cmpxchg_suc: not a 'wp'"
  end.

Tactic Notation "wp_faa" :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_faa: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_faa _ _ _ _ _ K))
      |fail 1 "wp_faa: cannot find 'FAA' in" e];
    [iSolveTC
    |solve_mapsto ()
    |pm_reduce; wp_finish]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_twp_faa _ _ _ _ K))
      |fail 1 "wp_faa: cannot find 'FAA' in" e];
    [solve_mapsto ()
    |pm_reduce; wp_finish]
  | _ => fail "wp_faa: not a 'wp'"
  end.


Require Import RelationClasses.
Require Import List.

Require Import sflib.
From Paco Require Import paco.

Require Import Basic.
Require Import Axioms.
Require Import Loc.
Require Import Language.
Require Export ZArith.

Require Import Event.
Require Import Syntax.
Require Import Maps.
Require Import Integers.
Require Import LibTactics.
Require Import Coqlib.

(** * Semantics of the CSimpRTL *)

(* This file defines the semantics of concurrent simple RTL language (RTL) *)

(* The semantics of CSimpRTL is a set of transitions on the thread-local state *)

(** ** Register File *)
Module RegFile.
  (** Register file is a total map from register to value. *)
  Definition t := RegFun.t int.

  (** Register file initialization *)
  Definition init := RegFun.init Int.zero.

  Fixpoint eval_expr (e: Inst.expr) (rf: t): int :=
      match e with
      | Inst.expr_val val => val
      | Inst.expr_reg r => RegFun.find r rf
      | Inst.expr_op2 op e1 e2 => Op2.eval op (eval_expr e1 rf) (eval_expr e2 rf)
      end.

End RegFile.

Lemma expr_eval_eq:
  forall e R_t R_s
    (REG_EQ: forall r, RegSet.In r (Inst.regs_of_expr e) ->
                  RegFun.find r R_t = RegFun.find r R_s),
    RegFile.eval_expr e R_t = RegFile.eval_expr e R_s.
Proof.
  induction e; ii; ss; eauto.
  - exploit REG_EQ; eauto. eapply RegSet.singleton_spec; eauto.
  - specialize (IHe1 R_t R_s).
    exploit IHe1; eauto. ii. eapply REG_EQ; eauto.
    eapply RegSet.union_spec; eauto. introv EVAL_REG1.
    specialize (IHe2 R_t R_s).
    exploit IHe2; eauto. ii. eapply REG_EQ; eauto.
    eapply RegSet.union_spec; eauto. introv EVAL_REG2.
    rewrite EVAL_REG1, EVAL_REG2. eauto.
Qed.

(** ** Continuation *)
Module Continuation.
    Inductive t :=
    | done
    | stack (regs: RegFile.t) (blk: BBlock.t) (cdhp: CodeHeap) (cont: t)
    .
End Continuation.

(** ** Thread-Local State and State Transitions *)
(** Thread-local state includes:
    - regs: register file;
    - blk: current basic block;
    - cdhp: codeheap for current function;
    - cont: continuation, which acts as a call stack;
    - code: whole program *)
Module State.
    Structure t := mk {
        regs: RegFile.t;
        blk: BBlock.t;
        cdhp: CodeHeap;
        cont: Continuation.t;
        code: Code;
    }.

    Definition init(code:Code) (f:Language.fid) : option t :=
      match (code!f) with
      | Some (ch, fentry) =>
        match (ch!fentry) with
        | Some b => Some (mk RegFile.init b ch Continuation.done code)
        | _ => None
        end
      | _ => None
      end.

    Definition is_terminal (s: t): Prop:=
        (blk s) = BBlock.ret /\ (cont s) = Continuation.done.

    (** transform a `int32` to Loc.t (which is `positive` indeed) *)
    Definition int2loc (i: int) : Loc.t := Z.to_pos (Int.unsigned i).

    Notation "[[ i ]]" := (int2loc i) (at level 75, right associativity).

    (** State transitions *)
    Inductive step: forall (e:ProgramEvent.t) (s1:t) (s2:t), Prop :=
    | step_skip
        rf b b' ch cont code
        (BLK: b = Inst.skip ## b')
        :
        step ProgramEvent.silent
             (mk rf b ch cont code)
             (mk rf b' ch cont code)
    | step_assign
        r e rf rf' b b' ch cont code
        (BLK: b = (Inst.assign r e) ## b')
        (REGFILE: rf' = RegFun.add r (RegFile.eval_expr e rf) rf)
        :
        step ProgramEvent.silent
            (mk rf b ch cont code)
            (mk rf' b' ch cont code)
    | step_load
        r loc or v rf rf' b b' ch cont code
        (BLK: b = (Inst.load r loc or) ## b')
        (REGFILE: rf' = RegFun.add r v rf)
        :
        step (ProgramEvent.read loc v or)
            (mk rf b ch cont code)
            (mk rf' b' ch cont code)
    | step_store
        loc e ow v  rf b b' ch cont code
        (BLK: b = (Inst.store loc e ow) ## b')
        (VAL: RegFile.eval_expr e rf = v)
        :
        step (ProgramEvent.write loc v ow)
            (mk rf b ch cont code)
            (mk rf b' ch cont code)
    | step_out
        e v rf b b' ch cont code
        (BLK: b = (Inst.print e) ## b')
        (VAL: RegFile.eval_expr e rf = v)
        :
        step (ProgramEvent.syscall (Event.mk v))
            (mk rf b ch cont code)
            (mk rf b' ch cont code)
    | step_cas_same
        r loc er ew or ow vr vw rf rf' b b' ch cont code
        (BLK: b = (Inst.cas r loc er ew or ow) ## b')
        (ATOMIC: or <> Ordering.plain )
        (VALR: RegFile.eval_expr er rf = vr)
        (VALW: RegFile.eval_expr ew rf = vw)
        (REGFILE: rf' = RegFun.add r Int.one rf)
        :
        step (ProgramEvent.update loc vr vw or ow)
            (mk rf b ch cont code)
            (mk rf' b' ch cont code)
    | step_cas_flip
        r loc er ew or ow vr' vr vw rf rf' b b' ch cont code
        (BLK: b = (Inst.cas r loc er ew or ow) ## b')
        (ATOMIC: or <> Ordering.plain )
        (VALR: RegFile.eval_expr er rf = vr')
        (VALW: RegFile.eval_expr ew rf = vw)
        (TEST: Int.cmp Cne vr vr')
        (REGFILE: rf' = RegFun.add r Int.zero rf)
        :
        step (ProgramEvent.read loc vr or)
            (mk rf b ch cont code)
            (mk rf' b' ch cont code)
    | step_call
        rf (code:Code) (b:BBlock.t) b' f fret f0 b b0 ch ch0 cont cont0
        (BLK: b = BBlock.call f fret)
        (FIND_FUNC: (code!f) = Some (ch0, f0))
        (ENTRY_BLK: (ch0!f0) = Some (b0))
        (STACK: ch!fret = Some (b'))
        (CONT: cont0 = (Continuation.stack rf b' ch cont))
        :
        step ProgramEvent.silent
            (mk rf b ch cont code)
            (mk (RegFile.init) b0 ch0 cont0 code)
    | step_ret
        b rf rf0 b0 ch0 cont0 ch cont code
        (BLK: b = BBlock.ret)
        (CONT: cont = (Continuation.stack rf0 b0 ch0 cont0))
        :
        step (ProgramEvent.silent)
            (mk rf b ch cont code)
            (mk rf0 b0 ch0 cont0 code)
    | step_fence_rel
        b rf ch b' cont code
        (BLK: b = (Inst.fence_rel) ## b')
        :
        step (ProgramEvent.fence (Ordering.relaxed) (Ordering.acqrel))
            (mk rf b ch cont code)
            (mk rf b' ch cont code)
    | step_fence_acq
        b rf ch b' cont code
        (BLK: b = (Inst.fence_acq) ## b')
        :
        step (ProgramEvent.fence (Ordering.acqrel) (Ordering.relaxed))
            (mk rf b ch cont code)
            (mk rf b' ch cont code)
    | step_fence_sc
        b rf ch b' cont code
        (BLK: b = (Inst.fence_sc) ## b')
        :
        step (ProgramEvent.fence (Ordering.relaxed) (Ordering.seqcst))
            (mk rf b ch cont code)
            (mk rf b' ch cont code)
    | step_jmp
        b f rf ch b' cont code
        (BLK: b = BBlock.jmp f)
        (TGT: ch!f = Some (b'))
        :
        step (ProgramEvent.silent)
            (mk rf b ch cont code)
            (mk rf b' ch cont code)
    | step_be
        b e f1 f2 rf v ch b' cont code
        (BLK: b = BBlock.be e f1 f2)
        (COND: RegFile.eval_expr e rf = v)
        (BRANCH: (ch!f1 = Some (b') /\ Int.eq v Int.zero) \/
                (ch!f2 = Some (b') /\ Int.cmp Cne v Int.zero))
        :
        step (ProgramEvent.silent)
            (mk rf b ch cont code)
            (mk rf b' ch cont code)
    .
End State.

Program Definition rtl_lang:Language.t :=
  Language.mk
    State.init
    State.is_terminal
    State.step _ _ _.
Next Obligation.
(** prove determinacy of rtl language (required by Language.v) on thread-local transition*)
  inv STEP1; try solve [inv STEP2; inv BLK; tryfalse; eauto];
    inv STEP2; inv BLK; tryfalse.
  {
    right. left.
    exists or0 loc0 v v0; eauto.
  }
  {
    eauto.
  }
  {
    right; right; left.
    exists or0 ow0 loc0.
    exists (RegFile.eval_expr er0 rf) (RegFile.eval_expr ew0 rf) vr.
    eauto.
  }
  {
    right; right; right.
    exists or0 ow0 loc0.
    exists (RegFile.eval_expr er0 rf) (RegFile.eval_expr ew0 rf) vr.
    eauto.
  }
  {
    right; left.
    exists or0 loc0 vr vr0.
    eauto.
  }
  {
    left. split; eauto.
    rewrite FIND_FUNC in FIND_FUNC0. inv FIND_FUNC0.
    rewrite ENTRY_BLK in ENTRY_BLK0. inv ENTRY_BLK0.
    rewrite STACK in STACK0. inv STACK0.
    eauto.
  }
  {
    inv CONT; eauto.
  }
  {
    rewrite TGT in TGT0. inv TGT0; eauto.
  }
  {
    left; eauto.
    destruct BRANCH; destruct BRANCH0.
    {
      destruct H, H0.
      rewrite H in H0; inv H0; eauto.
    }
    {
      destruct H, H0.
      unfolds Int.cmp, Int.eq.
      destruct (Coqlib.zeq (Int.unsigned (RegFile.eval_expr e0 rf)) (Int.unsigned Int.zero)); tryfalse.
    }
    {
      destruct H, H0.
      unfolds Int.cmp, Int.eq.
      destruct (Coqlib.zeq (Int.unsigned (RegFile.eval_expr e0 rf)) (Int.unsigned Int.zero)); tryfalse.
    }
    {
      destruct H, H0.
      rewrite H in H0; inv H0; eauto.
    }
  }
Qed.
Next Obligation.
  inv READ.
  eexists. left.
  {
    econs; eauto.
  }
  {
    destruct (classic (Int.cmp Cne val' (RegFile.eval_expr er rf))).
    {
      eexists.
      left. eapply State.step_cas_flip; eauto.
    }
    {
      unfold Int.cmp in H.
      unfold negb in H.
      destruct (Int.eq val' (RegFile.eval_expr er rf)) eqn:Heqe; ss.
      eapply Int.same_if_eq in Heqe; subst.
      eexists.
      right.
      do 2 eexists.
      econs; eauto.
    }
  }
Qed.
Next Obligation.
  inv UPDATE.
  destruct (classic (Int.cmp Cne val' (RegFile.eval_expr er rf))).
  {
    eexists.
    left.
    eapply State.step_cas_flip; eauto.
  }
  {
    unfold Int.cmp in H.
    unfold negb in H.
    destruct (Int.eq val' (RegFile.eval_expr er rf)) eqn:Heqe; ss.
    eapply Int.same_if_eq in Heqe; subst.
    eexists.
    right.
    econs; eauto.
  }
Qed.

Lemma regs_add_neg
      r (v: Const.t) r' regs
      (NEQ: r <> r'):
  (RegFun.add r v regs) r' = regs r'.
Proof.
  assert(RegFun.find r' (RegFun.add r v regs) = regs r').
  rewrite RegFun.add_spec_neq; eauto.
  unfold LocFun.find in *. eauto.
Qed.

Lemma regs_add_nonfree_var_eq_eval_expr:
  forall expr regs r val,
  ~(RegSet.mem r (Inst.regs_of_expr expr)) ->
  RegFile.eval_expr expr regs = RegFile.eval_expr expr (RegFun.add r val regs).
Proof.
  induction expr.
  -
   intros. unfold RegFile.eval_expr. trivial.
  -
  intros. unfold RegFile.eval_expr.
  assert (r <> reg). {
    unfolds Inst.regs_of_expr.
    intro.
    apply H.
    rewrite H0.
    rewrite RegSet.Facts.singleton_b.
    unfold RegSet.Facts.eqb.
    des_ifs.
  }
  unfold RegFun.find in *.
  rewrite regs_add_neg; trivial.
  -
    intros.
    unfold RegFile.eval_expr. unfold Op2.eval.
    rewrite <- IHexpr1; trivial.
    rewrite <- IHexpr2; trivial.
    *
    unfold Inst.regs_of_expr in H.
    fold Inst.regs_of_expr in H.
    rewrite RegSet.Facts.union_b in H.
    unfold "||" in H.
    intro.
    apply H.
    des_ifs.
    *
    unfold Inst.regs_of_expr in H.
    fold Inst.regs_of_expr in H.
    rewrite RegSet.Facts.union_b in H.
    unfold "||" in H.
    intro.
    apply H.
    des_ifs.
Qed.