Require Import RelationClasses.

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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.

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

Require Import Cover.
Require Import MemorySplit.
Require Import MemoryMerge.
Require Import FulfillStep.
Require Import MemoryProps.

Require Import LowerMemory.
Require Import JoinedView.

Require Import MaxView.
Require Import Delayed.

Require Import Lia.

Require Import JoinedView.
Require Import SeqLift.
Require Import Sequential.

Require Import Pred.

Require Import SeqLiftStep.

Variant sim_thread_sol
        (c: bool)
        (vs: Loc.t -> Const.t)
        (P: Loc.t -> bool)
        (D: Loc.t -> bool)
        mem lc: Prop :=
  | sim_thread_intro
      (CONS: Local.promise_consistent lc)
      (DEBT: forall loc to from msg
                    (GET: Memory.get loc to lc.(Local.promises) = Some (from, msg)),
          (<<MSG: msg <> Message.reserve>>) /\ (<<DEBT: c = true -> D loc>>))
      (NSYNC: forall loc, Memory.nonsynch_loc loc lc.(Local.promises))
      (VALS: forall loc,
        exists from released,
          (<<GET: Memory.get loc (lc.(Local.tview).(TView.cur).(View.rlx) loc) mem = Some (from, Message.concrete (vs loc) released)>>))
      (PERM: forall loc val released (MAX: max_readable mem lc.(Local.promises) loc (lc.(Local.tview).(TView.cur).(View.pln) loc) val released),
          P loc)
.

Definition lowered_content (b: bool) (cnt0 cnt1: option (Time.t * Message.t)): Prop :=
  (cnt0 = cnt1 /\ b = false) \/
    cnt1 = match cnt0 with
           | Some (_, Message.reserve) | None => None
           | Some (from, Message.undef) => Some (from, Message.undef)
           | Some (from, Message.concrete val released) => Some (from, Message.concrete val None)
           end.

Lemma lowered_content_trans b0 b1 b2 cnt0 cnt1 cnt2
      (LOWER0: lowered_content b0 cnt0 cnt1)
      (LOWER1: lowered_content b1 cnt1 cnt2)
      (BOOL: b0 = false -> b1 = false -> b2 =false)
  :
  lowered_content b2 cnt0 cnt2.
Proof.
  unfold lowered_content in *. des; subst; auto.
  right. des_ifs.
Qed.

Definition lowered_memory mem0 mem1: Prop :=
  forall loc to, lowered_content false (Memory.get loc to mem0) (Memory.get loc to mem1).

Global Program Instance lowered_memory_PreOrder: PreOrder lowered_memory.
Next Obligation.
Proof.
  ii. left. auto.
Qed.
Next Obligation.
Proof.
  ii. specialize (H loc to). specialize (H0 loc to).
  eapply lowered_content_trans; eauto.
Qed.

Lemma lower_none_lowered_memory mem0 loc from to val released mem1
      (LOWER: Memory.lower mem0 loc from to (Message.concrete val released) (Message.concrete val None) mem1)
  :
  lowered_memory mem0 mem1.
Proof.
  ii. erewrite (@Memory.lower_o mem1); eauto. des_ifs.
  { ss. des; clarify. right.
    eapply Memory.lower_get0 in LOWER. des. rewrite GET. ss.
  }
  { left. auto. }
Qed.

Lemma cancel_lowered_memory mem0 loc from to  mem1
      (CANCEL: Memory.remove mem0 loc from to Message.reserve mem1)
  :
  lowered_memory mem0 mem1.
Proof.
  ii. erewrite (@Memory.remove_o mem1); eauto. des_ifs.
  { ss. des; clarify. right.
    eapply Memory.remove_get0 in CANCEL. des. rewrite GET. ss.
  }
  { left. auto. }
Qed.

Lemma nonsynch_all
      lang st
      tvw prom0 mem0 sc
      (LOCAL: Local.wf (Local.mk tvw prom0) mem0)
  :
  exists prom1 mem1,
    (<<STEPS: rtc (@Thread.tau_step lang) (Thread.mk _ st (Local.mk tvw prom0) sc mem0) (Thread.mk _ st (Local.mk tvw prom1) sc mem1)>>) /\
      (<<NONE: forall loc to,
          Memory.get loc to prom1 = match Memory.get loc to prom0 with
                                    | Some (_, Message.reserve) | None => None
                                    | Some (from, Message.undef) => Some (from, Message.undef)
                                    | Some (from, Message.concrete val released) => Some (from, Message.concrete val None)
                                    end>>) /\
      (<<MAX: forall loc val released,
          max_readable mem0 prom0 loc (tvw.(TView.cur).(View.pln) loc) val released
          <->
            max_readable mem1 prom1 loc (tvw.(TView.cur).(View.pln) loc) val released>>) /\
      (<<PRESERVE: forall loc to val released from
                          (GET: Memory.get loc to mem0 = Some (from, Message.concrete val released)),
        exists released', (<<GET: Memory.get loc to mem1 = Some (from, Message.concrete val released')>>)>>)
.
Proof.
  inv LOCAL. clear TVIEW_WF TVIEW_CLOSED. rename PROMISES into MLE.
  red in FINITE. des.
  cut (exists prom1 mem1,
             (<<STEPS: rtc (@Thread.tau_step lang) (Thread.mk _ st (Local.mk tvw prom0) sc mem0) (Thread.mk _ st (Local.mk tvw prom1) sc mem1)>>) /\
               (<<NONE: forall loc to (IN: List.In (loc, to) dom),
                   lowered_content true (Memory.get loc to prom0) (Memory.get loc to prom1)>>) /\
               (<<MAX: forall loc val released,
                   max_readable mem0 prom0 loc (tvw.(TView.cur).(View.pln) loc) val released
                   <->
                     max_readable mem1 prom1 loc (tvw.(TView.cur).(View.pln) loc) val released>>) /\
               (<<LOWERPROM: lowered_memory prom0 prom1>>) /\
               (<<LOWERMEM: lowered_memory mem0 mem1>>)).
  { i. des. esplits; eauto.
    { i. specialize (NONE loc to). unfold lowered_content in *.
      destruct (Memory.get loc to prom0) as [[from msg]|] eqn:PROM.
      { hexploit NONE; eauto. i; des; ss. }
      { specialize (LOWERPROM loc to). rewrite PROM in LOWERPROM.
        red in LOWERPROM. des; auto.
      }
    }
    { i. specialize (LOWERMEM loc to). rewrite GET in LOWERMEM. des; eauto.
      red in LOWERMEM. des; eauto.
    }
  }
  clear FINITE. revert prom0 mem0 MLE BOT. induction dom.
  { i. esplits.
    { refl. }
    { i. ss. }
    { auto. }
    { refl. }
    { refl. }
  }
  i. destruct a as [loc to].
  destruct (Memory.get loc to prom0) as [[from msg]|] eqn:GET.
  { destruct msg.
    { hexploit Memory.lower_exists.
      { eapply GET. }
      { hexploit memory_get_ts_strong; eauto. i. des; clarify.
        rewrite BOT in GET. ss.
      }
      { instantiate (1:=Message.concrete val None). econs; ss. }
      { econs; ss. refl. }
      i. des.
      hexploit Memory.lower_exists_le; eauto. i. des.
      assert (PROMISE: Memory.promise prom0 mem0 loc from to (Message.concrete val None) mem2 mem1 (Memory.op_kind_lower (Message.concrete val released))).
      { econs; eauto; ss. econs. eapply Time.bot_spec. }
      hexploit (IHdom mem2 mem1); eauto.
      { eapply promise_memory_le; eauto. }
      { eapply Memory.promise_bot_none; eauto. }
      i. des. esplits.
      { econs 2.
        { econs.
          { econs. econs 1. econs; eauto. }
          { ss. }
        }
        { eauto. }
      }
      { i. ss. des; clarify.
        { eapply lowered_content_trans.
          2:{ eapply LOWERPROM. }
          2:{ instantiate (1:=true). ss. }
          des; clarify.
          { rewrite GET. erewrite (@Memory.lower_o mem2); eauto.
            des_ifs; ss; des; clarify. right. auto.
          }
        }
        { eapply lowered_content_trans.
          2:{ eapply NONE; eauto. }
          2:{ instantiate (1:=false). ss. }
          eapply lower_none_lowered_memory; eauto.
        }
      }
      { i. etrans; [|eapply MAX]. destruct (Loc.eq_dec loc0 loc); subst.
        { eapply promise_max_readable; eauto. }
        { eapply promise_unchanged_loc in PROMISE; eauto. des.
          eapply unchanged_loc_max_readable; eauto.
        }
      }
      { etrans; eauto. eapply lower_none_lowered_memory; eauto. }
      { etrans; eauto. eapply lower_none_lowered_memory; eauto. }
    }
    { hexploit (IHdom prom0 mem0); eauto. i. des. esplits; eauto.
      i. ss. des; clarify.
      { eapply lowered_content_trans.
        2:{ eapply LOWERPROM. }
        2:{ instantiate (1:=true). ss. }
        rewrite GET. right. auto.
      }
      { eapply NONE; auto. }
    }
    { hexploit Memory.remove_exists.
      { eapply GET. }
      i. des.
      hexploit Memory.remove_exists_le; eauto. i. des.
      assert (PROMISE: Memory.promise prom0 mem0 loc from to Message.reserve mem2 mem1 (Memory.op_kind_cancel)).
      { econs; eauto; ss. }
      hexploit (IHdom mem2 mem1); eauto.
      { eapply promise_memory_le; eauto. }
      { eapply Memory.promise_bot_none; eauto. }
      i. des. esplits.
      { econs 2.
        { econs.
          { econs. econs 1. econs; eauto. }
          { ss. }
        }
        { eauto. }
      }
      { i. ss. des; clarify.
        { eapply lowered_content_trans.
          2:{ eapply LOWERPROM. }
          2:{ instantiate (1:=true). ss. }
          des; clarify.
          { rewrite GET. erewrite (@Memory.remove_o mem2); eauto.
            des_ifs; ss; des; clarify. right. auto.
          }
        }
        { eapply lowered_content_trans.
          2:{ eapply NONE; eauto. }
          2:{ instantiate (1:=false). ss. }
          eapply cancel_lowered_memory; eauto.
        }
      }
      { i. etrans; [|eapply MAX]. destruct (Loc.eq_dec loc0 loc); subst.
        { eapply promise_max_readable; eauto. }
        { eapply promise_unchanged_loc in PROMISE; eauto. des.
          eapply unchanged_loc_max_readable; eauto.
        }
      }
      { etrans; eauto. eapply cancel_lowered_memory; eauto. }
      { etrans; eauto. eapply cancel_lowered_memory; eauto. }
    }
  }
  { hexploit (IHdom prom0 mem0); eauto. i. des. esplits; eauto.
    i. ss. des; clarify.
    { eapply lowered_content_trans.
      2:{ eapply LOWERPROM. }
      2:{ instantiate (1:=true). ss. }
      rewrite GET. right. auto.
    }
    { eapply NONE; auto. }
  }
Qed.

Lemma sim_thread_sim_thread_sol
      c D f vers flag_src flag_tgt vs_src vs_tgt
      mem_src0 mem_tgt lc_src0 lc_tgt sc_src sc_tgt
      (SIM: sim_thread
              f vers flag_src flag_tgt vs_src vs_tgt
              mem_src0 mem_tgt lc_src0 lc_tgt sc_src sc_tgt)
      (BOT: c = true -> lc_tgt.(Local.promises) = Memory.bot)
      (CONSTGT: Local.promise_consistent lc_tgt)
      (DEBT: forall loc (TGT: flag_src loc = false) (DEBT: D loc = false), flag_tgt loc = false)
      (WF: Mapping.wfs f)
      (LOCAL: Local.wf lc_src0 mem_src0)
      lang st
  :
  exists mem_src1 lc_src1 vs,
    (<<STEPS: rtc (@Thread.tau_step lang) (Thread.mk _ st lc_src0 sc_src mem_src0) (Thread.mk _ st lc_src1 sc_src mem_src1)>>) /\
      (<<SIM: sim_thread_sol c vs (fun loc => vs_src loc) D mem_src1 lc_src1>>) /\
      (<<VALS: forall loc val (VAL: vs_src loc = Some val), vs loc = val>>)
.
Proof.
  hexploit (choice (fun loc val =>
                      exists from released,
                        (<<GET: Memory.get loc (lc_src0.(Local.tview).(TView.cur).(View.rlx) loc) mem_src0 = Some (from, Message.concrete val released)>>))).
  { inv LOCAL. inv TVIEW_CLOSED. inv CUR.
    intros loc. hexploit (RLX loc). i. des. eauto.
  }
  intros [vs VALS]. inv SIM.
  assert (CONSSRC: Local.promise_consistent lc_src0).
  { eapply sim_local_consistent; eauto. }
  destruct lc_src0 as [tvw_src prom_src0].
  hexploit nonsynch_all; eauto. i. des.
  exists mem1, (Local.mk tvw_src prom1), vs. splits.
  { eauto. }
  { econs; eauto.
    { ii. ss. rewrite NONE in PROMISE. des_ifs.
      { eapply CONSSRC; eauto; ss. }
      { eapply CONSSRC; eauto; ss. }
    }
    { inv LOCAL0. i. ss.
      assert (exists msg', Memory.get loc to prom_src0 = Some (from, msg') /\ msg <> Message.reserve).
      { rewrite NONE in GET. des_ifs.
        { esplits; eauto; ss. }
        { esplits; eauto; ss. }
      }
      des. splits; auto. i. subst.
      hexploit sim_promises_get_if; eauto. i. des.
      { rewrite BOT in GET0; auto. rewrite Memory.bot_get in GET0. ss. }
      { destruct (flag_src loc) eqn:EQ.
        { erewrite sim_promises_none in H; eauto. ss. }
        { destruct (D loc) eqn:DEBT0; eauto. hexploit DEBT; eauto. i. des; clarify. }
      }
    }
    { ii. ss. rewrite NONE in GET. des_ifs. }
    { i. ss. specialize (VALS loc). des. hexploit PRESERVE; eauto. }
    { i. ss. ss. hexploit (MAXSRC loc). i. inv H.
      destruct (vs_src loc) eqn:VAL; ss.
      exfalso. eapply NONMAX; eauto. eapply MAX; eauto.
    }
  }
  { i. hexploit (MAXSRC loc). i. inv H.
    hexploit (VALS loc). i.
    hexploit MAX0; eauto. i. des. ss. inv MAX1.
    assert (TS: View.pln (TView.cur tvw_src) loc = View.rlx (TView.cur tvw_src) loc).
    { eapply TimeFacts.antisym.
      { eapply LOCAL. }
      destruct (Time.le_lt_dec (View.rlx (TView.cur tvw_src) loc) (View.pln (TView.cur tvw_src) loc)); auto.
      exfalso. eapply MAX2 in l; eauto; ss.
      exploit CONSSRC; eauto; ss. i. timetac.
    }
    rewrite TS in *. clarify.
  }
Qed.

Lemma sim_thread_none
      vs P D mem lc
      (SIM: sim_thread_sol true vs P D mem lc)
      (DEBT: forall loc, D loc = false)
  :
  lc.(Local.promises) = Memory.bot.
Proof.
  eapply Memory.ext. i. rewrite Memory.bot_get.
  inv SIM. destruct (Memory.get loc ts lc.(Local.promises)) eqn:GET; auto.
  destruct p. exploit DEBT0; eauto. i. des.
  exfalso. hexploit DEBT1; eauto. rewrite DEBT. ss.
Qed.

Lemma sim_thread_sol_failure
      c vs P D mem lc
      (SIM: sim_thread_sol c vs P D mem lc)
  :
  Local.failure_step lc.
Proof.
  inv SIM. econs. eauto.
Qed.

Lemma sim_thread_sol_fence
      c vs P D mem lc0 sc ordr ordw
      (SIM: sim_thread_sol c vs P D mem lc0)
      (ORDR: ~ Ordering.le Ordering.acqrel ordr)
      (ORDW: ~ Ordering.le Ordering.seqcst ordw)
  :
  exists lc1,
    (<<FENCE: Local.fence_step lc0 sc ordr ordw lc1 sc>>) /\
    (<<SIM: sim_thread_sol c vs P D mem lc1>>)
.
Proof.
  inv SIM. esplits.
  { econs; eauto.
    { destruct ordw; ss. }
    { i. destruct ordw; ss. }
  }
  econs; eauto; ss.
  { ii. ss. des_ifs. eapply CONS; eauto. }
  { ii. des_ifs. }
  { ii. des_ifs. eapply PERM; eauto. }
Qed.

Lemma sim_thread_sol_racy
      c vs P D mem lc loc
      (SIM: sim_thread_sol c vs P D mem lc)
      (LOCAL: Local.wf lc mem)
      (ORD: ~ P loc)
  :
  exists to, Local.is_racy lc mem loc to Ordering.na.
Proof.
  inv SIM. destruct lc.
  hexploit non_max_readable_race; eauto.
Qed.

Lemma sim_thread_sol_read_na_racy
      c vs P D mem lc loc
      (SIM: sim_thread_sol c vs P D mem lc)
      (LOCAL: Local.wf lc mem)
      (ORD: ~ P loc)
      val
  :
  exists to, Local.racy_read_step lc mem loc to val Ordering.na.
Proof.
  exploit sim_thread_sol_racy; eauto. i. des.
  esplits. eauto.
Qed.

Lemma sim_thread_sol_write_na_racy
      c vs P D mem lc loc
      (SIM: sim_thread_sol c vs P D mem lc)
      (LOCAL: Local.wf lc mem)
      (ORD: ~ P loc)
  :
  exists to, Local.racy_write_step lc mem loc to Ordering.na.
Proof.
  exploit sim_thread_sol_racy; eauto. i. des.
  esplits. econs; eauto.
  inv SIM. auto.
Qed.

Lemma sim_thread_sol_read_na
      c vs P D mem lc loc val
      (SIM: sim_thread_sol c vs P D mem lc)
      (LOCAL: Local.wf lc mem)
      (VAL: Const.le val (vs loc))
  :
  exists ts released,
    (<<READ: Local.read_step lc mem loc ts val released Ordering.na lc>>)
.
Proof.
  inv SIM. hexploit (VALS loc); eauto. i. des.
  esplits. econs; eauto.
  { econs; ss. eapply LOCAL. }
  destruct lc. f_equal. ss. unfold TView.read_tview. des_ifs.
  ss. rewrite ! View.join_bot_r. rewrite ! View.le_join_l.
  { destruct tview; auto. }
  { eapply View.singleton_rw_spec.
    { eapply LOCAL. }
    { eapply LOCAL. }
  }
  { eapply View.singleton_rw_spec.
    { eapply LOCAL. }
    { refl. }
  }
Qed.

Lemma sim_thread_sol_read
      c vs P D mem lc0 loc ord val
      (SIM: sim_thread_sol c vs P D mem lc0)
      (LOCAL: Local.wf lc0 mem)
      (ORD: ~ Ordering.le Ordering.acqrel ord)
      (VAL: Const.le val (vs loc))
  :
  exists ts released lc1,
    (<<READ: Local.read_step lc0 mem loc ts val released ord lc1>>) /\
    (<<SIM: sim_thread_sol c vs (fun loc0 => if (Loc.eq_dec loc0 loc) then true else P loc0) D mem lc1>>)
.
Proof.
  inv SIM. hexploit (VALS loc); eauto. i. des.
  esplits. econs; eauto.
  { econs; ss.
    { eapply LOCAL. }
    { i. refl. }
  }
  destruct lc0 as [tvw0 prom]. ss.
  set (tvw1 := (TView.read_tview
                  tvw0 loc
                  (View.rlx (TView.cur tvw0) loc) released ord)).
  assert (OTHERPLN: forall loc0 (NEQ: loc0 <> loc),
             tvw1.(TView.cur).(View.pln) loc0 = tvw0.(TView.cur).(View.pln) loc0).
  { i. ss. des_ifs. ss. rewrite timemap_bot_join_r.
    unfold TimeMap.join. eapply TimeFacts.le_join_l.
    unfold View.singleton_ur_if. des_ifs; ss.
    { rewrite timemap_singleton_neq; auto. eapply Time.bot_spec. }
    { eapply Time.bot_spec. }
  }
  assert (RLX: forall loc0, tvw1.(TView.cur).(View.rlx) loc0 = tvw0.(TView.cur).(View.rlx) loc0).
  { i. ss. des_ifs. ss. rewrite timemap_bot_join_r.
    unfold TimeMap.join. eapply TimeFacts.le_join_l.
    unfold View.singleton_ur_if. des_ifs; ss.
    { eapply TimeMap.singleton_spec. refl. }
    { eapply TimeMap.singleton_spec. refl. }
  }
  remember tvw1. clear tvw1 Heqt.
  econs; eauto; ss.
  { ii. ss. rewrite RLX. eapply CONS; eauto. }
  { i. rewrite RLX. eauto. }
  { i. destruct (Loc.eq_dec loc0 loc); auto.
    rewrite OTHERPLN in MAX; eauto.
  }
Qed.

Lemma sim_thread_sol_write_na
      c vs P D mem0 lc0 sc loc val
      (SIM: sim_thread_sol c vs P D mem0 lc0)
      (LOCAL: Local.wf lc0 mem0)
      (MEM: Memory.closed mem0)
      lang st
  :
  (exists to, Local.racy_write_step lc0 mem0 loc to Ordering.na)
  \/
  exists lc1 mem1 lc2 mem2 from to msgs kinds kind,
    (<<STEPS: rtc (@Thread.tau_step _)
                  (Thread.mk lang st lc0 sc mem0)
                  (Thread.mk _ st lc1 sc mem1)>>) /\
    (<<WRITE: Local.write_na_step lc1 sc mem1 loc from to val Ordering.na lc2 sc mem2 msgs kinds kind>>) /\
    (<<SIM: sim_thread_sol c (fun loc0 => if Loc.eq_dec loc0 loc then val else vs loc0) (fun loc0 => if (Loc.eq_dec loc0 loc) then true else P loc0) (fun loc0 => if (Loc.eq_dec loc0 loc) then false else D loc0) mem2 lc2>>)
.
Proof.
  destruct lc0 as [tvw0 prom0].
  destruct (classic (exists val released, <<MAX: max_readable mem0 prom0 loc (tvw0.(TView.cur).(View.pln) loc) val released>>)).
  2:{ left. inv SIM.
      exploit non_max_readable_race; eauto. i. des. eauto. }
  right. des.
  inv SIM. hexploit max_readable_na_write_step; eauto.
  { i. exploit NSYNC; eauto. }
  { refl. }
  { eapply Time.incr_spec. }
  { eapply Time.incr_spec. }
  i. des. esplits.
  { eapply reserve_future_steps. eapply cancel_future_reserve_future; eauto. }
  { eauto. }
  assert (OTHERPLN: forall loc0 (NEQ: loc0 <> loc),
             tvw1.(TView.cur).(View.pln) loc0 = tvw0.(TView.cur).(View.pln) loc0).
  { inv WRITE. i. ss. des_ifs. ss.
    unfold TimeMap.join. eapply TimeFacts.le_join_l.
    rewrite timemap_singleton_neq; auto. eapply Time.bot_spec.
  }
  assert (OTHERRLX: forall loc0 (NEQ: loc0 <> loc),
             tvw1.(TView.cur).(View.rlx) loc0 = tvw0.(TView.cur).(View.rlx) loc0).
  { inv WRITE. i. ss. des_ifs. ss.
    unfold TimeMap.join. eapply TimeFacts.le_join_l.
    rewrite timemap_singleton_neq; auto. eapply Time.bot_spec.
  }
  assert (SAMERLX: tvw1.(TView.cur).(View.rlx) loc = tvw1.(TView.cur).(View.pln) loc).
  { rewrite VIEW. inv WRITE. clarify. ss.
    unfold TimeMap.join. rewrite timemap_singleton_eq.
    eapply TimeFacts.le_join_r.
    hexploit (VALS loc). i. des.
    eapply Memory.max_ts_spec in GET. des. etrans; eauto.
    left. etrans; eapply Time.incr_spec.
  }
  econs.
  { ii. ss. rewrite PROMISES in PROMISE. des_ifs.
    rewrite OTHERRLX; eauto.
  }
  { ii. ss. rewrite PROMISES in GET. des_ifs. eauto. }
  { ii. ss. rewrite PROMISES in GET. des_ifs. eapply NSYNC in GET; eauto. }
  { ii. ss. des_ifs.
    { rewrite SAMERLX. rewrite VIEW. inv MAX0. eauto. }
    { erewrite Memory.add_o; eauto.
      erewrite Memory.add_o; eauto. des_ifs.
      { ss. des; clarify. }
      { ss. des; clarify. }
      clear o. rewrite OTHERRLX; auto.
      inv LOWER. rewrite OTHER; auto.
    }
  }
  { i. ss. des_ifs.
    inv WRITE. clarify. eapply na_write_unchanged_loc in WRITE0; eauto.
    eapply cancel_future_unchanged_loc in RESERVE; eauto. des.
    rewrite OTHERPLN in MAX1; auto.
    des. eapply PERM. eapply unchanged_loc_max_readable; [..|eauto].
    { etrans; eauto. }
    { etrans; eauto. }
  }
Qed.

Lemma write_tview_other_rlx
      tvw sc loc ts ord loc0
      (NEQ: loc0 <> loc)
  :
  (TView.write_tview tvw sc loc ts ord).(TView.cur).(View.rlx) loc0 = tvw.(TView.cur).(View.rlx) loc0.
Proof.
  ss. des_ifs. ss.
  unfold TimeMap.join. eapply TimeFacts.le_join_l.
  rewrite timemap_singleton_neq; auto. eapply Time.bot_spec.
Qed.

Lemma write_tview_other_pln
      tvw sc loc ts ord loc0
      (NEQ: loc0 <> loc)
  :
  (TView.write_tview tvw sc loc ts ord).(TView.cur).(View.pln) loc0 = tvw.(TView.cur).(View.pln) loc0.
Proof.
  ss. des_ifs. ss.
  unfold TimeMap.join. eapply TimeFacts.le_join_l.
  rewrite timemap_singleton_neq; auto. eapply Time.bot_spec.
Qed.

Lemma write_tview_same_pln
      tvw sc loc ts ord
      (WRITABLE: TView.writable tvw.(TView.cur) sc loc ts ord)
      (TVIEW: TView.wf tvw)
  :
  (TView.write_tview tvw sc loc ts ord).(TView.cur).(View.pln) loc = ts.
Proof.
  ss. unfold TimeMap.join.
  rewrite timemap_singleton_eq; auto. eapply TimeFacts.le_join_r.
  transitivity (View.rlx (TView.cur tvw) loc).
  { eapply TVIEW. }
  { left. eapply WRITABLE. }
Qed.

Lemma write_tview_same_rlx
      tvw sc loc ts ord
      (WRITABLE: TView.writable tvw.(TView.cur) sc loc ts ord)
  :
  (TView.write_tview tvw sc loc ts ord).(TView.cur).(View.rlx) loc = ts.
Proof.
  ss. unfold TimeMap.join.
  rewrite timemap_singleton_eq; auto. eapply TimeFacts.le_join_r.
  left. eapply WRITABLE.
Qed.

Lemma sim_thread_sol_write
      c vs P D mem0 lc0 sc loc ord val
      (SIM: sim_thread_sol c vs P D mem0 lc0)
      (LOCAL: Local.wf lc0 mem0)
      (MEM: Memory.closed mem0)
  :
  exists lc1 mem1 from to released kind,
    (<<WRITE: Local.write_step lc0 sc mem0 loc from to val None released ord lc1 sc mem1 kind>>) /\
    (<<SIM: sim_thread_sol c (fun loc0 => if Loc.eq_dec loc0 loc then val else vs loc0) (fun loc0 => if (Loc.eq_dec loc0 loc) then true else P loc0) D mem1 lc1>>)
.
Proof.
  Local Opaque TView.write_tview.
  destruct lc0 as [tvw0 prom0].
  assert (exists lc1 mem1 from to released kind,
             (<<WRITE: Local.write_step (Local.mk tvw0 prom0) sc mem0 loc from to val None released ord lc1 sc mem1 kind>>) /\
             (<<CONS: Local.promise_consistent lc1>>) /\
             (<<NSYNC: forall loc, Memory.nonsynch_loc loc lc1.(Local.promises)>>) /\
             (<<GET: forall from0 to0 msg0 (GET: Memory.get loc to0 lc1.(Local.promises) = Some (from0, msg0)),
               exists from1, Memory.get loc to0 prom0 = Some (from1, msg0)>>)).
  { set (msg := fun ts => Message.concrete val (TView.write_released tvw0 sc loc ts None ord)).
    assert (MSGWF: forall ts, Message.wf (msg ts)).
    { i. unfold msg. econs.
      eapply TViewFacts.write_future0; eauto. eapply LOCAL.
    }
    assert (MSGTO: forall ts (WRITABLE: TView.writable tvw0.(TView.cur) sc loc ts ord), Memory.message_to (msg ts) loc ts).
    { i. econs. eapply writable_message_to; eauto.
      { eapply LOCAL. }
      { eapply WRITABLE. }
      { eapply Time.bot_spec. }
    }
    hexploit (cell_elements_least (prom0 loc) (fun _ => True)).
    i. des.
    { assert (TS: Time.lt from to).
      { hexploit memory_get_ts_strong; eauto. i. des; clarify.
        inv LOCAL. ss. specialize (BOT loc). setoid_rewrite GET in BOT. ss.
      }
      set (ts := Time.middle from to).
      hexploit (Time.middle_spec TS). i. des.
      assert (WRITABLE: TView.writable tvw0.(TView.cur) sc loc ts ord).
      { econs. eapply TimeFacts.le_lt_lt; [|eauto].
        inv SIM. hexploit (VALS loc). i. des.
        eapply memory_get_from_mon; eauto.
        { eapply LOCAL. eauto. }
        exploit CONS; eauto. eapply DEBT; eauto.
      }
      hexploit (@Memory.split_exists prom0 loc from ts to (msg ts) msg0); eauto.
      i. des.
      hexploit Memory.split_exists_le.
      { eapply LOCAL. }
      { eauto. }
      i. des.
      hexploit Memory.remove_exists.
      { eapply Memory.split_get0 in H1. des. eapply GET2. }
      i. des.
      assert (WRITE: Memory.write prom0 mem0 loc from ts (msg ts) mem3 mem1 (Memory.op_kind_split to msg0)).
      { econs; eauto.
        { econs 2; eauto.
          { ss. }
          { inv SIM. eapply DEBT; eauto. }
        }
      }
      esplits.
      { econs; eauto. inv SIM. eauto. }
      { ii. ss. destruct (Loc.eq_dec loc0 loc).
        { subst. rewrite write_tview_same_rlx; auto.
          erewrite Memory.remove_o in PROMISE; eauto.
          erewrite Memory.split_o in PROMISE; eauto. des_ifs.
          { ss. des; clarify. }
          { ss. des; clarify. eapply LEAST in PROMISE; eauto.
            eapply TimeFacts.lt_le_lt; eauto.
          }
        }
        { rewrite write_tview_other_rlx; auto. inv SIM. eapply CONS; eauto.
          ss. erewrite <- Memory.write_get_diff_promise; eauto.
        }
      }
      { ii. ss. inv SIM. erewrite Memory.remove_o in GET0; eauto.
        erewrite Memory.split_o in GET0; eauto. des_ifs.
        { ss. des; clarify. eapply NSYNC in GET; eauto. }
        { eapply NSYNC in GET0; eauto. }
      }
      { i. ss. erewrite Memory.remove_o in GET0; eauto.
        erewrite Memory.split_o in GET0; eauto. des_ifs.
        { ss. des; clarify. esplits. eauto. }
        { eauto. }
      }
    }
    { assert (WRITABLE: TView.writable tvw0.(TView.cur) sc loc (Time.incr (Memory.max_ts loc mem0)) ord).
      { econs. inv SIM. hexploit (VALS loc). i. des.
        eapply Memory.max_ts_spec in GET. des.
        eapply TimeFacts.le_lt_lt.
        { eapply MAX. }
        { eapply Time.incr_spec. }
      }
      hexploit (@Memory.add_exists mem0 loc (Memory.max_ts loc mem0) (Time.incr (Memory.max_ts loc mem0))); eauto.
      { i. eapply Memory.max_ts_spec in GET2. des.
        symmetry. eapply interval_le_disjoint. auto.
      }
      { eapply Time.incr_spec. }
      i. des.
      hexploit Memory.add_exists_le.
      { eapply LOCAL. }
      { eauto. }
      i. des. esplits.
      { econs; eauto.
        { econs; eauto.
          { econs; eauto. i. ss.
            hexploit Memory.max_ts_spec; eauto. i. des.
            eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
            { eapply Time.incr_spec. }
            etrans.
            { eapply memory_get_ts_le. eauto. }
            { eauto. }
          }
          { hexploit Memory.remove_exists.
            { eapply Memory.add_get0. eapply H0. }
            i. des. eapply MemoryMerge.add_remove in H0; eauto.
            subst. eauto.
          }
        }
        { inv SIM. eauto. }
      }
      { ii. ss. destruct (Loc.eq_dec loc0 loc).
        { subst. eapply EMPTY in PROMISE. ss. }
        { rewrite write_tview_other_rlx; auto. inv SIM. eapply CONS; eauto. }
      }
      { inv SIM. eauto. }
      { eauto. }
    }
  }
  des. esplits; eauto. inv SIM. inv WRITE. ss. econs; eauto; ss.
  { i. destruct (Loc.eq_dec loc0 loc).
    { subst. eapply GET in GET0. des. eauto. }
    { erewrite Memory.write_get_diff_promise in GET0; eauto. }
  }
  { i. des_ifs.
    { rewrite write_tview_same_rlx; auto.
      esplits. eapply Memory.write_get2; eauto.
    }
    { rewrite write_tview_other_rlx; auto.
      erewrite Memory.write_get_diff; eauto.
    }
  }
  { i. des_ifs.
    rewrite write_tview_other_pln in MAX; auto.
    eapply write_unchanged_loc in WRITE0; eauto. des.
    eapply PERM; eauto. eapply unchanged_loc_max_readable; eauto.
  }
Qed.


Require Import Raft.
Require Import CommonTheorems.
Require Import SpecLemmas.
Require Import RaftRefinementInterface.
Require Import CroniesTermInterface.

Require Import CroniesCorrectInterface.
Require Import CandidateEntriesInterface.

Require Import RefinementSpecLemmas.
Require Import RefinementCommonTheorems.

Require Import UpdateLemmas.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Require Import PrevLogCandidateEntriesTermInterface.

Section PrevLogCandidateEntriesTerm.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.
  Context {cei : candidate_entries_interface}.
  Context {cti : cronies_term_interface}.
  Context {cci : cronies_correct_interface}.

  Lemma prevLog_candidateEntriesTerm_init :
    refined_raft_net_invariant_init prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_init, prevLog_candidateEntriesTerm.
    simpl. intuition.
  Qed.

  Lemma candidateEntriesTerm_ext : forall t sigma sigma',
      (forall h, sigma' h = sigma h) ->
      candidateEntriesTerm t sigma ->
      candidateEntriesTerm t sigma'.
  Proof using.
    unfold candidateEntriesTerm.
    intros. break_exists_exists.
    repeat find_higher_order_rewrite. intuition.
  Qed.

  Lemma candidateEntriesTerm_same : forall st st' t,
       candidateEntriesTerm t st ->
       (forall h, cronies (fst (st' h)) = cronies (fst (st h))) ->
       (forall h, currentTerm (snd (st' h)) = currentTerm (snd (st h))) ->
       (forall h, type (snd (st' h)) = type (snd (st h))) ->
       candidateEntriesTerm t st'.
  Proof using.
    unfold candidateEntriesTerm.
    intros. break_exists_exists.
    repeat find_higher_order_rewrite.
    intuition.
  Qed.

  Ltac update_destruct :=
    match goal with
      | [ H : context [ update _ ?x _ ?y ] |- _ ] =>
        destruct (name_eq_dec x y); subst; rewrite_update; simpl in *
      | [  |- context [ update _ ?x _ ?y ] ] =>
        destruct (name_eq_dec x y); subst; rewrite_update; simpl in *
    end.

  Lemma prevLog_candidateEntriesTerm_client_request :
    refined_raft_net_invariant_client_request prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_client_request, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - eapply candidateEntriesTerm_ext; eauto.
      eapply candidateEntriesTerm_same; eauto; intros;
      update_destruct; auto.
      + now erewrite update_elections_data_client_request_cronies by eauto.
      + find_apply_lem_hyp handleClientRequest_type. intuition.
      + find_apply_lem_hyp handleClientRequest_type. intuition.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and. subst. simpl in *.
      exfalso. eapply handleClientRequest_no_append_entries; eauto.
      find_rewrite. eauto 10.
  Qed.

  Lemma update_elections_data_timeout_cronies :
    forall h d out d' l t,
      handleTimeout h (snd d) = (out, d', l) ->
      cronies (update_elections_data_timeout h d) t = cronies (fst d) t \/
      (t = currentTerm d' /\ type d' = Candidate /\
       cronies (update_elections_data_timeout h d) t = votesReceived d').
  Proof using.
    unfold update_elections_data_timeout.
    intros.
    repeat break_match; repeat find_inversion; simpl; auto.
    break_match; auto.
  Qed.

  Lemma handleClientRequest_preserves_candidateEntriesTerm:
    forall net h d t out l,
      refined_raft_intermediate_reachable net ->
      handleTimeout h (snd (nwState net h)) = (out, d, l) ->
      candidateEntriesTerm t (nwState net) ->
      candidateEntriesTerm t
                           (update (nwState net) h
                                   (update_elections_data_timeout h (nwState net h), d)).
  Proof using cti.
    unfold candidateEntriesTerm.
    intros.
    break_exists_exists. break_and.
    match goal with
    | [ H : handleTimeout _ _ = _ |- _ ] =>
      pose proof H;
        eapply update_elections_data_timeout_cronies with (t := t) in H
    end. break_or_hyp.
    - update_destruct; auto.
      find_copy_apply_lem_hyp handleTimeout_type_strong.
      intuition; repeat find_rewrite; auto.
      find_apply_lem_hyp wonElection_exists_voter.
      break_exists.
      find_apply_lem_hyp in_dedup_was_in.
      find_copy_apply_lem_hyp cronies_term_invariant; auto.
      simpl in *.
      omega.
    - update_destruct; auto.
      find_copy_apply_lem_hyp handleTimeout_type_strong.
      find_apply_lem_hyp wonElection_exists_voter.
      break_exists.
      find_apply_lem_hyp in_dedup_was_in.
      find_copy_apply_lem_hyp cronies_term_invariant; auto.
      intuition; subst; repeat find_rewrite; auto;
      simpl in *; omega.
  Qed.

  Lemma prevLog_candidateEntriesTerm_timeout :
    refined_raft_net_invariant_timeout prevLog_candidateEntriesTerm.
  Proof using cti.
    unfold refined_raft_net_invariant_timeout, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - eapply candidateEntriesTerm_ext; eauto.
      eapply handleClientRequest_preserves_candidateEntriesTerm; eauto.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      subst. simpl in *.
      exfalso. eapply handleTimeout_not_is_append_entries; eauto.
      find_rewrite. eauto 10.
  Qed.

  Lemma handleAppendEntries_preserves_candidateEntriesTerm :
    forall net h t n pli plt es ci d m t',
      handleAppendEntries h (snd (nwState net h)) t n pli plt es ci = (d, m) ->
      refined_raft_intermediate_reachable net ->
      candidateEntriesTerm t' (nwState net) ->
      candidateEntriesTerm t' (update (nwState net) h
                                 (update_elections_data_appendEntries
                                    h
                                    (nwState net h) t n pli plt es ci, d)).
  Proof using.
    unfold candidateEntriesTerm.
    intros.
    break_exists_exists. break_and.
    update_destruct.
    - rewrite update_elections_data_appendEntries_cronies.
      find_apply_lem_hyp handleAppendEntries_type.
      intuition; subst; repeat find_rewrite; auto.
      discriminate.
    - intuition.
  Qed.

  Lemma prevLog_candidateEntriesTerm_append_entries :
    refined_raft_net_invariant_append_entries prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_append_entries, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
      eapply candidateEntriesTerm_ext; eauto.
      eapply handleAppendEntries_preserves_candidateEntriesTerm; eauto.
    - exfalso. eapply handleAppendEntries_not_append_entries; eauto.
      simpl in *. subst. eauto 10.
  Qed.

  Lemma handleAppendEntriesReply_preserves_candidateEntriesTerm :
  forall net h h' t es r st' ms t',
    handleAppendEntriesReply h (snd (nwState net h)) h' t es r = (st', ms) ->
    refined_raft_intermediate_reachable net ->
    candidateEntriesTerm t' (nwState net) ->
    candidateEntriesTerm t' (update (nwState net) h (fst (nwState net h), st')).
  Proof using.
    unfold candidateEntriesTerm.
    intros. break_exists_exists.
    find_apply_lem_hyp handleAppendEntriesReply_type.
    update_destruct.
    - intuition; repeat find_rewrite; auto. discriminate.
    - auto.
  Qed.

  Lemma prevLog_candidateEntriesTerm_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_append_entries_reply, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
      eapply candidateEntriesTerm_ext; eauto.
      eauto using handleAppendEntriesReply_preserves_candidateEntriesTerm.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      find_apply_lem_hyp handleAppendEntriesReply_packets.
      subst. simpl in *. intuition.
  Qed.

  Lemma update_elections_data_requestVote_cronies_same :
    forall h h' t lli llt st,
      cronies (update_elections_data_requestVote h h' t h' lli llt st) =
      cronies (fst st).
  Proof using.
    unfold update_elections_data_requestVote.
    intros.
    repeat break_match; auto.
  Qed.

  Lemma advanceCurrentTerm_same_or_type_follower :
    forall st t,
      advanceCurrentTerm st t = st \/
      type (advanceCurrentTerm st t) = Follower.
  Proof using.
    unfold advanceCurrentTerm.
    intros. repeat break_match; auto.
  Qed.

  Lemma handleRV_advanceCurrentTerm_preserves_candidateEntriesTerm :
    forall net h h' t lli llt t',
      candidateEntriesTerm t' (nwState net) ->
      candidateEntriesTerm t'
                       (update (nwState net) h
                               (update_elections_data_requestVote h h' t h' lli llt (nwState net h),
                                advanceCurrentTerm (snd (nwState net h)) t)).
  Proof using.
    unfold candidateEntriesTerm.
    intros.
    break_exists_exists.
    update_destruct; intuition.
    - now rewrite update_elections_data_requestVote_cronies_same.
    - intros.
      match goal with
      | [ H : context [advanceCurrentTerm ?st ?t] |- _ ] =>
        pose proof advanceCurrentTerm_same_or_type_follower st t
      end.
      intuition.
      + repeat find_rewrite. auto.
      + congruence.
  Qed.

  Lemma handleRequestVote_preserves_candidateEntriesTerm :
    forall net h h' t lli llt d t' m,
      handleRequestVote h (snd (nwState net h)) t h' lli llt = (d, m) ->
      candidateEntriesTerm t' (nwState net) ->
      candidateEntriesTerm t' (update (nwState net) h
                                 (update_elections_data_requestVote
                                    h h' t h' lli llt (nwState net h), d)).
  Proof using.
    unfold candidateEntriesTerm.
    intros.
    break_exists_exists.
    update_destruct; intuition.
    - now rewrite update_elections_data_requestVote_cronies_same.
    - unfold handleRequestVote, advanceCurrentTerm in *.
      repeat break_match; do_bool; repeat find_inversion; simpl in *; break_and; try discriminate; auto.
  Qed.

  Lemma prevLog_candidateEntriesTerm_request_vote :
    refined_raft_net_invariant_request_vote prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_request_vote, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
      eapply candidateEntriesTerm_ext; eauto.
      eapply handleRequestVote_preserves_candidateEntriesTerm; eauto.
    - exfalso. eapply handleRequestVote_no_append_entries; eauto.
      simpl in *. subst. eauto 10.
  Qed.

  Lemma handleRequestVoteReply_preserves_candidateEntriesTerm :
    forall net h h' t r st' t',
      handleRequestVoteReply h (snd (nwState net h)) h' t r = st' ->
      refined_raft_intermediate_reachable net ->
      candidateEntriesTerm t' (nwState net) ->
      candidateEntriesTerm t' (update (nwState net) h
                                 (update_elections_data_requestVoteReply h h' t r (nwState net h),
                                  st')).
  Proof using cci.
    unfold candidateEntriesTerm.
    intros.
    break_exists_exists.
    update_destruct; auto.
    break_and.
    unfold raft_data in *. simpl in *.
    unfold update_elections_data_requestVoteReply.
    match goal with
    | |- context [handleRequestVoteReply ?h ?st ?h' ?t ?r] =>
      remember (handleRequestVoteReply h st h' t r) as new_state
    end; find_copy_apply_lem_hyp handleRequestVoteReply_spec.
    repeat (break_match); intuition; repeat find_rewrite; intuition;
    simpl; break_if; auto.
    - find_apply_lem_hyp cronies_correct_invariant.
      unfold cronies_correct in *. intuition.
      unfold votes_received_leaders in *.
      match goal with
      | H :  Leader = _ |- _ =>
        symmetry in H
      end. find_apply_hyp_hyp.
      eapply wonElection_no_dup_in;
        eauto using NoDup_dedup, in_dedup_was_in, dedup_In.
    - destruct (serverType_eq_dec (type (snd (nwState net x))) Leader); intuition.
      find_apply_lem_hyp cronies_correct_invariant; auto.
      eapply wonElection_no_dup_in;
        eauto using NoDup_dedup, in_dedup_was_in, dedup_In.
  Qed.

  Lemma prevLog_candidateEntriesTerm_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply prevLog_candidateEntriesTerm.
  Proof using cci.
    unfold refined_raft_net_invariant_request_vote_reply, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp.
    find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
    eapply candidateEntriesTerm_ext; eauto.
    subst.
    eapply handleRequestVoteReply_preserves_candidateEntriesTerm; eauto.
  Qed.

  Lemma doLeader_preserves_candidateEntriesTerm :
    forall net gd d h os d' ms t',
      nwState net h = (gd, d) ->
      doLeader d h = (os, d', ms) ->
      candidateEntriesTerm t' (nwState net) ->
      candidateEntriesTerm t' (update (nwState net) h (gd, d')).
  Proof using.
    unfold candidateEntriesTerm.
    intros. break_exists_exists.
    break_and.
    update_destruct; auto.
    split.
    - match goal with
      | [ H : nwState ?net ?h = (?x, _) |- _ ] =>
        replace (x) with (fst (nwState net h)) in * by (rewrite H; auto)
      end.
      intuition.
    - match goal with
      | [ H : nwState ?net ?h = (_, ?x) |- _ ] =>
        replace (x) with (snd (nwState net h)) in * by (rewrite H; auto); clear H
      end.
      find_apply_lem_hyp doLeader_type.
      intuition. subst. repeat find_rewrite.
      auto.
  Qed.

  Lemma getNextIndex_ext :
    forall st st' h,
      nextIndex st' = nextIndex st ->
      log st' = log st ->
      getNextIndex st' h = getNextIndex st h.
  Proof using.
    unfold getNextIndex.
    intros.
    repeat find_rewrite.
    auto.
  Qed.

  Lemma replicaMessage_ext :
    forall st st' h h',
      nextIndex st' = nextIndex st ->
      log st' = log st ->
      currentTerm st' = currentTerm st ->
      commitIndex st' = commitIndex st ->
      replicaMessage st' h h' = replicaMessage st h h'.
  Proof using.
    unfold replicaMessage.
    intros.
    repeat break_match; repeat tuple_inversion; repeat find_rewrite;
    erewrite getNextIndex_ext in * by eauto; congruence.
  Qed.

  Lemma prevLog_candidateEntriesTerm_do_leader :
    refined_raft_net_invariant_do_leader prevLog_candidateEntriesTerm.
  Proof using cei.
    unfold refined_raft_net_invariant_do_leader, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - find_apply_hyp_hyp.
      eapply candidateEntriesTerm_ext; eauto.
      eapply doLeader_preserves_candidateEntriesTerm; eauto.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      subst. simpl in *.
      find_copy_eapply_lem_hyp doLeader_messages; eauto.
      break_and. intuition.
      + omega.
      + break_exists. break_and.
        red.
        find_apply_lem_hyp candidate_entries_invariant.
        unfold CandidateEntries, candidateEntries_host_invariant in *.
        find_apply_lem_hyp findAtIndex_elim. break_and.
        match goal with
        | [ H : nwState ?net ?h = (?y, ?x) |- _ ] =>
          replace (x) with (snd (nwState net h)) in * by (rewrite H; auto);
          replace (y) with (fst (nwState net h)) in * by (rewrite H; auto)
        end.

        eapply_prop_hyp In In.
        subst.
        find_eapply_lem_hyp (doLeader_preserves_candidateEntries); eauto.

        match goal with
        | [ H : nwState ?net ?h = (?y, ?x) |- _ ] => clear H
        end.

        unfold candidateEntries in *. break_exists_exists.
        find_higher_order_rewrite.
        update_destruct; auto.
  Qed.

  Lemma doGenericServer_preserves_candidateEntriesTerm :
    forall net gd d h os d' ms t,
      nwState net h = (gd, d) ->
      doGenericServer h d = (os, d', ms) ->
      candidateEntriesTerm t (nwState net) ->
      candidateEntriesTerm t (update (nwState net) h (gd, d')).
  Proof using.
    intros.
    find_apply_lem_hyp doGenericServer_type. break_and.
    eapply candidateEntriesTerm_same; eauto.
    - intros. update_destruct; auto.
      find_rewrite. simpl. auto.
    - intros. update_destruct; auto.
      repeat find_rewrite.  auto.
    - intros. update_destruct; auto.
      repeat find_rewrite.  auto.
  Qed.

  Lemma prevLog_candidateEntriesTerm_do_generic_server :
    refined_raft_net_invariant_do_generic_server prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_do_generic_server, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp. break_or_hyp.
    - eapply candidateEntriesTerm_ext; eauto.
      eapply doGenericServer_preserves_candidateEntriesTerm; eauto.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      subst. simpl in *.
      find_apply_lem_hyp doGenericServer_packets. subst. simpl in *. intuition.
  Qed.

  Lemma prevLog_candidateEntriesTerm_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_state_same_packet_subset, prevLog_candidateEntriesTerm.
    simpl. intros.
    find_apply_hyp_hyp.
    eapply candidateEntriesTerm_ext with (sigma := (nwState net)).
    - auto.
    - eauto.
  Qed.

  Lemma prevLog_candidateEntriesTerm_reboot :
    refined_raft_net_invariant_reboot prevLog_candidateEntriesTerm.
  Proof using.
    unfold refined_raft_net_invariant_reboot, prevLog_candidateEntriesTerm, reboot.
    simpl. intros.
    eapply candidateEntriesTerm_ext; eauto.
    repeat find_rewrite.
    find_apply_hyp_hyp.
    unfold candidateEntriesTerm in *.
    break_exists_exists.
    update_destruct; auto.
    repeat find_rewrite.
    simpl in *. intuition.
    discriminate.
  Qed.

  Lemma prevLog_candidateEntriesTerm_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      prevLog_candidateEntriesTerm net.
  Proof using cci cti cei rri.
    intros.
    apply refined_raft_net_invariant; auto.
    - apply prevLog_candidateEntriesTerm_init.
    - apply prevLog_candidateEntriesTerm_client_request.
    - apply prevLog_candidateEntriesTerm_timeout.
    - apply prevLog_candidateEntriesTerm_append_entries.
    - apply prevLog_candidateEntriesTerm_append_entries_reply.
    - apply prevLog_candidateEntriesTerm_request_vote.
    - apply prevLog_candidateEntriesTerm_request_vote_reply.
    - apply prevLog_candidateEntriesTerm_do_leader.
    - apply prevLog_candidateEntriesTerm_do_generic_server.
    - apply prevLog_candidateEntriesTerm_state_same_packet_subset.
    - apply prevLog_candidateEntriesTerm_reboot.
  Qed.

  Instance plceti : prevLog_candidateEntriesTerm_interface.
  Proof.
    constructor.
    apply prevLog_candidateEntriesTerm_invariant.
  Qed.
End PrevLogCandidateEntriesTerm.


Require Import Ensembles.
Require Import AST.
Require Import Floats.
Require Import Metatheory.
Require Import alist.
Require Import monad.
Require Import targetdata.
Require Import genericvalues.
Require Import Values.
Require Import Memory.
Require Import Integers.
Require Import Coqlib.
Require Import syntax.
Require Import typings.
Require Import static.
Require Import opsem.
Require Import opsem_props.
Require Import opsem_wf.
Require Import vellvm_tactics.

Import LLVMsyntax.
Import LLVMgv.
Import LLVMtd.
Import LLVMtypings.

(* This file defines the non-deterministic instance of Vellvm's operational
   semantics. *)

(* NDGVs implements the signature of GenericValues. *)
Module MNDGVs.

Lemma singleton_inhabited : forall U (x:U), Inhabited U (Singleton U x).
Proof.
  intros. apply Inhabited_intro with (x:=x); auto using In_singleton.
Qed.

Lemma full_set_inhabited : forall U,
  (exists x:U, True) -> Inhabited U (Full_set U).
Proof.
  intros. inversion H.
  apply Inhabited_intro with (x:=x); auto using Full_intro.
Qed.

Definition t := Ensemble GenericValue.
Definition instantiate_gvs (gv : GenericValue) (gvs : t) : Prop :=
  Ensembles.In _ gvs gv.
Definition inhabited (gvs : t) : Prop := Ensembles.Inhabited _ gvs.
Hint Unfold instantiate_gvs inhabited.
Definition cundef_gvs gv ty : t :=
match ty with
| typ_int sz => fun gv => exists z, gv = (Vint (sz-1) z, Mint (sz - 1))::nil
| typ_floatpoint fp_float =>
    fun gv => exists f, gv = (Val.singleoffloat (Vfloat f), Mfloat32)::nil
| typ_floatpoint fp_double => fun gv => exists f, gv = (Vfloat f, Mfloat64)::nil
| typ_pointer _ =>
    fun gv => exists b, exists ofs, gv = (Vptr b ofs, AST.Mint 31)::nil
| _ => Singleton GenericValue gv
end.

Definition undef_gvs gv ty : t :=
match ty with
| typ_int sz =>
    Ensembles.Union _ (Singleton _ gv)
      (fun gv => exists z, gv = (Vint (sz-1) z, Mint (sz-1))::nil)
| typ_floatpoint fp_float =>
    Ensembles.Union _ (Singleton _ gv)
      (fun gv => exists f, gv = (Val.singleoffloat (Vfloat f), Mfloat32)::nil)
| typ_floatpoint fp_double =>
    Ensembles.Union _ (Singleton _ gv)
      (fun gv => exists f, gv = (Vfloat f, Mfloat64)::nil)
| typ_pointer _ =>
    Ensembles.Union _ (Singleton _ gv)
      (fun gv => exists b, exists ofs, gv = (Vptr b ofs, AST.Mint 31)::nil)
| _ => Singleton GenericValue gv
end.

Definition cgv2gvs (gv:GenericValue) ty : t :=
match gv with
| (Vundef, _)::nil => cundef_gvs gv ty
| _ => Singleton _ gv
end.

Definition gv2gvs (gv:GenericValue) (ty:typ) : t :=
match gv with
| (Vundef, _)::nil => undef_gvs gv ty
| _ => Singleton GenericValue gv
end.

Notation "gv @ gvs" :=
  (instantiate_gvs gv gvs) (at level 43, right associativity).
Notation "$ gv # t $" := (gv2gvs gv t) (at level 41).

Lemma cundef_gvs__getTypeSizeInBits : forall S los nts gv t sz al gv',
  wf_typ S (los,nts) t ->
  _getTypeSizeInBits_and_Alignment los
    (getTypeSizeInBits_and_Alignment_for_namedts (los,nts) true) true t =
      Some (sz, al) ->
  Coqlib.nat_of_Z (Coqlib.ZRdiv (Z_of_nat sz) 8) = sizeGenericValue gv ->
  gv' @ (cundef_gvs gv t) ->
  Coqlib.nat_of_Z (Coqlib.ZRdiv (Z_of_nat sz) 8) =
    sizeGenericValue gv'.
Proof.
  intros S los nts gv t sz al gv' Hwft Heq1 Heq2 Hin.
  destruct_typ t; simpl in *;
    try solve [inv Heq1; inv Hin; erewrite int_typsize; eauto |
               inv Heq1; inv Hin; eauto].
    destruct f; try solve [inv Heq1; inv Hin; eauto].
    inv Heq1. inv Hin. inv H. simpl. auto.
Qed.

Lemma cundef_gvs__matches_chunks : forall S los nts gv t gv',
  wf_typ S (los,nts) t ->
  gv_chunks_match_typ (los, nts) gv t ->
  gv' @ (cundef_gvs gv t) ->
  gv_chunks_match_typ (los, nts) gv' t.
Proof.
  intros S los nts gv t gv' Hwft Heq1 Hin.
  unfold gv_chunks_match_typ, vm_matches_typ in *.
  inv_mbind.
  destruct_typ t; simpl in *; uniq_result;
    try solve [inv Heq1; inv Hin; auto].

    inv Heq1; inv Hin.
    constructor; auto.
    split; auto. simpl. split; auto. apply Int.unsigned_range.

    destruct f; uniq_result; inv Heq1; inv Hin; eauto.
      constructor; auto.
      split; auto. simpl. rewrite Float.singleoffloat_idem. auto.

      constructor; auto.
      split; auto. simpl. auto.

    inv Heq1. inv Hin. inv H.
    constructor; auto.
    split; auto. simpl. auto.
Qed.

Lemma cundef_gvs__inhabited : forall gv ty, inhabited (cundef_gvs gv ty).
Proof.
  destruct_typ ty; simpl;
    try solve [eapply Ensembles.Inhabited_intro; constructor].
    eapply Ensembles.Inhabited_intro.
      exists (Int.zero (s0-1)). auto.

    destruct f; try solve [
      eapply Ensembles.Inhabited_intro; exists Float.zero; auto |
      eapply Ensembles.Inhabited_intro; constructor].

    eapply Ensembles.Inhabited_intro.
      exists Mem.nullptr. exists (Int.repr 31 0). auto.
Qed.

Lemma undef_gvs__getTypeSizeInBits : forall S los nts gv t sz al gv',
  wf_typ S (los,nts) t ->
  _getTypeSizeInBits_and_Alignment los
    (getTypeSizeInBits_and_Alignment_for_namedts (los,nts) true) true t =
      Some (sz, al) ->
  Coqlib.nat_of_Z (Coqlib.ZRdiv (Z_of_nat sz) 8) = sizeGenericValue gv ->
  gv' @ (undef_gvs gv t) ->
  Coqlib.nat_of_Z (Coqlib.ZRdiv (Z_of_nat sz) 8) =
    sizeGenericValue gv'.
Proof.
  intros S los nts gv t sz al gv' Hwft Heq1 Heq2 Hin.
  destruct_typ t; simpl in *;
    try solve [inv Heq1; inv Hin; erewrite int_typsize; eauto |
               inv Heq1; inv Hin; eauto].

    inv Heq1; inv Hin; inv H; unfold Size.to_nat;
      try solve [eauto | erewrite int_typsize; eauto].

    destruct f; try solve [inv Heq1; inv Hin; eauto |
                           inv Heq1; inv Hin; inv H; auto].

    inv Heq1; inv Hin; inv H; auto.
      inv H0. auto.
Qed.

Lemma undef_gvs__matches_chunks : forall S los nts gv t gv',
  wf_typ S (los,nts) t ->
  gv_chunks_match_typ (los, nts) gv t ->
  gv' @ (undef_gvs gv t) ->
  gv_chunks_match_typ (los, nts) gv' t.
Proof.
  intros S los nts gv t gv' Hwft Heq1 Hin.
  unfold gv_chunks_match_typ, vm_matches_typ in *.
  inv_mbind.
  destruct_typ t; simpl in *; uniq_result; try solve [
    inv Heq1; inv Hin; eauto
  ].

    inv Heq1; inv Hin; inv H.
    constructor; auto.
    constructor; auto.
      split; auto. split; auto. apply Int.unsigned_range.

    destruct f; uniq_result; try solve [
      inv Heq1; inv Hin; eauto
    ].

      inv Heq1; inv Hin; inv H.
      constructor; auto.
      constructor; auto.
        split; auto. simpl. rewrite Float.singleoffloat_idem. auto.

      inv Heq1; inv Hin; inv H.
      constructor; auto.
      constructor; auto.
        split; auto. simpl. auto.

    inv Heq1; inv Hin; inv H; try solve [congruence | auto].
      match goal with
      | H1: exists _:_, _ |- _ => inv H1;
         constructor; try solve [auto | split; simpl; auto]
      end.
Qed.

Lemma undef_gvs__inhabited : forall gv ty, inhabited (undef_gvs gv ty).
Proof.
  destruct_typ ty; simpl; try solve [
    eapply Ensembles.Inhabited_intro; apply Union_introl; constructor |
    eapply Ensembles.Inhabited_intro; constructor].

    destruct f; try solve [
      eapply Ensembles.Inhabited_intro; apply Union_introl; constructor |
      eapply Ensembles.Inhabited_intro; constructor].
Qed.

Lemma cgv2gvs__getTypeSizeInBits : forall S los nts gv t sz al gv',
  wf_typ S (los,nts) t ->
  _getTypeSizeInBits_and_Alignment los
    (getTypeSizeInBits_and_Alignment_for_namedts (los,nts) true) true t =
      Some (sz, al) ->
  Coqlib.nat_of_Z (Coqlib.ZRdiv (Z_of_nat sz) 8) = sizeGenericValue gv ->
  gv' @ (cgv2gvs gv t) ->
  Coqlib.nat_of_Z (Coqlib.ZRdiv (Z_of_nat sz) 8) =
    sizeGenericValue gv'.
Proof.
  intros S los nts gv t sz al gv' Hwft Heq1 Heq2 Hin.
  destruct gv; simpl in *.
    inv Hin. simpl. auto.

    destruct p.
    destruct v; try solve [inv Hin; simpl; auto].
    destruct gv; try solve [inv Hin; simpl; auto].
      eapply cundef_gvs__getTypeSizeInBits in Hin; eauto.
Qed.

Lemma cgv2gvs__matches_chunks : forall S los nts gv t gv',
  wf_typ S (los,nts) t ->
  gv_chunks_match_typ (los, nts) gv t ->
  instantiate_gvs gv' (cgv2gvs gv t) ->
  gv_chunks_match_typ (los, nts) gv' t.
Proof.
  intros S los nts gv t gv' Hwft Heq1 Hin.
  unfold gv_chunks_match_typ, vm_matches_typ in *.
  inv_mbind.
  destruct gv as [|[]]; simpl in *.
    inv Hin. simpl. auto.

    destruct v; try solve [inv Hin; simpl; auto].
    destruct gv; try solve [inv Hin; simpl; auto].
      eapply cundef_gvs__matches_chunks in Hin;
        unfold gv_chunks_match_typ, vm_matches_typ in *; simpl in *; eauto.
        rewrite <- HeqR in Hin. auto.
        rewrite <- HeqR. auto.
Qed.

Lemma cgv2gvs__inhabited : forall gv t, inhabited (cgv2gvs gv t).
Proof.
  intros gv t.
  destruct gv; simpl.
    apply Ensembles.Inhabited_intro with (x:=nil).
    apply Ensembles.In_singleton.

    destruct p.
    destruct v; auto using singleton_inhabited, cundef_gvs__inhabited.
    destruct gv; auto using singleton_inhabited, cundef_gvs__inhabited.
Qed.

Lemma gv2gvs__getTypeSizeInBits : forall S los nts gv t sz al,
  wf_typ S (los,nts) t ->
  _getTypeSizeInBits_and_Alignment los
    (getTypeSizeInBits_and_Alignment_for_namedts (los,nts) true) true t =
      Some (sz, al) ->
  Coqlib.nat_of_Z (Coqlib.ZRdiv (Z_of_nat sz) 8) = sizeGenericValue gv ->
  forall gv', gv' @ (gv2gvs gv t) ->
  sizeGenericValue gv' = Coqlib.nat_of_Z (Coqlib.ZRdiv (Z_of_nat sz) 8).
Proof.
  intros S los nts gv t sz al Hwft Heq1 Heq2 gv' Hin.
  destruct gv; simpl in *.
    inv Hin. simpl. auto.

    destruct p.
    destruct v; try solve [inv Hin; simpl; auto].
    destruct gv; try solve [inv Hin; simpl; auto].
      eapply undef_gvs__getTypeSizeInBits in Hin; eauto.
Qed.

Lemma gv2gvs__matches_chunks : forall S los nts gv t,
  wf_typ S (los,nts) t ->
  gv_chunks_match_typ (los, nts) gv t ->
  forall gv', gv' @ (gv2gvs gv t) ->
  gv_chunks_match_typ (los, nts) gv' t.
Proof.
  intros S los nts gv t Hwft Heq1 gv' Hin.
  unfold gv_chunks_match_typ, vm_matches_typ in *.
  inv_mbind.
  destruct gv as [|[]]; simpl in *.
    inv Hin. simpl. auto.

    destruct v; try solve [inv Hin; simpl; auto].
    destruct gv; try solve [inv Hin; simpl; auto].
      eapply undef_gvs__matches_chunks in Hin;
        unfold gv_chunks_match_typ, vm_matches_typ in *; simpl in *; eauto.
        rewrite <- HeqR in Hin. auto.
        rewrite <- HeqR. auto.
Qed.

Lemma gv2gvs__inhabited : forall gv t, inhabited ($ gv # t $).
Proof.
  intros gv t.
  destruct gv; simpl.
    apply Ensembles.Inhabited_intro with (x:=nil).
    apply Ensembles.In_singleton.

    destruct p.
    destruct v; auto using singleton_inhabited, undef_gvs__inhabited.
    destruct gv; auto using singleton_inhabited, undef_gvs__inhabited.
Qed.

Definition lift_op1 (f: GenericValue -> option GenericValue) gvs1 ty : option t
  :=
  Some (fun gv2 => exists gv1, exists gv2',
    gv1 @ gvs1 /\ f gv1 = Some gv2' /\ (gv2 @ $ gv2' # ty $)).

Definition lift_op2 (f: GenericValue -> GenericValue -> option GenericValue)
  gvs1 gvs2 ty : option t :=
  Some (fun gv3 => exists gv1, exists gv2, exists gv3',
    gv1 @ gvs1 /\ gv2 @ gvs2 /\ f gv1 gv2 = Some gv3' /\ (gv3 @ $ gv3' # ty $)).

Lemma lift_op1__inhabited : forall f gvs1 ty gvs2
  (H:forall x, exists z, f x = Some z),
  inhabited gvs1 ->
  lift_op1 f gvs1 ty = Some gvs2 ->
  inhabited gvs2.
Proof.
  intros. inv H1. inv H0.
  destruct (@H x) as [z J].
  destruct (@gv2gvs__inhabited z ty).
  exists x0. unfold Ensembles.In. exists x. exists z.
  rewrite J.
  repeat (split; auto).
Qed.

Lemma lift_op2__inhabited : forall f gvs1 gvs2 ty gv3
  (H:forall x y, exists z, f x y = Some z),
  inhabited gvs1 -> inhabited gvs2 ->
  lift_op2 f gvs1 gvs2 ty = Some gv3 ->
  inhabited gv3.
Proof.
  intros. inv H0. inv H1. inv H2.
  destruct (@H x x0) as [z J].
  destruct (@gv2gvs__inhabited z ty).
  exists x1. unfold Ensembles.In. exists x. exists x0. exists z.
  rewrite J.
  repeat (split; auto).
Qed.

Lemma lift_op1__isnt_stuck : forall f gvs1 ty
  (H:forall x, exists z, f x = Some z),
  exists gvs2, lift_op1 f gvs1 ty = Some gvs2.
Proof.
  intros. unfold lift_op1. eauto.
Qed.

Lemma lift_op2__isnt_stuck : forall f gvs1 gvs2 ty
  (H:forall x y, exists z, f x y = Some z),
  exists gv3, lift_op2 f gvs1 gvs2 ty = Some gv3.
Proof.
  intros. unfold lift_op2. eauto.
Qed.

Lemma lift_op1__getTypeSizeInBits : forall S los nts f g t sz al gvs,
  wf_typ S (los,nts) t ->
  _getTypeSizeInBits_and_Alignment los
    (getTypeSizeInBits_and_Alignment_for_namedts (los,nts) true) true t =
      Some (sz, al) ->
  (forall x y, x @ g -> f x = Some y ->
   sizeGenericValue y = nat_of_Z (ZRdiv (Z_of_nat sz) 8)) ->
  lift_op1 f g t = Some gvs ->
  forall gv : GenericValue,
  gv @ gvs ->
  sizeGenericValue gv = nat_of_Z (ZRdiv (Z_of_nat sz) 8).
Proof.
  intros. inv H2.
  destruct H3 as [x [y [J1 [J2 J3]]]].
  apply H1 in J2; auto.
  eapply gv2gvs__getTypeSizeInBits; eauto.
Qed.

Lemma lift_op1__matches_chunks : forall S los nts f g t gvs
  (Hwft: wf_typ S (los,nts) t),
  (forall x y, x @ g -> f x = Some y ->
   gv_chunks_match_typ (los, nts) y t) ->
  lift_op1 f g t = Some gvs ->
  forall gv : GenericValue,
  gv @ gvs ->
  gv_chunks_match_typ (los, nts) gv t.
Proof.
  intros. inv H0.
  destruct H1 as [x [y [J1 [J2 J3]]]].
  apply H in J2; auto.
  eapply gv2gvs__matches_chunks; eauto.
Qed.

Lemma lift_op2__getTypeSizeInBits : forall S los nts f g1 g2 t sz al gvs,
  wf_typ S (los,nts) t ->
  _getTypeSizeInBits_and_Alignment los
    (getTypeSizeInBits_and_Alignment_for_namedts (los,nts) true) true t =
      Some (sz, al) ->
  (forall x y z, x @ g1 -> y @ g2 -> f x y = Some z ->
   sizeGenericValue z = nat_of_Z (ZRdiv (Z_of_nat sz) 8)) ->
  lift_op2 f g1 g2 t = Some gvs ->
  forall gv : GenericValue,
  gv @ gvs ->
  sizeGenericValue gv = nat_of_Z (ZRdiv (Z_of_nat sz) 8).
Proof.
  intros. inv H2.
  destruct H3 as [x [y [z [J1 [J2 [J3 J4]]]]]].
  apply H1 in J3; auto.
  eapply gv2gvs__getTypeSizeInBits; eauto.
Qed.

Lemma lift_op2__matches_chunks : forall S los nts f g1 g2 t gvs
  (Hwft: wf_typ S (los,nts) t),
  (forall x y z, x @ g1 -> y @ g2 -> f x y = Some z ->
   gv_chunks_match_typ (los, nts) z t) ->
  lift_op2 f g1 g2 t = Some gvs ->
  forall gv : GenericValue,
  gv @ gvs ->
  gv_chunks_match_typ (los, nts) gv t.
Proof.
  intros. inv H0.
  destruct H1 as [x [y [z [J1 [J2 [J3 J4]]]]]].
  apply H in J3; auto.
  eapply gv2gvs__matches_chunks; eauto.
Qed.

Lemma inhabited_inv : forall gvs, inhabited gvs -> exists gv, gv @ gvs.
Proof.
  intros. inv H; eauto.
Qed.

Lemma instantiate_undef__undef_gvs : forall gv t, gv @ (undef_gvs gv t).
Proof.
  intros. unfold undef_gvs.
  destruct_typ t0; try solve [apply Union_introl; constructor | constructor].
  destruct f;
    try solve [apply Union_introl; constructor | constructor].
Qed.

Lemma instantiate_gv__gv2gvs : forall gv t, gv @ ($ gv # t $).
Proof.
  intros.
  destruct gv; simpl; try constructor.
  destruct p; simpl; try constructor.
  destruct v; simpl; try constructor.
  destruct gv; simpl;
    try solve [constructor | auto using instantiate_undef__undef_gvs].
Qed.

Lemma none_undef2gvs_inv : forall gv gv' t,
  gv @ $ gv' # t $ -> (forall mc, (Vundef, mc)::nil <> gv') -> gv = gv'.
Proof.
  intros.
  destruct gv'; try solve [inv H; auto].
  destruct p.
  destruct v; try solve [inv H; auto].
  destruct gv'; try solve [inv H; auto].
  assert (J:=@H0 m). congruence.
Qed.

End MNDGVs.

Definition NDGVs : GenericValues := mkGVs
MNDGVs.t
MNDGVs.instantiate_gvs
MNDGVs.inhabited
MNDGVs.cgv2gvs
MNDGVs.gv2gvs
MNDGVs.lift_op1
MNDGVs.lift_op2
MNDGVs.cgv2gvs__getTypeSizeInBits
MNDGVs.cgv2gvs__matches_chunks
MNDGVs.cgv2gvs__inhabited
MNDGVs.gv2gvs__getTypeSizeInBits
MNDGVs.gv2gvs__matches_chunks
MNDGVs.gv2gvs__inhabited
MNDGVs.lift_op1__inhabited
MNDGVs.lift_op2__inhabited
MNDGVs.lift_op1__isnt_stuck
MNDGVs.lift_op2__isnt_stuck
MNDGVs.lift_op1__getTypeSizeInBits
MNDGVs.lift_op2__getTypeSizeInBits
MNDGVs.lift_op1__matches_chunks
MNDGVs.lift_op2__matches_chunks
MNDGVs.inhabited_inv
MNDGVs.instantiate_gv__gv2gvs
MNDGVs.none_undef2gvs_inv.


Require Import GhostSimulations.
Require Import Raft.

Require Import UpdateLemmas.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Require Import RaftRefinementInterface.
Require Import SpecLemmas.
Require Import RefinementSpecLemmas.

Require Import AllEntriesVotesWithLogInterface.
Require Import AllEntriesLogInterface.
Require Import VotesWithLogTermSanityInterface.
Require Import VotesCorrectInterface.
Require Import VotesVotesWithLogCorrespondInterface.

Section AllEntriesVotesWithLog.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.
  Context {aeli : allEntries_log_interface}.
  Context {vwltsi : votesWithLog_term_sanity_interface}.
  Context {vvwlci : votes_votesWithLog_correspond_interface}.
  Context {vci : votes_correct_interface}.

  Ltac update_destruct :=
    match goal with
      | [ |- context [ update _ ?y _ ?x ] ] => destruct (name_eq_dec y x)
    end.

  Ltac update_destruct_hyp :=
    match goal with
      | [ _ : context [ update _ ?y _ ?x ] |- _ ] => destruct (name_eq_dec y x)
    end.

  Ltac destruct_update :=
    repeat (first [update_destruct_hyp|update_destruct]; subst; rewrite_update).

  Lemma update_elections_data_appendEntries_allEntries' :
    forall h st t h' pli plt es ci t' e,
      In (t', e) (allEntries (update_elections_data_appendEntries h st t h' pli plt es ci)) ->
      In (t', e) (allEntries (fst st)) \/ currentTerm (snd st) <= t'.
  Proof using.
    intros. unfold update_elections_data_appendEntries in *.
    repeat break_match; auto. simpl in *.
    do_in_app. intuition. do_in_map. find_inversion.
    right.
    unfold handleAppendEntries in *.
    repeat break_match; find_inversion; simpl in *; do_bool; auto.
  Qed.

  Lemma allEntries_votesWithLog_append_entries :
    refined_raft_net_invariant_append_entries allEntries_votesWithLog.
  Proof using vwltsi.
    red. unfold allEntries_votesWithLog. intros. simpl in *.
    repeat find_higher_order_rewrite.
    destruct_update; simpl in *.
    - find_eapply_lem_hyp votesWithLog_update_elections_data_append_entries; eauto.
      find_copy_apply_lem_hyp votesWithLog_term_sanity_invariant; eauto.
      find_eapply_lem_hyp update_elections_data_appendEntries_allEntries'; eauto.
      intuition; do 2 (unfold raft_data, ghost_data in *; simpl in *); try omega.
      eapply_prop_hyp votesWithLog votesWithLog; eauto. intuition.
      right. break_exists_exists. intuition.
      find_higher_order_rewrite. destruct_update; simpl in *; auto.
      rewrite update_elections_data_appendEntries_leaderLogs. auto.
    - eapply_prop_hyp votesWithLog votesWithLog; eauto. intuition.
      right. break_exists_exists. intuition.
      find_higher_order_rewrite. destruct_update; simpl in *; auto.
      rewrite update_elections_data_appendEntries_leaderLogs. auto.
  Qed.

  Lemma allEntries_votesWithLog_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply allEntries_votesWithLog.
  Proof using.
    red. unfold allEntries_votesWithLog. intros. simpl in *.
    repeat find_higher_order_rewrite.
    destruct_update; simpl in *;
    eapply_prop_hyp votesWithLog votesWithLog; eauto; intuition;
    right; break_exists_exists; intuition;
    find_higher_order_rewrite; destruct_update; simpl in *; auto.
  Qed.

  Definition currentTerm_votedFor_votesWithLog net :=
    forall h t n,
      (currentTerm (snd (nwState net h)) = t /\
       votedFor (snd (nwState net h)) = Some n) ->
      exists l,
        In (t, n, l) (votesWithLog (fst (nwState net h))).

  Lemma currentTerm_votedFor_votesWithLog_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      currentTerm_votedFor_votesWithLog net.
  Proof using vci vvwlci.
    unfold currentTerm_votedFor_votesWithLog. intros.
    eapply votes_votesWithLog_correspond_invariant; eauto.
    break_and.
    eapply votes_correct_invariant; eauto.
  Qed.

  Lemma handleRequestVote_currentTerm_leaderId' :
    forall h st t c li lt st' m,
      handleRequestVote h st t c li lt = (st', m) ->
      votedFor st' <> votedFor st ->
      currentTerm st < currentTerm st' \/
      leaderId st = None.
  Proof using.
    intros. unfold handleRequestVote, advanceCurrentTerm in *.
    repeat (break_match; try find_inversion; simpl in *; auto);
    do_bool; auto; congruence.
  Qed.

  Lemma handleRequestVote_currentTerm :
    forall h st t src lli llt st' m,
      handleRequestVote h st t src lli llt = (st', m) ->
      currentTerm st <= currentTerm st'.
  Proof using.
    intros.
    unfold handleRequestVote, advanceCurrentTerm in *.
    repeat break_match; find_inversion; simpl in *; do_bool; auto.
  Qed.

  Lemma votesWithLog_update_elections_data_request_vote :
    forall net h t src lli llt st' m t' h' l',
      refined_raft_intermediate_reachable net ->
      handleRequestVote h (snd (nwState net h)) t src lli llt = (st', m) ->
      In (t', h', l') (votesWithLog (update_elections_data_requestVote h src t src lli llt (nwState net h))) ->
      In (t', h', l') (votesWithLog (fst (nwState net h))) \/
      (t' = currentTerm st' /\
       l' = log st' /\
       (leaderId (snd (nwState net h)) = None \/
        currentTerm (snd (nwState net h)) < currentTerm st')).
  Proof using.
    unfold update_elections_data_requestVote.
    intros.
    repeat break_match; repeat tuple_inversion; intuition;
    simpl in *; intuition;
    tuple_inversion; intuition; repeat (do_bool; intuition);
    try congruence;
    unfold raft_data, ghost_data in *; simpl in *;
    repeat find_rewrite; repeat find_inversion;
    find_copy_apply_lem_hyp handleRequestVote_currentTerm_leaderId;
    intuition;
    find_apply_lem_hyp handleRequestVote_currentTerm_leaderId'; repeat find_rewrite; try congruence; intuition.
  Qed.

  Lemma allEntries_votesWithLog_request_vote :
    refined_raft_net_invariant_request_vote allEntries_votesWithLog.
  Proof using aeli.
    red. unfold allEntries_votesWithLog. intros. simpl in *.
    repeat find_higher_order_rewrite.
    destruct_update; simpl in *.
    - find_rewrite_lem update_elections_data_requestVote_allEntries.
      find_copy_apply_lem_hyp handleRequestVote_currentTerm.
      find_copy_eapply_lem_hyp votesWithLog_update_elections_data_request_vote; eauto.
      intuition.
      + eapply_prop_hyp votesWithLog votesWithLog; eauto; intuition;
        right; break_exists_exists; intuition;
        find_higher_order_rewrite; destruct_update; simpl in *; auto.
        rewrite leaderLogs_update_elections_data_requestVote. auto.
      + subst.
        find_apply_lem_hyp handleRequestVote_log. repeat find_rewrite.
        find_copy_eapply_lem_hyp allEntries_log_invariant; eauto.
        intuition.
        right. break_exists_exists. repeat find_higher_order_rewrite.
        simpl in *.
        destruct_update; simpl in *; intuition;
        try rewrite leaderLogs_update_elections_data_requestVote; eauto.
      +  subst.
        find_apply_lem_hyp handleRequestVote_log. repeat find_rewrite.
        find_copy_eapply_lem_hyp allEntries_log_invariant; eauto.
        intuition.
        right. break_exists_exists. repeat find_higher_order_rewrite.
        simpl in *.
        destruct_update; simpl in *; intuition;
        try rewrite leaderLogs_update_elections_data_requestVote; eauto.
    - eapply_prop_hyp votesWithLog votesWithLog; eauto; intuition;
      right; break_exists_exists; intuition;
      find_higher_order_rewrite; destruct_update; simpl in *; auto.
      rewrite leaderLogs_update_elections_data_requestVote. auto.
  Qed.

  Lemma allEntries_votesWithLog_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply allEntries_votesWithLog.
  Proof using.
    red. unfold allEntries_votesWithLog. intros. simpl in *.
    repeat find_higher_order_rewrite.
    destruct_update; simpl in *.
    - find_rewrite_lem update_elections_data_requestVoteReply_allEntries.
      find_eapply_lem_hyp votesWithLog_update_elections_data_request_vote_reply; eauto.
      eapply_prop_hyp votesWithLog votesWithLog; eauto; intuition;
      right; break_exists_exists; intuition;
      find_higher_order_rewrite; destruct_update; simpl in *; auto.
      eauto using update_elections_data_requestVoteReply_old.
    - eapply_prop_hyp votesWithLog votesWithLog; eauto; intuition;
      right; break_exists_exists; intuition;
      find_higher_order_rewrite; destruct_update; simpl in *; auto.
      eauto using update_elections_data_requestVoteReply_old.
  Qed.

  Lemma update_elections_data_client_request_allEntries_in_or_term :
    forall h st client id c out st' ms t e,
      handleClientRequest h (snd st) client id c = (out, st', ms) ->
      In (t, e) (allEntries (update_elections_data_client_request h st client id c)) ->
      In (t, e) (allEntries (fst st)) \/
      t = currentTerm (snd st).
  Proof using.
    intros.
    intros.
    unfold update_elections_data_client_request in *.
    repeat break_match; repeat find_inversion; auto.
    simpl in *. intuition.
    find_inversion. repeat find_rewrite. intuition.
    unfold handleClientRequest in *.
    break_match; find_inversion; simpl in *; auto.
  Qed.

  Lemma allEntries_votesWithLog_client_request :
    refined_raft_net_invariant_client_request allEntries_votesWithLog.
  Proof using vwltsi.
    red. unfold allEntries_votesWithLog. intros. simpl in *.
    repeat find_higher_order_rewrite.
    destruct_update; simpl in *.
    - find_copy_eapply_lem_hyp update_elections_data_client_request_allEntries_in_or_term; eauto. intuition.
      + repeat find_rewrite.
        find_eapply_lem_hyp votesWithLog_update_elections_data_client_request; eauto.
        eapply_prop_hyp votesWithLog votesWithLog; eauto; intuition;
        right; break_exists_exists; intuition;
        find_higher_order_rewrite; destruct_update; simpl in *; auto.
        rewrite update_elections_data_client_request_leaderLogs. auto.
      + subst.
        find_eapply_lem_hyp votesWithLog_update_elections_data_client_request; eauto.
        find_eapply_lem_hyp votesWithLog_term_sanity_invariant; eauto.
        repeat (unfold raft_data, ghost_data in *; simpl in *). omega.
    - eapply_prop_hyp votesWithLog votesWithLog; eauto; intuition;
        right; break_exists_exists; intuition;
        find_higher_order_rewrite; destruct_update; simpl in *; auto.
      rewrite update_elections_data_client_request_leaderLogs. auto.
  Qed.

  Lemma votesWithLog_update_elections_data_timeout' :
    forall net h out st' ps t' h' l',
      refined_raft_intermediate_reachable net ->
      handleTimeout h (snd (nwState net h)) = (out, st', ps) ->
      In (t', h', l') (votesWithLog (update_elections_data_timeout h (nwState net h))) ->
      In (t', h', l') (votesWithLog (fst (nwState net h))) \/
      (t' = currentTerm st' /\ l' = log st' /\ currentTerm (snd (nwState net h)) < currentTerm st').
  Proof using.
    unfold update_elections_data_timeout.
    intros. repeat break_match; simpl in *; intuition; repeat tuple_inversion; intuition.
    - unfold handleTimeout, tryToBecomeLeader in *.
      repeat break_match; repeat find_inversion; simpl in *; intuition.
    - unfold handleTimeout, tryToBecomeLeader in *.
      repeat break_match;  repeat find_inversion; simpl in *; congruence.
  Qed.

  Lemma allEntries_votesWithLog_timeout :
    refined_raft_net_invariant_timeout allEntries_votesWithLog.
  Proof using aeli.
    red. unfold allEntries_votesWithLog. intros. simpl in *.
    repeat find_higher_order_rewrite.
    destruct_update; simpl in *.
    - find_rewrite_lem update_elections_data_timeout_allEntries.
      find_eapply_lem_hyp votesWithLog_update_elections_data_timeout'; eauto.
      intuition.
      + eapply_prop_hyp votesWithLog votesWithLog; eauto; intuition;
        right; break_exists_exists; intuition;
        find_higher_order_rewrite; destruct_update; simpl in *; auto.
        rewrite update_elections_data_timeout_leaderLogs. auto.
      + subst.
        find_copy_apply_lem_hyp handleTimeout_log_same. repeat find_rewrite.
        find_apply_lem_hyp allEntries_log_invariant; eauto. intuition.
        right.
        break_exists_exists; intuition;
        find_higher_order_rewrite; destruct_update; simpl in *; auto;
        rewrite update_elections_data_timeout_leaderLogs; auto.
    - eapply_prop_hyp votesWithLog votesWithLog; eauto; intuition;
      right; break_exists_exists; intuition;
      find_higher_order_rewrite; destruct_update; simpl in *; auto.
      rewrite update_elections_data_timeout_leaderLogs; auto.
  Qed.

  Lemma allEntries_votesWithLog_do_leader :
    refined_raft_net_invariant_do_leader allEntries_votesWithLog.
  Proof using.
    red. unfold allEntries_votesWithLog. intros. simpl in *.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    eapply_prop_hyp votesWithLog votesWithLog; eauto; intuition;
    right; break_exists_exists; intuition;
    find_higher_order_rewrite; destruct_update; simpl in *; auto.
  Qed.

  Lemma allEntries_votesWithLog_do_generic_server :
    refined_raft_net_invariant_do_generic_server allEntries_votesWithLog.
  Proof using.
    red. unfold allEntries_votesWithLog. intros. simpl in *.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    eapply_prop_hyp votesWithLog votesWithLog; eauto; intuition;
    right; break_exists_exists; intuition;
    find_higher_order_rewrite; destruct_update; simpl in *; auto.
  Qed.

  Lemma allEntries_votesWithLog_init :
    refined_raft_net_invariant_init allEntries_votesWithLog.
  Proof using.
    red. unfold allEntries_votesWithLog. intros. simpl in *. intuition.
  Qed.

  Lemma allEntries_votesWithLog_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset allEntries_votesWithLog.
  Proof using.
    red. unfold allEntries_votesWithLog in *. intros.
    repeat find_reverse_higher_order_rewrite.
    copy_eapply_prop_hyp votesWithLog votesWithLog; eauto. intuition. right.
    break_exists_exists. repeat find_higher_order_rewrite. auto.
  Qed.

  Lemma allEntries_votesWithLog_reboot :
    refined_raft_net_invariant_reboot allEntries_votesWithLog.
  Proof using.
    red. unfold allEntries_votesWithLog in *. intros. simpl in *.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    repeat find_higher_order_rewrite.
    subst. unfold reboot in *.
    destruct_update; simpl in *; eauto; copy_eapply_prop_hyp votesWithLog votesWithLog; eauto;
    repeat find_rewrite; intuition;
    right; break_exists_exists; intuition; find_higher_order_rewrite;
    destruct_update; simpl in *; auto.
  Qed.

  Theorem allEntries_votesWithLog_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      allEntries_votesWithLog net.
  Proof using vwltsi aeli rri.
    intros.
    eapply refined_raft_net_invariant; eauto.
    - exact allEntries_votesWithLog_init.
    - exact allEntries_votesWithLog_client_request.
    - exact allEntries_votesWithLog_timeout.
    - exact allEntries_votesWithLog_append_entries.
    - exact allEntries_votesWithLog_append_entries_reply.
    - exact allEntries_votesWithLog_request_vote.
    - exact allEntries_votesWithLog_request_vote_reply.
    - exact allEntries_votesWithLog_do_leader.
    - exact allEntries_votesWithLog_do_generic_server.
    - exact allEntries_votesWithLog_state_same_packet_subset.
    - exact allEntries_votesWithLog_reboot.
  Qed.

  Instance aevwli : allEntries_votesWithLog_interface.
  split. eauto using allEntries_votesWithLog_invariant.
  Defined.
End AllEntriesVotesWithLog.


(* If the following hold,
	All executable code resides in low memory
	All exported symbols target low memory areas
	No disassembled instructions spans a chunk boundary
	static branches target low memory chunk boundaries
	all computed jumps that do not reference the IAT are
		immediately preceded by and-masking
		instruction from Table 1 in the same chunk
	Computed jumps that read the IAT access a properly
		aligned IAT entry, and are preceded by an
		and-mask of the return address (call
		instructions must end on a chunk boundary
		rather than requiring a mask, since they push
		their own return address
	There are no trap instructions; int or syscall
THEN:
	These properties ensure that any unaligned instruction sequences
concealed within untrusted, executable sections are not reachable
at runtime.
*)

(* Actual algorithm that tests an imaginary binary - image this in
the light of FastVerifier *)

(*------------------------ COPIED AND PASTED FROM FastVerifier ----------------- *)

(* Copyright (c) 2011. Greg Morrisett, Gang Tan, Joseph Tassarotti,
   Jean-Baptiste Tristan, and Edward Gan.

   This file is part of RockSalt.

   This file 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.
*)

Require Import Coqlib.
Require Import Parser.
Require Import List.
Require Import Bits.
Require Import Decode.
Require Import X86Syntax.
Require Import Int32.
Require Import ReinsVerifierDFA.
Require Import PEFormat.
Require Import PETraversal.

Import X86_PARSER_ARG.
Import X86_PARSER.
Import X86_BASE_PARSER.

Require Coq.MSets.MSetAVL.
Require Coq.Structures.OrdersAlt.
Require Coq.MSets.MSetFacts.
Module New_Int32_OT := (Coq.Structures.OrdersAlt.Update_OT Int32_OT).
Module Int32Set := Coq.MSets.MSetAVL.Make New_Int32_OT.

Definition n_shift_add (b: bool) (x: nat) :=
  (if b then 2 * x + 1 else 2 * x)%nat.

Open Scope Z_scope.

Fixpoint n_of_bits (n: nat) (f: Z -> bool) {struct n}: nat :=
  match n with
  | O => O
  | S m => n_shift_add (f 0) (n_of_bits m (fun i => f (i + 1)))
  end.

(* Maybe tokens as nats isn't best... *)
Definition byte2token (b: int8) : token_id := Zabs_nat (Word.unsigned b).
Definition token2byte (t: token_id) : int8 := Word.repr (Z_of_nat t).

Section BUILT_DFAS.

  (* In this section we will just assume the DFAs are all built;
     that is, non_cflow_dfa should be the result of "make_dfa non_cflow_parser" and
     similarly for dir_cflow_dfa and nacljmp_dfa *)
  Variable non_cflow_dfa : DFA.
  Variable dir_cflow_dfa : DFA.
  Variable reinsjmp_nonIAT_dfa : DFA.
  Variable reinsjmp_IAT_or_RET_dfa : DFA.
  Variable reinsjmp_IAT_CALL_dfa : DFA.
  Variable reinsjmp_nonIAT_mask : parser (pair_t instruction_t instruction_t).
  Variable reinsjmp_IAT_or_RET_mask : parser (pair_t instruction_t instruction_t).
  Variable reinsjmp_IAT_CALL_p : parser instruction_t.

  (* G.T.: may be a good idea to parametrize the DFA w.r.t. the ChunkSize;
     Google's verifier allows it either to be 16 or 32.
   Parameters logChunkSize:nat.
   Hypothesis logChunkSize_range : (0 < logChunkSize <= Word.wordsize 31)%nat.
  *)

  Fixpoint parseloop (ps:X86_PARSER.instParserState) (bytes:list int8) :
    option ((prefix * instr) * list int8) :=
    match bytes with
      | nil => None
      | b::bs => match X86_PARSER.parse_byte ps b with
                   | (ps',nil) => parseloop ps' bs
                   | (_, v::_) => Some (v,bs)
                 end
    end.

  Inductive jumptype : Set :=
  | JMP_t : jumptype
  | JCC_t : jumptype
  | CALL_t: jumptype.

  Definition extract_disp_and_type bytes : option (int32 * jumptype) :=
    match (parseloop Decode.X86_PARSER.initial_parser_state bytes) with
      | Some ((_, JMP true false (Imm_op disp) None), _) => Some (disp, JMP_t)
      | Some ((_, Jcc ct disp), _) => Some (disp, JCC_t)
      | Some ((_, CALL true false (Imm_op disp) None), _) => Some (disp, CALL_t)
      | _ => None
    end.

  (* parseloop, X86_PARSER.parse_byte, and X86_PARSER.instParserState all have a
     too-restrictive type, expecting the underlying parser to parse a prefix and
     an instruction. For our reinsjmp parsers, we are parsing pairs of instructions,
     so we redefine these three functions with that in mind *)

  Record instParserState' := mkPS' {
      inst_ctxt' : ctxt_t;
      inst_regexp' : regexp (pair_t instruction_t instruction_t);
      inst_regexp_wf' : wf_regexp inst_ctxt' inst_regexp'
  }.

  Definition parse_byte' (ps:instParserState') (b:int8) :
    instParserState' * list (instr * instr) :=
    let cs := byte_explode b in
    let r' := deriv_parse' (inst_regexp' ps) cs in
    let wf' := wf_derivs (inst_ctxt' ps) cs (inst_regexp' ps) (inst_regexp_wf' ps) in
      (mkPS' (inst_ctxt' ps) r' wf', apply_null (inst_ctxt' ps) r' wf').

  Fixpoint parseloop' (ps:instParserState') (bytes:list int8) :
    option ((instr * instr) * list int8) :=
    match bytes with
      | nil => None
      | b::bs => match parse_byte' ps b with
                   | (ps',nil) => parseloop' ps' bs
                   | (_, v::_) => Some (v,bs)
                 end
    end.

  Definition extract_IAT_jmp_dest bytes : option (option address) :=
    let regexp_pair := parser2regexp reinsjmp_IAT_or_RET_mask in
    let ips := mkPS' (snd regexp_pair) (fst regexp_pair) (p2r_wf reinsjmp_IAT_or_RET_mask _) in
    match (parseloop' ips bytes) with
    | Some ((_, JMP true true (Address_op addr) None), _) => Some (Some addr)
    | Some ((_, RET _ _), _) => Some None
    | _ => None
    end.

  (* parseloop, X86_PARSER.parse_byte, and X86_PARSER.instParserState all have a
     too-restrictive type, expecting the underlying parser to parse a prefix and
     an instruction. For our IAT call extraction, we want a single instruction. *)

  Record instParserState'' := mkPS'' {
      inst_ctxt'' : ctxt_t;
      inst_regexp'' : regexp instruction_t;
      inst_regexp_wf'' : wf_regexp inst_ctxt'' inst_regexp''
  }.

  Definition parse_byte'' (ps:instParserState'') (b:int8) :
    instParserState'' * list instr :=
    let cs := byte_explode b in
    let r' := deriv_parse' (inst_regexp'' ps) cs in
    let wf' := wf_derivs (inst_ctxt'' ps) cs (inst_regexp'' ps) (inst_regexp_wf'' ps) in
      (mkPS'' (inst_ctxt'' ps) r' wf', apply_null (inst_ctxt'' ps) r' wf').

  Fixpoint parseloop'' (ps:instParserState'') (bytes:list int8) :
    option (instr * list int8) :=
    match bytes with
      | nil => None
      | b::bs => match parse_byte'' ps b with
                   | (ps',nil) => parseloop'' ps' bs
                   | (_, v::_) => Some (v,bs)
                 end
    end.

  Definition extract_IAT_call_dest bytes : option address :=
    let regexp_pair := parser2regexp (reinsjmp_IAT_CALL_p) in
    let ips := mkPS'' (snd regexp_pair) (fst regexp_pair) (p2r_wf (reinsjmp_IAT_CALL_p) _) in
    match (parseloop'' ips bytes) with
    | Some (CALL true true (Address_op addr) None, _) => Some addr
    | _ => None
    end.

  Definition is_nonIAT_call bytes : bool :=
    let regexp_pair := parser2regexp (reinsjmp_nonIAT_mask) in
    let ips := mkPS' (snd regexp_pair) (fst regexp_pair) (p2r_wf (reinsjmp_nonIAT_mask) _) in
    match (parseloop' ips bytes) with
    | Some ((_, CALL _ _ _ _), _) => true
    | _ => false
    end.

  (* Note: it's important to specify the type of tokens as "list token_id", not
     "list nat", even though token_id is defined to be nat. If a proof environment
     has one value of type "list token_id" and the other of type "list nat",
     proof scripts such as rewrite or omega may fail since token_id needs to
     be unfolded. *)

  Fixpoint process_buffer_aux (loc: int32) (n: nat) (tokens:list (list token_id))
    (curr_res: Int32Set.t * Int32Set.t * Int32Set.t * Int32Set.t) :=
    match n with
    | O => None
    | S m =>
      match curr_res with
      | (start_instrs, check_list, iat_check_list, call_check_list) =>
        match tokens with
        | nil => Some curr_res
        | chunk::rest => (* There are left over bytes in the buffer *)
          match chunk with
          | nil => process_buffer_aux loc m rest curr_res
          | _ =>
            match
             (dfa_recognize 256 non_cflow_dfa              chunk,
              dfa_recognize 256 dir_cflow_dfa              chunk,
              dfa_recognize 256 reinsjmp_nonIAT_dfa        chunk,
              dfa_recognize 256 reinsjmp_IAT_or_RET_dfa    chunk,
              dfa_recognize 256 reinsjmp_IAT_CALL_dfa      chunk) with

            (* Non-Control-Flow Only *)
            | (Some (len, remaining), None, None, None, None) =>
              process_buffer_aux (loc +32_n len) m (remaining::rest)
              (Int32Set.add loc start_instrs, check_list, iat_check_list, call_check_list)

            (* Direct Control-Flow (Only) *)
            | (None, Some (len, remaining), None, None, None) =>
              match extract_disp_and_type (List.map token2byte (firstn len chunk)) with
                | Some (disp, JMP_t)
                | Some (disp, JCC_t) =>
                  process_buffer_aux (loc +32_n len) m (remaining::rest)
                  (Int32Set.add loc start_instrs,
                   Int32Set.add (loc +32_n len +32 disp) check_list,
                   iat_check_list,
                   call_check_list)
                | Some (disp, CALL_t) =>
                  process_buffer_aux (loc +32_n len) m (remaining::rest)
                  (Int32Set.add loc start_instrs,
                   Int32Set.add (loc +32_n len +32 disp) check_list,
                   iat_check_list,
                   Int32Set.add (loc +32_n len) call_check_list)
                | _ => None
              end

            (* Non-IAT Indirect Control Flow (with Non-Control-Flow mask) *)
            | (Some res0, None, Some (len, remaining), None, None) =>
              process_buffer_aux (loc +32_n len) m (remaining::rest)
              (if is_nonIAT_call (List.map token2byte (firstn len chunk)) then
                  (Int32Set.add loc start_instrs, check_list, iat_check_list,
                   Int32Set.add (loc +32_n len) call_check_list)
              else
                  (Int32Set.add loc start_instrs, check_list, iat_check_list, call_check_list))

            (* IAT Indirect Jump or Retrun (with Non-Control-Flow mask) *)
            | (Some res0, None, None, Some (len, remaining), None) =>
              match extract_IAT_jmp_dest (List.map token2byte (firstn len chunk)) with
              (* Not an actual IAT jmp or RET (shouldn't happen) *)
              | None => None
              (* IAT jmp *)
              | Some (Some indir) =>
                process_buffer_aux (loc +32_n len) m (remaining::rest)
                (Int32Set.add loc start_instrs, check_list,
                 Int32Set.add (addrDisp indir) iat_check_list,
                 call_check_list)
              (* RET *)
              | Some None =>
                process_buffer_aux (loc +32_n len) m (remaining::rest)
                (Int32Set.add loc start_instrs, check_list, iat_check_list, call_check_list)
              end

            (* IAT Call Only (No Mask necessary) *)
            | (None, None, None, None, Some (len, remaining)) =>
              match extract_IAT_call_dest (List.map token2byte (firstn len chunk)) with
              (* Not actually an IAT call (shouldn't happen) *)
              | None => None
              (* IAT Call *)
              | Some indir =>
                process_buffer_aux (loc +32_n len) m (remaining::rest)
                (Int32Set.add loc start_instrs, check_list,
                Int32Set.add (addrDisp indir) iat_check_list,
                Int32Set.add (loc +32_n len) call_check_list)
              end

            (* None of the DFAs matched or too many DFAs matched *)
            | _ => None
            end
          end
        end
      end
    end.

  (* The idea here is, given a list of int8s representing the code,
     we call process_buffer_aux with n := length of the (flattened)
     list plus one for each sub-list; since each sub-list incurs one
     recursive call, and each instruction is at least one byte long,
     this should be enough calls to process_buffer_aux to process
     everything in the buffer, without us having to worry about
     termination proofs
     Note: one way to avoid the n is would be to show each dfa consumes
     at least one byte.
     *)
  Definition process_buffer (buffer: list (list int8)) :=
    process_buffer_aux
      (Word.repr 0)
      ((List.fold_left (fun a b => a + b)%nat (List.map (fun l => length l + 1)%nat buffer) 0%nat) + 1)
      (List.map (List.map byte2token) buffer)
      (Int32Set.empty, Int32Set.empty, Int32Set.empty, Int32Set.empty).

  Definition aligned_bool (a:int32):bool :=
    Zeq_bool (Zmod (unsigned a) chunkSize) 0.
  Definition aligned (a:int32) := aligned_bool a = true.

  Require Import Recdef.
  Function checkAligned_aux (p: Int32Set.t * Z * nat) {measure snd p}
    : bool :=
  match p with
    | (_, 0%nat) => true
    | ((startAddrs, next), len) =>
      (Int32Set.mem (repr next) startAddrs &&
       checkAligned_aux (startAddrs, (next + chunkSize),
                            (len - Zabs_nat chunkSize)%nat))
  end.
  intros. simpl. omega.
  Defined.

  (* checking that all aligned addresses between 0 and len is in startAddrs *)
  Definition checkAligned (startAddrs:Int32Set.t) (len: nat) :bool :=
    checkAligned_aux (startAddrs, 0, len).

  (* checking all jump targets are either in startAddrs or are aligned addresses *)
  Definition checkJmpTargets (jmpTargets: Int32Set.t) :=
    Int32Set.for_all aligned_bool jmpTargets.

  Definition checkIATAddresses (iat : IATBounds) (iatAddresses : Int32Set.t) : bool :=
    match iat with
    | iatbounds (start, size) =>
        let checkAddress addr :=
	     andb
                (andb (lequ start addr) (lequ addr (start +32 size)))
                (eq (modu (addr -32 start) (repr (Z_of_nat (wordsize 31)))) (repr 0)) in
          Int32Set.for_all checkAddress iatAddresses
    end.

  Definition checkCallAlignment (callAddrs : Int32Set.t) : bool :=
    Int32Set.for_all aligned_bool callAddrs.

  (* A section is in low memory if its end (start + length) is <= lowMemCutoff,
     and the addition doesn't overflow *)
  Definition checkExecSectionLowMemory (start : int32) (length : int32) : bool :=
    andb (int32_lequ_bool (start +32 length) (@repr 31 lowMemCutoff)) (checkNoOverflow start length).

  (* Given an executable section, represented as a list of bytes,
  *  check that the section obeys policy *)
  Definition checkExecSection (iat : IATBounds) (section: int32 * int32 * list (list int8)) : (bool * Int32Set.t) :=
    match section with
    | (start,len,buffer) =>
        if checkExecSectionLowMemory start len then
          match process_buffer buffer with
          | None => (false, Int32Set.empty)
          | Some (start_addrs, check_addrs, iat_check_addrs, call_check_addrs) =>
              (andb (andb (andb (checkAligned start_addrs (length buffer))
                (checkJmpTargets check_addrs)) (checkIATAddresses iat iat_check_addrs))
                (checkCallAlignment call_check_addrs),
              start_addrs)
          end
        else
          (false,Int32Set.empty)
    end.

  (* Given a PE file, check the following properties for each executable section:
   * - All executable sections reside in low memory
   * - All exported symbols target low memory chunk boundaries (checkExports)
   * - No disassembled instruction spans a chunk boundary (checkAligned)
   * - Static branches target low memory chunk boundaries (checkJmpTargets)
   * - Non-IAT computed jumps are masked (reinsjmp_nonIAT_mask)
   * - IAT computed jumps have return addr masked and actually target the iat
   *     (reinsjmp_IAT_or_RET_mask + checkIATAddresses)
   * - Call instructions end on a chunk bounary
   * - No trap instructions (will not parse)
   *)
  Definition checkProgram (data : list (list int8)) : (bool * Int32Set.t) :=
    let exec := getExecutableSections data in
    let iat := getIATBounds data in
    if checkExports data safeMask then
      let exec_check := List.map (checkExecSection iat) exec in
      let pass := List.fold_left andb (List.map (@fst _ _) exec_check) true in
      let addrs :=
        if pass then
          List.fold_left Int32Set.union (List.map (@snd _ _) exec_check) Int32Set.empty
        else
          Int32Set.empty
      in
        (pass,addrs)
    else
      (false,Int32Set.empty).

End BUILT_DFAS.

Require Import CompiledDFAs.

Definition checkProgram' (data : list (list int8)) : (bool * Int32Set.t) :=
    checkProgram
      non_cflow_dfa
      dir_cflow_dfa
      reinsjmp_nonIAT_dfa
      reinsjmp_IAT_JMP_or_RET_dfa
      reinsjmp_IAT_CALL_dfa
      reinsjmp_nonIAT_mask
      reinsjmp_IAT_JMP_or_RET_mask
      reinsjmp_IAT_CALL_p
      data.

Extraction "reinsverif.ml" checkProgram'.