(******************************************************************************)
(** Events of compiled program's execution graph follow the compilation scheme*)
(******************************************************************************)
Require Import Classical Peano_dec.
From hahn Require Import Hahn.
Require Import Omega.
Require Import Events.
Require Import Execution.
Require Import Execution_eco.
Require Import imm_s_hb.
Require Import imm_s.
(* Require Import OCamlToimm_s_prog. *)
Require Import OmmImmCompScheme.
Require Import OmmImmSimulation.
Require Import BoundedRelsProperties.
Require Import BlockSteps.
Require Import Utils.
Require Import ClosuresProperties.
Require Import Prog.
Require Import ProgToExecution.
Require Import ProgToExecutionProperties.
Require Import Logic.Decidable.
From PromisingLib Require Import Basic Loc.
Require Import Basics.
Set Implicit Arguments.

Section CompCorrHelpers.

  Notation "'E' G" := G.(acts_set) (at level 1).
  Notation "'R' G" := (fun a => is_true (is_r G.(lab) a)) (at level 1).
  Notation "'W' G" := (fun a => is_true (is_w G.(lab) a)) (at level 1).
  Notation "'RW' G" := (R G ∪₁ W G) (at level 1).
  Notation "'F' G" := (fun a => is_true (is_f G.(lab) a)) (at level 1).
  Notation "'AcqF' G" := (fun a => is_true (is_f_acq G.(lab) a)) (at level 1).
  Notation "'AcqrelF' G" := (fun a => is_true (is_f_acqrel G.(lab) a)) (at level 1).
  Notation "'ORlx' G" := (fun a => is_true (is_only_rlx G.(lab) a)) (at level 1).
  Notation "'ORlxW' G" := (fun a => is_true (is_orlx_w G.(lab) a)) (at level 1).
  Notation "'Sc' G" := (fun a => is_true (is_sc G.(lab) a)) (at level 1).
  Notation "'Acq' G" := (fun a => is_true (is_acq G.(lab) a)) (at level 1).
  Notation "'Acqrel' G" := (fun a => is_true (is_acqrel G.(lab) a)) (at level 1).
  Notation "'R_ex' G" := (fun a => is_true (R_ex G.(lab) a)) (at level 1).
  Notation "'hbo'" := (OCaml.hb).
  Notation "'same_loc' G" := (same_loc G.(lab)) (at level 1).
  Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).

  Definition omm_premises_hold G :=
    ⟪ WSCFACQRMW : E G ∩₁ W G ∩₁ Sc G ≡₁ codom_rel (⦗AcqF G⦘ ⨾ immediate (sb G) ⨾ rmw G) ⟫ /\
    ⟪ RMWSC  : rmw G ≡ ⦗Sc G⦘ ⨾ rmw G⨾ ⦗Sc G⦘ ⟫ /\
    ⟪ WRLXF : E G ∩₁ ORlxW G ⊆₁ codom_rel (⦗AcqrelF G⦘ ⨾ immediate (sb G)) ⟫ /\
    ⟪ RSCF  : E G ∩₁ R G ∩₁ Sc G ⊆₁ codom_rel (⦗AcqF G⦘ ⨾ immediate (sb G)) ⟫.

  Hint Resolve r_pl w_pl acq_pl acqrel_pl sc_pl orlx_w_pl f_acqrel_pl f_acq_pl : label_ext.

  Definition step0 st1 st2 tid :=
    ⟪STEP: step tid st1 st2 ⟫ /\
    ⟪ADD0: G st2 = G st1⟫.

  Definition step1 st1 st2 tid index label :=
    ⟪STEP: step tid st1 st2 ⟫ /\
    ⟪ADD1: exists foo bar baz bazz, G st2 = add (G st1) tid index label foo bar baz bazz⟫.

  Definition step2 st1 st2 tid index label1 label2 :=
    ⟪STEP: step tid st1 st2 ⟫ /\
    ⟪ADD1: exists foo bar baz bazz, G st2 = add_rmw (G st1) tid index label1 label2 foo bar baz bazz⟫.

  Lemma step1_index_exact st1 st2 tid index label (STEP1: step1 st1 st2 tid index label):
    index = eindex st1 /\ eindex st2 = eindex st1 + 1.
  Proof.
    red in STEP1. desc.
    assert (forall G a b c d e f g, G <> add G a b c d e f g) as ADD_NEQ.
    { ins. red. ins. unfold add in H.
      apply (@f_equal _ _ acts) in H. simpl in H.
      apply (@f_equal _ _ (@length _)) in H. simpl in H. omega. }
    assert (forall G a b c d e f g a' b' c' d' e' f' g' h',
               add_rmw G a' b' c' d' e' f' g' h' <> add G a b c d e f g) as ADD_RMW_NEQ.
    { ins. red. ins. unfold add, add_rmw in H.
      apply (@f_equal _ _ acts) in H. simpl in H.
      apply (@f_equal _ _ (@length _)) in H. simpl in H. omega. }
    do 2 (red in STEP; desc).
    inversion ISTEP0.
    all: try (rewrite UG in ADD1; apply ADD_NEQ in ADD1; by vauto).
    all: try (rewrite UG in ADD1; apply ADD_RMW_NEQ in ADD1; by vauto).
    all: split; auto.
    all: rewrite ADD1 in UG; apply (@f_equal _ _ acts) in UG; simpl in UG.
    all: inversion UG; auto.
  Qed.

  Lemma step2_index_exact st1 st2 tid index label1 label2 (STEP1: step2 st1 st2 tid index label1 label2):
    index = eindex st1 /\ eindex st2 = eindex st1 + 2.
  Proof.
    red in STEP1. desc.
    assert (forall G a b c d e f g h, G <> add_rmw G a b c d e f g h) as ADD_RMW_NEQ.
    { ins. red. ins. unfold add in H.
      apply (@f_equal _ _ acts) in H. simpl in H.
      apply (@f_equal _ _ (@length _)) in H. simpl in H. omega. }
    assert (forall G a b c d e f g a' b' c' d' e' f' g' h',
               add G a b c d e f g <> add_rmw G a' b' c' d' e' f' g' h') as ADD_RMW_ADD_NEQ.
    { ins. red. ins. unfold add, add_rmw in H.
      apply (@f_equal _ _ acts) in H. simpl in H.
      apply (@f_equal _ _ (@length _)) in H. simpl in H. omega. }
    do 2 (red in STEP; desc).
    inversion ISTEP0.
    all: try (rewrite UG in ADD1; apply ADD_RMW_NEQ in ADD1; by vauto).
    all: try (rewrite UG in ADD1; apply ADD_RMW_ADD_NEQ in ADD1; by vauto).
    all: split; auto.
    all: rewrite ADD1 in UG; apply (@f_equal _ _ acts) in UG; simpl in UG.
    all: inversion UG; auto.
  Qed.

  Lemma immediate_sb_repr st thread (WFT: wf_thread_state thread st):
    immediate (sb (G st)) ≡ (fun e1 e2 =>
                               exists ind, e1 = ThreadEvent thread ind /\
                                      e2 = ThreadEvent thread (ind + 1) /\
                                      ind + 1 < eindex st).
  Proof.
    split.
    { red. ins. red in H. desc.
      unfold sb in H. apply seq_eqv_lr in H. destruct H as [Ex [ESBxy Ey]].
      destruct y.
      { red in ESBxy. destruct x; vauto. }
      assert (thread0 = thread); [| subst thread0].
      { destruct WFT. specialize (acts_rep _ Ey). desc. vauto. }
      destruct x.
      { destruct WFT. specialize (acts_rep _ Ex). desc. vauto. }
      red in ESBxy. desc. subst.
      exists index0. splits; auto.
      2: { destruct WFT. specialize (acts_rep _ Ey). desc. inversion REP.
           subst. omega. }
      f_equal.
      destruct (NPeano.Nat.eq_decidable index (index0 + 1)); auto.
      assert (E (G st) (ThreadEvent thread (index0 + 1))) as E'.
      { destruct WFT. specialize (acts_clos (index0 + 1)).
        apply acts_clos.
        specialize (acts_rep _ Ey). desc. inversion REP. omega. }
      exfalso. apply (H0 (ThreadEvent thread (index0 + 1))).
      all: red; apply seq_eqv_lr; splits; auto; red; splits; [auto| omega]. }
    red. ins. desc. subst.
    assert (E (G st) (ThreadEvent thread ind)) as Ex.
    { destruct WFT. specialize (acts_clos ind).
      subst. apply acts_clos. omega. }
    assert (E (G st) (ThreadEvent thread (ind + 1))) as Ey.
    { destruct WFT. specialize (acts_clos (ind + 1)).
      subst. apply acts_clos. omega. }
    red. split.
    { apply seq_eqv_lr. splits; auto. red. split; [auto| omega]. }
    ins. apply seq_eqv_lr in R1. apply seq_eqv_lr in R2. desc.
    destruct c; vauto. red in R4. red in R0. desc. subst. omega.
  Qed.

  Lemma singl_rel_event_repr thread ind:
    singl_rel (ThreadEvent thread ind) (ThreadEvent thread (ind + 1)) ≡
              (fun e1 e2 => e1 = ThreadEvent thread ind /\
                         e2 = ThreadEvent thread (ind + 1)).
  Proof. basic_solver. Qed.

  Lemma step_1_label_ext_helper st1 st2 tid new_label index
        (STEP1: step1 st1 st2 tid index new_label)
        n (REACH: (step tid) ^^ n (init (instrs st1)) st1):
    let lbl_ext (S: (actid -> label) -> actid -> bool)
                (matcher : label -> bool) :=
        S (lab (G st2)) ≡₁ S (lab (G st1)) ∪₁ (if matcher new_label then eq (ThreadEvent tid index) else ∅) in
    ⟪E_EXT: E (G st2) ≡₁ E (G st1) ∪₁ eq (ThreadEvent tid index) ⟫ /\
    ⟪RMW_EXT: rmw (G st2) ≡ rmw (G st1) ⟫ /\
    ⟪SB_EXT: E (G st1) ≡₁ ∅ \/ immediate (sb (G st2)) ≡ immediate (sb (G st1)) ∪ singl_rel (ThreadEvent tid (index - 1)) (ThreadEvent tid index) ⟫ /\
    ⟪R_EXT: lbl_ext (@is_r actid) r_matcher ⟫ /\
    ⟪W_EXT: lbl_ext (@is_w actid) w_matcher ⟫ /\
    ⟪W_ORLX_EXT: lbl_ext (@is_orlx_w actid) orlx_w_matcher ⟫ /\
    ⟪F_ACQ_EXT: lbl_ext (@is_f_acq actid) f_acq_matcher ⟫ /\
    ⟪F_ACQREL_EXT: lbl_ext (@is_f_acqrel actid) f_acqrel_matcher ⟫ /\
    ⟪SC_EXT: lbl_ext (@is_sc actid) sc_matcher⟫ .
  Proof.
    forward eapply step1_index_exact; eauto. ins. destruct H as [H EINDEX2].  subst.
    red in STEP1. desc.
    pose proof label_set_step as LBL_STEP.
    specialize LBL_STEP with (st1 := st1) (st2 := st2) (tid := tid).
    assert (E (G st2) ≡₁ E (G st1) ∪₁ eq (ThreadEvent tid (eindex st1))) as E_EXT.
    { desc. rewrite ADD1. unfold acts_set. basic_solver. }
    simpl. splits; auto.
    { desc. rewrite ADD1. basic_solver. }
    { assert (wf_thread_state tid st1) as WFT.
      { eapply wf_thread_state_steps with (s := init (instrs st1)); [apply wf_thread_state_init| ].
        apply crt_num_steps. eauto. }
      destruct (gt_0_eq (eindex st1)).
      2: { left. split; [| basic_solver]. red. ins. red in H0.
           destruct WFT. specialize (acts_rep x H0). desc. omega. }
      right.
      assert (wf_thread_state tid st1) as WFT1.
      { eapply wf_thread_state_steps with (s := init (instrs st1)); [apply wf_thread_state_init| ].
        apply crt_num_steps. eauto. }
      assert (wf_thread_state tid st2) as WFT2.
      { eapply wf_thread_state_step; eauto. }
      rewrite (immediate_sb_repr WFT1), (immediate_sb_repr WFT2); eauto.
      replace (eindex st1) with ((eindex st1 - 1) + 1) at 2 by omega.
      rewrite EINDEX2.
      rewrite singl_rel_event_repr.
      split.
      { red. ins. desc. subst. destruct (Nat.lt_decidable (ind + 1) (eindex st1)).
        { red. left. eexists. splits; eauto. }
        red. right. splits.
        all: f_equal; omega. }
      red. ins. red in H0. des.
      { subst. eexists. splits; eauto. omega. }
      subst. eexists. splits; eauto. omega. }
    all: apply LBL_STEP; eauto with label_ext.
    all: eapply nonnop_bounded; eauto with label_ext; vauto.
  Qed.

  Lemma step_2_label_ext_helper st1 st2 tid new_label1 new_label2 index
        (STEP2: step2 st1 st2 tid index new_label1 new_label2)
        n (REACH: (step tid) ^^ n (init (instrs st1)) st1):
    let ev1 := (ThreadEvent tid index) in
    let ev2 := (ThreadEvent tid (index + 1)) in
    let lbl_ext2 (S: (actid -> label) -> actid -> bool)
                (matcher : label -> bool) :=
        S (lab (G st2)) ≡₁ S (lab (G st1)) ∪₁ (if matcher new_label1 then eq ev1 else ∅) ∪₁ (if matcher new_label2 then eq ev2 else ∅) in
    ⟪E_EXT: E (G st2) ≡₁ E (G st1) ∪₁ eq ev1 ∪₁ eq ev2 ⟫ /\
    ⟪RMW_EXT: rmw (G st2) ≡ rmw (G st1) ∪ singl_rel ev1 ev2 ⟫ /\
    ⟪SB_EXT: E (G st1) ≡₁ ∅ \/ immediate (sb (G st2)) ≡ immediate (sb (G st1)) ∪ singl_rel (ThreadEvent tid (index - 1)) ev1 ∪ singl_rel ev1 ev2 ⟫ /\
    ⟪R_EXT: lbl_ext2 (@is_r actid) r_matcher ⟫ /\
    ⟪W_EXT: lbl_ext2 (@is_w actid) w_matcher ⟫ /\
    ⟪W_ORLX_EXT: lbl_ext2 (@is_orlx_w actid) orlx_w_matcher ⟫ /\
    ⟪F_ACQ_EXT: lbl_ext2 (@is_f_acq actid) f_acq_matcher ⟫ /\
    ⟪F_ACQREL_EXT: lbl_ext2 (@is_f_acqrel actid) f_acqrel_matcher ⟫ /\
    ⟪SC_EXT: lbl_ext2 (@is_sc actid) sc_matcher⟫ .
  Proof.
    forward eapply step2_index_exact; eauto. ins. destruct H as [H EINDEX2].  subst.
    red in STEP2. desc.
    pose proof label_set_rmw_step as LBL_STEP.
    specialize LBL_STEP with (st1 := st1) (st2 := st2) (tid := tid).
    assert (E (G st2) ≡₁ E (G st1) ∪₁ eq (ThreadEvent tid (eindex st1)) ∪₁ eq (ThreadEvent tid (eindex st1 + 1))) as E_EXT.
    { desc. rewrite ADD1. unfold acts_set. basic_solver. }
    simpl. splits; auto.
    { desc. rewrite ADD1. unfold add_rmw. simpl. basic_solver. }
    { assert (wf_thread_state tid st1) as WFT1.
      { eapply wf_thread_state_steps with (s := init (instrs st1)); [apply wf_thread_state_init| ].
        apply crt_num_steps. eauto. }
      assert (wf_thread_state tid st2) as WFT2.
      { eapply wf_thread_state_step; eauto. }
      destruct (gt_0_eq (eindex st1)).
      2: { left. split; [| basic_solver]. red. ins. red in H0.
           destruct WFT1. specialize (acts_rep x H0). desc. omega. }
      right.
      rewrite (immediate_sb_repr WFT1), (immediate_sb_repr WFT2); eauto.
      replace (eindex st1) with ((eindex st1 - 1) + 1) at 2 by omega.
      do 2 rewrite singl_rel_event_repr.
      rewrite EINDEX2. split.
      { rewrite unionA. red. ins. desc. subst.
        destruct (Const.lt_ge_cases (ind + 1) (eindex st1)).
        { red. left. eexists. splits; eauto. }
        red. right. destruct (NPeano.Nat.eq_decidable (ind + 1) (eindex st1)).
        { red. left. splits; vauto; f_equal; omega. }
        red. right. splits; vauto; f_equal; omega. }
      red. ins. destruct H0 as [[SB1 | SB'] | SB''].
      { desc. eexists. splits; eauto. omega. }
      { desc. subst. eexists. splits; eauto. omega. }
      desc. subst. eexists. splits; eauto. omega.
      }
    all: apply LBL_STEP; eauto with label_ext.
    all: eapply nonnop_bounded; eauto with label_ext; vauto.
  Qed.

  Lemma EXTSB_IRR e:
    ⦗eq e⦘ ⨾ ext_sb ⨾ ⦗eq e⦘ ≡ ∅₂.
  Proof.
    split; [| basic_solver]. rewrite seq_eqv_lr. red. ins.
    desc. subst. red in H0. destruct y; vauto. desc. omega.
  Qed.

  Lemma EXTSB_MON e1 e2 (GT: index e1 > index e2):
    ⦗eq e1⦘ ⨾ ext_sb ⨾ ⦗eq e2⦘ ≡ ∅₂.
  Proof.
    split; [| basic_solver]. rewrite seq_eqv_lr. red. ins.
    desc. subst. destruct x.
    { simpl in GT. omega. }
    destruct y; vauto. simpl in H0. simpl in GT. desc. omega.
  Qed.

  Lemma step_11_label_ext_helper st1 st2 st3 tid new_label1 new_label2 index1 index2
        (IND1: index1 >= eindex st1) (IND2: index2 >= eindex st2)
        (STEP11: step1 st1 st2 tid index1 new_label1)
        (STEP12: step1 st2 st3 tid index2 new_label2)
        n (REACH: (step tid) ^^ n (init (instrs st1)) st1):
    let ev1 := (ThreadEvent tid index1) in
    let ev2 := (ThreadEvent tid index2) in
    let lbl_ext2 (S: (actid -> label) -> actid -> bool)
                (matcher : label -> bool) :=
        S (lab (G st3)) ≡₁ S (lab (G st1)) ∪₁ (if matcher new_label1 then eq ev1 else ∅) ∪₁ (if matcher new_label2 then eq ev2 else ∅) in
    ⟪E_EXT: E (G st3) ≡₁ E (G st1) ∪₁ eq ev1 ∪₁ eq ev2 ⟫ /\
    ⟪RMW_EXT: rmw (G st3) ≡ rmw (G st1) ⟫ /\
    ⟪SB_EXT: (E (G st1) ≡₁ ∅ /\ sb (G st3) ≡ singl_rel ev1 ev2) \/
             immediate (sb (G st3)) ≡ immediate (sb (G st1)) ∪ singl_rel (ThreadEvent tid (index1 - 1)) ev1 ∪ singl_rel ev1 ev2 ⟫ /\
    ⟪R_EXT: lbl_ext2 (@is_r actid) r_matcher ⟫ /\
    ⟪W_EXT: lbl_ext2 (@is_w actid) w_matcher ⟫ /\
    ⟪W_ORLX_EXT: lbl_ext2 (@is_orlx_w actid) orlx_w_matcher ⟫ /\
    ⟪F_ACQ_EXT: lbl_ext2 (@is_f_acq actid) f_acq_matcher ⟫ /\
    ⟪F_ACQREL_EXT: lbl_ext2 (@is_f_acqrel actid) f_acqrel_matcher ⟫ /\
    ⟪SC_EXT: lbl_ext2 (@is_sc actid) sc_matcher⟫ .
  Proof.
    forward eapply (@step1_index_exact st1 st2) as [H EINDEX2]; eauto.
    forward eapply (@step1_index_exact st2 st3) as [H' EINDEX3]; eauto.
    ins. subst.
    forward eapply (@step_1_label_ext_helper st1 st2 tid) as STEP1; eauto.
    red in STEP11. desc.
    forward eapply (@step_1_label_ext_helper st2 st3 tid new_label2 (eindex st2)) as STEP2; eauto.
    { Unshelve. 2: exact (S n). replace (instrs st2) with (instrs st1).
      2: { apply steps_same_instrs. exists tid. apply rt_step. auto. }
      apply step_prev. exists st1. split; auto. }
    simpl in *. desc. simpl. splits.
    4: { rewrite R_EXT, R_EXT0. auto. }
    4: { rewrite W_EXT, W_EXT0. auto. }
    4: { rewrite W_ORLX_EXT, W_ORLX_EXT0. auto. }
    4: { rewrite F_ACQ_EXT, F_ACQ_EXT0. auto. }
    4: { rewrite F_ACQREL_EXT, F_ACQREL_EXT0. auto. }
    4: { rewrite SC_EXT, SC_EXT0. auto. }
    { rewrite E_EXT, E_EXT0. auto. }
    { rewrite RMW_EXT, RMW_EXT0. auto. }
    { clear W_EXT. clear W_EXT0. clear W_ORLX_EXT. clear W_ORLX_EXT0. clear F_ACQ_EXT. clear F_ACQ_EXT0. clear F_ACQREL_EXT. clear F_ACQREL_EXT0. clear SC_EXT. clear SC_EXT0. clear R_EXT. clear R_EXT0. clear RMW_EXT. clear RMW_EXT0.
      destruct SB_EXT as [NO_E2 | E2_ADD].
      { exfalso. generalize E_EXT0. rewrite NO_E2. basic_solver. }
      desc.
      destruct SB_EXT0 as [NO_E1 | E1_ADD].
      { left. split; auto.
        unfold sb. rewrite E_EXT, E_EXT0, NO_E1. remove_emptiness.
        rewrite id_union. rewrite seq_union_l, !seq_union_r.
        repeat rewrite EXTSB_IRR.
        rewrite EXTSB_MON with (e1 := (ThreadEvent tid (eindex st2))).
        2: { simpl. omega. }
        remove_emptiness.
        apply unique_restr. red. split; [auto| omega]. }
      right. rewrite E2_ADD, E1_ADD.
      replace (eindex st2 - 1) with (eindex st1); auto. omega. }
    Qed.

  Lemma step_12_label_ext_helper st1 st2 st3 tid new_label1 new_label21 new_label22 index1 index2
        (IND1: index1 >= eindex st1) (IND2: index2 >= eindex st2)
        (STEP11: step1 st1 st2 tid index1 new_label1)
        (STEP12: step2 st2 st3 tid index2 new_label21 new_label22)
        n (REACH: (step tid) ^^ n (init (instrs st1)) st1):
    let ev1 := (ThreadEvent tid index1) in
    let ev2 := (ThreadEvent tid index2) in
    let ev3 := (ThreadEvent tid (index2 + 1)) in
    let lbl_ext3 (S: (actid -> label) -> actid -> bool)
                (matcher : label -> bool) :=
        S (lab (G st3)) ≡₁ S (lab (G st1)) ∪₁
          (if matcher new_label1 then eq ev1 else ∅) ∪₁
          (if matcher new_label21 then eq ev2 else ∅) ∪₁
          (if matcher new_label22 then eq ev3 else ∅) in
    ⟪E_EXT: E (G st3) ≡₁ E (G st1) ∪₁ eq ev1 ∪₁ eq ev2  ∪₁ eq ev3 ⟫ /\
    ⟪RMW_EXT: rmw (G st3) ≡ rmw (G st1) ∪ singl_rel ev2 ev3⟫ /\
    ⟪SB_EXT: (E (G st1) ≡₁ ∅ /\ sb (G st3) ≡ singl_rel ev1 ev2 ∪ singl_rel ev2 ev3 ∪ singl_rel ev1 ev3) \/
             immediate (sb (G st3)) ≡ immediate (sb (G st1)) ∪ singl_rel (ThreadEvent tid (index1 - 1)) ev1 ∪ singl_rel ev1 ev2  ∪ singl_rel ev2 ev3 ⟫ /\
    ⟪R_EXT: lbl_ext3 (@is_r actid) r_matcher ⟫ /\
    ⟪W_EXT: lbl_ext3 (@is_w actid) w_matcher ⟫ /\
    ⟪W_ORLX_EXT: lbl_ext3 (@is_orlx_w actid) orlx_w_matcher ⟫ /\
    ⟪F_ACQ_EXT: lbl_ext3 (@is_f_acq actid) f_acq_matcher ⟫ /\
    ⟪F_ACQREL_EXT: lbl_ext3 (@is_f_acqrel actid) f_acqrel_matcher ⟫ /\
    ⟪SC_EXT: lbl_ext3 (@is_sc actid) sc_matcher⟫ .
  Proof.
    forward eapply (@step1_index_exact st1 st2) as [H EINDEX2]; eauto.
    forward eapply (@step2_index_exact st2 st3) as [H' EINDEX3]; eauto.
    ins. subst.
    forward eapply (@step_1_label_ext_helper st1 st2 tid) as STEP1; eauto.
    red in STEP11. desc.
    forward eapply (@step_2_label_ext_helper st2 st3 tid new_label21 new_label22 (eindex st2)) as STEP2; eauto.
    { Unshelve. 2: exact (S n). replace (instrs st2) with (instrs st1).
      2: { apply steps_same_instrs. exists tid. apply rt_step. auto. }
      apply step_prev. exists st1. split; auto. }
    simpl in *. desc. simpl. splits.
    4: { rewrite R_EXT, R_EXT0. auto. }
    4: { rewrite W_EXT, W_EXT0. auto. }
    4: { rewrite W_ORLX_EXT, W_ORLX_EXT0. auto. }
    4: { rewrite F_ACQ_EXT, F_ACQ_EXT0. auto. }
    4: { rewrite F_ACQREL_EXT, F_ACQREL_EXT0. auto. }
    4: { rewrite SC_EXT, SC_EXT0. auto. }
    { rewrite E_EXT, E_EXT0. auto. }
    { rewrite RMW_EXT, RMW_EXT0. auto. }
    { clear W_EXT. clear W_EXT0. clear W_ORLX_EXT. clear W_ORLX_EXT0. clear F_ACQ_EXT. clear F_ACQ_EXT0. clear F_ACQREL_EXT. clear F_ACQREL_EXT0. clear SC_EXT. clear SC_EXT0. clear R_EXT. clear R_EXT0. clear RMW_EXT. clear RMW_EXT0.
      destruct SB_EXT as [NO_E2 | E2_ADD].
      { exfalso. generalize E_EXT0. rewrite NO_E2. basic_solver. }
      desc.
      destruct SB_EXT0 as [NO_E1 | E1_ADD].
      { left. split; auto.
        unfold sb. rewrite E_EXT, E_EXT0, NO_E1. remove_emptiness.
        rewrite id_union. repeat rewrite id_union. expand_rels.
        rewrite EINDEX2.
        repeat rewrite EXTSB_IRR.
        rewrite EXTSB_MON with (e1 := (ThreadEvent tid (eindex st1 + 1))).
        2: { simpl. omega. }
        rewrite EXTSB_MON with (e1 := (ThreadEvent tid (eindex st1 + 1 + 1))).
        2: { simpl. omega. }
        rewrite EXTSB_MON with (e1 := (ThreadEvent tid (eindex st1 + 1 + 1))).
        2: { simpl. omega. }
        remove_emptiness.
        repeat rewrite unique_restr.
        2-4: by (simpl; split; [auto | omega]).
        basic_solver. }
      right. rewrite E2_ADD, E1_ADD.
      replace (eindex st2 - 1) with (eindex st1); auto. omega. }
    Qed.

  Lemma GI_1thread_omm_premises_block bst tid PO
        (COMP: is_thread_block_compiled PO (binstrs bst))
        (GOTO_RESTR: goto_addresses_restricted PO)
        (BLOCK_STEPS: (omm_block_step_PO PO tid)＊ (binit (binstrs bst)) bst):
    omm_premises_hold (bG bst).
  Proof.
    apply crt_num_steps in BLOCK_STEPS. destruct BLOCK_STEPS as [n_steps BLOCK_STEPS].
    generalize dependent bst. induction n_steps.
    { ins. red in BLOCK_STEPS. desc. rewrite <- BLOCK_STEPS. simpl.
      red. simpl. splits; basic_solver. }
    ins. red in BLOCK_STEPS. destruct BLOCK_STEPS as [bst_prev [STEPS_PREV STEP_NEXT]].
    assert (binstrs bst = binstrs bst_prev) as BINSTRS_SAME.
    { red in STEP_NEXT. desc. auto. }
    specialize (IHn_steps bst_prev).
    specialize_full IHn_steps; [congruence| congruence |].
    red in STEP_NEXT. desc.
    red in BLOCK_STEP. desc.
    remember (bpc bst_prev) as b. remember (bst2st bst_prev) as st_prev.
    assert (exists oinstr, is_instruction_compiled oinstr block) as [oinstr COMP_BLOCK].
    { eapply resulting_block_compiled; eauto. eapply COMPILED_NONEMPTY. eauto. }
    assert (forall i block_i, Some block_i = nth_error block i -> Some block_i = nth_error (instrs st_prev) (pc st_prev + i)) as BLOCK_CONTENTS.
    { ins. forward eapply (@near_pc block_i block i H bst_prev); eauto.
      { congruence. }
      apply nth_error_Some, OPT_VAL. exists block. congruence. }
    assert (forall i instr (BLOCK_I: Some instr = nth_error block i) instr' (OTHER: Some instr' = nth_error (instrs st_prev) (pc st_prev + i)) (NEQ: instr <> instr'), False).
    { ins. specialize (BLOCK_CONTENTS _ _ BLOCK_I). congruence. }
    assert (exists k, (step tid) ^^ k (init (instrs st_prev)) st_prev) as [k REACH].
    { apply crt_num_steps. subst st_prev. apply ommblocks_imply_steps with (PO := PO); auto.
      apply crt_num_steps. eexists. rewrite BINSTRS_SAME0. eauto. }
    assert (forall st', (step tid) st_prev st' -> (step tid) ^^ (k + 1) (init (instrs st')) st') as REACH'.
    { ins. replace (instrs st') with (instrs st_prev).
      2: { apply steps_same_instrs. eexists. apply rt_step. basic_solver. }
      rewrite Nat.add_1_r. apply step_prev. eexists. splits; eauto. }
    assert (wf_thread_state tid st_prev) as WFT.
    { apply wf_thread_state_steps with (s := init (instrs st_prev)); [apply wf_thread_state_init| ].
      apply crt_num_steps. eauto. }
    assert (forall {A: Type} (D: A -> Prop) r, immediate (restr_rel D r) ≡ restr_rel D (immediate (restr_rel D r))) as RESTR_IMM.
    { ins. basic_solver. }

    inv COMP_BLOCK; simpl in *.
    all: remember (bst2st bst_prev) as st_prev.
    { apply (same_relation_exp (seq_id_l (step tid))) in BLOCK_STEP0.
      do 2 (red in BLOCK_STEP0; desc).
      forward eapply (BLOCK_CONTENTS 0 ld) as INSTR; eauto.
      inversion ISTEP0.
      all: try (forward eapply (@H 0 ld eq_refl instr); vauto; rewrite Nat.add_0_r; vauto).
      assert (instr = ld).
      { cut (Some instr = Some ld); [ins; vauto| ].
        rewrite ISTEP, INSTR. rewrite Nat.add_0_r.
        vauto. }
      subst instr. inversion H0. subst ord. subst reg. subst lexpr.
      remember (Aload false Orlx (RegFile.eval_lexpr (regf st_prev) loc) val) as lbl.
      remember (bst2st bst) as st.
      replace (init (flatten (binstrs bst_prev))) with (init (instrs st_prev)) in * by vauto.
      red.
      replace (bG bst) with (G st) by vauto.
      forward eapply step_1_label_ext_helper as LBL_EXT; eauto.
      { red. splits; eauto. red. eexists. red. splits; eauto. }
      simpl in LBL_EXT. desc.
      assert (forall max_event index (IND: index >= eindex st_prev),
                 singl_rel max_event (ThreadEvent tid (eindex st_prev)) ⨾ rmw (G st_prev) ≡ ∅₂) as SB_RMW_HELPER.
      { split; [| basic_solver].
        rewrite rmw_bibounded; vauto.
        red. ins. red in H1. desc. red in H1. desc. subst.
        simpl in H2. omega. }
      subst lbl. simpl in *.
      des.
      { assert (sb (G st) ≡ ∅₂) as NO_SB.
        { split; [| basic_solver]. unfold Execution.sb.
          rewrite E_EXT, SB_EXT. remove_emptiness.
          rewrite seq_eqv_lr. red. ins. desc.
          subst. unfold ext_sb in H2. desc. omega. }
        assert (immediate (sb (G st)) ≡ ∅₂) as NO_ISB.
        { generalize NO_SB. basic_solver. }
        rewrite SB_EXT in *. clear SB_EXT.
        splits.
        all: unfold_clear_updated; expand_rels; simplify_updated_sets.
        2: by_IH IHn_steps.
        all: basic_solver. }
      splits.
      { unfold_clear_updated. expand_rels. simplify_updated_sets.
        rewrite SB_RMW_HELPER; eauto. remove_emptiness.
        by_IH IHn_steps. }
      { unfold_clear_updated. expand_rels. simplify_updated_sets.
        by_IH IHn_steps. }
      { unfold_clear_updated. expand_rels. simplify_updated_sets.
        rewrite codom_union. apply set_subset_union_r. left.
        by_IH IHn_steps. }
      { unfold_clear_updated. expand_rels. simplify_updated_sets.
        rewrite codom_union. apply set_subset_union_r. left.
        by_IH IHn_steps. } }
    { apply (same_relation_exp (@seqA _ _ _ _)) in BLOCK_STEP0.
      apply (same_relation_exp (seq_id_l (step tid ⨾ step tid))) in BLOCK_STEP0.
      red in BLOCK_STEP0. destruct BLOCK_STEP0 as [st_prev' [STEP1 STEP2]].
      do 2 (red in STEP1; desc). do 2 (red in STEP2; desc).
      forward eapply (BLOCK_CONTENTS 0 f) as INSTR; eauto.
      inversion ISTEP0.
      all: try (forward eapply (@H 0 f eq_refl instr); vauto; rewrite Nat.add_0_r; vauto).
      assert (instr = f).
      { cut (Some instr = Some f); [ins; vauto| ].
        rewrite ISTEP, INSTR. rewrite Nat.add_0_r.
        vauto. }
      rewrite <- INSTRS, UPC in *.
      subst instr. inversion H0. subst ord. (* subst reg. subst lexpr.  *)
      forward eapply (BLOCK_CONTENTS 1 st) as INSTR'; eauto.
      inversion ISTEP2.
      all: try (forward eapply (@H 1 st eq_refl instr0); by vauto).
      assert (instr0 = st).
      { cut (Some instr0 = Some st); [ins; vauto| ].
        rewrite ISTEP1. vauto. }
      subst instr0. inversion H1. subst ord. subst lexpr. subst expr.
      subst x. subst l. subst v.

      remember (Afence Oacqrel) as lbl.
      remember (Astore Xpln Orlx (RegFile.eval_lexpr (regf st_prev') loc)) as lbl'.
      rename st into st_.
      remember (bst2st bst) as st.
      replace (init (flatten (binstrs bst_prev))) with (init (instrs st_prev)) in * by vauto.
      red.
      replace (bG bst) with (G st) by vauto.
      forward eapply (@step_11_label_ext_helper st_prev st_prev' st) as LBL_EXT; eauto.
      { red. splits; eauto. do 2 (red; eexists); eauto. }
      { red. splits; eauto. red. eexists. red. splits.
        { congruence. }
        exists st_. splits; eauto. rewrite INSTR'. f_equal; vauto. }

      rewrite Heqlbl, Heqlbl' in LBL_EXT. simpl in LBL_EXT. desc.
      remember (ThreadEvent tid (eindex st_prev)) as ev.
      remember (ThreadEvent tid (eindex st_prev')) as ev'.
      destruct SB_EXT as [[NO_E SB_TRIVIAL] | SB_EXT].
      { assert (immediate (sb (G st)) ≡ singl_rel ev ev') as IMM_SB.
        { rewrite SB_TRIVIAL. split; [basic_solver| ].
          red. ins. red. split; auto.
          ins. red in H2, R1, R2. desc. subst.
          inversion R2. rewrite UINDEX in H3. simpl in H3. omega. }
        rewrite NO_E in *. (* clear NO_E. *)
        subst ev ev'. rewrite UINDEX in *.
        splits. all: try rewrite IMM_SB.
        { rewrite E_EXT, RMW_EXT.
          rewrite wft_rmwE; eauto. fold (acts_set (G st_prev)). rewrite NO_E.
          unfold_clear_updated; expand_rels; simplify_updated_sets.
          basic_solver 10. }
        { unfold_clear_updated; expand_rels; simplify_updated_sets.
          by_IH IHn_steps. }
        { unfold_clear_updated; expand_rels; simplify_updated_sets.
          basic_solver 10. }
        { unfold_clear_updated; expand_rels; simplify_updated_sets.
          basic_solver. }
      }

      splits.
      { subst ev ev'. rewrite UINDEX in *.
        unfold_clear_updated; expand_rels; simplify_updated_sets.
        assert (forall x d, singl_rel x (ThreadEvent tid (eindex st_prev + d)) ⨾ rmw (G st_prev) ≡ ∅₂).
        { ins. rewrite wft_rmwE; eauto. fold (acts_set (G st_prev)).
          rewrite singl_rel_restr. rewrite !seqA. rewrite <- seqA with (r2 := ⦗E (G st_prev)⦘).
          rewrite <- id_inter. simplify_updated_sets. basic_solver. }
        rewrite <- Nat.add_0_r with (n := (eindex st_prev)) at 4.
        repeat rewrite H2. remove_emptiness.
        rewrite id_union. expand_rels.
        unfold sb at 2. rewrite <- restr_relE, RESTR_IMM, restr_relE.
        rewrite !seqA. rewrite <- seqA with (r1 := ⦗eq (ThreadEvent tid (eindex st_prev))⦘).
        rewrite <- id_inter. simplify_updated_sets.
        by_IH IHn_steps. }
      { unfold_clear_updated; expand_rels; simplify_updated_sets.
        by_IH IHn_steps. }
      { subst ev ev'. rewrite UINDEX in *.
        unfold_clear_updated; expand_rels; simplify_updated_sets.
        apply set_subset_union_l. split; [| basic_solver 10].
        rewrite id_union. expand_rels.
        repeat rewrite codom_union.
        repeat (apply set_subset_union_r; left).
        by_IH IHn_steps. }
      { subst ev ev'. rewrite UINDEX in *.
        unfold_clear_updated; expand_rels; simplify_updated_sets.
        rewrite id_union. expand_rels.
        repeat rewrite codom_union.
        repeat (apply set_subset_union_r; left).
        by_IH IHn_steps. } }
    { apply (same_relation_exp (@seqA _ _ _ _)) in BLOCK_STEP0.
      apply (same_relation_exp (seq_id_l (step tid ⨾ step tid))) in BLOCK_STEP0.
      red in BLOCK_STEP0. destruct BLOCK_STEP0 as [st_prev' [STEP1 STEP2]].
      do 2 (red in STEP1; desc). do 2 (red in STEP2; desc).
      forward eapply (BLOCK_CONTENTS 0 f) as INSTR; eauto.
      inversion ISTEP0.
      all: try (forward eapply (@H 0 f eq_refl instr); vauto; rewrite Nat.add_0_r; vauto).
      assert (instr = f).
      { cut (Some instr = Some f); [ins; vauto| ].
        rewrite ISTEP, INSTR. rewrite Nat.add_0_r.
        vauto. }
      rewrite <- INSTRS, UPC in *.
      subst instr. inversion H0. subst ord. (* subst reg. subst lexpr.  *)
      forward eapply (BLOCK_CONTENTS 1 ld) as INSTR'; eauto.
      inversion ISTEP2.
      all: try (forward eapply (@H 1 ld eq_refl instr0); by vauto).
      assert (instr0 = ld).
      { cut (Some instr0 = Some ld); [ins; vauto| ].
        rewrite ISTEP1. vauto. }
      subst instr0. inversion H1. subst ord. subst lexpr. subst reg.
      subst l.

      remember (Afence Oacq) as lbl.
      remember (Aload false Osc (RegFile.eval_lexpr (regf st_prev') loc) val) as lbl'.
      remember (bst2st bst) as st.
      replace (init (flatten (binstrs bst_prev))) with (init (instrs st_prev)) in * by vauto.
      red.
      replace (bG bst) with (G st) by vauto.
      forward eapply (@step_11_label_ext_helper st_prev st_prev' st) as LBL_EXT; eauto.
      { red. splits; eauto. do 2 (red; eexists); eauto. }
      { red. splits; eauto. red. eexists. red. splits.
        { congruence. }
        exists ld. splits; eauto. rewrite INSTR'. f_equal; vauto. }

      rewrite Heqlbl, Heqlbl' in LBL_EXT. simpl in LBL_EXT. desc.
      remember (ThreadEvent tid (eindex st_prev)) as ev.
      remember (ThreadEvent tid (eindex st_prev')) as ev'.
      destruct SB_EXT as [[NO_E SB_TRIVIAL] | SB_EXT].
      { assert (immediate (sb (G st)) ≡ singl_rel ev ev') as IMM_SB.
        { rewrite SB_TRIVIAL. split; [basic_solver| ].
          red. ins. red. split; auto.
          ins. red in H2, R1, R2. desc. subst.
          inversion R2. rewrite UINDEX in H3. simpl in H3. omega. }
        rewrite NO_E in *. (* clear NO_E. *)
        subst ev ev'. rewrite UINDEX in *.
        splits. all: try rewrite IMM_SB.
        { rewrite E_EXT, RMW_EXT.
          rewrite wft_rmwE; eauto. fold (acts_set (G st_prev)). rewrite NO_E.
          unfold_clear_updated; expand_rels; simplify_updated_sets.
          basic_solver 10. }
        { unfold_clear_updated; expand_rels; simplify_updated_sets.
          rewrite wft_rmwE at 2; eauto. fold (acts_set (G st_prev)).
          rewrite !seqA. repeat seq_rewrite <- id_inter.
          unfold_clear_updated; expand_rels; simplify_updated_sets.
          repeat rewrite id_inter. rewrite !seqA.
          unfold acts_set. seq_rewrite <- wft_rmwE; eauto.
          by_IH IHn_steps. }
        { unfold_clear_updated; expand_rels; simplify_updated_sets.
          basic_solver 10. }
        { unfold_clear_updated; expand_rels; simplify_updated_sets.
          basic_solver 10. }
      }

      splits.
      { subst ev ev'. rewrite UINDEX in *.
        unfold_clear_updated; expand_rels; simplify_updated_sets.
        rewrite set_interA with (s'' := eq (ThreadEvent tid (eindex st_prev + 1))). simplify_updated_sets.
        rewrite singl_rel_restr. rewrite singl_rel_restr with (y := (ThreadEvent tid (eindex st_prev + 1))).
        rewrite wft_rmwE; eauto. fold (acts_set (G st_prev)).
        rewrite !seqA. repeat seq_rewrite <- id_inter.
        simplify_updated_sets.
        repeat rewrite eqv_empty. remove_emptiness.
        rewrite id_union, seq_union_l.
        (* TODO: refactor with previous case; also maybe add tactic especially for rmw; add id_inter folding into simplification *)
        arewrite (⦗eq (ThreadEvent tid (eindex st_prev))⦘
                    ⨾ immediate (sb (G st_prev)) ≡ ∅₂).
        { unfold sb. rewrite <- restr_relE, RESTR_IMM, restr_relE.
          seq_rewrite <- id_inter. simplify_updated_sets. basic_solver. }
        remove_emptiness. unfold acts_set. rewrite <- wft_rmwE; eauto.
        by_IH IHn_steps. }
      { unfold_clear_updated; expand_rels; simplify_updated_sets.
        rewrite wft_rmwE at 2; eauto. fold (acts_set (G st_prev)).
        rewrite !seqA. repeat seq_rewrite <- id_inter.
        unfold_clear_updated; expand_rels; simplify_updated_sets.
        subst ev ev'. simplify_updated_sets. repeat rewrite id_inter.
        rewrite !seqA.
        unfold acts_set. seq_rewrite <- wft_rmwE; eauto.
        by_IH IHn_steps. }
      { subst ev ev'. rewrite UINDEX in *.
        unfold_clear_updated; expand_rels; simplify_updated_sets.
        rewrite unionA, codom_union. apply set_subset_union_r. left.
        by_IH IHn_steps. }
      { subst ev ev'. rewrite UINDEX in *.
        unfold_clear_updated; expand_rels; simplify_updated_sets.
        rewrite set_interA with (s'' := eq (ThreadEvent tid (eindex st_prev + 1))). simplify_updated_sets.
        rewrite id_union. apply set_subset_union_l. split.
        { expand_rels.
          repeat rewrite codom_union.
          repeat (apply set_subset_union_r; left).
          by_IH IHn_steps. }
        repeat rewrite codom_union.
        repeat (apply set_subset_union_r; right).
        basic_solver 10. }
    }
    { apply (same_relation_exp (@seqA _ _ _ _)) in BLOCK_STEP0.
      apply (same_relation_exp (seq_id_l (step tid ⨾ step tid))) in BLOCK_STEP0.
      red in BLOCK_STEP0. destruct BLOCK_STEP0 as [st_prev' [STEP1 STEP2]].
      do 2 (red in STEP1; desc). do 2 (red in STEP2; desc).
      forward eapply (BLOCK_CONTENTS 0 f) as INSTR; eauto.
      inversion ISTEP0.
      all: try (forward eapply (@H 0 f eq_refl instr); vauto; rewrite Nat.add_0_r; vauto).
      assert (instr = f).
      { cut (Some instr = Some f); [ins; vauto| ].
        rewrite ISTEP, INSTR. rewrite Nat.add_0_r.
        vauto. }
      rewrite <- INSTRS, UPC in *.
      subst instr. inversion H0. subst ord. (* subst reg. subst lexpr.  *)
      forward eapply (BLOCK_CONTENTS 1 exc) as INSTR'; eauto.
      inversion ISTEP2.
      all: try (forward eapply (@H 1 exc eq_refl instr0); by vauto).
      assert (instr0 = exc).
      { cut (Some instr0 = Some exc); [ins; vauto| ].
        rewrite ISTEP1. vauto. }
      subst instr0. inversion H1. subst expr_new xmod ordr ordw reg lexpr rexmod.
      remember (Afence Oacq) as lbl.
      remember (Aload true Osc (RegFile.eval_lexpr (regf st_prev') loc) val0) as lbl'.
      remember (Astore Xpln Osc (RegFile.eval_lexpr (regf st_prev') loc) nval) as lbl''.
      rename st into st_. remember (bst2st bst) as st.
      replace (init (flatten (binstrs bst_prev))) with (init (instrs st_prev)) in * by vauto.
      red.
      replace (bG bst) with (G st) by vauto.
      forward eapply (@step_12_label_ext_helper st_prev st_prev' st) as LBL_EXT; eauto.
      { red. splits; eauto. do 2 (red; eexists); eauto. }
      { red. splits; eauto. red. eexists. red. splits.
        { congruence. }
        exists exc. splits; eauto. rewrite INSTR'. f_equal; vauto. }
      rewrite Heqlbl(* , Heqlbl', Heqlbl'' *) in LBL_EXT. simpl in LBL_EXT. desc.
      remember (ThreadEvent tid (eindex st_prev)) as ev.
      remember (ThreadEvent tid (eindex st_prev')) as ev'.
      remember (ThreadEvent tid (eindex st_prev' + 1)) as ev''.
      assert (wf_thread_state tid st_prev') as WFT'.
      { eapply wf_thread_state_step; eauto. red. eexists. red. splits; eauto. }
      assert (wf_thread_state tid st) as WFT''.
      { eapply wf_thread_state_step; eauto. red. eexists. red.
        splits; [congruence| ]. exists exc. splits; eauto. congruence. }

      destruct SB_EXT as [[NO_E SB_TRIVIAL] | SB_EXT].
      { assert (immediate (sb (G st)) ≡ singl_rel ev ev' ∪ singl_rel ev' ev'') as IMM_SB.
        { rewrite immediate_sb_repr; eauto.
          rewrite UINDEX0, UINDEX.
          assert (eindex st_prev = 0) as EINDEX0.
          { destruct (gt_0_eq (eindex st_prev)); auto.
            exfalso. destruct WFT. forward eapply (@acts_clos 0); [omega| ].
            generalize NO_E. unfold acts_set. basic_solver 100. }
          rewrite EINDEX0.
          split.
          { red. ins. desc. subst ev ev' ev'' x y. rewrite UINDEX.
            destruct ind.
            { red. left. rewrite EINDEX0. red. split; f_equal; omega.  }
            assert (ind = 0); [by omega| subst ind].
            red. right. rewrite EINDEX0. red. split; f_equal; omega. }
          red. ins. red in H2. des.
          { subst ev ev'. red in H2. desc. subst. eexists. splits; eauto. omega. }
          { subst ev ev'. red in H2. desc. subst. eexists. splits; eauto. omega. }
        }
        rewrite NO_E in *. (* clear NO_E. *)
        (* subst ev ev' ev''. rewrite UINDEX in *.  *)
        splits. all: try rewrite IMM_SB.
        { subst ev ev' ev''. rewrite UINDEX in *.
          rewrite E_EXT, RMW_EXT.
          rewrite wft_rmwE; eauto. fold (acts_set (G st_prev)). rewrite NO_E.
          rewrite eqv_empty. remove_emptiness.
          unfold_clear_updated. expand_rels. simplify_updated_sets.
          basic_solver 10. }
        { unfold_clear_updated. remove_emptiness.
          rewrite set_unionA. expand_rels.
          arewrite (⦗Sc (G st_prev) ∪₁ (eq ev' ∪₁ eq ev'')⦘
                      ⨾ rmw (G st_prev) ⨾ ⦗Sc (G st_prev) ∪₁ (eq ev' ∪₁ eq ev'')⦘ ≡ rmw (G st_prev)).
          { rewrite rel_endpoints_dom.
            2: { eapply wft_rmwE; eauto. }
            fold (acts_set (G st_prev)).
            expand_sets_only. subst ev ev' ev''. simplify_updated_sets.
            rewrite set_interC at 2. rewrite !id_inter, !seqA.
            unfold acts_set. seq_rewrite <- wft_rmwE; eauto.
            symmetry. by_IH IHn_steps. }
          apply union_more; [basic_solver| ].
          rewrite rel_endpoints_dom.
          2: { symmetry. eapply unique_restr. basic_solver. }
          expand_sets_only. subst ev ev' ev''. simplify_updated_sets.
          rewrite unique_restr; basic_solver. }
        { subst ev ev' ev''. rewrite UINDEX.
          unfold_clear_updated; expand_rels; simplify_updated_sets.
           basic_solver 10. }
        { subst ev ev' ev''. rewrite UINDEX.
          unfold_clear_updated; expand_rels; simplify_updated_sets.
          basic_solver 10. }
      }
      assert (forall st_, immediate (sb (G st_)) ≡ ⦗E (G st_)⦘ ⨾ immediate (sb (G st_)) ⨾ ⦗E (G st_)⦘) as SB_IMM_E.
      { ins. unfold sb. rewrite <- restr_relE. rewrite RESTR_IMM.
        rewrite restr_relE. basic_solver 10. }
      splits.
      { subst ev ev' ev''. rewrite UINDEX in *.
        rewrite E_EXT, W_EXT, SC_EXT at 1.
        remove_emptiness. expand_sets_only. simplify_updated_sets.
        repeat rewrite set_interA. simplify_updated_sets.
        rewrite RMW_EXT. expand_rels. rewrite codom_union.
        apply set_equiv_union.
        { rewrite SB_EXT. rewrite !seq_union_l.
          rewrite wft_rmwE; eauto. fold (acts_set (G st_prev)).
          rewrite singl_rel_restr. rewrite singl_rel_restr with (x := (ThreadEvent tid (eindex st_prev))). rewrite singl_rel_restr with (x := (ThreadEvent tid (eindex st_prev + 1))).
          rewrite !seqA. repeat seq_rewrite <- id_inter. simplify_updated_sets.
          unfold acts_set. seq_rewrite <- wft_rmwE; eauto.
          rewrite SB_IMM_E. rewrite !seqA. seq_rewrite <- id_inter.
          unfold_clear_updated. expand_sets_only. simplify_updated_sets.
          rewrite id_inter, seqA. seq_rewrite <- SB_IMM_E.
          rewrite <- set_interA. by_IH IHn_steps. }
        rewrite SB_EXT. expand_rels.
        rewrite singl_rel_restr with (x := (ThreadEvent tid (eindex st_prev - 1))). rewrite singl_rel_restr with (x := (ThreadEvent tid (eindex st_prev))). rewrite singl_rel_restr with (x := (ThreadEvent tid (eindex st_prev + 1))).
        rewrite !seqA. repeat seq_rewrite <- id_inter. simplify_updated_sets.
        rewrite SB_IMM_E. rewrite !seqA. repeat seq_rewrite <- id_inter. simplify_updated_sets.
        rewrite <- singl_rel_restr.
        unfold_clear_updated. expand_sets_only. simplify_updated_sets.
        basic_solver 10. }
      { unfold_clear_updated; expand_rels; simplify_updated_sets.
        rewrite wft_rmwE at 2; eauto. fold (acts_set (G st_prev)).
        rewrite !seqA. repeat seq_rewrite <- id_inter.
        unfold_clear_updated; expand_rels; simplify_updated_sets.
        subst ev ev' ev''. simplify_updated_sets. repeat rewrite id_inter.
        rewrite !seqA. unfold acts_set. seq_rewrite <- wft_rmwE; eauto.
        apply union_more; [by_IH IHn_steps| ].
        rewrite singl_rel_restr. rewrite !seqA. repeat seq_rewrite <- id_inter.
        rewrite UINDEX. expand_rels. simplify_updated_sets.
        basic_solver. }
      { subst ev ev' ev''. rewrite UINDEX in *.
        unfold_clear_updated; expand_rels; simplify_updated_sets.
        rewrite unionA.
        do 2 (rewrite codom_union; apply set_subset_union_r; left).
        by_IH IHn_steps. }
      { subst ev ev' ev''. rewrite UINDEX in *.
        unfold_clear_updated; expand_rels; simplify_updated_sets.
        rewrite !set_interA. simplify_updated_sets.
        rewrite !unionA, codom_union. apply set_subset_union.
        { rewrite id_union. expand_rels. rewrite codom_union.
          apply set_subset_union_r. left. rewrite <- set_interA. by_IH IHn_steps. }
        basic_solver 10. }
    }
    { apply (same_relation_exp (seq_id_l (step tid))) in BLOCK_STEP0.
      do 2 (red in BLOCK_STEP0; desc).
      forward eapply (BLOCK_CONTENTS 0 asn) as INSTR; eauto.
      inversion ISTEP0.
      all: try (forward eapply (@H 0 asn eq_refl instr); vauto; rewrite Nat.add_0_r; vauto).
      subst st_prev. simpl in *. congruence. }
    { apply (same_relation_exp (seq_id_l (step tid))) in BLOCK_STEP0.
      do 2 (red in BLOCK_STEP0; desc).
      forward eapply (BLOCK_CONTENTS 0 igt) as INSTR; eauto.
      inversion ISTEP0.
      all: try (forward eapply (@H 0 igt eq_refl instr); vauto; rewrite Nat.add_0_r; vauto).
      subst st_prev. simpl in *. congruence. }
  Qed.

  Lemma GI_1thread_omm_premises tid PO PI Gi
        (COMP: is_thread_compiled PO PI)
        (EXEC: thread_execution tid PI Gi)
        (GOTO_RESTR: goto_addresses_restricted PO):
    omm_premises_hold Gi.
  Proof.
    red in EXEC. destruct EXEC as [st_fin [STEPS [TERM GRAPH]]].
    red in COMP. desc. red in COMP. desc.
    set (bst_fin := bst_from_st st_fin BPI (length BPI)).
    assert (st_fin = bst2st bst_fin) as BST.
    { replace PI with (instrs st_fin) in *.
      2: { apply eq_trans with (y := instrs (init PI)); auto.
           symmetry. apply steps_same_instrs. eauto. }
      unfold bst2st. simpl. rewrite firstn_all.
      red in TERM. rewrite (@is_terminal_pc_bounded st_fin tid PO (flatten BPI)) in TERM; [| rewrite <- COMP0; auto | vauto].
      rewrite <- COMP0 in *.
      rewrite <- TERM. by destruct st_fin. }
    forward eapply (@steps_imply_ommblocks bst_fin) as BLOCK_STEPS; eauto.
    { simpl. rewrite <- COMP0, <- BST. eauto. }
    replace Gi with (bG bst_fin).
    eapply GI_1thread_omm_premises_block; eauto.
  Qed.

End CompCorrHelpers.


Require Import Stack2 Stack3A HoareDef SimModSem.
Require Import Coqlib.
Require Import ImpPrelude.
Require Import Skeleton.
Require Import PCM.
Require Import ModSem Behavior.
Require Import Relation_Definitions.

(*** TODO: export these in Coqlib or Universe ***)
Require Import Relation_Operators.
Require Import RelationPairs.
From ITree Require Import
     Events.MapDefault.
From ExtLib Require Import
     Core.RelDec
     Structures.Maps
     Data.Map.FMapAList.
Require Import HTactics ProofMode IPM.
Require Import OpenDef STB.

Set Implicit Arguments.

Local Open Scope nat_scope.

Section SIMMODSEM.

  Context `{Σ: GRA.t}.
  Context `{@GRA.inG stkRA Σ}.

  Let W: Type := Any.t * Any.t.

  Inductive sim_loc: URA.car (t:=(Excl.t _)) -> option (list val) -> option (list val) -> Prop :=
  | sim_loc_k stk0: sim_loc (Some stk0) None (Some stk0)
  | sim_loc_u stk0: sim_loc ε (Some stk0) (Some stk0)
  | sim_loc_absent: sim_loc ε None None
  .

  Notation sim res0 mgr_src0 mgr_tgt0 :=
    (∀ h, sim_loc ((res0: URA.car (t:=_stkRA)) h)
                  ((mgr_src0: gmap mblock (list val)) !! h) ((mgr_tgt0: gmap mblock (list val)) !! h)).

  Let wf: _ -> W -> Prop :=
    @mk_wf _ unit
           (fun _ _mgr_src0 _mgr_tgt0 =>
              (∃ mgr_src0 mgr_tgt0 (res0: URA.car (t:=_stkRA)),
                  (⌜(<<SRC: _mgr_src0 = mgr_src0↑>>) /\ (<<TGT: _mgr_tgt0 = mgr_tgt0↑>>) /\
                   (<<SIM: sim res0 mgr_src0 mgr_tgt0>>)⌝)
                  ∧ ({{"O": OwnM ((Auth.black res0): URA.car (t:=stkRA))}})
              )%I)
  .

  Variable global_stb: gname -> option fspec.
  Hypothesis STBINCL: stb_incl (to_stb StackStb) global_stb.

  Lemma _is_stack_wf
        h stk
    :
      <<WF: URA.wf (_is_stack h stk)>>
  .
  Proof. ur. ur. i. unfold _is_stack. des_ifs; ur; ss. Qed.

  Hint Constructors sim_loc.
  Lemma sim_fresh_k
        res0 mgr_src0 mgr_tgt0
        (SIM: sim res0 mgr_src0 mgr_tgt0)
        (h: mblock) (stk: (list val))
        (FRESH: mgr_tgt0 !! h = None)
    :
      <<SIM: sim (<[h:=Excl.just stk]>res0) mgr_src0 (<[h:=stk]> mgr_tgt0)>>
  .
  Proof.
    ii.
    destruct (dec h h0).
    - subst. rewrite ! lookup_insert. unfold insert, fn_insert. des_ifs. ss.
      specialize (SIM h0). inv SIM; ss; et.
      { econs; ss; et. }
      { rewrite FRESH in *. clarify. }
      { econs; ss; et. }
    - rewrite lookup_insert_ne; ss. unfold insert, fn_insert. des_ifs.
  Qed.

  Lemma sim_update_k
        res0 mgr_src0 mgr_tgt0
        (SIM: sim res0 mgr_src0 mgr_tgt0)
        (h: mblock) (stk: (list val))
        (FRESH: mgr_src0 !! h = None)
    :
      <<SIM: sim (<[h:=Excl.just stk]>res0) mgr_src0 (<[h:=stk]> mgr_tgt0)>>
  .
  Proof.
    ii.
    destruct (dec h h0).
    - subst. rewrite ! lookup_insert. unfold insert, fn_insert. des_ifs. ss.
      specialize (SIM h0). inv SIM; ss; et.
      { econs; ss; et. }
      { rewrite FRESH in *. clarify. }
      { econs; ss; et. }
    - rewrite lookup_insert_ne; ss. unfold insert, fn_insert. des_ifs.
  Qed.

  Lemma sim_fresh_u
        res0 mgr_src0 mgr_tgt0
        (SIM: sim res0 mgr_src0 mgr_tgt0)
        (h: mblock) (stk: (list val))
        (FRESH: mgr_tgt0 !! h = None)
    :
      <<SIM: sim res0 (<[h:=stk]>mgr_src0) (<[h:=stk]> mgr_tgt0)>>
  .
  Proof.
    ii.
    destruct (dec h h0).
    - subst. rewrite ! lookup_insert. unfold insert, fn_insert. des_ifs. ss.
      specialize (SIM h0). inv SIM; ss; et.
      { rewrite FRESH in *. clarify. }
    - rewrite ! lookup_insert_ne; ss.
  Qed.

  Lemma sim_update_u
        res0 mgr_src0 mgr_tgt0
        (SIM: sim res0 mgr_src0 mgr_tgt0)
        (h: mblock) (stk: (list val))
        (FRESH: res0 h = ε)
    :
      <<SIM: sim res0 (<[h:=stk]> mgr_src0) (<[h:=stk]> mgr_tgt0)>>
  .
  Proof.
    ii.
    destruct (dec h h0).
    - subst. rewrite ! lookup_insert. unfold insert, fn_insert. des_ifs. ss.
      specialize (SIM h0). inv SIM; ss; et.
      { rewrite FRESH in *. clarify. }
    - rewrite ! lookup_insert_ne; ss.
  Qed.

  Lemma add_disj_insert
        (stk_res0: _stkRA) h stk
        (DISJ: stk_res0 h = ε)
    :
        (stk_res0 ⋅ _is_stack h stk) = <[h:=Excl.just stk]>stk_res0
  .
  Proof.
    unfold insert, fn_insert. extensionality b. ur. unfold _is_stack. des_ifs.
    - rewrite DISJ. rewrite URA.unit_idl. ss.
    - rewrite URA.unit_id. ss.
  Qed.

  (* Ltac renamer := *)
  (*   match goal with *)
  (*   | [mp_src: gmap nat (list val) |- _ ] => *)
  (*     let tmp := fresh "_tmp_" in *)
  (*     rename mp_src into tmp; *)
  (*     let name := fresh "stk_mgr0" in *)
  (*     rename tmp into name *)
  (*   end; *)
  (*   match goal with *)
  (*   | [ACC: current_iPropL _ ?Hns |- _ ] => *)
  (*     match Hns with *)
  (*     | context[(?name, ([∗ map] _↦_ ∈ _, _))%I] => mRename name into "SIM" *)
  (*     end *)
  (*   end *)
  (* . *)

  Ltac renamer :=
    let tmp := fresh "_tmp_" in

    match goal with
    | H: context[OwnM (Auth.black ?x)] |- _ =>
      rename x into tmp; let name := fresh "res0" in rename tmp into name
    end;

    match goal with
    | |- gpaco8 _ _ _ _ _ _ _ _ _ _ (Any.pair ?mp_src↑ _, _) ((?mp_tgt↑), _) =>

      (* rename mr_src into tmp; let name := fresh "res0" in rename tmp into name *)
      (* ; *)
      (* try match goal with *)
      (*     | H: _stkRA |- _ => rename H into tmp; let name := fresh "res0" in rename tmp into name *)
      (*     end *)
      (* ; *)

      repeat multimatch mp_src with
             | context[?g] =>
               match (type of g) with
               | gmap mblock (list val) =>
                 rename g into tmp; let name := fresh "mgr_src0" in rename tmp into name
               | _ => fail
               end
             end
      ;

      repeat multimatch mp_tgt with
             | context[?g] =>
               match (type of g) with
               | gmap mblock (list val) =>
                 rename g into tmp; let name := fresh "mgr_tgt0" in rename tmp into name
               | _ => fail
               end
             end
    end
  .
  Ltac post_call :=
    fold wf; clear_fast; mDesAll; des_safe; subst; try rewrite Any.upcast_downcast in *; clarify; renamer.

  Theorem sim_modsem: ModSemPair.sim (Stack3A.StackSem global_stb) (Stack2.StackSem).
  Proof.
    econstructor 1 with (wf:=wf) (le:=top2); ss; et; swap 2 3.
    { esplits. econs; ss.
      - eapply to_semantic. iIntros "H". iExists _, _, _. iSplits; ss; et.
    }
    econs; ss.
    { unfold Stack2.new_body, cfunN, cfunU. init.
      - harg. mDesAll. des; clarify. steps.
        post_call.
        rename x0 into h.
        astart 0. astop. steps. force_l. eexists. steps.

        mOwnWf "O".
        assert(WF1: forall k, res0 k <> Excl.boom).
        { eapply Auth.black_wf in WF0. eapply pw_wf in WF0. des. ii. specialize (WF0 k).
          destruct (res0 k); ss. ur in WF0; ss. }

        hret _; ss.
        { iPoseProof (OwnM_Upd with "O") as "O".
          { eapply Auth.auth_alloc2. instantiate (1:=(_is_stack h [])).
            rewrite add_disj_insert; ss.
            { eapply (@pw_insert_wf); et.
              { eapply Auth.black_wf; et. }
              { ur; ss. }
            }
            specialize (WF1 h). destruct (res0 h) eqn:T; ss; et.
            { spc SIM. rewrite T in *. inv SIM. rewrite _GUARANTEE in *. ss. }
          }
          iMod "O". iDestruct "O" as "[A B]". iModIntro. iSplitL "A"; ss; et.
          iSplits; ss; et. iPureIntro. ii.
          assert(B: res0 h = Excl.unit).
          { destruct (res0 h) eqn:V; ss.
            - specialize (SIM h). rewrite V in SIM. inv SIM. rewrite _GUARANTEE in *. ss.
            - exploit WF1; et; ss.
          }
          rewrite add_disj_insert; ss. eapply sim_fresh_k; et.
        }
      - harg. mDesAll. des; clarify. unfold new_body. cbn. steps. astop. steps.
        rename x0 into h. force_l. exists h. steps.
        unfold pget. steps.
        assert(S:=SIM h). rewrite _GUARANTEE in *. inv S; ss. astop. steps.
        astop. steps. force_l; ss. steps. astop. steps.

        hret _; ss.
        iModIntro. iSplits; ss; et. iPureIntro. eapply sim_fresh_u; et.
    }

    econs; ss.
    { unfold Stack2.pop_body, cfunN. init.
      - harg. mDesAll. des; clarify. steps. ss. mDesAll. des; clarify.
        renamer. rename n into h. rename l into stk0.

        mCombine "O" "A".
        mOwnWf "O".
        assert(A: forall k, URA.wf ((res0 k): URA.car (t:=Excl.t _))).
        { eapply URA.wf_mon in WF0.
          eapply Auth.black_wf in WF0. eapply pw_wf in WF0. des. ii. specialize (WF0 k). ss. }
        assert(B: res0 h = Some stk0).
        { dup WF0.
          eapply Auth.auth_included in WF0. des. unfold _is_stack in WF0. eapply pw_extends in WF0. des.
          spc WF0. des_ifs. ss. eapply Excl.extends in WF0; ss. }
        assert(S:=SIM h). rewrite B in *. inv S; ss. steps.
        astart 0. astop.
        destruct stk0 as [|x stk1].
        + steps. force_l. esplits. steps.
          rewrite <- H3. steps. hret _; ss.
          iDestruct "O" as "[A B]". iModIntro. iFrame. iSplitL "A"; ss; et.
        + steps.

          set (res1:=<[h:=Excl.just stk1]>res0).
          assert(WF1: URA.wf (res1: URA.car (t:=_stkRA))).
          { subst res1. eapply (@pw_insert_wf); et.
            { eapply URA.wf_mon in WF0. eapply Auth.black_wf in WF0. ss. }
            ur; ss.
          }

          mAssert _ with "O".
          { iApply (OwnM_Upd with "O").
            eapply Auth.auth_update with (a':=res1) (b':=_is_stack h (stk1)).
            bar. ii. ss. des. clarify. esplits; et.
            assert(D: ctx0 h = Excl.unit).
            { clear - B. repeat ur in B. unfold _is_stack in *. des_ifs. }
            extensionality h0. subst res1. unfold insert, fn_insert. des_ifs.
            - ur. rewrite D. unfold _is_stack. ur. des_ifs.
            - unfold _is_stack. ur. des_ifs.
          }
          mUpd "A". mDesOwn "A".

          assert(SIM0: sim res1 mgr_src0 (<[h:=stk1]> mgr_tgt0)).
          { eapply sim_update_k; et. }

          force_l. esplits. steps.
          rewrite <- H3. steps. hret _; ss.
          iModIntro. iFrame. iSplitL "A"; ss; et.
      - harg. mDesAll. des; clarify. unfold pop_body. cbn.
        steps. astop. steps. astop. steps. astop. steps.
        rename n into h. rename l into stk0. destruct v; ss. des_ifs_safe.
        assert(S:=SIM h). rewrite _UNWRAPU1 in *. inv S; ss. steps.
        destruct stk0 as [|x0 stk1].
        + steps. hret _; ss. iModIntro. iSplits; ss; et.
        + steps. unfold pput. astop. steps.

          hret _; ss.
          { iModIntro. iSplits; ss; et. iPureIntro. eapply sim_update_u; et. }
    }

    econs; ss.
    { unfold Stack2.push_body, cfunN. init.
      - harg. mDesAll. des; clarify. steps. ss. mDesAll. des; clarify.
        renamer. rename n into h. rename l into stk0. rename v into x.
        mCombine "O" "A".
        mOwnWf "O".
        assert(A: forall k, URA.wf ((res0 k): URA.car (t:=Excl.t _))).
        { eapply URA.wf_mon in WF0.
          eapply Auth.black_wf in WF0. eapply pw_wf in WF0. des. ii. specialize (WF0 k). ss. }
        assert(B: res0 h = Some stk0).
        { dup WF0.
          eapply Auth.auth_included in WF0. des. unfold _is_stack in WF0. eapply pw_extends in WF0. des.
          spc WF0. des_ifs. ss. eapply Excl.extends in WF0; ss. }
        assert(S:=SIM h). rewrite B in *. inv S; ss. steps.

        set (res1:=<[h:=Excl.just (x::stk0)]>res0).
        assert(WF1: URA.wf (res1: URA.car (t:=_stkRA))).
        { subst res1. eapply (@pw_insert_wf); et.
          { eapply URA.wf_mon in WF0. eapply Auth.black_wf in WF0. ss. }
          ur; ss.
        }

        mAssert _ with "O".
        { iApply (OwnM_Upd with "O").
          eapply Auth.auth_update with (a':=res1) (b':=_is_stack h (x::stk0)).
          bar. ii. ss. des. clarify. esplits; et.
          assert(D: ctx0 h = Excl.unit).
          { clear - B. repeat ur in B. unfold _is_stack in *. des_ifs. }
          extensionality h0. subst res1. unfold insert, fn_insert. des_ifs.
          - ur. rewrite D. unfold _is_stack. ur. des_ifs.
          - unfold _is_stack. ur. des_ifs.
        }
        mUpd "A". mDesOwn "A".

        assert(SIM0: sim res1 mgr_src0 (<[h:=x::stk0]> mgr_tgt0)).
        { eapply sim_update_k; et. }

        astop. steps.
        force_l. esplits. steps.
        rewrite <- H3. steps. hret _; ss.
        iModIntro. iFrame. iSplitL "A"; ss; et.
      - harg. mDesAll. des; clarify. unfold push_body. cbn.
        steps. astop. steps. astop. steps. astop. steps. astop. steps.
        rename n into h. rename l into stk0. destruct v; ss. des_ifs_safe.
        assert(S:=SIM h). rewrite _UNWRAPU0 in *. inv S; ss. steps.
        unfold pput. steps.

        hret _; ss.
        { iModIntro. iSplits; ss; et. iPureIntro. eapply sim_update_u; et. }
    }
  Unshelve.
    all: try exact 0. all: ss.
  Qed.

End SIMMODSEM.

Section SIMMOD.

  Context `{Σ: GRA.t}.
  Context `{@GRA.inG stkRA Σ}.

  Variable global_stb: Sk.t -> gname -> option fspec.
  Hypothesis STBINCL: forall sk, stb_incl (to_stb StackStb) (global_stb sk).

  Theorem correct: refines2 [Stack2.Stack] [Stack3A.Stack global_stb].
  Proof.
    eapply adequacy_local2. econs; ss.
    { ii. eapply sim_modsem; ss. }
  Qed.

End SIMMOD.


Require Export Iron.Language.SystemF2.Ki.
Require Export Iron.Language.SystemF2.KiJudge.
Require Export Iron.Language.SystemF2.TyEnv.
Require Export Iron.Language.SystemF2.TySubsts.
Require Export Iron.Language.SystemF2Store.Def.
Require Export Iron.Language.SystemF2Store.Exp.
Require Import Coq.Logic.FunctionalExtensionality.

(******************************************************************************)
(* Builtin in types. *)
Definition tUnit
 := makeTApps (TCon tcUnit) nil.

Definition tFun (t1: ty) (t2: ty)
 := TApp (TApp (TCon TyConFun) t1) t2.
Hint Unfold tFun.

(* TODO: move this to Env module *)
(* Store Typing holds the types of locations *)
Definition stenv := list ty.

(******************************************************************************)
(* Type Judgement assigns a type to an expression. *)
Inductive TYPE (ds: defs) (ke: kienv) (te: tyenv) (se: stenv)
           : exp -> ty -> Prop :=

 (* Variables *)
 | TyVar
   :  forall i t
   ,  DEFSOK ds
   -> get i te = Some t
   -> TYPE ds ke te se (XVar i) t

 (* Locations must refer to data types.
    Naked functions are not place in the store because
    they are not updatable and have no region annotations. *)
 | TyLoc
   :  forall i t tc
   ,  DEFSOK ds
   -> get i se         = Some t
   -> getCtorOfType t  = Some tc
   -> isTyConData tc

   -> TYPE ds ke te se (XLoc i) t

 (* Type abstraction *)
 | TyLAM
   :  forall x1 t1
   ,  TYPE ds (ke :> KStar) (liftTE 0 te) (liftTE 0 se) x1 t1
   -> TYPE ds ke             te           se            (XLAM x1) (TForall t1)

 (* Type application *)
 | TyAPP
   :  forall x1 t1 t2
   ,  TYPE ds ke te se x1 (TForall t1)
   -> KIND ke t2 KStar
   -> TYPE ds ke te se (XAPP x1 t2) (substTT 0 t2 t1)

 (* Function abstraction *)
 | TyLam
   :  forall x t1 t2
   ,  KIND ke t1 KStar
   -> TYPE ds ke (te :> t1) se x            t2
   -> TYPE ds ke te         se (XLam t1 x) (tFun t1 t2)

 (* Applications *)
 | TyApp
   :  forall x1 x2 t1 t2
   ,  TYPE ds ke te se x1           (tFun t1 t2)
   -> TYPE ds ke te se x2           t1
   -> TYPE ds ke te se (XApp x1 x2) t2

 (* Data Constructors *)
 | TyCon
   :  forall tc (ks: list ki) tsFields tsParam xs dc dcs
   ,  hasDef ds (DefType tc ks       dcs)
   -> hasDef ds (DefData dc tsFields tc)
   -> Forall2 (KIND ke) tsParam ks
   -> Forall2 (TYPE ds ke te se) xs (map (substTTs 0 tsParam) tsFields)
   -> TYPE ds ke te se (XCon dc tsParam xs) (makeTApps (TCon tc) tsParam)

 (* Case Expressions *)
 | TyCase
   :  forall xObj tObj tcObj ks tResult alts dcs

      (* check types of expression and alternatives *)
   ,  TYPE ds ke te se xObj tObj
   -> Forall (fun alt => TYPEA ds ke te se alt tObj tResult) alts

      (* All data cons must have a corresponding alternative.
         Maybe we should move this to the well-formedness judgement *)
   -> getCtorOfType tObj  = Some tcObj
   -> hasDef ds (DefType tcObj ks dcs)
   -> Forall (fun dc => In dc (map dcOfAlt alts)) dcs

   -> TYPE ds ke te se (XCase xObj alts) tResult

 (* Update data object *)
 | TyUpdate
   :  forall i xObj dcObj tcObj tsParam tsFields ks dcs xField tField
   ,  hasDef ds (DefType tcObj ks dcs)
   -> hasDef ds (DefData dcObj tsFields tcObj)
   -> Forall2 (KIND ke) tsParam ks
   -> get i  tsFields     = Some tField
   -> TYPE ds ke te se xObj (makeTApps (TCon tcObj) tsParam)
   -> TYPE ds ke te se xField (substTTs 0 tsParam tField)
   -> TYPE ds ke te se (XUpdate dcObj i tsParam xObj xField) tUnit

with TYPEA  (ds: defs) (ke: kienv) (te: tyenv) (se: stenv)
     : alt -> ty -> ty -> Prop :=
 (* Case Alternatives *)
 | TyAlt
   :  forall x1 dc tc ks tsParam tsFields tResult dcs
   ,  hasDef ds (DefType tc ks dcs)
   -> hasDef ds (DefData dc tsFields tc)
   -> Forall2 (KIND ke) tsParam ks
   -> TYPE  ds ke (te >< map (substTTs 0 tsParam) tsFields) se x1 tResult
   -> TYPEA ds ke te se (AAlt dc x1) (makeTApps (TCon tc) tsParam) tResult.

Hint Constructors TYPE.
Hint Constructors TYPEA.

(* Invert all hypothesis that are compound typing statements. *)
Ltac inverts_type :=
 repeat
  (match goal with
   | [ H: TYPE  _ _ _ _ (XVar  _)     _       |- _ ] => inverts H
   | [ H: TYPE  _ _ _ _ (XLoc  _)     _       |- _ ] => inverts H
   | [ H: TYPE  _ _ _ _ (XLAM  _)     _       |- _ ] => inverts H
   | [ H: TYPE  _ _ _ _ (XAPP  _ _)   _       |- _ ] => inverts H
   | [ H: TYPE  _ _ _ _ (XLam  _ _)   _       |- _ ] => inverts H
   | [ H: TYPE  _ _ _ _ (XApp  _ _)   _       |- _ ] => inverts H
   | [ H: TYPE  _ _ _ _ (XCon  _ _ _) _       |- _ ] => inverts H
   | [ H: TYPE  _ _ _ _ (XCase _ _)   _       |- _ ] => inverts H
   | [ H: TYPE  _ _ _ _ (XUpdate _ _ _ _ _) _ |- _ ] => inverts H
   | [ H: TYPEA _ _ _ _ (AAlt _ _)    _ _     |- _ ] => inverts H
   end).

(********************************************************************)
(* Well typing imples data type defs are ok *)
Lemma type_defsok
 :  forall ds ke te se x t
 ,  TYPE ds ke te se x t
 -> DEFSOK ds.
Proof.
 intros. gen ke te se t.
 induction x using exp_mutind with
  (PA := fun a => forall ke te se t1 t2
      ,  TYPEA ds ke te se a t1 t2
      -> DEFSOK ds)
   ; intros; inverts_type; try eauto.
Qed.
Hint Resolve type_defsok.

(********************************************************************)
(* Uniqueness of typing *)
Lemma type_unique
 :  forall ds ke te se x t1 t2
 ,  TYPE ds ke te se x t1
 -> TYPE ds ke te se x t2
 -> t1 = t2.
Proof.
 intros. gen ds ke te se t1 t2.
 induction x using exp_mutind with
  (PA := fun a => forall ds ke te se t2 t3 t3'
      ,  TYPEA ds ke te se a t2 t3
      -> TYPEA ds ke te se a t2 t3'
      -> t3 = t3');
  intros; try (solve [inverts_type; try congruence]).

 inverts_type. spec IHx H1 H2. auto. congruence.
 inverts_type. spec IHx H2 H3. auto. congruence.
 inverts_type. spec IHx H5 H6. auto. congruence.

 Case "XApp".
  inverts_type.
  spec IHx1 H3 H2. auto.
  spec IHx2 H5 H6. auto.
  unfold tFun in *.
  congruence.

 Case "XCon".
  inverts_type.
  defs_merge.
  auto.

 Case "XCase".
  inverts_type.
  have (tObj0 = tObj).
   eauto. subst.

  repeat nforall.
  assert (length aa > 0).
   lets D: @length_in_in_nonempty H9.
   have (DEFOK ds (DefType tcObj ks dcs)) as HD.
   inverts HD.
   lists. rip.

  destruct aa.
   nope.
   have (TYPEA ds ke te se a tObj t1) as HT1.
   have (TYPEA ds ke te se a tObj t2) as HT2.
   spec H a HT1 HT2; burn.

 Case "Alt".
  inverts_type.
  eapply makeTApps_eq_params in H2. rip.
  defs_merge.
  lets D1: IHx H8 H11; auto.
Qed.

(********************************************************************)
(* Forms of values.
   If we know the type of a value,
   then we know the form of that value. *)
Lemma value_lam
 :  forall x ds ke te se t1 t2
 ,  value x
 -> TYPE ds ke te se x (tFun t1 t2)
 -> (exists t x', x = XLam t x').
Proof.
 intros. destruct x; eauto; nope.

 (* 'x' can't be a XLoc because we don't store naked functions in the heap *)
 Case "XLoc n = XLam t x'".
  inverts H0.
  unfold tFun in H4.
  simpl in *. inverts H4.
  nope.
Qed.
Hint Resolve value_lam.

Lemma value_loc
 :  forall x ds ke te se tcObj ts
 ,  value x
 -> isTyConData tcObj
 -> TYPE ds ke te se x (makeTApps (TCon tcObj) ts)
 -> (exists l, x = XLoc l).
Proof.
 intros. destruct x; eauto; nope.

 Case "XLAM x = XLoc l".
  inverts_type.
   symmetry in H3.
   apply makeTApps_takeTCon in H3.
   nope.

 Case "XLam t x = XLoc l".
  inverts_type.
   symmetry in H4.
   unfold tFun in *.
   apply makeTApps_takeTCon in H4.
   simpl in H4.
   inverts H4.
   nope.
Qed.

(********************************************************************)
(* Forms of types *)
Lemma type_XLAM
 :  forall ds ke te se x t
 ,  TYPE ds ke te se (XLAM x) t
 -> (exists t', t = TForall t').
Proof.
 intros. destruct t; nope.
 eauto.
Qed.
Hint Resolve type_XLAM.

Lemma type_XLam
 :  forall ds ke te se x t1 t2
 ,  TYPE ds ke te se (XLam t1 x) t2
 -> (exists t21 t22, t2 = tFun t21 t22).
Proof.
 intros. destruct t2; nope.
 inverts H.
 unfold tFun. eauto.
Qed.
Hint Resolve type_XLam.

(********************************************************************)
(* A well typed expression is well formed *)

Theorem type_wfX
 :  forall ds ke te se x t
 ,  TYPE ds ke te se x t
 -> wfX (length ke) (length te) (length se) x.
Proof.
 intros. gen ds ke te se t.
 induction x using exp_mutind with
  (PA := fun a => forall ds ke te se t1 t2
      ,  TYPEA ds ke te se a t1 t2
      -> wfA (length ke) (length te) (length se) a)
  ; intros; inverts_type; eauto.

 Case "XLAM".
  eapply WfX_XLAM.
  apply IHx in H1.
  rrwrite (length (ke :> KStar) = S (length ke)) in H1.
  rewrite <- length_liftTE in H1.
  rewrite <- length_liftTE in H1.
  auto.

 Case "XLam".
  eapply WfX_XLam; eauto.
  apply IHx in H4.
  rrwrite (length (te :> t) = S (length te)) in H4.
  auto.

 Case "XCon".
  apply WfX_XCon.
  repeat nforall. intros.
  have (exists k, KIND ke x k).
  dest k. eauto.
   repeat nforall. intros.
   have (exists t, TYPE ds ke te se x t).
   dest t. eauto.

 Case "XCase".
  eapply WfX_XCase; eauto.
  repeat nforall. eauto.

 Case "XAlt".
  destruct dc.
  eapply WfA_AAlt. eauto.
  apply IHx in H7.
  rr. lists.
  rrwrite (length te + length tsFields = length tsFields + length te).
  eauto.
Qed.
Hint Resolve type_wfX.

Lemma type_wfX_Forall2
 :  forall ds ke te se xs ts
 ,  Forall2 (TYPE ds ke te se) xs ts
 -> Forall (wfX (length ke) (length te) (length se)) xs.
Proof.
 intros.
 eapply (Forall2_Forall_left (TYPE ds ke te se)).
 intros. nforall. eauto.
 eauto.
Qed.
Hint Resolve type_wfX_Forall2.

(********************************************************************)
(* Weakening Kind Env in Type Judgement. *)
Lemma type_kienv_insert
 :  forall ix ds ke te se x1 t1 k2
 ,  TYPE ds ke                te             se              x1             t1
 -> TYPE ds (insert ix k2 ke) (liftTE ix te) (liftTE ix se) (liftTX ix x1) (liftTT 1 ix t1).
Proof.
 intros. gen ix ds ke te se t1 k2.
 induction x1 using exp_mutind with
  (PA := fun a => forall ix ds ke te se k2 t3 t4
               ,  TYPEA ds ke te se a t3 t4
               -> TYPEA ds (insert ix k2 ke) (liftTE ix te)   (liftTE ix se)
                           (liftTA ix a)     (liftTT 1 ix t3) (liftTT 1 ix t4))
  ; intros; inverts_type; simpl; eauto.

 Case "XVar".
  apply TyVar; auto.
  apply get_map; auto.

 Case "XLoc".
  eapply TyLoc; eauto.
  apply get_map; auto.
  burn.

 Case "XLAM".
  eapply TyLAM.
  rewrite insert_rewind.
  rewrite (liftTE_liftTE 0 ix).
  rewrite (liftTE_liftTE 0 ix).
  burn.

 Case "XAPP".
  rewrite (liftTT_substTT' 0 ix).
  simpl.
  eapply TyAPP.
  eapply (IHx1 ix) in H2. simpl in H2. eauto.
  apply kind_kienv_insert; auto.

 Case "XLam".
  apply TyLam.
   apply kind_kienv_insert. auto.
   rrwrite ( liftTE ix te :> liftTT 1 ix t
           = liftTE ix (te :> t)).
   burn.

 Case "XApp".
  eapply TyApp.
   eapply IHx1_1 in H2. simpl in H2. eauto.
   eapply IHx1_2 in H4. eauto.

 Case "XCon".
  (* unpack the data type definition *)
  have (DEFOK ds (DefData dc tsFields tc)).

  (* show XCon has the correct type *)
  rr. eapply TyCon; eauto.

   (* type args have correct kinds *)
    eapply Forall2_map_left.
    eapply Forall2_impl; eauto.
    eauto using kind_kienv_insert.

   (* exp args have correct types *)
    apply Forall2_map.
    apply Forall2_map_right' in H8.

    eapply Forall2_impl_in; eauto.
     simpl. intros.

     nforall.
     lets D: H x ix k2; auto. clear H.
     eauto.

     have (wfT (length ks) y) as HT.
     have (length ts = length ks) as HL.
     rewrite <- HL in HT.

     assert ( liftTT 1 ix (substTTs 0 ts y)
            = substTTs 0 (map (liftTT 1 ix) ts) y) as HF.
      rrwrite (ix = ix + 0).
      rewrite liftTT_substTTs'.
      rrwrite (ix + 0 = ix).
      f_equal.
      rr. auto.

     rewrite <- HF.
     auto.

 Case "XCase".
  eapply TyCase; eauto.
  apply  Forall_map.
  eapply Forall_impl_in; eauto.
   intros. repeat nforall.
   eapply H; burn.
    rr. burn.
    repeat nforall. intros.
     have (In x (map dcOfAlt aa)).
     rr. auto.

 Case "XUpdate".
  have (DEFOK ds (DefData dc tsFields tcObj)).
  eapply TyUpdate; eauto.
   eapply Forall2_map_left.
    eapply Forall2_impl; eauto.
    eauto using kind_kienv_insert.
  rrwrite (TCon tcObj = liftTT 1 ix (TCon tcObj)).
  rewrite <- liftTT_makeTApps.
  eauto.
  rrwrite (ix = 0 + ix).
   rewrite substTTs_liftTT.
    rr. eauto.
    rr.
    rrwrite (length ts = length ks).
    repeat nforall. eauto.

 Case "XAlt".
  have (DEFOK ds (DefData dc tsFields tc)).

  rr.
  eapply TyAlt; eauto.
   eapply Forall2_map_left.
   eapply Forall2_impl; eauto.
    intros. eapply kind_kienv_insert. auto.

   assert ( map (liftTT 1 ix) (map (substTTs 0 tsParam)  tsFields)
          = map (substTTs 0 (map (liftTT 1 ix) tsParam)) tsFields) as HXX.
    lists.
    erewrite map_ext_in; eauto.
    intros.
    rename a into t1.

    rrwrite (ix = ix + 0).
    rewrite liftTT_substTTs'.
    f_equal.
    nnat.

    have (wfT (length ks) t1).
    rw   (length tsParam = length ks).
    auto.

   unfold liftTE in IHx1.
   unfold liftTE.
   rewrite <- HXX.
   rewrite <- map_app.
   burn.
Qed.

Lemma type_kienv_weaken1
 :  forall ds ke te se x1 t1 k2
 ,  TYPE ds ke                   te  se            x1            t1
 -> TYPE ds (ke :> k2) (liftTE 0 te) (liftTE 0 se) (liftTX 0 x1) (liftTT 1 0 t1).
Proof.
 intros.
 assert (ke :> k2 = insert 0 k2 ke) as HI.
  simpl. destruct ke; auto.
 rewrite HI.
 eapply type_kienv_insert; auto.
Qed.

(********************************************************************)
(* Weakening Type Env in Type Judgement.
   We can insert a new type into the type environment, provided we
   lift existing references to types higher in the stack across
   the new one. *)
Lemma type_tyenv_insert
 :  forall ds ke te se ix x t1 t2
 ,  TYPE ds ke te se x t1
 -> TYPE ds ke (insert ix t2 te) se (liftXX 1 ix x) t1.
Proof.
 intros. gen ix ds ke se te t1 t2.
 induction x using exp_mutind with
  (PA := fun a => forall ix ds ke se te t2 t3 t4
      ,  TYPEA ds ke te se a t3 t4
      -> TYPEA ds ke (insert ix t2 te) se (liftXA 1 ix a) t3 t4)
  ; intros; inverts_type; simpl; eauto.

 Case "XVar".
  nnat; lift_cases; burn.

 Case "XLAM".
  apply TyLAM.
  assert ( liftTE 0 (insert ix t2 te)
         = insert ix (liftTT 1 0 t2) (liftTE 0 te)).
   unfold liftTE. rewrite map_insert. auto.
   burn.

 Case "XLam".
  apply TyLam; eauto.
  rewrite insert_rewind. auto.

 Case "XCon".
  eapply TyCon; eauto.
   nforall.
   apply (Forall2_map_left (TYPE ds ke (insert ix t2 te) se)).
   apply (Forall2_impl_in  (TYPE ds ke te se)); eauto.

 Case "XCase".
  eapply TyCase; eauto.
   apply Forall_map.
   apply (Forall_impl_in
     (fun a => TYPEA ds ke te se a tObj t1)); eauto.
   repeat nforall. eauto.
   repeat nforall.
    intros. lists.
    rename x0 into d.
    eapply map_exists_in.
    have (In d (map dcOfAlt aa)).
    assert (exists a, dcOfAlt a = d /\ In a aa).
     eapply map_in_exists. auto.
   shift a. rip.
   eapply dcOfAlt_liftXA.

 Case "XAlt".
  have (DEFOK ds (DefData dc tsFields tc)).
  destruct dc. inverts keep H.
  eapply TyAlt; eauto.
  rewrite insert_app.
  lists.
  eauto.
Qed.

(* We can push a new type onto the environment stack provided
   we lift references to existing types across the new one. *)
Lemma type_tyenv_weaken1
 :  forall ds ke te se x t1 t2
 ,  TYPE ds ke te se x t1
 -> TYPE ds ke (te :> t2) se (liftXX 1 0 x) t1.
Proof.
 intros.
 assert (te :> t2 = insert 0 t2 te) as HI.
  simpl. destruct te; auto.
 rewrite HI.
 apply type_tyenv_insert. auto.
Qed.

(* We can several new types onto the environment stack provided
   we lift referenes to existing types across the new one. *)
Lemma type_tyenv_weaken_append
 :  forall ds ke te te' se x t1
 ,  TYPE ds ke te se x t1
 -> TYPE ds ke (te >< te') se (liftXX (length te') 0 x) t1.
Proof.
 intros.
 induction te'; simpl.
  burn.

  rrwrite (S (length te') = length te' + 1).
  rrwrite (length te' + 1 = 1 + length te').
  rewrite <- liftXX_plus.
  eapply type_tyenv_weaken1.
  burn.
Qed.

(********************************************************************)
(* Weakening Store Typing in Type Judgement. *)
Lemma type_stenv_snoc
 :  forall ds ke te se t2    x t1
 ,  closedT t2
 -> TYPE ds ke te se         x t1
 -> TYPE ds ke te (t2 <: se) x t1.
Proof.
 intros. gen ds ke te se t1 t2.
 induction x using exp_mutind with
  (PA := fun a => forall ds ke te se t2 t3 t4
      ,  closedT t2
      -> TYPEA ds ke te se         a t3 t4
      -> TYPEA ds ke te (t2 <: se) a t3 t4)
  ; intros; inverts_type; eauto.

 Case "XLAM".
  eapply TyLAM.
  unfold liftTE in *. rr.
  spec IHx H2. eauto.

 Case "XCon".
  eapply TyCon; eauto.
  eapply Forall2_impl_in with (R1 := TYPE ds ke te se);
   repeat nforall; eauto.

 Case "XCase".
  eapply TyCase;
   repeat nforall; eauto.
Qed.
Hint Resolve type_stenv_snoc.

Lemma type_stenv_weaken
 :  forall ds ke te se1 se2 x t1
 ,  Forall closedT se2
 -> TYPE ds ke te  se1         x t1
 -> TYPE ds ke te (se2 >< se1) x t1.
Proof.
 intros. gen ds ke te se1.
 induction se2; intros.
 rewrite app_nil_right. auto.
 rrwrite ((se2 :> a) >< se1 = se2 >< (a <: se1)).
 inverts H. eauto.
Qed.
Hint Resolve type_stenv_weaken.

Lemma type_stenv_extends
 :  forall ds ke te se1 se2 x t1
 ,  Forall closedT se2
 -> extends se2 se1
 -> TYPE ds ke te se1 x t1
 -> TYPE ds ke te se2 x t1.
Proof.
 intros.
 unfold extends in *.
 destruct H0 as [se3]. subst.
 eapply type_stenv_weaken; auto.
  eauto.
Qed.
Hint Resolve type_stenv_extends.

Lemma typea_stenv_extends
 :  forall ds ke te aa t1 t2 se1 se2
 ,  Forall closedT se2
 -> extends se2 se1
 -> TYPEA ds ke te se1 aa t1 t2
 -> TYPEA ds ke te se2 aa t1 t2.
Proof.
 intros.
 destruct aa.
 inverts H1.
 eauto.
Qed.
Hint Resolve typea_stenv_extends.


From iris.algebra Require Import auth agree excl gmap gset frac.
From iris.proofmode Require Import proofmode.
From iris.base_logic Require Import invariants.
From iris.program_logic Require Import adequacy.
From cap_machine Require Import
     stdpp_extra iris_extra
     rules logrel fundamental.
From cap_machine.examples Require Import addr_reg_sample malloc assert macros_new.
From cap_machine.examples Require Export mkregion_helpers disjoint_regions_tactics.
From cap_machine.examples Require Import template_adequacy.

Module ocpl.
Include with_adv_and_link.

Record ocpl_library `{MachineParameters} := MkOcplLibrary {
  (* malloc library *)
  malloc_start : Addr;
  malloc_memptr : Addr;
  malloc_mem_start : Addr;
  malloc_end : Addr;

  malloc_code_size :
    (malloc_start + length malloc_subroutine_instrs)%a
    = Some malloc_memptr;

  malloc_memptr_size :
    (malloc_memptr + 1)%a = Some malloc_mem_start;

  malloc_mem_size :
    (malloc_mem_start <= malloc_end)%a;

  (* assert library *)
  assert_start : Addr;
  assert_cap : Addr;
  assert_flag : Addr;
  assert_end : Addr;

  assert_code_size :
    (assert_start + length assert_subroutine_instrs)%a = Some assert_cap;
  assert_cap_size :
    (assert_cap + 1)%a = Some assert_flag;
  assert_flag_size :
    (assert_flag + 1)%a = Some assert_end;

  (* disjointness of the two libraries *)
  libs_disjoint : ## [
      finz.seq_between assert_start assert_end;
      finz.seq_between malloc_mem_start malloc_end;
      [malloc_memptr];
      finz.seq_between malloc_start malloc_memptr
     ]
}.

Definition malloc_library_content `{MachineParameters} (layout : ocpl_library) : gmap Addr Word :=
  (* code for the malloc subroutine *)
  mkregion (malloc_start layout) (malloc_memptr layout) malloc_subroutine_instrs
  (* Capability to malloc's memory pool, used by the malloc subroutine *)
  ∪ list_to_map [((malloc_memptr layout), WCap RWX (malloc_memptr layout) (malloc_end layout) (malloc_mem_start layout))]
  (* Malloc's memory pool, initialized to zero *)
  ∪ mkregion (malloc_mem_start layout) (malloc_end layout) (region_addrs_zeroes (malloc_mem_start layout) (malloc_end layout)).

Definition lib_entry_malloc `{MachineParameters} (layout : ocpl_library) : lib_entry :=
  {| lib_start := malloc_start layout;
     lib_end := malloc_end layout;
     lib_entrypoint := malloc_start layout;
     lib_full_content := malloc_library_content layout|}.

(* assert library entry *)
Definition assert_library_content `{MachineParameters} (layout : ocpl_library) : gmap Addr Word :=
  (* code for the assert subroutine, followed by a capability to the assert flag
     and the flag itself, initialized to 0. *)
  mkregion (assert_start layout) (assert_cap layout) assert_subroutine_instrs
  ∪ list_to_map [(assert_cap layout, WCap RW (assert_flag layout) (assert_end layout) (assert_flag layout))]
  ∪ list_to_map [(assert_flag layout, WInt 0)] (* assert flag *).

Definition lib_entry_assert `{MachineParameters} (layout : ocpl_library) : lib_entry :=
  {| lib_start := assert_start layout;
     lib_end := assert_end layout;
     lib_entrypoint := assert_start layout;
     lib_full_content := assert_library_content layout |}.

(* full library *)
Definition library `{MachineParameters} (layout : ocpl_library) : lib :=
  {| priv_libs := [lib_entry_assert layout] ;
     pub_libs := [lib_entry_malloc layout] |}.

Definition OK_invariant `{MachineParameters} (layout : ocpl_library) (m : gmap Addr Word) : Prop :=
  ∀ w, m !! (assert_flag layout) = Some w → w = WInt 0%Z.

Definition OK_dom `{MachineParameters} (layout : ocpl_library) : gset Addr := {[ assert_flag layout ]}.

Program Definition OK_dom_correct `{MachineParameters} (layout : ocpl_library) :
  ∀ m m',
    (∀ a, a ∈ OK_dom layout → ∃ x, m !! a = Some x ∧ m' !! a = Some x) →
    OK_invariant layout m ↔ OK_invariant layout m'.
Proof.
  intros m m' Hdom.
  destruct Hdom with (assert_flag layout) as [w [Hw1 Hw2] ]. rewrite /OK_dom. set_solver.
  split;intros HOK;intros w' Hw';simplify_eq;apply HOK;auto.
Defined.

Definition flag_inv `{MachineParameters} (layout : ocpl_library) : memory_inv :=
  {| minv := OK_invariant layout;
     minv_dom := {[ assert_flag layout ]} ;
     minv_dom_correct := OK_dom_correct layout |}.

Lemma flag_inv_is_initial_memory `{MachineParameters} (layout : ocpl_library) trusted_prog adv_prog trusted_table adv_table m :
  is_initial_memory trusted_prog adv_prog (library layout) trusted_table adv_table m →
  minv (flag_inv layout) m.
Proof.
  intros Hinit. intros a Hin.
  destruct Hinit as (?&?&Hlibs&?&?&?&Hlibdisj).
  cbn in Hlibs. rewrite map_union_empty in Hlibs.
  assert ((assert_library_content layout) ⊆ m) as Hassert.
  { etrans;[|eauto]. apply map_union_subseteq_r. cbn in Hlibdisj.
    rewrite !map_union_empty in Hlibdisj. auto. }
  pose proof (assert_code_size layout). pose proof (assert_cap_size layout).
  pose proof (assert_flag_size layout).
  assert (list_to_map [(assert_flag layout, WInt 0)] ⊆ m) as Hassert_flag.
  { etrans;[|eauto]. eapply map_union_subseteq_r'. 2: done.
    pose proof (libs_disjoint layout) as Hdisjoint. disjoint_map_to_list.
    apply elem_of_disjoint. intro. rewrite elem_of_app !elem_of_finz_seq_between !elem_of_list_singleton.
    intros [ [? ?]|?] ->; solve_addr. }
  eapply (lookup_weaken _ _ (assert_flag layout) (WInt 0)) in Hassert_flag.
    by simplify_eq. by simplify_map_eq.
Qed.

Lemma flag_inv_sub `{MachineParameters} (layout : ocpl_library) :
  minv_dom (flag_inv layout) ⊆ dom (lib_region (priv_libs (library layout))).
Proof.
  cbn. rewrite map_union_empty.
  intros ? Hinit. rewrite elem_of_singleton in Hinit.
  rewrite /assert_library_content.
  pose proof (assert_code_size layout). pose proof (assert_cap_size layout).
  pose proof (assert_flag_size layout).
  rewrite /= dom_union_L. apply elem_of_union_r.
  rewrite dom_insert_L. set_solver.
Qed.

Definition assertInv `{memG Σ, regG Σ, MachineParameters} (layout : ocpl_library) :=
  assert_inv (assert_start layout) (assert_flag layout) (assert_end layout).
Definition mallocInv `{memG Σ, regG Σ, MachineParameters} (layout : ocpl_library) :=
  malloc_inv (malloc_start layout) (malloc_end layout).

Definition mallocN : namespace := nroot .@ "pub" .@ "malloc".
Definition assertN : namespace := nroot .@ "priv" .@ "assert".

Theorem ocpl_template_adequacy `{MachineParameters} (Σ : gFunctors)
    (layout: ocpl_library)
    (P Adv: prog)
    (P_tbl : @tbl_priv P (library layout))
    (Adv_tbl : @tbl_pub Adv (library layout)) (r_adv : RegName)
    (m m': Mem) (reg reg': Reg) (es: list cap_lang.expr):
  is_initial_memory P Adv (library layout) P_tbl Adv_tbl m →
  is_initial_registers P Adv (library layout) P_tbl Adv_tbl reg r_adv →
  Forall (λ w, is_z w = true) (prog_instrs Adv) →

  let filtered_map := λ (m : gmap Addr Word), filter (fun '(a, _) => a ∉ minv_dom (flag_inv layout)) m in
  (∀ `{memG Σ', regG Σ', sealStoreG Σ', logrel_na_invs Σ', subG Σ Σ'} rmap,
      dom rmap = all_registers_s ∖ {[ PC; r_adv ]} →
      ⊢ inv invN (minv_sep (flag_inv layout))
        ∗ na_inv logrel_nais mallocN (mallocInv layout)
        ∗ na_inv logrel_nais assertN (assertInv layout)
        ∗ na_own logrel_nais ⊤
        ∗ PC ↦ᵣ WCap RWX (prog_lower_bound P_tbl) (prog_end P) (prog_start P)
        ∗ r_adv ↦ᵣ WCap RWX (prog_lower_bound Adv_tbl) (prog_end Adv) (prog_start Adv)
        ∗ ([∗ map] r↦w ∈ rmap, r ↦ᵣ w ∗ ⌜is_z w = true⌝)
        (* P program and table *)
        ∗ (prog_lower_bound P_tbl) ↦ₐ (WCap RO (tbl_start P_tbl) (tbl_end P_tbl) (tbl_start P_tbl))
        ∗ ([∗ map] a↦w ∈ (tbl_region P_tbl), a ↦ₐ w)
        ∗ ([∗ map] a↦w ∈ (prog_region P), a ↦ₐ w)
        (* Adv program and table *)
        ∗ (prog_lower_bound Adv_tbl) ↦ₐ (WCap RO (tbl_start Adv_tbl) (tbl_end Adv_tbl) (tbl_start Adv_tbl))
        ∗ ([∗ map] a↦w ∈ (tbl_region Adv_tbl), a ↦ₐ w)
        ∗ ([∗ map] a↦w ∈ (prog_region Adv), a ↦ₐ w)

        -∗ WP Seq (Instr Executable) {{ λ _, True }}) →

  rtc erased_step ([Seq (Instr Executable)], (reg, m)) (es, (reg', m')) →
  minv (flag_inv layout) m'.
Proof.
  intros ? ? ? ? Hspec.
  eapply (template_adequacy_no_seals Σ);[eauto..|]; (* rewrite /invGpreS. solve_inG. *)
    try typeclasses eauto.
  eapply flag_inv_is_initial_memory;eauto.
  eapply flag_inv_sub;eauto.
  intros. cbn.
  rewrite !map_union_empty.
  iIntros "(#Hflag & Hown & HPC & Hr_adv & Hrmap & Htbl & Htbl_r
           & Hprog & Htbl_adv & Htbl_adv_r & Hprog_adv & Hmalloc & Hassert)".

  (* allocate malloc invariant *)
  iMod (na_inv_alloc logrel_nais ⊤ mallocN (mallocInv layout)
          with "[Hmalloc]") as "#Hinv_malloc".
  { iNext. rewrite /mallocInv /malloc_inv. iExists (malloc_memptr layout), (malloc_mem_start layout).
    rewrite /malloc_library_content.
    iDestruct (big_sepM_union with "Hmalloc") as "[Hpubs Hinit]".
    { pose proof (libs_disjoint layout) as Hdisjoint.
      rewrite !disjoint_list_cons in Hdisjoint |- *.
      disjoint_map_to_list. set_solver + Hdisjoint. }
    iDestruct (big_sepM_union with "Hpubs") as "[Hpubs Hmid]".
    { pose proof (libs_disjoint layout) as Hdisjoint.
      rewrite !disjoint_list_cons in Hdisjoint |- *.
      disjoint_map_to_list. set_solver + Hdisjoint. }
    pose proof (malloc_code_size layout) as Hmalloc_size.
    pose proof (malloc_memptr_size layout) as Hmalloc_memptr_size.
    pose proof (malloc_mem_size layout) as Hmalloc_mem_size.
    iSplitL "Hpubs".
    iApply big_sepM_to_big_sepL2. apply finz_seq_between_NoDup.
    rewrite finz_seq_between_length /finz.dist.
    solve_addr +Hmalloc_size.
    assert (((malloc_start layout) ^+ length malloc_subroutine_instrs)%a = (malloc_memptr layout)) as ->
    ;[solve_addr+Hmalloc_size|iFrame].
    iSplit;[auto|]. iDestruct (big_sepM_insert with "Hmid") as "[$ _]";auto.
    iSplit;[|iPureIntro;solve_addr+Hmalloc_size Hmalloc_memptr_size Hmalloc_mem_size].
    iApply big_sepM_to_big_sepL2. apply finz_seq_between_NoDup.
    rewrite finz_seq_between_length replicate_length /finz.dist. solve_addr +Hmalloc_mem_size. iFrame. }

  (* allocate the flag invariant *)
  iMod (na_inv_alloc logrel_nais ⊤ assertN (assertInv layout)
          with "[Hassert]") as "#Hinv_assert".
  { iNext. rewrite /assertInv /assert_inv /assert_library_content.
    iExists (assert_cap layout).
    pose proof (assert_code_size layout). pose proof (assert_cap_size layout).
    pose proof (assert_flag_size layout).
    rewrite map_filter_union.
    2: { disjoint_map_to_list. apply elem_of_disjoint. intro.
         rewrite elem_of_app elem_of_finz_seq_between !elem_of_list_singleton.
         intros [ [? ?]|?]; solve_addr. }
    iDestruct (big_sepM_union with "Hassert") as "[Hassert _]".
    { eapply map_disjoint_filter. disjoint_map_to_list.
      apply elem_of_disjoint. intro.
      rewrite elem_of_app elem_of_finz_seq_between !elem_of_list_singleton.
      intros [ [? ?]|?]; solve_addr. }
    rewrite map_filter_id.
    2: { intros ? ? HH%elem_of_dom_2. rewrite !dom_union_L dom_mkregion_eq in HH.
         2: solve_addr. apply elem_of_union in HH.
         rewrite elem_of_singleton. destruct HH as [HH|HH].
         rewrite -> elem_of_list_to_set, elem_of_finz_seq_between in HH; solve_addr.
         rewrite -> dom_list_to_map_singleton, elem_of_list_to_set, elem_of_list_singleton in HH; solve_addr. }
    iDestruct (big_sepM_union with "Hassert") as "[Hassert Hcap]".
    { disjoint_map_to_list. apply elem_of_disjoint. intro.
      rewrite elem_of_finz_seq_between !elem_of_list_singleton. solve_addr. }
    iDestruct (mkregion_sepM_to_sepL2 with "Hassert") as "Hassert". solve_addr.
    rewrite (_: assert_cap layout = assert_start layout ^+ length assert_subroutine_instrs)%a. 2: solve_addr.
    iFrame "Hassert". iDestruct (big_sepM_insert with "Hcap") as "[Hcap _]". done.
    iFrame "Hcap". iPureIntro. repeat split; solve_addr. }

  iApply Hspec; [exact|..|iFrame "∗ #"];auto.
Qed.

End ocpl.


Require Import Benchmarks.ProcessSchedulerSetup.

(** This file demonstrates the extraction from a Fiat ADT to a Facade
    “CompileUnit”. For convenience, here is a copy of the Process Scheduler
    specs:

        Definition SchedulerSchema          Def ADT Schema  rep := QueryStructure Structure,

                  relation "Processes" has schema
                  <"pid" :: W, "state" :: State, "cpu" :: W>
                  where (UniqueAttribute ``"pid")
          ] enforcing [].

         Definition SchedulerSpec : ADT _ :=
            Def ADT
             {
             rep := QueryStructure SchedulerSchema,

             Def Constructor0 "Init" : rep := empty,

             Def Method3 "Spawn" (r : rep) (new_pid cpu state : W) : rep * bool :=
               Insert (<"pid" :: new_pid, "state" :: state, "cpu" :: cpu> : RawTuple) into r!"Processes",

             Def Method1 "Enumerate" (r : rep) (state : State) : rep * list W :=
               procs <- For (p in r!"Processes")
                        Where (p!"state" = state)
                        Return (p!"pid");
               ret (r, procs),

             Def Method1 "GetCPUTime" (r : rep) (id : W) : rep * list W :=
                 proc <- For (p in r!"Processes")
                         Where (p!"pid" = id)
                         Return (p!"cpu");
               ret (r, proc)
         }%methDefParsing.

     We have added the output of each of the three “Compute” calls below;
     running the example up to that point takes about 6 minutes on a modern machine. *)

Definition CUnit
  : { env : _ &
    BuildCompileUnit2TSpec
      env
      AbsR'
      (fun r => BagSanityConditions (prim_fst r))
      (DecomposeIndexedQueryStructure' QsADTs.ADTValue _ _)
      (DecomposeIndexedQueryStructurePre' QsADTs.ADTValue _ _ _)
      (DecomposeIndexedQueryStructurePost' QsADTs.ADTValue _ _ (Scheduler_RepWrapperT _))
      (QueryStructureSchema.numQSschemaSchemas SchedulerSchema)
      "ProcessSchedulerAX"
      "ProcessSchedulerOP"
      Scheduler_coDomainWrappers
      Scheduler_DomainWrappers
      (Scheduler_RepWrapperT _)
      (Scheduler_DecomposeRep_well_behaved QsADTs.ADTValue _ _ (Scheduler_RepWrapperT _))
      SharpenedRepImpl} .
Proof.
  Time _compile QSEnv_Ax.          (* 228s *)
Time Defined.                            (* 185s *)

Eval lazy in (methodBody "Spawn" CUnit).

(*
     = Some
         ("snd" <- "ADT"."Tuples2_findSecond"("rep", "arg");
          "test" <- "ADT"."TupleList_empty"("snd");
          If Const (Word.natToWord 32 1) = Var "test" Then
            "v1" <- Var "arg";
            "v2" <- Var "arg1";
            "v3" <- Var "arg0";
            "o1" <- Const (Word.natToWord 32 0);
            "o2" <- Const (Word.natToWord 32 1);
            "o3" <- Const (Word.natToWord 32 2);
            "vlen" <- Const (Word.natToWord 32 3);
            "tup" <- "ADT"."Tuple_new"("vlen");
            "vtmp" <- "ADT"."Tuple_set"("tup", "o1", "v1");
            "vtmp" <- "ADT"."Tuple_set"("tup", "o2", "v2");
            "vtmp" <- "ADT"."Tuple_set"("tup", "o3", "v3");
            "vtmp" <- "ADT"."Tuples2_insert"("rep", "tup");
            "tmp" <- Const (Word.natToWord 32 0);
            "test0" <- "ADT"."TupleList_empty"("snd");
            While (Var "test0" = Const (Word.natToWord 32 0))
                "head" <- "ADT"."TupleList_pop"("snd");
                "size" <- Const (Word.natToWord 32 3);
                "tmp'" <- "ADT"."Tuple_delete"("head", "size");
                "test0" <- "ADT"."TupleList_empty"("snd");
            "test0" <- "ADT"."TupleList_delete"("snd");
            __;
            "ret" <- Const (Word.natToWord 32 1)
          Else
            "tmp" <- Const (Word.natToWord 32 0);
            "test0" <- "ADT"."TupleList_empty"("snd");
            While (Var "test0" = Const (Word.natToWord 32 0))
                "head" <- "ADT"."TupleList_pop"("snd");
                "size" <- Const (Word.natToWord 32 3);
                "tmp'" <- "ADT"."Tuple_delete"("head", "size");
                "test0" <- "ADT"."TupleList_empty"("snd");
            "test0" <- "ADT"."TupleList_delete"("snd");
            __;
            "ret" <- Const (Word.natToWord 32 0)
          EndIf)%facade
     : option Stmt *)

Eval lazy in (methodBody "Enumerate" CUnit).

(*
   = Some
         ("snd" <- "ADT"."Tuples2_findFirst"("rep", "arg");
          "ret" <- "ADT"."WordList_new"();
          "test" <- "ADT"."TupleList_empty"("snd");
          While (Var "test" = Const (Word.natToWord 32 0))
              "head" <- "ADT"."TupleList_pop"("snd");
              "pos" <- Const (Word.natToWord 32 0);
              "head'" <- "ADT"."Tuple_get"("head", "pos");
              "size" <- Const (Word.natToWord 32 3);
              "tmp" <- "ADT"."Tuple_delete"("head", "size");
              "tmp" <- "ADT"."WordList_push"("ret", "head'");
              "test" <- "ADT"."TupleList_empty"("snd");
          "test" <- "ADT"."TupleList_delete"("snd");
          __)%facade
     : option Stmt *)

Eval lazy in (methodBody "GetCPUTime" CUnit).

(*
     = Some
         ("snd" <- "ADT"."Tuples2_findSecond"("rep", "arg");
          "ret" <- "ADT"."WordList_new"();
          "test" <- "ADT"."TupleList_empty"("snd");
          While (Var "test" = Const (Word.natToWord 32 0))
              "head" <- "ADT"."TupleList_pop"("snd");
              "pos" <- Const (Word.natToWord 32 2);
              "head'" <- "ADT"."Tuple_get"("head", "pos");
              "size" <- Const (Word.natToWord 32 3);
              "tmp" <- "ADT"."Tuple_delete"("head", "size");
              "tmp" <- "ADT"."WordList_push"("ret", "head'");
              "test" <- "ADT"."TupleList_empty"("snd");
          "test" <- "ADT"."TupleList_delete"("snd");
          __)%facade
     : option Stmt *)


Require Import Bool.
Require Import List.

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

From PromisingLib Require Import Basic.
Require Import Event.
From PromisingLib Require Import Language.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Progress.

Require Import FulfillStep.
Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import Compatibility.
Require Import SimThread.

Require Import ReorderStep.
Require Import ReorderLoad.
Require Import ReorderStore.
Require Import ReorderUpdate.
Require Import ReorderFence.
Require Import ReorderAbort.

Require Import Syntax.
Require Import Semantics.

Set Implicit Arguments.

Inductive reorder: forall (i1 i2:Instr.t), Prop :=
| reorder_intro_load
    r1 l1 o1 i2
    (REORDER: reorder_load r1 l1 o1 i2):
    reorder (Instr.load r1 l1 o1) i2
| reorder_intro_store
    l1 v1 o1 i2
    (REORDER: reorder_store l1 v1 o1 i2):
    reorder (Instr.store l1 v1 o1) i2
| reorder_intro_update
    l1 v1 rmw1 or1 ow1 i2
    (REORDER: reorder_update l1 v1 rmw1 or1 ow1 i2):
    reorder (Instr.update l1 v1 rmw1 or1 ow1) i2
| reorder_intro_fence
    or1 ow1 i2
    (REORDER: reorder_fence or1 ow1 i2):
    reorder (Instr.fence or1 ow1) i2
| reorder_intro_abort
    i2
    (REORDER: reorder_abort i2):
    reorder Instr.abort i2
.

Lemma reorder_sim_stmts
      i1 i2 (REORDER: reorder i1 i2):
  sim_stmts eq
            [Stmt.instr i2; Stmt.instr i1]
            [Stmt.instr i1; Stmt.instr i2]
            eq.
Proof.
  pcofix CIH. ii. subst. pfold. ii. splits; ii.
  { inv TERMINAL_TGT. }
  { exploit SimPromises.cap; try eapply LOCAL; eauto. }
  { right. esplits; eauto.
    inv LOCAL. apply SimPromises.sem_bot_inv in PROMISES; auto. rewrite PROMISES. auto.
  }
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
    try (inv STATE; inv INSTR; inv REORDER); ss.
  - (* promise *)
    right.
    exploit sim_local_promise; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    econs 2. econs 1; eauto. econs; eauto. eauto.
  - (* load *)
    right.
    exploit sim_local_read; eauto; try refl. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 1.
    + auto.
    + left. eapply paco9_mon; [apply sim_load_sim_thread|]; ss.
      econs; eauto.
      eapply Local.read_step_future; eauto.
  - (* update-load *)
    right.
    exploit sim_local_read; eauto; try refl. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 1.
    + auto.
    + left. eapply paco9_mon; [apply sim_update_sim_thread|]; ss.
      econs; [eauto|..]; s; eauto.
      eapply Local.read_step_future; eauto.
  - (* store *)
    right.
    exploit Local.write_step_future; eauto; try by viewtac. i. des.
    hexploit sim_local_write_bot; try exact LOCAL1; try exact SC;
      try exact WF_SRC; try refl; viewtac. i. des.
    exploit write_promise_fulfill; eauto; try by viewtac. i. des.
    exploit Local.promise_step_future; eauto. i. des.
    esplits.
    + ss.
    + eauto.
    + econs 2. econs 1. econs; eauto.
    + auto.
    + etrans; eauto.
    + auto.
    + left. eapply paco9_mon; [apply sim_store_sim_thread|done].
      econs; eauto.
  - (* update *)
    right.
    exploit Local.read_step_future; eauto. i. des.
    exploit Local.write_step_future; eauto. i. des.
    exploit sim_local_read; eauto; try refl. i. des.
    exploit Local.read_step_future; eauto. i. des.
    hexploit sim_local_write_bot; try apply LOCAL2; try apply LOCAL0; try apply SC; eauto; try refl; try by viewtac. i. des.
    exploit write_promise_fulfill; eauto; try by viewtac. i. des.
    exploit Local.promise_step_future; eauto. i. des.
    exploit reorder_read_promise; try exact STEP_SRC; try exact STEP1; eauto. i. des.
    exploit Local.promise_step_future; eauto. i. des.
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_fulfill_bot; try exact STEP2; try exact LOCAL4; try exact REL1;
      try exact WF3; try refl; eauto; try by viewtac. i. des.
    esplits.
    + ss.
    + eauto.
    + econs 2. econs 1. econs; eauto.
    + auto.
    + etrans; eauto.
    + auto.
    + left. eapply paco9_mon; [apply sim_update_sim_thread|done].
      econs; [eauto|..]; s; eauto.
      etrans; eauto.
  - (* fence *)
    right.
    exploit sim_local_fence; try apply SC; eauto; try refl. i. des.
    esplits.
    + ss.
    + eauto.
    + econs 1.
    + auto.
    + etrans; [|eauto]. inv STEP_SRC. apply TViewFacts.write_fence_sc_incr.
    + auto.
    + left. eapply paco9_mon; [apply sim_fence_sim_thread|]; ss.
      econs; eauto.
  - (* abort *)
    left.
    eapply sim_abort_steps_failure. econs; eauto.
    eapply sim_local_failure; eauto.
Unshelve.
  { econs. econs 3. }
  { econs 2. }
Qed.