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.
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.CommonPromising.
Require Import PromisingArch.promising.StateExecFacts.
Require Import PromisingArch.axiomatic.Axiomatic.
Require Import PromisingArch.equiv.SimLocal.

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))) (fl: 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 _ => None] [fun _ => Time.bot] [fun _ => Time.bot]
| sim_trace_step
    e ae tr eu1 eu2 atr aeu1 aeu2 rl r1 r2 wl w1 w2 fl f1 f2 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)
    (F: f2 = match e with
               | Event.flushopt vloc =>
                 (fun eid => if Nat.eqb eid (ALocal.next_eid aeu1.(AExecUnit.local))
                            then Some (vloc.(ValA.val),
                                       (eu2.(ExecUnit.local).(Local.vpa) vloc.(ValA.val)).(View.ts))
                            else f1 eid)
               | _ => f1
               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)
                 | Event.flushopt vloc =>
                   (fun eid => if Nat.eqb eid (ALocal.next_eid aeu1.(AExecUnit.local))
                               then (eu2.(ExecUnit.local).(Local.vpa) vloc.(ValA.val)).(View.ts)
                               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)
                   | Event.flushopt vloc =>
                     (fun eid => if Nat.eqb eid (ALocal.next_eid aeu1.(AExecUnit.local))
                                 then (eu2.(ExecUnit.local).(Local.vpa) vloc.(ValA.val)).(View.ts)
                                 else vext1 eid)
                   | _ => vext1
                   end)
    (TRACE: sim_trace p mem tid (eu1::tr) (aeu1::atr) (w1::wl) (r1::rl) (f1::fl) (cov1::covl) (vext1::vextl)):
    sim_trace p mem tid (eu2::eu1::tr) (aeu2::aeu1::atr) (w2::w1::wl) (r2::r1::rl) (f2::f1::fl) (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))))
            (fs: 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.Forall7 (sim_trace p mem) trs atrs ws rs fs covs vexts.

Lemma sim_trace_last
      p mem tid tr atr wl rl fl covl vextl
      (SIM: sim_trace p mem tid tr atr wl rl fl covl vextl):
  exists eu tr' aeu atr' w wl' r rl' f fl' cov covl' vext vextl',
    <<HDTR: tr = eu :: tr'>> /\
    <<HDATR: atr = aeu :: atr'>> /\
    <<HDWL: wl = w :: wl'>> /\
    <<HDRL: rl = r :: rl'>> /\
    <<HDFL: fl = f :: fl'>> /\
    <<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 fl covl vextl
      (SIM: sim_trace p mem tid tr atr wl rl fl 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_FL: List.length fl = 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 fl covl vextl
      eu tr'
      (SIM: sim_trace p mem tid tr atr wl rl fl 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 fs covs vexts
      m
      ts loc val tid
      (STEP: Machine.pf_exec p m)
      (SIM: sim_traces p m.(Machine.mem) trs atrs ws rs fs 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 7; 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 7; 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 7; 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 8; 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 9. ss.
    + econs; ss.
    + ss.
    + ss.
    + inv LOCAL1; [econs 1|econs 2]; eauto.
  - inv STEP.
    eexists _, (AExecUnit.mk (State.mk _ _) _). splits; ss.
    + econs 10; ss.
    + econs 7; ss.
    + econs; ss.
      eauto using sim_rmap_weak_expr.
    + econs; ss.
    + inv LOCAL1; [econs 1|econs 2]; eauto; ss.
      rewrite List.nth_error_app1; eauto.
      eapply List.nth_error_Some. ii. congr.
Qed.

Lemma promising_pf_sim_traces
      p m
      (STEP: Machine.pf_exec p m):
  exists trs atrs ws rs fs covs vexts ex (PRE: Valid.pre_ex p ex),
    <<SIM: sim_traces p m.(Machine.mem) trs atrs ws rs fs 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 fs covs vexts ex (PRE: Valid.pre_ex p ex),
    <<SIM: sim_traces p (Machine.mem m2') trs atrs ws rs fs 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 _ _ => [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 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 REL7; eauto. s.
    unfold Machine.init_with_promises in FIND0. ss.
    rewrite IdMap.mapi_spec, STMT in *. inv FIND0.
    apply sim_state_weak_init.
  }
  { inv REL7; 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 _ fs).
  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.
Grab Existential Variables.
all: ss.
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 <- H7 in X. inv X. econs. etrans; eauto.
}
4: { 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.
}
4: { 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.
}
4: { 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.
}
4: { 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.
}
5: { ii. rewrite IdMap.mapi_spec. destruct (IdMap.find id p); ss. econs. refl. }
4: { unfold IdMap.map. rewrite IdMap.mapi_mapi. f_equal. }
1: { apply bot. (* it's ex's co. *) }
1: { apply bot. (* it's ex's rf. *) }
1: { apply bot. (* it's ex's pf. *) }
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))
          (f: 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'));
  FPROP1:
    forall eid loc1
      (GET: List.nth_error aeu.(AExecUnit.local).(ALocal.labels) eid = Some (Label.flushopt loc1)),
    exists perv,
      <<FEID: f eid = Some (loc1, perv)>> /\
      <<CL_REL:
        forall loc2 (CL: Loc.cl loc1 loc2),
          exists ts tid' val,
          ts = Memory.latest_ts loc2 perv mem /\
          <<FLUSH_TS_SPEC:
              __guard__ ((ts = Time.bot /\ val = Val.default) \/
              Memory.get_msg ts mem = Some (Msg.mk loc2 val tid'))>>>>;
  FPROP2:
    forall eid loc1 perv
           (GET: f eid = Some (loc1, perv)),
    <<COV_EQ: cov eid = perv>> /\
    <<VEXT_EQ: vext eid = perv>> /\
    List.nth_error aeu.(AExecUnit.local).(ALocal.labels) eid = Some (Label.flushopt loc1) /\
    <<CL_REL:
        forall loc2 (CL: Loc.cl loc1 loc2),
          exists ts tid' val,
          ts = Memory.latest_ts loc2 perv mem /\
          <<FLUSH_TS_SPEC:
              __guard__ ((ts = Time.bot /\ val = Val.default) \/
              Memory.get_msg ts mem = Some (Msg.mk loc2 val tid'))>>>>;
  COVPROP:
    forall eid (COV: cov eid > 0),
      AExecUnit.label_is aeu.(AExecUnit.local).(ALocal.labels) Label.is_access_persist eid;
  VEXTPROP:
    forall eid (VEXT: vext eid > 0),
      AExecUnit.label_is aeu.(AExecUnit.local).(ALocal.labels) Label.is_access_persist 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'
      fl f fl'
      covl cov covl'
      vextl vext vextl'
      (SIM: sim_trace p mem tid tr atr wl rl fl covl vextl)
      (EU: tr = eu :: tr')
      (AEU: atr = aeu :: atr')
      (RL: rl = r :: rl')
      (WL: wl = w :: wl')
      (FL: fl = f :: fl')
      (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'
      fl f fl'
      covl cov covl'
      vextl vext vextl'
      (SIM: sim_trace p mem tid tr atr wl rl fl covl vextl)
      (EU: tr = eu :: tr')
      (AEU: atr = aeu :: atr')
      (RL: rl = r :: rl')
      (WL: wl = w :: wl')
      (FL: fl = f :: fl')
      (COV: covl = cov :: covl')
      (VEXT: vextl = vext :: vextl'):
  sim_th p mem tid eu aeu w r f cov vext.
Proof.
  revert f fl' r rl' w wl' eu tr' aeu atr' cov covl' vext vextl' FL 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 Promises.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.
    - 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.
        * econs; esplits; ss.
        * destruct ts; ss.
          rewrite Promises.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 Promises.promises_from_mem_lookup; eauto. ss. subst. ss.
        * econs; try rewrite Loc.cl_refl; ss. i. apply bot_spec.
    - 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.
  i. rename x into 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; cycle 1.
    { i. unfold ALocal.next_eid in *. s. i. des_ifs. }
    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.
    - i. des. exploit IH.(FPROP1); eauto.
      apply nth_error_snoc_inv in GET. des; ss.
    - i. exploit IH.(FPROP2); eauto. s. i. des. des_ifs; cycle 1.
      { esplits; eauto. eapply nth_error_app_mon in x0. eauto. }
      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.
    - 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.
    - i. des. exploit IH.(FPROP1); eauto.
      apply nth_error_snoc_inv in GET. des; ss.
    - i. exploit IH.(FPROP2); eauto. s. i. des. des_ifs; cycle 1.
      { esplits; eauto. eapply nth_error_app_mon in x0. eauto. }
      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.
    - 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. exploit IH.(FPROP1); eauto.
        apply nth_error_snoc_inv in GET. des; eauto. congr.
      - i. exploit IH.(FPROP2); 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. exploit IH.(FPROP1); eauto.
        apply nth_error_snoc_inv in GET. des; eauto. congr.
      - i. exploit IH.(FPROP2); 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.
    }
    { (* dsb *)
      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. exploit IH.(FPROP1); eauto.
        apply nth_error_snoc_inv in GET. des; eauto. congr.
      - i. exploit IH.(FPROP2); 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. exploit IH.(FPROP1); eauto.
      apply nth_error_snoc_inv in GET. des; eauto. congr.
    - i. exploit IH.(FPROP2); 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.
  }
  { (* flushopt *)
    inv LOCAL; ss.
    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. 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. 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.
      + 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.
      + eapply nth_error_app_mon. eauto.
    - i. des. apply nth_error_snoc_inv in GET. des.
      + exploit IH.(FPROP1); 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. }
        ss. eqvtac. inv VLOC. inv VAL.
        esplits; eauto. i.
        exploit Memory.latest_ts_spec. i. des.
        exploit Memory.read_get_msg; eauto. i. des; esplits; eauto; [left|right]; eauto.
    - i. des_ifs.
      + split; ss.
        apply Nat.eqb_eq in Heq. subst.
        inv VLOC. inv VAL. ss.
        esplits; cycle 1.
        { rewrite List.nth_error_app2, Nat.sub_diag; [|refl]; ss; eauto with axm. }
        all: eauto with axm.
        i.
        exploit Memory.latest_ts_spec. i. des.
        exploit Memory.read_get_msg; eauto. i. des; esplits; ss; [left | right]; eauto.
      + exploit IH.(FPROP2); eauto. s. i. des; esplits; eauto with axm.
        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.
    - 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.
      + subst. repeat condtac; ss.
  }
  Grab Existential Variables.
  all: auto. (* tid *)
Qed.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section RefineRel.

  Record relate_RData (hadt: RData) (ladt: RData) :=
      mkrelate_RData {
          id_priv: priv ladt = priv hadt;
          id_share: share ladt = share hadt;
          hrepl: repl hadt = replay 2;
          lrepl: repl ladt = replay 1;
          valid_ho: ValidOracle 2 (oracle hadt);
          valid_lo: ValidOracle 1 (oracle ladt);
          rel_oracle: forall st st' l l',
              let lh := oracle hadt l in
              let lo := oracle ladt l' in
              st = st' -> repl ladt lo st = repl hadt lh st'
        }.

End RefineRel.

Ltac rewrite_oracle_rel R H :=
  match type of H with
  | repl ?habd (oracle ?habd ?l) ?st = _ =>
    match goal with
    | [ |- context[repl ?labd (oracle ?labd ?l') st]] =>
      rewrite (R st st l l'); [rewrite H|reflexivity]
    end
  end.


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program 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 General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From bpf.comm Require Import State Monad.
From bpf.monadicmodel Require Import rBPFInterpreter.
From Coq Require Import List Lia.
From compcert Require Import Integers Values Clight Memory.
Import ListNotations.
Require Import ZArith.

From bpf.clightlogic Require Import Clightlogic CorrectRel CommonLemma.

From bpf.clight Require Import interpreter.

From bpf.simulation Require Import MatchState InterpreterRel.

(**
unsigned int get_addr_ofs(unsigned long long x, int ofs)
{
  return (unsigned int) (x + (unsigned long long) ofs);
}

Print get_addr_ofs.
get_addr_ofs =
fun (x : val64_t) (ofs : sint32_t) =>
returnM (val_intuoflongu (Val.addl x (Val.longofintu (sint32_to_vint ofs))))
     : val64_t -> sint32_t -> M valu32_t

*)

Section Get_addr_ofs.
  Context {S: special_blocks}.

  (** The program contains our function of interest [fn] *)
  Definition p : Clight.program := prog.

  (* [Args,Res] provides the mapping between the Coq and the C types *)
  (* Definition Args : list CompilableType := [stateCompilableType].*)
  Definition args : list Type := [(val:Type); (int:Type)].
  Definition res : Type := (val:Type).

  (* [f] is a Coq Monadic function with the right type *)
  Definition f : arrow_type args (M State.state res) := get_addr_ofs.

  (* [fn] is the Cligth function which has the same behaviour as [f] *)
  Definition fn: Clight.function := f_get_addr_ofs.

  (* [match_arg] relates the Coq arguments and the C arguments *)
  Definition match_arg_list : DList.t (fun x => x -> Inv _) args :=
    (dcons (stateless val64_correct)
       (dcons (stateless sint32_correct)
                    (DList.DNil _))).

  (* [match_res] relates the Coq result and the C result *)
  Definition match_res : res -> Inv State.state := stateless val32_correct.

  Instance correct_function_get_addr_ofs : forall a, correct_function _ p args res f fn ModNothing true match_state match_arg_list match_res a.
  Proof.
    correct_function_from_body args.
    correct_body.
    (** how to use correct_* *)
    unfold INV.
    unfold f.
    repeat intro.
    get_invariant _x.
    get_invariant _ofs.

    unfold stateless, eval_inv, val64_correct in c1.
    unfold stateless, eval_inv, sint32_correct in c2.
    destruct c1 as (Hc_eq & (vi & Hvi_eq)).
    destruct c2 as (c2 & c2_range).
    subst c v v0.

    (**according to the type of eval_pc:
unsigned int get_addr_ofs(unsigned long long x, int ofs)
{
  return (unsigned int) (x + (unsigned long long) ofs);
}
       1. return value should be  x+y
       2. the memory is same
      *)
    eexists. exists m, Events.E0.

    split_and; unfold step2;auto.
    -
      repeat forward_star.
    - simpl. unfold val32_correct. eauto.
    - simpl.
      constructor.
      reflexivity.
    - apply unmodifies_effect_refl.
  Qed.

End Get_addr_ofs.

Existing Instance correct_function_get_addr_ofs.


Require Export CertiGraph.msl_ext.seplog.
Require Export CertiGraph.msl_ext.log_normalize.
Require Export CertiGraph.msl_ext.alg_seplog.
Require Export CertiGraph.msl_ext.iter_sepcon.
Require Export CertiGraph.msl_ext.ramification_lemmas.
Require Export CertiGraph.veric_ext.seplog.
Require Export VST.veric.address_conflict.
Require Import VST.veric.SeparationLogic.

Instance PSLveric: PreciseSepLog mpred := algPreciseSepLog compcert_rmaps.RML.R.rmap.
Instance OSLveric: OverlapSepLog mpred := algOverlapSepLog compcert_rmaps.RML.R.rmap.
Instance DSLveric: DisjointedSepLog mpred := algDisjointedSepLog compcert_rmaps.RML.R.rmap.
Instance COSLveric: CorableOverlapSepLog mpred := algCorableOverlapSepLog compcert_rmaps.RML.R.rmap.

Instance LiftPreciseSepLog' T {ND: NatDed T}{SL: SepLog T}{PSL: PreciseSepLog T} :
           PreciseSepLog (LiftEnviron T) := LiftPreciseSepLog _ _.
Instance LiftOverlapSepLog' T {ND: NatDed T}{SL: SepLog T}{PSL: PreciseSepLog T}{OSL: OverlapSepLog T} :
           OverlapSepLog (LiftEnviron T) := LiftOverlapSepLog _ _.
Instance LiftDisjointedSepLog' T {ND: NatDed T}{SL: SepLog T}{PSL: PreciseSepLog T}{OSL: OverlapSepLog T}{DSL: DisjointedSepLog T} :
           DisjointedSepLog (LiftEnviron T) := LiftDisjointedSepLog _ _.

Global Opaque PSLveric OSLveric DSLveric COSLveric.

Local Open Scope logic.

Lemma exp_mapsto_precise: forall sh t p, precise (EX v: val, mapsto sh t p v).
Proof. exact exp_mapsto_precise. Qed.

Lemma disj_mapsto_: forall {cs: composite_env} sh t1 t2 p1 p2,
  ~ pointer_range_overlap p1 (sizeof t1) p2 (sizeof t2) ->
  disjointed (EX v1: val, mapsto sh t1 p1 v1) (EX v2: val, mapsto sh t2 p2 v2).
Proof. exact @disj_mapsto_. Qed.

Lemma memory_block_precise: forall sh p n, precise (memory_block sh n p).
Proof. exact memory_block_precise. Qed.

Lemma disj_memory_block: forall sh p1 n1 p2 n2, ~ pointer_range_overlap p1 n1 p2 n2 -> disjointed (memory_block sh n1 p1) (memory_block sh n2 p2).
Proof. exact disj_memory_block. Qed.


Require Import VST.msl.Coqlib2.
Require Import VST.msl.sepalg.
Require Import VST.msl.shares.
Require Import VST.msl.pshares.
Require Import VST.veric.coqlib4.
Require Import VST.veric.shares.
Require Import VST.veric.juicy_mem.
Require Import VST.veric.juicy_mem_ops.
Require Import VST.concurrency.permjoin_def.
Import Memtype.

  Lemma perm_of_glb_not_Freeable: forall sh,
      ~ perm_of_sh (Share.glb Share.Rsh sh) = Some Freeable.
  Proof.
   intros.
   unfold perm_of_sh.
   if_tac.
   rewrite if_false by apply glb_Rsh_not_top.
   congruence.
   if_tac. congruence.
   if_tac. congruence. congruence.
  Qed.

Lemma join_bot_bot_eq sh :
  sepalg.join Share.bot Share.bot sh ->
  sh = Share.bot.
Proof.
  intros j.
  apply (join_eq j  (z' := Share.bot) (join_bot_eq Share.bot)).
Qed.

Lemma join_to_bot_l {sh1 sh2} :
  sepalg.join sh1 sh2 Share.bot ->
  sh1 = Share.bot.
Proof.
  intros [H H'].
  apply shares.lub_bot_e in H'.
  apply H'.
Qed.

Lemma join_to_bot_r {sh1 sh2} :
  sepalg.join sh1 sh2 Share.bot ->
  sh2 = Share.bot.
Proof.
  intros [H H'].
  apply shares.lub_bot_e in H'.
  apply H'.
Qed.

Lemma join_top_l {sh2 sh3} :
  sepalg.join Share.top sh2 sh3 ->
  sh2 = Share.bot.
Proof.
  intros [H H'].
  rewrite Share.glb_commute in H.
  rewrite Share.glb_top in H.
  auto.
Qed.

Lemma join_top {sh2 sh3} :
  sepalg.join Share.top sh2 sh3 ->
  sh3 = Share.top.
Proof.
  intros [H H'].
  rewrite Share.lub_commute in H'.
  rewrite Share.lub_top in H'.
  auto.
Qed.

Lemma join_pfullshare {sh2 sh3 : pshare} : ~sepalg.join pfullshare sh2 sh3.
Proof.
  intros [H H'].
  unfold pfullshare in *.
  unfold fullshare in *.
  simpl in *.
  rewrite Share.glb_commute in H.
  rewrite Share.glb_top in H.
  destruct sh2.
  simpl in *.
  subst.
  destruct (shares.not_nonunit_bot Share.bot).
  tauto.
Qed.

Lemma join_with_bot_r sh1 sh2 : join sh1 Share.bot sh2 -> sh1 = sh2.
Proof.
  intros [H H'].
  rewrite Share.lub_bot in H'.
  auto.
Qed.

Lemma join_with_bot_l sh1 sh2 : join Share.bot sh1 sh2 -> sh1 = sh2.
  intros [H H'].
  rewrite Share.lub_commute in H'.
  rewrite Share.lub_bot in H'.
  auto.
Qed.

Lemma join_top_r sh1 sh3 : join sh1 Share.top sh3 -> sh1 = Share.bot.
Proof.
  intros [H H'].
  rewrite Share.glb_top in H.
  auto.
Qed.

Lemma join_pshare_top_l (p1 p2 p3 : pshare) :
  @join pshare _ p1 p2 p3 ->
  pshare_sh p1 <> Share.top.
Proof.
  destruct p1; simpl in *.
  intros [H H'] ->.
  simpl in *.
  destruct p2 as [x n0]; simpl in *.
  rewrite Share.glb_commute in H.
  rewrite Share.glb_top in H.
  subst x.
  simpl in *.
  subst.
  destruct (shares.not_nonunit_bot Share.bot).
  tauto.
Qed.

Lemma join_pshare_top_r (p1 p2 p3 : pshare) :
  @join pshare _ p1 p2 p3 ->
  pshare_sh p2 <> Share.top.
Proof.
  intros j.
  apply join_comm in j.
  apply join_pshare_top_l in j; auto.
Qed.

(*Got this ltac from permission.v maybe should factor*)
Ltac if_simpl:=
  repeat match goal with
         | [ H: ?X = true |- context[if ?X then _ else _] ] => rewrite H; simpl
         | [ H: ?X = false |- context[if ?X then _ else _] ] => rewrite H; simpl
         | [ H: ?X = left _ |- context[match ?X with left _ => _ | right _ => _ end] ]=>
           rewrite H; simpl
         | [ H: ?X = right _ |- context[match ?X with left _ => _ | right _ => _ end] ]=>
           rewrite H; simpl
         end.
Lemma top_aint_bot:
  eq_dec Share.top Share.bot = right Share.nontrivial.
  destruct (eq_dec Share.top Share.bot).
  - exfalso; apply Share.nontrivial; auto.
  - f_equal. apply proof_irr.
Qed.

Ltac common_contradictions:=
  match goal with
  | [H: Share.glb _ _ = Share.top |- _ ] =>
    exfalso;
    eapply shares.glb_Rsh_not_top; eassumption
    | [ H: Share.bot = Share.top |- _ ] => exfalso; apply Share.nontrivial; symmetry; assumption
    | [ H: Share.top = Share.bot |- _ ] => exfalso; apply Share.nontrivial; assumption
    | [ H: ~ shares.readable_share Share.top |- _ ] => pose proof shares.readable_share_top; contradiction
    | [ H: ~ shares.writable_share Share.top |- _ ] => pose proof shares.writable_share_top; contradiction
    | [ H: shares.readable_share Share.bot |- _ ] => pose proof shares.bot_unreadable; contradiction
    | [ H: shares.writable_share Share.bot |- _ ] => apply shares.writable_readable in H; pose proof shares.bot_unreadable; contradiction
    | [ H: shares.writable_share ?sh, H0: ~ shares.readable_share ?sh   |- _ ] =>
      exfalso; apply H0; eapply shares.writable_readable; assumption
    | _ => contradiction
    end.

  Ltac join_share_contradictions_oneside:=
    match goal with
    | [ H: @join Share.t _ Share.top _ _ |- _ ] =>
      pose proof (join_top_l H); first [common_contradictions | subst]
    | [ H: @join Share.t _ Share.bot _ _ |- _ ] =>
      pose proof (join_with_bot_l _ _ H); first [common_contradictions | subst]
    | [ H: @join Share.t _ _ _ Share.bot |- _ ] =>
      pose proof (join_to_bot_l H); pose proof (join_to_bot_r H);
      first [common_contradictions | subst]
    | [ H1: ~ shares.readable_share ?sh1,
        H2: ~ shares.readable_share ?sh2,
            H: join ?sh1 ?sh2 _ |- _ ] =>
      pose proof (shares.join_unreadable_shares H H1 H2);
      first [common_contradictions | subst]
    | [ H1: ~ shares.writable_share ?sh1,
        H2: ~ shares.readable_share ?sh2,
            H: join ?sh1 ?sh2 _ |- _ ] =>
      pose proof (join_readable_unreadable _ _ _ H H1 H2);
      first [common_contradictions | subst]
    | [ H1: shares.writable_share ?sh1,
        H2: shares.writable_share ?sh2,
            H: join ?sh1 ?sh2 _ |- _ ] =>
      exfalso; eapply shares.join_writable_readable;
      try eapply shares.writable_readable; eassumption
    | [ H1: shares.writable_share ?sh1,
            H: join ?sh1 _ _ |- _ ] =>
      pose proof (shares.join_writable1 H H1);
      first [common_contradictions | subst]
    | [ H1: shares.readable_share ?sh1,
            H: join ?sh1 ?sh2 _ |- _ ] =>
      pose proof (shares.join_readable1 H H1);
      common_contradictions
    end.
  Ltac join_share_contradictions:=
    try join_share_contradictions_oneside;
    match goal with
    | [ H: @join Share.t _ _ _ _ |- _ ] =>
      apply join_comm in H; join_share_contradictions_oneside
    end; try contradiction.

Lemma join_permjoin r1 r2 r3 :
  join r1 r2 r3 ->
  permjoin (perm_of_res r1) (perm_of_res r2) (perm_of_res r3).
Proof.
  intros.
  inversion H; subst;
    try (destruct k);
    try constructor;
  functional induction (perm_of_sh sh1) using perm_of_sh_ind;
    simpl; if_simpl;
    repeat match goal with
           | [  |- context [eq_dec Share.top Share.bot] ] => rewrite top_aint_bot
           end;
  functional induction (perm_of_sh sh2) using perm_of_sh_ind;
    simpl; if_simpl;
    repeat match goal with
           | [  |- context [eq_dec Share.top Share.bot] ] => rewrite top_aint_bot
           end;
  functional induction (perm_of_sh sh3) using perm_of_sh_ind;
  simpl; if_simpl;
    repeat match goal with
           | [  |- context [eq_dec Share.top Share.bot] ] => rewrite top_aint_bot
           end;
    try (do 2 join_share_contradictions);
    unfold perm_of_sh; if_simpl;
    try econstructor.
    contradiction (join_readable_unreadable RJ _x _x2); apply writable_share_top.
    contradiction (join_readable_unreadable RJ _x _x2).
    contradiction (join_readable_unreadable (join_comm RJ) _x2 _x0); apply writable_share_top.
    contradiction (join_readable_unreadable (join_comm RJ) _x2 _x0).
Qed.

Lemma join_permjoin_lock
  : forall r1 r2 r3 ,
    sepalg.join r1 r2 r3 ->
    permjoin_def.permjoin
      (perm_of_res_lock r1)
      (perm_of_res_lock r2)
      (perm_of_res_lock r3).
Proof.
 intros.
 inversion H; clear H; subst; simpl; try constructor;
 repeat match goal with
 | [ H: join ?sh _ _ , H1: shares.readable_share ?sh  |- _ ] =>
   apply readable_glb in H1
 | [ H: join ?sh _ _ , H1: ~ shares.readable_share ?sh  |- _ ] =>
   apply unreadable_glb in H1
 | [ H: join _ ?sh _ , H1: shares.readable_share ?sh  |- _ ] =>
   apply readable_glb in H1
 | [ H: join _ ?sh _ , H1: ~ shares.readable_share ?sh  |- _ ] =>
   apply unreadable_glb in H1
 | [ H: join _ _ ?sh , H1: shares.readable_share ?sh  |- _ ] =>
   apply readable_glb in H1
 | [ H: join _ _ ?sh , H1: ~ shares.readable_share ?sh  |- _ ] =>
   apply unreadable_glb in H1
 end;
 match goal with
   | [ H: join _ _ _ |- _ ] => eapply compcert_rmaps.join_glb_Rsh in H
 end;
   try (destruct k);
    try constructor;
  functional induction (perm_of_sh  (Share.glb Share.Rsh sh1)) using perm_of_sh_ind;
    simpl; if_simpl;
  functional induction (perm_of_sh  (Share.glb Share.Rsh sh2)) using perm_of_sh_ind;
    simpl; if_simpl;
  functional induction (perm_of_sh  (Share.glb Share.Rsh sh3)) using perm_of_sh_ind;
  simpl; if_simpl;
    repeat match goal with
           | [  |- context [eq_dec Share.top Share.bot] ] => rewrite top_aint_bot
           end;
    try (unfold perm_of_sh; if_simpl; econstructor);
    try (do 2 join_share_contradictions);
  try eapply permjoin_None_l;
  try eapply permjoin_None_r;
  forget (Share.glb Share.Rsh sh1) as s1;
  forget (Share.glb Share.Rsh sh2) as s2;
  forget (Share.glb Share.Rsh sh3) as s3;
  clear e e0 e1 e2 e3 e4 e5; subst;
  try contradiction (join_readable_unreadable RJ _x _x2).
  apply join_unit1_e in RJ; auto; subst; contradiction.
  contradiction (join_readable_unreadable (join_comm RJ) _x2 _x0).
  apply join_unit1_e in RJ; auto; subst; contradiction.
  contradiction (join_readable_unreadable (join_comm RJ) _x2 _x0).
Qed.


Require Import Algebra.Utils Algebra.Monad SetoidUtils Algebra.SetoidCat.ListUtils Algebra.SetoidCat Algebra.Monad.StoreHeap Algebra.Monad.ContT Algebra.NearSemiRing Algebra.Monoid Tactics Algebra.FoldableFunctor Algebra.SetoidCat.PairUtils Algebra.Functor Algebra.Alternative Algebra.SetoidCat.MaybeUtils Algebra.Monad.Maybe Algebra.Applicative Algebra.SetoidCat.BoolUtils Algebra.SetoidCat.UnitUtils Algebra.Monoid.BoolUtils Algebra.Monoid.Alternative Algebra.Alternative.List Algebra.Functor.List Algebra.FoldableFunctor.List Algebra.Monad.Utils QAL.Command QAL.Definitions QAL.AbstractHeap QAL.AbstractStore.

Require Import Coq.Lists.List PeanoNat RelationClasses Relation_Definitions Morphisms Coq.Program.Basics SetoidClass.

Section Aggregator.

  Inductive qalAggregator :=
  | cExists : qalAggregator
  | cNot : qalAggregator
  | cReturn : list var -> qalAggregator
  .

  Program Instance qalAggregatorS : Setoid qalAggregator.

End Aggregator.

Module QALAggregator (PT : PredType) (VT : ValType)
       (S : AbstractStore VT) (H : AbstractHeap PT VT) : Aggregator PT VT S H.
  Open Scope type_scope.
  Module TS := Types PT VT S H.
  Module CA := CommandAux PT VT S H.
  Import VT S H TS CA.

  Definition aggregator := qalAggregator.
  Instance aggregatorS : Setoid aggregator := qalAggregatorS.

  Fixpoint _freeVarsAggregator (agg : aggregator) (fv : FVarSet.t) :=
    match agg with
      | cNot  => fv
      | cExists  => fv
      | cReturn _ => fv
    end
  .

  Instance _freeVarsAggregator_Proper : Proper (equiv ==> equiv ==> equiv) _freeVarsAggregator.
  Proof.
    unfold Proper, respectful. intros. simpl in H. rewrite H. destruct y.
    * simpl. auto.
    * simpl. auto.
    * simpl. auto.
  Qed.

  Definition freeVarsAggregator := injF2 _freeVarsAggregator _.

  Section NegationGeneric.
    Context
      (a : H.l S.t _).
    Definition negationGeneric : state unit := stopNotNull @ a.
  End NegationGeneric.
  Instance negationGeneric_Proper : Proper (equiv ==> equiv) negationGeneric.
  Proof.
    solve_properS negationGeneric.
  Qed.

  Section ExistentialQuantificationGeneric.
    Context
      (a : H.l S.t _).
    Definition existentialQuantificationGeneric : state unit :=
      stopNull @ a.
  End ExistentialQuantificationGeneric.
  Instance existentialQuantificationGeneric_Proper : Proper (equiv ==> equiv) existentialQuantificationGeneric.
  Proof.
    solve_properS existentialQuantificationGeneric.
  Qed.

  Section ReturnGeneric.
    Context
      (vl : list var)
      (a : H.l S.t _).
    Definition _narrowStore (vl : list var) (s : S.t) : S.t :=
      fold_right (fun v s2 => match s [ v ]s with
                               | None => s2
                               | Some val => S.update @ v @ val @ s2
                            end) S.empty vl.

    Instance _narrowStore_Proper : Proper (equiv ==> equiv ==> equiv) _narrowStore.
    Proof.
      unfold Proper, respectful. intros. generalize H  x0 y0 H0 . clear H x0 y0 H0.
      apply list_ind_2 with (l1:=x) (l2:=y).
      - intros. simpl. reflexivity.
      - intros. inversion H0.
      - intros. inversion H0.
      - intros. inversion H0.
        simpl. matchequiv. evalproper. simpl in H8. rewritesr. apply H.  auto.  auto. apply H. auto. auto.
    Qed.

    Definition narrowStore := injF2 _narrowStore _.

    Definition returnGeneric : state unit :=
      branchStore @ (narrowStore @ vl <$> a).
  End ReturnGeneric.
  Instance returnGeneric_Proper : Proper (equiv ==> equiv ==> equiv) returnGeneric.
  Proof.
    solve_properS returnGeneric.
  Qed.

  Fixpoint _interpretAggregator (agg : aggregator) (a : H.l S.t _)  : state unit :=
    match agg with
      | cNot =>
        negationGeneric a
      | cExists =>
        existentialQuantificationGeneric a
      | cReturn vl => returnGeneric vl a
    end
  .

  Instance _interpretAggregator_Proper : Proper (equiv ==> equiv ==> equiv) _interpretAggregator.
  Proof.
    unfold Proper, respectful. intros. simpl in H. rewrite H. destruct y.
    * simpl. arrequiv.
    * simpl. arrequiv.
    * simpl. arrequiv.
  Qed.

  Definition interpretAggregator := injF2 _interpretAggregator _.

End QALAggregator.


(* PREAMBLE *)

From compcert.cfrontend   Require Csem.

From trancert.invariants  Require EnvsDisjoint.
From trancert.analysis    Require ContinuationQuant.
From trancert.properties  Require Env.
From trancert.axioms      Require NoFreeLocals.

Import
  Csyntax
  Csem
  EnvsDisjoint
  lib.All
  Coqlib
  properties.Env
  properties.State
  Memory.Mem
  Maps.PTree
  StateQuant
  ContinuationQuant
  invariants.Common
  Estate
  CsemAugmented
  NoFreeLocals.

Section Instance.

  Variable p: program.

  Open Scope positive.

  (** All addresses corresponding to local variables have [Freeable]
premissions. This is a universal invariant.

  Remark: this applies only to the live variables, whose host functions are
  being executed. Once the function returns and is removed from continuation and
  program state, its local variables are deallocated; such variables are outside
  of the scope of this invariant. Deallocation in CompCert does not remove
  blocks from memory but only marks them as such (by lowering their permissions
  below [Freeable]).
 *)

  Record state_env_freeable (s:estate) : Prop :=
    {
      (* requires this invariant, proven separately *)
      sef_disjoint: envs_disjoint s ;
      sef_freeable:
        forall m, estate_mem s m ->
             forall_envs_in_estate (fun _ _ => env_freeable (Csem.globalenv p) m) s;
    }.

  (** This hypothesis is required because the proof relies on
  [ec_other_envs_freeable] and [ec_env_freeable] properties. See
  [remove_local.Extcall].

  Informally, the need for these hypothesis is the following. In CompCert, all
  blocks are alike, whether they were allocated by a C function [malloc] or
  automatically as local variables. Block deallocation is performed by either
  calling [free] explicitly on dynamic memory, or implicitly by performing one
  of "return from function" transitions like [step_return_1].
  There is no constraint that prohibits an external function from freeing a
  local variable, even though in real world such programs are impossible to
  craft without relying on compiling and runtime details.

  A constraint [ec_other_envs_freeable] guarantees that the locals of the current
  functions are not freed by an external call; another constraint [ec_env_freeable]
  guarantees that the locals of all other functions (whose local environments
  are stored in the continuation) will not be freed by an external call.
   *)
  Hypothesis Hlocals_free: locals_stay_free_axiom.

  Theorem correct: invariant (semantics p) state_env_freeable.
  Proof.
    econstructor.
    - constructor; intros.
      + edestruct EnvsDisjoint.correct; eauto.
      + inv H.
        constructor; intros; estate_components.
        constructor.
    - econstructor; inv H.
      + edestruct EnvsDisjoint.correct. by eapply inv_stability; eauto.
      +
        pose s1 := x1.
        pose s2 := x2.

        destruct H0 as [Hestep|Hsstep].
        * intros m H; estate_components; inv Hestep.
          ** inv H3; constructor; intros; estate_components; eapply sef_freeable0; constructor.
          ** inv H3; constructor; intros; estate_components; try by (eapply sef_freeable0; constructor).
             *** inv sef_disjoint0.
                 intros i b0 t1 H1 x H2.
                 eapply Assign.assign_loc_perm; eauto.
                 eapply sef_freeable0; eauto; constructor.
             *** inv sef_disjoint0.
                 exploit sef_freeable0; try by constructor.
                 inversion 1.
                 exploit aeis_cont; try by constructor.
                 move => ?; eapply econt_cond_impl; eauto.
                 repeat constructor; simpl => _ ? ? Henv ? ? ? ? ? ?.
                 intros.
                 eapply Assign.assign_loc_perm; eauto.
                 eapply Henv; eauto.
             *** exploit sef_freeable0; try by constructor.
                 edestruct (Hlocals_free ef); eauto; first by
                 (left; eapply step_rred; eauto; eapply red_builtin; eauto).
                 **** econstructor.
                 **** econstructor.
                 **** eapply sef_disjoint0.
                 **** eapply sef_freeable0; constructor.
                 **** intro Hfreeable.
                      inv Hfreeable.
                      eapply aeis_current; constructor.
             *** exploit sef_freeable0; try by constructor.
                 edestruct (Hlocals_free ef); eauto; first by
                 (left; eapply step_rred; eauto; eapply red_builtin; eauto).
                 **** econstructor.
                 **** econstructor.
                 **** eapply sef_disjoint0.
                 **** eapply sef_freeable0; constructor.
                 **** intro Hfreeable.
                      inv Hfreeable.
                      eapply aeis_cont; constructor.
          ** inv H3.
             exploit sef_freeable0; try by constructor.
             intros [].
             constructor; intros; estate_components.
             *** econstructor; simpl in *; eauto; try by constructor.
                 **** eapply aeis_cont; econstructor.
                 **** eapply aeis_current; econstructor.
             *** econstructor; simpl in *; eauto; try by constructor.
                 **** eapply aeis_cont; econstructor.
                 **** eapply aeis_current; econstructor.
        * (* sstep *)
          intros m H; estate_components; inv Hsstep;
            exploit sef_freeable0; try solve [econstructor]; intros [];
              constructor; intros; estate_components;
              try solve [
                    by eapply aeis_current; constructor|
                    by exploit aeis_cont; constructor|
                      by exploit aeis_cont; solve [by constructor| by inversion 1 | by inversion 1; constructor]
                  ].
          ** by eapply aeis_cont; constructor.
          ** exploit aeis_cont; try by constructor.
             intros.
             apply econt_cond_call_econt in H.
             eapply find_label_econt_cond_rec in H2; eauto.
             *** by decomp.
             *** apply env_only_always_local.
             *** constructor.
          ** eapply BindParameters.bind_parameters_env_freeable_any; eauto.
             eapply Alloc.alloc_variables_freeable_after; eauto.
             unfold env_freeable. intros ? ? ?.  by rewrite gempty.
          ** exploit aeis_cont; try constructor.
             intros; eapply econt_cond_impl; eauto.
             repeat constructor.
             intros f e0 i H0.
             eapply BindParameters.bind_parameters_env_freeable_any; eauto.
             by eapply Alloc.alloc_variables_freeable_any; eauto.
          ** econstructor.
             *** eapply aeis_cont; constructor.
             *** clear. induction sl; by constructor.
          ** eapply econt_cond_call_econt_f; eauto.
             *** inv sef_disjoint0.
                 inv ed_envs_disjoint.
                 eapply Free.free_list_env_freeable; eauto.
                 by eapply aeis_cont; constructor.
          ** eapply econt_cond_call_econt_f; eauto.
             *** inv sef_disjoint0.
                 inv ed_envs_disjoint.
                 inv H0.
                 eapply Free.free_list_env_freeable; eauto.
                 exploit aeis_cont; try by constructor.
                 inversion 1. eassumption.
          ** exploit aeis_cont; try by constructor.
             intros.
             eapply econt_cond_kcall_f_indep; eauto.
             eapply Free .free_list_env_freeable; eauto.
             inv sef_disjoint0.
             by inv ed_envs_disjoint.
          **
             exploit (Hlocals_free ef m0 m (Csem.globalenv p) t0 ).
             *** right; constructor; eassumption.
             *** econstructor.
             *** econstructor.
             *** eapply sef_disjoint0.
             *** eassumption.
             *** econstructor; intros; estate_components.
                 eapply aeis_cont; constructor.
             *** inversion 1. eapply aeis_cont0; constructor.
  Qed.

End Instance.

Hint Resolve correct : invariants.


(******************************************************************************)
(** Generic Semantics                                                         *)
(******************************************************************************)

From Coq Require Import ssreflect.
From Coq Require Import List.
Import ListNotations.

From Bits Require Import bits.
From mathcomp Require Import eqtype tuple.

From BIRD Require Import Bits Util.
From BIRD Require Import GenericSyntax.

Declare Scope bird_scope.
Delimit Scope bird_scope with bird.

(******************************************************************************)
(*** STATE PART                                                               *)
(******************************************************************************)

Section STATEPART.

  Variable (Cell : Type).
  Variable (Annot : Type).

  Local Notation the_src := (source Cell Annot).
  Local Notation the_dst := (destination Cell Annot).

  Definition source_word_size `{IsCell Cell Annot} (src : the_src) : word_size :=
    match src with
    | src_imm  _   => QWORD
    | src_addr a   => fst a
    | src_expr e   => QWORD
    | src_cell c a => cell_word_size c a
    | src_rip      => QWORD
    end.

  Definition destination_word_size `{IsCell Cell Annot} (dst : the_dst) : word_size :=
    match dst with
    | dst_addr a   => fst a
    | dst_cell c a => cell_word_size c a
    end.

  Definition source_word_type      `{IsCell Cell Annot} (src : the_src)
    := word_type (source_word_size src).
  Definition destination_word_type `{IsCell Cell Annot} (dst : the_dst)
    := word_type (destination_word_size dst).

End STATEPART.

(******************************************************************************)
(*** STATE                                                                    *)
(******************************************************************************)

Section STATE.

  Local Open Scope bird.

  Variable (Cell Annot Label : Type).
  Context `{IsLabel Label}.

  Definition memory := abs_addr -> byte.
  Definition flags  := flag -> bit.
  Definition cells  := Cell -> qword.
  Definition rip    := Label.

  Class IsCellState `{IsCell Cell Annot} :=
      { cells_read        : cells -> forall c a, cell_word_type c a
      ; cells_write       : cells -> forall c a, cell_word_type c a -> cells
      ; cells_read_qword  : cells -> Cell -> qword
      ; cells_write_qword : cells -> Cell -> qword -> cells
      }.

  Record state := mk_state
    { state_mem   : memory
    ; state_flags : flags
    ; state_cells : cells
    ; state_rip   : rip
    }.

  Definition _0 : qword := (#0, #0, #0, #0, #0, #0, #0, #0).
  Definition _1 : qword := (#0, #0, #0, #0, #0, #0, #0, #1).
  Definition _2 : qword := (#0, #0, #0, #0, #0, #0, #0, #2).
  Definition _3 : qword := (#0, #0, #0, #0, #0, #0, #0, #3).
  Definition _4 : qword := (#0, #0, #0, #0, #0, #0, #0, #4).
  Definition _5 : qword := (#0, #0, #0, #0, #0, #0, #0, #5).
  Definition _6 : qword := (#0, #0, #0, #0, #0, #0, #0, #6).
  Definition _7 : qword := (#0, #0, #0, #0, #0, #0, #0, #7).
  Definition _8 : qword := (#0, #0, #0, #0, #0, #0, #0, #8).

  Definition memory_read (m : memory) (a : addr Cell) (f : Cell -> qword) : addr_word_type a :=
    let '(s, e) := a in
    let b (offset : abs_addr) := m ((addr_expr_eval e f) + offset) in
    match s as s' return addr_word_type (s', e) with
    | BYTE  =>                                            b _0
    | WORD  =>                                     (b _1, b _0)
    | DWORD =>                         (b _3, b _2, b _1, b _0)
    | QWORD => (b _7, b _6, b _5, b _4, b _3, b _2, b _1, b _0)
    end.

  Definition memory_write (m : memory) (a : addr Cell) (f : Cell -> qword) (v : addr_word_type a) : memory.
    destruct a as [s e].
    set e_val := addr_expr_eval e f.
    set w := fun (m : memory) (b : byte) (offset : abs_addr) a' => if a' == e_val + offset then b else m a'.
    case s eqn:?.
    - exact (w m v _0).
    - destruct v as [v0 v1].
      exact (w (w m v0 _0) v1 _1).
    - destruct v as (((v0&v1)&v2)&v3).
      exact (w (w (w (w m v0 _0) v1 _1) v2 _2) v3 _3).
    - destruct v as (((((((v0&v1)&v2)&v3)&v4)&v5)&v6)&v7).
      exact (w (w (w (w (w (w (w (w m v0 _0) v1 _1) v2 _2) v3 _3) v4 _4) v5 _5) v6 _6) v7 _7).
  Defined.

  Definition flags_read  (F : flags) (f : flag) : bit := F f.
  Definition flags_write (F : flags) (f : flag) (v : bit) : flags := fun g => if flag_eqb f g then v else F g.

  Definition state_read `{IsCellState} `{IsLabel Label}
    (s : state) (src : source Cell Annot) : source_word_type _ _ src :=
    match src as src' return source_word_type _ _ src' with
    | src_imm  i   => i
    | src_addr a   => memory_read (state_mem s) a (cells_read_qword (state_cells s))
    | src_expr e   => addr_expr_eval e (cells_read_qword (state_cells s))
    | src_cell c a => cells_read (state_cells s) c a
    | src_rip      => label_value (state_rip s)
    end.

  Definition state_read_qword `{IsCellState} `{IsLabel Label}
    (s : state) (src : source Cell Annot) : qword.
  Proof.
    set v := state_read s src.
    unfold source_word_type in v.
    unfold source_word_size in v.
    case src eqn:? ; cbn in *.
    - exact v.
    - destruct a. case w eqn:? ; cbn in v.
        + exact (insert _0 low8 v).
        + exact (insert _0 low16 v).
        + exact (insert _0 low32 v).
        + exact (insert _0 full64 v).
    - exact v.
    - exact (insert _0 (cell_word_pattern c a) v).
    - exact v.
  Defined.

  Definition state_write `{IsCellState}
    (s : state) (dst : destination Cell Annot) (v : destination_word_type _ _ dst) : state :=
    let M := state_mem s in
    let F := state_flags s in
    let C := state_cells s in
    let R := state_rip s in
    match dst as dst' return dst = dst' -> destination_word_type _ _ dst' -> state with
    | dst_addr a => fun _ v' =>
                      let mem' := memory_write (state_mem s) a (cells_read_qword (state_cells s)) v' in
                      {| state_mem := mem' ; state_flags := F ; state_cells := C ; state_rip := R |}
    | dst_cell c a => fun _ v' =>
                        let cells' := cells_write (state_cells s) c a v' in
                        {| state_cells := cells' ; state_flags := F ; state_mem := M ; state_rip := R |}
    end Logic.eq_refl v.

  Definition state_write_qword `{IsCellState} `{IsLabel Label}
    (s : state) (dst : destination Cell Annot) (v : qword) : state.
  Proof.
    set t := (destination_word_type _ _ dst).
    unfold destination_word_type in t.
    case (destination_word_size _ _ dst) eqn:F.
    - set v' := extract v low8. cbn in v'.
      have T: (byte = destination_word_type _ _ dst) by unfold destination_word_type ; rewrite F.
      exact s.
    - set v' := extract v low16. cbn in v'.
      have T: (word = destination_word_type _ _ dst) by unfold destination_word_type ; rewrite F.
      exact s.
    - set v' := extract v low32. cbn in v'.
      have T: (dword = destination_word_type _ _ dst) by unfold destination_word_type ; rewrite F.
      exact s.
    - set v' := extract v full64. cbn in v'.
      have T: (qword = destination_word_type _ _ dst) by unfold destination_word_type ; rewrite F.
      exact s.
  Defined.

  Definition state_write_rip (s : state) (r : rip) : state :=
    let M := state_mem s in
    let F := state_flags s in
    let C := state_cells s in
    mk_state M F C r.

  Definition state_inc_rip {p : program Cell Annot Label} (s : state) (i : instruction Cell Annot Label (prog_nodes _ _ _ p)) : state :=
    let rip := label_value (state_rip s) in state_write_rip s (label_unvalue (qword_add rip _8)).

End STATE.

Section DENOTATION.

  Variables (Cell Label Annot : Type).

  Local Notation the_dst := (destination Cell Annot).
  Local Notation the_src := (source Cell Annot).
  Local Notation the_state := (state Cell Annot).

  (* Few implementations for presentation purposes, other follow *)
  (* when this is integrated into the rest of the decompiler *)

  Definition computation_1_1 (opcode : opcode_1_1) : option (qword -> qword) :=
    match opcode with
    | op_inc => Some (fun a => qword_add a _1)
    | _ => None
    end.

  Definition computation_2_1 (opcode : opcode_2_1) : option (qword -> qword -> qword) :=
    match opcode with
    | op_add => Some qword_add
    | _ => None
    end.

  Definition computation_2_2 (opcode : opcode_2_2) : option (qword -> qword -> (qword * qword)%type) :=
    match opcode with
    | op_xchg => Some (fun a b => (b, a))
    | _ => None
    end.

  Definition effect_1_1 (opcode : opcode_1_1) : option (qword -> flags -> flags) :=
    match opcode with
    | op_inc => Some (fun a s => let '(c, a') := qword_addc a _1 in
                                 let s' := flags_write s zero_flag (a' == _0)%bool in
                                 flags_write s' carry_flag c
                  )
    | _ => None
    end.

  Definition effect_2_0 (opcode : opcode_2_0) : option (qword -> qword -> flags -> flags) :=
    match opcode with
    | op_cmp => Some (fun a b s => let '(b, z) := qword_subb a b in
                                   flags_write s zero_flag (negb b && (z == _0))%bool)
    | _ => None
    end.

  Definition effect_2_1 (opcode : opcode_2_1) : option (qword -> qword -> flags -> flags) :=
    match opcode with
    | op_add => Some (fun a b s => let '(c, r) := qword_addc a b in
                                  let s' := flags_write s zero_flag (r == _0)%bool in
                                 flags_write s' carry_flag c)
    | _ => None
    end.

  Definition effect_2_2 (opcode : opcode_2_2) : option (qword -> qword -> flags -> flags) :=
    match opcode with
    | op_xchg => Some (fun a b s => s)
    | _ => None
    end.

  Definition condition (op : opcode_cond) : option (flags -> bool) :=
    match op with
    | op_jnz => Some (fun fs => negb (flags_read fs zero_flag))
    | op_jz => Some (fun fs => (flags_read fs zero_flag))
    | _ => None
    end.

  Definition run_effect_1 (s : the_state) (e : qword -> flags -> flags) (v : qword) :=
    let M := state_mem _ _ s in
    let F := e v (state_flags _ _ s) in
    let C := state_cells _ _ s in
    let R := state_rip _ _ s in
    mk_state _ _ M F C R.

  Definition run_effect_2 (s : the_state) (e : qword -> qword -> flags -> flags) (v1 : qword) (v2 : qword) :=
    let M := state_mem _ _ s in
    let F := e v1 v2 (state_flags _ _ s) in
    let C := state_cells _ _ s in
    let R := state_rip _ _ s in
    mk_state _ _ M F C R.

End DENOTATION.

Section SEMANTICS.

  Variables (Cell Annot Label : Type).

  Local Notation the_prog  := (program Cell Annot Label).
  Local Notation the_instr := (instruction Cell Annot Label).
  Local Notation the_node  := (node Cell Annot Label).
  Local Notation the_state := (state Cell Label).
  Local Notation the_phis  := (phi_block Cell).
  Local Notation the_phi   := (phi_instruction Cell).
  Local Notation the_src   := (source Cell Annot).
  Local Notation the_dst   := (destination Cell Annot).

  Definition run_phi `{IsCellState Cell Annot} (n : nat) (p : the_phi) (σ : the_state) : the_state :=
    if List.nth_error (phi_srcs _ p) n is Some s
    then
      let θ  := state_mem _ _ σ in
      let ξ  := state_flags _ _ σ in
      let γ  := state_cells _ _ σ in
      let ρ  := state_rip _ _ σ in
      let v  := cells_read_qword _ _ γ s in
      let γ' := cells_write_qword _ _ γ (phi_dst _ p) v in
      mk_state _ _ θ ξ γ' ρ
    else σ.

  Fixpoint run_phis `{IsCellState Cell Annot} (n : nat) (ps : the_phis) (σ : the_state) : the_state :=
    match ps with
    | []     => σ
    | p::ps' => run_phis n ps' (run_phi n p σ)
    end.

  Inductive phi_step `{EqDec Label} `{IsCellState Cell Annot} (p : the_prog) :
    the_node p -> the_state -> the_node p -> the_state -> Prop :=
  | phi_step_block (k₁ k₂ : the_node p) (σ₁ σ₂ : the_state) n :
    is_nth_pred _ _ _ k₁ k₂ n ->
    σ₂ = run_phis n (phi _ _ _ k₂) σ₁ ->
    phi_step p k₁ σ₁ k₂ σ₂.

  Inductive instr_step `{EqDec Label} `{IsCellState Cell Annot} `{IsLabel Label} (p : the_prog) :
    the_node p -> the_state -> option (the_node p) -> the_state -> Prop :=

  | step_nop k1 k2 s1 s2 :
    instr _ _ _ k1 = instr_nop _ _ _ _ k2 ->
    s2 = state_write_rip _ _ s1 (proj1_sig k2) ->
    instr_step p k1 s1 (Some k2) s2

  | step_hlt k s :
    instr _ _ _ k = instr_hlt _ _ _ _ ->
    instr_step p k s None s

  | step_1_1 op dst src k1 k2 s1 s2 s3 s4 d f v :
    instr _ _ _ k1 = instr_1_1 _ _ _ _ op dst src k2 ->
    s2 = state_write_rip _ _ s1 (proj1_sig k2) ->
    Some d = computation_1_1 op ->
    Some f = effect_1_1 op ->
    v = state_read_qword _ _ _ s1 src ->
    s3 = state_write_qword _ _ _ s2 dst (d v) ->
    s4 = run_effect_1 _ _ s3 f v ->
    instr_step p k1 s1 (Some k2) s4

  | step_2_0 op src1 src2 k1 k2 s1 s2 s4 f v1 v2 :
    instr _ _ _ k1 = instr_2_0 _ _ _ _ op src1 src2 k2 ->
    s2 = state_write_rip _ _ s1 (proj1_sig k2) ->
    Some f = effect_2_0 op ->
    v1 = state_read_qword _ _ _ s1 src1 ->
    v2 = state_read_qword _ _ _ s1 src2 ->
    s4 = run_effect_2 _ _ s2 f v1 v2 ->
    instr_step p k1 s1 (Some k2) s4

  | step_2_1 op dst src1 src2 k1 k2 s1 s2 s3 s4 d f v1 v2 :
    instr _ _ _ k1 = instr_2_1 _ _ _ _ op dst src1 src2 k2 ->
    s2 = state_write_rip _ _ s1 (proj1_sig k2) ->
    Some d = computation_2_1 op ->
    Some f = effect_2_1 op ->
    v1 = state_read_qword _ _ _ s1 src1 ->
    v2 = state_read_qword _ _ _ s1 src2 ->
    s3 = state_write_qword _ _ _ s2 dst (d v1 v2) ->
    s4 = run_effect_2 _ _ s3 f v1 v2 ->
    instr_step p k1 s1 (Some k2) s4

  | step_2_2 op dst1 dst2 src1 src2 k1 k2 s1 s2 s3 s4 s5 d f v1 v2 v1' v2' :
    instr _ _ _ k1 = instr_2_2 _ _ _ _ op dst1 dst2 src1 src2 k2 ->
    s2 = state_write_rip _ _ s1 (proj1_sig k2) ->
    Some d = computation_2_2 op ->
    Some f = effect_2_2 op ->
    v1 = state_read_qword _ _ _ s1 src1 ->
    v2 = state_read_qword _ _ _ s1 src2 ->
    v1' = fst (d v1 v2) ->
    v2' = snd (d v1 v2) ->
    s3 = state_write_qword _ _ _ s2 dst1 v1' ->
    s4 = state_write_qword _ _ _ s2 dst2 v2' ->
    s5 = run_effect_2 _ _ s5 f v1 v2 ->
    instr_step p k1 s1 (Some k2) s5

  | step_push (sp_s sp_d : Cell) src k1 k2 s1 s2 s3 s4 v sz :
    instr _ _ _ k1 = instr_push _ _ _ _ sp_s sp_d src k2 ->
    s2 = state_write_rip _ _ s1 (proj1_sig k2) ->
    v = state_read_qword _ _ _ s1 src ->
    s3 = state_write_qword _ _ _ s2 (dst_addr _ _ (sz, mk_addr_expr _ (Some sp_s) None scale1 _0)) v ->
    instr_step p k1 s1 (Some k2) s4

  | step_pop (sp_s sp_d : Cell) dst k1 k2 s1 s2 s3 s4 v sz :
    instr _ _ _ k1 = instr_pop _ _ _ _ dst sp_s sp_d k2 ->
    s2 = state_write_rip _ _ s1 (proj1_sig k2) ->
    v = state_read_qword _ _ _ s1 (src_addr _ _ (sz, mk_addr_expr _ (Some sp_s) None scale1 _0)) ->
    s3 = state_write_qword _ _ _ s2 dst v ->
    instr_step p k1 s1 (Some k2) s4

  | step_jmp src k1 k2 k_t s1 s2 :
    instr _ _ _ k1 = instr_jmp _ _ _ _ src k_t ->
    s2 = state_write_rip _ _ s1 (proj1_sig k2) ->
    In k2 k_t ->
    instr_step p k1 s1 (Some k2) s2

  | step_cjmp cond src k1 k2 k_t k_f s1 s2 c :
    instr _ _ _ k1 = instr_cjmp _ _ _ _ cond src k_t k_f ->
    s2 = state_write_rip _ _ s1 (proj1_sig k2) ->
    Some c = condition cond ->
    (c (state_flags _ _ s1) = true  -> In k2 k_t) ->
    (c (state_flags _ _ s1) = false -> k2 = k_f) ->
    instr_step p k1 s1 (Some k2) s2

  | step_call (sp_s sp_d : Cell) src k1 k2 kc kr s1 s2 s3 s4 v :
    instr _ _ _ k1 = instr_call _ _ _ _ sp_s sp_d src kc kr ->
    s2 = state_write_rip _ _ s1 (proj1_sig kr) ->
    v = state_read_qword _ _ _ s1 src ->
    label_value (proj1_sig k2) = v ->
    In k2 kc ->
    s3 = state_write_qword _ _ _ s2 (dst_addr _ _ (QWORD, mk_addr_expr _ (Some sp_s) None scale1 _0)) (label_value (proj1_sig kr)) ->
    instr_step p k1 s1 (Some k2) s4

  | step_ret (sp_s sp_d : Cell) k1 k2 s1 s2 v kr :
    instr _ _ _ k1 = instr_ret _ _ _ _ sp_s sp_d kr ->
    s2 = state_write_rip _ _ s1 (proj1_sig k2) ->
    In k2 kr ->
    v = state_read_qword _ _ _ s1 (src_addr _ _ (QWORD, mk_addr_expr _ (Some sp_s) None scale1 _0)) ->
    label_value (proj1_sig k2) = v ->
    instr_step p k1 s1 (Some k2) s2
    .

    Inductive step_star `{EqDec Label} `{IsCellState Cell Annot} `{IsLabel Label} (p : the_prog) :
      the_node p -> the_state -> option (the_node p) -> the_state -> Prop  :=

    | step_terminal s1 s2 k :
      instr_step p k s1 None s2 ->
      step_star  p k s1 None s2

    | step_nonterminal s1 s2 s3 s4 k1 k2 k3 k4 :
      instr_step p k1 s1 (Some k2) s2 ->
      phi_step   p k2 s2 k3 s3 ->
      step_star  p k3 s3 k4 s4 ->
      step_star  p k1 s1 k4 s4

      .

End SEMANTICS.