Require Import CertiGraph.CertiGC.gc_spec.

Local Open Scope logic.

Lemma data_at_heaptype_eq: forall (sh: share) v h,
    isptr h -> field_compatible heap_type [StructField _spaces] h ->
    data_at sh heap_type v h = data_at sh (tarray space_type 12) v h.
Proof.
  intros. unfold_data_at (data_at _ heap_type _ _). rewrite field_at_data_at. simpl nested_field_type.
  rewrite field_address_offset; auto. simpl nested_field_offset.
  rewrite isptr_offset_val_zero; auto.
Qed.

Lemma split2_data_at_Tarray_space_type:
  forall (sh: share) (n n1: Z) (v: list (val * (val * val))) (p: val),
    0 <= n1 <= n -> n = Zlength v ->
    data_at sh (tarray space_type n) v p =
    data_at sh (tarray space_type n1) (sublist 0 n1 v) p *
    data_at sh (tarray space_type (n - n1)) (sublist n1 n v)
            (field_address0 (tarray space_type n) [ArraySubsc n1] p).
Proof.
  intros. pose proof (split2_data_at_Tarray sh space_type n n1) as HS.
  apply HS with (v' := v); auto.
  - rewrite Z.le_lteq. right; auto.
  - rewrite sublist_same; auto.
Qed.

Lemma space_array_1_eq: forall (sh: share) (v: (val * (val * val))) (p: val),
    data_at sh (tarray space_type 1) [v] p = data_at sh space_type v p.
Proof.
  intros. pose proof (data_at_singleton_array_eq sh space_type). apply H. reflexivity.
Qed.

Lemma repeat_cons {t: Type}: forall i (v: t),
    1 <= i -> repeat v (Z.to_nat i) = v :: repeat v (Z.to_nat (i - 1)).
Proof.
  intros. replace (Z.to_nat i) with (S (Z.to_nat (i - 1))).
  - simpl. auto.
  - rewrite <- Z2Nat.inj_succ by lia. f_equal. lia.
Qed.

Lemma Znth_repeat_app {X: Type} {IX: Inhabitant X}: forall i (vh v0 vn: X) l,
    1 <= i -> Znth i (vh :: repeat v0 (Z.to_nat (i - 1)) ++ vn :: l) = vn.
Proof.
  intros. rewrite Znth_pos_cons by lia.
  rewrite app_Znth2 by (rewrite Zlength_repeat; lia).
  rewrite Zlength_repeat by lia.
  replace (i - 1 - (i - 1)) with 0 by lia. rewrite Znth_0_cons. reflexivity.
Qed.

Lemma upd_Znth_repeat_app {X: Type} {IX: Inhabitant X}:
  forall i (vh v0 v1 v2: X) l,
    1 <= i -> upd_Znth i (vh :: repeat v0 (Z.to_nat (i - 1)) ++ v1 :: l) v2 =
              vh :: repeat v0 (Z.to_nat (i - 1)) ++ v2 :: l.
Proof.
  intros. rewrite app_comm_cons, upd_Znth_app2.
  - rewrite app_comm_cons. f_equal.
    rewrite Zlength_cons, Zlength_repeat by lia.
    replace (i - Z.succ (i - 1)) with 0 by lia.
    rewrite upd_Znth0. f_equal.
  - rewrite Zlength_cons, !Zlength_repeat by lia.
    replace (Z.succ (i - 1)) with i by lia.
    pose proof (Zlength_nonneg (v1 :: l)). lia.
Qed.

Lemma body_create_heap: semax_body Vprog Gprog f_create_heap create_heap_spec.
Proof.
  start_function.
  forward_call (heap_type, gv).
  Intros h. if_tac.
  - subst h; forward_if False; [| first [exfalso; now apply H | inversion H ]].
    unfold all_string_constants; Intros.
    forward_call.
    contradiction.
  - Intros. forward_if True; [contradiction | forward; entailer! |]. Intros.
    (* make "data_at sh space_type v h " in SEP *)
    assert_PROP (isptr h) by entailer!. remember (Vundef, (Vundef, Vundef)) as vn.
    assert_PROP (field_compatible heap_type [StructField _spaces] h) by entailer!.
    replace_SEP 2 (data_at Ews heap_type (default_val heap_type) h) by entailer!.
    change (default_val heap_type) with
        (repeat (Vundef, (Vundef, Vundef)) (Z.to_nat 12)).
    rewrite <- Heqvn. rewrite data_at_heaptype_eq; auto.
    rewrite (split2_data_at_Tarray_space_type Ews 12 1);
      [| lia | rewrite Zlength_repeat; lia].
    rewrite sublist_repeat by lia. simpl repeat at 1.
    rewrite space_array_1_eq. Intros. forward_call (Ews, h, Z.shiftl 1 16, gv, sh).
    (* make succeed *)
    + unfold MAX_SPACE_SIZE. compute; split; [discriminate | reflexivity].
    + Intros p0. freeze [0;1;2;3;4;6] FR.
      (* change back to "data_at sh heap_type v h" *)
      rewrite <- space_array_1_eq. rewrite sublist_repeat by lia.
      change (12 - 1) with 11 at 2.
      gather_SEP (data_at Ews (tarray space_type 1) _ h)
                 (data_at Ews (tarray space_type (12 - 1)) _ _).
      remember (p0, (p0, offset_val (WORD_SIZE * Z.shiftl 1 16) p0)) as vh.
      remember (vh :: repeat vn (Z.to_nat 11)) as vl.
      replace [vh] with (sublist 0 1 vl). 2: {
        subst vl; rewrite sublist_one; try lia.
        - rewrite Znth_0_cons; auto.
        - rewrite Zlength_cons, Zlength_repeat; lia.
      } replace (repeat  vn (Z.to_nat 11)) with (sublist 1 12 vl) by
          (rewrite Heqvl, sublist_1_cons, sublist_repeat; [reflexivity|lia..]).
      rewrite <- split2_data_at_Tarray_space_type;
        [| lia | rewrite Heqvl, Zlength_cons, Zlength_repeat; lia].
      remember (if Archi.ptr64 then
                  (Vlong (Int64.repr 0),
                   (Vlong (Int64.repr 0), Vlong (Int64.repr 0))) else
                  (Vint (Int.repr 0), (Vint (Int.repr 0), Vint (Int.repr 0)))) as v0.
      (* change succeed *) subst vl. rewrite <- data_at_heaptype_eq; auto.
      cbv [Archi.ptr64] in Heqv0.
      forward_for_simple_bound
        12
        (EX i: Z,
         PROP ( )
         LOCAL (temp _h h; gvars gv)
         SEP (data_at Ews heap_type
                      (vh :: repeat v0 (Z.to_nat (i - 1)) ++
                          repeat vn (Z.to_nat (12 - i))) h; FRZL FR))%assert.
      * entailer!.
      * Opaque Znth. forward. rewrite (repeat_cons (12 - i)) at 2 by lia.
        rewrite Znth_repeat_app by apply (proj1 H2). rewrite Heqvn at 2.
        rewrite (repeat_cons (12 - i)) by lia.
        rewrite upd_Znth_repeat_app by apply (proj1 H2). forward.
        rewrite Znth_repeat_app by apply (proj1 H2).
        rewrite upd_Znth_repeat_app by apply (proj1 H2). forward.
        rewrite Znth_repeat_app by apply (proj1 H2).
        rewrite upd_Znth_repeat_app by apply (proj1 H2).
        simpl fst.
        replace (i + 1 - 1) with i by lia. try rewrite !Int.signed_repr by rep_lia.
        rewrite <- Heqv0. replace (12 - i - 1) with (12 - (i + 1)) by lia.
        change (v0 :: repeat vn (Z.to_nat (12 - (i + 1))))
               with ([v0] ++ repeat vn (Z.to_nat (12 - (i + 1)))).
        rewrite app_assoc.
        replace (repeat v0 (Z.to_nat (i - 1)) ++ [v0]) with
            (repeat v0 (Z.to_nat i)). 1: entailer!.
        replace [v0] with (repeat v0 (Z.to_nat 1)) by (simpl; auto).
        rewrite <- repeat_app. f_equal. rewrite <- Z2Nat.inj_add by lia.
        f_equal. lia.
      * replace (12 - 12) with 0 by lia. simpl repeat at 2.
        rewrite app_nil_r. change 12 with MAX_SPACES at 2. thaw FR.
        change (Z.shiftl 1 16) with NURSERY_SIZE in *.
        assert (v0 = zero_triple) by (subst v0; unfold zero_triple; reflexivity).
        rewrite H2. forward. Exists h p0. entailer!. Transparent Znth.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import Coq.derive.Derive.
Require Import bedrock2.Syntax.
Require Import compiler.FlatToRiscvDef.
Require Import compiler.MemoryLayout.
Require Import compiler.Pipeline.
Require Import compiler.RiscvWordProperties.
Require Import coqutil.Word.Interface.
Require Import coqutil.Map.Z_keyed_SortedListMap.
Require Import coqutil.Z.HexNotation.
Require Import Bedrock2Experiments.WordProperties.
Require Import Bedrock2Experiments.StateMachineMMIO.
Require Import Bedrock2Experiments.StateMachineSemantics.
Require Import Bedrock2Experiments.Aes.Constants.
Require Import Bedrock2Experiments.Aes.Aes.
Require Import Bedrock2Experiments.Aes.AesExample.
Require Import Bedrock2Experiments.Aes.AesToRiscV.
Require Import Bedrock2Experiments.Aes.AesSemantics.
Require coqutil.Word.Naive.
Require coqutil.Map.SortedListWord.
Require riscv.Utility.InstructionNotations.
Import Syntax.Coercions.
Local Open Scope string_scope.

(* use literals for the main function *)
Existing Instance constant_literals.

(* pointers to input and output memory locations (these are dummy values) *)
Definition input_data_ptr := AES_BASE_ADDR + 0x70.
Definition input_iv_ptr := AES_BASE_ADDR + 0x80.
Definition input_key_ptr := AES_BASE_ADDR + 0x90.
Definition output_ptr := AES_BASE_ADDR + 0x70.

(* main function: simply call aes_encrypt with literal constants and pointers *)
Definition main_body : cmd :=
  cmd.call []
           aes_encrypt
           [expr.literal input_data_ptr;
           expr.literal input_key_ptr;
           expr.literal input_iv_ptr;
           expr.literal output_ptr].

Definition main : func :=
  ("main", ([], [], main_body)).

Definition funcs : list func := [main; aes_encrypt].

Derive aes_example_compile_result
       SuchThat (compile compile_ext_call (map.of_list (funcs ++ AesToRiscV.funcs))
                 = Some aes_example_compile_result)
       As aes_example_compile_result_eq.
Proof.
  (* doing a more surgical vm_compute in the lhs only avoids fully computing the map
     type, which would slow eq_refl and Qed dramatically *)
  lazymatch goal with
    |- ?lhs = _ =>
    let x := (eval vm_compute in lhs) in
    change lhs with x
  end.
  exact eq_refl.
Qed.

Definition aes_example_asm := Eval compute in fst (fst aes_example_compile_result).

Module PrintAssembly.
  Import riscv.Utility.InstructionNotations.
  Redirect "aes_example.s" Print aes_example_asm.
End PrintAssembly.


Require Import Omega.
Require Import RelationClasses.

From sflib Require Import sflib.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import Loc.

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

Require Import MemoryRel.

Set Implicit Arguments.

Inductive ftau T (step: forall (e:ThreadEvent.t) (e1 e2:T), Prop) (e:ThreadEvent.t) (e1 e2:T): Prop :=
| ftau_intro
    (TSTEP: step e e1 e2)
    (EVENT: ThreadEvent.get_event e = None)
.
Hint Constructors ftau.

Inductive with_pre {A} {E} (step: E -> A -> A -> Prop) bs : option (A*E) ->  A -> Prop :=
| swp_base:
  with_pre step bs None bs
| swp_step
    pre ms e es
    (PSTEPS: with_pre step bs pre ms)
    (PSTEP: step e ms es):
  with_pre step bs (Some(ms,e)) es
.
Hint Constructors with_pre.

Lemma with_pre_rtc_union
      A E (step: E -> A -> A -> Prop) c1 c2 pre
      (STEPS: with_pre step c1 pre c2):
  rtc (union step) c1 c2.
Proof.
  ginduction STEPS; s; i; subst; eauto.
  i. etrans; eauto.
Qed.

Lemma rtc_union_with_pre
      A E (step: E -> A -> A -> Prop) c1 c2
      (STEPS: rtc (union step) c1 c2):
  exists pre,
  with_pre step c1 pre c2.
Proof.
  apply Operators_Properties.clos_rt_rt1n_iff,
        Operators_Properties.clos_rt_rtn1_iff in STEPS.
  induction STEPS.
  { exists None. eauto. }
  des. inv H. exists (Some(y,e)). s. eauto.
Qed.

Lemma with_pre_rtc_tau
      A (step: ThreadEvent.t -> A -> A -> Prop) c1 c2 pre
      (STEPS: with_pre (ftau step) c1 pre c2):
  rtc (tau step) c1 c2.
Proof.
  ginduction STEPS; s; i; subst; eauto.
  i. etrans; eauto.
  econs 2; [|reflexivity]. inv PSTEP. eauto.
Qed.

Lemma rtc_tau_with_pre
      A (step: ThreadEvent.t -> A -> A -> Prop) c1 c2
      (STEPS: rtc (tau step) c1 c2):
  exists pre,
  with_pre (ftau step) c1 pre c2.
Proof.
  apply Operators_Properties.clos_rt_rt1n_iff,
        Operators_Properties.clos_rt_rtn1_iff in STEPS.
  induction STEPS.
  { exists None. eauto. }
  des. inv H. exists (Some(y,e)). eauto.
Qed.

Lemma with_pre_implies
      E A (step step': E -> A -> A -> Prop) c1 c2 pre
      (IMPL: forall e c1 c2 (STEP: step e c1 c2), step' e c1 c2)
      (STEPS: with_pre step c1 pre c2):
  with_pre step' c1 pre c2.
Proof.
  induction STEPS; eauto.
Qed.

Lemma with_pre_trans
      A E (step: E -> A -> A -> Prop) c1 c2 c3 pre1 pre2
      (STEPS1: with_pre step c1 pre1 c2)
      (STEPS2: with_pre step c2 pre2 c3):
  with_pre step c1 (option_app pre2 pre1) c3.
Proof.
  ginduction STEPS2; s; i; des; subst; eauto.
Qed.

Lemma local_simul_fence
      com prm prm' sc ordr ordw com' sc'
      (LOCAL: Local.fence_step (Local.mk com prm) sc ordr ordw (Local.mk com' prm') sc'):
  Local.fence_step (Local.mk com Memory.bot) sc ordr ordw (Local.mk com' Memory.bot) sc'.
Proof.
  inv LOCAL. econs; eauto.
  s. i. apply Memory.bot_nonsynch.
Qed.

Lemma local_simul_write
      cmp com com' sc sc' mS mT mT' loc from to val relr relw ord kind prm prm'
      (SUB: mem_sub cmp mS mT)
      (DISJOINT: Memory.disjoint mS prm)
      (WRITE: Local.write_step (Local.mk com prm) sc mT loc from to val relr relw ord (Local.mk com' prm') sc' mT' kind):
  exists mS',
  Local.write_step (Local.mk com Memory.bot) sc mS loc from to val relr relw ord (Local.mk com' Memory.bot) sc' mS' Memory.op_kind_add.
Proof.
  set (relw' := relw).
  assert (RELW_WF: View.opt_wf relw').
  { inv WRITE. inv WRITE0. inv PROMISE.
    - inv MEM. inv ADD. auto.
    - inv MEM. inv SPLIT. auto.
    - inv MEM. inv LOWER. auto.
  }
  inv WRITE.
  hexploit (@Memory.add_exists Memory.bot loc from to val relw'); eauto.
  { i. rewrite Memory.bot_get in *. congr. }
  { eapply MemoryFacts.write_time_lt. eauto. }
  i. des.
  hexploit (@Memory.add_exists mS loc from to val relw'); eauto.
  { i. destruct msg2.
    inv WRITE0. inv PROMISE.
    - exploit SUB; eauto. i. des.
      inv MEM. inv ADD. eauto.
    - exploit Memory.split_get0; try exact PROMISES; eauto. s. i. des.
      inv DISJOINT. exploit DISJOINT0; eauto. i. des.
      symmetry in x. eapply Interval.le_disjoint; eauto. econs; [refl|].
      inv MEM. inv SPLIT. left. auto.
    - exploit Memory.lower_get0; try exact PROMISES; eauto. s. i.
      symmetry. eapply DISJOINT; eauto.
  }
  { eapply MemoryFacts.write_time_lt. eauto. }
  i. des.
  hexploit (@Memory.remove_exists mem2 loc from to val relw'); eauto.
  { erewrite Memory.add_o; eauto. condtac; ss. des; congr. }
  i. des.
  replace mem1 with Memory.bot in H1; cycle 1.
  { apply Memory.ext. i.
    erewrite (@Memory.remove_o mem1); eauto. erewrite (@Memory.add_o mem2); eauto.
    condtac; ss. des. subst. apply Memory.bot_get.
  }
  esplits. econs; eauto.
  - econs; eauto. econs; eauto.
    inv WRITE0. by inv PROMISE.
  - s. i. splits; ss. apply Memory.bot_nonsynch.
Qed.

Inductive small_step (withprm: bool) (tid:Ident.t) (e:ThreadEvent.t) (c1:Configuration.t): forall (c2:Configuration.t), Prop :=
| small_step_intro
    lang pf st1 st2 lc1 ths2 lc2 sc2 memory2
    (TID: IdentMap.find tid c1.(Configuration.threads) = Some (existT _ lang st1, lc1))
    (STEP: Thread.step pf e (Thread.mk _ st1 lc1 c1.(Configuration.sc) c1.(Configuration.memory)) (Thread.mk _ st2 lc2 sc2 memory2))
    (THS2: ths2 = IdentMap.add tid (existT _ _ st2, lc2) c1.(Configuration.threads))
    (PFREE: orb withprm pf)
  :
  small_step withprm tid e c1 (Configuration.mk ths2 sc2 memory2)
.
Hint Constructors small_step.

Inductive small_opt_step withprm tid e: forall (c1 c2:Configuration.t), Prop :=
| small_opt_step_none
    c
    (EVENT: ThreadEvent.get_event e = None):
    small_opt_step withprm tid e c c
| small_opt_step_some
    c1 c2
    (STEP: small_step withprm tid e c1 c2):
    small_opt_step withprm tid e c1 c2
.

Definition small_step_evt withprm (tid:Ident.t) (c1 c2:Configuration.t) : Prop :=
  union (small_step withprm tid) c1 c2.
Hint Unfold small_step_evt.

Definition small_step_all withprm (c1 c2:Configuration.t) : Prop :=
  union (small_step_evt withprm) c1 c2.
Hint Unfold small_step_all.

Lemma small_step_evt_to_true
      withprm tid cST1 cST2
      (STEP: small_step_evt withprm tid cST1 cST2):
  small_step_evt true tid cST1 cST2.
Proof.
  destruct withprm; eauto.
  inv STEP. inv USTEP.
  econs. econs; eauto.
Qed.

Lemma small_step_future
      e tid c1 c2 withprm
      (WF1: Configuration.wf c1)
      (STEP: small_step withprm e tid c1 c2):
  <<WF2: Configuration.wf c2>> /\
  <<FUTURE: Memory.future c1.(Configuration.memory) c2.(Configuration.memory)>> /\
  <<SC_FUTURE: TimeMap.le  c1.(Configuration.sc) c2.(Configuration.sc)>>.
Proof.
  inv WF1. inv WF. inv STEP. ss. clear PFREE.
  exploit THREADS; ss; eauto. i.
  exploit Thread.step_future; eauto.
  s; i; des. splits; [|by eauto|by eauto]. econs; ss. econs.
  - i. Configuration.simplify.
    + exploit THREADS; try apply TH1; eauto. i. des.
      exploit Thread.step_disjoint; eauto. s. i. des.
      symmetry. auto.
    + exploit THREADS; try apply TH2; eauto. i. des.
      exploit Thread.step_disjoint; eauto. i. des.
      auto.
    + eapply DISJOINT; [|eauto|eauto]. auto.
  - i. Configuration.simplify.
    exploit THREADS; try apply TH; eauto. i.
    exploit Thread.step_disjoint; eauto. s. i. des.
    auto.
Qed.

Lemma rtc_small_step_future
      c1 c2 withprm
      (WF1: Configuration.wf c1)
      (STEP: rtc (small_step_all withprm) c1 c2):
  <<WF2: Configuration.wf c2>> /\
  <<FUTURE: Memory.future c1.(Configuration.memory) c2.(Configuration.memory)>> /\
  <<SC_FUTURE: TimeMap.le  c1.(Configuration.sc) c2.(Configuration.sc)>>.
Proof.
  revert WF1. induction STEP; i.
  - splits; eauto; reflexivity.
  - destruct H. destruct USTEP.
    exploit small_step_future; eauto. i; des.
    exploit IHSTEP; eauto. i; des.
    splits; eauto.
    + etrans; eauto.
    + etrans; eauto.
Qed.

Lemma thread_step_small_step
      lang pf e tid threads
      st1 lc1 sc1 mem1
      st2 lc2 sc2 mem2
      (TID: IdentMap.find tid threads = Some (existT _ lang st1, lc1))
      (STEP: Thread.step pf e (Thread.mk lang st1 lc1 sc1 mem1) (Thread.mk lang st2 lc2 sc2 mem2)):
  small_step true tid e
             (Configuration.mk threads sc1 mem1)
             (Configuration.mk (IdentMap.add tid (existT _ lang st2, lc2) threads) sc2 mem2).
Proof.
  econs; eauto.
Qed.

Lemma thread_step_small_step_aux
      lang pf e tid threads
      st1 lc1 sc1 mem1
      st2 lc2 sc2 mem2
      (STEP: Thread.step pf e (Thread.mk lang st1 lc1 sc1 mem1) (Thread.mk lang st2 lc2 sc2 mem2)):
  small_step true tid e
             (Configuration.mk (IdentMap.add tid (existT _ lang st1, lc1) threads) sc1 mem1)
             (Configuration.mk (IdentMap.add tid (existT _ lang st2, lc2) threads) sc2 mem2).
Proof.
  exploit thread_step_small_step; eauto.
  { eapply IdentMap.Facts.add_eq_o. eauto. }
  rewrite (IdentMap.add_add_eq tid (existT _ lang st2, lc2)). eauto.
Qed.

Lemma rtc_thread_step_rtc_small_step_aux
      lang tid threads
      th1 th2
      (TID: IdentMap.find tid threads = Some (existT _ lang th1.(Thread.state), th1.(Thread.local)))
      (STEP: (rtc (@Thread.all_step lang)) th1 th2):
  rtc (small_step_evt true tid)
      (Configuration.mk threads th1.(Thread.sc) th1.(Thread.memory))
      (Configuration.mk (IdentMap.add tid (existT _ lang th2.(Thread.state), th2.(Thread.local)) threads) th2.(Thread.sc) th2.(Thread.memory)).
Proof.
  revert threads TID. induction STEP; i.
  - apply rtc_refl. f_equal. apply IdentMap.eq_leibniz. ii.
    rewrite IdentMap.Facts.add_o. condtac; auto. subst. auto.
  - inv H. inv USTEP. destruct x, y. ss. econs 2.
    + econs; eauto.
    + etrans; [eapply IHSTEP|].
      * apply IdentMap.Facts.add_eq_o. auto.
      * apply rtc_refl. f_equal. apply IdentMap.eq_leibniz. ii.
        rewrite ? IdentMap.Facts.add_o. condtac; auto.
Qed.

Lemma rtc_thread_step_rtc_small_step
      lang tid threads
      st1 lc1 sc1 mem1
      st2 lc2 sc2 mem2
      (TID: IdentMap.find tid threads = Some (existT _ lang st1, lc1))
      (STEP: (rtc (@Thread.all_step lang)) (Thread.mk lang st1 lc1 sc1 mem1) (Thread.mk lang st2 lc2 sc2 mem2)):
  rtc (small_step_evt true tid)
      (Configuration.mk threads sc1 mem1)
      (Configuration.mk (IdentMap.add tid (existT _ lang st2, lc2) threads) sc2 mem2).
Proof.
  exploit rtc_thread_step_rtc_small_step_aux; eauto. auto.
Qed.

Lemma rtc_tau_thread_step_rtc_tau_small_step_aux
      lang tid threads
      th1 th2
      (TID: IdentMap.find tid threads = Some (existT _ lang th1.(Thread.state), th1.(Thread.local)))
      (STEP: (rtc (@Thread.tau_step lang)) th1 th2):
  rtc (tau (small_step true tid))
      (Configuration.mk threads th1.(Thread.sc) th1.(Thread.memory))
      (Configuration.mk (IdentMap.add tid (existT _ lang th2.(Thread.state), th2.(Thread.local)) threads) th2.(Thread.sc) th2.(Thread.memory)).
Proof.
  revert threads TID. induction STEP; i.
  - apply rtc_refl. f_equal. apply IdentMap.eq_leibniz. ii.
    rewrite IdentMap.Facts.add_o. condtac; auto. subst. auto.
  - inv H. inv TSTEP. destruct x, y. ss. econs 2.
    + econs; eauto.
    + etrans; [eapply IHSTEP|].
      * apply IdentMap.Facts.add_eq_o. auto.
      * apply rtc_refl. f_equal. apply IdentMap.eq_leibniz. ii.
        rewrite ? IdentMap.Facts.add_o. condtac; auto.
Qed.

Lemma rtc_tau_thread_step_rtc_tau_small_step
      lang tid threads
      st1 lc1 sc1 mem1
      st2 lc2 sc2 mem2
      (TID: IdentMap.find tid threads = Some (existT _ lang st1, lc1))
      (STEP: (rtc (@Thread.tau_step lang)) (Thread.mk lang st1 lc1 sc1 mem1) (Thread.mk lang st2 lc2 sc2 mem2)):
  rtc (tau (small_step true tid))
      (Configuration.mk threads sc1 mem1)
      (Configuration.mk (IdentMap.add tid (existT _ lang st2, lc2) threads) sc2 mem2).
Proof.
  exploit rtc_tau_thread_step_rtc_tau_small_step_aux; eauto. auto.
Qed.

Lemma tau_pf_step_small_step
      lang tid threads
      st1 lc1 sc1 mem1
      st2 lc2 sc2 mem2
      (TID: IdentMap.find tid threads = Some (existT _ lang st1, lc1))
      (STEP: tau (Thread.step true) (Thread.mk lang st1 lc1 sc1 mem1) (Thread.mk lang st2 lc2 sc2 mem2)):
  small_step_evt false tid
             (Configuration.mk threads sc1 mem1)
             (Configuration.mk (IdentMap.add tid (existT _ lang st2, lc2) threads) sc2 mem2).
Proof.
  inv STEP. econs. econs; eauto.
Qed.

Lemma tau_pf_step_small_step_aux
      lang tid threads
      st1 lc1 sc1 mem1
      st2 lc2 sc2 mem2
      (STEP: tau (Thread.step true) (Thread.mk lang st1 lc1 sc1 mem1) (Thread.mk lang st2 lc2 sc2 mem2)):
  small_step_evt false tid
             (Configuration.mk (IdentMap.add tid (existT _ lang st1, lc1) threads) sc1 mem1)
             (Configuration.mk (IdentMap.add tid (existT _ lang st2, lc2) threads) sc2 mem2).
Proof.
  exploit tau_pf_step_small_step; eauto.
  { eapply IdentMap.Facts.add_eq_o. eauto. }
  rewrite (IdentMap.add_add_eq tid (existT _ lang st2, lc2)). eauto.
Qed.

Lemma rtc_tau_pf_step_rtc_small_step_aux
      lang tid threads
      th1 th2
      (TID: IdentMap.find tid threads = Some (existT _ lang th1.(Thread.state), th1.(Thread.local)))
      (STEP: (rtc (tau (@Thread.step lang true))) th1 th2):
  rtc (small_step_evt false tid)
      (Configuration.mk threads th1.(Thread.sc) th1.(Thread.memory))
      (Configuration.mk (IdentMap.add tid (existT _ lang th2.(Thread.state), th2.(Thread.local)) threads) th2.(Thread.sc) th2.(Thread.memory)).
Proof.
  revert threads TID. induction STEP; i.
  - apply rtc_refl. f_equal. apply IdentMap.eq_leibniz. ii.
    rewrite IdentMap.Facts.add_o. condtac; auto. subst. auto.
  - inv H. destruct x, y. ss. econs 2.
    + econs; eauto.
    + etrans; [eapply IHSTEP|].
      * apply IdentMap.Facts.add_eq_o. auto.
      * apply rtc_refl. f_equal. apply IdentMap.eq_leibniz. ii.
        rewrite ? IdentMap.Facts.add_o. condtac; auto.
Qed.

Lemma rtc_tau_pf_step_rtc_small_step
      lang tid threads
      st1 lc1 sc1 mem1
      st2 lc2 sc2 mem2
      (TID: IdentMap.find tid threads = Some (existT _ lang st1, lc1))
      (STEP: (rtc (tau (@Thread.step lang true))) (Thread.mk lang st1 lc1 sc1 mem1) (Thread.mk lang st2 lc2 sc2 mem2)):
  rtc (small_step_evt false tid)
      (Configuration.mk threads sc1 mem1)
      (Configuration.mk (IdentMap.add tid (existT _ lang st2, lc2) threads) sc2 mem2).
Proof.
  exploit rtc_tau_pf_step_rtc_small_step_aux; eauto.
  eauto.
Qed.

Lemma step_small_steps
      e tid c1 c3
      (STEP: Configuration.step e tid c1 c3)
      (WF1: Configuration.wf c1)
      (CONSISTENT1: Configuration.consistent c1):
  exists c2 te,
    <<STEPS: rtc (tau (small_step true tid)) c1 c2>> /\
    <<STEP: small_step true tid te c2 c3>> /\
    <<EVENT: e = ThreadEvent.get_event te>> /\
    <<WF2: Configuration.wf c2>> /\
    <<WF3: Configuration.wf c3>> /\
    <<CONSISTENT3: Configuration.consistent c3>>.
Proof.
  exploit Configuration.step_future; eauto. i. des.
  inv STEP. destruct c1, e2. ss.
  exploit rtc_tau_thread_step_rtc_tau_small_step; eauto. i. des.
  exploit thread_step_small_step_aux; eauto. i. des.
  esplits; eauto.
  eapply rtc_small_step_future; try exact WF1.
  eapply rtc_implies, x0. i. inv H. eauto.
Qed.

Lemma small_step_find
      tid1 tid2 c1 c2 e withprm
      (STEP: small_step withprm tid1 e c1 c2)
      (TID: tid1 <> tid2):
  IdentMap.find tid2 c1.(Configuration.threads) = IdentMap.find tid2 c2.(Configuration.threads).
Proof.
  inv STEP. s.
  rewrite IdentMap.gso; eauto.
Qed.

Lemma rtc_small_step_find
      tid1 tid2 c1 c2 withprm
      (STEP: rtc (small_step_evt withprm tid1) c1 c2)
      (TID: tid1 <> tid2):
  IdentMap.find tid2 c1.(Configuration.threads) = IdentMap.find tid2 c2.(Configuration.threads).
Proof.
  induction STEP; auto.
  inv H. rewrite <-IHSTEP.
  eauto using small_step_find.
Qed.

Lemma thread_step_tview_le
     lang pf e (t1 t2: @Thread.t lang)
     (STEP: Thread.step pf e t1 t2)
     (LOCALWF: Local.wf t1.(Thread.local) t1.(Thread.memory))
     (SCWF: Memory.closed_timemap t1.(Thread.sc) t1.(Thread.memory))
     (MEMWF: Memory.closed t1.(Thread.memory)):
  TView.le t1.(Thread.local).(Local.tview) t2.(Thread.local).(Local.tview).
Proof.
  eapply Thread.step_future; eauto.
Qed.

Lemma rtc_small_step_tview_le
     c1 c2 tid lst1 lst2 lc1 lc2 withprm
     (STEPS: rtc (small_step_evt withprm tid) c1 c2)
     (THREAD1: IdentMap.find tid c1.(Configuration.threads) = Some (lst1, lc1))
     (THREAD2: IdentMap.find tid c2.(Configuration.threads) = Some (lst2, lc2))
     (WF: Configuration.wf c1):
  TView.le lc1.(Local.tview) lc2.(Local.tview).
Proof.
  ginduction STEPS; i.
  - rewrite THREAD1 in THREAD2. depdes THREAD2. reflexivity.
  - inv H. exploit small_step_future; eauto.
    intros [WF2 _].
    inv WF.
    destruct USTEP. rewrite THREAD1 in TID. depdes TID.
    etrans; [apply (thread_step_tview_le STEP)|]; eauto.
    eapply WF0; eauto.
    eapply IHSTEPS; eauto.
    s. subst. rewrite IdentMap.gss. eauto.
Qed.

Lemma small_step_write_lt
      tid c c1 e lst lc loc from ts val rel ord withprm
      (STEP: small_step withprm tid e c c1)
      (EVENT: ThreadEvent.is_writing e = Some (loc, from, ts, val, rel, ord))
      (THREAD: IdentMap.find tid (Configuration.threads c) = Some (lst, lc)):
  Time.lt (lc.(Local.tview).(TView.cur).(View.rlx) loc) ts.
Proof.
  inv STEP. rewrite THREAD in TID. inv TID.
  inv STEP0; inv STEP; ss. inv LOCAL; ss; inv EVENT.
  - inv LOCAL0. apply WRITABLE.
  - eapply TimeFacts.le_lt_lt; cycle 1.
    + inv LOCAL2. inv WRITABLE. apply TS.
    + inv LOCAL1. s. do 2 (etrans; [|apply TimeMap.join_l]). refl.
Qed.

Lemma small_step_promise_decr
      tid tid' loc ts e c1 c2 lst2 lc2 from2 msg2
      (STEPT: small_step false tid e c1 c2)
      (FIND2: IdentMap.find tid' c2.(Configuration.threads) = Some (lst2,lc2))
      (PROMISES: Memory.get loc ts lc2.(Local.promises) = Some (from2, msg2)):
  exists lst1 lc1 from1 msg1,
  <<FIND1: IdentMap.find tid' c1.(Configuration.threads) = Some (lst1,lc1)>> /\
  <<PROMISES: Memory.get loc ts lc1.(Local.promises) = Some (from1, msg1)>>.
Proof.
  inv STEPT; ss.
  revert FIND2. rewrite IdentMap.gsspec. condtac.
  - i. inv FIND2.
    inv STEP; inv STEP0;
      (try inv LOCAL);
      (try inv LOCAL0);
      (try by esplits; eauto).
    + ss. apply promise_pf_inv in PFREE; eauto. des. subst. inv PROMISE.
      destruct msg2. exploit Memory.op_get_inv; eauto.
      { econs 3. eauto. }
      i. des.
      * subst. esplits; eauto. eapply Memory.lower_get0. eauto.
      * esplits; eauto.
    + inv WRITE.
      revert PROMISES. erewrite Memory.remove_o; eauto. condtac; ss.
      guardH o. i. destruct msg2.
      exploit MemoryFacts.MemoryFacts.promise_get_promises_inv_diff; eauto.
      { ii. inv H. unguardH o. des; congr. }
      i. des. esplits; eauto.
    + inv LOCAL1.
      inv LOCAL2. inv WRITE.
      revert PROMISES. erewrite Memory.remove_o; eauto. condtac; ss.
      guardH o. i. destruct msg2.
      exploit MemoryFacts.MemoryFacts.promise_get_promises_inv_diff; eauto.
      { ii. inv H. unguardH o. des; congr. }
      i. des. esplits; eauto.
  - i. esplits; eauto.
Qed.

Corollary small_step_promise_decr_bot
      tid tid' e c1 c2 lst1 lc1 lst2 lc2
      (STEPT: small_step false tid e c1 c2)
      (FIND1: IdentMap.find tid' c1.(Configuration.threads) = Some (lst1,lc1))
      (FIND2: IdentMap.find tid' c2.(Configuration.threads) = Some (lst2,lc2))
      (PROMISES: lc1.(Local.promises) = Memory.bot):
  lc2.(Local.promises) = Memory.bot.
Proof.
  apply Memory.ext. i. setoid_rewrite Cell.bot_get.
  destruct (Memory.get loc ts (Local.promises lc2)) as [[from msg]|] eqn: EQ; eauto.
  exploit small_step_promise_decr; eauto.
  i; des. rewrite FIND0 in FIND1. inv FIND1.
  rewrite PROMISES in *.
  setoid_rewrite Cell.bot_get in PROMISES0. done.
Qed.

Lemma small_steps_promise_decr
      tid' loc ts c1 c2 lst2 lc2 from2 msg2
      (STEPT: rtc (small_step_all false) c1 c2)
      (FIND2: IdentMap.find tid' c2.(Configuration.threads) = Some (lst2,lc2))
      (PROMISES: Memory.get loc ts lc2.(Local.promises) = Some (from2, msg2)):
  exists lst1 lc1 from1 msg1,
  <<FIND1: IdentMap.find tid' c1.(Configuration.threads) = Some (lst1,lc1)>> /\
  <<PROMISES: Memory.get loc ts lc1.(Local.promises) = Some (from1, msg1)>>.
Proof.
  move STEPT at top. revert_until STEPT.
  apply rtc_reverse in STEPT. induction STEPT.
  - i. esplits; eauto.
  - inv H. inv USTEP. i. exploit small_step_promise_decr; eauto. i. des.
    exploit IHSTEPT; eauto.
Qed.


Require Import Bool String List.
Require Import Lib.CommonTactics Lib.ilist Lib.Word.
Require Import Lib.Struct Lib.FMap Lib.StringEq Lib.Indexer.
Require Import Kami.Syntax Kami.Semantics Kami.RefinementFacts Kami.Renaming Kami.Wf.
Require Import Kami.Renaming Kami.Specialize Kami.Inline Kami.InlineFacts Kami.Decomposition.
Require Import Kami.Tactics Kami.Notations Kami.PrimBram.
Require Import Ex.MemTypes Ex.SC Ex.NativeFifo Ex.MemAsync Ex.ProcFetch Ex.ProcFInl.
Require Import Eqdep ProofIrrelevance.

Set Implicit Arguments.

Section Invariants.
  Variables addrSize iaddrSize instBytes dataBytes rfIdx: nat.

  Variables (fetch: AbsFetch addrSize iaddrSize instBytes dataBytes).

  Variable (f2dElt: Kind).
  Variable (f2dPack:
              forall ty,
                Expr ty (SyntaxKind (Data instBytes)) -> (* rawInst *)
                Expr ty (SyntaxKind (Pc addrSize)) -> (* curPc *)
                Expr ty (SyntaxKind (Pc addrSize)) -> (* nextPc *)
                Expr ty (SyntaxKind Bool) -> (* epoch *)
                Expr ty (SyntaxKind f2dElt)).
  Variables
    (f2dRawInst: forall ty, fullType ty (SyntaxKind f2dElt) ->
                            Expr ty (SyntaxKind (Data instBytes)))
    (f2dCurPc: forall ty, fullType ty (SyntaxKind f2dElt) ->
                          Expr ty (SyntaxKind (Pc addrSize)))
    (f2dNextPc: forall ty, fullType ty (SyntaxKind f2dElt) ->
                           Expr ty (SyntaxKind (Pc addrSize)))
    (f2dEpoch: forall ty, fullType ty (SyntaxKind f2dElt) ->
                          Expr ty (SyntaxKind Bool)).

  Context {indexSize tagSize: nat}.
  Variables (getIndex: forall ty, fullType ty (SyntaxKind (Bit addrSize)) ->
                                  Expr ty (SyntaxKind (Bit indexSize)))
            (getTag: forall ty, fullType ty (SyntaxKind (Bit addrSize)) ->
                                Expr ty (SyntaxKind (Bit tagSize))).

  Variables (pcInit : ConstT (Pc addrSize)).

  Definition fetchICacheInl :=
    projT1 (fetchICacheInl fetch f2dPack getIndex getTag pcInit).

  Record fetchICache_inv (o: RegsT) : Prop :=
    { pcv : fullType type (SyntaxKind (Pc addrSize));
      Hpcv : M.find "pc"%string o = Some (existT _ _ pcv);
      pinitv : fullType type (SyntaxKind Bool);
      Hpinitv : M.find "pinit"%string o = Some (existT _ _ pinitv);
      pinitRqv : fullType type (SyntaxKind Bool);
      HpinitRqv : M.find "pinitRq"%string o = Some (existT _ _ pinitRqv);
      pinitRqOfsv : fullType type (SyntaxKind (Bit iaddrSize));
      HpinitRqOfsv : M.find "pinitRqOfs"%string o = Some (existT _ _ pinitRqOfsv);
      pinitRsOfsv : fullType type (SyntaxKind (Bit iaddrSize));
      HpinitRsOfsv : M.find "pinitRsOfs"%string o = Some (existT _ _ pinitRsOfsv);
      fepochv : fullType type (SyntaxKind Bool);
      Hfepochv : M.find "fEpoch"%string o = Some (existT _ _ fepochv);
      pcuv : fullType type (SyntaxKind Bool);
      Hpcuv : M.find "pcUpdated"%string o = Some (existT _ _ pcuv);

      bramv : fullType type (SyntaxKind (Vector (Data instBytes) iaddrSize));
      Hbramv : M.find "pgm"--"bram" o = Some (existT _ _ bramv);
      breadv : fullType type (bramReadValK (Data instBytes) type);
      Hbreadv : M.find "pgm"--"readVal" o = Some (existT _ _ breadv);

      Hinv0 : pinitv = false -> breadv = None;
      Hinv1 : pinitv = true -> pcuv = false ->
              match breadv with
              | Some val => val = bramv (evalExpr (toIAddr _ pcv))
              | None => True
              end
    }.

  Ltac fetchICache_inv_old :=
    repeat match goal with
           | [H: fetchICache_inv _ |- _] => destruct H
           end;
    kinv_red.

  Ltac fetchICache_inv_new :=
    econstructor; (* let's prove that the invariant holds for the next state *)
    try (findReify; (reflexivity || eassumption); fail);
    kinv_red; (* unfolding invariant definitions *)
    try eassumption; intros; try reflexivity.
    (* intuition kinv_simpl; intuition idtac. *)

  Ltac fetchICache_inv_tac := fetchICache_inv_old; fetchICache_inv_new.

  Lemma fetchICache_inv_ok':
    forall init n ll,
      init = initRegs (getRegInits fetchICacheInl) ->
      Multistep fetchICacheInl init n ll ->
      fetchICache_inv n.
  Proof. (* SKIP_PROOF_ON
    induction 2.

    - fetchICache_inv_old.
      unfold getRegInits, fetchICacheInl, ProcFInl.fetchICacheInl, projT1.
      fetchICache_inv_new.

    - kinvert.
      + mred.
      + mred.
      + kinv_dest_custom fetchICache_inv_tac.
      + kinv_dest_custom fetchICache_inv_tac.
      + kinv_dest_custom fetchICache_inv_tac.
      + kinv_dest_custom fetchICache_inv_tac.
      + kinv_dest_custom fetchICache_inv_tac.
      + kinv_dest_custom fetchICache_inv_tac.
      + kinv_dest_custom fetchICache_inv_tac.
      + kinv_dest_custom fetchICache_inv_tac.
        END_SKIP_PROOF_ON *) apply cheat.
  Qed.

  Lemma fetchICache_inv_ok:
    forall o,
      reachable o fetchICacheInl ->
      fetchICache_inv o.
  Proof.
    intros; inv H; inv H0.
    eapply fetchICache_inv_ok'; eauto.
  Qed.

End Invariants.


Set Warnings "-notation-overridden".
Set Warnings "-extraction-reserved-identifier".

(** Linear Scan Register Allocator

    The linear scan algorithm in this module is documented by the paper
    "Optimized Interval Splitting in a Linear Scan Register Allocator" by
    Christian Wimmer and Hanspeter Mӧssenbӧck:

    https://www.usenix.org/legacy/events/vee05/full_papers/p132-wimmer.pdf
*)
Require Import LinearScan.Lib.
Require Export Hask.Haskell.
Require Import LinearScan.Allocate.
Require Import LinearScan.Assign.
Require Import LinearScan.Blocks.
Require Import LinearScan.Build.
Require Import LinearScan.Interval.
Require Import LinearScan.LiveSets.
Require Import LinearScan.Loops.
Require Import LinearScan.Resolve.
Require Import LinearScan.ScanState.
Require Import LinearScan.Morph.
Require Import LinearScan.Verify.

Generalizable All Variables.

Inductive FinalStage : Set :=
  | BuildingIntervalsFailed
  | AllocatingRegistersFailed.

Record ScanStateDescSet (maxReg : nat) : Set := {
    s_nextInterval : nat;

    s_intervals      : seq IntervalDesc;
    s_fixedIntervals : seq (option IntervalDesc);

    (* The [nat] in this member indicates the beginning position of the
       interval. *)
    s_unhandled : seq (nat * nat);       (* starts after pos *)
    s_active    : seq (nat * nat);       (* ranges over pos *)
    s_inactive  : seq (nat * nat);       (* falls in lifetime hole *)
    s_handled   : seq (nat * option nat) (* ends before pos *)
}.

Definition toScanStateDescSet `(sd : ScanStateDesc maxReg) :
  ScanStateDescSet maxReg :=
  {| s_nextInterval   := nextInterval sd
   ; s_intervals      := map (fun x => @getIntervalDesc x.1 x.2)
                             (vec_to_seq (intervals sd))
   ; s_fixedIntervals := map (fun mx =>
                                match mx with
                                | Some x => Some (@getIntervalDesc x.1 x.2)
                                | None => None
                                end)
                             (vec_to_seq (fixedIntervals sd))
   ; s_unhandled      := [seq (nat_of_ord (fst i), snd i) | i <- unhandled sd ]
   ; s_active         := [seq (nat_of_ord (fst i),
                               nat_of_ord (snd i)) | i <- active sd ]
   ; s_inactive       := [seq (nat_of_ord (fst i),
                               nat_of_ord (snd i)) | i <- inactive sd ]
   ; s_handled        := [seq (nat_of_ord (fst i),
                               option_map (fun x => nat_of_ord x) (snd i))
                         | i <- handled sd ]
   |}.

Record Details {blockType1 blockType2 : Set} (maxReg : nat) : Set := {
  reason          : option (seq SSTrace * FinalStage);
  liveSets        : IntMap BlockLiveSets;
  resolvingMoves  : IntMap (seq ResolvingMoveSet);
  inputBlocks     : seq blockType1;
  orderedBlocks   : seq blockType1;
  allocatedBlocks : (IntMap (RegStateDescSet * seq AllocError) *
                     IntMap RegStateDescSet *
                     IntMap RegStateDescSet)
                        + seq blockType2;
  scanStatePre    : option (ScanStateDescSet maxReg);
  scanStatePost   : option (ScanStateDescSet maxReg);
  loopState       : LoopState
}.

Definition linearScan
  `{dict : Monad m} {blockType1 blockType2 opType1 opType2 : Set}
  (maxReg : nat) (registers_exist : maxReg > 0)
  (binfo : BlockInfo blockType1 blockType2 opType1 opType2)
  (oinfo : @OpInfo maxReg m dict opType1 opType2)
  (useVerifier : UseVerifier) (blocks : seq blockType1) : m (Details maxReg) :=
  (* order blocks and operations (including loop detection) *)
  z <- computeBlockOrder binfo blocks ;
  let: (loops, blocks1) := z in

  (* create intervals with live ranges *)
  let liveSets  := computeLocalLiveSets binfo oinfo blocks1 in
  let liveSets' := computeGlobalLiveSetsRecursively binfo blocks1 liveSets in

  let ssig := buildIntervals binfo oinfo blocks1 loops liveSets' in
  (* allocate registers *)
  let opCount := (countOps binfo blocks1).+1 in
  match walkIntervals registers_exist ssig.2 opCount.*2.+1 with
  | inl (err, ssig') =>
    pure $ Build_Details _ _ maxReg (Some (err, AllocatingRegistersFailed))
      liveSets' emptyIntMap blocks blocks1 (inr [::])
      (Some (toScanStateDescSet ssig.1))
      (Some (toScanStateDescSet ssig'.1)) loops

  | inr ssig' =>
      match finalizeScanState ssig'.2 opCount.*2 with
      | inl err =>
        pure $ Build_Details _ _ maxReg (Some (err, AllocatingRegistersFailed))
          liveSets' emptyIntMap blocks blocks1 (inr [::])
          (Some (toScanStateDescSet ssig.1))
          (Some (toScanStateDescSet ssig'.1)) loops

      | inr (exist sd _) =>
        let allocs := determineAllocations sd in
        let mappings := resolveDataFlow binfo allocs blocks1 liveSets' in
        res <- assignRegNum binfo oinfo useVerifier allocs liveSets'
                            mappings loops blocks1 ;
        let: (moves, blocks2) := res in
        let blockInfo := match blocks2 with
          | inr xs => inr xs
          | inl vs =>
              inl (verErrors vs,
                   IntMap_map (fun x => fromRegStateDesc x.1) (verInit vs),
                   IntMap_map (fun x => fromRegStateDesc x.1) (verFinal vs))
          end in

        pure $ Build_Details _ _ maxReg None
          liveSets' moves blocks blocks1 blockInfo
          (Some (toScanStateDescSet ssig.1))
          (Some (toScanStateDescSet sd)) loops
      end
  end.

Require Import Hask.Haskell.

(* Set Extraction Conservative Types. *)

Extract Inductive NonEmpty => "[]" ["(:[])" "(:)"]
  "(\ns nc l -> case l of [x] -> ns x; (x:xs) -> nc x xs)".

Extract Inlined Constant NE_length  => "Prelude.length".
Extract Inlined Constant NE_to_list => "Prelude.id".
Extract Inlined Constant NE_head    => "Prelude.head".
Extract Inlined Constant NE_last    => "Prelude.last".
Extract Inlined Constant NE_map     => "Prelude.map".
Extract Inlined Constant NE_foldl   => "Data.List.foldl'".

Separate Extraction linearScan.

(* Show which axioms we depend on for this development. *)
Print Assumptions linearScan.

(* Print Libraries. *)


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

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

Require Export Lemmas_Comb_Behaviour.
Require Export Lemmas_Struct.

Set Implicit Arguments.
Unset Strict Implicit.

Definition d_Map_List4_pdt_Grant (l : d_list (d_list bool 4) 4)
  (g : d_list (bool * bool) 4) :=
  d_map (List2_pdt (A:=bool))
    (d_map2 Grant_for_Out l
       (List4 (List2 (fst (Fst_of_l4 g)) (snd (Fst_of_l4 g)))
          (List2 (fst (Scd_of_l4 g)) (snd (Scd_of_l4 g)))
          (List2 (fst (Thd_of_l4 g)) (snd (Thd_of_l4 g)))
          (List2 (fst (Fth_of_l4 g)) (snd (Fth_of_l4 g))))).

Lemma ltReq_false_G1 :
 forall (l : d_list (d_list bool 4) 4) (g1 g1' g2 g2' g3 g3' g4 g4' : bool),
 Ackor (Fst_of_l4 l) = false ->
 Fst_of_l4
   (d_Map_List4_pdt_Grant l (List4 (g1, g1') (g2, g2') (g3, g3') (g4, g4'))) =
 (g1, g1').
intros.
unfold d_Map_List4_pdt_Grant in |- *.
unfold Fst_of_l4 in |- *; simpl in |- *.
unfold Grant_for_Out in |- *; unfold SuccessfulInput in |- *;
 unfold RequestsToArbitrate in |- *.
replace (Fst_of_l4 (d_Head l)) with false.
replace (Scd_of_l4 (d_Head l)) with false.
replace (Thd_of_l4 (d_Head l)) with false.
replace (Fth_of_l4 (d_Head l)) with false; simpl in |- *.
replace (Convert_port_list2 (Convert_list2_port (List2 g1 g1'))) with
 (List2 g1 g1').
auto.
unfold Convert_list2_port in |- *; unfold Convert_port_list2 in |- *;
 simpl in |- *.
elim g1; elim g1'; simpl in |- *; auto.
apply sym_equal; apply Ackor_false_fth; auto.
apply sym_equal; apply Ackor_false_thd; auto.
apply sym_equal; apply Ackor_false_scd; auto.
apply sym_equal; apply Ackor_false_fst; auto.
Qed.

Lemma ltReq_false_G2 :
 forall (l : d_list (d_list bool 4) 4) (g1 g1' g2 g2' g3 g3' g4 g4' : bool),
 Ackor (Scd_of_l4 l) = false ->
 Scd_of_l4
   (d_Map_List4_pdt_Grant l (List4 (g1, g1') (g2, g2') (g3, g3') (g4, g4'))) =
 (g2, g2').
intros.
unfold d_Map_List4_pdt_Grant in |- *.
unfold Scd_of_l4 in |- *; simpl in |- *.
unfold Grant_for_Out in |- *; unfold SuccessfulInput in |- *;
 unfold RequestsToArbitrate in |- *.
replace (Fst_of_l4 (d_Head (d_tl l))) with false.
replace (Scd_of_l4 (d_Head (d_tl l))) with false.
replace (Thd_of_l4 (d_Head (d_tl l))) with false.
replace (Fth_of_l4 (d_Head (d_tl l))) with false; simpl in |- *.
replace (Convert_port_list2 (Convert_list2_port (List2 g2 g2'))) with
 (List2 g2 g2').
auto.
unfold Convert_list2_port in |- *; unfold Convert_port_list2 in |- *;
 simpl in |- *.
elim g2; elim g2'; simpl in |- *; auto.
apply sym_equal; apply Ackor_false_fth; auto.
apply sym_equal; apply Ackor_false_thd; auto.
apply sym_equal; apply Ackor_false_scd; auto.
apply sym_equal; apply Ackor_false_fst; auto.
Qed.

Lemma ltReq_false_G3 :
 forall (l : d_list (d_list bool 4) 4) (g1 g1' g2 g2' g3 g3' g4 g4' : bool),
 Ackor (Thd_of_l4 l) = false ->
 Thd_of_l4
   (d_Map_List4_pdt_Grant l (List4 (g1, g1') (g2, g2') (g3, g3') (g4, g4'))) =
 (g3, g3').
intros.
unfold d_Map_List4_pdt_Grant in |- *.
unfold Thd_of_l4 in |- *; simpl in |- *.
unfold Grant_for_Out in |- *; unfold SuccessfulInput in |- *;
 unfold RequestsToArbitrate in |- *.
generalize H; clear H.
elim (non_empty l).
intros x t; elim t; clear t; intros t H'.
rewrite H'; simpl in |- *; intro H.
replace (Fst_of_l4 (d_Head (d_tl t))) with false.
replace (Scd_of_l4 (d_Head (d_tl t))) with false.
replace (Thd_of_l4 (d_Head (d_tl t))) with false.
replace (Fth_of_l4 (d_Head (d_tl t))) with false; simpl in |- *.
replace (Convert_port_list2 (Convert_list2_port (List2 g3 g3'))) with
 (List2 g3 g3').
auto.
unfold Convert_list2_port in |- *; unfold Convert_port_list2 in |- *;
 simpl in |- *.
elim g3; elim g3'; simpl in |- *; auto.
apply sym_equal; apply Ackor_false_fth; auto.
apply sym_equal; apply Ackor_false_thd; auto.
apply sym_equal; apply Ackor_false_scd; auto.
apply sym_equal; apply Ackor_false_fst; auto.
Qed.

Lemma ltReq_false_G4 :
 forall (l : d_list (d_list bool 4) 4) (g1 g1' g2 g2' g3 g3' g4 g4' : bool),
 Ackor (Fth_of_l4 l) = false ->
 Fth_of_l4
   (d_Map_List4_pdt_Grant l (List4 (g1, g1') (g2, g2') (g3, g3') (g4, g4'))) =
 (g4, g4').
intros.
unfold d_Map_List4_pdt_Grant in |- *.
unfold Fth_of_l4 in |- *; simpl in |- *.
unfold Grant_for_Out in |- *; unfold SuccessfulInput in |- *;
 unfold RequestsToArbitrate in |- *.
generalize H; clear H.
elim (non_empty l).
intros x t; elim t; clear t; intros t H'.
elim (non_empty t).
intros x' t'; elim t'; clear t'; intros t' H''.
rewrite H'; rewrite H''; simpl in |- *; intro H.
replace (Fst_of_l4 (d_Head (d_tl t'))) with false.
replace (Scd_of_l4 (d_Head (d_tl t'))) with false.
replace (Thd_of_l4 (d_Head (d_tl t'))) with false.
replace (Fth_of_l4 (d_Head (d_tl t'))) with false; simpl in |- *.
replace (Convert_port_list2 (Convert_list2_port (List2 g4 g4'))) with
 (List2 g4 g4').
auto.
unfold Convert_list2_port in |- *; unfold Convert_port_list2 in |- *;
 simpl in |- *.
elim g4; elim g4'; simpl in |- *; auto.
apply sym_equal; apply Ackor_false_fth; auto.
apply sym_equal; apply Ackor_false_thd; auto.
apply sym_equal; apply Ackor_false_scd; auto.
apply sym_equal; apply Ackor_false_fst; auto.
Qed.


(* type_remove *)
Require Import Semantics.
Require Import Sumbool_dec.
Require Import FMapFacts.
Require Import OptionMap2.
Require Import SemanticsDefinitions.
Require Import AccessRights.
Require Import AccessRightSets.
Require Import RefSets.
Require Import References.
Require Import Indices.
Require Import Capabilities.
Require Import Objects.
Require Import SystemState.
Require Import SemanticsDefinitions.

Module SimpleSemantics (Ref:ReferenceType) (RefS: RefSetType Ref) (Cap:CapabilityType Ref) (Ind:IndexType) (Obj:ObjectType Ref Cap Ind) (Sys:SystemStateType Ref Cap Ind Obj) (SemDefns: SemanticsDefinitionsType Ref Cap Ind Obj Sys) : SemanticsType Ref RefS Cap Ind Obj Sys SemDefns.
  Import SemDefns.
  Export SemDefns.

(*  Module RS_Mod := RefSets.Make Ref.
  Import RS_Mod. *)
  Import RefS.

  (* in the following, I'm abusing notation.
     We use t as an object, not an index to find the target defining an object.
     We use c as a capability, not an index in t naming the capability.
     Likewise with cl for capability lists. *)
  (* (read a t s): a reads data from t.  *)
  (* abstract *)
  Definition do_read (a:Ref.t) (t:Ind.t) (s:Sys.t) : Sys.t := s.

  Theorem read_spec: forall a t s, Sys.eq (do_read a t s) s.
  Proof.
    intros.
    unfold do_read.
    apply Sys.eq_refl.
  Qed.

  (* (write a t s): a writes data to t. *)
  (* abstract *)
  Definition do_write (a:Ref.t) (t:Ind.t) (s:Sys.t) : Sys.t := s.

  Theorem write_spec: forall a t s, Sys.eq (do_write a t s) s.
  Proof.
    intros.
    unfold do_write.
    apply Sys.eq_refl.
  Qed.

  (* (fetch a t c i s): a fetches c from t and places it at index i. *)
  (* abstract *)
  Definition do_fetch (a:Ref.t) (t:Ind.t) (c:Ind.t) (i:Ind.t) (s:Sys.t) : Sys.t :=
    if (true_bool_of_sumbool (SemDefns.fetch_preReq_dec a t s))
      then if (true_bool_of_sumbool (SemDefns.option_hasRight_dec (SC.getCap t a s) rd))
        then (option_map1 (fun tgt => SC.copyCap c tgt i a s) s (SemDefns.option_target (SC.getCap t a s)))
        else (option_map1 (fun tgt => SC.weakCopyCap c tgt i a s) s (SemDefns.option_target (SC.getCap t a s)))
      else s.

  Theorem fetch_invalid: forall a t c i s,
    ~ SemDefns.fetch_preReq a t s -> Sys.eq (do_fetch a t c i s) s.
  Proof.
    intros.
    unfold do_fetch.
    destruct (SemDefns.fetch_preReq_dec a t s); [contradiction | simpl].
    apply Sys.eq_refl.
  Qed.

  Theorem fetch_read: forall a t c i s,
    SemDefns.fetch_preReq a t s -> SemDefns.option_hasRight (SC.getCap t a s) rd ->
    Sys.eq (do_fetch a t c i s)
         (option_map1 (fun tgt => SC.copyCap c tgt i a s) s (SemDefns.option_target (SC.getCap t a s))).
  Proof.
    intros.
    unfold do_fetch.
    destruct (SemDefns.fetch_preReq_dec a t s); try contradiction; simpl.
    destruct (SemDefns.option_hasRight_dec (SC.getCap t a s) rd); try contradiction; simpl.
    apply Sys.eq_refl.
  Qed.

  Theorem fetch_weak: forall a t c i s,
    SemDefns.fetch_preReq a t s -> ~ SemDefns.option_hasRight (SC.getCap t a s) rd ->
    SemDefns.option_hasRight (SC.getCap t a s) wk  ->
    Sys.eq (do_fetch a t c i s)
    (option_map1 (fun tgt => SC.weakCopyCap c tgt i a s) s (SemDefns.option_target (SC.getCap t a s))).
  Proof.
    intros.
    unfold do_fetch.
    destruct (SemDefns.fetch_preReq_dec a t s); try contradiction; simpl.
    destruct (SemDefns.option_hasRight_dec (SC.getCap t a s) rd); try contradiction; simpl.
    apply Sys.eq_refl.
  Qed.

  Ltac prove_valid_invalid do_X X_preReq_dec a t s :=
    intros; unfold do_X; destruct (X_preReq_dec a t s); try contradiction; simpl; apply Sys.eq_refl.

  (* (store a t c i s): a stores c to t at index i. *)
  (* abstract *)
  Definition do_store (a:Ref.t) (t:Ind.t) (c:Ind.t) (i:Ind.t) (s:Sys.t) : Sys.t :=
    if (true_bool_of_sumbool (SemDefns.store_preReq_dec a t s))
      then (option_map1 (fun tgt => SC.copyCap c a i tgt s) s (SemDefns.option_target (SC.getCap t a s)))
      else s.

  Theorem store_invalid : forall a t c i s, ~ SemDefns.store_preReq a t s -> Sys.eq (do_store a t c i s) s.
  Proof.
    prove_valid_invalid do_store SemDefns.store_preReq_dec a t s.
  Qed.

  Theorem  store_valid: forall a t c i s, SemDefns.store_preReq a t s ->
    Sys.eq (do_store a t c i s)
    (option_map1 (fun tgt => SC.copyCap c a i tgt s) s (SemDefns.option_target (SC.getCap t a s))).
  Proof.
    prove_valid_invalid do_store SemDefns.store_preReq_dec a t s.
  Qed.

  (* (revoke a t c s): a removes capability c from t. *)
  (* abstract *)
  Definition do_revoke (a:Ref.t) (t:Ind.t) (c:Ind.t) (s:Sys.t) : Sys.t :=
    if (true_bool_of_sumbool (SemDefns.revoke_preReq_dec a t s))
      then (option_map1 (fun tgt => SC.rmCap c tgt s) s (SemDefns.option_target (SC.getCap t a s)))
      else s.

  Theorem revoke_invalid : forall a t c s, ~ SemDefns.revoke_preReq a t s -> Sys.eq (do_revoke a t c s) s.
  Proof.
    prove_valid_invalid do_revoke SemDefns.revoke_preReq_dec a t s.
  Qed.

  Theorem revoke_valid : forall a t c s, SemDefns.revoke_preReq a t s ->
    Sys.eq (do_revoke a t c s)
    (option_map1 (fun tgt => SC.rmCap c tgt s) s (SemDefns.option_target (SC.getCap t a s))).
  Proof.
    prove_valid_invalid do_revoke SemDefns.revoke_preReq_dec a t s.
  Qed.

  (* (send a t cil op_i s): a sends a message to t containing capabilities.
     The cil is a capability -> index list, and is a list of pairs.
     Each capability c is stored at index i in t. *)
  (* abstract *)
  Definition do_send (a:Ref.t) (t:Ind.t) (cil:list (Ind.t * Ind.t)) (op_i:option Ind.t) (s:Sys.t) : Sys.t :=
    if (true_bool_of_sumbool (SemDefns.send_preReq_dec a t s))
      then (option_map1 (fun tgt => SC.copyCapList a tgt cil
      (option_map1
             (fun i =>
               SC.addCap i
               (Cap.mkCap a (ARSet.singleton tx))
               tgt
               s)
             s
             op_i)) s (SemDefns.option_target (SC.getCap t a s)))
      else s.

  Theorem send_invalid : forall a t cil op_i s, ~ SemDefns.send_preReq a t s -> Sys.eq (do_send a t cil op_i s) s.
  Proof.
    prove_valid_invalid do_send SemDefns.send_preReq_dec a t s.
  Qed.

  Theorem send_valid : forall a t cil op_i s, SemDefns.send_preReq a t s ->
    Sys.eq (do_send a t cil op_i s)
    (option_map1
      (fun tgt =>
        SC.copyCapList a tgt cil
           (option_map1
             (fun i =>
               SC.addCap i
               (Cap.mkCap a (ARSet.singleton tx))
               tgt
               s)
             s
             op_i))
      s
      (SemDefns.option_target (SC.getCap t a s))).
  Proof.
    prove_valid_invalid do_send SemDefns.send_preReq_dec a t s.
  Qed.

  (* (destroy a t s): a destroys t. *)
  (* abstract *)
  Definition do_destroy (a:Ref.t) (t:Ind.t) (s:Sys.t) : Sys.t :=
      if (true_bool_of_sumbool (SemDefns.destroy_preReq_dec a t s))
      then (option_map1 (fun tgt => SC.set_dead tgt s) s (SemDefns.option_target (SC.getCap t a s)))
      else s.

  Theorem destroy_invalid: forall a t s, ~ SemDefns.destroy_preReq a t s -> Sys.eq (do_destroy a t s) s.
  Proof.
    prove_valid_invalid do_destroy SemDefns.destroy_preReq_dec a t s.
  Qed.

  Theorem destroy_valid: forall a t s, SemDefns.destroy_preReq a t s ->
    Sys.eq (do_destroy a t s)
    (option_map1 (fun tgt => SC.set_dead tgt s) s (SemDefns.option_target (SC.getCap t a s))).
  Proof.
    prove_valid_invalid do_destroy SemDefns.destroy_preReq_dec a t s.
  Qed.

  (* (allocate a n i cil s): a allocates child n,
     handing it capabilities via cil, and places the child's cap at index i. *)
  (* abstract *)
  Definition do_allocate (a:Ref.t) (n:Ref.t) (i:Ind.t) (cil:list (Ind.t * Ind.t)) (s:Sys.t) : Sys.t :=
    if (true_bool_of_sumbool (SemDefns.allocate_preReq_dec a n s))
      then
    (SC.addCap i
      (Cap.mkCap n
        (ARSet.add rd
          (ARSet.add wr
            (ARSet.add wk
              (ARSet.singleton tx))))) a
    (SC.copyCapList a n cil
      (SC.set_alive n (SC.updateObj n (Obj.MapS.empty _)
        (SC.rmCapsByTarget n s)))))
    else s.
  Theorem allocate_invalid: forall a n i cil s, ~ SemDefns.allocate_preReq a n s -> Sys.eq (do_allocate a n i cil s) s.
  Proof.
    prove_valid_invalid do_allocate SemDefns.allocate_preReq_dec a n s.
  Qed.

  Theorem allocate_valid: forall a n i cil s, SemDefns.allocate_preReq a n s ->
    Sys.eq (do_allocate a n i cil s)
    (SC.addCap i
      (Cap.mkCap n all_rights) a
    (SC.copyCapList a n cil
      (SC.set_alive n (SC.updateObj n (Obj.MapS.empty _)
        (SC.rmCapsByTarget n s))))).
  Proof.
    prove_valid_invalid do_allocate SemDefns.allocate_preReq_dec a n s.
  Qed.

  Inductive operation : Type :=
  | read: Ref.t -> Ind.t  -> operation
  | write: Ref.t -> Ind.t -> operation
  | fetch: Ref.t -> Ind.t -> Ind.t -> Ind.t -> operation
  | store: Ref.t -> Ind.t -> Ind.t -> Ind.t -> operation
  | revoke: Ref.t -> Ind.t -> Ind.t -> operation
  | send: Ref.t -> Ind.t -> list (Ind.t * Ind.t) -> option Ind.t -> operation
  | allocate: Ref.t -> Ref.t -> Ind.t -> list (Ind.t * Ind.t) -> operation
  | destroy: Ref.t -> Ind.t -> operation.

  Inductive do_op_spec : operation -> (Sys.t -> Sys.t) -> Prop :=
    | do_op_spec_read: forall a t, do_op_spec (read a t) (do_read a t)
    | do_op_spec_write: forall a t, do_op_spec (write a t) (do_write a t)
    | do_op_spec_fetch: forall a t c i, do_op_spec (fetch a t c i) (do_fetch a t c i)
    | do_op_spec_store: forall a t c i, do_op_spec (store a t c i) (do_store a t c i)
    | do_op_spec_revoke: forall a t c, do_op_spec (revoke a t c) (do_revoke a t c)
    | do_op_spec_send: forall a t cil op_i, do_op_spec (send a t cil op_i) (do_send a t cil op_i)
    | do_op_spec_allocate: forall a t i cil, do_op_spec (allocate a t i cil) (do_allocate a t i cil)
    | do_op_spec_destroy: forall a t, do_op_spec (destroy a t) (do_destroy a t).

  Hint Constructors do_op_spec.

  Definition do_op op s:=
    match op with
      | read a t => do_read a t s
      | write a t => do_write a t s
      | fetch a t c i => do_fetch a t c i s
      | store a t c i => do_store a t c i s
      | revoke a t c => do_revoke a t c s
      | send a t cil op_i => do_send a t cil op_i s
      | allocate a n i cil => do_allocate a n i cil s
      | destroy a t => do_destroy a t s
    end.

  Theorem do_op_spec_do_op: forall op,
    do_op_spec op (do_op op).
  Proof.
    intros.
    destruct op; unfold do_op; constructor.
  Qed.

  Definition add_option_target s a t r_set := (option_map1 (fun tgt => RefSet.add tgt r_set) r_set (SemDefns.option_target (SC.getCap t a s))).

  Inductive read_from_def s: operation -> RefSet.t -> Prop :=
  | read_from_read_valid : forall a t x,
    SemDefns.read_preReq a t s ->
    RefSet.Equal (add_option_target s a t (RefSet.singleton a)) x ->
    read_from_def s (read a t) x
  | read_from_read_invalid : forall a t x,
    ~ SemDefns.read_preReq a t s ->
    RefSet.Empty x ->
    read_from_def s (read a t) x

  | read_from_write_valid: forall a t x,
    SemDefns.write_preReq a t s ->
    RefSet.Equal (RefSet.singleton a) x ->
    read_from_def s (write a t) x
  | read_from_write_invalid: forall a t x,
    ~ SemDefns.write_preReq a t s ->
    RefSet.Empty x ->
    read_from_def s (write a t) x

  | read_from_fetch_valid : forall a t c i x,
    SemDefns.fetch_preReq a t s ->
    RefSet.Equal (add_option_target s a t (RefSet.singleton a)) x ->
    read_from_def s (fetch a t c i) x
  | read_from_fetch_invalid : forall a t c i x,
    ~ SemDefns.fetch_preReq a t s ->
    RefSet.Empty x ->
    read_from_def s (fetch a t c i) x

  | read_from_store_valid: forall a t c i x,
    SemDefns.store_preReq a t s ->
    RefSet.Equal (RefSet.singleton a) x ->
    read_from_def s (store a t c i) x
  | read_from_store_invalid: forall a t c i x,
    ~ SemDefns.store_preReq a t s ->
    RefSet.Empty x ->
    read_from_def s (store a t c i) x

  | read_from_revoke_valid: forall a t c x,
    SemDefns.revoke_preReq a t s ->
    RefSet.Equal (RefSet.singleton a) x ->
    read_from_def s (revoke a t c) x
  | read_from_revoke_invalid: forall a t c x,
    ~ SemDefns.revoke_preReq a t s ->
    RefSet.Empty x ->
    read_from_def s (revoke a t c) x

  | read_from_send_valid: forall a t cil op_i x,
    SemDefns.send_preReq a t s ->
    RefSet.Equal (RefSet.singleton a) x ->
    read_from_def s (send a t cil op_i) x
  | read_from_send_invalid: forall a t cil op_i x,
    ~ SemDefns.send_preReq a t s ->
    RefSet.Empty x ->
    read_from_def s (send a t cil op_i) x

  | read_from_allocate_valid: forall a n i cil x,
    SemDefns.allocate_preReq a n s ->
    RefSet.Equal (RefSet.singleton a) x ->
    read_from_def s (allocate a n i cil) x
  | read_from_allocate_invalid: forall a n i cil x,
    ~ SemDefns.allocate_preReq a n s ->
    RefSet.Empty x ->
    read_from_def s (allocate a n i cil) x

  | read_from_destroy_valid: forall a t x,
    SemDefns.destroy_preReq a t s ->
    RefSet.Equal (RefSet.singleton a) x ->
    read_from_def s (destroy a t) x
  | read_from_destroy_invalid: forall a t x,
    ~ SemDefns.destroy_preReq a t s ->
    RefSet.Empty x ->
    read_from_def s (destroy a t) x.

  Inductive wrote_to_def s: operation -> RefSet.t -> Prop :=
  | wrote_to_read_valid : forall a t x,
    SemDefns.read_preReq a t s ->
    RefSet.Equal (RefSet.singleton a) x ->
    wrote_to_def s (read a t) x
  | wrote_to_read_invalid : forall a t x,
    ~ SemDefns.read_preReq a t s ->
    RefSet.Empty x ->
    wrote_to_def s (read a t) x

  | wrote_to_write_valid: forall a t x,
    SemDefns.write_preReq a t s ->
    RefSet.Equal (add_option_target s a t RefSet.empty) x ->
    wrote_to_def s (write a t) x
  | wrote_to_write_invalid: forall a t x,
    ~ SemDefns.write_preReq a t s ->
    RefSet.Empty x ->
    wrote_to_def s (write a t) x

  | wrote_to_fetch_valid : forall a t c i x,
    SemDefns.fetch_preReq a t s ->
    RefSet.Equal (RefSet.singleton a) x ->
    wrote_to_def s (fetch a t c i) x
  | wrote_to_fetch_invalid : forall a t c i x,
    ~ SemDefns.fetch_preReq a t s ->
    RefSet.Empty x ->
    wrote_to_def s (fetch a t c i) x

  | wrote_to_store_valid: forall a t c i x,
    SemDefns.store_preReq a t s ->
    RefSet.Equal (add_option_target s a t RefSet.empty) x ->
    wrote_to_def s (store a t c i) x
  | wrote_to_store_invalid: forall a t c i x,
    ~ SemDefns.store_preReq a t s ->
    RefSet.Empty x ->
    wrote_to_def s (store a t c i) x

  | wrote_to_revoke_valid: forall a t c x,
    SemDefns.revoke_preReq a t s ->
    RefSet.Equal (add_option_target s a t RefSet.empty) x ->
    wrote_to_def s (revoke a t c) x
  | wrote_to_revoke_invalid: forall a t c x,
    ~ SemDefns.revoke_preReq a t s ->
    RefSet.Empty x ->
    wrote_to_def s (revoke a t c) x

  | wrote_to_send_valid: forall a t cil op_i x,
    SemDefns.send_preReq a t s ->
    RefSet.Equal (add_option_target s a t RefSet.empty) x ->
    wrote_to_def s (send a t cil op_i) x
  | wrote_to_send_invalid: forall a t cil op_i x,
    ~ SemDefns.send_preReq a t s ->
    RefSet.Empty x ->
    wrote_to_def s (send a t cil op_i) x

  | wrote_to_allocate_valid: forall a n i cil x,
    SemDefns.allocate_preReq a n s ->
    RefSet.Equal (RefSet.add n (RefSet.singleton a)) x ->
    wrote_to_def s (allocate a n i cil) x
  | wrote_to_allocate_invalid: forall a n i cil x,
    ~ SemDefns.allocate_preReq a n s ->
    RefSet.Empty x ->
    wrote_to_def s (allocate a n i cil) x

  | wrote_to_destroy_valid: forall a t x,
    SemDefns.destroy_preReq a t s ->
    RefSet.Equal (RefSet.singleton a) x ->
    wrote_to_def s (destroy a t) x
  | wrote_to_destroy_invalid: forall a t x,
    ~ SemDefns.destroy_preReq a t s ->
    RefSet.Empty x ->
    wrote_to_def s (destroy a t) x.

  (*abstract*)
  Definition read_from s op :=
    match op with
      | read a t => if (SemDefns.read_preReq_dec a t s)
        then add_option_target s a t (RefSet.singleton a)
        else RefSet.empty
      | write a t => if (SemDefns.write_preReq_dec a t s)
        then RefSet.singleton a
        else RefSet.empty
      | fetch a t c i => if (SemDefns.fetch_preReq_dec a t s)
        then add_option_target s a t (RefSet.singleton a)
        else RefSet.empty
      | store a t c i => if SemDefns.store_preReq_dec a t s
        then RefSet.singleton a
        else RefSet.empty
      | revoke a t c => if SemDefns.revoke_preReq_dec a t s
        then RefSet.singleton a
        else RefSet.empty
      | send a t cil opt_i => if SemDefns.send_preReq_dec a t s
        then RefSet.singleton a
        else RefSet.empty
      | allocate a n i cil => if SemDefns.allocate_preReq_dec a n s
        then RefSet.singleton a
        else RefSet.empty
      | destroy a t => if SemDefns.destroy_preReq_dec a t s
        then RefSet.singleton a
        else RefSet.empty
    end.

    Ltac solve_apply_16_constructors remainder :=
      solve [constructor 1; remainder
        | constructor 2; remainder
        | constructor 3; remainder
        | constructor 4; remainder
        | constructor 5; remainder
        | constructor 6; remainder
        | constructor 7; remainder
        | constructor 8; remainder
        | constructor 9; remainder
        | constructor 10; remainder
        | constructor 11; remainder
        | constructor 12; remainder
        | constructor 13; remainder
        | constructor 14; remainder
        | constructor 15; remainder
        | constructor 16; remainder
      ].

  Theorem read_from_spec : forall s op ob_list,
    read_from_def s op ob_list <->
    RefSet.Equal (read_from s op) ob_list.
  Proof.

    (* these will be deleted by typeify2.pl as they are in a proof body *)
    Ltac reduce_dec dec :=
      let Hcase := fresh "Hcase" in
        case dec; intros Hcase; try contradiction.
    Ltac solve_reduce_tail H0 := solve[ auto| eapply RefSetProps.empty_is_empty_1 in H0;
              eapply RefSet.eq_sym; auto].
    Ltac reduce_and_solve dec H0 := reduce_dec dec; solve_reduce_tail H0.
    Ltac empty_solution := auto; apply RefSetProps.empty_is_empty_2; apply RefSet.eq_sym; auto.
    Ltac reduce_and_solve2 dec := reduce_dec dec; [intros H; solve_apply_16_constructors auto
      | intros H; solve_apply_16_constructors empty_solution].

    intros; split; intros.
    destruct H; unfold read_from;
      try solve [reduce_and_solve (send_preReq_dec a t s) H0
      | reduce_and_solve (read_preReq_dec a t s) H0
      | reduce_and_solve (write_preReq_dec a t s) H0
      | reduce_and_solve (fetch_preReq_dec a t s) H0
      | reduce_and_solve (store_preReq_dec a t s) H0
      | reduce_and_solve (revoke_preReq_dec a t s) H0
      | reduce_and_solve (allocate_preReq_dec a n s) H0
      | reduce_and_solve (destroy_preReq_dec a t s) H0
      ].

    revert H; unfold read_from in *; destruct op;

      try solve
        [ reduce_and_solve2 (send_preReq_dec t t0 s)
          | reduce_and_solve2 (read_preReq_dec t t0 s)
          | reduce_and_solve2 (write_preReq_dec t t0 s)
          | reduce_and_solve2 (fetch_preReq_dec t t0 s)
          | reduce_and_solve2 (store_preReq_dec t t0 s)
          | reduce_and_solve2 (revoke_preReq_dec t t0 s)
          | reduce_and_solve2 (allocate_preReq_dec t t0 s)
          | reduce_and_solve2 (destroy_preReq_dec t t0 s)
        ].

  Qed.

  (*abstract*)
  Definition wrote_to s op :=
    match op with
      | read a t =>  if (SemDefns.read_preReq_dec a t s)
        then RefSet.singleton a
        else RefSet.empty
      | write a t =>  if (SemDefns.write_preReq_dec a t s)
        then add_option_target s a t RefSet.empty
        else RefSet.empty
      | fetch a t c i =>  if (SemDefns.fetch_preReq_dec a t s)
        then RefSet.singleton a
        else RefSet.empty
      | store a t c i => if (SemDefns.store_preReq_dec a t s)
        then add_option_target s a t RefSet.empty
        else RefSet.empty
      | revoke a t c => if (SemDefns.revoke_preReq_dec a t s)
        then add_option_target s a t RefSet.empty
        else RefSet.empty
      | send a t cil opt_i => if (SemDefns.send_preReq_dec a t s)
        then add_option_target s a t RefSet.empty
        else RefSet.empty
      | allocate a n i cil => if (SemDefns.allocate_preReq_dec a n s)
        then RefSet.add n (RefSet.singleton a)
        else RefSet.empty
      | destroy a t => if (SemDefns.destroy_preReq_dec a t s)
        then RefSet.singleton a
        else RefSet.empty
    end.

  Theorem wrote_to_spec : forall s op ob_list,
    wrote_to_def s op ob_list <->
    RefSet.Equal (wrote_to s op) ob_list.
  Proof.
    intros; split; intros.

    destruct H; unfold wrote_to;
      try solve [reduce_and_solve (send_preReq_dec a t s) H0
      | reduce_and_solve (read_preReq_dec a t s) H0
      | reduce_and_solve (write_preReq_dec a t s) H0
      | reduce_and_solve (fetch_preReq_dec a t s) H0
      | reduce_and_solve (store_preReq_dec a t s) H0
      | reduce_and_solve (revoke_preReq_dec a t s) H0
      | reduce_and_solve (allocate_preReq_dec a n s) H0
      | reduce_and_solve (destroy_preReq_dec a t s) H0
      ].

    revert H; unfold wrote_to in *; destruct op;
      try solve
        [ reduce_and_solve2 (send_preReq_dec t t0 s)
          | reduce_and_solve2 (read_preReq_dec t t0 s)
          | reduce_and_solve2 (write_preReq_dec t t0 s)
          | reduce_and_solve2 (fetch_preReq_dec t t0 s)
          | reduce_and_solve2 (store_preReq_dec t t0 s)
          | reduce_and_solve2 (revoke_preReq_dec t t0 s)
          | reduce_and_solve2 (allocate_preReq_dec t t0 s)
          | reduce_and_solve2 (destroy_preReq_dec t t0 s)
        ].

Qed.

End SimpleSemantics.


Require Import erasure.
Require Import progStepImpliesSpec.
Require Import progStepWF.

(*Definitions*)
CoInductive ParDiverge : pHeap -> pPool -> Prop :=
|divergeStep : forall T1 T2 T2' H H',
                 pstep H T1 T2 (pOK H' T1 T2') ->
                 ParDiverge H' (pUnion T1 T2') -> ParDiverge H (pUnion T1 T2)
.

CoInductive ParDiverge' : pHeap -> pPool -> Prop :=
|divergeStep' : forall H H' T T',
                 pstepPlus H T H' T' -> ParDiverge' H' T' -> ParDiverge' H T.

Theorem ParDivergeEq : forall H T, ParDiverge H T <-> ParDiverge' H T.
Proof.
  intros. split; intros.
  {genDeps{T; H}. cofix. intros. inv H0. econstructor. econstructor. eauto.
   constructor. eapply ParDivergeEq; eassumption. }
  {genDeps{T; H}. cofix CH. intros. inv H0. inv H2. inv H4.
   {econstructor. eassumption. eapply CH. eauto. }
   {assert(ParDiverge' H'0 (pUnion T t0)). econstructor. econstructor.
    eassumption. eassumption. assumption. econstructor. eassumption.
    eapply CH. rewrite <- H2. eauto. }
  }
Qed.

Theorem eActTerm : forall x, exists M, actionTerm x M.
Proof.
  intros. destruct x; repeat econstructor.
Qed.

Ltac actTermTac x := assert(exists M, actionTerm x M) by apply eActTerm; invertHyp.

Theorem getLastApp : forall (T:Type) a c (b:T),
                       last(a++[b]) c = b.
Proof.
  induction a; intros.
  {simpl. auto. }
  {simpl. destruct (a0++[b]) eqn:eq.
   {invertListNeq. }
   {rewrite <- eq. eauto. }
  }
Qed.

Theorem unspecLastActPool : forall tid s a s2 M' M,
                         actionTerm a M' ->
                         unspecPool(tSingleton(tid,unlocked(s++[a]),s2,M)) =
                         tSingleton(tid,unlocked nil,s2,M').
Proof.
  induction s; intros.
  {simpl. inv H; auto. }
  {simpl. destruct (s++[a0])eqn:eq.
   {invertListNeq. }
   {rewrite <- eq. rewrite getLastApp. inv H; auto. }
  }
Qed.

Theorem actionTrmConsSame'' : forall a M' N s1 s2 tid,
                             actionTerm a M' ->
                             unspecPool(tSingleton(tid,unlocked s1,s2,M')) =
                             unspecPool(tSingleton(tid,aCons a (unlocked s1),s2,N)).
Proof.
  induction s1; intros.
  {simpl. inv H; auto.  }
  {simpl. destruct s1. auto. erewrite getLastNonEmpty; eauto. }
Qed.

Theorem actionTrmConsSame' : forall a M' N s1 s2 tid,
                             actionTerm a M' ->
                             unspecPool(tSingleton(tid,s1,s2,M')) =
                             unspecPool(tSingleton(tid,aCons a s1,s2,N)).
Proof.
  intros. destruct s1; auto. apply actionTrmConsSame''. auto.
Qed.

Theorem unspecEmpty : forall tid s1 s2 M,
                unspecPool(tSingleton(tid,locked s1,s2,M)) = (Empty_set thread).
Proof.
  intros. simpl. auto.
Qed.

Ltac sswfHelper := eapply spec_multi_trans;[eassumption|econstructor].

Hint Constructors actionTerm spec_multistep.

Theorem specStepWF : forall H T H' t t',
                       wellFormed H (tUnion T t) -> spec_step H T t H' T t' ->
                       wellFormed H' (tUnion T t').
Proof.
  intros. inv H1.
  {inv H0. econstructor. rewrite unspecUnionComm in *. destruct s1.
   {simpl in *. sswfHelper; auto. eapply SBasicStep; eauto. }
   {destructLast l. inv H3. invertHyp. actTermTac x. erewrite unspecLastActPool in *; eauto.
    sswfHelper; eauto. eapply SBasicStep; eauto. }
   {simpl in *. sswfHelper; eauto. eapply SBasicStep; eauto. }
  }
  {unfoldTac. inv H0. econstructor. rewrite coupleUnion. repeat rewrite unspecUnionComm in *.
   destruct b.
   {simpl in *. sswfHelper. eapply SFork; eauto. constructor. }
   {erewrite <- actionTrmConsSame'. rewrite unspecEmpty. unfoldTac. rewrite union_empty_r.
    sswfHelper. eapply SFork; eauto. constructor. auto. }
   {simpl in *.  sswfHelper. eapply SFork; eauto. constructor. }
  }
  {inv H0. econstructor. rewrite unspecUnionComm in *. destruct b.
   {simpl in *. erewrite unspecHeapRBRead; eauto. sswfHelper. eapply SGet; eauto. constructor. }
   {erewrite unspecHeapRBRead; eauto. erewrite <- actionTrmConsSame'; auto. sswfHelper.
    eapply SGet; eauto. constructor. }
   {simpl in *. erewrite unspecHeapRBRead; eauto. sswfHelper. eapply SGet; eauto. constructor. }
  }
  {inv H0. constructor. rewrite unspecHeapAddWrite; auto. rewrite unspecUnionComm in *.
   destruct b.
   {simpl in *. sswfHelper. eapply SPut; eauto. constructor. }
   {erewrite <- actionTrmConsSame'; eauto. sswfHelper. eapply SPut; eauto. constructor. }
   {simpl in *. sswfHelper. eapply SPut; eauto. constructor. }
  }
  {inv H0. constructor. rewrite unspecHeapExtend. rewrite unspecUnionComm in *. destruct b.
   {sswfHelper. eapply SNew; eauto. constructor. }
   {erewrite <- actionTrmConsSame'; eauto. sswfHelper. eapply SNew; eauto. constructor. }
   {sswfHelper. eapply SNew; eauto. constructor. }
  }
  {inv H0. constructor. unfoldTac. rewrite coupleUnion. repeat rewrite unspecUnionComm in *.
   rewrite unspecEmpty. unfoldTac. rewrite union_empty_r. destruct b.
   {sswfHelper. eapply SSpec; eauto. constructor. }
   {erewrite <- actionTrmConsSame'; eauto. sswfHelper. eapply SSpec; eauto. constructor. }
   {sswfHelper. eapply SSpec; eauto. constructor. }
  }
Qed.

Theorem specMultiWF : forall H T H' T', wellFormed H T -> spec_multistep H T H' T' ->
                                        wellFormed H' T'.
Proof.
  intros. induction H1.
  {auto. }
  {eapply specStepWF in H; eauto. }
Qed.

Theorem pstepDiffUnused : forall H H' T T' t t',
                            pstep H T t (pOK H' T t') ->
                            pstep H T' t (pOK H' T' t').
Proof.
  intros. Hint Constructors pstep. inv H0; eauto.
Qed.

Theorem pstepSingleton : forall H T1 T2 H' T2',
                           pstep H T1 T2 (pOK H' T1 T2') -> exists t, T2 = Single ptrm t.
Proof.
  intros. inv H0; eauto.
Qed.

CoInductive SpecDiverge : sHeap -> pool-> Prop :=
|specDiverge : forall T1 T2 T2' H H' H'' T,
                 spec_multistep H T H' (tUnion T1 T2) ->
                 prog_step H' T1 T2 (OK H'' T1 T2') ->
                 SpecDiverge H'' (tUnion T1 T2') -> SpecDiverge H T.

Theorem SpecDivergeParDiverge' : forall H T,
                wellFormed H T ->
                SpecDiverge H T -> ParDiverge' (eraseHeap H) (erasePool T).
Proof.
  cofix CH. intros. inv H1. copy H3. apply specMultiWF in H3; auto.
  eapply spec_multistepErase in H1. invertHyp. rewrite H6. rewrite H2.
  rewrite eraseUnionComm in *. copy H4. apply prog_specImpliesNonSpec in H4; auto.
  invertHyp.  apply prog_stepWF in H1; auto. rewrite eraseUnionComm in *.
  econstructor. eassumption. eapply CH. eauto. eauto.
Qed.

Theorem SpecDivergeParDiverge : forall H T,
              wellFormed H T ->
              SpecDiverge H T -> ParDiverge (eraseHeap H) (erasePool T).
Proof.
  intros. apply SpecDivergeParDiverge' in H1. rewrite ParDivergeEq. auto. auto.
Qed.


From iris.base_logic.lib Require Export invariants.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".

Definition vs `{invG Σ} (E1 E2 : coPset) (P Q : iProp Σ) : iProp Σ :=
  (□ (P -∗ |={E1,E2}=> Q))%I.
Arguments vs {_ _} _ _ _%I _%I.

Instance: Params (@vs) 4.
Notation "P ={ E1 , E2 }=> Q" := (vs E1 E2 P Q)
  (at level 99, E1,E2 at level 50, Q at level 200,
   format "P  ={ E1 , E2 }=>  Q") : uPred_scope.
Notation "P ={ E }=> Q" := (P ={E,E}=> Q)%I
  (at level 99, E at level 50, Q at level 200,
   format "P  ={ E }=>  Q") : uPred_scope.

Notation "P ={ E1 , E2 }=> Q" := (P ={E1,E2}=> Q)%I
  (at level 99, E1,E2 at level 50, Q at level 200,
   format "P  ={ E1 , E2 }=>  Q") : stdpp_scope.
Notation "P ={ E }=> Q" := (P ={E}=> Q)%I
  (at level 99, E at level 50, Q at level 200,
   format "P  ={ E }=>  Q") : stdpp_scope.

Section vs.
Context `{invG Σ}.
Implicit Types P Q R : iProp Σ.
Implicit Types N : namespace.

Global Instance vs_ne E1 E2 : NonExpansive2 (vs E1 E2).
Proof. solve_proper. Qed.

Global Instance vs_proper E1 E2 : Proper ((≡) ==> (≡) ==> (≡)) (vs E1 E2).
Proof. apply ne_proper_2, _. Qed.

Lemma vs_mono E1 E2 P P' Q Q' :
  (P ⊢ P') → (Q' ⊢ Q) → (P' ={E1,E2}=> Q') ⊢ P ={E1,E2}=> Q.
Proof. by intros HP HQ; rewrite /vs -HP HQ. Qed.

Global Instance vs_mono' E1 E2 : Proper (flip (⊢) ==> (⊢) ==> (⊢)) (vs E1 E2).
Proof. solve_proper. Qed.

Lemma vs_false_elim E1 E2 P : False ={E1,E2}=> P.
Proof. iIntros "!# []". Qed.
Lemma vs_timeless E P : Timeless P → ▷ P ={E}=> P.
Proof. by iIntros (?) "!# > ?". Qed.

Lemma vs_transitive E1 E2 E3 P Q R :
  (P ={E1,E2}=> Q) ∧ (Q ={E2,E3}=> R) ⊢ P ={E1,E3}=> R.
Proof.
  iIntros "#[HvsP HvsQ] !# HP".
  iMod ("HvsP" with "HP") as "HQ". by iApply "HvsQ".
Qed.

Lemma vs_reflexive E P : P ={E}=> P.
Proof. by iIntros "!# HP". Qed.

Lemma vs_impl E P Q : □ (P → Q) ⊢ P ={E}=> Q.
Proof. iIntros "#HPQ !# HP". by iApply "HPQ". Qed.

Lemma vs_frame_l E1 E2 P Q R : (P ={E1,E2}=> Q) ⊢ R ∗ P ={E1,E2}=> R ∗ Q.
Proof. iIntros "#Hvs !# [$ HP]". by iApply "Hvs". Qed.

Lemma vs_frame_r E1 E2 P Q R : (P ={E1,E2}=> Q) ⊢ P ∗ R ={E1,E2}=> Q ∗ R.
Proof. iIntros "#Hvs !# [HP $]". by iApply "Hvs". Qed.

Lemma vs_mask_frame_r E1 E2 Ef P Q :
  E1 ## Ef → (P ={E1,E2}=> Q) ⊢ P ={E1 ∪ Ef,E2 ∪ Ef}=> Q.
Proof.
  iIntros (?) "#Hvs !# HP". iApply fupd_mask_frame_r; auto. by iApply "Hvs".
Qed.

Lemma vs_inv N E P Q R :
  ↑N ⊆ E → inv N R ∗ (▷ R ∗ P ={E∖↑N}=> ▷ R ∗ Q) ⊢ P ={E}=> Q.
Proof.
  iIntros (?) "#[? Hvs] !# HP". iInv N as "HR" "Hclose".
  iMod ("Hvs" with "[HR HP]") as "[? $]"; first by iFrame.
  by iApply "Hclose".
Qed.

Lemma vs_alloc N P : ▷ P ={↑N}=> inv N P.
Proof. iIntros "!# HP". by iApply inv_alloc. Qed.

Lemma wand_fupd_alt E1 E2 P Q : (P ={E1,E2}=∗ Q) ⊣⊢ ∃ R, R ∗ (P ∗ R ={E1,E2}=> Q).
Proof. rewrite uPred.wand_alt. by setoid_rewrite uPred.persistently_impl_wand. Qed.
End vs.


From Hammer Require Import Hammer.

From Coq Require Import List Syntax.
From compcert Require Import Alphabet.
From compcert Require Grammar.
From compcert Require Automaton.
From compcert Require Interpreter.
From Coq.ssr Require Import ssreflect.

Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A).

Section Init.

Variable init:initstate.

Inductive word_has_stack_semantics:
forall (word:list token) (stack:stack), Prop :=
| Nil_stack_whss: word_has_stack_semantics [] []
| Cons_stack_whss:
forall (wordq:list token) (stackq:stack),
word_has_stack_semantics wordq stackq ->

forall (wordt:list token) (s:noninitstate)
(pt:parse_tree (last_symb_of_non_init_state s) wordt),

word_has_stack_semantics
(wordq++wordt) (existT noninitstate_type s (pt_sem pt)::stackq).

Lemma pop_spec_ptl A symbols_to_pop action word_stk stk (res : A) stk' :
pop_spec symbols_to_pop stk action stk' res ->
word_has_stack_semantics word_stk stk ->
exists word_stk' word_res (ptl:parse_tree_list symbols_to_pop word_res),
(word_stk' ++ word_res = word_stk)%list /\
word_has_stack_semantics word_stk' stk' /\
ptl_sem ptl action = res.
Proof. hammer_hook "Interpreter_correct" "Interpreter_correct.Make.pop_spec_ptl".
intros Hspec. revert word_stk.
induction Hspec as [stk sem|symbols_to_pop st stk action sem stk' res Hspec IH];
intros word_stk Hword_stk.
- exists word_stk, [], Nil_ptl. rewrite -app_nil_end. eauto.
- inversion Hword_stk. subst_existT.
edestruct IH as (word_stk' & word_res & ptl & ? & Hword_stk'' & ?); [eassumption|].
subst. eexists word_stk', (word_res ++ _)%list, (Cons_ptl ptl _).
split; [|split]=>//. rewrite app_assoc //.
Qed.

Lemma reduce_step_invariant (stk:stack) (prod:production) Hv Hi word buffer :
word_has_stack_semantics word stk ->
match reduce_step init stk prod buffer Hv Hi with
| Accept_sr sem buffer_new =>
exists pt : parse_tree (NT (start_nt init)) word,
buffer = buffer_new /\ pt_sem pt = sem
| Progress_sr stk' buffer_new =>
buffer = buffer_new /\ word_has_stack_semantics word stk'
| Fail_sr => True
end.
Proof. hammer_hook "Interpreter_correct" "Interpreter_correct.Make.reduce_step_invariant".
intros Hword_stk. unfold reduce_step.
match goal with
| |- context [pop_state_valid init ?stp stk ?x1 ?x2 ?x3 ?x4 ?x5] =>
generalize (pop_state_valid init stp stk x1 x2 x3 x4 x5)
end.
destruct pop as [stk' sem] eqn:Hpop=>/= Hv'.
apply pop_spec_ok in Hpop. apply pop_spec_ptl with (word_stk := word) in Hpop=>//.
destruct Hpop as (word1 & word2 & ptl & <- & Hword1 & <-).
generalize (reduce_step_subproof1 init stk prod Hv stk' (fun _ : True => Hv')).
destruct goto_table as [[st' EQ]|].
- intros _. split=>//.
change (ptl_sem ptl (prod_action prod)) with (pt_sem (Non_terminal_pt prod ptl)).
generalize (Non_terminal_pt prod ptl). rewrite ->EQ. intros pt. by constructor.
- intros Hstk'. destruct Hword1; [|by destruct Hstk'].
generalize (reduce_step_subproof0 init prod [] (fun _ : True => Hstk')).
simpl in Hstk'. rewrite -Hstk' // => EQ. rewrite cast_eq.
exists (Non_terminal_pt prod ptl). by split.
Qed.

Lemma step_invariant stk word buffer safe Hi :
word_has_stack_semantics word stk ->
match step safe init stk buffer Hi with
| Accept_sr sem buffer_new =>
exists word_new (pt:parse_tree (NT (start_nt init)) word_new),
(word ++ buffer = word_new ++ buffer_new)%buf /\
pt_sem pt = sem
| Progress_sr stk_new buffer_new =>
exists word_new,
(word ++ buffer = word_new ++ buffer_new)%buf /\
word_has_stack_semantics word_new stk_new
| Fail_sr => True
end.
Proof. hammer_hook "Interpreter_correct" "Interpreter_correct.Make.step_invariant".
intros Hword_stk. unfold step.
generalize (reduce_ok safe (state_of_stack init stk)).
destruct action_table as [prod|awt].
- intros Hv.
apply (reduce_step_invariant stk prod (fun _ => Hv) Hi word buffer) in Hword_stk.
destruct reduce_step=>//.
+ destruct Hword_stk as (pt & <- & <-); eauto.
+ destruct Hword_stk as [<- ?]; eauto.
- destruct buffer as [tok buffer]=>/=.
move=> /(_ (token_term tok)) Hv. destruct (awt (token_term tok)) as [st EQ|prod|]=>//.
+ eexists _. split; [by apply app_buf_assoc with (l2 := [_])|].
change (token_sem tok) with (pt_sem (Terminal_pt tok)).
generalize (Terminal_pt tok). generalize [tok].
rewrite -> EQ=>word' pt /=. by constructor.
+ apply (reduce_step_invariant stk prod (fun _ => Hv) Hi word (tok::buffer))
in Hword_stk.
destruct reduce_step=>//.
* destruct Hword_stk as (pt & <- & <-); eauto.
* destruct Hword_stk as [<- ?]; eauto.
Qed.

Lemma parse_fix_invariant stk word buffer safe log_n_steps Hi :
word_has_stack_semantics word stk ->
match proj1_sig (parse_fix safe init stk buffer log_n_steps Hi) with
| Accept_sr sem buffer_new =>
exists word_new (pt:parse_tree (NT (start_nt init)) word_new),
(word ++ buffer = word_new ++ buffer_new)%buf /\
pt_sem pt = sem
| Progress_sr stk_new buffer_new =>
exists word_new,
(word ++ buffer = word_new ++ buffer_new)%buf /\
word_has_stack_semantics word_new stk_new
| Fail_sr => True
end.
Proof. hammer_hook "Interpreter_correct" "Interpreter_correct.Make.parse_fix_invariant".
revert stk word buffer Hi.
induction log_n_steps as [|log_n_steps IH]=>/= stk word buffer Hi Hstk;
[by apply step_invariant|].
assert (IH1 := IH stk word buffer Hi Hstk).
destruct parse_fix as [[] Hi']=>/=; try by apply IH1.
destruct IH1 as (word' & -> & Hstk')=>//. by apply IH.
Qed.

Theorem parse_correct safe buffer log_n_steps:
match parse safe init buffer log_n_steps with
| Parsed_pr sem buffer_new =>
exists word_new (pt:parse_tree (NT (start_nt init)) word_new),
buffer = (word_new ++ buffer_new)%buf /\
pt_sem pt = sem
| _ => True
end.
Proof. hammer_hook "Interpreter_correct" "Interpreter_correct.Make.parse_correct".
unfold parse.
assert (Hparse := parse_fix_invariant [] [] buffer safe log_n_steps
(parse_subproof init)).
destruct proj1_sig=>//. apply Hparse. constructor.
Qed.

End Init.

End Make.


Require Import mlattice id_and_loc.
Require Import LibTactics tactics.

Require Import mlattice.
Module Language (L: Lattice).
  Import L.
  Module ProdL := ProductLattice L LH.
  Module ProdLatProp := LatticeProperties ProdL.
  Module LHLatProp := LatticeProperties LH.
  Definition level := ProdL.T.
  Definition level_proj1 := L.T.

  Inductive op := Plus | Mult.

  Inductive expr :=
  | Const: nat -> expr
  | Var: id -> expr
  | BinOp: op -> expr -> expr -> expr.

  Inductive cmd  :=
  | Skip: cmd
  | Stop: cmd
  | Assign: id -> expr -> cmd
  | If: expr -> cmd -> cmd -> cmd
  | While: expr -> cmd -> cmd
  | Seq: cmd -> cmd -> cmd
  | At: level_proj1 -> expr -> cmd -> cmd
  | BackAt: level_proj1 -> nat -> cmd
  | NewArr: id -> level_proj1 -> expr -> expr -> cmd
  | SetArr: id -> expr -> expr -> cmd
  | GetArr: id -> id -> expr -> cmd
  | Time: id -> cmd
  | TimeOut: cmd.

Notation "'STOP'" := Stop (only parsing).
Notation "'SKIP'" := Skip (only parsing).
Notation "x '::=' e" := (Assign x e) (at level 80).
Notation "c1 ';;' c2":= (Seq c1 c2)  (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (While b c) (at level 80, right associativity).
Notation "'IFB' e 'THEN' c1 'ELSE' c2 'FI'" :=
  (If e c1 c2) (at level 80, right associativity).
Notation "'AT' ℓ 'FOR' e 'DO' c" :=
  (At ℓ e c) (at level 80).
Notation "'BACKAT' ℓ 'WHEN' n 'DO' c" :=
    (BackAt ℓ n c) (at level 80).
Notation "'SET' x '[' e1 ']'  'TO' e2 " :=
  (SetArr x e1 e2) (at level 80).
Notation "'GET' x 'FROM' y '[' e ']'" :=
    (GetArr x y e) (at level 80).
Notation "'TIME' '(' x ')'" := (Time x).
Notation "'TIMEOUT'" := TimeOut.

Inductive value :=
| ValNum: nat -> value
| ValLoc: loc -> value.

End Language.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Tacticals to make auto and crush simplify.

*)

Set Implicit Arguments.
Require Export List.
Export ListNotations.
Require Export ZArith.
Require Export Init.Datatypes.
Require Import Coq.Bool.Bool.
Require Import Coq.Setoids.Setoid.

Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.
(* Require Export ContextExtensionRelation. *)

Create HintDb Chapter3.
Hint Constructors Value : Chapter3.
Hint Constructors S : Chapter3.
Hint Constructors R : Chapter3.
Hint Constructors L : Chapter3.
Hint Constructors get : Chapter3.
Hint Constructors set : Chapter3.
Hint Constructors gettype : Chapter3.
Hint Constructors ret : Chapter3.
Hint Constructors styp : Chapter3.
Hint Constructors ltyp : Chapter3.
Hint Constructors rtyp : Chapter3.
Hint Constructors htyp : Chapter3.
Hint Constructors refp : Chapter3.
Hint Constructors prog : Chapter3.
Hint Constructors K : Chapter3.
Hint Constructors AK : Chapter3.
Hint Constructors ASGN : Chapter3.
Hint Constructors WFDG : Chapter3.
Hint Constructors WFU : Chapter3.
Hint Constructors WFC : Chapter3.
Hint Constructors WFD : Chapter3.
(* Hint Constructors ExtendedByD : Chapter3. *)

Hint Extern 4 => discriminate. (* For ifs. *)

(* Getting eauto to evaluate functions requires some of this. *)
Hint Extern 0 ((H.map _ _) = Some _) => try reflexivity : Chapter3.
Hint Extern 0 ((H.add _ _) = _) => try reflexivity : Chapter3.
Hint Extern 0 ((H.delete _ _) = _) => try reflexivity : Chapter3.

Hint Extern 0 ((D.map _ _) = Some _) => try reflexivity : Chapter3.
Hint Extern 0 ((G.map _ _) = Some _) => try reflexivity : Chapter3.
Hint Extern 0 (U.map _ _ _ = None) => try reflexivity : Chapter3.

(* Now the judgements work by popping of the left most element of their lists. *)

Lemma app_removefirst_first :
  forall (A : Type) (d : A) (l : list A),
    l <> nil -> l = [hd d l] ++ (tail l).
Proof.
Admitted.

Ltac left_list_recurse_gamma m :=
  rewrite app_removefirst_first with (l:= m) (d:=(EV.var(1000),cint));
  try simpl hd;
  try simpl tail;
  try discriminate.

Ltac left_list_recurse_delta m :=
  rewrite app_removefirst_first with (l:= m) (d:=(TV.var(1000),A));
  try simpl hd;
  try simpl tail;
  try discriminate.

Ltac left_list_recurse_upsilon m :=
  rewrite app_removefirst_first with (l:= m) (d:= ( ((EV.var 1000), []), cint));
  try simpl hd;
  try simpl tail;
  try discriminate.

Ltac left_list_recurse_path m :=
  rewrite app_removefirst_first with (l:= m) (d:= (u_pe));
  try simpl hd;
  try simpl tail;
  try discriminate.

Ltac list_splitter :=
   match goal with
     | [ |- gettype _ _ _ _ (?x ++ ?y) _ ]   => try constructor
     | [ |- gettype _ _ _ _ ?x _ ]
       => try (left_list_recurse_path x; constructor)

   end.

Hint Extern 3 (gettype _ _ _ _ _ _)   => list_splitter.

Hint Extern 5 ([] ++ _ = _) => try reflexivity.
Hint Extern 5 (_ = [] + _)  => try reflexivity.

(* A sleazy way to work around this eauto requires my db bug. *)
Ltac Crunch := eauto 20 with Chapter3; crush; eauto 20 with Chapter3.


Require Import Bool List String Peano_dec Lia.
Require Import Common FMap IndexSupport HVector Syntax Topology Semantics SemFacts StepM.
Require Import Invariant TrsInv Simulation Serial SerialFacts.
Require Import RqRsLang RqRsCorrect.

Require Import Ex.Spec Ex.SpecInds Ex.Template.
Require Import Ex.Mesi Ex.Mesi.Mesi.

Set Implicit Arguments.

Import PropMonadNotations.
Import CaseNotations.

Local Open Scope list.
Local Open Scope hvec.
Local Open Scope fmap.

#[global] Existing Instance Mesi.ImplOStateIfc.

Section ObjInv.
  Variable topo: DTree.

  Definition MesiUpLockObjInv (oidx: IdxT): ObjInv :=
    fun ost orq =>
      (rqiu <+- orq@[upRq];
      rmsg <+- rqiu.(rqi_msg);
      match case rmsg.(msg_id) on idx_dec default True with
      | mesiRqS:
          ost#[owned] = false /\ ost#[status] <= mesiI /\
          ost#[dir].(dir_st) <= mesiS
      | mesiRqM:
          ost#[owned] = false /\ ost#[status] <= mesiS /\
          ost#[dir].(dir_st) <= mesiS
      end).

  Definition DownLockFromChild (oidx: IdxT) (rqid: RqInfo Msg) :=
    exists cidx,
      rqid.(rqi_midx_rsb) = Some (downTo cidx) /\
      parentIdxOf topo cidx = Some oidx.

  Definition DownLockFromParent (oidx: IdxT) (rqid: RqInfo Msg) :=
    rqid.(rqi_midx_rsb) = Some (rsUpFrom oidx).

  Definition MesiDownLockObjInv (oidx: IdxT): ObjInv :=
    fun ost orq =>
      (rqid <+- orq@[downRq];
      rmsg <+- rqid.(rqi_msg);
      match case rmsg.(msg_id) on idx_dec default True with
      | mesiRqS: DownLockFromChild oidx rqid /\
                 ost#[status] <= mesiI /\ mesiE <= ost#[dir].(dir_st) <= mesiM /\
                 In ost#[dir].(dir_excl) (subtreeChildrenIndsOf topo oidx) /\
                 map fst rqid.(rqi_rss) = [rsUpFrom ost#[dir].(dir_excl)]
      | mesiRqM: DownLockFromChild oidx rqid /\
                 ost#[status] <= mesiS /\
                 ((ost#[owned] = true /\ ost#[dir].(dir_st) = mesiS /\
                   SubList ost#[dir].(dir_sharers) (subtreeChildrenIndsOf topo oidx) /\
                   (rsb <+- rqid.(rqi_midx_rsb);
                   map fst rqid.(rqi_rss) =
                   map rsUpFrom (remove idx_dec (objIdxOf rsb) ost#[dir].(dir_sharers)))) \/
                  (mesiE <= ost#[dir].(dir_st) <= mesiM /\
                   In ost#[dir].(dir_excl) (subtreeChildrenIndsOf topo oidx) /\
                   map fst rqid.(rqi_rss) = [rsUpFrom ost#[dir].(dir_excl)]))
      | mesiDownRqS: DownLockFromParent oidx rqid /\
                     ost#[status] <= mesiI /\ mesiE <= ost#[dir].(dir_st) <= mesiM /\
                     In ost#[dir].(dir_excl) (subtreeChildrenIndsOf topo oidx) /\
                     map fst rqid.(rqi_rss) = [rsUpFrom ost#[dir].(dir_excl)]
      | mesiDownRqIS: DownLockFromParent oidx rqid /\
                      ost#[dir].(dir_st) = mesiS /\
                      SubList ost#[dir].(dir_sharers) (subtreeChildrenIndsOf topo oidx) /\
                      map fst rqid.(rqi_rss) = map rsUpFrom ost#[dir].(dir_sharers)
      | mesiDownRqIM: DownLockFromParent oidx rqid /\
                      ((ost#[dir].(dir_st) = mesiS /\
                        SubList ost#[dir].(dir_sharers) (subtreeChildrenIndsOf topo oidx) /\
                        map fst rqid.(rqi_rss) = map rsUpFrom ost#[dir].(dir_sharers)) \/
                       (mesiE <= ost#[dir].(dir_st) <= mesiM /\
                        In ost#[dir].(dir_excl) (subtreeChildrenIndsOf topo oidx) /\
                        map fst rqid.(rqi_rss) = [rsUpFrom ost#[dir].(dir_excl)]))
      end).

  Definition MesiObjInvs (oidx: IdxT): ObjInv :=
    fun ost orq =>
      MesiUpLockObjInv oidx ost orq /\
      MesiDownLockObjInv oidx ost orq.

End ObjInv.

Ltac disc_mesi_obj_invs :=
  repeat
    match goal with
    | [H: MesiObjInvs _ _ _ _ |- _] => destruct H
    | [H: MesiUpLockObjInv _ _ _ |- _] =>
      red in H; mred; simpl in H; disc_rule_conds_const
    | [H: MesiDownLockObjInv _ _ _ _ |- _] =>
      red in H; mred; simpl in H; disc_rule_conds_const
    | [Hmsg: msg_id ?rmsg = _, H: context [msg_id ?rmsg] |- _] =>
      rewrite Hmsg in H; simpl in H
    end.


Require Import Coq.Logic.Classical_Prop.

Require Import SpecCert.Address.
Require Import SpecCert.Cache.
Require Import SpecCert.Formalism.
Require Import SpecCert.Interval.
Require Import SpecCert.Map.
Require Import SpecCert.Memory.
Require Import SpecCert.Smm.Delta.Invariant.
Require Import SpecCert.Smm.Delta.Preserve.Architecture.
Require Import SpecCert.Smm.Software.
Require Import SpecCert.x86.

Lemma write_strat_uc
      (pa: PhysicalAddress)
      (v:  Value)
  : partial_preserve (Write pa v)
                     (fun a => resolve_cache_strategy (proc a) pa = Uncachable)
                     inv.
Proof.
  unfold partial_preserve.
  intros a a' Hinv Hsmm_strat Hpre Hpost.
  unfold x86_postcondition, write_post in Hpost.
  rewrite Hsmm_strat in Hpost.
  unfold write_uncachable in Hpost.
  apply (update_memory_content_with_context_preserves_inv a a' pa v Hinv Hpost).
Qed.

Lemma write_strat_sh
      (pa: PhysicalAddress)
      (v: Value)
  : partial_preserve (Write pa v)
                     (fun a => resolve_cache_strategy (proc a) pa = SmrrHit)
                     inv.
Proof.
  unfold partial_preserve.
  intros a a' Hinv Hsmm_strat Hpre Hpost.
  unfold x86_postcondition, write_post in Hpost.
  rewrite Hsmm_strat in Hpost.
  unfold write_smrrhit in Hpost.
  rewrite Hpost.
  exact Hinv.
Qed.

Lemma write_strat_smrr_wb
      (pa: PhysicalAddress)
      (v:  Value)
  : partial_preserve (Write pa v)
                     (fun a => is_inside_smrr (proc a) pa
                            /\ smm_strategy (smrr (proc a)) = WriteBack)
                     inv.
Proof.
  unfold partial_preserve.
  intros a a' Hinv [Hinside_smrr Hsmm_strat] Hpre Hpost.
  unfold x86_postcondition, write_post, resolve_cache_strategy in Hpost.
  destruct is_inside_smrr_dec; [| intuition ].
  destruct is_in_smm_dec as [Hin_smm|Hnot].
  + rewrite Hsmm_strat in Hpost.
    unfold write_writeback in Hpost.
    assert (is_inside_smram pa -> is_in_smm (proc a)); [
        intro Hin;
        exact Hin_smm |].
    destruct cache_hit_dec.
    * apply (update_cache_content_with_context_preserves_inv a a' pa v Hinv H Hpost).
    * remember (load_in_cache_from_memory a pa) as a''.
      assert (inv a'') as Hinv''; [
          apply (load_in_cache_from_memory_preserves_inv a a'' pa Hinv H Heqa'') |].
      assert (proc a = proc a'').
      apply load_in_cache_from_memory_changes_only_mem_and_cache in Heqa'' as [Hproc Hmc].
      rewrite <- Hproc.
      reflexivity.
      assert (is_in_smm (proc a'')).
      rewrite <- H0.
      exact Hin_smm.
      assert (is_inside_smram pa -> is_in_smm (proc a'')); [
        intro Hin;
          exact H1 |].
      rewrite (context_is_preserves a a'' H0) in Hpost.
      eapply (update_cache_content_with_context_preserves_inv a'' a' pa v Hinv'' H2 Hpost).
  + unfold write_smrrhit in Hpost.
    rewrite Hpost.
    exact Hinv.
Qed.

Lemma write_not_smrr
      (pa: PhysicalAddress)
      (v: Value)
  : partial_preserve (Write pa v)
                     (fun a => ~ is_inside_smrr (proc a) pa)
                     inv.
Proof.
  unfold partial_preserve.
  intros a a' Hinv Hnot_inside_smrr Hpre Hpost.
  unfold x86_postcondition in Hpost;
  unfold x86_precondition in Hpre.
  assert (write_post smm_context pa v a a') as Hx; [unfold x86_postcondition in Hpost; exact Hpost |].
  remember (resolve_cache_strategy (proc a) pa) as strat.
  unfold write_post in Hpost.
  assert (strat = strategy (proc a)).
  unfold resolve_cache_strategy in Heqstrat.
  destruct is_inside_smrr_dec; [ intuition |].
  exact Heqstrat.
  case_eq (resolve_cache_strategy (proc a) pa); intro Hres; rewrite Hres in Hpost.
  + apply (write_strat_uc pa v a a' Hinv Hres Hpre Hx).
  + destruct (is_inside_smrr_dec (proc a) pa); [ intuition |].
    unfold write_writeback in Hpost.
    assert (is_inside_smram pa -> is_in_smm (proc a)).
    intro Hfalse.
    destruct Hinv as [Hsmramc [Hsmram [Hsmrr Hclean]]].
    apply Hsmrr in Hfalse.
    apply n in Hfalse.
    destruct Hfalse.
    destruct (cache_hit_dec (cache a) pa).
    * apply (update_cache_content_with_context_preserves_inv a a' pa v Hinv H0 Hpost).
    * apply (load_then_update_cache_with_context_preserves_inv a a' pa v Hinv H0 Hpost).
 + apply (write_strat_sh pa v a a' Hinv Hres Hpre Hx).
Qed.

Lemma write_inv
      (pa: PhysicalAddress)
      (v: Value)
  : preserve (Write pa v) inv.
Proof.
  unfold preserve.
  intros a a' Hinv Htrans.
  destruct (is_inside_smrr_dec (proc a) pa).
  + case_eq (resolve_cache_strategy (proc a) pa); intro Hres.
    * apply (write_strat_uc pa v a a' Hinv Hres Htrans).
    * assert (is_inside_smrr (proc a) pa /\ smm_strategy (smrr (proc a)) = WriteBack).
      split; [ exact i |].
      unfold resolve_cache_strategy in Hres.
      destruct is_inside_smrr_dec; [| intuition ].
      destruct is_in_smm_dec; [| discriminate Hres ].
      exact Hres.
      apply (write_strat_smrr_wb pa v a a' Hinv H Htrans).
    * apply (write_strat_sh pa v a a' Hinv Hres Htrans).
  + apply (write_not_smrr pa v a a' Hinv n Htrans).
Qed.