Require Import Relations.
Require Import Permutation.
Require Import NArith.
Require Import PArith.
Require Import ZArith.
Require Import Lia.
Require Import FMapPositive.
Require Import FSetPositive.
Require Import EquivDec.
From sflib Require Import sflib.
Require Import PacoNotation.
Require Import HahnRelationsBasic.

Require Import PromisingArch.lib.Basic.
Require Import PromisingArch.lib.HahnRelationsMore.
Require Import PromisingArch.lib.Order.
Require Import PromisingArch.lib.Time.
Require Import PromisingArch.lib.Lang.
Require Import PromisingArch.promising.Promising.
Require Import PromisingArch.promising.StateExecFacts.
Require Import PromisingArch.axiomatic.Axiomatic.
Require Import PromisingArch.axiomatic.CommonAxiomatic.

Set Implicit Arguments.

Inductive sim_trace (p: program) (mem: Memory.t) (tid: Id.t):
  forall (tr: list (ExecUnit.t (A:=unit))) (atr: list AExecUnit.t)
     (wl: list (nat -> option (Loc.t * Time.t))) (rl: list (nat -> option (Loc.t * Time.t)))
     (cov: list (nat -> Time.t)) (vext: list (nat -> Time.t)), Prop :=
| sim_trace_init
    st lc stmts
    (FIND: IdMap.find tid (Machine.init_with_promises p mem).(Machine.tpool) = Some (st, lc))
    (STMT: IdMap.find tid p = Some stmts):
    sim_trace p mem tid [ExecUnit.mk st lc mem] [AExecUnit.mk (State.init stmts) ALocal.init]
              [fun _ => None] [fun _ => None] [fun _ => Time.bot] [fun _ => Time.bot]
| sim_trace_step
    e ae tr eu1 eu2 atr aeu1 aeu2 rl r1 r2 wl w1 w2 covl cov1 cov2 vextl vext1 vext2
    (STEP: ExecUnit.state_step0 tid e e eu1 eu2)
    (ASTATE_STEP: State.step ae aeu1.(AExecUnit.state) aeu2.(AExecUnit.state))
    (ALOCAL_STEP: ALocal.step ae aeu1.(AExecUnit.local) aeu2.(AExecUnit.local))
    (EVENT: sim_event e ae)
    (STATE: sim_state_weak eu2.(ExecUnit.state) aeu2.(AExecUnit.state))
    (LOCAL: sim_local_weak eu2.(ExecUnit.local) aeu2.(AExecUnit.local))
    (W: w2 = match e with
             | Event.write _ _ vloc _ (ValA.mk _ 0 _) =>
               (fun eid => if Nat.eqb eid (ALocal.next_eid aeu1.(AExecUnit.local))
                          then Some (vloc.(ValA.val),
                                     Memory.latest_ts
                                       vloc.(ValA.val)
                                       (eu2.(ExecUnit.local).(Local.coh) vloc.(ValA.val)).(View.ts)
                                       mem)
                         else w1 eid)
             | _ => w1
             end)
    (R: r2 = match e with
               | Event.read _ _ vloc _ =>
                 (fun eid => if Nat.eqb eid (ALocal.next_eid aeu1.(AExecUnit.local))
                            then Some (vloc.(ValA.val),
                                       Memory.latest_ts
                                         vloc.(ValA.val)
                                         (eu2.(ExecUnit.local).(Local.coh) vloc.(ValA.val)).(View.ts)
                                         mem)
                            else r1 eid)
               | _ => r1
               end)
    (COV: cov2 = match e with
                 | Event.read _ _ vloc _
                 | Event.write _ _ vloc _ (ValA.mk _ 0 _) =>
                   (fun eid => if Nat.eqb eid (ALocal.next_eid aeu1.(AExecUnit.local))
                              then Memory.latest_ts
                                     vloc.(ValA.val)
                                     (eu2.(ExecUnit.local).(Local.coh) vloc.(ValA.val)).(View.ts)
                                     mem
                              else cov1 eid)
                 | _ => cov1
                 end)
    (VEXT: vext2 = match e with
                   | Event.read _ _ _ res =>
                     (fun eid => if Nat.eqb eid (ALocal.next_eid aeu1.(AExecUnit.local))
                                then res.(ValA.annot).(View.ts)
                                else vext1 eid)
                   | Event.write _ _ vloc _ (ValA.mk _ 0 _) =>
                     (fun eid => if Nat.eqb eid (ALocal.next_eid aeu1.(AExecUnit.local))
                                then (eu2.(ExecUnit.local).(Local.coh) vloc.(ValA.val)).(View.ts)
                                else vext1 eid)
                   | _ => vext1
                   end)
    (TRACE: sim_trace p mem tid (eu1::tr) (aeu1::atr) (w1::wl) (r1::rl) (cov1::covl) (vext1::vextl)):
    sim_trace p mem tid (eu2::eu1::tr) (aeu2::aeu1::atr) (w2::w1::wl) (r2::r1::rl) (cov2::cov1::covl) (vext2::vext1::vextl)
.

Definition sim_traces
           (p: program) (mem: Memory.t)
           (trs: IdMap.t (list (ExecUnit.t (A:=unit))))
           (atrs: IdMap.t (list AExecUnit.t))
           (ws: IdMap.t (list (nat -> option (Loc.t * Time.t))))
           (rs: IdMap.t (list (nat -> option (Loc.t * Time.t))))
           (covs: IdMap.t (list (nat -> Time.t)))
           (vexts: IdMap.t (list (nat -> Time.t)))
  : Prop :=
  IdMap.Forall6 (sim_trace p mem) trs atrs ws rs covs vexts.

Lemma sim_trace_last
      p mem tid tr atr wl rl covl vextl
      (SIM: sim_trace p mem tid tr atr wl rl covl vextl):
  exists eu tr' aeu atr' w wl' r rl' cov covl' vext vextl',
    <<HDTR: tr = eu :: tr'>> /\
    <<HDATR: atr = aeu :: atr'>> /\
    <<HDWL: wl = w :: wl'>> /\
    <<HDRL: rl = r :: rl'>> /\
    <<HDCOVL: covl = cov :: covl'>> /\
    <<HDVEXTL: vextl = vext :: vextl'>>.
Proof.
  inv SIM; esplits; eauto.
Qed.

Lemma sim_trace_length
      p mem tid tr atr wl rl covl vextl
      (SIM: sim_trace p mem tid tr atr wl rl covl vextl):
  <<LENGTH_ATR: List.length atr = List.length tr>> /\
  <<LENGTH_WL: List.length wl = List.length tr>> /\
  <<LENGTH_RL: List.length rl = List.length tr>> /\
  <<LENGTH_COVL: List.length covl = List.length tr>> /\
  <<LENGTH_VEXTL: List.length vextl = List.length tr>>.
Proof.
  induction SIM; ss. des. splits; congr.
Qed.

Lemma sim_trace_memory
      p mem tid tr atr rl wl covl vextl
      eu tr'
      (SIM: sim_trace p mem tid tr atr rl wl covl vextl)
      (EU: tr = eu :: tr'):
  mem = eu.(ExecUnit.mem).
Proof.
  revert eu tr' EU.
  induction SIM.
  - ii. inv EU. ss.
  - ii. inv EU. exploit IHSIM; try refl. i.
    inv STEP. ss.
Qed.

Lemma sim_traces_memory
      p trs atrs rs ws covs vexts
      m
      ts loc val tid
      (STEP: Machine.pf_exec p m)
      (SIM: sim_traces p m.(Machine.mem) trs atrs ws rs covs vexts)
      (TR: IdMap.Forall2
             (fun tid tr sl => exists l, tr = (ExecUnit.mk (fst sl) (snd sl) m.(Machine.mem)) :: l)
             trs m.(Machine.tpool))
      (GET: Memory.get_msg ts m.(Machine.mem) = Some (Msg.mk loc val tid)):
  exists eu, IdMap.find tid trs = Some eu.
Proof.
  generalize (SIM tid). intro X. inv X; eauto.
  generalize (TR tid). rewrite <- H0. intro X. inv X.
  inv STEP. hexploit state_exec_rtc_state_step; [by eauto|]. i. des.
  exploit Machine.step_get_msg_tpool.
  - etrans.
    + eapply Machine.rtc_step_mon; [|by eauto]. right. ss.
    + eapply Machine.rtc_step_mon; [|by eauto]. left. ss.
  - inv EQUIV. rewrite <- MEM. eauto.
  - s. i. des. inv EQUIV. generalize (TPOOL tid). congr.
Qed.

Ltac simplify :=
  repeat
    (try match goal with
         | [H1: _ = IdMap.find ?id ?m, H2: _ = IdMap.find ?id ?m |- _] =>
           rewrite <- H1 in H2; inv H2
         | [H1: IdMap.find ?id ?m = _, H2: IdMap.find ?id ?m = _ |- _] =>
           rewrite H1 in H2; inv H2
         | [H1: IdMap.find ?id ?m = _, H2: _ = IdMap.find ?id ?m |- _] =>
           rewrite H1 in H2; inv H2
         | [H: Some _ = Some _ |- _] => inv H
         | [H: _::_ = _::_ |- _] => inv H
         end).

Lemma promising_pf_sim_step
      tid e (eu1 eu2:ExecUnit.t (A:=unit)) aeu1
      (STATE1: sim_state_weak eu1.(ExecUnit.state) aeu1.(AExecUnit.state))
      (LOCAL1: sim_local_weak eu1.(ExecUnit.local) aeu1.(AExecUnit.local))
      (STEP: ExecUnit.state_step0 tid e e eu1 eu2):
  exists ae aeu2,
    <<ASTATE_STEP: State.step ae aeu1.(AExecUnit.state) aeu2.(AExecUnit.state)>> /\
    <<ALOCAL_STEP: ALocal.step ae aeu1.(AExecUnit.local) aeu2.(AExecUnit.local)>> /\
    <<EVENT: sim_event e ae>> /\
    <<STATE2: sim_state_weak eu2.(ExecUnit.state) aeu2.(AExecUnit.state)>> /\
    <<LOCAL2: sim_local_weak eu2.(ExecUnit.local) aeu2.(AExecUnit.local)>>.
Proof.
  destruct eu1 as [st1 lc1 mem1].
  destruct eu2 as [st2 lc2 mem2].
  destruct aeu1 as [[astmt1 armap1] alc1].
  inv STATE1. inv STEP. ss. subst. inv STATE; inv LOCAL; inv EVENT; ss.
  - eexists _, (AExecUnit.mk (State.mk _ _) _). splits; ss.
    + econs 1.
    + econs; ss.
    + ss.
    + ss.
    + inv LOCAL1; [econs 1|econs 2]; eauto.
  - eexists _, (AExecUnit.mk (State.mk _ _) _). splits; ss.
    + econs 2. ss.
    + econs; ss.
    + econs; ss.
    + econs; ss. eauto using sim_rmap_weak_add, sim_rmap_weak_expr.
    + inv LOCAL1; [econs 1|econs 2]; eauto.
  - inv STEP. ss.
    eexists _, (AExecUnit.mk (State.mk _ _) _). splits; ss.
    + econs 3; ss.
    + econs 2; ss.
    + econs; ss. eauto using sim_rmap_weak_add, sim_rmap_weak_expr.
    + econs; ss. eauto using sim_rmap_weak_add, sim_rmap_weak_expr.
    + destruct ex0.
      * econs 2; ss.
        rewrite List.nth_error_app2, minus_diag; ss.
        specialize (@sim_rmap_weak_expr rmap armap1 eloc RMAP). i.
        inv H. rewrite VAL. refl.
      * inv LOCAL1; [econs 1|econs 2]; eauto; ss.
        rewrite List.nth_error_app1; eauto.
        eapply List.nth_error_Some. ii. congr.
  - inv STEP. ss.
    eexists _, (AExecUnit.mk (State.mk _ _) _). splits; ss.
    + econs 4; ss.
    + econs 3; ss. inv WRITABLE. i. specialize (EX H). des.
      inv LOCAL1; try congr.
      rewrite TSX in LOCAL_EX. inv LOCAL_EX.
      esplits; eauto. rewrite LABEL_EX; eauto.
    + econs; ss.
      * eauto using sim_rmap_weak_add, sim_rmap_weak_expr.
      * eauto using sim_rmap_weak_add, sim_rmap_weak_expr.
    + econs; ss. eauto using sim_rmap_weak_add, sim_rmap_weak_expr.
    + destruct ex0; eauto.
      inv LOCAL1; [econs 1|econs 2]; ss.
      { eauto. }
      { eauto. }
      rewrite List.nth_error_app1; eauto.
      eapply List.nth_error_Some. ii. congr.
  - inv STEP. destruct ex0; ss.
    eexists _, (AExecUnit.mk (State.mk _ _) _). splits; ss.
    + econs 4; ss.
    + econs 4; ss.
    + econs; ss.
      * eauto using sim_rmap_weak_add, sim_rmap_weak_expr.
      * eauto using sim_rmap_weak_add, sim_rmap_weak_expr.
    + econs; ss. eauto using sim_rmap_weak_add, sim_rmap_weak_expr.
    + eauto.
  - inv STEP.
    eexists _, (AExecUnit.mk (State.mk _ _) _). splits; ss.
    + econs 5; ss.
    + econs 5; ss.
    + econs; ss.
    + econs; ss.
    + inv LOCAL1; [econs 1|econs 2]; eauto; ss.
      rewrite List.nth_error_app1; eauto.
      eapply List.nth_error_Some. ii. congr.
  - inv STEP.
    eexists _, (AExecUnit.mk (State.mk _ _) _). splits; ss.
    + econs 5; ss.
    + econs 5; ss.
    + econs; ss.
    + econs; ss.
    + inv LOCAL1; [econs 1|econs 2]; eauto; ss.
      rewrite List.nth_error_app1; eauto.
      eapply List.nth_error_Some. ii. congr.
  - inv LC.
    eexists _, (AExecUnit.mk (State.mk _ _) _). splits; ss.
    + econs 6; ss.
    + econs 6; ss.
    + econs; ss.
      exploit sim_rmap_weak_expr; eauto. intro X. inv X.
      inv VAL. rewrite <- H0. ss.
    + inv LOCAL1; [econs 1|econs 2]; eauto; ss.
      rewrite List.nth_error_app1; eauto.
      eapply List.nth_error_Some. ii. congr.
  - eexists _, (AExecUnit.mk (State.mk _ _) _). splits; ss.
    + econs 7. ss.
    + econs; ss.
    + ss.
    + ss.
    + inv LOCAL1; [econs 1|econs 2]; eauto.
Qed.

Lemma promising_pf_sim_traces
      p m
      (STEP: Machine.pf_exec p m):
  exists trs atrs ws rs covs vexts ex (PRE: Valid.pre_ex p ex),
    <<SIM: sim_traces p m.(Machine.mem) trs atrs ws rs covs vexts>> /\
    <<TR: IdMap.Forall2
            (fun tid tr sl => exists l, tr = (ExecUnit.mk (fst sl) (snd sl) m.(Machine.mem)) :: l)
            trs m.(Machine.tpool)>> /\
    <<ATR: IdMap.Forall2
             (fun tid atr aeu => exists l, atr = aeu :: l)
             atrs PRE.(Valid.aeus)>>.
Proof.
  inv STEP. exploit state_exec_rtc_state_step; eauto. i. des.
  eapply Machine.equiv_no_promise in NOPROMISE; eauto. revert NOPROMISE.
  cut (exists trs atrs ws rs covs vexts ex (PRE: Valid.pre_ex p ex),
    <<SIM: sim_traces p (Machine.mem m2') trs atrs ws rs covs vexts>> /\
    <<TR: forall tid, opt_rel
            (fun tr sl => exists l, tr = (ExecUnit.mk (fst sl) (snd sl) (Machine.mem m2')) :: l)
            (IdMap.find tid trs)
            (IdMap.find tid (Machine.tpool m2'))>> /\
    <<ATR: IdMap.Forall2
             (fun tid atr aeu => exists l, atr = aeu :: l)
             atrs PRE.(Valid.aeus)>>).
  { inv EQUIV. rewrite MEM. i. des. esplits; eauto. ii. rewrite TPOOL. ss. }
  clear m STEP2 EQUIV.
  apply clos_rt_rt1n_iff, clos_rt_rtn1_iff in EXEC. induction EXEC.
  { eexists (IdMap.map (fun x => [x]) (IdMap.mapi (fun _ _ => _) p)).
    eexists (IdMap.map (fun x => [x]) (IdMap.mapi (fun _ _ => _) p)).
    eexists (IdMap.mapi (fun _ _ => [fun _ => None]) p).
    eexists (IdMap.mapi (fun _ _ => [fun _ => None]) p).
    eexists (IdMap.mapi (fun _ _ => [bot]) p).
    eexists (IdMap.mapi (fun _ _ => [bot]) p).
    eexists (Execution.mk (IdMap.mapi (fun _ _ => _) p) bot bot bot bot bot bot).
    eexists (@Valid.mk_pre_ex _ _ (IdMap.mapi (fun tid stmts => AExecUnit.mk (State.init stmts) ALocal.init) p)  _ _ _ _ _ _).
    hexploit Machine.rtc_promise_step_spec; eauto. s. intro X.
    s. splits; cycle 1.
    - i. specialize (X tid). rewrite ? IdMap.map_spec, ? IdMap.mapi_spec in *.
      rewrite X. destruct (IdMap.find tid p); ss. econs. eauto.
    - ii. rewrite ? IdMap.map_spec, ? IdMap.mapi_spec. destruct (IdMap.find id p); ss. eauto.
    - ii. rewrite ? IdMap.map_spec, ? IdMap.mapi_spec. destruct (IdMap.find id p) eqn:STMTS; ss. econs.
      econs 1; ss. rewrite IdMap.mapi_spec, STMTS. s. ss.
  }
  des.
  destruct y as [tpool1 mem1].
  destruct z as [tpool2 mem2].
  ss. inv H. ss. subst. inv STEP. inv STEP0. ss. subst.
  generalize (TR tid). rewrite FIND. intro Y. inv Y. des. subst. rename H0 into TRS. symmetry in TRS.
  generalize (SIM tid). intro Y. inv Y; [congr|]. rewrite TRS in H0. inv H0.
  hexploit sim_trace_last; eauto. i. des. subst. simplify.
  exploit promising_pf_sim_step; eauto.
  { inv REL6; eauto. s.
    unfold Machine.init_with_promises in FIND0. ss.
    rewrite IdMap.mapi_spec, STMT in *. inv FIND0.
    apply sim_state_weak_init.
  }
  { inv REL6; eauto. s.
    unfold Machine.init_with_promises in FIND0. ss.
    rewrite IdMap.mapi_spec, STMT in *. inv FIND0.
    auto.
  }
  { instantiate (1 := ExecUnit.mk _ _ _). econs; ss; eauto. }
  i. des.

  eexists (IdMap.add tid _ trs).
  eexists (IdMap.add tid _ atrs).
  eexists (IdMap.add tid _ ws).
  eexists (IdMap.add tid _ rs).
  eexists (IdMap.add tid _ covs).
  eexists (IdMap.add tid _ vexts).
  eexists (Execution.mk _ _ _ _ _ _ _).
  eexists (@Valid.mk_pre_ex _ _ (IdMap.add tid _ PRE.(Valid.aeus))  _ _ _ _ _ _).
  s. splits; cycle 1.
  - i. rewrite ? IdMap.add_spec. condtac; eauto.
  - ii. rewrite ? IdMap.add_spec. condtac; eauto.
  - s. ii. rewrite ? IdMap.add_spec. condtac; eauto. inversion e0. subst. clear e0 X. econs.
    econs 2; eauto. econs; eauto.
Unshelve.
all: ss.
all: try apply bot.
1: { econs. }
3: { funext. i. funext. i. propext. econs; ss. i. inv H.
     rewrite IdMap.map_spec, IdMap.mapi_spec in RELS. destruct (IdMap.find tid p); ss.
     inv RELS. inv REL. ss.
}
3: { funext. i. funext. i. propext. econs; ss. i. inv H.
     rewrite IdMap.map_spec, IdMap.mapi_spec in RELS. destruct (IdMap.find tid p); ss.
     inv RELS. inv REL. ss.
}
3: { funext. i. funext. i. propext. econs; ss. i. inv H.
     rewrite IdMap.map_spec, IdMap.mapi_spec in RELS. destruct (IdMap.find tid p); ss.
     inv RELS. inv REL. ss.
}
3: { funext. i. funext. i. propext. econs; ss. i. inv H.
     rewrite IdMap.map_spec, IdMap.mapi_spec in RELS. destruct (IdMap.find tid p); ss.
     inv RELS. inv REL. ss.
}
1: { ii. rewrite IdMap.mapi_spec. destruct (IdMap.find id p); ss. econs. refl. }
1: { unfold IdMap.map. rewrite IdMap.mapi_mapi. f_equal. }
1: { ii. generalize (PRE.(Valid.AEUS) id). intro X.
     rewrite IdMap.add_spec. condtac; ss. inversion e0. subst. clear e0 X0.
     generalize (ATR tid). rewrite <- H. intro Y. inv Y. des. inv REL.
     rewrite <- H6 in X. inv X. econs. etrans; eauto.
}
Qed.

Inductive sim_th
          (p:program) (mem:Memory.t) (tid:Id.t)
          (eu:ExecUnit.t (A:=unit))
          (aeu:AExecUnit.t)
          (w: nat -> option (Loc.t * Time.t))
          (r: nat -> option (Loc.t * Time.t))
          (cov: nat -> Time.t)
          (vext: nat -> Time.t): Prop := mk {
  WPROP1:
    forall ts loc val
      (GET: Memory.get_msg ts mem = Some (Msg.mk loc val tid)),
      ((Promises.lookup ts eu.(ExecUnit.local).(Local.promises) = true /\
        forall eid, w eid <> Some (loc, ts)) \/
       (Promises.lookup ts eu.(ExecUnit.local).(Local.promises) = false /\
        exists eid ex ord,
          w eid = Some (loc, ts) /\
          List.nth_error aeu.(AExecUnit.local).(ALocal.labels) eid = Some (Label.write ex ord loc val)));
  WPROP2:
    forall eid ex ord loc val
      (GET: List.nth_error aeu.(AExecUnit.local).(ALocal.labels) eid = Some (Label.write ex ord loc val)),
    exists ts,
      w eid = Some (loc, ts) /\
      Memory.get_msg ts mem = Some (Msg.mk loc val tid);
  WPROP3:
    forall eid loc ts (GET: w eid = Some (loc, ts)),
      Time.lt Time.bot ts /\
      cov eid = ts /\
      vext eid = ts /\
      le ts (eu.(ExecUnit.local).(Local.coh) loc).(View.ts) /\
      exists ex ord val,
        List.nth_error aeu.(AExecUnit.local).(ALocal.labels) eid = Some (Label.write ex ord loc val) /\
        Memory.get_msg ts mem = Some (Msg.mk loc val tid);
  WPROP4:
    forall eid1 loc1 eid2 loc2 ts (W1: w eid1 = Some (loc1, ts)) (W2: w eid2 = Some (loc2, ts)),
      eid1 = eid2;
  RPROP1:
    forall eid ex ord loc val
      (GET: List.nth_error aeu.(AExecUnit.local).(ALocal.labels) eid = Some (Label.read ex ord loc val)),
    exists ts tid',
      r eid = Some (loc, ts) /\
      __guard__ ((ts = Time.bot /\ val = Val.default) \/
                 Memory.get_msg ts mem = Some (Msg.mk loc val tid'));
  RPROP2:
    forall eid loc ts (GET: r eid = Some (loc, ts)),
    cov eid = ts /\
    le ts (eu.(ExecUnit.local).(Local.coh) loc).(View.ts) /\
    exists ex ord val tid',
      List.nth_error aeu.(AExecUnit.local).(ALocal.labels) eid = Some (Label.read ex ord loc val) /\
      __guard__ ((ts = Time.bot /\ val = Val.default) \/
                 Memory.get_msg ts mem = Some (Msg.mk loc val tid'));
  COVPROP:
    forall eid (COV: cov eid > 0),
      AExecUnit.label_is aeu.(AExecUnit.local).(ALocal.labels) Label.is_access eid;
  VEXTPROP:
    forall eid (VEXT: vext eid > 0),
      AExecUnit.label_is aeu.(AExecUnit.local).(ALocal.labels) Label.is_access eid;

  PO: forall iid1 iid2 label1 label2
     (PO: iid1 < iid2)
     (LABEL1: List.nth_error aeu.(AExecUnit.local).(ALocal.labels) iid1 = Some label1)
     (LABEL2: List.nth_error aeu.(AExecUnit.local).(ALocal.labels) iid2 = Some label2)
     (REL: Execution.label_loc label1 label2),
      <<PO_LOC_WRITE:
        Label.is_write label2 ->
        Time.lt (cov iid1) (cov iid2)>> /\
      <<PO_LOC_READ:
        Label.is_read label2 ->
        Time.le (cov iid1) (cov iid2)>>;
  EU_WF: ExecUnit.wf tid eu;
  AEU_WF: AExecUnit.wf aeu;
  MEM: eu.(ExecUnit.mem) = mem;
}.

Lemma sim_trace_sim_state_weak
      p mem tid
      tr eu tr'
      atr aeu atr'
      wl w wl'
      rl r rl'
      covl cov covl'
      vextl vext vextl'
      (SIM: sim_trace p mem tid tr atr wl rl covl vextl)
      (EU: tr = eu :: tr')
      (AEU: atr = aeu :: atr')
      (RL: rl = r :: rl')
      (WL: wl = w :: wl')
      (COV: covl = cov :: covl')
      (VEXT: vextl = vext :: vextl'):
  sim_state_weak eu.(ExecUnit.state) aeu.(AExecUnit.state).
Proof.
  subst. inv SIM; ss.
  rewrite IdMap.mapi_spec, STMT in FIND. inv FIND.
  eapply sim_state_weak_init.
Qed.

Lemma sim_trace_sim_th
      p mem tid
      tr eu tr'
      atr aeu atr'
      wl w wl'
      rl r rl'
      covl cov covl'
      vextl vext vextl'
      (SIM: sim_trace p mem tid tr atr wl rl covl vextl)
      (EU: tr = eu :: tr')
      (AEU: atr = aeu :: atr')
      (RL: rl = r :: rl')
      (WL: wl = w :: wl')
      (COV: covl = cov :: covl')
      (VEXT: vextl = vext :: vextl'):
  sim_th p mem tid eu aeu w r cov vext.
Proof.
  revert r rl' w wl' eu tr' aeu atr' cov covl' vext vextl' RL WL EU AEU COV VEXT. induction SIM.
  { i. simplify. ss. econs; ss.
    - rewrite IdMap.mapi_spec, STMT in FIND. inv FIND. s. i.
      left. splits; ss. destruct ts; ss.
      eapply Machine.promises_from_mem_lookup. eauto.
    - rewrite IdMap.mapi_spec, STMT in FIND. inv FIND. s. i.
      destruct eid; ss.
    - rewrite IdMap.mapi_spec, STMT in FIND. inv FIND. s. i.
      destruct eid; ss.
    - unfold Time.bot. i. lia.
    - unfold Time.bot. i. lia.
    - i. destruct iid1; ss.
    - rewrite IdMap.mapi_spec, STMT in FIND. inv FIND.
      econs; ss.
      + econs. i. unfold RMap.find. rewrite IdMap.gempty. ss. apply bot_spec.
      + econs; ss; i; try by apply bot_spec.
        (* * unfold bot. unfold fun_bot. unfold bot. unfold Time.bot. lia. *)
        (* * eexists. unfold bot. unfold fun_bot. unfold Memory.read. ss. *)
        * econs; esplits; ss.
        * destruct ts; ss.
          rewrite Machine.promises_from_mem_spec in IN. des.
          apply lt_le_S. rewrite <- List.nth_error_Some. ii. congr.
        * destruct ts; ss.
          unfold Memory.get_msg in *. ss. destruct msg.
          exploit Machine.promises_from_mem_lookup; eauto. ss. subst. ss.
    - rewrite IdMap.mapi_spec, STMT in FIND. inv FIND.
      econs; ss.
      + ii. unfold RMap.init in N. unfold RMap.find in N.
        rewrite IdMap.gempty in N. ss.
      + ii. apply List.nth_error_In in LABEL. inv LABEL.
  }
  clear LOCAL.
  i. simplify.
  destruct eu1 as [st1 lc1 mem1].
  destruct eu as [st2 lc2 mem2].
  destruct aeu1 as [ast1 alc1].
  destruct aeu as [ast2 alc2].
  assert (mem1 = mem); subst.
  { exploit sim_trace_memory; eauto. }
  ss. exploit IHSIM; eauto. intro IH.
  assert (EU_WF2: ExecUnit.wf tid (ExecUnit.mk st2 lc2 mem2)).
  { destruct IH.
    eapply ExecUnit.state_step_wf; eauto. econs; eauto. }
  assert (AEU_WF2: AExecUnit.wf (AExecUnit.mk ast2 alc2)).
  { destruct IH.
    eapply AExecUnit.step_future; eauto. }
  inv STEP. inv ALOCAL_STEP; inv EVENT; ss; eauto.
  { (* internal *)
    inv LOCAL; ss. inv EVENT. econs; ss; try by apply IH.
  }
  { (* read *)
    inv LOCAL; ss. generalize IH.(EU_WF). i. inv H.
    specialize (Local.read_spec LOCAL STEP). intro READ_SPEC. guardH READ_SPEC.
    inv STEP. inv STATE0. inv ASTATE_STEP. ss. inv EVENT.
    exploit sim_trace_sim_state_weak; eauto. s. intro Y. inv Y. ss. inv STMTS.
    exploit sim_rmap_weak_expr; eauto. intro Y. inv Y.

    econs; ss; clear EU_WF2 AEU_WF2.
    - i. exploit IH.(WPROP1); eauto. s. i. des; [left|right]; esplits; eauto.
      eapply nth_error_app_mon. eauto.
    - i. exploit IH.(WPROP2); eauto.
      apply nth_error_snoc_inv in GET. des; eauto. congr.
    - i. exploit IH.(WPROP3); eauto. s. i. des. des_ifs.
      { exfalso. apply Nat.eqb_eq in Heq. subst.
        unfold ALocal.next_eid in *.
        assert (H: List.nth_error (ALocal.labels alc1) (length (ALocal.labels alc1)) <> None) by (ii; congr).
        apply List.nth_error_Some in H. lia.
      }
      esplits; eauto.
      + rewrite fun_add_spec. des_ifs; eauto. inv e.
        ss. etrans; eauto. apply join_l.
      + eapply nth_error_app_mon. eauto.
    - eapply IH.(WPROP4).
    - i. apply nth_error_snoc_inv in GET. des.
      + exploit IH.(RPROP1); eauto. i. des. esplits; eauto.
        des_ifs. apply Nat.eqb_eq in Heq. subst. unfold ALocal.next_eid in *. lia.
      + des_ifs; cycle 1.
        { apply Nat.eqb_neq in Heq. unfold ALocal.next_eid in *. congr. }
        rewrite fun_add_spec in *. condtac; [|congr].
        inv VLOC. inv VAL. ss. subst. rewrite VAL1 in *.
        move READ_SPEC at bottom. desH READ_SPEC. rewrite <- COH0.
        exploit Memory.read_get_msg; eauto. i. des; esplits; eauto.
    - i. des_ifs.
      + apply Nat.eqb_eq in Heq. subst.
        rewrite fun_add_spec in *. des_ifs; [|congr].
        inv VLOC. inv VAL. ss. subst. rewrite VAL1 in *.
        move READ_SPEC at bottom. desH READ_SPEC. rewrite <- COH0.
        exploit Memory.read_get_msg; eauto. i. des; esplits; eauto.
        all: try by rewrite COH0 at 1; eapply Memory.latest_ts_spec.
        all: try by rewrite List.nth_error_app2, Nat.sub_diag; [|refl]; ss.
      + exploit IH.(RPROP2); eauto. s. i. des. esplits; eauto.
        * rewrite fun_add_spec. des_ifs; eauto.
          inv e. etrans; eauto. ss. apply join_l.
        * eapply nth_error_app_mon. eauto.
    - unfold ALocal.next_eid in *. s. i. des_ifs.
      { apply Nat.eqb_eq in Heq. subst. econs; eauto.
        - rewrite List.nth_error_app2, Nat.sub_diag; [|refl]. ss.
        - econs; ss.
      }
      apply AExecUnit.label_is_mon. eapply IH.(COVPROP); eauto.
    - unfold ALocal.next_eid in *. s. i. des_ifs.
      { apply Nat.eqb_eq in Heq. subst. econs; eauto.
        - rewrite List.nth_error_app2, Nat.sub_diag; [|refl]. ss.
        - econs; ss.
      }
      apply AExecUnit.label_is_mon. eapply IH.(VEXTPROP); eauto.
    - i. unfold ALocal.next_eid in *.
      apply nth_error_snoc_inv in LABEL1. apply nth_error_snoc_inv in LABEL2. des.
      + repeat condtac.
        all: try apply Nat.eqb_eq in X; ss; subst; try lia.
        all: try apply Nat.eqb_eq in X0; ss; subst; try lia.
        eapply IH.(PO); eauto.
      + lia.
      + subst. repeat condtac; ss.
        all: try apply Nat.eqb_eq in X; ss; subst; try lia.
        all: try apply Nat.eqb_neq in X0; ss; try lia.
        splits; ss. rewrite fun_add_spec. des_ifs; [|congr].
        inv REL. destruct label1; ss.
        * destruct (equiv_dec loc0 loc); ss. inv e0.
          destruct (equiv_dec (ValA.val (sem_expr rmap0 eloc0)) loc); ss. inv e0.
          exploit IH.(RPROP1); eauto. i. des.
          exploit IH.(RPROP2); eauto. s. i. des. subst.
          exploit sim_rmap_weak_expr; eauto. i. inv x2. rewrite VAL1 in *.
          desH x5.
          { rewrite x5. apply bot_spec. }
          exploit Memory.latest_ts_read_le; try eapply Memory.get_msg_read; eauto. i.
          rewrite x2. apply Memory.latest_ts_mon. apply join_l.
        * destruct (equiv_dec loc0 loc); ss. inv e0.
          destruct (equiv_dec (ValA.val (sem_expr rmap0 eloc0)) loc); ss. inv e0.
          exploit IH.(WPROP2); eauto. i. des.
          exploit IH.(WPROP3); eauto. s. i. des. subst.
          exploit sim_rmap_weak_expr; eauto. i. inv x3. rewrite VAL1 in *.
          exploit Memory.latest_ts_read_le; try eapply Memory.get_msg_read; eauto. i.
          rewrite x3. apply Memory.latest_ts_mon. apply join_l.
      + subst. repeat condtac; ss.
        all: try apply Nat.eqb_eq in X; ss; try lia.
  }
  { (* write *)
    inv LOCAL; ss; inv EVENT; inv RES; inv STEP; ss. inv STATE. ss.
    destruct IH.(EU_WF).
    econs; ss; clear EU_WF2 AEU_WF2.
    - i. exploit IH.(WPROP1); eauto. s. i. rewrite Promises.unset_o. des_ifs.
      { inv e. right. rewrite MSG in GET. inv GET. esplits; ss.
        - instantiate (1 := ALocal.next_eid alc1). des_ifs; cycle 1.
          { apply Nat.eqb_neq in Heq. congr. }
          rewrite fun_add_spec. des_ifs; ss; try congr.
          repeat f_equal. destruct ts; ss.
          unfold Memory.get_msg in MSG. ss. rewrite MSG. des_ifs.
        - rewrite List.nth_error_app2, Nat.sub_diag; ss.
          inv VLOC. inv VVAL. rewrite VAL0, VAL1. eauto.
      }
      des; [left|right]; splits; ss.
      + i. des_ifs; eauto. apply Nat.eqb_eq in Heq. subst. ii. inv H.
        rewrite fun_add_spec in *. des_ifs; [|congr]. ss. apply c.
        specialize (Memory.latest_ts_spec (ValA.val vloc0) ts mem). i. des.
        destruct ts; ss. unfold Memory.get_msg in MSG. ss. rewrite MSG. des_ifs.
      + esplits; eauto.
        * des_ifs; eauto. apply Nat.eqb_eq in Heq. subst. unfold ALocal.next_eid in *.
          assert (H: List.nth_error (ALocal.labels alc1) (length (ALocal.labels alc1)) <> None) by (ii; congr).
          apply List.nth_error_Some in H. lia.
        * eapply nth_error_app_mon. eauto.
    - i. unfold ALocal.next_eid in *. apply nth_error_snoc_inv in GET. des.
      + des_ifs.
        { apply Nat.eqb_eq in Heq. subst. lia. }
        eapply IH.(WPROP2); eauto.
      + des_ifs; cycle 1.
        { apply Nat.eqb_neq in Heq. lia. }
        esplits; eauto.
        * inv VLOC. rewrite VAL0. eauto.
        * rewrite fun_add_spec in *. des_ifs; [|congr]. ss.
          inv VLOC. inv VVAL. rewrite <- VAL0, <- VAL1.
          specialize (Memory.latest_ts_spec (ValA.val vloc0) ts mem). i. des.
          destruct ts; ss. unfold Memory.get_msg in MSG. ss.
          rewrite MSG. ss. des_ifs.
    - i. unfold ALocal.next_eid in *. des_ifs.
      + apply Nat.eqb_eq in Heq. subst. rewrite fun_add_spec. des_ifs; [|congr]. inv e.
        destruct ts; ss. esplits; eauto.
        * unfold Memory.get_msg in MSG. ss. rewrite MSG. des_ifs.
          unfold Time.lt, Time.bot. lia.
        * unfold Memory.get_msg in MSG. ss. rewrite MSG. des_ifs.
        * unfold Memory.get_msg in MSG. ss. rewrite MSG. des_ifs.
        * rewrite List.nth_error_app2, Nat.sub_diag; ss.
          inv VLOC. rewrite VAL0. eauto.
        * generalize MSG. intro X. inv VVAL. rewrite <- VAL0.
          unfold Memory.get_msg in X. ss. rewrite X. des_ifs.
      + exploit IH.(WPROP3); eauto. s. i. des. esplits; eauto.
        * rewrite fun_add_spec. des_ifs; eauto. inv e. etrans; eauto.
          inv WRITABLE. apply Nat.lt_le_incl. ss.
        * eapply nth_error_app_mon. eauto.
    - i. unfold ALocal.next_eid in *.
      specialize (Memory.latest_ts_spec (ValA.val vloc0) ts mem). i. des.
      exploit Memory.latest_ts_read_le; [|refl|i; exploit le_antisym; try eapply LE; eauto; i].
      { eapply Memory.get_msg_read; eauto. }
      des_ifs.
      + apply Nat.eqb_eq in Heq. apply Nat.eqb_eq in Heq0. subst. ss.
      + clear Heq0. rewrite fun_add_spec in *. des_ifs; [|congr].
        exploit IH.(WPROP3); eauto. s. i. des.
        exploit IH.(WPROP1); eauto. s. rewrite x1 in *.
        rewrite PROMISE. i. des; ss.
        rewrite MSG in x7. inv x7. clear - WRITABLE x5. unfold le in x5. inv WRITABLE. lia.
      + rewrite fun_add_spec in *. des_ifs; [|congr].
        exploit IH.(WPROP3); eauto. s. i. des.
        exploit IH.(WPROP1); eauto. s. rewrite x1 in *.
        rewrite PROMISE. i. des; ss.
        rewrite MSG in x7. inv x7. clear -WRITABLE x5. unfold le in x5. inv WRITABLE. lia.
      + eapply IH.(WPROP4); eauto.
    - i. exploit IH.(RPROP1); eauto.
      apply nth_error_snoc_inv in GET. des; eauto. congr.
    - i. exploit IH.(RPROP2); eauto. s. i. des. esplits; eauto.
      * des_ifs.
        exfalso. apply Nat.eqb_eq in Heq. subst.
        unfold ALocal.next_eid in *.
        assert (H: List.nth_error (ALocal.labels alc1) (length (ALocal.labels alc1)) <> None) by (ii; congr).
        apply List.nth_error_Some in H. lia.
      * rewrite fun_add_spec. des_ifs; eauto. inv e. etrans; eauto.
        inv WRITABLE. apply Nat.lt_le_incl. ss.
      * eapply nth_error_app_mon. eauto.
    - unfold ALocal.next_eid in *. s. i. des_ifs.
      { apply Nat.eqb_eq in Heq. subst. econs; eauto.
        - rewrite List.nth_error_app2, Nat.sub_diag; [|refl]. ss.
        - econs; ss.
      }
      apply AExecUnit.label_is_mon. eapply IH.(COVPROP); eauto.
    - unfold ALocal.next_eid in *. s. i. des_ifs.
      { apply Nat.eqb_eq in Heq. subst. econs; eauto.
        - rewrite List.nth_error_app2, Nat.sub_diag; [|refl]. ss.
        - econs; ss.
      }
      apply AExecUnit.label_is_mon. eapply IH.(VEXTPROP); eauto.
    - inv ASTATE_STEP; ss; eauto. subst.
      inv VLOC. inv VVAL. rewrite VAL0, VAL1 in *. unfold ALocal.next_eid in *.
      i. apply nth_error_snoc_inv in LABEL1. apply nth_error_snoc_inv in LABEL2. des.
      + repeat condtac; ss.
        all: try apply Nat.eqb_eq in X; ss; subst; try lia.
        all: try apply Nat.eqb_eq in X0; ss; subst; try lia.
        eapply IH.(PO); eauto.
      + lia.
      + subst. repeat condtac; ss.
        all: try apply Nat.eqb_eq in X; ss; subst; try lia.
        all: try apply Nat.eqb_neq in X0; ss; try lia.
        splits; ss. rewrite fun_add_spec. des_ifs; [|congr].
        inv REL. destruct label1; ss.
        * destruct (equiv_dec loc0 loc); ss. inv e0.
          destruct (equiv_dec (ValA.val (sem_expr rmap eloc)) loc); ss. inv e0.
          exploit IH.(RPROP1); eauto. i. des.
          exploit IH.(RPROP2); eauto. s. i. des. subst.
          destruct ts; ss. unfold Memory.get_msg in MSG. ss. rewrite MSG. des_ifs.
          eapply Nat.le_lt_trans; eauto. inv WRITABLE. rewrite VAL0 in *. ss.
        * destruct (equiv_dec loc0 loc); ss. inv e0.
          destruct (equiv_dec (ValA.val (sem_expr rmap eloc)) loc); ss. inv e0.
          exploit IH.(WPROP2); eauto. i. des.
          exploit IH.(WPROP3); eauto. s. i. des. subst.
          destruct ts; ss. unfold Memory.get_msg in MSG. ss. rewrite MSG. des_ifs.
          eapply Nat.le_lt_trans; eauto. inv WRITABLE. rewrite VAL0 in *. ss.
      + subst. repeat condtac; ss.
        all: try apply Nat.eqb_eq in X; ss; try lia.
  }
  { (* write failure *)
    inv RES. destruct res1. ss. subst.
    inv LOCAL; ss; inv STEP; ss. inv EVENT. econs; ss; try by apply IH.
  }
  { (* barrier *)
    inv LOCAL; ss.
    { (* isb *)
      inv STEP. inv ASTATE_STEP. ss. inv EVENT. econs; ss.
      - i. exploit IH.(WPROP1); eauto. s. i. des; [left|right]; esplits; eauto.
        eapply nth_error_app_mon. eauto.
      - i. exploit IH.(WPROP2); eauto.
        apply nth_error_snoc_inv in GET. des; eauto. congr.
      - i. exploit IH.(WPROP3); eauto. i. des. esplits; eauto.
        eapply nth_error_app_mon. eauto.
      - eapply IH.(WPROP4).
      - i. exploit IH.(RPROP1); eauto.
        apply nth_error_snoc_inv in GET. des; eauto. congr.
      - i. exploit IH.(RPROP2); eauto. s. i. des. esplits; eauto.
        eapply nth_error_app_mon. eauto.
      - i. apply AExecUnit.label_is_mon. eapply IH.(COVPROP); eauto.
      - i. apply AExecUnit.label_is_mon. eapply IH.(VEXTPROP); eauto.
      - i. apply nth_error_snoc_inv in LABEL1. des; cycle 1.
        { subst. inv REL. inv X. }
        apply nth_error_snoc_inv in LABEL2. des; cycle 1.
        { subst. inv REL. inv Y. }
        eapply IH.(PO); eauto.
    }
    { (* dmb *)
      inv STEP. inv ASTATE_STEP. ss. inv EVENT. econs; ss.
      - i. exploit IH.(WPROP1); eauto. s. i. des; [left|right]; esplits; eauto.
        eapply nth_error_app_mon. eauto.
      - i. exploit IH.(WPROP2); eauto.
        apply nth_error_snoc_inv in GET. des; eauto. congr.
      - i. exploit IH.(WPROP3); eauto. s. i. des. esplits; eauto.
        eapply nth_error_app_mon. eauto.
      - eapply IH.(WPROP4).
      - i. exploit IH.(RPROP1); eauto.
        apply nth_error_snoc_inv in GET. des; eauto. congr.
      - i. exploit IH.(RPROP2); eauto. s. i. des. esplits; eauto.
        eapply nth_error_app_mon. eauto.
      - i. apply AExecUnit.label_is_mon. eapply IH.(COVPROP); eauto.
      - i. apply AExecUnit.label_is_mon. eapply IH.(VEXTPROP); eauto.
      - i. apply nth_error_snoc_inv in LABEL1. des; cycle 1.
        { subst. inv REL. inv X. }
        apply nth_error_snoc_inv in LABEL2. des; cycle 1.
        { subst. inv REL. inv Y. }
        eapply IH.(PO); eauto.
    }
  }
  { (* control *)
    inv LOCAL; ss. inv LC. inv STATE0. inv ASTATE_STEP. ss. inv EVENT.
    econs; ss.
    - i. exploit IH.(WPROP1); eauto. s. i. des; [left|right]; esplits; eauto.
      eapply nth_error_app_mon. eauto.
    - i. exploit IH.(WPROP2); eauto.
      apply nth_error_snoc_inv in GET. des; eauto. congr.
    - i. exploit IH.(WPROP3); eauto. i. des. esplits; eauto.
      eapply nth_error_app_mon. eauto.
    - eapply IH.(WPROP4).
    - i. exploit IH.(RPROP1); eauto.
      apply nth_error_snoc_inv in GET. des; eauto. congr.
    - i. exploit IH.(RPROP2); eauto. s. i. des. esplits; eauto.
      eapply nth_error_app_mon. eauto.
    - i. apply AExecUnit.label_is_mon. eapply IH.(COVPROP); eauto.
    - i. apply AExecUnit.label_is_mon. eapply IH.(VEXTPROP); eauto.
    - i. apply nth_error_snoc_inv in LABEL1. des; cycle 1.
      { subst. inv REL. inv X. }
      apply nth_error_snoc_inv in LABEL2. des; cycle 1.
      { subst. inv REL. inv Y. }
      eapply IH.(PO); eauto.
  }
Unshelve.
all: auto. (* tid *)
Qed.


Require Import Sem SimProg Skeleton Mod ModSem SimMod SimModSem SimSymb SimMem Sound SimSymb.
Require Import Cop Ctypes ClightC.
Require SimMemId SimMemExt SimMemInj.
Require SoundTop UnreachC.
Require SimSymbId SimSymbDrop.
Require Import MutrecABspec.
Require Import CoqlibC.
Require Import ValuesC.
Require Import LinkingC.
Require Import MapsC.
Require Import AxiomsC.
Require Import Ord.
Require Import MemoryC.
Require Import SmallstepC.
Require Import Events.
Require Import Preservation.
Require Import Integers.
Require Import LocationsC Conventions.

Require Import MatchSimModSem ModSemProps.
Require Import IdSimExtra.
Require Import CopC.
Require Import sflib.

Set Implicit Arguments.

Local Opaque Z.mul Z.add Z.sub Z.div.

Inductive match_states_ext_ab
  : unit -> state -> state -> SimMemExt.t' -> Prop :=
| match_ext_Callstate
    i m_src m_tgt sm0
    (MWFSRC: m_src = sm0.(SimMemExt.src))
    (MWFTGT: m_tgt = sm0.(SimMemExt.tgt))
    (MWF: Mem.extends m_src m_tgt)
  :
    match_states_ext_ab
      tt
      (Callstate i m_src)
      (Callstate i m_tgt)
      sm0
| match_return_Callstate
    i m_src m_tgt sm0
    (MWFSRC: m_src = sm0.(SimMemExt.src))
    (MWFTGT: m_tgt = sm0.(SimMemExt.tgt))
    (MWF: Mem.extends m_src m_tgt)
  :
    match_states_ext_ab
      tt
      (Returnstate i m_src)
      (Returnstate i m_tgt)
      sm0.

Section ABSOUNDSTATE.

  Variable skenv_link: SkEnv.t.
  Variable su: Sound.t.

  Inductive sound_state_ab
    : state -> Prop :=
  | sound_Callstate
      i m
      (WF: Sound.wf su)
      (MEM: UnreachC.mem' su m)
      (SKE: su.(Unreach.ge_nb) = skenv_link.(Genv.genv_next))
    :
      sound_state_ab (Callstate i m)
  | sound_Returnstate
      i m
      (WF: Sound.wf su)
      (MEM: UnreachC.mem' su m)
      (SKE: su.(Unreach.ge_nb) = skenv_link.(Genv.genv_next))
    :
      sound_state_ab (Returnstate i m)
  .

End ABSOUNDSTATE.

Section ABSOUND.

  Variable skenv_link: SkEnv.t.

  Lemma ab_unreach_local_preservation
    :
      exists sound_state, <<PRSV: local_preservation (modsem skenv_link tt) sound_state>>
  .
  Proof.
    esplits.
    eapply local_preservation_strong_horizontal_spec with (lift := UnreachC.le') (sound_state := sound_state_ab skenv_link); eauto.
    econs; ss; i.
    { eapply UnreachC.liftspec; et. }
    - inv INIT. ss. unfold Sound.args in SUARG. des_ifs. des. esplits.
      + refl.
      + ss. econs; eauto. inv SKENV. ss.
      + instantiate (1:=get_mem). ss. refl.
    - inv STEP; inv SUST. esplits; eauto.
      + refl.
      + econs; eauto.
      + ss. refl.
    - inv FINAL; inv SUST. esplits; eauto.
      + refl.
      + econs; eauto. ss.
      + ss. refl.
  Qed.

End ABSOUND.

Inductive match_states_ab_internal:
  state -> state -> meminj -> mem -> mem -> Prop :=
| match_Callstate
    i m_src m_tgt j
  :
    match_states_ab_internal
      (Callstate i m_src)
      (Callstate i m_tgt)
      j m_src m_tgt
| match_Returnstate
    i m_src m_tgt j
  :
    match_states_ab_internal
      (Returnstate i m_src)
      (Returnstate i m_tgt)
      j m_src m_tgt
.

Inductive match_states_ab
  : unit -> state -> state -> SimMemInj.t' -> Prop :=
| match_states_ab_intro
    st_src st_tgt j m_src m_tgt sm0
    (MWFSRC: m_src = sm0.(SimMemInj.src))
    (MWFTGT: m_tgt = sm0.(SimMemInj.tgt))
    (MWFINJ: j = sm0.(SimMemInj.inj))
    (MATCHST: match_states_ab_internal st_src st_tgt j m_src m_tgt)
    (MWF: SimMemInj.wf' sm0)
  :
    match_states_ab
      tt st_src st_tgt sm0
.

Lemma a_id
      (WF: Sk.wf MutrecABspec.module)
  :
    exists mp,
      (<<SIM: @ModPair.sim SimMemId.SimMemId SimMemId.SimSymbId SoundTop.Top mp>>)
      /\ (<<SRC: mp.(ModPair.src) = (MutrecABspec.module)>>)
      /\ (<<TGT: mp.(ModPair.tgt) = (MutrecABspec.module)>>)
.
Proof.
  eapply any_id; auto.
Qed.

Lemma a_ext_unreach
      (WF: Sk.wf MutrecABspec.module)
 :
    exists mp,
      (<<SIM: @ModPair.sim SimMemExt.SimMemExt SimMemExt.SimSymbExtends UnreachC.Unreach mp>>)
      /\ (<<SRC: mp.(ModPair.src) = (MutrecABspec.module)>>)
      /\ (<<TGT: mp.(ModPair.tgt) = (MutrecABspec.module)>>)
.
Proof.
  eexists (ModPair.mk _ _ _); s.
  esplits; eauto. instantiate (1:=SimSymbId.mk _ _).
  econs; ss; i.
  destruct SIMSKENVLINK.
  exploit ab_unreach_local_preservation. i. des.
  eapply match_states_sim with (match_states := match_states_ext_ab)
                               (match_states_at := top4); ss.
  - apply unit_ord_wf.
  - eauto.
  - i. ss. inv INITTGT. inv SAFESRC. inv H. clarify.
    inv SIMARGS; ss. esplits; eauto; ss.
    + econs; eauto.
    + assert (i = i0).
      { subst. inv VALS. inv H2. ss. }
      subst. econs; eauto. ss.

  - i. ss. des. inv SAFESRC. esplits. econs; ss.
    + inv SIMARGS; ss. inv FPTR; eauto. clarify.
    + instantiate (1:=i). inv SIMARGS; ss.
      rewrite VS in *. inv VALS. inv H3. inv H1. ss.
    + auto.

  - i. inv MATCH; auto.

  - i. ss. inv FINALSRC. inv MATCH.
    esplits; eauto.
    + econs.
    + econs; eauto. econs.

  - right. ii. des.
    esplits.
    + i. inv MATCH; ss.
      * unfold ModSem.is_step. do 2 eexists. ss.
      * unfold safe_modsem in H.
        exploit H. eapply star_refl. ii. des; clarify. inv EVSTEP.
    + ii. inv STEPTGT; inv MATCH; ss.
      esplits; eauto.
      { left. eapply plus_one. econs. }
      econs; eauto.
Qed.

Lemma a_ext_top
      (WF: Sk.wf MutrecABspec.module)
 :
    exists mp,
      (<<SIM: @ModPair.sim SimMemExt.SimMemExt SimMemExt.SimSymbExtends SoundTop.Top mp>>)
      /\ (<<SRC: mp.(ModPair.src) = (MutrecABspec.module)>>)
      /\ (<<TGT: mp.(ModPair.tgt) = (MutrecABspec.module)>>)
.
Proof.
  eexists (ModPair.mk _ _ _); s.
  esplits; eauto. instantiate (1:=SimSymbId.mk _ _).
  econs; ss; i.
  destruct SIMSKENVLINK.
  eapply match_states_sim with (match_states := match_states_ext_ab)
                               (match_states_at := top4); ss.
  - apply unit_ord_wf.
  - eapply SoundTop.sound_state_local_preservation.
  - i. ss. inv INITTGT. inv SAFESRC. inv H. clarify.
    inv SIMARGS; ss. esplits; eauto; ss.
    + econs; eauto.
    + assert (i = i0).
      { subst. inv VALS. inv H2. ss. }
      subst. econs; eauto. ss.

  - i. ss. des. inv SAFESRC. esplits. econs; ss.
    + inv SIMARGS; ss. inv FPTR; eauto. clarify.
    + instantiate (1:=i). inv SIMARGS; ss.
      rewrite VS in *. inv VALS. inv H3. inv H1. ss.
    + auto.

  - i. inv MATCH; auto.

  - i. ss. inv FINALSRC. inv MATCH.
    esplits; eauto.
    + econs.
    + econs; eauto. econs.

  - right. ii. des.
    esplits.
    + i. inv MATCH; ss.
      * unfold ModSem.is_step. do 2 eexists. ss.
      * unfold safe_modsem in H.
        exploit H. eapply star_refl. ii. des; clarify. inv EVSTEP.
    + ii. inv STEPTGT; inv MATCH; ss.
      esplits; eauto.
      { left. eapply plus_one. econs. }
      econs; eauto.
Qed.

Lemma ab_inj_drop_bot
      (WF: Sk.wf (MutrecABspec.module))
  :
    exists mp,
      (<<SIM: @ModPair.sim SimMemInjC.SimMemInj SimSymbDrop.SimSymbDrop SoundTop.Top mp>>)
      /\ (<<SRC: mp.(ModPair.src) = (MutrecABspec.module)>>)
      /\ (<<TGT: mp.(ModPair.tgt) = (MutrecABspec.module)>>)
      /\ (<<SSBOT: mp.(ModPair.ss) = SimSymbDrop.mk bot1 (MutrecABspec.module) (MutrecABspec.module)>>)
.
Proof.
  eexists (ModPair.mk _ _ _); s.
  esplits; eauto.
  econs; ss; i.
  { econs; ss; i; clarify.
    inv WF. auto. }
  eapply match_states_sim with (match_states := match_states_ab)
                                 (match_states_at := top4); ss.
  - apply unit_ord_wf.
  - eapply SoundTop.sound_state_local_preservation.

  - i. ss. inv INITTGT. inv SAFESRC. inv SIMARGS; ss. inv H.
    esplits; eauto.
    + econs; eauto.
    + refl.
    + econs; eauto.
      assert (i = i0).
      { subst. inv VALS. inv H2; ss. inv VS0. ss. }
      subst i0. econs.

  - i. des. inv SAFESRC. inv SIMARGS; ss.
    rewrite VS in *. inv VALS. inv H1. inv H3.
    unfold Genv.find_funct, Genv.find_funct_ptr in *. des_ifs.
    inv SIMSKENV. ss. inv SIMSKE. ss. inv FPTR.  exploit SIMDEF; eauto.
    i. des. clarify. esplits; eauto. econs; ss; eauto.
    unfold Genv.find_funct_ptr. des_ifs.

  - i. inv MATCH; eauto.

  - i. ss. inv FINALSRC. inv MATCH. inv MATCHST. esplits; eauto.
    + econs.
    + econs; eauto. econs.
    + refl.

  - right. ii. des.
    esplits.
    + i. inv MATCH; inv MATCHST; ss.
      * unfold ModSem.is_step. do 2 eexists. ss.
      * unfold safe_modsem in H.
        exploit H. eapply star_refl. ii. des; clarify. inv EVSTEP.
    + ii. inv STEPTGT; inv MATCH; inv MATCHST; ss.
      esplits; eauto.
      { left. eapply plus_one. econs. }
      { refl. }
      econs; eauto. econs; eauto.
Qed.

Lemma ab_inj_drop
      (WF: Sk.wf (MutrecABspec.module))
  :
    exists mp,
      (<<SIM: @ModPair.sim SimMemInjC.SimMemInj SimSymbDrop.SimSymbDrop SoundTop.Top mp>>)
      /\ (<<SRC: mp.(ModPair.src) = (MutrecABspec.module)>>)
      /\ (<<TGT: mp.(ModPair.tgt) = (MutrecABspec.module)>>)
.
Proof.
  exploit ab_inj_drop_bot; eauto. i. des. eauto.
Qed.

Lemma ab_inj_id
      (WF: Sk.wf (MutrecABspec.module))
  :
    exists mp,
      (<<SIM: @ModPair.sim SimMemInjC.SimMemInj SimMemInjC.SimSymbId SoundTop.Top mp>>)
      /\ (<<SRC: mp.(ModPair.src) = (MutrecABspec.module)>>)
      /\ (<<TGT: mp.(ModPair.tgt) = (MutrecABspec.module)>>)
.
Proof.
  eapply sim_inj_drop_bot_id. apply ab_inj_drop_bot; auto.
Qed.

Require Import IdSimInvExtra.

Section INJINV.

Local Existing Instance SimSymbDropInv.SimMemInvTop.
Local Existing Instance SimSymbDropInv.SimSymbDropInv.
Local Existing Instance SoundTop.Top.

Inductive match_states_ab_inv
  : unit -> state -> state -> SimMem.t -> Prop :=
| match_states_ab_inv_intro
    st_src st_tgt j m_src m_tgt sm0
    (MWFSRC: m_src = sm0.(SimMem.src))
    (MWFTGT: m_tgt = sm0.(SimMem.tgt))
    (MWFINJ: j = sm0.(SimMemInjInv.minj).(SimMemInj.inj))
    (MATCHST: match_states_ab_internal st_src st_tgt j m_src m_tgt)
    (MWF: SimMem.wf sm0)
  :
    match_states_ab_inv
      tt st_src st_tgt sm0.

Lemma ab_inj_inv_id
      (WF: Sk.wf (MutrecABspec.module))
  :
    exists mp,
      (<<SIM: ModPair.sim mp>>)
      /\ (<<SRC: mp.(ModPair.src) = (MutrecABspec.module)>>)
      /\ (<<TGT: mp.(ModPair.tgt) = (MutrecABspec.module)>>)
.
Proof.
  eexists (ModPair.mk _ _ _); s.
  esplits; eauto. instantiate (1:=SimSymbDropInv.mk bot1 _ _).
  econs; ss; i.
  { econs; ss; i; clarify. inv WF. eauto. }
  eapply match_states_sim with (match_states := match_states_ab_inv)
                               (match_states_at := top4); ss.
  - apply unit_ord_wf.
  - eapply SoundTop.sound_state_local_preservation.

  - i. ss. inv INITTGT. inv SAFESRC. inv SIMARGS; ss. inv H.
    esplits; eauto.
    + econs; eauto.
    + refl.
    + econs; eauto.
      assert (i = i0).
      { subst. inv VALS. inv H2; ss. inv VS0. ss. }
      subst i0. econs.

  - i. des. inv SAFESRC. inv SIMARGS; ss.
    rewrite VS in *. inv VALS. inv H1. inv H3.
    unfold Genv.find_funct, Genv.find_funct_ptr in *. des_ifs.
    inv SIMSKENV. ss. inv SIMSKE. ss. inv FPTR.  exploit SIMDEF; eauto.
    i. des. clarify. esplits; eauto. econs; ss; eauto.
    unfold Genv.find_funct_ptr. des_ifs.

  - i. inv MATCH; eauto.

  - i. ss. inv FINALSRC. inv MATCH. inv MATCHST. esplits; eauto.
    + econs.
    + econs; eauto. econs.
    + refl.

  - right. ii. des.
    esplits.
    + i. inv MATCH; inv MATCHST; ss.
      * unfold ModSem.is_step. do 2 eexists. ss.
      * unfold safe_modsem in H.
        exploit H. eapply star_refl. ii. des; clarify. inv EVSTEP.
    + ii. inv STEPTGT; inv MATCH; inv MATCHST; ss.
      esplits; eauto.
      { left. eapply plus_one. econs. }
      { refl. }
      econs; eauto. econs; eauto.
Qed.

End INJINV.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of VMM                                          *)
(*                                                                     *)
(*          Refinement Proof for PThreadInit                           *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between PThreadIntro layer and PThreadInit layer*)
Require Import Coqlib.
Require Import Errors.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Asm.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Values.
Require Import Memory.
Require Import Maps.
Require Import CommonTactic.
Require Import AuxLemma.
Require Import FlatMemory.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import RealParams.
Require Import LoadStoreSem2.
Require Import AsmImplLemma.
Require Import GenSem.
Require Import RefinementTactic.
Require Import PrimSemantics.
Require Import XOmega.

Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compcertx.MakeProgram.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.
Require Import compcert.cfrontend.Ctypes.

Require Import LayerCalculusLemma.
Require Import AbstractDataType.

Require Import ThreadInitGenSpec.
Require Import PThreadIntro.
Require Import PThreadInit.

(** * Definition of the refinement relation*)
Section Refinement.

  Local Open Scope string_scope.
  Local Open Scope error_monad_scope.
  Local Open Scope Z_scope.

  Context `{real_params: RealParams}.

  Notation HDATA := RData.
  Notation LDATA := RData.

  Notation HDATAOps := (cdata (cdata_ops := pthreadinit_data_ops) HDATA).
  Notation LDATAOps := (cdata (cdata_ops := mshareintro_data_ops) LDATA).

  Section WITHMEM.

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

    (** Relation between raw data at two layers*)
    Record relate_RData (f: meminj) (hadt: LDATA) (ladt: LDATA) :=
      mkrelate_RData {
          flatmem_re: FlatMem.flatmem_inj (HP hadt) (HP ladt);
          vmxinfo_re: vmxinfo hadt = vmxinfo ladt;
          devout_re: devout hadt = devout ladt;
          CR3_re:  CR3 hadt = CR3 ladt;
          ikern_re: ikern hadt = ikern ladt;
          pg_re: pg hadt = pg ladt;
          ihost_re: ihost hadt = ihost ladt;
          AC_re: AC hadt = AC ladt;
          ti_fst_re: (fst (ti hadt)) = (fst (ti ladt));
          ti_snd_re: val_inject f (snd (ti hadt)) (snd (ti ladt));
          LAT_re: LAT hadt = LAT ladt;
          nps_re: nps hadt = nps ladt;
          init_re: init hadt = init ladt;

          pperm_re: pperm hadt = pperm ladt;
          PT_re:  PT hadt = PT ladt;
          ptp_re: ptpool hadt = ptpool ladt;
          idpde_re: idpde hadt = idpde ladt;
          ipt_re: ipt hadt = ipt ladt;
          smspool_re: smspool hadt = smspool ladt;

          kctxt_re: kctxt_inj f num_proc (kctxt hadt) (kctxt ladt);
          tcb_re:  tcb hadt = tcb ladt
        }.

    Inductive match_RData: stencil -> HDATA -> mem -> meminj -> Prop :=
    | MATCH_RDATA: forall habd m f s, match_RData s habd m f.

    Local Hint Resolve MATCH_RDATA.

    Global Instance rel_ops: CompatRelOps HDATAOps LDATAOps :=
      {
        relate_AbData s f d1 d2 := relate_RData f d1 d2;
        match_AbData s d1 m f := match_RData s d1 m f;
        new_glbl := nil
      }.

    (** ** Properties of relations*)
    Section Rel_Property.

      (** Prove that after taking one step, the refinement relation still holds*)
      Lemma relate_incr:
        forall abd abd' f f',
          relate_RData f abd abd'
          -> inject_incr f f'
          -> relate_RData f' abd abd'.
      Proof.
        inversion 1; subst; intros; inv H; constructor; eauto.
        - eapply kctxt_inj_incr; eauto.
      Qed.

      Lemma relate_kernel_mode:
        forall abd abd' f,
          relate_RData f abd abd'
          -> (kernel_mode abd <-> kernel_mode abd').
      Proof.
        inversion 1; simpl; split; congruence.
      Qed.

      Lemma relate_observe:
        forall p abd abd' f,
          relate_RData f abd abd' ->
          observe p abd = observe p abd'.
      Proof.
        inversion 1; simpl; unfold ObservationImpl.observe; congruence.
      Qed.

      Global Instance rel_prf: CompatRel HDATAOps LDATAOps.
      Proof.
        constructor; intros; simpl; trivial.
        eapply relate_incr; eauto.
        eapply relate_kernel_mode; eauto.
        eapply relate_observe; eauto.
      Qed.

    End Rel_Property.

    (** * Proofs the one-step forward simulations for the low level specifications*)
    Section OneStep_Forward_Relation.

      (** ** The low level specifications exist*)
      Section Exists.

        Lemma thread_init_exist:
          forall habd habd' labd i f,
            ObjQueue.thread_init_spec i habd = ret habd'
            -> relate_RData f habd labd
            -> exists labd', thread_init_spec i labd = Some labd'
                             /\ relate_RData f habd' labd'
                             /\ kernel_mode labd.
        Proof.
          unfold ObjQueue.thread_init_spec, thread_init_spec, sharedmem_init_spec,
          thread_init_spec.
          intros until f. exist_simpl.
        Qed.

        (*
        Lemma thread_free_exist:
          forall habd habd' labd n f,
            thread_free_spec habd n = Some habd'
            -> relate_RData f habd labd
            -> high_level_invariant habd
            -> exists labd', thread_free_spec labd n = Some labd'
                             /\ relate_RData f habd' labd'
                             /\ kernel_mode labd.
        Proof.
          unfold thread_free_spec, thread_free_spec,
          pt_free_spec, tcb_init_spec.
          intros until f.
          intros HP HR; inv HR; revert HP; simpl;
          subrewrite'; intros HQ; subdestruct.
          rewrite zle_true; [|omega].
          inv HQ. refine_split'; eauto.
          econstructor; eauto.
        Qed.*)

      End Exists.

      Section FRESH_PRIM.

        (*Lemma thread_free_spec_ref:
          compatsim (crel HDATA LDATA) (gensem thread_free_spec)
                    thread_free_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit thread_free_exist; eauto 1.
          intros [labd' [HP [HM Hkern]]].
          refine_split; try econstructor; eauto. constructor.
        Qed.*)

        Lemma thread_init_spec_ref:
          compatsim (crel HDATA LDATA) (gensem ObjQueue.thread_init_spec) thread_init_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit thread_init_exist; eauto 1.
          intros [labd' [HP [HM Hkern]]].
          refine_split; try econstructor; eauto. constructor.
        Qed.

      End FRESH_PRIM.

      Section PASSTHROUGH_RPIM.

        Global Instance: (LoadStoreProp (hflatmem_store:= flatmem_store) (lflatmem_store:= flatmem_store)).
        Proof.
          accessor_prop_tac.
          - eapply flatmem_store_exists; eauto.
        Qed.

        Lemma passthrough_correct:
          sim (crel HDATA LDATA) pthreadinit_passthrough pthreadintro.
        Proof.
          sim_oplus.
          - apply fload_sim.
          - apply fstore_sim.
          - apply flatmem_copy_sim.
          - apply vmxinfo_get_sim.
          - apply device_output_sim.
          - apply pfree_sim.
          - apply setPT_sim.
          - apply ptRead_sim.
          - apply ptResv_sim.
          - apply kctxt_new_sim.
          - apply shared_mem_status_sim.
          - apply offer_shared_mem_sim.
          - apply get_state_sim.
          - apply get_prev_sim.
          - apply get_next_sim.
          - apply set_state_sim.
          - apply set_prev_sim.
          - apply set_next_sim.
          - apply ptin_sim.
          - apply ptout_sim.
          - apply clearCR2_sim.
          - apply container_get_nchildren_sim.
          - apply container_get_quota_sim.
          - apply container_get_usage_sim.
          - apply container_can_consume_sim.
          - apply alloc_sim.
          - apply trapin_sim.
          - apply trapout_sim.
          - apply hostin_sim.
          - apply hostout_sim.
          - apply trap_info_get_sim.
          - apply trap_info_ret_sim.
          - apply kctxt_switch_sim.
          - layer_sim_simpl.
            + eapply load_correct2.
            + eapply store_correct2.
        Qed.

      End PASSTHROUGH_RPIM.

    End OneStep_Forward_Relation.

  End WITHMEM.

End Refinement.


Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Bool.Bool.

Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import compcert.common.AST.
Require Import compcert.cfrontend.Clight.
Require Import compcert.common.Globalenvs.
Require Import compcert.common.Memory. Import Memory.
Require Import compcert.common.Memdata. Import Memdata.
Require Import compcert.common.Values.

Require Import msl.Coqlib2.
Require Import msl.eq_dec.
Require Import msl.seplog.
Require Import veric.Clight_new.
Require Import veric.coqlib4.
Require Import sepcomp.Address.
Require Import sepcomp.mem_lemmas.
Require Import concurrency.permissions.

Set Bullet Behavior "Strict Subproofs".

(** * Results on cl_step *)

Lemma cl_step_decay ge c m c' m' : @cl_step ge c m c' m' -> @decay m m'.
Proof.
  intros step.
  induction step
    as [ ve te k m a1 a2 b ofs v2 v m' H H0 H1 H2 ASS | |
         ve te k m optid a al tyagrs tyres cc vf vargs f m'  ve' le' H H0 H1 H2 H3 H4 NRV ALLOC H6
         | | | | | | | | | f ve te optexp optid k m v' m' ve' te'' k' H H0 FREE H2 H3 | | | ];
    try apply decay_refl || apply IHstep.

  - (* assign: no change in permission *)
    intros b' ofs'.
    split.
    + inversion ASS as [v0 chunk m'0 H3 BAD H5 H6 | b'0 ofs'0 bytes m'0 H3 H4 H5 H6 H7 BAD H9 H10]; subst.
      -- pose proof storev_valid_block_2 _ _ _ _ _ BAD b'. tauto.
      -- pose proof Mem.storebytes_valid_block_2 _ _ _ _ _ BAD b'. tauto.
    + intros V; right; intros kind.
      (* destruct m as [c acc nb max no def]. simpl in *. *)
      inversion ASS as [v0 chunk m'0 H3 STO H5 H6 | b'0 ofs'0 bytes m'0 H3 H4 H5 H6 H7 STO H9 H10]; subst.
      -- simpl in *.
         Transparent Mem.store.
         unfold Mem.store in *; simpl in *.
         destruct (Mem.valid_access_dec m chunk b (Int.unsigned ofs) Writable).
         2:discriminate.
         injection STO as <-. simpl.
         reflexivity.
      -- Transparent Mem.storebytes.
         unfold Mem.storebytes in *.
         destruct (Mem.range_perm_dec
                     m b (Int.unsigned ofs)
                     (Int.unsigned ofs + Z.of_nat (Datatypes.length bytes)) Cur Writable).
         2:discriminate.
         injection STO as <-. simpl.
         reflexivity.

  - (* internal call : allocations *)
    clear -ALLOC.
    induction ALLOC. now apply decay_refl.
    apply decay_trans with m1. 3:apply IHALLOC.

    + clear -H.
      Transparent Mem.alloc.
      unfold Mem.alloc in *.
      injection H as <- <-.
      intros b V.
      unfold Mem.valid_block in *. simpl.
      apply Coqlib.Plt_trans_succ, V.

    + clear -H.
      unfold Mem.alloc in *.
      injection H as E <-.
      intros b ofs.
      split.
      * intros N V.
        subst m1.
        simpl in *.
        rewrite PMap.gsspec.
        unfold Mem.valid_block in *; simpl in *.
        if_tac; subst; auto.
        -- if_tac; auto.
        -- destruct N.
           apply Coqlib.Plt_succ_inv in V.
           tauto.
      * intros V.
        right.
        intros k.
        subst.
        simpl.
        rewrite PMap.gsspec.
        if_tac.
        -- subst b. inversion V. rewrite Pos.compare_lt_iff in *. edestruct Pos.lt_irrefl; eauto.
        -- reflexivity.

  - (* return: free_list *)
    revert FREE; clear.
    generalize (blocks_of_env ge ve); intros l.
    revert m m'; induction l as [| [[b o] o'] l IHl]; intros m m'' E.
    + simpl. injection E as <- ; apply decay_refl.
    + simpl in E.
      destruct (Mem.free m b o o') as [m' |] eqn:F.
      2:discriminate.
      specialize (IHl _ _ E).
      Transparent Mem.free.
      unfold Mem.free in *.
      if_tac in F. rename H into G.
      2:discriminate.
      apply decay_trans with m'. 3:now apply IHl.
      * injection F as <-.
        intros.
        unfold Mem.unchecked_free, Mem.valid_block in *.
        simpl in *.
        assumption.

      * injection F as <-.
        clear -G.
        unfold Mem.unchecked_free in *.
        intros b' ofs; simpl. unfold Mem.valid_block; simpl.
        split.
        tauto.
        intros V.
        rewrite PMap.gsspec.
        if_tac; auto. subst b'.
        hnf in G.
        destruct (Coqlib.proj_sumbool (Coqlib.zle o ofs)&&Coqlib.proj_sumbool (Coqlib.zlt ofs o'))%bool eqn:E.
        2: now auto.
        left. split; auto.
        destruct m as [co acc nb max noa def] eqn:Em; simpl in *.
        unfold Mem.perm in G; simpl in *.
        specialize (G ofs).
        cut (acc !! b ofs Cur = Some Freeable). {
          destruct k; auto.
          pose proof Mem.access_max m b ofs as M.
          subst m; simpl in M.
          intros A; rewrite A in M.
          destruct (acc !! b ofs Max) as [ [] | ]; inversion M; auto.
        }
        assert (R: (o <= ofs < o')%Z). {
          rewrite andb_true_iff in *. destruct E as [E F].
          apply Coqlib.proj_sumbool_true in E.
          apply Coqlib.proj_sumbool_true in F.
          auto.
        }
        autospec G.
        destruct (acc !! b ofs Cur) as [ [] | ]; inversion G; auto.
Qed.

Lemma cl_step_unchanged_on ge c m c' m' b ofs :
  @cl_step ge c m c' m' ->
  Mem.valid_block m b ->
  ~ Mem.perm m b ofs Cur Writable ->
  Maps.ZMap.get ofs (Maps.PMap.get b (Mem.mem_contents m)) =
  Maps.ZMap.get ofs (Maps.PMap.get b (Mem.mem_contents m')).
Proof.
  intros step.
  induction step
    as [ ve te k m a1 a2 b0 ofs0 v2 v m' H H0 H1 H2 ASS | |
         ve te k m optid a al tyagrs tyres cc vf vargs f m'  ve' le' H H0 H1 H2 H3 H4 NRV ALLOC H6
         | | | | | | | | | f ve te optexp optid k m v' m' ve' te'' k' H H0 FREE H2 H3 | | | ];
    intros V NW; auto.

  - (* assign: some things are updated, but not the chunk in non-writable permission *)
    inversion ASS; subst.
    + inversion H4.
      unfold Mem.store in *.
      destruct (Mem.valid_access_dec m chunk b0 (Int.unsigned ofs0) Writable); [|discriminate].
      injection H6 as <- ; clear ASS H4.
      simpl.
      destruct (eq_dec b b0) as [e|n]; swap 1 2.
      * rewrite PMap.gso; auto.
      * subst b0. rewrite PMap.gss.
        generalize ((Mem.mem_contents m) !! b); intros t.
        destruct v0 as [v0 align].
        specialize (v0 ofs).
        {
          destruct (adr_range_dec (b, Int.unsigned ofs0) (size_chunk chunk) (b, ofs)) as [a|a].
          - simpl in a; destruct a as [_ a].
            autospec v0.
            tauto.
          - simpl in a.
            symmetry.
            apply Mem.setN_outside.
            rewrite encode_val_length.
            replace (Z_of_nat (size_chunk_nat chunk)) with (size_chunk chunk); swap 1 2.
            { unfold size_chunk_nat in *. rewrite Z2Nat.id; auto. destruct chunk; simpl; omega. }
            assert (a' : ~ (Int.unsigned ofs0 <= ofs < Int.unsigned ofs0 + size_chunk chunk)%Z) by intuition.
            revert a'; clear.
            generalize (Int.unsigned ofs0).
            generalize (size_chunk chunk).
            intros.
            omega.
        }

    + (* still the case of assignment (copying) *)
      unfold Mem.storebytes in *.
      destruct (Mem.range_perm_dec m b0 (Int.unsigned ofs0) (Int.unsigned ofs0 + Z.of_nat (Datatypes.length bytes)) Cur Writable); [ | discriminate ].
      injection H8 as <-; clear ASS; simpl.
      destruct (eq_dec b b0) as [e|n]; swap 1 2.
      * rewrite PMap.gso; auto.
      * subst b0. rewrite PMap.gss.
        generalize ((Mem.mem_contents m) !! b); intros t.
        specialize (r ofs).
        {
          destruct (adr_range_dec (b, Int.unsigned ofs0) (Z.of_nat (Datatypes.length bytes)) (b, ofs)) as [a|a].
          - simpl in a; destruct a as [_ a].
            autospec r.
            tauto.
          - simpl in a.
            symmetry.
            apply Mem.setN_outside.
            assert (a' : ~ (Int.unsigned ofs0 <= ofs < Int.unsigned ofs0 + Z.of_nat (Datatypes.length bytes))%Z) by intuition.
            revert a'; clear.
            generalize (Int.unsigned ofs0).
            intros.
            omega.
        }

  - (* internal call : things are allocated -- each time in a new block *)
    clear -V ALLOC.
    induction ALLOC. easy.
    rewrite <-IHALLOC; swap 1 2.
    + unfold Mem.alloc in *.
      injection H as <- <-.
      unfold Mem.valid_block in *.
      simpl.
      apply Plt_trans_succ.
      auto.
    + clear IHALLOC.
      unfold Mem.alloc in *.
      injection H as <- <- . simpl.
      f_equal.
      rewrite PMap.gso. auto.
      unfold Mem.valid_block in *.
      auto with *.

  - (* return: free_list *)
    revert FREE NW V; clear.
    generalize (blocks_of_env ge ve); intros l.
    revert m m'; induction l as [| [[b' o] o'] l IHl]; intros m m'' E NW V.
    + simpl. injection E as <- . easy.
    + simpl in E.
      destruct (Mem.free m b' o o') as [m' |] eqn:F.
      2:discriminate.
      specialize (IHl _ _ E).
      unfold Mem.free in *.
      if_tac in F. 2:discriminate.
      injection F as <- .
      rewrite <-IHl. easy.
      * unfold Mem.perm in *.
        unfold Mem.unchecked_free.
        simpl.
        rewrite PMap.gsspec.
        if_tac; [ | easy ].
        subst.
        unfold Mem.range_perm in *.
        destruct (zle o ofs); auto.
        destruct (zlt ofs o'); simpl; auto.
      * unfold Mem.unchecked_free, Mem.valid_block; simpl. auto.
Qed.


(******************************************************************************)
(* PipeCheck: Specifying and Verifying Microarchitectural                     *)
(* Enforcement of Memory Consistency Models                                   *)
(*                                                                            *)
(* Copyright (c) 2014 Daniel Lustig, Princeton University                     *)
(* All rights reserved.                                                       *)
(*                                                                            *)
(* This library is free software; you can redistribute it and/or              *)
(* modify it under the terms of the GNU Lesser General Public                 *)
(* License as published by the Free Software Foundation; either               *)
(* version 2.1 of the License, or (at your option) any later version.         *)
(*                                                                            *)
(* This library is distributed in the hope that it will be useful,            *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU          *)
(* Lesser General Public License for more details.                            *)
(*                                                                            *)
(* You should have received a copy of the GNU Lesser General Public           *)
(* License along with this library; if not, write to the Free Software        *)
(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  *)
(* USA                                                                        *)
(******************************************************************************)

Require Import Ensembles.
Require Import Arith.
Require Import Bool.
Require Import List.
Import ListNotations.
Require Import wmm.
Require Import util2.
Require Import dot.
Require Import topsort.
Require Import stages.

(** * Traditional Five-Stage RISC Pipeline *)

(** ** Local Reorderings at different stages *)

(** [FIFO]: any ordering guaranteed at the input is also guaranteed at the
  output.  This is the common case. *)
Definition FIFO : LocalReordering :=
  fun _ ordering => ordering.

(** [NoOrderGuarantees]: Operations can leave the stage in any order; nothing
  is guaranteed. *)
Definition NoOrderGuarantees : LocalReordering :=
  fun _ _ => [].

(** ** Special Edge Maps *)

(** In most cases, we don't need to add any special edges *)
Definition NoSpecialEdges : SpecialEdgeMap :=
  fun _ _ _ => [].

(** The store buffer only allows one outstanding unacknowledged store at a
  time. *)

Fixpoint StoreBufferSpecialEdges
  (c n : nat)
  (e_before : list Event)
  (e : Event)
  (e_after : list Event)
  : GlobalGraph :=
  match e_after with
  | h::t =>
    match dirn h with
    | R => StoreBufferSpecialEdges c n e_before e t
    | W => [((6 * n, eiid e), (5 + 6 * c, eiid h), "StoreBuffer")]
    end
  | _ => []
  end.

(** * Pipeline Definition *)

(** ** Pipeline Stages *)

(** Each pipeline stage is defined by a name, a number, a [LocalReordering],
  and a function adding any special edges (in this case, only at the store
  buffer). *)

Definition RISC_PipelineStages n c := [
  mkStage "Fetch"       FIFO              NoSpecialEdges;
  mkStage "Decode"      FIFO              NoSpecialEdges;
  mkStage "Execute"     FIFO              NoSpecialEdges;
  mkStage "Memory"      FIFO              NoSpecialEdges;
  mkStage "Writeback"   FIFO              NoSpecialEdges;
  mkStage "StoreBuffer" FIFO              (StoreBufferSpecialEdges c n)
].

Definition RISC_SharedStages := [
  mkStage "MainMemory"  NoOrderGuarantees NoSpecialEdges;
  mkStage "Retire"      FIFO              NoSpecialEdges
].

Fixpoint RISC_AllStages (n : nat) :=
  fold_left (app (A:=_)) (map (RISC_PipelineStages n) [0 ... n-1]) []
  ++ RISC_SharedStages.

Definition StagesOfCore
  (c : nat)
  (l : list nat)
  : list nat :=
  map (fun x => x + 6 * c) l.

(** ** Pipeline Paths *)

Definition RISC_PathOptions
  (n : nat)
  (e : Event)
  : PathOptions :=
  let c := proc (iiid e) in
  match dirn e with
  | R => [
    mkPathOption (String.append "Read" (stringOfNat (loc e))) e
      (StagesOfCore c [0 ... 4])
      [mkPerformStages (3 + 6 * c) [0 ... n-1] [0 ... n-1] None true]
      NoSpecialEdges;
    mkPathOption (String.append "STBFwd" (stringOfNat (loc e))) e
      (StagesOfCore c [0 ... 4])
      [mkPerformStages (3 + 6 * c) [0 ... n-1] [c] None false]
      NoSpecialEdges
    ]
  | W => [
    mkPathOption (String.append "Write" (stringOfNat (loc e))) e
      (StagesOfCore c [0 ... 5] ++ StagesOfCore n [0; 1])
      [mkPerformStages (3 + 6 * c) [c] [c] None false;
       mkPerformStages (6 * n) [0 ... n-1] [0 ... n-1] None true]
      NoSpecialEdges
    ]
  end.

(** ** Pipeline Definition *)

Definition RISC_Pipeline (n : nat) :=
  mkPipeline
    "RISC"
    (RISC_AllStages n)
    (RISC_PathOptions n).