From hahn Require Import Hahn.
Require Import PromisingLib.
From Promising Require Import TView View Time Event Cell Thread Memory Configuration.

From imm Require Import Events.
From imm Require Import Execution.
From imm Require Import imm_s.
From imm Require Import imm_s_hb.
From imm Require Import imm_bob imm_s_ppo.

Require Import PArith.
Require Import Event_imm_promise.
From imm Require Import CombRelations.
From imm Require Import CombRelationsMore.
From imm Require Import TraversalConfig.
Require Import MaxValue.
From imm Require Import ViewRelHelpers.

Set Implicit Arguments.
Remove Hints plus_n_O.

Section ViewRel.
Variable G : execution.
Variable WF : Wf G.
Variable sc : relation actid.

Notation "'acts'" := G.(acts).
Notation "'co'" := G.(co).
Notation "'sw'" := G.(sw).
Notation "'hb'" := G.(hb).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'rmw'" := G.(rmw).
Notation "'lab'" := G.(lab).
Notation "'msg_rel'" := G.(msg_rel).
Notation "'urr'" := (urr G sc).
Notation "'release'" := G.(release).
Notation "'t_cur'" := (t_cur G sc).
Notation "'t_acq'" := (t_acq G sc).
Notation "'t_rel'" := (t_rel G sc).
Notation "'rfe'" := G.(rfe).
Notation "'rfi'" := G.(rfi).

Notation "'E'" := G.(acts_set).
Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'Loc_' l" := (fun x => loc lab x = Some l) (at level 1). (* , format "'Loc_'  l"). *)
Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'W_'" := (fun l => W ∩₁ Loc_ l).
(* Notation "'RW'" := (fun x => R x \/ W x). *)
Notation "'FR'" := (fun x => F x \/ R x).
Notation "'FW'" := (fun x => F x \/ W x).

Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (is_rlx lab).
Notation "'Rel'" := (is_rel lab).
Notation "'Acq'" := (is_acq lab).
Notation "'Acqrel'" := (is_acqrel lab).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

Definition sim_msg f_to b rel :=
  forall l, max_value f_to
              (fun a => msg_rel sc l a b \/ Loc_ l b /\ a = b)
              (LocFun.find l rel.(View.rlx)).

Definition sim_mem_helper f_to b from v rel :=
  ⟪ VAL: Some v = val lab b ⟫ /\
  ⟪ FROM: Time.lt from (f_to b) \/
    is_init b /\ from = Time.bot /\ (f_to b) = Time.bot ⟫ /\
  ⟪ SIMMSG: sim_msg f_to b rel ⟫.

Definition sim_rel C f_to rel i :=
  forall l' l, max_value f_to
    (t_rel i l l' C ∪₁
     if Loc.eq_dec l l'
     then W_ l' ∩₁ Tid_ i ∩₁ C
     else ∅)
    (LocFun.find l (LocFun.find l' rel).(View.rlx)).

Definition sim_cur C f_to cur i :=
  forall l,
    max_value f_to (t_cur i l C)
    (LocFun.find l cur.(View.rlx)).

Definition sim_acq C f_to acq i :=
  forall l,
    max_value f_to (t_acq i l C)
    (LocFun.find l acq.(View.rlx)).

Definition sim_tview C f_to tview i :=
  ⟪ CUR: sim_cur C f_to tview.(TView.cur) i ⟫ /\
  ⟪ ACQ: sim_acq C f_to tview.(TView.acq) i ⟫ /\
  ⟪ REL: sim_rel C f_to tview.(TView.rel) i ⟫.

Lemma sim_tview_read_step
      f_to f_from
      w r locr valr xrmw ordr C tview thread rel mem
      (COH : coherence G)
      (Wf_sc : wf_sc G sc)
      (SIMTVIEW : sim_tview C f_to tview thread)
      (RRLX : Rlx r)
      (NC : ~ C r)
      (SBC : forall y, C y /\ tid y = tid r -> sb y r)
      (PRC : doma (sb ⨾ ⦗ eq r ⦘) C)
      (RF : rf w r)
      (TID : tid r = thread)
      (RPARAMS : lab r = Aload xrmw ordr locr valr)
      (GET : Memory.get locr (f_to w) mem =
             Some (f_from w, Message.mk valr rel))
      (HELPER : sim_mem_helper f_to w (f_from w) valr rel.(View.unwrap)) :
  sim_tview
    (C ∪₁ eq r) f_to
    (TView.read_tview tview locr (f_to w) rel (rmod ordr))
    thread.
Proof using WF.
  assert (R r) as RR by type_solver.
  assert (W w) as WW by (apply (wf_rfD WF) in RF; revert RF; basic_solver).
  assert (Loc_ locr w) as WLOC.
  { assert (loc lab w = loc lab r) as H.
    { eapply loceq_rf; eauto. }
    by rewrite H; unfold loc; rewrite RPARAMS. }
  assert (~ is_init r) as RNINIT.
  { intros INIT. apply (init_w WF) in INIT. type_solver. }
  assert (E r) as RACTS by (apply (wf_rfE WF) in RF; revert RF; basic_solver).
  assert (loc lab r = Some locr) as RLOC.
  { by unfold loc; rewrite RPARAMS. }

  assert (~ F r) as NF.
  { intros H. type_solver. }

  assert (Ordering.le Ordering.relaxed (rmod ordr) = Rlx r) as ORDRLX.
    by unfold is_rlx, mode_le, mod; rewrite RPARAMS; destruct ordr; simpls.
  assert (Ordering.le Ordering.acqrel (rmod ordr) = Acq r) as ORDACQ.
    by unfold is_acq, mode_le, mod; rewrite RPARAMS; destruct ordr; simpls.

  assert
    (forall l (P : actid -> bool),
     dom_rel
     ((msg_rel sc l ∪ ⦗Loc_ l⦘) ⨾ rf ⨾ ⦗P⦘ ⨾ ⦗eq r⦘) ≡₁
     if P r
     then
       (fun a => msg_rel sc l a w \/ loc lab w = Some l /\ a = w)
     else ∅) as MSGALT.
  { ins; desf; [|basic_solver 21].
    split; [|basic_solver 21].
    unfolder; ins; desc.
    assert (z = w); subst.
      by eapply (wf_rff WF); eauto.
    basic_solver 21. }

  assert (forall l, W_ l ∩₁ eq r ≡₁ ∅) as DR'.
    by type_solver 21.

  assert (forall S l, W_ l ∩₁ eq r ∪₁ S ≡₁ S) as DR.
   by intros; rewrite DR'; apply set_union_empty_l.

  assert (forall l l',
   t_rel (tid r) l l' (C ∪₁ eq r) ∪₁
   (if LocSet.Facts.eq_dec l l'
    then W ∩₁ Loc_ l' ∩₁ Tid_ (tid r) ∩₁ (C ∪₁ eq r)
    else ∅) ≡₁
   t_rel (tid r) l l' C ∪₁
   (if LocSet.Facts.eq_dec l l'
    then W ∩₁ Loc_ l' ∩₁ Tid_ (tid r) ∩₁ C
    else ∅)) as RELALT.
  { ins; rewrite t_rel_union_eqv; auto.
    by desf; apply set_equiv_union; [done| type_solver 21].
    by revert PRC; basic_solver. }

  red in SIMTVIEW; desf.
  red in CUR; desf.
  red in ACQ; desf.
  red in REL; desf.
  cdes HELPER; clear FROM.
  red in SIMMSG; desf.
  red; splits; intros l; simpls;
    unfold LocFun.find, TimeMap.join in *;
    (try rewrite ORDRLX); try (rewrite ORDACQ).
  { eapply max_value_same_set.
    2: apply t_cur_urr_union_eqv; auto; revert PRC; basic_solver.
    rewrite Time.join_assoc.
    unfold CombRelations.t_cur, CombRelations.c_cur in CUR.
    eapply max_value_join; eauto.
    eapply max_value_join; eauto.
    { eapply max_value_same_set; [|by apply DR].
      eapply max_value_same_set; [|by eapply dom_rel_r; eauto].
      unfold TimeMap.singleton, LocFun.add, LocFun.find, LocFun.init.
      destruct (LocSet.Facts.eq_dec l locr); simpls; subst.
      all: unfold TimeMap.singleton, LocFun.add, LocFun.find, LocFun.init.
      { by apply max_value_singleton; rewrite Loc.eq_dec_eq. }
      rewrite Loc.eq_dec_neq; auto.
      apply max_value_empty; intros x HH; desf. }
    specialize (MSGALT l (Acq)).
    eapply max_value_same_set; [|by apply MSGALT].
    destruct (Acq r) eqn: RACQ; unfold View.rlx; simpls.
    by apply max_value_empty; intros x HH; desf. }
  { eapply max_value_same_set.
    2: apply t_acq_urr_union_eqv; auto; revert PRC; basic_solver.
    rewrite Time.join_assoc.
    unfold CombRelations.t_acq, CombRelations.c_acq in ACQ.
    eapply max_value_join; eauto.
    eapply max_value_join; eauto.
    { eapply max_value_same_set; [|by apply DR].
      eapply max_value_same_set; [|by eapply (dom_rel_r WF l); eauto].
      destruct (LocSet.Facts.eq_dec l locr); simpls; subst;
        unfold TimeMap.singleton, LocFun.add, LocFun.find, LocFun.init.
      { by rewrite Loc.eq_dec_eq; apply max_value_singleton. }
      rewrite Loc.eq_dec_neq; auto.
      apply max_value_empty; intros x HH; desf. }
    apply set_equiv_union; [reflexivity|].
    specialize (MSGALT l (fun x => true)).
    simpl in MSGALT. rewrite <- MSGALT.
    arewrite (⦗fun _ : actid => true⦘ ≡ ⦗fun _ : actid => True⦘).
    { split; intros x y H; red; red in H; desf. }
    by rewrite seq_id_l. }
  intros l'.
  by eapply max_value_same_set; [apply REL| apply RELALT].
Qed.

Lemma sim_tview_write_step f_to f_from
      w locw valw xmw ordw C tview thread rel mem sc_view
      (COH : coherence G)
      (Wf_sc : wf_sc G sc)
      (CINE : C ⊆₁ E)
      (CCLOS : doma (sb ⨾ ⦗C⦘) C)
      (SIMTVIEW : sim_tview C f_to tview thread)
      (NC : ~ C w)
      (SBC : forall y, C y /\ tid y = tid w -> sb y w)
      (PRC : doma (sb ⨾ ⦗ eq w ⦘) C)
      (TID : tid w = thread)
      (NINIT : ~ is_init w)
      (WACTS : E w)
      (WPARAMS : lab w = Astore xmw ordw locw valw)
      (GET : Memory.get locw (f_to w) mem =
             Some (f_from w, Message.mk valw rel))
      (HELPER : sim_mem_helper f_to w (f_from w) valw rel.(View.unwrap))
 : sim_tview
    (C ∪₁ eq w) f_to
    (TView.write_tview
       tview sc_view locw (f_to w) (wmod ordw))
    thread.
Proof using WF.
  assert (W w) as WW.
  { by unfold is_w; rewrite WPARAMS. }
  assert (loc lab w = Some locw) as LOC.
  { by unfold loc; rewrite WPARAMS. }
  assert (~ F w) as NF.
  { intros H; type_solver. }

  assert (forall S l, S ∪₁ dom_rel (⦗Loc_ l⦘ ⨾ rf ⨾ ⦗eq w⦘) ≡₁ S) as DR1.
    by ins; rewrite (dom_r (wf_rfD WF)); type_solver.

  assert (forall S O l,
             S ∪₁
             dom_rel ((msg_rel sc l ∪ ⦗Loc_ l⦘) ⨾ rf ⨾ ⦗O⦘ ⨾ ⦗eq w⦘) ≡₁ S)
    as DR2.
    by ins; rewrite (dom_r (wf_rfD WF)); type_solver.

  assert (forall S l,
             S ∪₁
             dom_rel ((msg_rel sc l ∪ ⦗Loc_ l⦘) ⨾ rf ⨾ ⦗eq w⦘) ≡₁ S)
    as DR5.
  { ins.
    arewrite (⦗eq w⦘ ≡ ⦗ fun _ => True ⦘ ⨾ ⦗eq w⦘).
    2: by apply DR2.
    by rewrite seq_id_l. }

  assert (forall l,
             W_ l ∩₁ eq w ≡₁
             if LocSet.Facts.eq_dec l locw then eq w else ∅) as DR3.
    by basic_solver.

  assert (Ordering.le Ordering.acqrel (wmod ordw) = Rel w)
    as ORDREL.
  { unfold is_rel, mode_le, mod; rewrite WPARAMS; destruct ordw; simpls. }

  red in SIMTVIEW; desf.
  red in CUR; desf.
  red in ACQ; desf.
  red in REL; desf.
  cdes HELPER; clear FROM.
  red in SIMMSG; desf.
  red; splits; intros l; simpls;
    unfold LocFun.find, TimeMap.join in *; try (rewrite ORDREL).
  { eapply max_value_same_set.
    2: apply t_cur_urr_union_eqv; auto; revert PRC; basic_solver.
    unfold CombRelations.t_cur, CombRelations.c_cur in CUR.
    eapply max_value_join; eauto.
    eapply max_value_same_set; [|eapply DR2].
    eapply max_value_same_set; [|eapply DR1].
    eapply max_value_same_set; [|eapply DR3].
    unfold TimeMap.singleton, LocFun.add, LocFun.find, LocFun.init.
    destruct (LocSet.Facts.eq_dec l locw); simpls; subst.
    { by apply max_value_singleton. }
    apply max_value_empty; intros x HH; desf. }
  { eapply max_value_same_set.
    2: apply t_acq_urr_union_eqv; auto; revert PRC; basic_solver.
    unfold CombRelations.t_acq, CombRelations.c_acq in ACQ.
    eapply max_value_join; eauto.
    eapply max_value_same_set; [|eapply DR5].
    eapply max_value_same_set; [|eapply DR1].
    eapply max_value_same_set; [|eapply DR3].
    unfold TimeMap.singleton, LocFun.add, LocFun.find, LocFun.init.
    destruct (LocSet.Facts.eq_dec l locw); simpls; subst.
    { by apply max_value_singleton. }
    apply max_value_empty; intros x HH; desf. }
  { intros l0; eapply max_value_same_set; [|eapply t_rel_w_union_eqv; eauto]; cycle 2.
    3: by apply urr_refl.
{
ins.
rewrite ((urr_rel_n_f_alt_union_eqv WF) sc Wf_sc l1 l' C w (tid w)); eauto.
basic_solver 42.
revert PRC; basic_solver 42.
}
    unfold TimeMap.join, TimeMap.singleton,View.singleton_ur,
    LocFun.add, LocFun.find, LocFun.init.
    destruct (LocSet.Facts.eq_dec l locw); simpls; subst.
    destruct (Rel w); simpls; eapply max_value_join; eauto.
    all: unfold LocFun.find, LocFun.init, TimeMap.singleton, LocFun.add.
    all: destruct (Loc.eq_dec l0 locw).
    1,3: by apply max_value_singleton; auto.
    all: by apply max_value_empty; auto. }
Qed.

Lemma sim_tview_f_issued f_to f_to' T tview thread
      (TCCOH : tc_coherent G sc T)
      (IMMCON : imm_consistent G sc)
      (RELCOV : W ∩₁ Rel ∩₁ issued T ⊆₁ covered T)
      (ISSEQ : forall e (ISS: issued T e), f_to' e = f_to e)
      (SIMTVIEW : sim_tview (covered T) f_to tview thread):
  sim_tview (covered T) f_to' tview thread.
Proof using WF.
  cdes SIMTVIEW.
  red; splits; red; ins; eapply max_value_new_f.
  1, 3, 5: by eauto.
  { intros x H. apply t_cur_covered in H; auto. }
  { intros x H. apply t_acq_covered in H; auto. }
  intros x [H|H].
  { apply t_rel_covered in H; auto. }
  destruct (classic (l = l')) as [LEQ|LNEQ].
  2: by rewrite Loc.eq_dec_neq in H; desf.
  apply ISSEQ.
  subst; rewrite Loc.eq_dec_eq in H.
  generalize (w_covered_issued TCCOH).
  revert H; basic_solver 21.
Qed.

Lemma sim_sc_fence_step
      T f_to
      f ordf ordr ordw tview thread sc_view
      (TCCOH : tc_coherent G sc T)
      (RELCOV : W ∩₁ Rel ∩₁ issued T ⊆₁ covered T)
      (IMMCON : imm_consistent G sc)
      (NEXT : next G (covered T) f)
      (TID : tid f = thread)
      (FPARAMS : lab f = Afence ordf)
      (SAME_MOD : fmod ordf ordr ordw)
      (SIMTVIEW : sim_tview (covered T) f_to tview thread)
      (SC_VIEW :
         forall (l : Loc.t),
           max_value f_to (S_tm G l (covered T)) (LocFun.find l sc_view)) :
  forall l : Loc.t,
    max_value f_to (S_tm G l (covered T ∪₁ eq f))
              (LocFun.find
                 l (TView.write_fence_sc
                      (TView.read_fence_tview tview ordr)
                      sc_view ordw)).
Proof using WF.
  cdes IMMCON.
  intros l. specialize (SC_VIEW l).
  destruct (classic (is_sc lab f)) as [FISSC|FISNOSC].
  all: unfold TView.write_fence_sc.
  { assert (Ordering.le Ordering.seqcst ordw /\
            Ordering.le Ordering.acqrel ordr) as [LLW LLR].
    { red in SAME_MOD.
      unfold is_sc, mod in FISSC. rewrite FPARAMS in FISSC.
      desf; desf. }
    unfold TView.read_fence_tview.
    rewrite LLW, LLR; simpls.
    unfold LocFun.find, TimeMap.join.
    eapply max_value_same_set.
    2: by eapply s_tm_cov_sc_fence; eauto.
    eapply max_value_join.
    3: by eauto.
    { done. }
    apply SIMTVIEW. }
  assert (covered T ⊆₁ covered T ∪₁ eq f) as CCC.
  { basic_solver. }
  eapply max_value_same_set.
  2: apply s_tm_n_f_steps.
  3: by apply CCC.
  2: by apply TCCOH.
  2: by intros r COVEQ COVT [FF FF']; destruct COVEQ; subst.
  assert (~ Ordering.le Ordering.seqcst ordw) as LL; [|by desf].
  intros H. subst.
  assert (ordw = Ordering.seqcst) as SS.
  { destruct ordw; desf. }
  unfold is_sc, mod in FISNOSC.
  red in SAME_MOD; simpls;
    rewrite FPARAMS in *; simpls.
  destruct ordf; desf.
Qed.

Lemma sim_tview_fence_step T
      f_to
      f ordf ordr ordw tview thread sc_view
      (TCCOH : tc_coherent G sc T)
      (RELCOV : W ∩₁ Rel ∩₁ issued T ⊆₁ covered T)
      (IMMCON : imm_consistent G sc)
      (COV : coverable G sc T f)
      (NCOV : ~ covered T f)
      (TID : tid f = thread)
      (SAME_MOD : fmod ordf ordr ordw)
      (FPARAMS : lab f = Afence ordf)
      (SIMTVIEW : sim_tview (covered T) f_to tview thread)
      (SC_VIEW :
         ~ (E∩₁F∩₁Sc ⊆₁ (covered T)) ->
         forall (l : Loc.t),
           max_value f_to (S_tm G l (covered T)) (LocFun.find l sc_view)) :
  sim_tview (covered T ∪₁ eq f) f_to
    (TView.write_fence_tview
       (TView.read_fence_tview tview ordr)
       sc_view ordw) (tid f).
Proof using WF.
  cdes IMMCON.
  assert (is_f lab f) as FENCE.
  { by unfold is_f; rewrite FPARAMS. }
  assert (E f) as EF.
  { apply COV. }
  red; splits.
  all: unfold TView.read_fence_tview, TView.write_fence_tview,
    TView.write_fence_sc; simpls.
  all: red; simpls.
  { intros l.
    eapply max_value_same_set.
    2: apply t_cur_fence_step; eauto.
    red in SAME_MOD.
    unfold is_sc, is_acq, mod; rewrite FPARAMS in *.
    destruct ordf; simpls; destruct SAME_MOD; subst.
    all: desf; simpls.
    1-5: by apply SIMTVIEW.
    unfold set_union; unfold LocFun.find.
    eapply max_value_join.
    { apply SC_VIEW.
      intros H. apply NCOV. apply H; split; [split|]; auto.
      unfold is_sc, mod. by rewrite FPARAMS. }
    { by apply SIMTVIEW. }
    basic_solver. }
  { intros l.
    eapply max_value_same_set.
    2: by apply t_acq_fence_step.
    red in SAME_MOD.
    unfold is_sc, is_acq, mod; rewrite FPARAMS in *.
    destruct ordf; simpls; destruct SAME_MOD; subst.
    all: desf; simpls.
    1-5: unfold LocFun.find, TimeMap.join, TimeMap.bot; simpls.
    1-5: eapply max_value_join; eauto; [|apply max_value_empty; intros x H; desf].
    1-5: by apply SIMTVIEW.
    rewrite TimeMap.join_comm, TimeMap.join_assoc, TimeMap.join_comm.
    eapply max_value_join; eauto.
    { rewrite TimeMap.le_join_r; [by apply SIMTVIEW|].
      apply TimeMap.le_PreOrder. }
    apply SC_VIEW.
    intros H. apply NCOV. apply H; split; [split|]; auto.
    unfold is_sc, mod. by rewrite FPARAMS. }
  intros l' l.
  eapply max_value_same_set; [| by eapply t_rel_fence_step].
  red in SAME_MOD.
  unfold is_sc, is_acq, is_acqrel, is_rel, mod; rewrite FPARAMS in *.
  destruct ordf; simpls; destruct SAME_MOD; subst.
  all: cdes SIMTVIEW; red in REL.
  all: desf; simpls.
  unfold LocFun.find, TimeMap.join, TimeMap.bot; simpls.
  eapply max_value_join; eauto.
  apply SC_VIEW.
  intros H. apply NCOV. apply H; split; [split|]; auto.
  unfold is_sc, mod. by rewrite FPARAMS.
Qed.

Lemma sim_tview_other_thread_step f_to
      C C' tview thread
      (CINIT : is_init ∩₁ E ⊆₁ C)
      (CINCL : C ⊆₁ C')
      (CE : C' ⊆₁ E)
      (COVSTEP : forall a, tid a = thread -> C' a -> C a)
      (SIMTVIEW : sim_tview C f_to tview thread) :
  sim_tview C' f_to tview thread.
Proof using.
  red; splits; red; splits; ins.
  all: eapply max_value_same_set.
  all: try by (apply SIMTVIEW).
  { apply t_cur_other_thread; eauto. }
  { apply t_acq_other_thread; eauto. }
  apply t_rel_if_other_thread; eauto.
Qed.

End ViewRel.


(** Defines the notion of a "distributed execution with crashes", and some
derived notions/lemmas. *)
From Perennial.program_logic Require Export language crash_lang.
From iris.prelude Require Import options.

Section dist_language.
  Context {Λ: language}.
  Context {CS: crash_semantics Λ}.

  Record dist_node :=
    { boot : expr Λ;
      tpool : list (expr Λ);
      local_state : state Λ }.

  Record node_init_cfg :=
    { init_restart : expr Λ;
      init_thread : expr Λ;
      init_local_state : state Λ }.

  Definition dist_cfg : Type := list dist_node * global_state Λ.

  Inductive dist_step : dist_cfg → list (observation Λ) → dist_cfg → Prop :=
  | dist_step_machine ρ1 κs ρ2 m eb t1 σ1 t2 σ2 :
      ρ1.1 !! m = Some {| boot := eb; tpool := t1; local_state := σ1 |} →
      ρ2.1 = <[ m := {| boot := eb; tpool := t2; local_state := σ2|}]> ρ1.1 →
      step (t1, (σ1,ρ1.2)) κs (t2, (σ2,ρ2.2)) →
      dist_step ρ1 κs ρ2
  | dist_step_crash ρ1 ρ2 m eb σ1 σ2 tp :
      ρ1.1 !! m = Some {| boot := eb; tpool := tp; local_state := σ1 |} →
      ρ2.1 = <[ m := {| boot := eb; tpool := [eb]; local_state := σ2 |}]> ρ1.1 →
      ρ2.2 = ρ1.2 →
      crash_prim_step CS σ1 σ2 →
      dist_step ρ1 [] ρ2.

  Inductive dist_nsteps : nat → dist_cfg → list (observation Λ) → dist_cfg → Prop :=
    | dist_nsteps_refl ρ :
       dist_nsteps 0 ρ [] ρ
    | dist_nsteps_l n ρ1 ρ2 ρ3 κ κs :
       dist_step ρ1 κ ρ2 →
       dist_nsteps n ρ2 κs ρ3 →
       dist_nsteps (S n) ρ1 (κ ++ κs) ρ3.
  Local Hint Constructors dist_nsteps : core.

  Definition erased_dist_step (ρ1 ρ2 : dist_cfg) := ∃ κ, dist_step ρ1 κ ρ2.

  Lemma erased_dist_steps_nsteps ρ1 ρ2 :
    rtc erased_dist_step ρ1 ρ2 ↔ ∃ n κs, dist_nsteps n ρ1 κs ρ2.
  Proof.
    split.
    - induction 1; firstorder eauto.
    - intros (n & κs & Hsteps). unfold erased_dist_step.
      induction Hsteps; eauto using rtc_refl, rtc_l.
  Qed.

  Definition not_stuck_node (dn: dist_node) (g: global_state Λ) :=
    ∀ e, e ∈ tpool dn → not_stuck e (local_state dn) g.

  (* Generate a dist_cfg from:
     (1) a list of init program, boot program, and initial local state for each node
     (2) a global state.
     Starting thread pool on each node is a single thread running the initial program *)
  Definition starting_dist_cfg (eσs : list node_init_cfg) g : dist_cfg :=
    (map (λ ρ, {| boot := init_restart ρ;
                  local_state := init_local_state ρ;
                  tpool := [init_thread ρ] |}) eσs, g).

End dist_language.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                           Arbitration_Specif.v                           *)
(****************************************************************************)

Require Export Arbiter4_Specif.
Require Export Arbitration.
Require Export PriorityDecode_Proof.
Require Export Timing_Proof.
Require Import Timing_Arbiter.

Set Implicit Arguments.
Unset Strict Implicit.

Section Arbitration_Specification.

  Let Input_type :=
    (bool * (d_list bool 4 * (d_list bool 4 * d_list (d_list bool 2) 4)))%type.

  Let Output_type :=
    (d_list bool 3 * d_list bool 3 * (d_list bool 3 * d_list bool 3))%type.

(** The automaton describing the behaviour of ARBITER has 5 states **)

  Inductive label_A : Set :=
    | WAIT_BEGIN_A : label_A
    | TRIGGER_A : label_A
    | START_A : label_A
    | ACTIVE_A : label_A
    | NOT_TRIGGER_A : label_A.

  Definition STATE_A : Set :=
    (label_A *
     (d_list (bool * bool) 4 * (d_list bool 4 * d_list (d_list bool 4) 4)))%type.

(** Automaton describing the transitions from a state to another **)

  Definition Trans_Arbitration (i : Input_type) (s : STATE_A) : STATE_A :=
    let (fs, t) := i in
    let (act, p') := t in
    let (pri, route) := p' in
    let (s', t) := s in
    let (g, p) := t in
    let (d, l) := p in
    match s' with
    | WAIT_BEGIN_A =>
        match fs with
        | true =>
            (START_A, (g, (l4_tttt, Convert_and_filter (act, (pri, route)))))
        | false =>
            (WAIT_BEGIN_A, (g, (d, Convert_and_filter (act, (pri, route)))))
        end
    | TRIGGER_A =>
        match fs with
        | true =>
            (START_A, (g, (l4_tttt, Convert_and_filter (act, (pri, route)))))
        | false =>
            (WAIT_BEGIN_A, (g, (d, Convert_and_filter (act, (pri, route)))))
        end
    | START_A =>
        match fs with
        | true =>
            (START_A, (g, (l4_tttt, Convert_and_filter (act, (pri, route)))))
        | false =>
            match Ackor act with
            | true =>
                (ACTIVE_A, (g, (d, Convert_and_filter (act, (pri, route)))))
            | false =>
                (START_A,
                (g, (l4_tttt, Convert_and_filter (act, (pri, route)))))
            end
        end
    | ACTIVE_A =>
        match fs with
        | true =>
            (START_A, (g, (l4_tttt, Convert_and_filter (act, (pri, route)))))
        | false =>
            match Ackor (d_map (Ackor (n:=3)) l) with
            | true =>
                (TRIGGER_A,
                (d_Map_List4_pdt_Grant l g,
                (Output_requested l, Convert_and_filter (act, (pri, route)))))
            | false =>
                (NOT_TRIGGER_A,
                (g, (d, Convert_and_filter (act, (pri, route)))))
            end
        end
    | NOT_TRIGGER_A =>
        match fs with
        | true =>
            (START_A, (g, (l4_tttt, Convert_and_filter (act, (pri, route)))))
        | false =>
            (NOT_TRIGGER_A, (g, (d, Convert_and_filter (act, (pri, route)))))
        end
    end.

(** The output function returns the result of ARBITRATION **)

  Definition Out_Arbitration (s : STATE_A) : Output_type :=
    let (_, t) := s in
    let (g, p) := t in
    let (d, _) := p in
    (List3 (fst (Fst_of_l4 g)) (snd (Fst_of_l4 g)) (Fst_of_l4 d),
    List3 (fst (Scd_of_l4 g)) (snd (Scd_of_l4 g)) (Scd_of_l4 d),
    (List3 (fst (Thd_of_l4 g)) (snd (Thd_of_l4 g)) (Thd_of_l4 d),
    List3 (fst (Fth_of_l4 g)) (snd (Fth_of_l4 g)) (Fth_of_l4 d))).

(** States stream **)

  Definition States_ARBITRATION :
    Stream Input_type -> STATE_A -> Stream STATE_A :=
    States_Mealy Trans_Arbitration.

(** Intented behaviour **)

  Definition Behaviour_ARBITRATION := Moore Trans_Arbitration Out_Arbitration.

(** Transformation of Behaviour_ARBITRATION to a Mealy automaton **)

  Definition Out_Arbitration_Mealy :=
    Out_Mealy (Input_type:=Input_type) Out_Arbitration.

  Lemma equiv_out_Arbitration_Moore_Mealy :
   forall (i : Input_type) (s : STATE_A),
   Out_Arbitration s = Out_Arbitration_Mealy i s.
  auto.
  Qed.

  Lemma Equiv_Arbitration_Moore_Mealy :
   forall (s : STATE_A) (i : Stream Input_type),
   EqS (Behaviour_ARBITRATION i s)
     (Mealy Trans_Arbitration Out_Arbitration_Mealy i s).
  intros s i.
  unfold Behaviour_ARBITRATION in |- *; unfold Out_Arbitration_Mealy in |- *;
   apply Equiv_Moore_Mealy.
  Qed.

(** Invariant definition **)

  Definition R_A (s_A : STATE_A)
    (s : state_id * (label_t * STATE_p) * STATE_a4) : Prop :=
    let (s_tpi, s_a4) := s in
    let (sA, t) := s_A in
    let (_, stp) := s_tpi in
    let (st, s_p) := stp in
    let (sp, l) := s_p in
    let (sa4, p) := s_a4 in
    let (G, p') := t in
    let (D, L) := p' in
    let (g, d) := p in
    (sA = WAIT_BEGIN_A /\ st = START_t /\ sa4 = WAIT_a4 /\ sp = START_p \/
     sA = WAIT_BEGIN_A /\ st = START_t /\ sa4 = WAIT_a4 /\ sp = DECODE_p \/
     sA = START_A /\
     st = WAIT_t /\ sa4 = START_a4 /\ sp = DECODE_p /\ D = l4_tttt \/
     sA = ACTIVE_A /\
     st = ROUTE_t /\ sa4 = START_a4 /\ sp = DECODE_p /\ D = l4_tttt \/
     sA = NOT_TRIGGER_A /\
     st = START_t /\ sa4 = START_a4 /\ sp = DECODE_p /\ D = l4_tttt \/
     sA = TRIGGER_A /\
     st = START_t /\ sa4 = AT_LEAST_ONE_IS_ACTIVE_a4 /\ sp = DECODE_p) /\
    G = g /\ D = d /\ L = l.

(** There is an hypothesis on input signals here **)

  Definition P_A (i : Input_type) (sA : STATE_A)
    (s : state_id * (label_t * STATE_p) * STATE_a4) :=
    let (s_tpi, _) := s in
    let (_, stp) := s_tpi in
    let (st, _) := stp in let (fs, _) := i in P_Timing fs st.

End Arbitration_Specification.


From stdpp Require Import finite.
From trillium.prelude Require Import quantifiers finitary.
From iris.algebra Require Import auth excl csum agree.
From iris.base_logic Require Import invariants.
From iris.proofmode Require Import tactics.
From aneris.prelude Require Import gset_map misc.
From aneris.aneris_lang.state_interp Require Import state_interp.
From aneris.aneris_lang Require Import
     lang resources network events proofmode adequacy.
From aneris.examples Require Export minimal_example_code.

Definition incr_exampleM : Model := model nat (λ m n, n = (m + 1)%nat) 0%nat.

Definition incr_res : cmra := authR (optionUR (csumR (exclR unitO) (agreeR (leibnizO loc)))).

Section resources.
  Context `{!inG Σ incr_res}.

  Definition oloc_to_res (ol : option loc) : option (csum (excl unit) (agree loc)) :=
    match ol with
    | Some l => Some (Cinr (to_agree l))
    | None => Some (Cinl (Excl ()))
    end.

  Definition incrloc_full (γ : gname) (ol : option loc) : iProp Σ :=
    own γ (● oloc_to_res ol).

  Definition incrloc_frag (γ : gname) (ol : option loc) : iProp Σ :=
    own γ (◯ oloc_to_res ol).

  Lemma incloc_create : ⊢ |==> ∃ γ, incrloc_full γ None ∗ incrloc_frag γ None.
  Proof. setoid_rewrite <- own_op; apply own_alloc. apply auth_both_valid; done. Qed.

  Lemma incrloc_agree γ ol ol' : incrloc_full γ ol -∗ incrloc_frag γ ol' -∗ ⌜ol = ol'⌝.
  Proof.
    iIntros "H1 H2".
    iDestruct (own_valid_2 with "H1 H2") as %Hvl.
    apply auth_both_valid_discrete in Hvl as [Hvl1 Hvl2].
    destruct ol; destruct ol'; [| | |done].
    - apply Some_csum_included in Hvl1 as [|[(?&?&?&?)|(?&?&?&?&Hvl1)]]; simplify_eq.
      revert Hvl1; rewrite Some_included_total; intros ->%to_agree_included%leibniz_equiv; done.
    - apply Some_csum_included in Hvl1 as [|[(?&?&?&?&?)|(?&?&?&?&?)]]; simplify_eq.
    - apply Some_csum_included in Hvl1 as [|[(?&?&?&?&?)|(?&?&?&?&?)]]; simplify_eq.
  Qed.

  Lemma incrloc_update γ l :
    incrloc_full γ None -∗ incrloc_frag γ None ==∗ incrloc_full γ (Some l) ∗ incrloc_frag γ (Some l).
  Proof.
    iIntros "H1 H2".
    setoid_rewrite <- own_op.
    iApply (own_update_2 with "H1 H2").
    apply auth_update.
    apply option_local_update.
    apply exclusive_local_update; done.
  Qed.

End resources.

Section proof.
  Context `{!anerisG incr_exampleM Σ, !inG Σ incr_res}.

  Context (ip : ip_address).

  Definition ICIname : namespace := nroot .@ "incr".

  Definition incr_inv γ : iProp Σ :=
    inv ICIname ((incrloc_full γ None ∗ alloc_evs "s" [] ∗ frag_st 0%nat) ∨
                 (∃ l (n : nat), incrloc_full γ (Some l) ∗
                    l ↦[ip] #n ∗
                    (∃ σ h, alloc_evs "s" [allocObs ip "s" l #0 σ h] ∗
                        ⌜valid_allocObs ip l σ h⌝) ∗
                    frag_st n)).

  Lemma incr_inv_init γ E :
    incrloc_full γ None -∗ alloc_evs "s" [] -∗ frag_st 0%nat ={E}=∗ incr_inv γ.
  Proof.
    iIntros "? ? ?".
    iApply inv_alloc; iNext; iLeft; iFrame.
  Qed.

  Lemma WP_incr_loop γ l :
    {{{incr_inv γ ∗ incrloc_frag γ (Some l) }}} incr_loop #l @[ip] {{{ RET #(); False }}}.
  Proof.
    iIntros (Φ) "#[Hinv Hl] _".
    iLöb as "IH".
    rewrite /incr_loop.
    wp_pures.
    wp_bind (!_)%E.
    iInv ICIname as "[[>H _]|H]" "Hcl".
    { iDestruct (incrloc_agree with "H Hl") as %?; done. }
    iDestruct "H" as (l' n) "(>Hfl & Hln & Hev & Hfg)".
    iDestruct (incrloc_agree with "Hfl Hl") as %?; simplify_eq.
    wp_load.
    iMod ("Hcl" with "[Hfl Hln Hev Hfg]") as "_".
    { iRight; iExists _, _; iFrame. }
    iModIntro.
    wp_pures.
    wp_bind (CAS _ _ _).
    iInv ICIname as "[[>H _]|H]" "Hcl".
    { iDestruct (incrloc_agree with "H Hl") as %?; done. }
    iDestruct "H" as (l' m) "(>Hfl & Hln & Hev & >Hfg)".
    iDestruct (incrloc_agree with "Hfl Hl") as %?; simplify_eq.
    destruct (decide (n = m)) as [->|].
    - iApply aneris_wp_atomic_take_step_model.
      iModIntro.
      iExists _, (m + 1)%nat; iFrame; iSplit.
      { iPureIntro; right; done. }
      wp_cas_suc.
      iIntros "Hfg".
      iApply fupd_mask_intro; first done.
      iIntros "_".
      iMod ("Hcl" with "[Hfl Hln Hev Hfg]") as "_".
      { replace #(m + 1) with #(m + 1)%nat by by repeat f_equal; lia.
        iRight; iExists _, _; iFrame. }
      iModIntro.
      do 2 wp_pure _; done.
    - wp_cas_fail.
      { intros ?; simplify_eq. }
      iMod ("Hcl" with "[Hfl Hln Hev Hfg]") as "_".
      { iRight; iExists _, _; iFrame. }
      iModIntro.
      do 2 wp_pure _; done.
  Qed.

  Lemma WP_incr_example γ :
    {{{incr_inv γ ∗ incrloc_frag γ None }}} incr_example @[ip] {{{ RET #(); False }}}.
  Proof.
    iIntros (Φ) "[#Hinv Hl] _".
    rewrite /incr_example.
    wp_bind (ref<<_>> _)%E.
    iInv ICIname as "[H|H]" "Hcl"; last first.
    { iDestruct "H" as (? ?) "[>H _]".
      iDestruct (incrloc_agree with "H Hl") as %?; done. }
    iDestruct "H" as "(Hfl & Hev & Hfg)".
    wp_apply (aneris_wp_alloc_tracked with "Hev").
    iIntros (l h σ) "(Hl0 & Hev1 & Hev2)".
    iMod (incrloc_update with "Hfl Hl") as "[Hfl #Hl]".
    iMod ("Hcl" with "[Hfl Hl0 Hev1 Hev2 Hfg]") as "_".
    { iNext; iRight. iExists _, _; iFrame; eauto. }
    iModIntro.
    wp_pures.
    wp_apply aneris_wp_fork.
    iSplitL.
    - iNext.
      wp_pures.
      iApply WP_incr_loop; [by iFrame "#"|].
      iNext; iIntros "?"; done.
    - iNext.
      iApply WP_incr_loop; [by iFrame "#"|].
      iNext; iIntros "?"; done.
  Qed.

End proof.

Definition heap_grows (c c' : cfg aneris_lang) : Prop :=
  dom c.2.(state_heaps) ⊆ dom c'.2.(state_heaps) ∧
  ∀ ip h h',
    c.2.(state_heaps) !! ip = Some h →
    c'.2.(state_heaps) !! ip = Some h' →
    dom h ⊆ dom h'.

Global Instance heap_grows_PreOder : PreOrder heap_grows.
Proof.
  rewrite /heap_grows; split; first by intros ?; set_solver.
  intros c1 c2 c3 [Hc121 Hc122] [Hc231 Hc232].
  split; first set_solver.
  intros ip h h' Hh Hh'.
  assert (is_Some (c2.2.(state_heaps) !! ip)) as [h'' Hh''].
  { apply elem_of_dom. apply elem_of_dom_2 in Hh. set_solver. }
  set_solver.
Qed.

Lemma valid_exec_heap_grows (ex : execution_trace aneris_lang) :
  valid_exec ex → trace_steps (λ x _ y, heap_grows x y) ex.
Proof.
  induction ex as [c|ex IHex c']; first by constructor.
  intros Hexvl.
  eapply valid_exec_exec_extend_inv in Hexvl as [Hecvl (c & <-%last_eq_trace_ends_in & Hstep)].
  econstructor; [done| |by apply IHex].
  rewrite /heap_grows.
  inversion Hstep as [????????? Htrl ? Hpstep|????? Htrl ? Hcfgstep]; simplify_eq/=; last first.
  { rewrite Htrl; simpl in *.
    inversion Hcfgstep; simpl in *; set_solver. }
  rewrite Htrl; simpl in *.
  inversion Hpstep as [????? Hhstep]; simplify_eq/=.
  inversion Hhstep as [??????? Hbstep|ip' ??????? Hbstep|ip' |]; simplify_eq/=.
  - inversion Hbstep; simplify_eq/=; set_solver.
  - rewrite dom_insert.
    split; first set_solver.
    intros ip.
    destruct (decide (ip = ip')) as [->|].
    + rewrite lookup_insert; intros ????; simplify_eq/=.
      inversion Hbstep; simplify_eq/=; set_solver.
    + rewrite lookup_insert_ne; last done; set_solver.
  - rewrite dom_insert.
    split; first set_solver.
    intros ip.
    destruct (decide (ip = ip')) as [->|].
    + rewrite lookup_insert; intros ????; simplify_eq/=.
    + rewrite lookup_insert_ne; last done; set_solver.
  - set_solver.
Qed.

Definition incr_sim ip (ex : execution_trace aneris_lang) (atr : finite_trace nat ()) : Prop :=
  trace_length ex = trace_length atr ∧
  ((events_of_trace (allocEV "s") ex = [] ∧ ∀ i n, atr !! i = Some n → n = 0)%nat ∨
  (∃ l (n : nat),
      (∃ σ h, events_of_trace (allocEV "s") ex = [allocObs ip "s" l #0 σ h] ∧
              valid_allocObs ip l σ h) ∧
      ∃ h,
        (trace_last ex).2.(state_heaps) !! ip = Some h ∧
        h !! l = Some #n ∧
        trace_last atr = n ∧
        (∀ i c h' v,
            ex !! i = Some c →
            state_heaps c.2 !! ip = Some h' →
            h' !! l = Some v →
            ∃ (m : nat), v = #m ∧ atr !! i = Some m ∧ m ≤ n) ∧
        (∀ m, m ≤ n → ∃ i c h',
              ex !! i = Some c ∧ state_heaps c.2 !! ip = Some h' ∧ h' !! l = Some #m ∧
              atr !! i = Some m)))%nat.

Definition init_state ip := {|
  state_heaps :=  {[ip := ∅ ]};
  state_sockets := {[ip := ∅ ]};
  state_ms := ∅; |}.

Lemma incr_exampleM_finitary : aneris_model_rel_finitary incr_exampleM.
Proof.
  intros n.
  apply finite_smaller_card_nat.
  apply sig_finite_eq1.
Qed.

Lemma gcounter_adequacy ip :
  @continued_simulation aneris_lang (aneris_to_trace_model incr_exampleM)
    (incr_sim ip)
    {tr[ ([mkExpr ip incr_example], init_state ip) ]}
    {tr[ 0%nat ]}.
Proof.
  eapply (simulation_adequacy #[anerisΣ incr_exampleM; GFunctor incr_res] incr_exampleM
                              NotStuck ∅ {["s"]} ∅ ∅ ∅ (λ _, True) _ ip).
  { set_solver. }
  { set_solver. }
  { apply aneris_sim_rel_finitary, incr_exampleM_finitary. }
  { set_solver. }
  { set_solver. }
  { set_solver. }
  { set_solver. }
  iIntros (?) "!#".
  iExists (λ _, True)%I.
  iIntros "_ _ _ #? Hevs _ _ _ _ Hfg".
  rewrite big_sepS_singleton.
  assert (inG #[ anerisΣ incr_exampleM; GFunctor incr_res] incr_res).
  { assert (subG (GFunctor incr_res) #[ anerisΣ incr_exampleM; GFunctor incr_res]).
    apply _. solve_inG. }
  iMod incloc_create as (γ) "[Hf Hl]".
  iMod (incr_inv_init ip with "Hf Hevs Hfg") as "#Hinv".
  iModIntro.
  iSplit; [done|].
  iSplitL.
  { iPoseProof (WP_incr_example _ _ (λ _, True)%I with "[$Hl//] []") as "H".
    - iNext; iIntros "?"; done.
    - rewrite aneris_wp_unfold /aneris_wp_def.
      iApply (wp_wand with "[H]"); first by iApply "H".
      auto. }
  iIntros (ex atr c Hvs Hexs Hatrs Hexe Hcntr _) "(Hevs & HSI & Hmdl & %Hvalid & Hsteps) _".
  destruct (valid_system_trace_start_or_contract ex atr) as [[-> ->]|Hcontr]; first done.
  { erewrite !first_eq_trace_starts_in; [|eassumption|eassumption].
    iMod fupd_mask_subseteq as "_"; [|iModIntro]; first done.
    iPureIntro.
    split; [done|].
    left; split.
    - rewrite events_of_singleton_trace; done.
    - intros [] ? ?; simplify_eq/=; done. }
  destruct Hcontr as (ex' & atr' & oζ & ℓ & Hex' & Hatr').
  specialize (Hcntr ex' atr' oζ ℓ Hex' Hatr') as [Hlen Hmrel].
  rewrite /incr_sim.
  destruct atr as [|atr m]; first by apply not_trace_contract_singleton in Hatr'.
  apply trace_contract_of_extend in Hatr'; simplify_eq.
  destruct ex as [|ex oζ' c']; first by apply not_trace_contract_singleton in Hex'.
  apply trace_contract_of_extend in Hex'; simplify_eq.
  iInv ICIname as ">[H|H]" "_"; iApply fupd_mask_intro_discard; [set_solver| |set_solver|].
  - iDestruct "H" as "(Hfl & Haev & Hfg)".
    rewrite /incr_sim.
    simpl.
    destruct Hex' as [-> ->]. destruct Hatr' as [-> ->].
    iSplit; [rewrite /= Hlen //|].
    iLeft.
    iDestruct "Hevs" as (? ? lbls) "(_ & _ & _ & _ & _ & Hevs)".
    iDestruct (alloc_evs_lookup with "Hevs Haev") as %Haevlu.
    apply lookup_fn_to_gmap in Haevlu as [Haevs _].
    rewrite Haevs.
    iSplit; first done.
    iIntros (i n Hin).
    destruct (decide (i = trace_length atr)).
    + rewrite trace_lookup_last in Hin; last by simpl in *; lia.
      simplify_eq. simpl.
      iDestruct (auth_frag_st_agree with "Hmdl Hfg") as %->; done.
    + destruct (events_of_trace_extend_app (allocEV "s") ex c' oζ) as (evs & Hevslen & Hevs & _).
      { eapply valid_system_trace_valid_exec_trace; done. }
      rewrite Haevs in Hevs.
      symmetry in Hevs; apply app_eq_nil in Hevs as [Hevs _].
      pose proof (trace_lookup_lt_Some_1 _ _ _ Hin); simpl in *.
      rewrite trace_lookup_extend_lt in Hin; last lia.
      destruct Hmrel as [Hmrel|Hmrel]; last first.
      { rewrite Hevs in Hmrel. destruct Hmrel as (?&?&(?&?&?&?)&?); done. }
      iPureIntro.
      by eapply Hmrel.
  - iDestruct "H" as (l n) "(Hfl & Hln & Haev & Hfg)".
    iDestruct "Haev" as (σ h) "[Haev %Haevvl]".
    destruct Hex' as [-> ->]. destruct Hatr' as [-> ->].
    iSplit; [rewrite /= Hlen //|].
    iRight.
    iDestruct "Hevs" as (? ? lbls) "(_ & _ & _ & _ & _ & Hevs)".
    iDestruct (alloc_evs_lookup with "Hevs Haev") as %Haevlu.
    apply lookup_fn_to_gmap in Haevlu as [Haevs _].
    rewrite Haevs.
    iExists l, n.
    iSplit; first by eauto.
    iDestruct (aneris_state_interp_heap_valid with "HSI Hln") as %(h'&Hh'&Hh'ln).
    iExists _.
    iSplit; first done.
    iSplit; first done.
    iDestruct (auth_frag_st_agree with "Hmdl Hfg") as %Hst.
    destruct (events_of_trace_extend_app (allocEV "s") ex c' oζ) as (evs & Hevslen & Hevs & Hevs').
    { eapply valid_system_trace_valid_exec_trace; done. }
    iPureIntro.
    rewrite Haevs in Hevs.
    destruct (events_of_trace (allocEV "s") ex) as [|aev evs'] eqn:Haevseq.
    + destruct Hmrel as [Hmrel|Hmrel]; last first.
      { destruct Hmrel as (?&?&(?&?&?&?)&?); done. }
      assert (trace_last atr = 0) as Hatrlast.
      { apply Hmrel with (pred (trace_length atr)). apply trace_lookup_last.
        pose proof (trace_length_at_least atr); simpl in *; lia. }
      simplify_eq/=.
      split; first done.
      edestruct Hevs' as (K & tp1 & tp2 & efs & Hpres & Hpree & Hposts & Hposte);
        first by apply elem_of_list_singleton.
      simplify_eq/=.
      rewrite Hposts /= lookup_insert in Hh'; simplify_eq/=.
      rewrite lookup_insert in Hh'ln; simplify_eq/=.
      assert (n = 0) as -> by lia.
      split; last first.
      { intros m Hm.
        assert (m = 0) as -> by lia.
        eexists (trace_length ex), _, _.
        rewrite !trace_lookup_last //=; last rewrite Hlen //.
        split; first done.
        rewrite Hposts /= lookup_insert.
        split; first done.
        rewrite lookup_insert; done. }
      intros i c'' h' v Hi Hh' Hv.
      pose proof (trace_lookup_lt_Some_1 _ _ _ Hi); simpl in *.
      destruct (decide (i = trace_length ex)) as [->|].
      * rewrite trace_lookup_last in Hi; last done.
        simplify_eq/=.
        rewrite Hposts /= lookup_insert in Hh'.
        simplify_eq/=.
        rewrite lookup_insert in Hv; simplify_eq.
        eexists 0; split; first done.
        rewrite trace_lookup_last; simpl; eauto with lia.
      * assert (heap_grows c'' (trace_last ex)) as [_ Hheaps].
        { rewrite -rt_rtc_same.
          apply valid_system_trace_valid_exec_trace in Hvs.
          pose proof (trace_length_at_least ex).
          eapply (trace_steps_lookup
                    _ _ (valid_exec_heap_grows _ Hvs)
                    i (pred (trace_length ex)) c'' (trace_last ex)).
          - pose proof (trace_length_at_least ex).
            (* lia bug!? *)
            apply PeanoNat.Nat.lt_le_pred.
            apply Nat.le_neq; split; last done.
            apply lt_n_Sm_le; done.
          - done.
          - rewrite trace_lookup_extend_lt; last first.
            { apply lt_pred_n_n. eauto. }
            rewrite trace_lookup_last; [done|].
            rewrite -(S_pred _ 0) //. }
        destruct Haevvl as [Haevvl1 Haevvl2].
        specialize (Hheaps _ _ _ Hh' Haevvl1).
        assert (is_Some (h !! l)) as [? ?]; last by simplify_eq.
        apply (elem_of_dom (D := gset loc)).
        apply (elem_of_dom_2 (D := gset loc)) in Hv.
        set_solver.
    + simplify_eq Hevs; clear Hevs; intros <- Hevs.
      symmetry in Hevs; apply app_eq_nil in Hevs as [? ?]; simplify_eq/=.
      split; first done.
      destruct Hmrel as [Hmrel|Hmrel].
      { destruct Hmrel as [? ?]; done. }
      destruct Hmrel as (l' & k & Hl' & Hatrk & h'' & Hh'' & Hh''l'k & Hrel1 & Hrel2).
      destruct Hl' as (σ' & h3 & Haevs' & [Haevvl'1 Haevvl'2]).
      destruct Haevvl as [Haevvl1 Haevvl2].
      simplify_eq /=.
      assert (trace_last atr ≤ n ≤ trace_last atr + 1).
      { simpl in *. rewrite /user_model_evolution /= in Hvalid. lia. }
      split.
      * intros i c'' h4 v Hc'' Hh4 Hv.
        destruct (decide (i < trace_length ex)).
        -- rewrite trace_lookup_extend_lt in Hc''; last done.
           rewrite trace_lookup_extend_lt; last lia.
           destruct (Hrel1 i c'' h4 v) as (m' & ? & ? & ?); [done|done|done|]; simplify_eq.
           eauto with lia.
        -- pose proof (trace_lookup_lt_Some_1 _ _ _ Hc''); simpl in *.
           assert (i = trace_length ex) as ->. (* lia bug! *)
           { assert (i ≤ trace_length ex) by by apply lt_n_Sm_le. lia. }
           rewrite trace_lookup_extend; last by simpl in *; lia.
           rewrite trace_lookup_extend in Hc''; last done.
           simplify_eq; eauto.
      * intros m Hm.
        destruct (decide (m = n)) as [->|].
        { eexists (trace_length ex), _, _.
          repeat (rewrite trace_lookup_extend; last solve [lia|done]); done. }
        destruct (Hrel2 m) as (i & ? & ? & Hexi & ? & ? & ?); first lia.
        pose proof (trace_lookup_lt_Some_1 _ _ _ Hexi).
        eexists i, _, _.
        rewrite trace_lookup_extend_lt; last first.
        { assert (trace_length ex = trace_length atr) as <-. lia. done. }
        rewrite trace_lookup_extend_lt; done.
Qed.


From mathcomp Require Import
  ssreflect ssrfun ssrbool eqtype ssrnat seq choice ssrint.
From extructures Require Import ord fmap.
From CoqUtils Require Import word.

Require Import lib.utils common.types.

Import DoNotation.

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

Module Concrete.

Local Open Scope word_scope.

Record mvec (mt : machine_types) : Type := MVec {
  cop  : opcode;
  ctpc : mword mt;
  cti  : mword mt;
  ct1  : mword mt;
  ct2  : mword mt;
  ct3  : mword mt
}.

Definition mvec_eqb mt (m1 m2 : mvec mt) : bool :=
  [&& cop m1 == cop m2,
      ctpc m1 == ctpc m2,
      cti m1 == cti m2,
      ct1 m1 == ct1 m2 &
      ct2 m1 == ct2 m2] && (ct3 m1 == ct3 m2).

Lemma mvec_eqbP mt : Equality.axiom (@mvec_eqb mt).
Proof.
  move => m1 m2.
  case: m1 => *. case: m2 => *.
  apply (iffP andP); simpl.
  - by move => [/and5P [/eqP -> /eqP -> /eqP -> /eqP -> /eqP ->] /eqP ->].
  - move => [-> -> -> -> -> ->]. by rewrite !eqxx.
Qed.

Definition mvec_eqMixin mt := EqMixin (@mvec_eqbP mt).
Canonical mvec_eqType mt :=
  Eval hnf in EqType (mvec mt) (@mvec_eqMixin mt).

Section MVecOrdType.

Variable mt : machine_types.

Definition tuple_of_mvec (mv : mvec mt) :=
  (cop mv, ctpc mv, cti mv, ct1 mv, ct2 mv, ct3 mv).

Definition mvec_of_tuple tup : mvec mt :=
  let: (cop, ctpc, cti, ct1, ct2, ct3) := tup in
  MVec cop ctpc cti ct1 ct2 ct3.

Lemma tuple_of_mvecK : cancel tuple_of_mvec mvec_of_tuple.
Proof. by case. Qed.

Definition mvec_choiceMixin := CanChoiceMixin tuple_of_mvecK.
Canonical mvec_choiceType := Eval hnf in ChoiceType (mvec mt) mvec_choiceMixin.
Definition mvec_ordMixin := CanOrdMixin tuple_of_mvecK.
Canonical mvec_ordType := Eval hnf in OrdType (mvec mt) mvec_ordMixin.

End MVecOrdType.

Record rvec (mt : machine_types) : Type := RVec {
  ctrpc : mword mt;
  ctr   : mword mt
}.

Definition rvec_eqb mt (r1 r2 : rvec mt) : bool :=
  [&& ctrpc r1 == ctrpc r2 & ctr r1 == ctr r2].

Lemma rvec_eqbP mt : Equality.axiom (@rvec_eqb mt).
Proof.
  move => r1 r2.
  case: r1 => *. case: r2 => *.
  apply (iffP andP); simpl.
  - by move => [/eqP -> /eqP ->].
  - move => [-> ->]. by rewrite !eqxx.
Qed.

Definition rvec_eqMixin mt := EqMixin (@rvec_eqbP mt).
Canonical rvec_eqType mt :=
  Eval hnf in EqType (rvec mt) (rvec_eqMixin mt).

Definition rules mt := {fmap mvec mt -> rvec mt}.

Section WithClasses.

Context (mt : machine_types).
Context (ops : machine_ops mt).

Let mvec := mvec mt.
Let rvec := rvec mt.
Let rules := rules mt.
Let atom := atom (mword mt) (mword mt).

(* If we were doing good modularization, these would be abstract! *)
Definition cache_line_addr : mword mt := 0%w.
(* BCP: Call it fault_handler_addr? *)
Definition fault_handler_start : mword mt := as_word 8.
Definition TNone   : mword mt := as_word 8.
Definition TMonitor : mword mt := 0.

Context {spops : machine_ops_spec ops}.

Definition Mop : mword mt := (cache_line_addr + 0)%w.
Definition Mtpc : mword mt := (cache_line_addr + 1)%w.
Definition Mti : mword mt := (cache_line_addr + as_word 2)%w.
Definition Mt1 : mword mt := (cache_line_addr + as_word 3)%w.
Definition Mt2 : mword mt := (cache_line_addr + as_word 4)%w.
Definition Mt3 : mword mt := (cache_line_addr + as_word 5)%w.
Definition Mtrpc : mword mt := (cache_line_addr + as_word 6)%w.
Definition Mtr : mword mt := (cache_line_addr + as_word 7)%w.

Definition mvec_fields := [:: Mop; Mtpc; Mti; Mt1; Mt2; Mt3].
Definition rvec_fields := [:: Mtrpc; Mtr].
Definition mvec_and_rvec_fields := mvec_fields ++ rvec_fields.

Inductive mvec_part : Set :=
  | mvp_tpc : mvec_part
  | mvp_ti  : mvec_part
  | mvp_t1  : mvec_part
  | mvp_t2  : mvec_part
  | mvp_t3  : mvec_part.

Definition DCMask := mvec_part -> bool.

Record CTMask : Set := mkCTMask {
  ct_trpc : option mvec_part;
  ct_tr   : option mvec_part
}.

Record Mask : Set := {
  dc : DCMask; (* don't care *)
  ct : CTMask  (* copy through *)
}.

Definition Masks := bool -> opcode -> Mask.

Definition mask_dc (dcm : DCMask) (mv : mvec) : mvec :=
  let '(MVec op tpc ti t1 t2 t3) := mv in
  MVec op
    (if dcm mvp_tpc then TNone else tpc)
    (if dcm mvp_ti  then TNone else ti)
    (if dcm mvp_t1  then TNone else t1)
    (if dcm mvp_t2  then TNone else t2)
    (if dcm mvp_t3  then TNone else t3).

Definition copy_mvec_part (mv : mvec) (tag : mword mt)
    (x : option mvec_part) : mword mt :=
  match x with
  | Some mvp_tpc => ctpc mv
  | Some mvp_ti  => cti mv
  | Some mvp_t1  => ct1 mv
  | Some mvp_t2  => ct2 mv
  | Some mvp_t3  => ct3 mv
  | None         => tag
  end.

Definition copy (mv : mvec) (rv : rvec) (ctm : CTMask) : rvec :=
  RVec (copy_mvec_part mv (ctrpc rv) (ct_trpc ctm))
         (copy_mvec_part mv (ctr   rv) (ct_tr   ctm)).

Definition is_monitor_tag (tpc:mword mt) : bool := tpc == TMonitor.

Definition cache_lookup (cache : rules)
    (masks : Masks) (mv : mvec) : option rvec :=
  let mask := masks (is_monitor_tag (ctpc mv)) (cop mv) in
  let masked_mv := mask_dc (dc mask) mv in
  do! rv <- getm cache masked_mv;
  Some (copy mv rv (ct mask)).

Local Notation memory := {fmap mword mt -> atom}.
Local Notation registers := {fmap reg mt -> atom}.

Record state := State {
  mem   : memory;
  regs  : registers;
  cache : rules;
  pc    : atom;
  epc   : atom
}.

Definition pcv (s : state) := vala (pc s).
Definition pct (s : state) := taga (pc s).

Lemma state_eta (cst : state) :
  cst = State (mem cst)
                (regs cst)
                (cache cst)
                (pcv cst)@(pct cst)
                (epc cst).
Proof. by case: cst=> ? ? ? [? ?] ?. Qed.

(* Need to do this masking both on lookup, and on rule add, right?
   This is optional; the software could do it *)
Definition add_rule (cache : rules) (masks : Masks) (mem : memory) : option rules :=
  do! aop   <- mem Mop;
  do! atpc  <- mem Mtpc;
  do! ati   <- mem Mti;
  do! at1   <- mem Mt1;
  do! at2   <- mem Mt2;
  do! at3   <- mem Mt3;
  do! atrpc <- mem Mtrpc;
  do! atr   <- mem Mtr;
  do! op    <- op_of_word (vala aop);
  let dcm := dc (masks false op) in
  let mv := mask_dc dcm (MVec op (vala atpc)
                              (vala ati) (vala at1) (vala at2) (vala at3)) in
  Some (setm cache mv (RVec (vala atrpc) (vala atr))).

Definition store_mvec (mem : memory) (mv : mvec) : memory :=
  unionm [fmap (Mop, (word_of_op (cop mv))@TMonitor);
               (Mtpc, (ctpc mv)@TMonitor);
               (Mti, (cti mv)@TMonitor);
               (Mt1, (ct1 mv)@TMonitor);
               (Mt2, (ct2 mv)@TMonitor);
               (Mt3, (ct3 mv)@TMonitor)]
         mem.

Section ConcreteSection.

Variable masks : Masks.

Local Notation "x .+1" := (x + 1)%w.

(* The mvector is written at fixed locations in monitor memory where
   the fault handler can access them (using the same addresses as for
   add_rule: Mop, Mtpc, etc.) *)
Definition miss_state (st : state) (mvec : mvec) : state :=
  let mem' := store_mvec (mem st) mvec in
  State mem' (regs st) (cache st) fault_handler_start@TMonitor (pc st).

(* The next functions build the next state by looking up on the cache,
   finding the appropriate tag values for the results and using those
   combined with its arguments (new register value and/or new pc value
   *)
(* TODO: find better name for these ... lookup? *)
(* BCP: check? *)

Definition next_state (st : state) (mvec : mvec)
                      (k : rvec -> option state) : option state :=
  let lookup := cache_lookup (cache st) masks mvec in
  match lookup with
  | Some rvec => k rvec
  | None => Some (miss_state st mvec)
  end.

Definition next_state_reg_and_pc (st : state) (mvec : mvec) (r : reg mt) x pc' : option state :=
  next_state st mvec (fun rvec =>
    do! reg' <- updm (regs st) r x@(ctr rvec);
    Some (State (mem st) reg' (cache st) pc'@(ctrpc rvec) (epc st))).

Definition next_state_reg (st : state) (mvec : mvec) r x : option state :=
  next_state_reg_and_pc st mvec r x (vala (pc st)).+1.

Definition next_state_pc (st : state) (mvec : mvec) x : option state :=
  next_state st mvec (fun rvec =>
    Some (State (mem st) (regs st) (cache st) x@(ctrpc rvec) (epc st))).

Inductive step (st st' : state) : Prop :=
| step_nop :
    forall mem reg cache pc epc tpc i ti,
    forall (ST : st = State mem reg cache pc@tpc epc),
    forall (PC : mem pc = Some i@ti),
    forall (INST : decode_instr i = Some (Nop _)),
    let mv := MVec NOP tpc ti TNone TNone TNone in
    forall (NEXT : next_state_pc st mv (pc.+1) = Some st'),
      step st st'
| step_const :
    forall mem reg cache pc epc n r tpc i ti old told,
    forall (ST : st = State mem reg cache pc@tpc epc),
    forall (PC : mem pc = Some i@ti),
    forall (INST : decode_instr i = Some (Const n r)),
    forall (OLD : reg r = Some old@told),
    let mv := MVec CONST tpc ti told TNone TNone in
    forall (NEXT : next_state_reg st mv r (swcast n) = Some st'),
      step st st'
| step_mov :
    forall mem reg cache pc epc r1 w1 r2 tpc i ti t1 old told,
    forall (ST : st = State mem reg cache pc@tpc epc),
    forall (PC : mem pc = Some i@ti),
    forall (INST : decode_instr i = Some (Mov r1 r2)),
    forall (REG1 : reg r1 = Some w1@t1),
    forall (OLD : reg r2 = Some old@told),
    let mv := MVec MOV tpc ti t1 told TNone in
    forall (NEXT : next_state_reg st mv r2 w1 = Some st'),
      step st st'
| step_binop :
    forall mem reg cache pc epc op r1 r2 r3 w1 w2 tpc i ti t1 t2 old told,
    forall (ST : st = State mem reg cache pc@tpc epc),
    forall (PC : mem pc = Some i@ti),
    forall (INST : decode_instr i = Some (Binop op r1 r2 r3)),
    forall (REG1 : reg r1 = Some w1@t1),
    forall (REG2 : reg r2 = Some w2@t2),
    forall (OLD : reg r3 = Some old@told),
    let mv := MVec (BINOP op) tpc ti t1 t2 told in
    forall (NEXT : next_state_reg st mv r3 (binop_denote op w1 w2) =
                   Some st'),
      step st st'
| step_load :
    forall mem reg cache pc epc r1 r2 w1 w2 tpc i ti t1 t2 old told,
    forall (ST : st = State mem reg cache pc@tpc epc),
    forall (PC : mem pc = Some i@ti),
    forall (INST : decode_instr i = Some (Load r1 r2)),
    forall (REG1 : reg r1 = Some w1@t1),
    forall (M1 : mem w1 = Some w2@t2),
    forall (OLD : reg r2 = Some old@told),
    let mv := MVec LOAD tpc ti t1 t2 told in
    forall (NEXT : next_state_reg st mv r2 w2 = Some st'),
      step st st'
| step_store :
    forall mem reg cache pc epc r1 r2 w1 w2 w3 tpc i ti t1 t2 t3,
    forall (ST : st = State mem reg cache pc@tpc epc),
    forall (PC : mem pc = Some i@ti),
    forall (INST : decode_instr i = Some (Store r1 r2)),
    forall (REG1 : reg r1 = Some w1@t1),
    forall (REG2 : reg r2 = Some w2@t2),
    forall (M1 : mem w1 = Some w3@t3),
    let mv := MVec STORE tpc ti t1 t2 t3 in
    forall (NEXT :
      next_state st mv (fun rvec =>
        do! mem' <- updm mem w1 w2@(ctr rvec);
        Some (State mem' reg cache (pc.+1)@(ctrpc rvec) epc)) = Some st'),
      step st st'
| step_jump :
    forall mem reg cache pc epc r w tpc i ti t1,
    forall (ST : st = State mem reg cache pc@tpc epc),
    forall (PC : mem pc = Some i@ti),
    forall (INST : decode_instr i = Some (Jump r)),
    forall (REG : reg r = Some w@t1),
    let mv := MVec JUMP tpc ti t1 TNone TNone in
    forall (NEXT : next_state_pc st mv w = Some st'),
      step st st'
| step_bnz :
    forall mem reg cache pc epc r n w tpc i ti t1,
    forall (ST : st = State mem reg cache pc@tpc epc),
    forall (PC : mem pc = Some i@ti),
    forall (INST : decode_instr i = Some (Bnz r n)),
    forall (REG : reg r = Some w@t1),
    let mv := MVec BNZ tpc ti t1 TNone TNone in
    let pc' := pc + if w == 0 then 1 else swcast n in
    forall (NEXT : next_state_pc st mv pc' = Some st'),
      step st st'
| step_jal :
    forall mem reg cache pc epc r w tpc i ti t1 old told,
    forall (ST : st = State mem reg cache pc@tpc epc),
    forall (PC : mem pc = Some i@ti),
    forall (INST : decode_instr i = Some (Jal r)),
    forall (REG : reg r = Some w@t1),
    forall (OLD: reg ra = Some old@told),
    let mv := MVec JAL tpc ti t1 told TNone in
    forall (NEXT : next_state_reg_and_pc st mv ra (pc.+1) w = Some st'),
      step st st'
| step_jumpepc :
    forall mem reg cache pc tpc w tepc i ti,
    forall (ST : st = State mem reg cache pc@tpc w@tepc),
    forall (PC : mem pc = Some i@ti),
    forall (INST : decode_instr i = Some (JumpEpc _)),
    let mv := MVec JUMPEPC tpc ti tepc TNone TNone in
    forall (NEXT : next_state_pc st mv w = Some st'),
      step st st'
| step_addrule :
    forall mem reg cache pc epc tpc i ti,
    forall (ST : st = State mem reg cache pc@tpc epc),
    forall (PC : mem pc = Some i@ti),
    forall (INST : decode_instr i = Some (AddRule _)),
    let mv := MVec ADDRULE tpc ti TNone TNone TNone in
    forall (NEXT :
      next_state st mv (fun rvec =>
        do! cache' <- add_rule cache masks mem;
        Some (State mem reg cache' (pc.+1)@(ctrpc rvec) epc)) = Some st'),
      step st st'
| step_gettag :
    forall mem reg cache pc epc r1 r2 w tpc i ti t1 old told,
    forall (ST : st = State mem reg cache pc@tpc epc),
    forall (PC : mem pc = Some i@ti),
    forall (INST : decode_instr i = Some (GetTag r1 r2)),
    forall (REG : reg r1 = Some w@t1),
    forall (OLD : reg r2 = Some old@told),
    let mv := MVec GETTAG tpc ti t1 told TNone in
    forall (NEXT : next_state_reg st mv r2 t1 = Some st'),
      step st st'
| step_puttag :
    forall mem reg cache pc epc r1 r2 r3 w t tpc i ti t1 t2 old told,
    forall (ST : st = State mem reg cache pc@tpc epc),
    forall (PC : mem pc = Some i@ti),
    forall (INST : decode_instr i = Some (PutTag r1 r2 r3)),
    forall (REG1 : reg r1 = Some w@t1),
    forall (REG2 : reg r2 = Some t@t2),
    forall (OLD: reg r3 = Some old@told),
    let mv := MVec PUTTAG tpc ti t1 t2 told in
    forall (NEXT :
      next_state st mv (fun rvec =>
        do! reg' <- updm reg r3 w@t;
        Some (State mem reg' cache (pc.+1@(ctrpc rvec)) epc)) = Some st'),
      step st st'.

End ConcreteSection.

End WithClasses.

Notation memory mt := {fmap mword mt -> atom (mword mt) (mword mt)}.
Notation registers mt := {fmap reg mt -> atom (mword mt) (mword mt)}.

End Concrete.

Module Exports.

Import Concrete.

Definition state_eqb mt : rel (state mt) :=
  [rel s1 s2 | [&& mem s1 == mem s2,
                   regs s1 == regs s2,
                   cache s1 == cache s2,
                   pc s1 == pc s2 &
                   epc s1 == epc s2] ].

Lemma state_eqbP mt : Equality.axiom (@state_eqb mt).
Proof.
  move => [? ? ? ? ?] [? ? ? ? ?].
  apply (iffP and5P); simpl.
  - by move => [/eqP -> /eqP -> /eqP -> /eqP -> /eqP ->].
  - by move => [-> -> -> -> ->].
Qed.

Definition state_eqMixin mt := EqMixin (@state_eqbP mt).
Canonical state_eqType mt := EqType (state mt) (@state_eqMixin mt).

End Exports.

Export Exports.

Arguments Concrete.State {_} _ _ _ _ _.
Arguments Concrete.TNone {mt}.
Arguments Concrete.TMonitor {mt}.


Require Import Terms.
Require Import LBracketSyntax.
Require Import LThrowBigStep. (* reuse helpers *)

(** * Continuations and partial configurations *)

Inductive Frame : Type :=
| RLet : Var -> Tm -> Frame
| RRet : Env -> Frame
| RBrk : Lab -> Lab -> Frame (* final label + original pc *)
| RCatch : Var -> Tm -> Frame.

Definition Cont := list Frame.

Definition PCfg := prod (prod Lab Env) Cont.

Inductive RCfg : Type :=
| CR : Tm -> RCfg     (* term to be reduced *)
| CA : Atom -> RCfg   (* return atom *)
| CT : Excp -> RCfg.  (* thrown exception *)

Definition Cfg := prod PCfg RCfg.

Definition result_to_rcfg r :=
  match r with
  | Suc a => CA a
  | Throw e => CT e
  end.

(** * Small-step Semantics for LambdaThrow *)

Notation "b @ L" := (b,L) (at level 5).

Notation "<< pc , r , k , X >>" := (((pc, r), k), X) (at level 5).

(** The reduction relation. *)
Definition step (c : Cfg) : Cfg :=
  match c with
  (* s_var *)
  | << pc, rho, k, CR (TVar x) >> =>
    match get rho x with
    | Some a => << pc, rho, k, CA a >>
    | None => << pc, rho, k, CT eUnbound >>
    end
  (* s_const *)
  | << pc, rho, k, CR (TConst c) >> =>
    << pc, rho, k, CA (VConst c)@bot>>
  (* s_let_start *)
  | << pc, rho, k, CR (TLet x t1 t2) >> =>
    << pc, rho, RLet x t2 :: k, CR t1 >>
  (* s_let_bind *)
  | << pc, rho, RLet x t :: k, CA a >> =>
    << pc, (x,a) :: rho, RRet rho :: k, CR t >>
  (* s_let_unwind *)
  | << pc, rho, RLet x t :: k, CT e >> =>
    << pc, rho, k, CT e >>
  (* s_abs *)
  | << pc, rho, k, CR (TAbs x t) >> =>
    << pc, rho, k, CA (VClos rho x t)@bot >>
  (* s_app *)
  | << pc, rho, k, CR (TApp x1 x2) >> =>
    match get rho x1, get rho x2 with
    | Some (VClos rho' x t)@L, Some a =>
      << pc\_/L, (x,a) :: rho', RRet rho :: k, CR t >>
    | Some (v,L), Some a =>
      << pc\_/L, rho, k, CT eType >>
    | _, _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_return *)
  | << pc, rho, RRet rho' :: k, CA a >> =>
    << pc, rho', k, CA a >>
  (* s_return_unwind *)
  | << pc, rho, RRet rho' :: k, CT e >> =>
    << pc, rho', k, CT e >>
  (* s_inx *)
  | << pc, rho, k, CR (TInx d x) >> =>
    match get rho x with
    | Some a =>
      << pc, rho, k, CA (VInx d a)@bot >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_match *)
  | << pc, rho, k, CR (TMatch x x' t1 t2) >> =>
    match get rho x with
    | Some (VInx DLeft a, l) =>
      << pc\_/l, (x',a) :: rho, RRet rho :: k, CR t1 >>
    | Some (VInx DRight a, l) =>
      << pc\_/l, (x',a) :: rho, RRet rho :: k, CR t2 >>
    | Some (_,l) =>
      << pc\_/l, rho, k, CT eType >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_tag *)
  | << pc, rho, k, CR (TTag x) >> =>
    match get rho x with
    | Some (v,l) =>
      << pc, rho, k, CA (vTag (tag_of v))@l >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_bop *)
  | << pc, rho, k, CR (TBOp b x' x'') >> =>
    match get rho x', get rho x'' with
    | Some v'@l', Some v''@l'' =>
      << pc\_/l'\_/l'', rho, k, result_to_rcfg (bop_result b v' v'')  >>
    | _,_  =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_bracket_start *)
  | << pc, rho, k, CR (TBracket x t) >> =>
    match get rho x with
    | Some (VConst (CLab L))@L' =>
      << pc\_/L', rho, RBrk L (pc\_/L') :: k, CR t >>
    | Some (v,L') =>
      << pc\_/L', rho, k, CT eType >>
    | None =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_bracket_end *)
  | << pc, rho, RBrk L' pc' :: k, CA v@L >> =>
    << pc', rho, k, CA (bracket_val (Suc v@L) pc (L' \_/ pc'))@L' >>
  | << pc, rho, RBrk L' pc' :: k, CT e >> =>
    << pc', rho, k, CA (bracket_val (Throw e) pc (L' \_/ pc'))@L' >>
  (* s_label_of *)
  | << pc, rho, k, CR (TLabelOf x) >> =>
    match get rho x with
    | Some (_,l) =>
      << pc, rho, k, CA (vLab l)@bot >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_get_pc *)
  | << pc, rho, k, CR TGetPc >> =>
    << pc, rho, k, CA (vLab pc)@bot >>
  (* s_throw *)
  | << pc, rho, k, CR (TThrow x) >> =>
    match get rho x with
    | Some (v,l) =>
      << pc\_/l, rho, k, CT (throw_excp v) >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_catch *)
  | << pc, rho, k, CR (TCatch t x t') >> =>
    << pc, rho, RCatch x t' :: k, CR t >>
  (* s_catch_no_excp *)
  | << pc, rho, RCatch x t' :: k, CA a >> =>
    << pc, rho, k, CA a >>
  (* s_catch_excp *)
  | << pc, rho, RCatch x t' :: k, CT e >> =>
    << pc, (x,(vExcp e)@bot) :: rho, RRet rho :: k, CR t' >>
  (* stack underflow (you're already done?) *)
  | << pc, rho, nil, CA _ >> =>
      << pc, rho, nil, CT eStack >>
  | << pc, rho, nil, CT _ >> =>
      << pc, rho, nil, CT eStack >>
  (* terms not from this language *)
  | << pc, rho, k, CR (TMkNav _) >> =>
      << pc, rho, k, CT eLanguage >>
  | << pc, rho, k, CR (TToSum _) >> =>
      << pc, rho, k, CT eLanguage >>
  end.

(* There are 7 different kinds of steps,
   here is how the stack evolves for each of them:
1. CR -> CR -- stack: push
2. CR -> CA -- stack: no change
3. CA -> CR -- stack: pop + maybe push (beta does pop but not push)
4. CA -> CA -- stack: pop
5. CA -> CT -- stack: no change (throw)
6. CT -> CT -- stack: clear (unwind)
7. CT -> CA -- stack: pop (catch)
*)

Definition final (c : Cfg) : bool :=
  match c with
  | << pc, rho, nil, CA _ >> => true
  | << pc, rho, nil, CT _ >> => true
  | _ => false
  end.

Fixpoint nstep (n : nat) (cm : Cfg*nat) : Cfg*nat :=
  match n with
  | S n' =>
    match cm with
    | (c,m) => if final c then (c,m) else nstep n' (step c, m+1)
    end
  | O => cm
  end.

Fixpoint lnstep (n : nat) (cl : Cfg*(list Cfg)) : Cfg*(list Cfg) :=
  match n with
  | S n' =>
    match cl with
    | (c,l) => if final c then (c,l) else lnstep n' (step c, c::l)
    end
  | O => cl
  end.

Definition mstep (n : nat) (t : Tm) : Cfg*nat :=
  nstep n (<< bot, nil, nil, CR t >>, 0).

Definition lmstep (n : nat) (t : Tm) : Cfg*(list Cfg) :=
  lnstep n (<< bot, nil, nil, CR t >>, []).

Definition sstep (n : nat) (t : Tm) : option ((Result*Lab)*nat) :=
  match mstep n t with
  | (<< pc, rho, nil, CA a >>, m) => Some ((Suc a,pc),m)
  | (<< pc, rho, nil, CT e >>, m) => Some ((Throw e,pc),m)
  | _ => None (* looping or need more steps *)
  end.


From Coq Require Import Bool List Program Lia.
From MetaCoq.Template Require Import config utils.
Require Import MetaCoq.Template.Universes.
From MetaCoq.PCUIC Require Import PCUICAst PCUICValidity PCUICGeneration
     PCUICTyping PCUICWeakeningEnv PCUICWeakening.

From MetaCoq.PCUIC Require Import PCUICSigmaCalculus.
Set Printing All.

Definition universes_decl_extends (u v: universes_decl) : Type :=
  match (u,v) with
  | (Monomorphic_ctx u', Monomorphic_ctx v') => LevelSet.Subset (fst u') (fst v') * ConstraintSet.Subset (snd u') (snd v')
  | (Polymorphic_ctx u', Polymorphic_ctx v') => True
  | _ => False
  end.

Lemma universes_decl_extends_wf_local `{checker_flags} Σ Γ (wfΓ : wf_local Σ Γ):
  All_local_env_over typing
         (fun (Σ : global_env_ext) (Γ : context) (_ : wf_local Σ Γ)
            (t T : term) (_ : Σ;;; Γ |- t : T) =>
          forall u : ContextSet.t,
          (*satisfiable_udecl Σ.1 (Monomorphic_ctx u) ->*)
          universes_decl_extends Σ.2 (Monomorphic_ctx u) ->
          (Σ.1, Monomorphic_ctx u);;; Γ |- t : T) Σ Γ wfΓ ->
  forall u, (*satisfiable_udecl Σ.1 (Monomorphic_ctx u) ->*)
            universes_decl_extends Σ.2 (Monomorphic_ctx u) ->
            wf_local (Σ.1, Monomorphic_ctx u) Γ.
Proof.
  intros. induction X; econstructor; pose (X1 := X0);
    specialize p with u; apply p in X1;
    pose (X2 := X1);
    try (apply typing_wf_local in X2; specialize p0 with u; apply p0 in X0);
    try solve [eauto|eassumption]; exists (tu.π1); eassumption.
Qed.

Lemma weakening_universe_decl_cumul `{CF:checker_flags} Σ u Γ M N :
  (*satisfiable_udecl Σ.1 (Monomorphic_ctx u) ->*)
  universes_decl_extends Σ.2 (Monomorphic_ctx u) ->
  cumul Σ Γ M N -> cumul (Σ.1, (Monomorphic_ctx u)) Γ M N.
Proof.
  intros (*st*) univ;
    destruct (Σ.2) eqn: Σ_eq; revgoals; first exfalso; subst; auto.
  induction 1; simpl.
  - econstructor. eapply (PCUICWeakeningEnv.leq_term_subset); revgoals. eassumption.
    unfold global_ext_constraints, ConstraintSet.Subset; intros.
    rewrite ConstraintSet.union_spec.
    rewrite ConstraintSet.union_spec in H.
    cbn in univ. destruct H; eauto using univ, H.
    left. simpl. apply (snd univ). rewrite Σ_eq in H.
    eassumption.
  - econstructor 2; eauto.
  - econstructor 3; eauto.
  - econstructor 4; eauto.
  - econstructor 5; eauto.
Qed.

Lemma global_ext_univ_ext Sigma v u:
  universes_decl_extends v u ->
  LevelSet.Subset (global_ext_levels (Sigma, v)) (global_ext_levels (Sigma, u)).
Proof.
  intros.
  destruct v eqn: v_eq; destruct u eqn: u_eq; revgoals; try solve[(exfalso; auto)].
  1: admit.
  unfold global_ext_levels, levels_of_udecl, LevelSet.Subset.
  simpl. intros.
  apply LevelSet.union_spec. apply LevelSet.union_spec in H.
  destruct H; auto; left. now apply (fst X).
Admitted.

Lemma weakening_universe_decl_consist `{checker_flags} Σ phi t u:
  (*satisfiable_udecl Σ.1 (Monomorphic_ctx u) ->*)
  universes_decl_extends Σ.2 (Monomorphic_ctx u) ->
  consistent_instance_ext Σ phi t ->
  consistent_instance_ext (Σ.1, Monomorphic_ctx u) phi t.
Proof.
  intros univ.
  unfold consistent_instance_ext, consistent_instance. destruct phi.
  - trivial.
  - destruct 1 as [prop [mem [eq vc]]]. split; auto. split.
    + apply forallb_forall. intros x. intros IN. eapply forallb_forall in mem.
      apply LevelSet.mem_spec. apply LevelSet.mem_spec in mem.
      eapply global_ext_univ_ext; eauto. eassumption.
    + split; eauto.
      unfold valid_constraints. unfold valid_constraints in vc.
      destruct check_univs; eauto.
      unfold valid_constraints0.  unfold valid_constraints0 in vc.
      intros. apply vc.
      unfold satisfies. unfold satisfies in H0.
      unfold ConstraintSet.For_all. unfold ConstraintSet.For_all in H0.
      intros x ins. apply H0.
      unfold global_ext_constraints. unfold global_ext_constraints in ins.
      apply ConstraintSet.union_spec. apply ConstraintSet.union_spec in ins.
      destruct ins; auto. left. simpl.
      destruct (Σ.2) eqn: Σ_eq; revgoals. exfalso. auto.
      apply (snd univ). eassumption.
Qed.

Lemma weakening_env_univ `{checker_flags}:
  env_prop (fun Σ Γ t T =>
              forall u, universes_decl_extends Σ.2 (Monomorphic_ctx u) -> (Σ.1, (Monomorphic_ctx u)) ;;; Γ |- t : T).
Proof.
  apply typing_ind_env; intros; rename_all_hyps.
    all: (destruct (Σ.2) eqn: Σ_eq; revgoals; first exfalso; auto;
          try solve[(econstructor; eauto)|eassumption]).
  - econstructor.
    + eapply universes_decl_extends_wf_local; eauto; rewrite Σ_eq; eassumption.
    + eauto.
  - econstructor.
    + eapply universes_decl_extends_wf_local; eauto; rewrite Σ_eq; eassumption.
    + unfold global_ext_levels, levels_of_udecl.
      unfold global_ext_levels, levels_of_udecl in H0.
      apply LevelSet.union_spec. apply LevelSet.union_spec in H0.
      destruct H0; eauto using H0, X0.
      left. apply (fst X0). rewrite Σ_eq in H0. eassumption.
  - econstructor; eauto.
    + eapply universes_decl_extends_wf_local; eauto; rewrite Σ_eq; eassumption.
    + unfold consistent_instance_ext. unfold consistent_instance_ext in H1.
      eapply weakening_universe_decl_consist; try (rewrite Σ_eq); eauto.
  - econstructor; eauto.
    + eapply universes_decl_extends_wf_local; eauto; rewrite Σ_eq; eassumption.
    + eapply weakening_universe_decl_consist; try (rewrite Σ_eq); eauto.
  - econstructor; eauto using X, X0.
    + eapply universes_decl_extends_wf_local; eauto. rewrite Σ_eq. eassumption.
    + eapply weakening_universe_decl_consist; try (rewrite Σ_eq); eauto.
  - econstructor; eauto using X, X0.
    close_Forall. intros; intuition.
  - econstructor; eauto.
    eapply All_local_env_impl. eapply X. simpl; intros.
    unfold lift_typing in *; destruct T; intuition eauto.
    apply b; try rewrite Σ_eq; eauto.
    destruct X2 as [s [tyu Hu]]. exists s. eapply Hu; try rewrite Σ_eq; eauto.
    eapply All_impl; eauto; simpl; intuition eauto.
  - econstructor; eauto.
    eapply All_local_env_impl. eapply X.
    simpl; intros.
    unfold lift_typing in *; destruct T; intuition eauto.
    eapply b; try rewrite Σ_eq; eauto.
    destruct X2 as [s [tyu Hu]]. exists s. eapply Hu; try rewrite Σ_eq; eauto.
    eapply All_impl; eauto; simpl; intuition eauto.
  - econstructor. eauto.
    destruct X2 as [isB|[s [Hu Ps]]].
    + left; auto. destruct isB. destruct x as [ctx' [s' [Heq Hu]]].
      exists ctx', s'. split; eauto.
      eapply universes_decl_extends_wf_local; eauto. rewrite Σ_eq. eassumption.
    + right. exists s. eapply Ps; auto.
    + destruct Σ as [Σ φ].
      eapply weakening_universe_decl_cumul; try rewrite Σ_eq; cbn in wfΓ; eassumption.
Qed.

Definition weaken_decl_univ_prop `{checker_flags}
           (P : global_env_ext -> context -> term -> option term -> Type) :=
  forall Σ v u, wf Σ -> universes_decl_extends v (Monomorphic_ctx u) -> forall Γ t T, P (Σ, v) Γ t T -> P (Σ, (Monomorphic_ctx u)) Γ t T.

Lemma weaken_decl_univ_prop_typing `{checker_flags}:
  weaken_decl_univ_prop (lift_typing typing).
Proof.
  red. intros * * * * *.
  destruct T; simpl.
  - intros Ht.
    eapply (weakening_env_univ (_, _)); eauto.
    eapply typing_wf_local in Ht; eauto.
  - intros [s Ht]. exists s.
    eapply (weakening_env_univ (_, _)); eauto. eapply typing_wf_local in Ht; eauto.
Qed.

Lemma from_validity `{checker_flags} Sigma u Gamma T:
  isWfArity_or_Type (Sigma, u) Gamma T ->
  {u' & (universes_decl_extends u u') × {s & ((Sigma, u') ;;; Gamma |- T : tSort s)}}.
Proof.
  intros.
  destruct X as [isWf | isT];
  revgoals.
  - exists u. split.
    1: {unfold universes_decl_extends, LevelSet.Subset, ConstraintSet.Subset; destruct u; auto. }
    exact isT.
  - destruct isWf as [ctx [s [desteq all_ctx]]].
    dependent induction all_ctx. (*as [all_nil | all_ass | all_def].*)
    + unfold app_context in x.
      symmetry in x.
      apply List.app_eq_nil in x. destruct x as [ctxnil gammanil]. subst.
      assert (T = tSort s). {
        induction T; unfold destArity in desteq; try inversion desteq; auto.
        1-2: rewrite destArity_app in desteq.
        1: destruct (destArity nil T2). 3: destruct (destArity nil T3).
        1-4:cbn in desteq; try destruct p; inversion desteq;
            unfold snoc, app_context in H2; symmetry in H2;
            contradict H2; apply List.app_cons_not_nil. } clear desteq.
      subst.
      eexists. split; revgoals.
      eexists.
    + admit. (*eexists. split; revgoals. eexists.*)
    + admit.
Admitted.


Require Import VST.floyd.base2.
Import ListNotations.
Import compcert.lib.Maps.

Module PosOrder <: Orders.TotalLeBool.
  Definition t := positive.
  Definition leb := Pos.leb.
  Theorem leb_total : forall a1 a2, Pos.leb a1 a2 = true \/ Pos.leb a2 a1 = true.
  Proof.  intros.
    pose proof (Pos.leb_spec a1 a2).
    pose proof (Pos.leb_spec a2 a1).
    inv H; inv H0; auto.
    clear - H2 H3.
    pose proof (Pos.lt_trans _ _ _ H2 H3).
    apply Pos.lt_irrefl in H. contradiction.
  Qed.
End PosOrder.
Module SortPos := Mergesort.Sort(PosOrder).

Module CompOrder <: Orders.TotalLeBool.
  Definition t := composite_definition.
  Definition leb := fun x y => Pos.leb (name_composite_def x) (name_composite_def y).
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.  intros. unfold leb.
    pose proof (Pos.leb_spec (name_composite_def a1) (name_composite_def a2)).
    pose proof (Pos.leb_spec (name_composite_def a2) (name_composite_def a1)).
    inv H; inv H0; auto.
    clear - H2 H3.
    pose proof (Pos.lt_trans _ _ _ H2 H3).
    apply Pos.lt_irrefl in H. contradiction.
  Qed.
End CompOrder.
Module SortComp := Mergesort.Sort(CompOrder).

Module GlobdefOrder <: Orders.TotalLeBool.
  Definition t := (ident * globdef (fundef function) type)%type.
  Definition leb := fun x y : (ident * globdef (fundef function) type)=> Pos.leb (fst x) (fst y).
  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.  intros. unfold leb.
    pose proof (Pos.leb_spec (fst a1) (fst a2)).
    pose proof (Pos.leb_spec (fst a2) (fst a1)).
    inv H; inv H0; auto.
    clear - H2 H3.
    pose proof (Pos.lt_trans _ _ _ H2 H3).
    apply Pos.lt_irrefl in H. contradiction.
  Qed.
End GlobdefOrder.
Module SortGlobdef := Mergesort.Sort(GlobdefOrder).

Definition isnil {A} (al: list A) :=
   match al with nil => true | _ => false end.

Lemma prod_eq_dec {A B} (Ha: forall (a1 a2:A), {a1 = a2} + {a1<>a2})
      (Hb: forall (b1 b2:B), {b1 = b2} + {b1<>b2}):
      forall (x y : A * B), {x=y} + {x<>y}.
Proof. intros. destruct x as [a1 b1]. destruct y as [a2 b2].
destruct (Ha a1 a2); [ subst | right; congruence].
destruct (Hb b1 b2); [ subst; left; trivial | right; congruence].
Defined.

Lemma function_eq_dec (f g: function): { f=g } + { f <> g }.
Proof.
destruct f as [rtF ccF paramsF varsF tempsF bodyF].
destruct g as [rtG ccG paramsG varsG tempsG bodyG].
destruct (type_eq rtF rtG); [ subst | right; congruence].
destruct (calling_convention_eq ccF ccG); [ subst | right; congruence].
destruct (list_eq_dec (prod_eq_dec ident_eq type_eq) paramsF paramsG); [ subst | right; congruence].
destruct (list_eq_dec (prod_eq_dec ident_eq type_eq) varsF varsG); [ subst | right; congruence].
destruct (list_eq_dec (prod_eq_dec ident_eq type_eq) tempsF tempsG); [ subst | right; congruence].
destruct (semax_lemmas.eq_dec_statement bodyF bodyG); [ subst; left; trivial | right; congruence].
Defined.

Definition merge_globdef (g1 g2: globdef (fundef function) type) :=
 match g1, g2 with
 | Gfun (External _ _ _ _), Gfun (External _ _ _ _) =>
     Errors.OK g1  (* SHOULD CHECK g1=g2 *)
 | Gfun (External _ _ _ _), Gfun (Internal f2) =>
     Errors.OK g2  (* SHOULD CHECK TYPES MATCH *)
 | Gfun (Internal f1), Gfun (External _ _ _ _) =>
    Errors.OK g1  (* SHOULD CHECK TYPES MATCH *)
 | Gfun (Internal f), Gfun (Internal g) => Errors.OK g1 (*this is OK
      since VSU.ComponentJoin contains hypothesis Fundefs_match*)
    (*Errors.Error [Errors.MSG "internal function clash"]*)
   (* if function_eq_dec f g then Errors.OK g1
    else Errors.Error [Errors.MSG "internal function clash"]*)
 | Gvar {| gvar_info := i1; gvar_init := l1; gvar_readonly := r1; gvar_volatile := v1 |},
   Gvar {| gvar_info := i2; gvar_init := l2; gvar_readonly := r2; gvar_volatile := v2 |} =>
   if (eqb_type i1 i2 &&
      bool_eq r1 r2 &&
      bool_eq v1 v2)%bool
   then if isnil l1
           then Errors.OK g2
           else if isnil l2 then Errors.OK g1
           else Errors.Error [Errors.MSG "Gvars both initialized"]
   else Errors.Error [Errors.MSG "Gvar type/readonly/volatile clash"]
  | _, _ => Errors.Error [Errors.MSG "Gvar versus Gfun"]
 end.

Function merge_global_definitions'
    (d1 d2: list (ident * globdef (fundef function) type))
    (fuel: nat) :=
 match fuel with
 | O => Errors.Error [Errors.MSG "out of fuel"]
 | S fuel' =>
  match d1, d2 with
  | nil, _ => Errors.OK d2
  | _, nil => Errors.OK d1
  | (i1,g1)::d1', (i2,g2)::d2' =>
     if Pos.ltb i1 i2
     then match merge_global_definitions' d1' d2 fuel' with
            | Errors.OK dl => Errors.OK ((i1,g1)::dl)
            | err => err
            end
     else if Pos.ltb i2 i1
     then match merge_global_definitions' d1 d2' fuel' with
            | Errors.OK dl => Errors.OK ((i2,g2)::dl)
            | err => err
            end
    else match merge_globdef g1 g2 with
           | Errors.OK g => match merge_global_definitions' d1' d2' fuel' with
                     | Errors.OK dl => Errors.OK ((i1,g)::dl)
                     | Errors.Error el => Errors.Error el
                    end
            | Errors.Error err => Errors.Error (Errors.POS i1 :: err)
            end
 end end.

Definition merge_global_definitions
    (d1 d2: list (ident * globdef (fundef function) type)) :=
 merge_global_definitions' d1 d2 (length d1 + length d2).

Fixpoint merge_prog_types' (e1 e2: list composite_definition)
                 (fuel: nat)
              : Errors.res (list composite_definition) :=
 match fuel with
 | O => Errors.Error [Errors.MSG "ran out of fuel in composites"]
 | S fuel' =>
 match e1, e2 with
 | nil, _ => Errors.OK e2
 | _, nil => Errors.OK e1
 | (Composite i1 su1 m1 a1 as c1) :: e1',
   (Composite i2 su2 m2 a2 as c2) :: e2' =>
   if Pos.ltb i1 i2
   then Errors.bind (merge_prog_types' e1' e2 fuel')
          (fun e => Errors.OK (c1::e))
   else if Pos.ltb i2 i1
   then Errors.bind (merge_prog_types' e1 e2' fuel')
          (fun e => Errors.OK (c2::e))
   else if (eqb_su su1 su2 &&
              eqb_list eqb_member m1 m2 &&
              eqb_attr a1 a2)%bool
   then Errors.bind (merge_prog_types' e1' e2' fuel')
          (fun e => Errors.OK (c1::e))
   else Errors.Error [Errors.MSG "struct/union does not match:"; Errors.POS i1]
 end
end.

Definition merge_prog_types e1 e2 :=
 merge_prog_types' e1 e2 (S(length e1 + length e2)).

Definition link_progs (prog1 prog2 : Clight.program) :
  Errors.res Clight.program :=
 match prog1, prog2 with
  {|prog_defs := d1;
    prog_public := p1;
    prog_main := m1;
    prog_types := t1;
    prog_comp_env := e1;
    prog_comp_env_eq := q1|},
  {|prog_defs := d2;
    prog_public := p2;
    prog_main := m2;
    prog_types := t2;
    prog_comp_env := e2;
    prog_comp_env_eq := q2|}  =>
 Errors.bind (merge_global_definitions
               (SortGlobdef.sort d1) (SortGlobdef.sort d2)) (fun d =>
 Errors.bind (merge_prog_types (SortComp.sort t1) (SortComp.sort t2)) (fun t =>
 match build_composite_env t as e
       return (build_composite_env t = e -> Errors.res Clight.program) with
 | Errors.Error err => fun _ => Errors.Error err
 | Errors.OK e =>  fun q =>
 if negb (eqb_ident m1 m2)
   then Errors.Error [Errors.MSG "main identifiers differ"]
   else
    Errors.OK {| prog_defs := d;
    prog_public := SortPos.merge (SortPos.sort p1) (SortPos.sort p2);
    prog_main := m2;
    prog_types := t;
    prog_comp_env := e;
    prog_comp_env_eq := q|}
   end eq_refl ))
end.

Definition link_progs_list (pl: list Clight.program) :
  Errors.res Clight.program :=
 match pl with
 | nil => Errors.Error [Errors.MSG "no programs to link"]
 | p::pl' => List.fold_left (fun q p =>
                  match q with
                  | Errors.Error e => q
                  | Errors.OK q' => link_progs q' p
                  end) pl' (Errors.OK p)
  end.

Ltac link_progs_list pl :=
 let q := constr:(linking.link_progs_list pl) in
 let q := eval hnf in q in
 let q := eval cbv beta iota delta [linking.SortComp.sort] in q in
 let q := eval simpl in q in
 match q with
 | Errors.Error ?e => fail 1 e
 | Errors.OK ?q' => exact q'
 end.

(*duplicate of lemma in globals_lemas*)
Lemma prog_defs_Clight_mkprogram:
 forall c g p m w,
 prog_defs (Clightdefs.mkprogram c g p m w) = g.
Proof.
intros. unfold Clightdefs.mkprogram.
destruct ( build_composite_env' c w).
reflexivity.
Qed.

Lemma prog_types_Clight_mkprogram:
  forall (c : list composite_definition) (g : list (ident * globdef Clight.fundef type)) (p : list ident)
    (m : ident) (w : wf_composites c), prog_types (Clightdefs.mkprogram c g p m w) = c.
Proof. intros. unfold prog_types. unfold Clightdefs.mkprogram.
destruct (build_composite_env' c w ); trivial.
Qed.

Module NEW_LINK_PROGS.  (* Everything in this Module should perhaps be moved to floyd/linking.v *)

(* All of this complexity is because the naturally computed proof whose type is
     build_composite_env t12 = Errors.OK e12
  blows up:  the nested environments explode exponentially.
 And that's a pity, because after all we have  proof irrelevance.  But I could not
 think of a better way than this to exploit proof irrelevance.  -- Andrew, 7/24/2020
*)
Definition carefully_link_progs (prog1 prog2 : Clight.program)
  (MAIN: prog_main prog1 = prog_main prog2)
  (d12: list (ident * globdef (fundef function) type))
  (Hd12: merge_global_definitions
               (SortGlobdef.sort (prog_defs prog1)) (SortGlobdef.sort (prog_defs prog2)) = Errors.OK d12)
  (t12: list composite_definition)
  (Ht12: merge_prog_types (SortComp.sort (prog_types prog1)) (SortComp.sort (prog_types prog2)) = Errors.OK t12)
  (e12: composite_env)
  (He12: build_composite_env t12 = Errors.OK e12)
  : Clight.program :=
 {| prog_defs := d12;
    prog_public := SortPos.merge (SortPos.sort (prog_public prog1)) (SortPos.sort (prog_public prog2));
    prog_main := prog_main prog2;
    prog_types := t12;
    prog_comp_env := e12;
    prog_comp_env_eq := He12|} .

Lemma Gt_neq_Lt: Gt = Lt -> False.
Proof. congruence. Qed.

Lemma prove_exists_align_attr:
  forall d, two_power_nat (Z.to_nat (Z.log2 d)) = d ->
    exists n, align_attr noattr d = two_power_nat n.
Proof.
intros.
exists (Z.to_nat (Z.log2 d)).
rewrite H. reflexivity.
Qed.

Lemma prove_align_attr:
  forall i j,  (j/i)*i=j -> (align_attr noattr i | j).
Proof. intros. exists (j/i). symmetry. apply H. Qed.

Ltac process_composite_definitions_step :=
repeat
match goal with
|- Errors.bind match ?z with _ => _ end  _  = _ =>
  set (j := z); hnf in j; simpl in j; subst j; cbv beta iota
end;
 match goal with |- context [Ctypes.composite_of_def_obligation_1 _ _ _ _] =>
   set (x := Ctypes.composite_of_def_obligation_1 _ _ _ _);
  simpl in x;
  match type of x with ?t =>
    replace x with (Gt_neq_Lt : t) by apply proof_irr
 end;
  clear x
end;
 match goal with |- context [Ctypes.composite_of_def_obligation_2 _ _ _] =>
   set (x := Ctypes.composite_of_def_obligation_2 _ _ _);
  simpl in x;
  match type of x with (exists i, align_attr noattr ?d = two_power_nat i) =>
    replace x with (prove_exists_align_attr d (eq_refl _)) by apply proof_irr
 end;
  clear x
end;
repeat
  match goal with |- context [Ctypes.composite_of_def_obligation_3 _ _ _ _] =>
   set (x := Ctypes.composite_of_def_obligation_3 _ _ _ _);
  simpl in x;
  match type of x with (align_attr noattr ?i | ?j)  =>
    replace x with (prove_align_attr i j (eq_refl _)) by apply proof_irr
 end;
  clear x
end;
change (Errors.bind (Errors.OK ?x) ?f) with (f x); cbv beta iota.

Ltac process_composite_definitions :=
 simpl;
 unfold build_composite_env;
 unfold add_composite_definitions, composite_of_def;
 simpl align; simpl align_attr; simpl rank_members;
 simpl PTree.set;
 repeat process_composite_definitions_step;
 reflexivity.

Ltac do_merge_global_definitions :=
match goal with |- context [SortGlobdef.sort ?x] =>
 set (j :=SortGlobdef.sort x); hnf in j; simpl in j; subst j
end;
match goal with |- context [SortGlobdef.sort ?x] =>
 set (j :=SortGlobdef.sort x); hnf in j; simpl in j; subst j
end;
match goal with |- ?A = _ =>
 set (j :=A); hnf in j; simpl in j; subst j
end; reflexivity.

Ltac do_merge_prog_types :=
match goal with |- context [SortComp.sort ?x] =>
 set (j :=SortComp.sort x); hnf in j; simpl in j; subst j
end;
match goal with |- context [SortComp.sort ?x] =>
 set (j :=SortComp.sort x); hnf in j; simpl in j; subst j
end;
match goal with |- ?A = _ =>
 set (j :=A); hnf in j; simpl in j; subst j
end; reflexivity.

Ltac do_link_progs_step1 p1 p2 :=
  eapply (carefully_link_progs p1 p2 (eq_refl _));
  [time "merge_global" do_merge_global_definitions
  |time "merge_types" do_merge_prog_types
  |time "process_composites" process_composite_definitions].

Ltac do_merge_global_definitions_unfold p1 p2 :=
  unfold p1; try rewrite prog_defs_Clight_mkprogram;
  unfold p2; try rewrite prog_defs_Clight_mkprogram;
  do_merge_global_definitions.

Ltac do_merge_prog_types_unfold p1 p2 :=
 unfold p1; try rewrite prog_types_Clight_mkprogram;
 unfold p2; try rewrite prog_types_Clight_mkprogram;
  do_merge_prog_types.

Ltac do_link_progs_step1_unfold p1 p2 :=
  eapply (carefully_link_progs p1 p2 (eq_refl _));
  [time "merge_global" do_merge_global_definitions_unfold p1 p2
  |time "merge_types" do_merge_prog_types_unfold p1 p2
  |time "process_composites" process_composite_definitions].

Ltac do_link_progs_step2 p :=
let x := eval hnf in p in
match x with
 {| prog_defs := ?d;
    prog_public := ?p;
    prog_main := ?m;
    prog_types := ?t;
    prog_comp_env := ?e;
    prog_comp_env_eq := _ |} =>
refine  {| prog_defs := d;
    prog_public := p;
    prog_main := m;
    prog_types := t;
    prog_comp_env := e;
    prog_comp_env_eq := _ |}
end;
abstract (exact (prog_comp_env_eq p)).

End NEW_LINK_PROGS.
(* Now, to use NEW_LINK_PROGS, it is unfortunately necessary to do this in two steps*)