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

Module ocpl.
Include with_adv_and_link.

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

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

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

  malloc_mem_size :
    (malloc_mem_start <= malloc_end)%a;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

End ocpl.


Require Import Benchmarks.ProcessSchedulerSetup.

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

        Definition SchedulerSchema          Def ADT Schema  rep := QueryStructure Structure,

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

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

             Def Constructor0 "Init" : rep := empty,

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

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

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

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

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

Eval lazy in (methodBody "Spawn" CUnit).

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

Eval lazy in (methodBody "Enumerate" CUnit).

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

Eval lazy in (methodBody "GetCPUTime" CUnit).

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


Require Import Bool.
Require Import List.

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

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

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

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

Require Import Syntax.
Require Import Semantics.

Set Implicit Arguments.

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

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


(* Well-scopedness definition for LambdaANF. Part of the CertiCoq project.
 * Author: Anonymized, 2016
 *)

Require Import LambdaANF.set_util LambdaANF.cps LambdaANF.eval LambdaANF.cps_util LambdaANF.ctx LambdaANF.identifiers.
Require Import Coq.MSets.MSetRBT Coq.Lists.List.
Require Import compcert.lib.Coqlib.

Import PS.

Definition env_subset (rho1 rho2 : env) :=
  forall x v, M.get x rho1 = Some v -> M.get x rho2 = Some v.

(** An expression is well scoped in an environment: [Γ |- e] *)
Inductive well_scoped_exp : env -> exp -> Prop :=
| WS_constr :
    forall x t ys vs e Γ,
      get_list ys Γ = Some vs ->
      (forall v, well_scoped_exp (M.set x v Γ) e) ->
      well_scoped_exp Γ (Econstr x t ys e)
| WS_case :
    forall x v te Γ,
      M.get x Γ = Some v ->
      Forall (fun p => well_scoped_exp Γ (snd p)) te ->
      well_scoped_exp Γ (Ecase x te)
| WSproj :
    forall x tau N y v e Γ,
      M.get y Γ = Some v ->
      (forall v, well_scoped_exp (M.set x v Γ) e) ->
      well_scoped_exp Γ (Eproj x tau N y e)
| WSletapp :
    forall x tau f ys v e Γ,
      get_list ys Γ = Some v ->
      (forall v, well_scoped_exp (M.set x v Γ) e) ->
      well_scoped_exp Γ (Eletapp x f tau ys e)
| WS_app :
    forall x v ys vs ft Γ,
      get_list ys Γ = Some vs ->
      M.get x Γ = Some v ->
      well_scoped_exp Γ (Eapp x ft ys)
| WS_prim :
    forall x f ys vs e Γ,
      get_list ys Γ = Some vs ->
      (forall v, well_scoped_exp (M.set x v Γ) e) ->
      well_scoped_exp Γ (Eprim x f ys e)
| WS_halt :
    forall x v Γ,
      M.get x Γ = Some v ->
      well_scoped_exp Γ (Ehalt x)
| WS_fun :
    forall defs e Γ,
      well_scoped_fundefs Γ defs ->
      (forall vs Γ',
         set_lists (elements (fundefs_names defs)) vs Γ = Some Γ' ->
         well_scoped_exp Γ' e) ->
      well_scoped_exp Γ (Efun defs e)
with well_scoped_fundefs : env -> fundefs -> Prop :=
| WS_fcons :
    forall f tau xs e defs Γ,
      (forall vs vs' Γ' Γ'',
         set_lists (elements (fundefs_names defs)) vs' Γ = Some Γ' ->
         set_lists xs vs Γ' = Some Γ'' ->
         well_scoped_exp Γ'' e) ->
      (forall v, well_scoped_fundefs (M.set f v Γ) defs) ->
      well_scoped_fundefs Γ (Fcons f tau xs e defs)
| WS_fnil :
    forall Γ,
      well_scoped_fundefs Γ Fnil.

Fixpoint fundefs_ctx_names (cdefs : fundefs_ctx) : FVSet :=
  match cdefs with
    | Fcons1_c f _ _ _ defs => add f (fundefs_names defs)
    | Fcons2_c f _ _ _ cdefs' => add f (fundefs_ctx_names cdefs')
  end.

(** [Γ {[Γ']} |- c  ]: A context is well scoped in an environment Γ, given that
    the expression we put in the hole is well scoped in the environment Γ' *)
Inductive well_scoped_exp_ctx : env -> exp_ctx -> env -> Prop :=
| WSCtx_hole :
    forall Γ Γ',
      env_subset Γ' Γ ->
      well_scoped_exp_ctx Γ Hole_c Γ'
| WSCtx_constr :
    forall x t ys vs c Γ Γ',
      get_list ys Γ = Some vs ->
      (forall v, well_scoped_exp_ctx (M.set x v Γ) c Γ') ->
      well_scoped_exp_ctx Γ (Econstr_c x t ys c) Γ'
| WSCtx_proj :
    forall x tau N y v c Γ Γ',
      M.get y Γ = Some v ->
      (forall v, well_scoped_exp_ctx (M.set x v Γ) c Γ') ->
      well_scoped_exp_ctx Γ (Eproj_c x tau N y c) Γ'
| WSCtx_letapp :
    forall x tau f ys vs c Γ Γ',
      get_list ys Γ = Some vs->
      (forall v, well_scoped_exp_ctx (M.set x v Γ) c Γ') ->
      well_scoped_exp_ctx Γ (Eletapp_c x f tau ys c) Γ'
| WSCtx_prim :
    forall x f ys vs c Γ Γ',
      get_list ys Γ = Some vs ->
      (forall v, well_scoped_exp_ctx (M.set x v Γ) c Γ') ->
      well_scoped_exp_ctx Γ (Eprim_c x f ys c) Γ'
| WSCtx_fun1 :
    forall defs c Γ Γ',
      well_scoped_fundefs Γ defs ->
      (forall vs Γ'',
         set_lists (elements (fundefs_names defs)) vs Γ = Some Γ'' ->
         well_scoped_exp_ctx Γ'' c Γ') ->
      well_scoped_exp_ctx Γ (Efun1_c defs c) Γ'
| WSCtx_fun2 :
    forall cdefs e Γ Γ',
      well_scoped_fundefs_ctx Γ cdefs Γ' ->
      (forall vs Γ'',
         set_lists (elements (fundefs_ctx_names cdefs)) vs Γ = Some Γ'' ->
         well_scoped_exp Γ'' e) ->
      well_scoped_exp_ctx Γ (Efun2_c cdefs e) Γ'
with well_scoped_fundefs_ctx : env -> fundefs_ctx -> env -> Prop :=
| WS_fcons1 :
    forall f tau xs c defs Γ Γ',
      (forall vs vs' Γ'' Γ''',
         set_lists (elements (fundefs_names defs)) vs' Γ = Some Γ''->
         set_lists xs vs Γ'' = Some Γ''' ->
         well_scoped_exp_ctx Γ''' c Γ') ->
      (forall v, well_scoped_fundefs (M.set f v Γ) defs) ->
      well_scoped_fundefs_ctx Γ (Fcons1_c f tau xs c defs) Γ'
| WS_fcons2 :
    forall f tau xs e cdefs Γ Γ',
      (forall vs vs' Γ'' Γ''',
         set_lists (elements (fundefs_ctx_names cdefs)) vs' Γ = Some Γ''->
         set_lists xs vs Γ'' = Some Γ''' ->
         well_scoped_exp Γ''' e) ->
      (forall v, well_scoped_fundefs_ctx (M.set f v Γ) cdefs Γ') ->
      well_scoped_fundefs_ctx Γ (Fcons2_c f tau xs e cdefs) Γ'.

Declare Scope env_scope.

Notation "Γ '⊢' e" := (well_scoped_exp Γ e) (at level 30, no associativity)
                      : env_scope.
Notation "Γ '{[' Γ' ']}' '⊢' e " := (well_scoped_exp_ctx Γ e Γ')
                                      (at level 30, no associativity)
                                    : env_scope.
Notation "Γ '⊢*' f" := (well_scoped_fundefs Γ f) (at level 30, no associativity)
                       : env_scope.
Notation "Γ '{[' Γ' ']}' '⊢*' f " := (well_scoped_fundefs_ctx Γ f Γ')
                                       (at level 30, no associativity)
                                     : env_scope.

Open Scope env_scope.
Open Scope ctx_scope.

Lemma env_subset_set Γ Γ' x v :
  env_subset Γ Γ' ->
  env_subset (M.set x v Γ) (M.set x v Γ')
.
Proof.
  intros Hsub x' v' Hget. rewrite M.gsspec in *.
  destruct (peq x' x); eauto.
Qed.

Lemma env_subset_set_lists Γ1 Γ2 Γ1' xs vs :
  env_subset Γ2 Γ1 ->
  Some Γ1' = set_lists xs vs Γ1 ->
  exists Γ2', Some Γ2' = set_lists xs vs Γ2 /\ env_subset Γ2' Γ1'.
Proof.
  revert vs Γ1'.
  induction xs; simpl; intros vs Γ1' Hsub Hset1;
  destruct vs; try discriminate.
  - inv Hset1; eexists; eauto.
  - destruct (set_lists xs vs Γ1) as [Γ1'' | ] eqn:Heq; try discriminate.
    edestruct (IHxs vs Γ1'' Hsub) as [Γ2' [Heq' Ηsub]]; eauto. inv Hset1.
    exists (M.set a v Γ2'). split. rewrite <- Heq'. eauto.
    eapply env_subset_set. eauto.
Qed.

Lemma env_subset_get_list Γ1 Γ2 xs vs :
  env_subset Γ1 Γ2 ->
  get_list xs Γ1 = Some vs ->
  get_list xs Γ2 = Some vs.
Proof.
  revert vs.
  induction xs; simpl; intros vs Hsub Hget; eauto.
  destruct (M.get a Γ1) eqn:Heq; try discriminate.
  destruct (get_list xs Γ1) eqn:Heq'; try discriminate.
  eapply Hsub in Heq. rewrite Heq. inv Hget.
  erewrite IHxs; eauto.
Qed.

Lemma env_subset_get Γ1 Γ2 x v :
  env_subset Γ1 Γ2 ->
  M.get x Γ1 = Some v ->
  M.get x Γ2 = Some v.
Proof.
  intros Henv Hget. eauto.
Qed.

Lemma well_scoped_exp_fundefs_weakening :
  (forall e Γ Γ',
     Γ ⊢ e -> env_subset Γ Γ' -> Γ' ⊢ e) /\
  (forall defs Γ Γ',
     Γ ⊢* defs -> env_subset Γ Γ' -> Γ' ⊢* defs).
Proof.
  exp_defs_induction IHc IHl IHfc; intros Γ Γ' Hws Hsub;
  try (now inv Hws; econstructor; eauto using env_subset_get_list, env_subset_get;
       intros; eapply IHc; eauto using env_subset_set).
  - inv Hws; econstructor; eauto.
    inv H3. constructor; eauto.
    assert (Hsuf : Γ' ⊢ Ecase v l)
      by (eapply IHl; eauto; econstructor; eauto).
    inv Hsuf; eauto.
  - inv Hws. constructor; eauto.
    intros. edestruct env_subset_set_lists as [Γ2 [Hset2 Hsub2]]; eauto.
  - inv Hws. constructor; eauto.
    intros. edestruct env_subset_set_lists as [Γ2 [Hset2 Hsub2]]; eauto.
    edestruct env_subset_set_lists as [Γ3 [Hset3 Hsub3]]; eauto.
    intros. eapply IHfc; eauto using env_subset_set.
Qed.

Lemma fundefs_names_eq fc e :
  eq (fundefs_ctx_names fc) (fundefs_names (fc <[ e ]>)).
Proof.
  induction fc; simpl; intros x; split; intros HIn; eauto;
  eapply add_spec in HIn; inv HIn; eapply add_spec; eauto;
  right; eapply IHfc; eauto.
Qed.

Lemma fundefs_names_elem fc e :
  eq (fundefs_ctx_names fc) (fundefs_names (fc <[ e ]>)).
Proof.
  induction fc; simpl; eauto;
  intros x; split; intros HIn; eauto;
  eapply add_spec in HIn; inv HIn; eapply add_spec; eauto;
  right; eapply IHfc; eauto.
Qed.

Lemma well_scoped_ctx_app :
  (forall c e Γ Γ',
     Γ {[ Γ' ]} ⊢ c  -> Γ' ⊢ e -> Γ  ⊢ c |[ e ]| ) /\
  (forall fc e Γ Γ',
     Γ {[ Γ' ]} ⊢* fc  -> Γ' ⊢ e -> Γ  ⊢* fc <[ e ]>).
Proof.
  exp_fundefs_ctx_induction IHc IHfc;
  try (now intros e' Γ Γ' Hws1 Hws2; inv Hws1;
       simpl; econstructor; eauto).
  - intros e' Γ Γ' Hws1 Hws2. inv Hws1. simpl.
    eapply well_scoped_exp_fundefs_weakening; eauto.
  - intros te e' Γ Γ' Hws1 Hws2. inv Hws1.
  - intros e' Γ Γ' Hws1 Hws2. inv Hws1.
    simpl. econstructor; eauto. intros.
    eapply H4. erewrite elements_eq; eauto.
    apply fundefs_names_eq.
  - intros e' Γ Γ' Hws1 Hws2. inv Hws1.
    simpl. econstructor; eauto. intros.
    eapply H6. erewrite elements_eq; eauto.
    apply fundefs_names_eq. eauto.
Qed.


Require Import Eqdep Lia Framework FSParameters FileDiskLayer. (* LoggedDiskLayer TransactionCacheLayer TransactionalDiskLayer. *)
Require Import FileDiskNoninterference FileDiskRefinement.
Require Import ATCDLayer FileDisk.TransferProofs ATCD_Simulation ATCD_AOE.
Require Import Not_Init HSS ATCD_ORS ATCD_TS_Common ATCD_TS_Recovery ATCD_TS_Transaction.

Import FileDiskLayer.
Set Nested Proofs Allowed.

Opaque File.recover.
Lemma ATCD_TS_InodeAllocator_read:
forall n inum u u' txns1 txns2 hdr1 hdr2,
Termination_Sensitive u
(Simulation.Definitions.compile
 ATCD_Refinement
 (Simulation.Definitions.compile
 ATC_Refinement
(@lift_L2 AuthenticationOperation _ TD _
    (Inode.InodeAllocator.read inum))))
(Simulation.Definitions.compile
 ATCD_Refinement
 (Simulation.Definitions.compile
 ATC_Refinement
(@lift_L2 AuthenticationOperation _ TD _
    (Inode.InodeAllocator.read inum))))
(Simulation.Definitions.compile
 ATCD_Refinement
 (Simulation.Definitions.compile
 ATC_Refinement
 (Simulation.Definitions.compile
    FD.refinement
    (| Recover |))))
(refines_valid ATCD_Refinement
  (refines_valid ATC_Refinement
 AD_valid_state))
(fun s1 s2 =>
refines_related ATCD_Refinement
(fun s1 s2 => refines_related ATC_Refinement
 (fun s1 s2  => exists s1a s2a,
    File.files_inner_rep s1a (fst (snd (snd s1))) /\
    File.files_inner_rep s2a (fst (snd (snd s2))) /\
    FD_related_states u' None s1a s2a) s1 s2 /\
(forall a,
 Transaction.get_first (fst (snd s1)) a = None <->
 Transaction.get_first (fst (snd s2)) a = None)) s1 s2 /\
 equivalent_for_recovery txns1 txns2 Log.Current_Part hdr1 hdr2 s1 s2 /\
 (forall a,
 fst (snd (snd s1)) a = None <->
 fst (snd (snd s2)) a = None) /\
 fst (snd (snd s1)) =
Mem.list_upd_batch empty_mem
  (map Log.addr_list txns1)
  (map Log.data_blocks txns1) /\
fst (snd (snd s2)) =
Mem.list_upd_batch empty_mem
  (map Log.addr_list txns2)
  (map Log.data_blocks txns2))
(ATCD_reboot_list n).
Proof.
Transparent Inode.InodeAllocator.read.
unfold Inode.InodeAllocator.read; simpl; intros.
destruct (Compare_dec.lt_dec inum
Inode.InodeAllocatorParams.num_of_blocks).
2: {
  intros; eapply TS_eqv_impl.
  apply ATCD_TS_ret.
  simpl; intuition eauto.
}
{
  eapply ATCD_TS_compositional; simpl.
  intros; eapply TS_eqv_impl.
  unfold Inode.InodeAllocatorParams.bitmap_addr in *.
  pose proof Inode.InodeAllocatorParams.blocks_fit_in_disk.
  intros; eapply ATCD_TS_Transaction_read.
  lia.
  simpl; intros; cleanup; eauto.
  {
    intros.
    unfold refines_related in *; cleanup.
    simpl in *; unfold HC_refines in *; cleanup.
    simpl in *; unfold HC_refines in *; cleanup.

    simpl in *; unfold TransactionToTransactionalDisk.Definitions.refines in *.
    unfold Definitions.refines in *; simpl in *.
    rewrite H13, H14.
    unfold LogCache.cached_log_rep in *; cleanup.
    repeat (split; eauto).
  }
  {
    simpl; intros.

    unfold refines_related in *; cleanup.
    edestruct ATCD_AOE.
    4: {
      instantiate (1:= RFinished _ _).
      instantiate (6:= []).
      unfold ATCD_reboot_list; simpl.
      econstructor.
      apply H.
    }
    all: try solve [simpl in *; eauto].
    shelve.

    edestruct ATCD_AOE.
    4: {
      instantiate (1:= RFinished _ _).
      instantiate (6:= []).
      unfold ATCD_reboot_list; simpl.
      econstructor.
      apply H0.
    }
    all: try solve [simpl in *; eauto].
    shelve.

    edestruct ATCD_simulation.
    2: apply H13.
    all: eauto.
    2:  unfold ATCD_reboot_list; simpl; econstructor; eauto.
    shelve.

    edestruct ATCD_simulation.
    2: apply H14.
    all: eauto.
    2:  unfold ATCD_reboot_list; simpl; econstructor; eauto.
    shelve.

    simpl in *; cleanup; repeat invert_exec.

    eapply_fresh lift2_invert_exec in H30;
    eapply_fresh lift2_invert_exec in H31; cleanup.

    unfold refines_related in *; cleanup.
    simpl in *; unfold HC_refines in *; cleanup.
    simpl in *; unfold TransactionToTransactionalDisk.Definitions.refines in *.

    eapply Transaction.read_finished in H26; eauto.
    eapply Transaction.read_finished in H24; eauto.

    unfold Inode.InodeAllocatorParams.bitmap_addr in *.
    cleanup; repeat split_ors; cleanup; try lia.
    erewrite InodeTS.inode_allocations_are_same with (s2:= fst (snd (snd x2))); eauto.
    destruct_fresh (nth_error
    (value_to_bits
       (fst (snd (snd x2)) Inode.InodeAllocatorParams.bitmap_addr)) inum);
    setoid_rewrite D; simpl.
    2: {
     eapply TS_eqv_impl.
      apply ATCD_TS_ret.
      shelve.
    }
    destruct b; simpl.
    2: {
     eapply TS_eqv_impl.
      apply ATCD_TS_ret.
      shelve.
    }
    eapply ATCD_TS_compositional; simpl.
    2: intros; apply ATCD_TS_ret.
    intros; eapply TS_eqv_impl.
    eapply ATCD_TS_Transaction_read.
    lia.
    shelve.
    intros; shelve.

    destruct (block_allocator_empty inum);
    rewrite H18;
    eapply TS_eqv_impl;
    try apply ATCD_TS_ret.
    shelve.
    shelve.
  }
  {
    simpl; intros; cleanup; eauto.
    unfold refines_related in *; cleanup.
    edestruct ATCD_AOE.
    4: {
      instantiate (1:= RFinished _ _).
      instantiate (6:= []).
      unfold ATCD_reboot_list; simpl.
      econstructor.
      apply H.
    }
    all: try solve [simpl in *; eauto].
    shelve.

    edestruct ATCD_AOE.
    4: {
      instantiate (1:= RFinished _ _).
      instantiate (6:= []).
      unfold ATCD_reboot_list; simpl.
      econstructor.
      apply H0.
    }
    all: try solve [simpl in *; eauto].
    shelve.

    edestruct ATCD_simulation.
    2: apply H13.
    all: eauto.
    2:  unfold ATCD_reboot_list; simpl; econstructor; eauto.
    shelve.

    edestruct ATCD_simulation.
    2: apply H14.
    all: eauto.
    2:  unfold ATCD_reboot_list; simpl; econstructor; eauto.
    shelve.

    simpl in *; cleanup; repeat invert_exec.

    eapply_fresh lift2_invert_exec in H30;
    eapply_fresh lift2_invert_exec in H31; cleanup.

    simpl in *; unfold HC_refines in *; cleanup.
    simpl in *; unfold TransactionToTransactionalDisk.Definitions.refines in *.

    eapply Transaction.read_finished in H26; eauto.
    eapply Transaction.read_finished in H24; eauto.

    unfold Inode.InodeAllocatorParams.bitmap_addr in *.
    pose proof Inode.InodeAllocatorParams.blocks_fit_in_disk.
    cleanup; repeat split_ors; cleanup; try lia; eauto.

    shelve.
  }
}
Unshelve.
all:
try match goal with
| [|- not_init _ ] =>
  unfold Transaction.read;
  destruct (Compare_dec.lt_dec Inode.InodeAllocatorParams.bitmap_addr
  data_length); simpl; intuition eauto;
  try destruct (Transaction.get_first t Inode.InodeAllocatorParams.bitmap_addr);
  simpl; intuition eauto;
  try match goal with
  | [H: eq_dep _ _ _ _ _ _ |- _] =>
  inversion H
  end
end.
5: instantiate (5 := fun _ _ s0 s3 =>
equivalent_for_recovery txns1 txns2 Log.Current_Part hdr1 hdr2 s0 s3 /\
(Transaction.get_first (fst (snd s0)) (inode_blocks_start + S inum) = None <->
 Transaction.get_first (fst (snd s3)) (inode_blocks_start + S inum) = None) /\
(fst (snd (snd s0)) (data_start + (inode_blocks_start + S inum)) = None <->
 fst (snd (snd s3)) (data_start + (inode_blocks_start + S inum)) = None) /\
fst (snd (snd s0)) =
Mem.list_upd_batch empty_mem (map Log.addr_list txns1)
  (map Log.data_blocks txns1) /\
fst (snd (snd s3)) =
Mem.list_upd_batch empty_mem (map Log.addr_list txns2)
  (map Log.data_blocks txns2)); simpl; intuition eauto.
5: simpl; intuition eauto.
9: simpl; intuition eauto.
5: simpl; intuition eauto.
14: simpl; intuition eauto.
10: simpl; intuition eauto.
5: {
  (*
  instantiate (1:= hdr2).
  instantiate (1:= hdr1).
  instantiate (1:= txns2).
  instantiate (1:= txns1).
  *)
  simpl; intuition eauto.
  simpl in *.

  simpl; intros; cleanup; eauto.
  unfold refines_related in *; cleanup.
  edestruct ATCD_AOE.
    4: {
      instantiate (1:= RFinished _ _).
      instantiate (6:= []).
      unfold ATCD_reboot_list; simpl.
      econstructor.
      apply H18.
    }
    all: try solve [simpl in *; eauto].
    shelve.
    simpl.
    unfold HC_refines; simpl.
    unfold HC_refines; simpl.
    unfold Definitions.refines, LogCache.cached_log_rep.
    unfold Log.log_rep, Log.log_header_rep, Log.log_rep_general.
    unfold equivalent_for_recovery in *; cleanup.
    eexists (_, (_, _)); simpl; intuition eauto.
    eexists; simpl; intuition eauto.

    edestruct ATCD_AOE.
    4: {
      instantiate (1:= RFinished _ _).
      instantiate (6:= []).
      unfold ATCD_reboot_list; simpl.
      econstructor.
      apply H26.
    }
    all: try solve [simpl in *; eauto].
    shelve.
    simpl.
    unfold HC_refines; simpl.
    unfold HC_refines; simpl.
    unfold Definitions.refines, LogCache.cached_log_rep.
    unfold Log.log_rep, Log.log_header_rep, Log.log_rep_general.
    unfold equivalent_for_recovery in *; cleanup.
    eexists (_, (_, _)); simpl; intuition eauto.
    eexists; simpl; intuition eauto.

    unfold equivalent_for_recovery in *; cleanup.
    edestruct ATCD_simulation.
    2: apply H35.
    all: eauto.
    3:  unfold ATCD_reboot_list; simpl; econstructor; eauto.
    shelve.
    unfold Simulation.Definitions.refines; simpl.
    unfold HC_refines; simpl.
    unfold HC_refines; simpl.
    unfold Definitions.refines, LogCache.cached_log_rep.
    unfold Log.log_rep, Log.log_header_rep, Log.log_rep_general.
    instantiate (1:= (_, (_, _))); simpl; intuition eauto.
    eexists; simpl; intuition eauto.

    edestruct ATCD_simulation.
    2: apply H44.
    all: eauto.
    3:  unfold ATCD_reboot_list; simpl; econstructor; eauto.
    shelve.
    unfold Simulation.Definitions.refines; simpl.
    unfold HC_refines; simpl.
    unfold HC_refines; simpl.
    unfold Definitions.refines, LogCache.cached_log_rep.
    unfold Log.log_rep, Log.log_header_rep, Log.log_rep_general.
    instantiate (1:= (_, (_, _))); simpl; intuition eauto.
    eexists; simpl; intuition eauto.

    simpl in *; cleanup_no_match; repeat invert_exec.

    repeat invert_lift2.
    simpl in *; unfold HC_refines in *; cleanup.
    simpl in *; unfold TransactionToTransactionalDisk.Definitions.refines in *.

    repeat cleanup_pairs.
    (*
    eapply Transaction.read_finished in H80; eauto.
    eapply Transaction.read_finished in H81; eauto.

    cleanup; repeat cleanup_pairs.

    repeat match goal with
    |[H: _ \/ _|- _] =>
    clear H
    end.

    unfold HC_refines in *; simpl in *; cleanup.
    unfold Definitions.refines, LogCache.cached_log_rep in *.
    unfold Log.log_rep, Log.log_header_rep, Log.log_rep_general in *.
    cleanup.

    eexists (_, (_, _)), (_, (_, _)); simpl; split.
    intuition eauto.
    do 2 eexists; split.
    eauto.
    *)
    admit.
}
Admitted.

Lemma ATCD_TS_DiskAllocator_read:
    forall n a1 a2 u u' txns1 txns2 hdr1 hdr2,
    (a1 < File.DiskAllocatorParams.num_of_blocks <-> a2 < File.DiskAllocatorParams.num_of_blocks) ->
    (File.DiskAllocatorParams.bitmap_addr + S a1 <
    data_length <->
    File.DiskAllocatorParams.bitmap_addr + S a2 <
    data_length) ->
    Termination_Sensitive u
  (Simulation.Definitions.compile
     ATCD_Refinement
     (Simulation.Definitions.compile
    ATC_Refinement
     (@lift_L2 AuthenticationOperation _ TD _
     (File.DiskAllocator.read a1))))
  (Simulation.Definitions.compile
     ATCD_Refinement
     (Simulation.Definitions.compile
    ATC_Refinement
     (@lift_L2 AuthenticationOperation _ TD _
     (File.DiskAllocator.read a2))))
  (Simulation.Definitions.compile
     ATCD_Refinement
     (Simulation.Definitions.compile
    ATC_Refinement
     (Simulation.Definitions.compile
        FD.refinement
        (| Recover |))))
        (refines_valid ATCD_Refinement
        (refines_valid ATC_Refinement
       AD_valid_state))
  (fun s1 s2 => equivalent_for_recovery txns1 txns2 Log.Current_Part hdr1 hdr2 s1 s2 /\
  refines_related ATCD_Refinement (fun s1 s2 => refines_related ATC_Refinement
  (fun s1 s2  => exists s1a s2a,
  File.files_inner_rep s1a (fst (snd (snd s1))) /\
  File.files_inner_rep s2a (fst (snd (snd s2))) /\
  FD_related_states u' None s1a s2a) s1 s2 /\
  (forall a,
     Transaction.get_first (fst (snd s1)) a = None <->
     Transaction.get_first (fst (snd s2)) a = None) /\
  (Transaction.get_first (fst (snd s1)) (File.DiskAllocatorParams.bitmap_addr + S a1) = None <->
   Transaction.get_first (fst (snd s2)) (File.DiskAllocatorParams.bitmap_addr + S a2) = None) /\
   nth_error
            (value_to_bits
               (upd_batch (snd (snd s1)) (rev (map fst (fst (snd s1))))
               (rev (map snd (fst (snd s1)))) File.DiskAllocatorParams.bitmap_addr)) a1 =
               nth_error
            (value_to_bits
               (upd_batch (snd (snd s2)) (rev (map fst (fst (snd s2))))
               (rev (map snd (fst (snd s2)))) File.DiskAllocatorParams.bitmap_addr)) a2) s1 s2)
  (ATCD_reboot_list n).
  Proof.
    unfold File.DiskAllocator.read; intros.
    destruct (Compare_dec.lt_dec a1 File.DiskAllocatorParams.num_of_blocks);
    destruct (Compare_dec.lt_dec a2 File.DiskAllocatorParams.num_of_blocks);
    try lia.
    2: intros; eapply TS_eqv_impl; [apply ATCD_TS_ret | shelve].
    simpl.
    eapply ATCD_TS_compositional.

    intros; eapply TS_eqv_impl.
    eapply ATCD_TS_Transaction_read.
    shelve.
    shelve.
    intros; cleanup; eauto.
    2: shelve.
    intros.

    intros; unfold refines_related in *; cleanup.
    intros; unfold refines_related in *; cleanup.
      eapply_fresh ATCD_oracle_refines_finished in H1; eauto.
      eapply_fresh ATCD_oracle_refines_finished in H2; eauto.
      cleanup.

      eapply_fresh ATCD_exec_lift_finished in H1; eauto;
      try solve [apply TransactionToTransactionalDisk.Refinement.TC_to_TD_core_simulation_finished];
      try solve [apply TransactionToTransactionalDisk.Refinement.TC_to_TD_core_simulation_crashed].
      cleanup.
      eapply_fresh ATCD_exec_lift_finished in H2; eauto;
      try solve [apply TransactionToTransactionalDisk.Refinement.TC_to_TD_core_simulation_finished];
      try solve [apply TransactionToTransactionalDisk.Refinement.TC_to_TD_core_simulation_crashed].
      cleanup.
      simpl in *.
      eapply_fresh ATCD_oracle_refines_impl_eq in H14; eauto.
      2: shelve. (* eapply have_same_structure_get_owner; eauto. *)
      2: apply TC_oracle_refines_operation_eq.
      cleanup.

      clear H1 H2.
    repeat invert_lift2; cleanup.
    apply HC_map_ext_eq in H1; subst.
    unfold HC_refines in *; simpl in *; cleanup.

    unfold TransactionToTransactionalDisk.Definitions.refines in *.
    eapply Transaction.read_finished in H18; eauto.
    eapply Transaction.read_finished in H21; eauto.
    cleanup; repeat split_ors; cleanup; try lia.
    unfold Transaction.transaction_rep in *; cleanup.
    setoid_rewrite H9.
    destruct_fresh (nth_error
    (value_to_bits
       (upd_batch (snd (snd x0)) (rev (map fst (fst (snd x0))))
          (rev (map snd (fst (snd x0))))
          File.DiskAllocatorParams.bitmap_addr)) a2); setoid_rewrite D.
          2: intros; eapply TS_eqv_impl; [apply ATCD_TS_ret | shelve].
    {
      destruct b.
      2: intros; eapply TS_eqv_impl; [apply ATCD_TS_ret | shelve].
      eapply ATCD_TS_compositional.
      2: intros; eapply TS_eqv_impl; [apply ATCD_TS_ret | shelve].
      intros; simpl;
      eapply TS_eqv_impl; [apply ATCD_TS_Transaction_read; eauto | shelve].
      shelve.
    }
    {
      edestruct (block_allocator_empty a1);
      edestruct (block_allocator_empty a2);
      cleanup;  (eapply TS_eqv_impl; [apply ATCD_TS_ret | shelve]).
    }
  Admitted.


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

(** This file provide the contextual refinement proof between PKContextNew layer and PThreadIntro layer*)
Require Import ShareIntroGenDef.

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

  Context `{real_params: RealParams}.

  Section WITHMEM.

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

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

    Lemma passthrough_correct:
      sim (crel HDATA LDATA) mshareintro_passthrough mptnew.
    Proof.
      sim_oplus.
      - apply fload_sim.
      - apply fstore_sim.
      - apply flatmem_copy_sim.
      - apply vmxinfo_get_sim.
      - apply device_output_sim.
      - apply pfree_sim.
      - apply setPT_sim.
      - apply ptRead_sim.
      - apply ptResv_sim.
      - apply ptResv2_sim.
      - apply pt_new_sim.
      - apply pmap_init_sim.
      - apply ptin_sim.
      - apply ptout_sim.
      - apply clearCR2_sim.
      - apply container_get_nchildren_sim.
      - apply container_get_quota_sim.
      - apply container_get_usage_sim.
      - apply container_can_consume_sim.
      - apply alloc_sim.
      - apply trapin_sim.
      - apply trapout_sim.
      - apply hostin_sim.
      - apply hostout_sim.
      - apply trap_info_get_sim.
      - apply trap_info_ret_sim.
      - layer_sim_simpl.
        + eapply load_correct2.
        + eapply store_correct2.
    Qed.

  End WITHMEM.

End Refinement.


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

(** This file provide the contextual refinement proof between MBoot layer and MALInit layer*)
Require Import ALInitGenDef.

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

  Context `{real_params: RealParams}.

  Section WITHMEM.

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

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

      Lemma setPG_exist:
        forall habd habd' labd f,
          setPG0_spec habd = Some habd'
          -> relate_RData f habd labd
          -> exists labd', setPG_spec labd = Some labd' /\ relate_RData f habd' labd'
                           /\ AT habd' = AT habd /\ nps habd' = nps habd.
      Proof.
        unfold setPG0_spec, setPG_spec; intros until f; exist_simpl.
      Qed.

      Lemma setCR3_exist:
        forall habd habd' labd id ofs f,
          setCR30_spec habd (GLOBP id ofs) = Some habd'
          -> relate_RData f habd labd
          -> exists labd', setCR3_spec labd (GLOBP id ofs) = Some labd' /\ relate_RData f habd' labd'
                           /\ AT habd' = AT habd /\ nps habd' = nps habd.
      Proof.
        unfold setCR30_spec, setCR3_spec; intros until f; exist_simpl.
      Qed.

      Lemma trapout_exist:
        forall habd habd' labd f,
          trapout0_spec habd = Some habd'
          -> relate_RData f habd labd
          -> exists labd', trapout'_spec labd = Some labd' /\ relate_RData f habd' labd'
                           /\ AT habd' = AT habd /\ nps habd' = nps habd.
      Proof.
        unfold trapout0_spec, trapout'_spec; intros until f; exist_simpl.
      Qed.

      Lemma hostout_exist:
        forall habd habd' labd f,
          hostout_spec habd = Some habd'
          -> relate_RData f habd labd
          -> exists labd', hostout'_spec labd = Some labd' /\ relate_RData f habd' labd'
                           /\ AT habd' = AT habd /\ nps habd' = nps habd.
      Proof.
        unfold hostout_spec, hostout'_spec; intros until f; exist_simpl.
      Qed.

    End Exists.

    Ltac pattern2_refinement_simpl:=
      pattern2_refinement_simpl' (@relate_AbData).

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

    Lemma passthrough_correct:
      sim (crel HDATA LDATA) malinit_passthrough mboot.
    Proof.
      sim_oplus.
      - apply fload'_sim.
      - apply fstore'_sim.
      - apply flatmem_copy'_sim.
      - apply vmxinfo_get_sim.
      - apply device_output_sim.
      - apply get_size_sim.
      - apply is_mm_usable_sim.
      - apply get_mm_s_sim.
      - apply get_mm_l_sim.
      - apply bootloader0_sim.
      - (* set_PG *)
        layer_sim_simpl; compatsim_simpl (@match_AbData); intros.
        exploit setPG_exist; eauto 1; intros [labd' [HP [HM[HAT HN]]]].
        match_external_states_simpl. congruence.
      - apply clearCR2_sim.
      - (* set_CR3 *)
        layer_sim_simpl; compatsim_simpl (@match_AbData); intros.
        inv_val_inject.
        eapply inject_forward_equal' in H8; eauto 1. inv H8.
        exploit setCR3_exist; eauto 1; intros [labd' [HP [HM[HAT HN]]]].
        match_external_states_simpl.
        rewrite Int.add_zero; eauto. congruence.
      - apply trapin_sim.
      - (* trapout *)
        layer_sim_simpl; compatsim_simpl (@match_AbData); intros.
        inv H4. inv match_extcall_states.
        exploit trapout_exist; eauto 1; intros [labd' [HP [HM[HAT HN]]]].
        inv match_match. match_external_states_simpl. congruence.
      - apply hostin_sim.
      - (* hostout *)
        layer_sim_simpl; compatsim_simpl (@match_AbData); intros.
        inv H4. inv match_extcall_states.
        exploit hostout_exist; eauto 1; intros [labd' [HP [HM[HAT HN]]]].
        inv match_match. match_external_states_simpl. congruence.
      - apply trap_info_get_sim.
      - apply trap_info_ret_sim.
      - layer_sim_simpl.
        + eapply load_correct1.
        + eapply store_correct1.
    Qed.

  End WITHMEM.

End Refinement.


Require Import Setoid.
From hahn Require Import Hahn.
From imm Require Import AuxDef Events Execution Execution_eco
     imm_bob imm_s_ppo imm_s imm_s_hb CombRelations AuxRel2.
From imm Require Import TraversalConfig Traversal.
Require Import AuxRel.
Require Export ExtTravRelations.
From imm Require Import TraversalProperties.

Set Implicit Arguments.

Section ExtTraversalConfig.
Variable G : execution.
Variable sc : relation actid.

Notation "'acts'" := G.(acts).
Notation "'sb'" := G.(sb).
Notation "'rmw'" := G.(rmw).
Notation "'data'" := G.(data).
Notation "'addr'" := G.(addr).
Notation "'ctrl'" := G.(ctrl).
Notation "'rmw_dep'" := G.(rmw_dep).
Notation "'rf'" := G.(rf).
Notation "'co'" := G.(co).
Notation "'coe'" := G.(coe).
Notation "'fr'" := G.(fr).

Notation "'eco'" := G.(eco).

Notation "'bob'" := G.(bob).
Notation "'fwbob'" := G.(fwbob).
Notation "'ppo'" := G.(ppo).
Notation "'rppo'" := G.(rppo).
Notation "'fre'" := G.(fre).
Notation "'rfi'" := G.(rfi).
Notation "'rfe'" := G.(rfe).
Notation "'deps'" := G.(deps).
Notation "'detour'" := G.(detour).
Notation "'release'" := G.(release).
Notation "'sw'" := G.(sw).
Notation "'hb'" := G.(hb).

Notation "'urr'" := (urr G sc).
Notation "'c_acq'" := (c_acq G sc).
Notation "'c_cur'" := (c_cur G sc).
Notation "'c_rel'" := (c_rel G sc).
Notation "'t_acq'" := (t_acq G sc).
Notation "'t_cur'" := (t_cur G sc).
Notation "'t_rel'" := (t_rel G sc).
Notation "'S_tm'" := G.(S_tm).
Notation "'S_tmr'" := G.(S_tmr).
Notation "'msg_rel'" := (msg_rel G sc).

Notation "'lab'" := G.(lab).
Notation "'loc'" := (loc lab).
Notation "'val'" := (val lab).
Notation "'mod'" := (Events.mod lab).
Notation "'same_loc'" := (same_loc lab).

Notation "'E'" := G.(acts_set).
Notation "'R'" := (fun x => is_true (is_r lab x)).
Notation "'W'" := (fun x => is_true (is_w lab x)).
Notation "'F'" := (fun x => is_true (is_f lab x)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).
Notation "'R_ex'" := (fun a => is_true (R_ex lab a)).
Notation "'W_ex'" := (W_ex G).
Notation "'W_ex_acq'" := (W_ex ∩₁ (fun a => is_true (is_xacq lab a))).

Notation "'Init'" := (fun a => is_true (is_init a)).
Notation "'Loc_' l" := (fun x => loc x = Some l) (at level 1).
Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'W_' l" := (W ∩₁ Loc_ l) (at level 1).

Notation "'Pln'" := (fun x => is_true (is_only_pln lab x)).
Notation "'Rlx'" := (fun x => is_true (is_rlx lab x)).
Notation "'Rel'" := (fun x => is_true (is_rel lab x)).
Notation "'Acq'" := (fun x => is_true (is_acq lab x)).
Notation "'Acqrel'" := (fun x => is_true (is_acqrel lab x)).
Notation "'Sc'" := (fun x => is_true (is_sc lab x)).
Notation "'Acq/Rel'" := (fun a => is_true (is_ra lab a)).

(******************************************************************************)
(** **   *)
(******************************************************************************)

Record ext_trav_config :=
  mkETC { etc_TC : trav_config; reserved : actid -> Prop; }.

Definition eissued  T := issued  (etc_TC T).
Definition ecovered T := covered (etc_TC T).

Definition dom_sb_S_rfrmw T rrf P :=
  dom_rel (sb ⨾ ⦗reserved T⦘) ∩₁ codom_rel (⦗P⦘ ⨾ rrf ⨾ rmw).

Record etc_coherent (T : ext_trav_config) :=
  mkETCC {
  etc_tccoh          : tc_coherent G sc (etc_TC T);
  etc_S_in_E         : reserved T ⊆₁ E;
  etc_I_in_S         : eissued T ⊆₁ reserved T;
  etc_S_I_in_W_ex    : reserved T \₁ eissued T ⊆₁ W_ex;
  etc_F_sb_S         : dom_rel (⦗F∩₁Acq/Rel⦘ ⨾ sb ⨾ ⦗reserved T⦘) ⊆₁ ecovered T ;
  etc_dr_R_acq_I     : dom_rel ((detour ∪ rfe) ⨾ (rmw ⨾ rfi)＊ ⨾ ⦗R∩₁Acq⦘ ⨾ sb ⨾ ⦗reserved T⦘) ⊆₁ eissued T ;
  etc_W_ex_sb_I      : dom_rel (⦗W_ex_acq⦘ ⨾ sb ⨾ ⦗reserved T⦘) ⊆₁ eissued T ;
  etc_sb_S           : dom_sb_S_rfrmw T (rf ⨾ ⦗R_ex⦘) (eissued T) ⊆₁ reserved T;
  (* TODO: uncomment the next property for handling FADDs. *)
  (* etc_sb_Acq_S       : dom_rel ((rmw ⨾ rfi)＊ ⨾ ⦗R∩₁Acq⦘ ⨾ sb ⨾ ⦗reserved T⦘) ∩₁ codom_rel (⦗eissued T⦘ ⨾ rf ⨾ rmw); *)
  etc_rppo_S         : dom_rel ((detour ∪ rfe) ⨾ (data ∪ rfi ∪ rmw)＊ ⨾ rppo ⨾ ⦗ reserved T ⦘) ⊆₁ eissued T;
  etc_d_rmw_S        : dom_rel (detour ⨾ rmw ⨾ ⦗ reserved T ⦘) ⊆₁ eissued T;
  etc_S_W_ex_rfrmw_I : reserved T ∩₁ W_ex ⊆₁ codom_rel (⦗eissued T⦘ ⨾ rf ⨾ rmw);
 }.

Section Props.

Variable WF : Wf G.
Variable T : ext_trav_config.
Variable ETCCOH : etc_coherent T.

Lemma etc_rmw_S : dom_rel ((detour ∪ rfe) ⨾ rmw ⨾ ⦗ reserved T ⦘) ⊆₁ eissued T.
Proof using WF ETCCOH.
  rewrite !seq_union_l, dom_union. unionL; [by apply ETCCOH|].
  rewrite rmw_W_ex, !seqA. rewrite <- id_inter. rewrite set_interC.
  rewrite etc_S_W_ex_rfrmw_I; auto. rewrite rfe_in_rf.
  remember (rf ⨾ rmw) as X.
  arewrite (rf ⨾ rmw ⊆ X) by subst.
  unfolder. ins. desf.
  assert (x = z); subst; auto.
  eapply wf_rfrmwf; eauto.
Qed.

Lemma eissuedW : eissued T ⊆₁ W.
Proof using ETCCOH. unfold eissued. eapply issuedW. apply ETCCOH. Qed.

Lemma reservedW : reserved T ⊆₁ W.
Proof using WF ETCCOH.
  arewrite (reserved T ⊆₁ reserved T \₁ eissued T ∪₁ reserved T ∩₁ eissued T).
  2: { rewrite eissuedW at 2; auto. rewrite etc_S_I_in_W_ex; auto.
       rewrite W_ex_in_W; auto. basic_solver. }
  unfolder. ins.
  destruct (classic (eissued T x)); eauto.
Qed.

End Props.
End ExtTraversalConfig.


Require Import VST.floyd.base2.
Require Import VST.floyd.client_lemmas.
Require Import VST.floyd.nested_field_lemmas.
Require Import VST.floyd.efield_lemmas.
Require Import VST.floyd.mapsto_memory_block.
Require Import VST.floyd.reptype_lemmas.
Require Import VST.floyd.data_at_rec_lemmas.
Require Import VST.floyd.field_at.
Require Import VST.floyd.stronger.
Require Import VST.floyd.entailer.
Require Import VST.floyd.closed_lemmas.
Require Import VST.floyd.proj_reptype_lemmas.
Require Import VST.floyd.replace_refill_reptype_lemmas.
Require Import VST.floyd.loadstore_field_at.
Require Import VST.floyd.nested_loadstore.

Local Open Scope logic.

Definition array_with_hole {cs: compspecs} sh (t: type) lo hi n (al': list (reptype t)) p :=
!! field_compatible (tarray t n) nil p &&
(ALL cl: list (reptype t),
(data_at sh (tarray t (hi-lo)) cl (field_address0 (tarray t n) (ArraySubsc lo :: nil) p)
-* data_at sh (tarray t n) (sublist 0 lo al' ++ cl ++ sublist hi n al') p)).

Lemma array_with_hole_local_facts {cs: compspecs}: forall sh t lo hi n (al': list (reptype t)) p,
array_with_hole sh t lo hi n al' p |--
!! (field_compatible (tarray t n) nil p).
Proof.
intros.
unfold array_with_hole. entailer!.
Qed.
#[export] Hint Resolve array_with_hole_local_facts : saturate_local.

Lemma wand_slice_array:
forall {cs: compspecs} lo hi n sh t (al: list (reptype t)) p,
0 <= lo <= hi ->
hi <= n ->
Zlength al = n ->
data_at sh (tarray t n) al p =
!! (field_compatible (tarray t n) nil p) &&
data_at sh (tarray t (hi-lo)) (sublist lo hi al) (field_address0 (tarray t n) (ArraySubsc lo :: nil) p) *
array_with_hole sh t lo hi n al p.
Proof.
  intros until p.
  intros H H0 H1.
  unfold data_at, array_with_hole.
  assert (forall n, reptype (tarray t n) = list (reptype t)).
  {
    intros.
    rewrite reptype_eq.
    auto.
  }
  apply pred_ext.
  + rewrite (add_andp _ _ (field_at_local_facts _ _ _ _ _)).
    normalize.
    rename H3 into H7, H4 into H8.
    erewrite field_at_Tarray.
      2: constructor.
      2: reflexivity.
      2: lia.
      2: apply JMeq_refl.
    erewrite (split3seg_array_at' _ _ _ 0 lo hi n); try lia.
      2:etransitivity; [exact H1 | lia].
    unfold data_at.
    rewrite (sepcon_comm (array_at _ _ _ _ _ _ _)), sepcon_assoc.
    apply sepcon_derives.
    - apply derives_refl'.
      f_equal.
      rewrite !Z.sub_0_r.
      auto.
    - apply allp_right; intros v. change (list (reptype t)) in v.
      * apply -> wand_sepcon_adjoint.
        rewrite (add_andp _ _ (field_at_local_facts _ _ _ _ _)).
        normalize.
        rewrite value_fits_eq in H4; simpl in H4.
        destruct H4.
        rewrite Z.max_r in H4 by lia.
        change (@Zlength (reptype t) v = hi - lo) in H4.
        erewrite (field_at_Tarray _ (tarray t n)).
          2: constructor.
          2: reflexivity.
          2: lia.
          2: apply JMeq_refl.
        erewrite (split3seg_array_at' _ _ _ 0 lo hi n); try lia.
        2:{
          change (Zlength (sublist 0 lo al ++ v ++ sublist hi n al) = n - 0).
          autorewrite with sublist.
          lia.
        }
        autorewrite with norm.
        change (array_at sh (tarray t n) nil 0 lo (sublist 0 lo al) p *
                array_at sh (tarray t n) nil hi n (sublist hi n al) p *
                field_at sh (tarray t (hi - lo)) nil v (field_address0 (tarray t n) (SUB lo) p)
                |-- array_at sh (tarray t n) nil 0 lo
                      (sublist 0 lo (sublist 0 lo al ++ v ++ sublist hi n al)) p *
                    data_at sh (nested_field_array_type (tarray t n) nil lo hi)
                      (sublist lo hi (sublist 0 lo al ++ v ++ sublist hi n al))
                      (field_address0 (tarray t n) (SUB lo) p) *
                    array_at sh (tarray t n) nil hi n
                      (sublist hi n (sublist 0 lo al ++ v ++ sublist hi n al)) p).
        unfold tarray; autorewrite with sublist.
        rewrite H4.
        replace (hi - lo - (hi - lo) + hi) with hi by lia.
        replace (n - lo - (hi - lo) + hi) with n by lia.
        rewrite !sepcon_assoc.
        apply sepcon_derives; [apply derives_refl |].
        rewrite sepcon_comm.
        apply sepcon_derives; [| apply derives_refl].
        autorewrite with sublist.
        apply derives_refl.
  + normalize.
    clear H2.
    rewrite sepcon_comm.
    apply wand_sepcon_adjoint.
    apply (allp_left _ (sublist lo hi al)); intros.
    apply wand_derives; [apply derives_refl |].
    unfold data_at.
    apply derives_refl'.
    f_equal.
    autorewrite with sublist.
    auto.
Qed.

Module SingletonHole.

Definition array_with_hole {cs: compspecs} sh (t: type) i n (al': list (reptype t)) p :=
ALL v:reptype t,
 (data_at sh t v (field_address (tarray t n) (ArraySubsc i :: nil) p) -* data_at sh (tarray t n) (upd_Znth i al' v) p).

Lemma array_with_hole_intro {cs: compspecs} sh: forall t i n (al: list (reptype t)) p,
  0 <= i < n ->
  data_at sh (tarray t n) al p |--
    data_at sh t (Znth i al) (field_address (tarray t n) (ArraySubsc i :: nil) p) *
      array_with_hole sh t i n al p.
Proof.
  intros.
  unfold data_at, array_with_hole.
  assert (forall n, reptype (tarray t n) = list (reptype t)).
  {
    intros.
    rewrite reptype_eq.
    auto.
  }
  saturate_local.
  assert (Zlength al = n).
  {
    destruct H2 as [? _].
    rewrite Z.max_r in H2 by lia.
    rewrite <- H2.
    reflexivity.
  }
  clear H2.
  erewrite field_at_Tarray.
      2: constructor.
      2: reflexivity.
      2: lia.
      2: apply JMeq_refl.
  erewrite (split3seg_array_at _ _ _ 0 i (i+1) n); try lia.
      2: change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  autorewrite with sublist.
  rewrite sublist_len_1.
      2: change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  erewrite array_at_len_1.
      2: apply JMeq_refl.
  rewrite field_at_data_at.
  change ((nested_field_type (tarray t n) (ArraySubsc i :: nil))) with t.
  cancel.
  apply allp_right; intros v.
  apply -> wand_sepcon_adjoint.

  unfold data_at at 2.
  erewrite field_at_Tarray.
      2: constructor.
      2: reflexivity.
      2: lia.
      2: apply JMeq_refl.
  erewrite (split3seg_array_at _ _ _ 0 i (i+1) n); try lia.
      2: autorewrite with sublist; change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  autorewrite with sublist.
  rewrite sublist_len_1.
      2: autorewrite with sublist; change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  erewrite array_at_len_1.
      2: apply JMeq_refl.
  rewrite field_at_data_at.
  change ((nested_field_type (tarray t n) (ArraySubsc i :: nil))) with t.
  rewrite upd_Znth_same.
      2: change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  rewrite sublist_upd_Znth_l; try lia.
      2: change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  rewrite sublist_upd_Znth_r; try lia.
      2: change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  cancel.
Qed.

Lemma array_with_hole_elim {cs: compspecs} sh: forall t i n (a: reptype t) (al: list (reptype t)) p,
  data_at sh t a (field_address (tarray t n) (ArraySubsc i :: nil) p) *
    array_with_hole sh t i n al p |--
      data_at sh (tarray t n) (upd_Znth i al a) p.
Proof.
  intros.
  rewrite sepcon_comm.
  apply wand_sepcon_adjoint.
  apply (allp_left _ a).
  auto.
Qed.

End SingletonHole.

Definition splice_into_list {A} (lo hi: Z) (source target : list A) : list A :=
   sublist 0 lo target
   ++ source
   ++ sublist hi (Zlength target) target.

Module SegmentHole.

Definition array_with_hole {cs: compspecs} sh (t: type) lo hi n (al': list (reptype t)) p :=
ALL v: list (reptype t),
 (data_at sh (tarray t (hi - lo)) v (field_address0 (tarray t n) (ArraySubsc lo :: nil) p) -* data_at sh (tarray t n) (splice_into_list lo hi v al') p).

Lemma array_with_hole_intro {cs: compspecs} sh: forall t lo hi n (al: list (reptype t)) p,
  0 <= lo <= hi ->
  hi <= n ->
  data_at sh (tarray t n) al p |--
    data_at sh (tarray t (hi - lo)) (sublist lo hi al) (field_address0 (tarray t n) (ArraySubsc lo :: nil) p) *
      array_with_hole sh t lo hi n al p.
Proof.
  intros.
  unfold data_at at 1, array_with_hole.
  assert (forall n, reptype (tarray t n) = list (reptype t)).
  {
    intros.
    rewrite reptype_eq.
    auto.
  }
  saturate_local.
  assert (Zlength al = n).
  {
    destruct H3 as [? _].
    rewrite Z.max_r in H3 by lia.
    rewrite <- H3.
    reflexivity.
  }
  clear H3.
  erewrite field_at_Tarray.
      2: constructor.
      2: reflexivity.
      2: lia.
      2: apply JMeq_refl.
  erewrite (split3seg_array_at _ _ _ 0 lo hi n); try lia.
      2: change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  autorewrite with sublist.
  change (tarray t (hi - lo)) with (nested_field_array_type (tarray t n) nil lo hi).
  erewrite <- array_at_data_at''' by first [reflexivity | lia].
  cancel.
  apply allp_right; intros v.
  apply -> wand_sepcon_adjoint.

  unfold data_at at 2.
  assert_PROP (Zlength v = hi - lo).
  {
    saturate_local.
    destruct H13.
    clear - H H13.
    apply prop_right.
    rewrite Z.max_r in H13 by lia.
    exact H13.
  }
  erewrite field_at_Tarray.
      2: constructor.
      2: reflexivity.
      2: lia.
      2: apply JMeq_refl.
  erewrite (split3seg_array_at _ _ _ 0 lo hi n); try lia.
      2: unfold splice_into_list; autorewrite with sublist; change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  erewrite <- array_at_data_at''' by first [reflexivity | lia].
  cancel.
  unfold splice_into_list.
  autorewrite with sublist.
  replace (hi - lo - Zlength v + hi) with hi by lia.
  replace (n - lo - Zlength v + hi) with n by lia.
  cancel.
  autorewrite with sublist.
  cancel.
Qed.

Lemma array_with_hole_elim {cs: compspecs} sh: forall t lo hi n (a: list (reptype t)) (al: list (reptype t)) p,
  data_at sh (tarray t (hi - lo)) a (field_address0 (tarray t n) (ArraySubsc lo :: nil) p) *
    array_with_hole sh t lo hi n al p |--
      data_at sh (tarray t n) (splice_into_list lo hi a al) p.
Proof.
  intros.
  rewrite sepcon_comm.
  apply wand_sepcon_adjoint.
  apply (allp_left _ a).
  auto.
Qed.

End SegmentHole.


Require Import String.
Require Import Coq.ZArith.ZArith.
Require Import coqutil.Z.Lia.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import riscv.Utility.Encode.
Require Import riscv.Utility.Utility.
Require Import coqutil.Word.LittleEndian.
Require Import coqutil.Word.Properties.
Require Import coqutil.Map.Interface.
Require Import coqutil.Tactics.Tactics.
Require Import riscv.Spec.Primitives.
Require Import riscv.Spec.Machine.
Require riscv.Platform.Memory.
Require Import riscv.Spec.PseudoInstructions.
Require Import riscv.Proofs.EncodeBound.
Require Import riscv.Proofs.DecodeEncode.
Require Import riscv.Platform.Run.
Require Import riscv.Utility.MkMachineWidth.
Require Import riscv.Utility.Monads. Import MonadNotations.
Require Import riscv.Utility.runsToNonDet.
Require Import coqutil.Datatypes.PropSet.
Require Import riscv.Platform.RiscvMachine.
Require Import riscv.Platform.MetricRiscvMachine.
Require Import riscv.Spec.MetricPrimitives.
Require Import compiler.RunInstruction.
Require Import compiler.RiscvEventLoop.
Require Import compiler.ForeverSafe.
Require Import compiler.GoFlatToRiscv.
Require Import coqutil.Tactics.Simp.
Require Import processor.KamiWord.
Require Import processor.KamiRiscvStep.
Require Import processor.KamiRiscv.
Require Import bedrock2.Syntax bedrock2.Semantics.
Require Import compiler.Pipeline.
Require Import compilerExamples.MMIO.
Require Import riscv.Platform.FE310ExtSpec.
Require Import compiler.FlatToRiscvDef.
Require Import coqutil.Tactics.rdelta.
Require Import end2end.KamiRiscvWordProperties.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import compiler.SeparationLogic.
Require Import compiler.ToplevelLoop.
Require Import compiler.CompilerInvariant.
Require Import compiler.ExprImpEventLoopSpec.

Local Open Scope Z_scope.

Require Import Coq.Classes.Morphisms.

#[global] Instance word_riscv_ok: @RiscvWordProperties.word.riscv_ok 32 KamiWord.wordW.
refine (@KamiRiscvWordProperties.kami_word_riscv_ok 5 _ _).
all: cbv; congruence.
Qed.

#[global] Existing Instance SortedListString.map.
#[global] Existing Instance SortedListString.ok.

(* TODO these definitions should be in KamiRiscv.v: *)

Definition get_kamiMemInit{memSizeLg: Z}
  (memInit: Syntax.Vec (Syntax.ConstT (Syntax.Bit MemTypes.BitsPerByte)) (Z.to_nat memSizeLg))
  (n: nat): Byte.byte :=
  byte.of_Z (Kami.Lib.Word.uwordToZ
               (Kami.Semantics.evalConstT (kamiMemInit _ memInit) (Kami.Lib.Word.natToWord _ n))).

Definition kami_mem_contains_bytes(bs: list Coq.Init.Byte.byte){memSizeLg}(from: KamiWord.word 32)
           (mem: Syntax.Vec (Syntax.ConstT (Syntax.Bit MemTypes.BitsPerByte)) (Z.to_nat memSizeLg)): Prop :=
  List.map (get_kamiMemInit mem) (seq 0 (List.length bs)) = bs.

Section Connect.

  Context (instrMemSizeLg memSizeLg stack_size_in_bytes: Z).

  Context {Registers: map.map Register (KamiWord.word 32)}
          {Registers_ok: map.ok Registers}
          {mem: map.map (KamiWord.word 32) byte}
          {mem_ok: map.ok mem}.

  Let instrMemSizeBytes: Z := 2 ^ (2 + instrMemSizeLg).

  Definition ml: MemoryLayout (width := 32) := {|
    code_start := word.of_Z 0;
    code_pastend := word.of_Z instrMemSizeBytes;
    heap_start := word.of_Z instrMemSizeBytes;
    heap_pastend := word.of_Z (2 ^ memSizeLg - stack_size_in_bytes);
    stack_start := word.of_Z (2 ^ memSizeLg - stack_size_in_bytes);
    stack_pastend := word.of_Z (2 ^ memSizeLg);
  |}.

  Context (memInit: Syntax.Vec (Syntax.ConstT (Syntax.Bit MemTypes.BitsPerByte))
                               (Z.to_nat memSizeLg)).

  Hypotheses (instrMemSizeLg_bounds: 3 <= instrMemSizeLg <= 30)
             (Hkmem: 2 + instrMemSizeLg < memSizeLg <= 16).

  Lemma memSizeLg_width_trivial: memSizeLg <= 32. Proof. blia. Qed.

  Definition p4mm: Kami.Syntax.Modules :=
    KamiRiscv.p4mm instrMemSizeLg memSizeLg (proj1 instrMemSizeLg_bounds)
                   (proj2 instrMemSizeLg_bounds)
                   memInit.

  Add Ring wring : (word.ring_theory (word := Consistency.word))
      (preprocess [autorewrite with rew_word_morphism],
       morphism (word.ring_morph (word := Consistency.word)),
       constants [word_cst]).

  Goal True.
  epose (_ : PrimitivesParams (FreeMonad.free MetricMinimalMMIO.action MetricMinimalMMIO.result)
                              MetricRiscvMachine).
  Abort.

  Existing Instance MetricMinimalMMIO.MetricMinimalMMIOSatisfiesPrimitives.

  Definition states_related :=
    states_related instrMemSizeLg memSizeLg (proj1 instrMemSizeLg_bounds) (proj2 instrMemSizeLg_bounds).

  Lemma split_ll_trace: forall {t2' t1' t},
      traces_related t (t2' ++ t1') ->
      exists t1 t2, t = t2 ++ t1 /\ traces_related t1 t1' /\ traces_related t2 t2'.
  Proof.
    induction t2'; intros.
    - exists t, nil. simpl in *. repeat constructor. assumption.
    - simpl in H. simp. specialize IHt2' with (1 := H4).
      destruct IHt2' as (t1 & t2 & E & R1 & R2). subst.
      exists t1. exists (e :: t2). simpl. repeat constructor; assumption.
  Qed.

  Lemma states_related_to_traces_related: forall m m' t,
      states_related (m, t) m' -> traces_related t m'.(getLog).
  Proof. intros. inversion H. simpl. assumption. Qed.

  (* for debugging f_equal *)
  Lemma cong_app: forall {A B: Type} (f f': A -> B) (a a': A),
      f = f' ->
      a = a' ->
      f a = f' a'.
  Proof. intros. congruence. Qed.

  Context (spec: ProgramSpec)
          (funimplsList: list (string * (list string * list string * cmd))).

  Hypothesis heap_start_agree: spec.(datamem_start) = ml.(heap_start).
  Hypothesis heap_pastend_agree: spec.(datamem_pastend) = ml.(heap_pastend).
  Hypothesis stack_size_div: stack_size_in_bytes mod bytes_per_word = 0.
  Hypothesis stack_size_bounds: 0 <= stack_size_in_bytes <= 2 ^ memSizeLg - instrMemSizeBytes.

  Lemma mlOk: MemoryLayoutOk ml.
  Proof.
    constructor;
      unfold ml, code_start, code_pastend, heap_start, heap_pastend, stack_start, stack_pastend.
    - reflexivity.
    - rewrite word.unsigned_of_Z.
      unfold word.wrap.
      etransitivity.
      1: exact (ToplevelLoop.mod_2width_mod_bytes_per_word (2 ^ memSizeLg - stack_size_in_bytes)).
      change bytes_per_word with 4.
      apply mod4_0.mod4_0_sub.
      + replace memSizeLg with (memSizeLg - 2 + 2) by blia.
        rewrite Z.pow_add_r by blia.
        apply mod4_0.mod4_mul4_r.
      + exact stack_size_div.
    - rewrite word.unsigned_of_Z.
      unfold word.wrap.
      etransitivity.
      1: exact (ToplevelLoop.mod_2width_mod_bytes_per_word (2 ^ memSizeLg)).
      replace memSizeLg with (memSizeLg - 2 + 2) by blia.
      rewrite Z.pow_add_r by blia.
      apply mod4_0.mod4_mul4_r.
    - rewrite word.unsigned_of_Z. change (word.wrap 0) with 0.
      eapply proj1. eapply word.unsigned_range.
    - reflexivity.
    - rewrite ?word.unsigned_of_Z. unfold word.wrap.
      pose proof (Z.pow_nonneg 2 (2 + instrMemSizeLg)).
      change width with 32 in *.
      assert (2 ^ memSizeLg < 2 ^ 32). {
        apply Z.pow_lt_mono_r; blia.
      }
      rewrite ?Z.mod_small; try split; try apply Z.pow_nonneg; try blia.
    - reflexivity.
    - rewrite ?word.unsigned_of_Z. unfold word.wrap.
      pose proof (Z.pow_nonneg 2 (2 + instrMemSizeLg)).
      change width with 32 in *.
      assert (2 ^ memSizeLg < 2 ^ 32). {
        apply Z.pow_lt_mono_r; blia.
      }
      rewrite ?Z.mod_small; try split; try apply Z.pow_nonneg; try blia.
  Qed.

  Hypothesis funimplsList_NoDup: NoDup (List.map fst funimplsList).

  (* goodTrace in terms of "exchange format" (list Event).
     Only holds at the beginning/end of each loop iteration,
     will be transformed into "exists suffix, ..." form later *)
  Definition goodTraceE(t: list Event): Prop :=
    exists bedrockTrace, traces_related t bedrockTrace /\ spec.(goodTrace) bedrockTrace.

  Definition bedrock2Inv := (fun t m l => forall mc, hl_inv spec t m l mc).

  Let funspecs := WeakestPrecondition.call funimplsList.

  Hypothesis goodTrace_implies_related_to_Events: forall (t: list LogItem),
      spec.(goodTrace) t -> exists t': list Event, traces_related t' t.

  Definition riscvMemInit_all_values: list byte :=
    List.map (get_kamiMemInit memInit) (seq 0 (Z.to_nat (2 ^ memSizeLg))).

  Definition riscvMemInit_values(from len: nat): list byte :=
    List.firstn len (List.skipn from riscvMemInit_all_values).

  Lemma riscvMemInit_to_seplog_aux: forall len from,
      Z.of_nat from + Z.of_nat len <= 2 ^ memSizeLg ->
      LowerPipeline.ptsto_bytes
        (word.of_Z (width := width) (Z.of_nat from))
        (map (get_kamiMemInit memInit) (seq from len))
        (map.of_list (map
          (fun i => (word.of_Z (BinIntDef.Z.of_nat i),
                     byte.of_Z (Word.uwordToZ (Semantics.evalConstT (kamiMemInit memSizeLg memInit)
                         (Word.natToWord (BinIntDef.Z.to_nat memSizeLg) i)))))
          (seq from len))).
  Proof.
    induction len; intros.
    - cbv. auto.
    - unfold LowerPipeline.ptsto_bytes, riscvMemInit_values in *.
      cbn [seq map array map.of_list].
      match goal with
      | |- context [map.put ?m ?k ?v] => pose proof map.put_putmany_commute k v m map.empty as P
      end.
      rewrite map.putmany_empty_r in P.
      rewrite P. clear P.
      eapply sep_comm.
      unfold sep.
      do 2 eexists.
      ssplit; cycle 1.
      + specialize (IHlen (S from)).
        replace (Z.of_nat (S from)) with (Z.of_nat from + 1) in IHlen by blia.
        rewrite word.ring_morph_add in IHlen.
        apply IHlen. blia.
      + unfold ptsto. reflexivity.
      + unfold map.split, map.disjoint. split; [reflexivity|].
        intros.
        rewrite map.get_put_dec in H1.
        destruct_one_match_hyp. 2: {
          rewrite map.get_empty in H1. discriminate.
        }
        subst.
        rewrite get_of_list_not_In in H0.
        * discriminate.
        * simpl. apply Word.weq.
        * exact mem_ok.
        * intro C.
          rewrite map_map in C.
          unfold fst in C.
          apply in_map_iff in C.
          destruct C as [ from' [E C] ].
          apply (f_equal word.unsigned) in E.
          do 2 rewrite word.unsigned_of_Z in E.
          unfold word.wrap in E.
          change width with 32 in *.
          rewrite (Z.mod_small (Z.of_nat from)) in E. 2: {
            split; [blia|].
            eapply Z.le_lt_trans with (m := 2 ^ memSizeLg). 1: blia.
            eapply Z.pow_lt_mono_r; blia.
          }
          apply in_seq in C.
          rewrite (Z.mod_small (Z.of_nat from')) in E. 2: {
            split; [blia|].
            eapply Z.le_lt_trans with (m := 2 ^ memSizeLg). 1: blia.
            eapply Z.pow_lt_mono_r; blia.
          }
          blia.
  Qed.

  Lemma riscvMemInit_to_seplog:
    (LowerPipeline.ptsto_bytes (word.of_Z 0) riscvMemInit_all_values)
    (riscvMemInit memSizeLg memInit).
  Proof.
    intros.
    unfold riscvMemInit_all_values, riscvMemInit.
    pose proof (riscvMemInit_to_seplog_aux (Z.to_nat (2 ^ memSizeLg)) 0) as P.
    change (Z.of_nat 0) with 0 in *.
    (* TODO could adapt riscvMemInit definition to make this not needed *)
    replace (2 ^ BinIntDef.Z.to_nat memSizeLg)%nat with (Z.to_nat (2 ^ memSizeLg)).
    1: eapply P.
    - rewrite Z2Nat.id. 1: blia.
      apply Z.pow_nonneg. blia.
    - rewrite N_Z_nat_conversions.Z2Nat.inj_pow; try blia. reflexivity.
  Qed.

  (* end to end, but still generic over the program *)
  Lemma end2end:
    (* Assumptions on the program logic level: *)
    forall init_code loop_body,
    map.get (map.of_list funimplsList) "init"%string = Some ([], [], init_code) ->
    (forall m, LowerPipeline.mem_available ml.(heap_start) ml.(heap_pastend) m ->
               WeakestPrecondition.cmd funspecs init_code [] m map.empty bedrock2Inv) ->
    map.get (map.of_list funimplsList) "loop"%string = Some ([], [], loop_body) ->
    (forall t m l, bedrock2Inv t m l ->
                   WeakestPrecondition.cmd funspecs loop_body t m l bedrock2Inv) ->
    (* Assumptions on the compiler level: *)
    forall (instrs: list Instruction) positions (required_stack_space: Z),
    compile_prog compile_ext_call ml (map.of_list funimplsList) = Success (instrs, positions, required_stack_space) ->
    required_stack_space <= word.unsigned (word.sub (stack_pastend ml) (stack_start ml)) / bytes_per_word ->
    word.unsigned (code_start ml) + Z.of_nat (Datatypes.length (instrencode instrs)) <=
      word.unsigned (code_pastend ml) ->
    Forall (fun i : Instruction => verify i iset) instrs ->
    ExprImp.valid_funs (map.of_list funimplsList) ->
    (* Assumptions on the Kami level: *)
    kami_mem_contains_bytes (instrencode instrs) ml.(code_start) memInit ->
    forall (t: Kami.Semantics.LabelSeqT) (mFinal: KamiImplMachine),
      (* IF the 4-stage pipelined processor steps to some final state mFinal, producing trace t,*)
      Kami.Semantics.Behavior p4mm mFinal t ->
      (* THEN the trace produced by the kami implementation can be mapped to an MMIO trace
         (this guarantees that the only external behavior of the kami implementation is MMIO)
         and moreover, this MMIO trace satisfies "not yet bad", as in, there exists at
         least one way to complete it to a good trace *)
      exists (t': list Event), KamiLabelSeqR t t' /\
                               exists (suffix: list Event), goodTraceE (suffix ++ t').
  Proof.
    intros *. intros GetInit Establish GetLoop Preserve. intros *. intros C RS L F V M. intros *. intros B.

    set (traceProp := fun (t: list Event) =>
                        exists (suffix: list Event), goodTraceE (suffix ++ t)).
    change (exists t' : list Event,
               KamiLabelSeqR t t' /\ traceProp t').

    (* stack of proofs, bottom-up: *)

    (* 1) Kami pipelined processor to riscv-coq *)
    pose proof @riscv_to_kamiImplProcessor as P1.
    specialize_first P1 traceProp.
    specialize_first P1 (ll_inv compile_ext_call ml spec).
    specialize_first P1 B.
    specialize_first P1 (proj1 Hkmem).
    specialize_first P1 memSizeLg_width_trivial.
    specialize_first P1 (proj2 Hkmem).
    (* destruct spec. TODO why "Error: sat is already used." ?? *)

    (* 2) riscv-coq to bedrock2 semantics *)
    pose proof compiler_invariant_proofs compile_ext_call compile_ext_call_correct as P2.
    specialize_first P2 spec.
    specialize_first P2 ml.
    specialize_first P2 mlOk.
    destruct P2 as [ P2establish [P2preserve P2use] ]. {
      intros. reflexivity.
    }
    eapply P1; clear P1.
    - assumption.
    - assumption.
    - (* establish *)
      intros.
      eapply P2establish.
      unfold initial_conditions.
      exists (map.of_list funimplsList), instrs, positions, required_stack_space.
      destr_RiscvMachine m0RV.
      subst.
      ssplit.
      + (* 3) bedrock2 semantics to bedrock2 program logic *)
        econstructor.
        * exact V.
        * exact GetInit.
        * intros.
          eapply ExprImp.weaken_exec.
          -- match goal with
             | H: LowerPipeline.mem_available ?from ?to _ |- _ =>
               rewrite heap_start_agree in H;
               rewrite heap_pastend_agree in H
             end.
             refine (WeakestPreconditionProperties.sound_cmd _ _ _ _ _ _ _ _ _); eauto.
          -- simpl. clear. intros. unfold bedrock2Inv in *. eauto.
        * exact GetLoop.
        * intros. unfold bedrock2Inv in *.
          eapply ExprImp.weaken_exec.
          -- refine (WeakestPreconditionProperties.sound_cmd _ _ _ _ _ _ _ _ _); eauto.
          -- simpl. clear. intros. eauto.
      + assumption.
      + assumption.
      + assumption.
      + assumption.
      + assumption.
      + assumption.
      + pose proof word.eqb_spec.
        cbv [imem LowerPipeline.mem_available].
        unfold code_start, code_pastend, heap_start, heap_pastend, stack_start, stack_pastend, ml in *.
        assert (Bounds_instrs: 0 <= Z.of_nat (Datatypes.length (instrencode instrs))) by blia.
        assert (Bounds_unused_imem: Z.of_nat (Datatypes.length (instrencode instrs)) <= instrMemSizeBytes). {
          move L at bottom.
          rewrite ?word.unsigned_of_Z in L.
          change (word.wrap 0) with 0 in L.
          unfold word.wrap in L.
          rewrite (Z.mod_small instrMemSizeBytes) in L. 1: blia.
          split.
          - apply Z.pow_nonneg. blia.
          - change width with 32. apply Z.pow_lt_mono_r; blia.
        }
        assert (Bounds_heap: instrMemSizeBytes <= 2 ^ memSizeLg - stack_size_in_bytes) by blia.
        assert (Bounds_stack: 2 ^ memSizeLg - stack_size_in_bytes <= 2 ^ memSizeLg) by blia.
        assert (Bounds_unmapped: 2 ^ memSizeLg < 2 ^ width). {
          change width with 32.
          apply Z.pow_lt_mono_r; try blia.
        }
        assert (Datatypes.length riscvMemInit_all_values = Z.to_nat (2 ^ memSizeLg)). {
          unfold riscvMemInit_all_values.
          rewrite map_length. rewrite seq_length.
          blia.
        }
        clear P2establish P2preserve P2use.
        eapply Proper_iff1_iff1; [|reflexivity..|].
        { progress repeat rewrite ?sep_ex1_r, ?sep_ex1_l; reflexivity. }
        eexists ?[stack].
         eapply Proper_iff1_iff1; [|reflexivity..|].
        { progress repeat rewrite ?sep_ex1_r, ?sep_ex1_l; reflexivity. }
        eexists ?[heap].
        eapply Proper_iff1_iff1; [|reflexivity..|].
        { progress repeat rewrite ?sep_ex1_r, ?sep_ex1_l; reflexivity. }
        eexists ?[unused_imem].
        eapply Proper_iff1_iff1; [|reflexivity..|].
        { progress repeat rewrite ?sep_emp_2, ?sep_emp_l, ?sep_emp_r; reflexivity. }
        eapply sep_emp_l; split.
        2: eapply sep_assoc; eapply sep_emp_l; split.
        3: eapply Proper_iff1_iff1; [|reflexivity..|].
        3: { progress repeat rewrite ?sep_assoc, ?sep_emp_2, ?sep_emp_l, ?sep_emp_r; reflexivity. }
        3: eapply sep_emp_l; split.

        all : cycle 3.
        Unshelve. {
          pose proof riscvMemInit_to_seplog as P.
          unfold LowerPipeline.ptsto_bytes in *.
          remember riscvMemInit_all_values as l. symmetry in Heql. pose proof Heql as E.
          (* 1) chop off instructions *)
          rewrite <- (firstn_skipn (Datatypes.length (instrencode instrs)) l) in E. subst l.
          match type of E with
          | _ = _ ++ ?L => remember L as l
          end.
          (* 2) chop off unused instruction memory *)
          rewrite <- (firstn_skipn (Z.to_nat instrMemSizeBytes - Datatypes.length (instrencode instrs))
                                   l) in E. subst l.
          rewrite List.app_assoc in E.
          match type of E with
          | _ = _ ++ ?L => remember L as l
          end.
          (* 3 chop off heap *)
          rewrite <- (firstn_skipn (Z.to_nat (2 ^ memSizeLg - instrMemSizeBytes - stack_size_in_bytes))
                                   l) in E. subst l.
          rewrite List.app_assoc in E.
          rewrite E in P; clear E.
          use_sep_assumption.
          wseplog_pre.
          simpl_addrs.
          unfold code_start, code_pastend, heap_start, heap_pastend, stack_start, stack_pastend, ml.
          replace (firstn (Datatypes.length (instrencode instrs)) riscvMemInit_all_values)
            with (instrencode instrs). 2: {
            unfold riscvMemInit_all_values.
            rewrite List.firstn_map.
            rewrite List.firstn_seq.
            rewrite Nat.min_l by blia.
            symmetry.
            exact M.
          }
          cancel.
          cancel_seps_at_indices 0%nat 0%nat. {
            f_equal.
            ring.
          }
          cancel_seps_at_indices 0%nat 0%nat. {
            f_equal.
            rewrite firstn_length.
            rewrite skipn_length.
            let word_ok := constr:(_ : word.ok _) in simpl_word_exprs word_ok.
            f_equal.
            blia.
          }
          cancel_seps_at_indices 0%nat 0%nat. {
            f_equal.
            rewrite ?firstn_length.
            rewrite ?skipn_length.
            let word_ok := constr:(_ : word.ok _) in simpl_word_exprs word_ok.
            f_equal.
            blia.
          }
          cbn [seps]. reflexivity.
        }
        all: repeat rewrite ?word.unsigned_sub, ?word.unsigned_add,
                            ?firstn_length, ?skipn_length, ?word.unsigned_of_Z;
             unfold word.wrap;
             change width with 32 in *.
        all: try (
          Z.div_mod_to_equations;
          (* COQBUG (performance) https://github.com/coq/coq/issues/10743#issuecomment-530673037
             cond_hyp_factor: *)
          repeat match goal with
                 | H : ?x -> _, H' : ?x -> _ |- _  =>
                   pose proof (fun u : x => conj (H u) (H' u)); clear H H'
                 end;
          blia).
      + change (word.unsigned (code_start ml)) with 0.
        assert (Hend: code_pastend ml = word.of_Z instrMemSizeBytes) by reflexivity.
        setoid_rewrite Hend.
        rewrite word.unsigned_of_Z.
        cbv [word.wrap].
        rewrite Z.mod_small. 2: {
          split.
          - apply Z.pow_nonneg; blia.
          - apply Z.pow_lt_mono_r; blia.
        }
        assumption.
      + reflexivity.
      + reflexivity.
      + unfold regs_initialized.regs_initialized. intros.
        match goal with
        | |- exists _, ?x = Some _ => destr x; [eauto|exfalso]
        end.
        match goal with
        | H: forall _, _ -> _ <> None |- _ => eapply H; eauto
        end.
      + reflexivity.
      + simpl. split.
        * apply @riscv_init_memory_undef_on_MMIO with (instrMemSizeLg:= instrMemSizeLg).
          { apply instrMemSizeLg_bounds. }
          { apply Hkmem. }
          { cbv [KamiProc.width]; blia. }
          { apply Hkmem. }
          { assumption. }
        * assumption.
    - (* preserve *)
      intros.
      refine (P2preserve _ _). assumption.
    - (* use *)
      intros *. intro Inv.
      subst traceProp. simpl.
      specialize_first P2use Inv.
      destruct P2use as [suff Good].
      unfold goodTraceE.
      pose proof (goodTrace_implies_related_to_Events _ Good) as G.
      destruct G as [t' R].
      pose proof (split_ll_trace R). simp.
      eauto 10.
  Qed.

End Connect.


Require Import Verdi.GhostSimulations.

Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.
Require Import VerdiRaft.NoAppendEntriesToSelfInterface.
Require Import VerdiRaft.OneLeaderLogPerTermInterface.
Require Import VerdiRaft.AppendEntriesRequestsCameFromLeadersInterface.
Require Import VerdiRaft.LeadersHaveLeaderLogsInterface.

Require Import VerdiRaft.NoAppendEntriesToLeaderInterface.

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

  Context {rri : raft_refinement_interface}.
  Context {naetsi : no_append_entries_to_self_interface}.
  Context {ollpti : one_leaderLog_per_term_interface}.
  Context {aercfli : append_entries_came_from_leaders_interface}.
  Context {lhlli : leaders_have_leaderLogs_interface}.

  Definition no_append_entries_to_leader' (net : network) : Prop :=
    forall p t n pli plt es ci,
      In p (nwPackets net) ->
      pBody p = AppendEntries t n pli plt es ci ->
      type (snd (nwState net (pDst p))) = Leader ->
      currentTerm (snd (nwState net (pDst p))) = t ->
      False.

  Definition no_append_entries_to_self' (net : network) : Prop :=
    forall p t n pli plt es ci,
      In p (nwPackets net) ->
      pBody p = AppendEntries t n pli plt es ci ->
      pDst p = pSrc p ->
      False.

  Theorem lift_no_append_entries_to_self :
    forall net,
      refined_raft_intermediate_reachable net ->
      no_append_entries_to_self (deghost net).
  Proof using naetsi rri.
    intros.
    eapply lift_prop; eauto using no_append_entries_to_self_invariant.
  Qed.

  Lemma ghost_packet :
    forall (net : network (params := raft_refined_multi_params)) p,
      In p (nwPackets net) ->
      In (deghost_packet p) (nwPackets (deghost net)).
  Proof using.
    unfold deghost.
    simpl. intuition.
    apply in_map_iff.
    eexists; eauto.
  Qed.

  Theorem no_append_entries_to_self'_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      no_append_entries_to_self' net.
  Proof using naetsi rri.
    unfold no_append_entries_to_self'. intros.
    find_apply_lem_hyp ghost_packet.
    find_eapply_lem_hyp lift_no_append_entries_to_self; auto.
    simpl in *. eauto.
  Qed.

  Lemma no_append_entries_to_leader_invariant' :
    forall net,
      refined_raft_intermediate_reachable net ->
      no_append_entries_to_leader' net.
  Proof using lhlli aercfli ollpti naetsi rri.
    unfold no_append_entries_to_leader'. intros. subst.
    find_copy_eapply_lem_hyp no_append_entries_to_self'_invariant; eauto.
    find_false.
    find_eapply_lem_hyp leaders_have_leaderLogs_invariant; eauto.
    break_exists.
    find_eapply_lem_hyp append_entries_came_from_leaders_invariant; eauto.
    break_exists.
    eapply one_leaderLog_per_term_host_invariant; eauto.
  Qed.

  Lemma deghost_packet_exists :
    forall net p,
      In p (nwPackets (deghost net)) ->
      exists (q : packet (params := raft_refined_multi_params (raft_params := raft_params))),
        In q (nwPackets net) /\ p = deghost_packet q.
  Proof using.
    unfold deghost.
    simpl.
    intros.
    do_in_map.
    eauto.
  Qed.

  Instance noaetli : no_append_entries_to_leader_interface.
  split. intros.
  apply lower_prop; auto.
  intros.
  find_apply_lem_hyp no_append_entries_to_leader_invariant'.
  unfold no_append_entries_to_leader', no_append_entries_to_leader in *.
  intros.
  find_apply_lem_hyp deghost_packet_exists. break_exists. intuition. subst.
  simpl in *. repeat break_match; simpl in *. subst.
  match goal with
    | H : nwState ?h = (?gd, ?d) |- _ =>
      replace gd with (fst (nwState h)) in * by (rewrite H; reflexivity);
        replace d with (snd (nwState h)) in * by (rewrite H; reflexivity);
        clear H
  end. eauto.
  Qed.
End NoAppendEntriesToLeader.