From RecordUpdate Require Import RecordSet.
From Perennial.Helpers Require Import ipm Map.

From Goose.github_com.mit_pdos.perennial_examples Require Import async_mem_alloc_dir.
From Perennial.program_proof Require Import async_disk_lib.
From Perennial.program_proof Require Import async_disk_prelude.
From Perennial.goose_lang.lib Require Import slice.crash_slice.
From Perennial.program_proof.examples Require Import
     alloc_addrset alloc_crash_proof async_mem_alloc_inode_proof.
From Perennial.goose_lang.lib Require Import typed_slice. (* shadows things, should be last *)

Module dir.
  Record t :=
    mk { inodes: gmap nat (list Block); }.
  Global Instance _eta : Settable t := settable! mk <inodes>.
  Global Instance _witness : Inhabited t := populate!.
End dir.

(* FIXME: port to [auth_map]; then these instances likely also can disappear. *)
Canonical Structure listLO A := leibnizO (list A).
Canonical Structure gset64O := leibnizO (gset u64).

Local Definition blocksR := authR $ gmapUR nat (exclR $ listLO Block).
Local Definition allocsR := authR $ gmapUR nat (exclR $ gset64O).

Section goose.
  Context `{!heapGS Σ}.
  Context `{!allocG Σ}.
  Context `{!stagedG Σ}.
  Context `{!inG Σ blocksR}.
  Context `{!inG Σ allocsR}.

  (* The client picks our namespace *)
  Context (N: namespace).
  (* We use parts of it ourselves and assign the rest to sub-libraries. *)
  Let dirN := N.@"dir".
  Let allocN := N.@"allocator".
  Let inodeN := N.@"inode".

  Definition num_inodes: nat := 5.
  Hint Unfold num_inodes : word.

  Context (P: dir.t → iProp Σ).
  Implicit Types (dir σ: dir.t).

  (** Per-inode statements and lemmas about them. *)
  Local Definition inode_blocks γblocks (idx: nat) (blocks: list Block): iProp Σ :=
    own γblocks (◯ {[ idx := Excl blocks ]}: blocksR).
  Local Definition inode_allblocks γblocks (allblocks: gmap nat (list Block)): iProp Σ :=
    own γblocks (● (Excl <$> allblocks): blocksR).
  Local Definition inode_used γused (idx: nat) (used: gset u64): iProp Σ :=
    own γused (◯ {[ idx := Excl used ]}: allocsR).
  Local Definition inode_allused γused (allused: gmap nat (gset u64)): iProp Σ :=
    own γused (● (Excl <$> allused): allocsR).

  (* Twice the same proofs... really this should be abstracted, ideally into Iris. *)
  Lemma inode_blocks_lookup γblocks (idx: nat) (blocks: list Block) (allblocks: gmap nat (list Block)):
    inode_blocks γblocks idx blocks -∗
    inode_allblocks γblocks allblocks -∗
    ⌜allblocks !! idx = Some blocks⌝.
  Proof.
    iIntros "Hblocks Hallblocks".
    iDestruct (own_valid_2 with "Hallblocks Hblocks") as
        %[Hincl _]%auth_both_valid_discrete.
    iPureIntro.
    move: Hincl. rewrite singleton_included_l=> -[oblocks []].
    rewrite lookup_fmap fmap_Some_equiv=> -[blocks' [-> ->]].
    rewrite Excl_included leibniz_equiv_iff => -> //.
  Qed.

  Lemma inode_blocks_update {γblocks E} {idx: nat} (blocks1 blocks2: list Block) (allblocks: gmap nat (list Block)):
    inode_blocks γblocks idx blocks1 -∗
    inode_allblocks γblocks allblocks ={E}=∗
    inode_blocks γblocks idx blocks2 ∗ inode_allblocks γblocks (<[ idx := blocks2 ]> allblocks).
  Proof.
    iIntros "Hblocks Hallblocks".
    iDestruct (inode_blocks_lookup with "Hblocks Hallblocks") as %Hallblocks.
    iMod (own_update_2 with "Hallblocks Hblocks") as "[Hallblocks $]".
    { apply: auth_update. apply: singleton_local_update.
      { by rewrite lookup_fmap Hallblocks. }
      apply: exclusive_local_update. done. }
    rewrite -fmap_insert. done.
  Qed.

  Lemma inode_blocks_alloc E (allblocks: gmap nat (list Block)):
    ⊢ |={E}=> ∃ γblocks, ([∗ map] idx ↦ blocks ∈ allblocks, inode_blocks γblocks idx blocks) ∗ inode_allblocks γblocks allblocks.
  Proof.
    set allblocksR: gmapUR nat (exclR $ listLO Block) := Excl <$> allblocks.
    iMod (own_alloc (● allblocksR ⋅ ◯ allblocksR)) as (γ) "[Ha Hf]".
    { rewrite auth_both_valid_discrete. split; first done.
      intros i. rewrite /allblocksR lookup_fmap. by destruct (allblocks !! i). }
    iModIntro. iExists γ. iFrame "Ha".
    iInduction allblocks as [|i x m Hnew] "IH" using map_ind.
    { rewrite big_sepM_empty. done. }
    rewrite big_sepM_insert // /allblocksR fmap_insert.
    rewrite (insert_singleton_op (Excl <$> m) i (Excl x: exclR $ listLO Block)); last first.
    { rewrite lookup_fmap Hnew. done. }
    rewrite auth_frag_op. iDestruct "Hf" as "[$ Hf]".
    iApply "IH". done.
  Qed.

  Lemma inode_used_lookup γused (idx: nat) (used: gset u64) (allused: gmap nat (gset u64)):
    inode_used γused idx used -∗
    inode_allused γused allused -∗
    ⌜allused !! idx = Some used⌝.
  Proof.
    iIntros "Hused Hallused".
    iDestruct (own_valid_2 with "Hallused Hused") as
        %[Hincl _]%auth_both_valid_discrete.
    iPureIntro.
    move: Hincl. rewrite singleton_included_l=> -[oused []].
    rewrite lookup_fmap fmap_Some_equiv=> -[used' [-> ->]].
    rewrite Excl_included leibniz_equiv_iff => -> //.
  Qed.

  Lemma inode_used_update {γused E} {idx: nat} (used1 used2: gset u64) (allused: gmap nat (gset u64)):
    inode_used γused idx used1 -∗
    inode_allused γused allused ={E}=∗
    inode_used γused idx used2 ∗ inode_allused γused (<[ idx := used2 ]> allused).
  Proof.
    iIntros "Hused Hallused".
    iDestruct (inode_used_lookup with "Hused Hallused") as %Hallused.
    iMod (own_update_2 with "Hallused Hused") as "[Hallused $]".
    { apply: auth_update. apply: singleton_local_update.
      { by rewrite lookup_fmap Hallused. }
      apply: exclusive_local_update. done. }
    rewrite -fmap_insert. done.
  Qed.

  Lemma inode_used_alloc E (allused: gmap nat (gset u64)):
    ⊢ |={E}=> ∃ γused, ([∗ map] idx ↦ used ∈ allused, inode_used γused idx used) ∗ inode_allused γused allused.
  Proof.
    set allusedR: gmapUR nat (exclR $ gset64O) := Excl <$> allused.
    iMod (own_alloc (● allusedR ⋅ ◯ allusedR)) as (γ) "[Ha Hf]".
    { rewrite auth_both_valid_discrete. split; first done.
      intros i. rewrite /allusedR lookup_fmap. by destruct (allused !! i). }
    iModIntro. iExists γ. iFrame "Ha".
    iInduction allused as [|i x m Hnew] "IH" using map_ind.
    { rewrite big_sepM_empty. done. }
    rewrite big_sepM_insert // /allusedR fmap_insert.
    rewrite (insert_singleton_op (Excl <$> m) i (Excl x: exclR $ gset64O)); last first.
    { rewrite lookup_fmap Hnew. done. }
    rewrite auth_frag_op. iDestruct "Hf" as "[$ Hf]".
    iApply "IH". done.
  Qed.

  (** Protocol invariant for inode library *)
  Local Definition Pinode γblocks γused (ino: nat) (s: inode.t): iProp Σ :=
    "Hownblocks" ∷ inode_blocks γblocks ino s.(inode.blocks) ∗
    "Hused1" ∷ inode_used γused ino s.(inode.addrs).

  (** Protocol invariant for alloc library *)
  Local Definition Palloc γused (s: alloc.t): iProp Σ :=
    ∃ allocs: gmap nat (gset u64), (* per-inode used blocks *)
      "%Halloc_size" ∷ ⌜size allocs = num_inodes⌝ ∗
      "%Hused_global" ∷ ⌜alloc.used s = ⋃ (snd <$> map_to_list allocs)⌝ ∗
      "Hused2" ∷ inode_allused γused allocs.

  (** Our own invariant (added to this is [P dir]) *)
  Definition dir_inv γblocks (dir: dir.t): iProp Σ :=
    "%Hdom" ∷ ⌜ ∀ idx, idx < num_inodes → is_Some (dir.(dir.inodes) !! idx) ⌝ ∗
    "Hγblocks" ∷ inode_allblocks γblocks dir.(dir.inodes).

  (** In-memory state of the directory (persistent) *)
  Definition dir_state (l alloc_l: loc) (inode_refs: list loc) : iProp Σ :=
    ∃ d (inodes_s: Slice.t),
      "#d" ∷ readonly (l ↦[Dir :: "d"] (disk_val d)) ∗
      "#allocator" ∷ readonly (l ↦[Dir :: "allocator"] #alloc_l) ∗
      "#inodes" ∷ readonly (l ↦[Dir :: "inodes"] (slice_val inodes_s)) ∗
      "#inodes_s" ∷ readonly (is_slice_small inodes_s ptrT 1 (inode_refs))
  .

  (** State of unallocated blocks *)
  Local Definition allocΨ (a: u64): iProp Σ := ∃ bd b, int.Z a d↦[bd] b.

  Definition is_dir l (sz: Z) : iProp Σ :=
    ∃ (alloc_ref: loc) (inode_refs: list loc) γalloc γused γblocks,
      "%Hlen" ∷ ⌜length inode_refs = num_inodes⌝ ∗
      "Hro_state" ∷ dir_state l alloc_ref inode_refs ∗
      "#Hinodes" ∷ ([∗ list] i ↦ inode_ref ∈ inode_refs,
        is_inode inodeN inode_ref (Pinode γblocks γused i) (U64 (Z.of_nat i))) ∗
      "#Halloc" ∷ is_allocator (Palloc γused)
        allocΨ allocN alloc_ref (rangeSet num_inodes (sz-num_inodes)) γalloc ∗
      "#Hinv" ∷ ncinv dirN (∃ σ, dir_inv γblocks σ ∗ P σ)
  .

  Definition dir_cinv sz σ (post_crash: bool) : iProp Σ :=
    ∃ γblocks γused,
    "Hinodes" ∷ (∃ s_inodes,
                    "%Hinode_len" ∷ ⌜length s_inodes = num_inodes⌝ ∗
                    "Hinodes" ∷ ([∗ list] i↦s_inode ∈ s_inodes,
                   "Hinode_cinv" ∷ (if post_crash then inode_cinv_postcrash (U64 (Z.of_nat i)) s_inode
                                   else inode_cinv_precrash (U64 (Z.of_nat i)) s_inode) ∗
                    "HPinode" ∷ Pinode γblocks γused i s_inode)) ∗
    "Halloc" ∷ alloc_crash_cond_no_later (Palloc γused) allocΨ (rangeSet num_inodes (sz-num_inodes)) post_crash ∗
    "Hs_inode" ∷ dir_inv γblocks σ
  .

  Lemma dir_cinv_post_crash sz σ :
    dir_cinv sz σ true -∗ dir_cinv sz σ false.
  Proof.
    iNamed 1.
    iExists _, _; iFrame.
    iSplitR "Halloc"; last first.
    { iApply alloc_crash_cond_no_later_from_post_crash; auto. }
    iNamed "Hinodes". iExists _. iSplit; first eauto.
    iApply (big_sepL_mono with "Hinodes").
    iIntros (?? Hlook). iNamed 1.
    iFrame. rewrite /inode_cinv_postcrash. iDestruct "Hinode_cinv" as (?) "H".
    by iApply inode_durable_to_cinv.
  Qed.

  Definition pre_dir l (sz: Z) dir : iProp Σ :=
    ∃ alloc_ref inode_refs γblocks γused,
      "%Hlen" ∷ ⌜length inode_refs = num_inodes⌝ ∗
      "Hro_state" ∷ dir_state l alloc_ref inode_refs ∗
      "Hd_inv" ∷ dir_inv γblocks dir ∗
      "Hinodes" ∷ (∃ s_inodes,
                      [∗ list] i↦inode_ref;s_inode ∈ inode_refs;s_inodes,
                     pre_inode inode_ref (U64 (Z.of_nat i)) s_inode ∗
                  Pinode γblocks γused i s_inode) ∗
      "Halloc" ∷ (∃ s_alloc,
                     "Halloc_mem" ∷ is_allocator_mem_pre alloc_ref s_alloc ∗
                     "%Halloc_dom" ∷ ⌜alloc.domain s_alloc = rangeSet num_inodes (sz-num_inodes)⌝ ∗
                     "Hunused" ∷ ([∗ set] k ∈ alloc.unused s_alloc, allocΨ k) ∗
                     "HPalloc" ∷ Palloc γused s_alloc)
  .

  Theorem big_sepM_const_seq {PROP:bi} {A} start sz (def: A) (Φ: nat → A → PROP) :
    ([∗ map] i↦x ∈ gset_to_gmap def (set_seq start sz), Φ i x) -∗
    ([∗ list] i ∈ seq start sz, Φ i def).
  Proof.
    (iInduction sz as [|sz] "IH" forall (start)).
    - rewrite gset_to_gmap_empty big_sepM_empty /=.
      auto.
    - simpl.
      rewrite gset_to_gmap_union_singleton.
      rewrite big_sepM_insert; last first.
      { apply lookup_gset_to_gmap_None.
        rewrite elem_of_set_seq.
        lia. }
      iIntros "[$ Hm]".
      iApply ("IH" with "Hm").
  Qed.

  (* for compatibility with Coq v8.11 *)
  Lemma seq_S : forall len start, seq start (S len) = seq start len ++ [start + len].
  Proof.
    intros len start.
    change [start + len] with (seq (start + len) 1).
    rewrite <- seq_app.
    rewrite <- plus_n_Sm, <- plus_n_O; reflexivity.
  Qed.

  Theorem init_dir {E} (sz: Z) :
    (num_inodes ≤ sz < 2^64)%Z →
    ([∗ list] i ∈ seqZ 0 sz, i d↦[block0] block0) ={E}=∗
    let σ0 := dir.mk $ gset_to_gmap [] $ set_seq 0 num_inodes in
    dir_cinv sz σ0 true.
  Proof.
    (* Proof outline:
       - split disk blocks into first num_inodes and [num_inodes,sz-num_inodes)
       - create inode_cinv using init_inode for each of the first 5
       - create allocator free blocks from remainder, prove something about
         remainder's domain being same as [rangeSet num_inodes (sz -
         num_inodes)]
       - allocate ghost variables for each Pinode and Palloc
     *)
    iIntros (Hbound) "Hd".
    replace (sz) with ((Z.of_nat num_inodes) + ((sz - Z.of_nat num_inodes)))%Z by lia.
    rewrite -> seqZ_app by lia.
    change (0 + Z.of_nat num_inodes)%Z with (Z.of_nat num_inodes).
    rewrite big_sepL_app.
    iDestruct "Hd" as "[Hinodes Hfree]".

    iMod (inode_used_alloc _ (gset_to_gmap ∅ $ set_seq 0 num_inodes)) as (γused) "[Hinode_used Hallused]".
    iMod (inode_blocks_alloc _ (gset_to_gmap [] $ set_seq 0 num_inodes)) as (γblocks) "[Hinode_blocks Hallblocks]".
    iModIntro.
    iApply big_sepM_const_seq in "Hinode_used".
    iApply big_sepM_const_seq in "Hinode_blocks".

    iExists γblocks, γused; iFrame.
    iSplitL "Hinodes Hinode_blocks Hinode_used".
    {
      iInduction num_inodes as [|n Sn] "IH".
      + iExists []; auto.
      + iAssert (⌜(n <= sz)%Z ∧ (sz < 2^64)%Z⌝)%I as "IHbound"; [iPureIntro; word|].
        rewrite !seq_S.
        rewrite seqZ_S.
        repeat change (0+n) with n.
        change (0+n)%Z with (Z.of_nat n).
        rewrite !big_sepL_app.
        iDestruct "Hinodes" as "[Hrest Hinode]".
        iDestruct "Hinode_blocks" as "[Hrest_blocks Hinode_block]".
        iDestruct "Hinode_used" as "[Hrest_used Hinode_used]".
        iSpecialize ("IH" with "IHbound Hrest Hrest_blocks Hrest_used").
        iDestruct "IH" as (s_inodes) "H"; iNamed "H".

        iExists (s_inodes ++ [(inode.mk ∅ [])]).
        iSplitR.
        ++ iPureIntro. rewrite app_length; simpl. lia.
        ++ rewrite big_sepL_app. iFrame "Hinodes".
           repeat rewrite big_sepL_singleton.
           replace (Z.of_nat n) with (int.Z (U64 n)) by word.
           rewrite Hinode_len.
           replace (n+0)%nat with n by word.
           replace (Z.of_nat n) with (int.Z (U64 n)) by word.
           iDestruct (init_inode with "Hinode") as "Hinode".
           iFrame.
    }
    iSplitL "Hfree Hallused".
    { pose proof (new_alloc_state_properties num_inodes (sz-num_inodes) ∅ ltac:(set_solver))
        as (Hdom&Hpost_crash&Hused&Hunused).
      iExists (new_alloc_state num_inodes (sz-num_inodes) ∅).
      iSplitR; first eauto.
      iSplitR.
      { replace ((num_inodes + (sz - num_inodes) - Z.of_nat num_inodes)%Z) with ((sz - num_inodes)%Z) by word.
        rewrite /alloc.domain in Hdom; eauto.
      }
      rewrite /Palloc Hused.
      iSplitL "Hallused".
      + iExists (gset_to_gmap ∅ (set_seq 0 num_inodes)).
        iFrame "Hallused".
        iSplit; iPureIntro; set_unfold; lia.
      + rewrite Hunused difference_empty_L.
        rewrite /rangeSet.
        rewrite big_sepS_list_to_set; last first.
        { apply seq_U64_NoDup; word. }
        rewrite big_sepL_fmap.
        unfold allocΨ.
        iApply (big_sepL_mono with "Hfree").
        iIntros (???) "H".
        iExists _.
        iExists _.
        iExactEq "H".
        f_equiv.
        * apply lookup_seqZ in H. word.
        * eauto.
    }

    iPureIntro.
    intros idx Hidx.
    exists [].
    apply lookup_gset_to_gmap_Some; split; auto.
    set_unfold. lia.
  Qed.

  Lemma pre_inodes_to_cinv inode_refs s_inodes :
    ([∗ list] i↦inode_ref;s_inode ∈ inode_refs;s_inodes,
        pre_inode inode_ref i s_inode) -∗
    ([∗ list] i↦s_inode ∈ s_inodes,
        inode_cinv_precrash i s_inode).
  Proof.
    iIntros "Hpre".
    iApply big_sepL2_to_sepL_2 in "Hpre".
    iApply (big_sepL_mono with "Hpre").
    iIntros (???) "Hpre".
    iDestruct "Hpre" as (inode_ref) "(?&Hpre)".
    iApply pre_inode_to_cinv; eauto.
  Qed.

  Lemma pre_inodes_to_cinv' inode_refs s_inodes :
    ([∗ list] i↦inode_ref;s_inode ∈ inode_refs;s_inodes,
        pre_inode inode_ref i s_inode) -∗
    ([∗ list] i↦s_inode ∈ s_inodes,
        inode_cinv_postcrash i s_inode).
  Proof.
    iIntros "Hpre".
    iApply big_sepL2_to_sepL_2 in "Hpre".
    iApply (big_sepL_mono with "Hpre").
    iIntros (???) "Hpre".
    iDestruct "Hpre" as (inode_ref) "(?&Hpre)".
    iApply pre_inode_to_cinv'; eauto.
  Qed.

  Lemma inodes_cinv_post_to_pre k s_inodes :
    ([∗ list] i↦s_inode ∈ s_inodes,
        inode_cinv_postcrash (k + i) s_inode) -∗
    ([∗ list] i↦s_inode ∈ s_inodes,
        inode_cinv_precrash (k + i) s_inode).
  Proof.
    iIntros "Hpre".
    iApply (big_sepL_mono with "Hpre").
    iIntros (???) "Hpre".
    by iApply inode_cinv_post_to_pre.
  Qed.

  Lemma pre_dir_to_cinv l sz dir :
    pre_dir l sz dir -∗ dir_cinv sz dir true.
  Proof.
    iNamed 1.
    iDestruct "Hinodes" as (s_inodes) "Hpre_inodes".
    iNamed "Halloc".
    iExists _, _; iFrame.
    iSplitL "Hpre_inodes".
    - iDestruct (big_sepL2_length with "Hpre_inodes") as %Hlen'.
      iExists s_inodes; iFrame.
      iSplit.
      { iPureIntro; congruence. }
      iApply big_sepL2_flip in "Hpre_inodes".
      iApply (big_sepL2_elim_big_sepL with "[] Hpre_inodes"); first auto.
      iIntros "!>" (???????) "[Hpre HP]".
      assert (x = z) by congruence; subst.
      iFrame.
      iApply pre_inode_to_cinv'; eauto.
    - iDestruct (is_allocator_pre_post_crash with "Halloc_mem") as %?.
      iExists _; iFrame "∗ %".
  Qed.

  Theorem is_dir_alloc l (sz: Z) σ :
    (5 ≤ sz < 2^64)%Z →
    ▷ P σ -∗
    pre_dir l sz σ ={⊤}=∗
    init_cancel (is_dir l sz)
                (∃ σ', dir_cinv sz σ' false ∗ ▷ P σ').
  Proof.
    iIntros (?) "HP"; iNamed 1.
    iNamed "Hinodes".
    iNamed "Halloc".
    iMod (is_allocator_alloc with "Hunused HPalloc Halloc_mem") as "Halloc".

    (* allocate all the inodes into a list of is_inodes and a cfupd for all the
    crash obligations *)
    iDestruct (big_sepL2_length with "Hinodes") as %Hs_inodes_len.
    iDestruct (big_sepL2_mono with "Hinodes") as "inode_fupds".
    { iIntros (?????) "[Hpre HP]".
      iDestruct (is_inode_alloc inodeN with "HP Hpre") as "H".
      iDestruct (bupd_fupd with "H") as "H". iExact "H". }
    cbv beta.
    iMod (big_sepL2_fupd with "inode_fupds") as "Hinodes".
    iDestruct (big_sepL2_init_cancel with "Hinodes") as "Hinodes".

    iMod (ncinv_alloc dirN _ (∃ σ, dir_inv γblocks σ ∗ P σ)
         with "[Hd_inv HP]") as "(#Hinv&Hinv_crash)".
    { iNext.
      iExists _; iFrame. }
    iMod (own_disc_fupd_elim with "Hinv_crash") as "Hinv_crash".
    rewrite Halloc_dom.
    iModIntro.
    (* Combine then use init_cancel wand *)
    iDestruct (init_cancel_sep with "Halloc Hinodes") as "H".

    iApply (init_cancel_cfupd ⊤).
    iApply (init_cancel_fupd ⊤).
    iApply (init_cancel_wand with "H [Hro_state] [Hinv_crash]").
    { iIntros "H". iDestruct "H" as "(H1&Hinodes)".
      iDestruct "H1" as (γ) "Halloc".
      iModIntro. iExists _, _, _, _, _. iFrame.
      iSplit; first eauto.
      iFrame "Hinv".
      iApply big_sepL2_to_sepL_1' in "Hinodes"; eauto.
      iApply (big_sepL_mono with "Hinodes"); eauto.
      iIntros (???) "H". iDestruct "H" as (s_inode) "(_&$)".
    }
    iIntros "(Halloc&Hinodes)".
    iModIntro.
    iMod (cfupd_weaken_mask with "Hinv_crash") as "Hdir"; auto.
    iDestruct "Hdir" as (σ') "(>Hdir_inv&HP)".
    iIntros "Hc". iExists _. iFrame.
    iMod (alloc_crash_cond_strip_later with "Halloc") as "Halloc".
    iModIntro.
    iExists _, _; iFrame.
    (* here's a bit of gymnastics to maneuver the existential in the big_sepL: *)
    iDestruct (big_sepL2_const_sepL_r with "Hinodes") as "(_&Hinodes)".
    iDestruct (big_sepL_exists_list with "Hinodes") as (s_inodes') "[%Hlen' Hinodes]".
    iApply big_sepL2_to_sepL_1' in "Hinodes"; auto.
    iApply big_sepL2_to_sepL_2 in "Hinodes".
    iExists s_inodes'. iSplit; first (iPureIntro; congruence).

    iApply (big_sepL_mono with "Hinodes").
    iIntros (???) "H".
    iDestruct "H" as (s_inode) "(_&H)".
    iFrame.
  Qed.

  (* TODO: use this to replace list_lookup_lt (it's much easier to remember) *)
  Local Tactic Notation "list_elem" constr(l) constr(i) "as" simple_intropattern(x) :=
    let H := fresh "H" x "_lookup" in
    let i := lazymatch type of i with
            | nat => i
            | Z => constr:(Z.to_nat i)
            | u64 => constr:(int.nat i)
            end in
    destruct (list_lookup_lt _ l i) as [x H];
    [ try solve [ len ]
    | ].

  Lemma wpc_openInodes d s_inodes :
    length s_inodes = num_inodes →
    {{{ ([∗ list] i↦s_inode ∈ s_inodes,
          inode_cinv_postcrash (U64 (Z.of_nat i)) s_inode)
      }}}
      openInodes (disk_val d) @ ⊤
    {{{ inode_s inode_refs, RET (slice_val inode_s);
        is_slice_small inode_s ptrT 1 inode_refs ∗
        [∗ list] i↦inode_ref;s_inode ∈ inode_refs;s_inodes,
            pre_inode inode_ref (U64 (Z.of_nat i)) s_inode
    }}}
    {{{ ([∗ list] i↦s_inode ∈ s_inodes,
          inode_cinv_precrash (U64 (Z.of_nat i)) s_inode) }}}.
  Proof.
    iIntros (? Φ Φc) "Hinode_cinvs HΦ".
    rewrite /openInodes; wpc_pures.
    { crash_case. iApply (big_sepL_mono with "[$]"). iIntros. iApply (inode_cinv_post_to_pre); eauto. }
    iCache with "HΦ Hinode_cinvs".
    { crash_case. iApply (big_sepL_mono with "[$]"). iIntros. iApply (inode_cinv_post_to_pre); eauto. }
    wpc_frame_seq.
    wp_apply wp_ref_of_zero.
    { auto. }
    iIntros (ino_l) "Hinodes". iNamed 1.
    wpc_pures.
    wpc_frame_seq.
    wp_apply wp_ref_to.
    { auto. }
    iIntros (addr_ref) "Haddr". iNamed 1.
    wpc_pures.
    set (inodeT:=(struct.t async_mem_alloc_inode.Inode)).
    wpc_apply (wpc_forUpto
               (λ n, ∃ (inode_s: Slice.t) (inode_refs: list loc),
                   "Hinodes" ∷ ino_l ↦[slice.T ptrT] (slice_val inode_s) ∗
                   "Hinode_slice" ∷ is_slice inode_s ptrT 1 inode_refs ∗
                   "Hpre_inodes" ∷ ([∗ list] i↦inode_ref;s_inode ∈ inode_refs;(take (int.nat n) s_inodes),
                    pre_inode inode_ref i s_inode) ∗
                   "Hinode_cinvs" ∷ ([∗ list] i↦s_inode ∈ (drop (int.nat n) s_inodes),
                                     inode_cinv_postcrash (int.nat n+i) s_inode)
               )%I
              (λ n,
               "Hpre_inodes" ∷ ([∗ list] i↦s_inode ∈ take (int.nat n) s_inodes,
                                inode_cinv_precrash i s_inode) ∗
               "Hinode_cinvs" ∷ ([∗ list] i↦s_inode ∈ drop (int.nat n) s_inodes,
                      inode_cinv_precrash (int.nat n + i) s_inode)
              )%I
              with "[] [Hinodes $Haddr Hinode_cinvs]").
    { word. }
    { iIntros (i Hbound); iNamed 1. iFrame. iSplitL "Hpre_inodes".
      - iApply pre_inodes_to_cinv. eauto.
      - iApply inodes_cinv_post_to_pre. eauto.
    }
    { iIntros (n Φ' Φc') "!> (inv&Haddr&%Hbound) HΦ".
      iNamed "inv".
      wpc_pures.
      { crash_case. iLeft. iFrame.
        iSplitL "Hpre_inodes".
        - by iApply pre_inodes_to_cinv.
        - iApply inodes_cinv_post_to_pre. eauto.
      }
      iCache with "HΦ Hpre_inodes Hinode_cinvs".
      { crash_case. iLeft. iFrame.
        iSplitL "Hpre_inodes".
        - by iApply pre_inodes_to_cinv.
        - iApply inodes_cinv_post_to_pre. eauto.
      }
      wpc_bind (load_ty _ _). wpc_frame. wp_load. iModIntro. iNamed 1.
      wpc_bind (async_mem_alloc_inode.Open _ _).
      change (int.Z (U64 5)) with (Z.of_nat num_inodes) in Hbound.
      list_elem s_inodes n as s_inode.
      rewrite [drop (int.nat n) s_inodes](drop_S _ s_inode); last by auto.
      iDestruct (big_sepL_cons with "Hinode_cinvs") as "[Hs_inode Hinode_cinvs]".
      wpc_apply (async_mem_alloc_inode_proof.wpc_Open with "[Hs_inode]").
      { replace (U64 $ int.nat n + 0) with n by word.
        iFrame. }
      iSplit.
      { iLeft in "HΦ". iIntros "Hs_inode".
        iApply "HΦ".
        iLeft. iSplitL "Hpre_inodes".
        { by iApply pre_inodes_to_cinv. }
        iApply big_sepL_cons.
        replace (U64 $ int.nat n + 0) with n by word.
        iFrame.
        setoid_rewrite <-(Nat.add_succ_comm).
        by iApply inodes_cinv_post_to_pre.
      }
      iIntros "!>" (inode_ref) "Hpre_inode".
      wpc_frame "HΦ Hpre_inode Hpre_inodes Hinode_cinvs".
      { crash_case. iLeft. iApply (pre_inodes_to_cinv) in "Hpre_inodes". iFrame.
        simpl.
        replace (U64 $ int.nat n + 0) with n by word.
        iSplitL "Hpre_inode".
        { by iApply pre_inode_to_cinv. }
        iApply (big_sepL_mono with "Hinode_cinvs").
        iIntros (???) "H". by iApply inode_cinv_post_to_pre.
      }
      wp_load.
      wp_apply (wp_SliceAppend with "Hinode_slice").
      iIntros (inode_s') "Hinode_slice".
      wp_store. iModIntro.
      iNamed 1.
      iRight in "HΦ"; iApply "HΦ".
      iFrame.
      iExists _, _; iFrame.
      iDestruct (big_sepL2_length with "Hpre_inodes") as %Hlens;
          autorewrite with len in Hlens.
      replace (int.nat (word.add n 1%Z)) with (S (int.nat n)); last first.
      { unfold num_inodes in Hbound; word. }
      iSplitR "Hinode_cinvs".
      - erewrite take_S_r by eauto.
        iApply (big_sepL2_app with "Hpre_inodes").
        simpl. iSplitL; last done.
        iExactEq "Hpre_inode".
        f_equal.
        word.
      - iApply (big_sepL_mono with "Hinode_cinvs").
        iIntros (?? ?) "Hpre".
        iExactEq "Hpre".
        repeat (f_equal; try word). }
    { iExists Slice.nil, [].
      iFrame.
      rewrite big_sepL2_nil.
      rewrite -is_slice_zero.
      rewrite /named //. }
    iSplit.
    { (* loop crash condition implies overall crash condition *)
      iLeft in "HΦ".
      iIntros "Hinv".
      iDestruct "Hinv" as (i) "(Hpre&%Hbound')".
      iNamed "Hpre".
      iApply "HΦ".
      iEval (rewrite -[l in big_opL _ _ l](take_drop (int.nat i))).
      rewrite big_sepL_app.
      iSplitL "Hpre_inodes".
      - iApply (big_sepL_mono with "Hpre_inodes").
        iIntros (???) "Hpre".
        iDestruct "Hpre" as (?) "Hpre".
        iExists _. iFrame.
      - iApply (big_sepL_mono with "Hinode_cinvs").
        iIntros (???) "Hpre".
        change (int.Z (U64 5)) with 5%Z in Hbound'.
        iExactEq "Hpre".
        f_equal; len.
        rewrite H /num_inodes.
        replace (int.nat i `min` 5)%nat with (int.nat i) by lia.
        f_equal. }
    iIntros "!> (Hinv&Haddr)". iNamed "Hinv".
    change (int.Z (U64 5)) with 5%Z.
    rewrite -> take_ge by word.
    rewrite -> drop_ge by word.
    wpc_frame_compl "Hinodes".
    { crash_case. iApply pre_inodes_to_cinv. eauto. }
    wp_load. iModIntro.
    iNamed 1.
    iRight in "HΦ"; iApply "HΦ".
    iFrame.
    iApply (is_slice_to_small with "Hinode_slice").
  Qed.

  Theorem wpc_inodeUsedBlocks inode_s inode_refs s_inodes :
    {{{ "Hinode_s" ∷ is_slice_small inode_s ptrT 1 inode_refs ∗
        "Hpre_inodes" ∷ [∗ list] i↦inode_ref;s_inode ∈ inode_refs;s_inodes,
                    pre_inode inode_ref i s_inode }}}
      inodeUsedBlocks (slice_val inode_s) @ ⊤
    {{{ (addrs_ref:loc) used, RET #addrs_ref;
        "Hused_set" ∷ is_addrset addrs_ref used ∗
        "%Hused_eq" ∷ ⌜used = ⋃ (inode.addrs <$> s_inodes)⌝ ∗
        "Hinode_s" ∷ is_slice_small inode_s ptrT 1 inode_refs ∗
        "Hpre_inodes" ∷ [∗ list] i↦inode_ref;s_inode ∈ inode_refs;s_inodes,
                  pre_inode inode_ref i s_inode }}}
    {{{ [∗ list] i↦s_inode ∈ s_inodes,
       inode_cinv_precrash i s_inode
    }}}.
  Proof.
    iIntros (Φ Φc) "Hpre HΦ"; iNamed "Hpre".
    rewrite /inodeUsedBlocks.
    wpc_pures.
    { iLeft in "HΦ". iApply "HΦ". by iApply pre_inodes_to_cinv. }
    iCache with "HΦ Hpre_inodes".
    { crash_case. by iApply pre_inodes_to_cinv. }
    wpc_frame_seq.
    wp_apply (wp_NewMap unit (t:=struct.t alloc.unit)).
    iIntros (addrs_ref) "Hused_set".
    iApply is_addrset_from_empty in "Hused_set".
    iNamed 1.
    wpc_pures.
    iDestruct (is_slice_small_sz with "Hinode_s") as %Hinode_ref_len.
    wpc_apply (wpc_forSlice (V:=loc)
                (λ n, "Hpre_inodes" ∷ ([∗ list] i↦inode_ref;s_inode ∈ inode_refs;s_inodes,
                                  pre_inode inode_ref i s_inode) ∗
               "Hused_set" ∷ is_addrset addrs_ref
                  (⋃ (take (int.nat n) (inode.addrs <$> s_inodes))))%I
                ([∗ list] i↦s_inode ∈ s_inodes, inode_cinv_precrash i s_inode)%I
             with "[] [] [$Hinode_s $Hpre_inodes $Hused_set]").
    { iIntros "!>" (x) "Hpre"; iNamed "Hpre". iApply pre_inodes_to_cinv. eauto. }
    { iIntros (i inode_ref) "!>".
      iIntros (Φ' Φc') "(Hpre&%Hbound&%Hlookup) HΦ"; iNamed "Hpre".
      wpc_pures.
      { crash_case. by iApply pre_inodes_to_cinv. }
      iDestruct (big_sepL2_lookup_1_some with "Hpre_inodes") as "%Hs_inode_lookup"; eauto.
      destruct Hs_inode_lookup as [s_inode Hs_inode_lookup].
      iDestruct (big_sepL2_lookup_acc_and _ (λ i inode_ref s_inode, inode_cinv_precrash i s_inode) with "Hpre_inodes") as "(Hinode&Hpre_inodes)"; eauto.
      { clear.
        iIntros (k inode_ref s_inode ??) "Hpre".
        iApply pre_inode_to_cinv; eauto. }
      wpc_pures.
      { iRight in "Hpre_inodes".
        crash_case.
        iApply pre_inode_to_cinv in "Hinode".
        iSpecialize ("Hpre_inodes" with "Hinode").
        iApply big_sepL2_to_sepL_2 in "Hpre_inodes".
        iApply (big_sepL_mono with "Hpre_inodes").
        iIntros (???) "Hcinv".
        iDestruct "Hcinv" as (?) "(_&$)". }
      wpc_apply (wpc_Inode__UsedBlocks with "Hinode").
      iSplit.
      { iRight in "Hpre_inodes".
        crash_case. iLeft in "HΦ". iIntros. iApply "HΦ".
        iSpecialize ("Hpre_inodes" with "[$]").
        iApply big_sepL2_to_sepL_2 in "Hpre_inodes".
        iApply (big_sepL_mono with "Hpre_inodes").
        iIntros (???) "Hcinv".
        iDestruct "Hcinv" as (?) "(_&$)". }
      iIntros "!>" (addrs_s addrs) "(Hused_addrs&%Haddrset&Hpre_inode)".
      wpc_frame "HΦ Hpre_inodes Hpre_inode".
      {
        iRight in "Hpre_inodes".
        iRight in "Hpre_inode".
        crash_case. iSpecialize ("Hpre_inodes" with "Hpre_inode").
        iFrame.
        iApply big_sepL2_to_sepL_2 in "Hpre_inodes".
        iApply (big_sepL_mono with "Hpre_inodes").
        iIntros (???) "Hcinv".
        iDestruct "Hcinv" as (?) "(_&$)". }
      iDestruct (is_slice_small_acc with "Hused_addrs") as "(Hused_addrs&Hused_cap)".
      wp_apply (wp_SetAdd with "[$Hused_set $Hused_addrs]").
      iIntros "(Hused_set&Hused_addrs)".
      iDestruct ("Hused_cap" with "Hused_addrs") as "Hused_addrs".
      iNamed 1.
      iApply "HΦ".
      iSplitR "Hused_set".
      { iLeft in "Hpre_inodes".
        iApply ("Hpre_inodes" with "(Hpre_inode Hused_addrs)"). }
      rewrite Haddrset.
      iExactEq "Hused_set".
      rewrite /named.
      f_equal.
      replace (int.nat (word.add i 1%Z)) with (S (int.nat i)) by word.
      erewrite take_S_r; last first.
      { rewrite list_lookup_fmap.
        rewrite Hs_inode_lookup //. }
      rewrite union_list_app_L /= right_id_L //. }
    iSplit.
    { iLeft in "HΦ". eauto. }
    iIntros "!> (Hinv&Hinode_s)"; iNamed "Hinv".
    wpc_pures.
    iDestruct (big_sepL2_length with "Hpre_inodes") as %Hlens.
    iApply "HΦ"; iFrame.
    rewrite -> take_ge by len; eauto.
  Qed.

  Fixpoint delete_below `(m : gmap nat T) (off : nat) :=
    match off with
    | O => m
    | S off' => delete off' (delete_below m off')
    end.

  Lemma delete_below_insert : forall (off : nat) (pos : nat) `(m : gmap nat T) v,
    off <= pos ->
    delete_below (<[pos:=v]> m) off = <[pos:=v]> (delete_below m off).
  Proof.
    induction off; intros; simpl; eauto.
    rewrite IHoff; last by lia.
    rewrite delete_insert_ne //. lia.
  Qed.

  Lemma delete_below_delete : forall (off : nat) (pos : nat) `(m : gmap nat T),
    off <= pos ->
    delete_below (delete pos m) off = delete pos (delete_below m off).
  Proof.
    induction off; intros; simpl; eauto.
    rewrite IHoff; last by lia.
    rewrite delete_commute //.
  Qed.

  Lemma unify_alloc_inodes_used_helper γused γblocks allocs s_inodes off :
    ([∗ list] i↦s_inode ∈ s_inodes, Pinode γblocks γused (off + i) s_inode) -∗
    inode_allused γused allocs -∗
    ⌜length s_inodes = length (map_to_list (delete_below allocs off)) ->
     ⋃ (map_to_list (delete_below allocs off)).*2 = ⋃ (inode.addrs <$> s_inodes)⌝.
  Proof.
    rewrite /Pinode.
    iIntros "Hinodes Hall".
    iInduction s_inodes as [|] "IH" forall (off).
    { iPureIntro. intros.
      generalize dependent (map_to_list (delete_below allocs off)). intros.
      destruct l; simpl in *; congruence. }
    iDestruct "Hinodes" as "[Ha Hinodes]". iNamed "Ha".
    iDestruct (inode_used_lookup with "Hused1 Hall") as "%".
    replace (allocs) with (<[off := a.(inode.addrs)]> (delete off allocs)) at 2 3.
    2: { rewrite insert_delete //. replace (off) with (off + 0) by lia. done. }
    rewrite delete_below_insert; last by lia.
    rewrite map_to_list_insert.
    2: { rewrite delete_below_delete; last by lia. rewrite lookup_delete //. }
    rewrite ?fmap_cons ?union_list_cons /=.
    iDestruct ("IH" $! (S off) with "[Hinodes] Hall") as "%IH".
    { setoid_rewrite plus_n_Sm. iFrame. }
    rewrite delete_below_delete; last by lia.
    iPureIntro. intros.
    rewrite -IH /=; last by lia. done.
  Qed.

  Lemma unify_alloc_inodes_used γused γblocks s_alloc s_inodes :
    length s_inodes = num_inodes →
    ([∗ list] i↦s_inode ∈ s_inodes, Pinode γblocks γused i s_inode) -∗
    Palloc γused s_alloc -∗
    ⌜alloc.used s_alloc = ⋃ (inode.addrs <$> s_inodes)⌝.
  Proof.
    rewrite /Palloc.
    iIntros (Hlen) "Hinodes". iNamed 1. rewrite Hused_global.
    iDestruct (unify_alloc_inodes_used_helper _ _ _ _ 0 with "Hinodes Hused2") as "%Hhelper".
    iPureIntro. rewrite -Hhelper /=; eauto.
    rewrite length_gmap_to_list.
    congruence.
  Qed.

  Theorem wpc_Open d (sz: u64) σ0 :
    (5 ≤ int.Z sz)%Z →
    {{{ dir_cinv (int.Z sz) σ0 true }}}
      Open (disk_val d) #sz @ ⊤
    {{{ l, RET #l; pre_dir l (int.Z sz) σ0 }}}
    {{{ dir_cinv (int.Z sz) σ0 false }}}.
  Proof using Type* - P.
    iIntros (? Φ Φc) "Hcinv HΦ".
    wpc_call.
    { iApply dir_cinv_post_crash; auto. }
    { iApply dir_cinv_post_crash; auto. }
    iNamed "Hcinv".
    iCache with "HΦ Hinodes Halloc Hs_inode".
    { crash_case.
      iApply dir_cinv_post_crash.
      iExists _, _; iFrame. }
    wpc_pures.
    iNamed "Hinodes".
    iDestruct (big_sepL_sep with "Hinodes") as "(Hinode_cinvs&HPinodes)".
    wpc_apply (wpc_openInodes with "Hinode_cinvs"); auto.
    iSplit.
    { iLeft in "HΦ". iIntros "Hinode_cinvs".
      iApply "HΦ".
      iExists _, _; iFrame.
      iSplitR "Halloc"; last first.
      { iApply alloc_crash_cond_no_later_from_post_crash; auto. }
      iExists _. iSplit; first eauto.
      iApply big_sepL_sep. iFrame.
    }
    iIntros "!>" (inode_s inode_refs) "(Hinode_s & Hpre_inodes)".
    iCache with "HΦ Hpre_inodes HPinodes Halloc Hs_inode".
    { crash_case.
      iExists _, _; iFrame.
      iSplitR "Halloc"; last first.
      { iApply alloc_crash_cond_no_later_from_post_crash; auto. }
      iExists _. iSplit; first eauto.
      iApply big_sepL_sep. iFrame.
      iApply pre_inodes_to_cinv. eauto.
    }
    wpc_pures.
    wpc_apply (wpc_inodeUsedBlocks with "[$Hinode_s $Hpre_inodes]").
    iSplit.
    { iLeft in "HΦ". iIntros "Hinode_cinvs".
      iApply "HΦ".
      iExists _, _; iFrame.
      iSplitR "Halloc"; last first.
      { iApply alloc_crash_cond_no_later_from_post_crash; auto. }
      iExists _. iSplit; first eauto.
      iApply big_sepL_sep. iFrame.
    }
    iIntros "!>" (addrs_ref used); iNamed 1.
    iDestruct "Halloc" as (s_alloc) "Halloc"; iNamed "Halloc".
    iDestruct (unify_alloc_inodes_used with "HPinodes HPalloc") as %Hused; auto.
    wpc_frame "HΦ Hpre_inodes HPinodes HPalloc Hunused Hs_inode".
    { crash_case.
      iExists _, _; iFrame.
      iSplitL "Hpre_inodes HPinodes".
      - iExists s_inodes; iFrame "∗ %".
        iApply big_sepL_sep; iFrame.
        iApply pre_inodes_to_cinv. eauto.
      - iExists _; iFrame "∗ %". }
    rewrite -wp_fupd.
    wp_apply (wp_newAllocator s_alloc with "Hused_set").
    { word. }
    { word_cleanup.
      rewrite /alloc.domain.
      rewrite Halloc_dom.
      f_equal; lia. }
    { congruence. }
    { auto. }
    iIntros (alloc_ref) "Halloc_mem".
    wp_apply wp_allocStruct; first val_ty.
    iIntros (inode_ref) "Hinode_fields".
    iDestruct (struct_fields_split with "Hinode_fields") as "(d&allocator&inodes&_)".
    iMod (readonly_alloc_1 with "d") as "#d".
    iMod (readonly_alloc_1 with "allocator") as "#allocator".
    iMod (readonly_alloc_1 with "inodes") as "#inodes".
    iMod (readonly_alloc_1 with "Hinode_s") as "#inode_s".
    iModIntro.
    iNamed 1.
    iApply "HΦ".
    iDestruct (big_sepL2_length with "Hpre_inodes") as %Hlens.
    iExists alloc_ref, inode_refs, _, _; iFrame.
    iSplit.
    { iPureIntro; lia. }
    iSplitR.
    { iExists _, _; iFrame "#". }
    iSplitL "Hpre_inodes HPinodes".
    { iExists s_inodes; iFrame.
      rewrite big_sepL2_sep; iFrame.
      iAssert ([∗ list] k↦v ∈ inode_refs, emp)%I as "Hinode_refs".
      { iApply big_sepL_emp. done. }
      iDestruct (big_sepL2_sepL_2 with "Hinode_refs HPinodes") as "Hmerge"; eauto.
      iApply (big_sepL2_mono with "Hmerge").
      iIntros (?????) "[_ H]". iFrame.
    }
    iExists _; iFrame "∗ %".
  Qed.

  Theorem wpc_Dir__Read (Q: option Block → iProp Σ) l sz (idx: u64) (i: u64) :
    int.nat idx < num_inodes →
    {{{ "#Hdir" ∷ is_dir l sz ∗
        "Hfupd" ∷ (∀ σ blocks mb,
                      ⌜σ.(dir.inodes) !! int.nat idx = Some blocks ∧
                       mb = blocks !! int.nat i⌝ -∗
                      ▷ P σ ={⊤ ∖ ↑N}=∗ ▷ P σ ∗ Q mb)
    }}}
      Dir__Read #l #idx #i @ ⊤
    {{{ (s:Slice.t) mb, RET (slice_val s);
        match mb with
        | None => ⌜s = Slice.nil⌝
        | Some b => is_block s 1 b
        end ∗ Q mb }}}
    {{{ True }}}.
  Proof.
    iIntros (Hidx Φ Φc) "Hpre HΦ"; iNamed "Hpre".
    wpc_call.
    { crash_case; auto. }
    { crash_case; auto. }
    iCache with "HΦ Hfupd".
    { crash_case; auto. }
    iNamed "Hdir". iNamed "Hro_state".
    edestruct (lookup_lt_is_Some_2 inode_refs) as [inode_ref Hinode_ref].
    { rewrite Hlen. done. }
    iDestruct (big_sepL_lookup _ _ _ _ Hinode_ref with "Hinodes") as "Hinode {Hinodes}".
    wpc_pures.
    wpc_frame_seq.
    wp_loadField.
    iMod (readonly_load with "inodes_s") as (qinodes) "{inodes_s} inodes_s".
    wp_apply (wp_SliceGet _ _ _ _ _ inode_refs with "[$inodes_s //]").
    iIntros "inodes_s Hrest". iNamed "Hrest".
    wpc_pures.
    (* Now we get to the actual read operation. *)
    iApply (wpc_step_strong_mono _ _ _ _ _
         (λ v, (∃ s mb, ⌜ v = slice_val s ⌝ ∗
                match mb with
                | Some b => is_block s 1 b
                | None => ⌜s = Slice.nil⌝
                end ∗ Q mb))%I _ True with "[-HΦ] [HΦ]"); auto.
    2: { iSplit.
         * iNext. iIntros (?) "H". iDestruct "H" as (??) "(%&?)". subst.
           iModIntro. iRight in "HΦ". by iApply "HΦ".
         * iLeft in "HΦ". iIntros. iModIntro. by iApply "HΦ". }
    iApply (wpc_Inode__Read with "[Hinode]"); first done.
    iSplit; first eauto.
    iIntros "!>" (σI mb) "[%Hmb HPI]". iNamed "HPI".
    iInv dirN as (σD) "[>Hdir HPD]".
    (* We need to learn that this inode exists in σD. *)
    rewrite /dir_inv. iNamed "Hdir".
    destruct (Hdom _ Hidx) as [σI' HσI'].
    iDestruct (inode_blocks_lookup with "Hownblocks Hγblocks") as %Hblock.
    simplify_eq.
    iMod fupd_mask_subseteq as "HcloseM"; (* adjust mask *)
        last iMod ("Hfupd" with "[] HPD") as "[HPD HQ]".
    { solve_ndisj. }
    { iPureIntro. eauto. }
    iMod "HcloseM" as "_". iModIntro. iSplitL "Hγblocks HPD".
    { (* re-establish dir_inv *) eauto 10 with iFrame. }
    iModIntro. iSplitL "Hownblocks Hused1".
    { (* re-establish inode invariant *) rewrite /Pinode. eauto 10 with iFrame. }
    iSplit.
    { eauto. }
    iIntros (s) "Hpost".
    iExists _, _; iSplit; first eauto; iFrame; eauto.
  Qed.

  Theorem wpc_Dir__Size (Q: u64 → iProp Σ) l sz (idx: u64):
    int.nat idx < num_inodes →
    {{{ "#Hdir" ∷ is_dir l sz ∗
        "Hfupd" ∷ (∀ σ blocks sz,
                      ⌜σ.(dir.inodes) !! int.nat idx = Some blocks ∧
                       int.nat sz = length blocks⌝ -∗
                      ▷ P σ ={⊤ ∖ ↑N}=∗ ▷ P σ ∗ Q sz)
    }}}
      Dir__Size #l #idx @ ⊤
    {{{ sz, RET #sz; Q sz }}}
    {{{ True }}}.
  Proof.
    iIntros (Hidx Φ Φc) "Hpre HΦ"; iNamed "Hpre".
    wpc_call.
    { crash_case; auto. }
    { crash_case; auto. }
    iCache with "HΦ Hfupd".
    { crash_case; auto. }
    wpc_pures.
    iNamed "Hdir". iNamed "Hro_state".
    edestruct (lookup_lt_is_Some_2 inode_refs) as [inode_ref Hinode_ref].
    { rewrite Hlen. done. }
    iDestruct (big_sepL_lookup _ _ _ _ Hinode_ref with "Hinodes") as "Hinode {Hinodes}".
    wpc_frame_seq.
    wp_loadField.
    iMod (readonly_load with "inodes_s") as (qinodes) "{inodes_s} inodes_s".
    wp_apply (wp_SliceGet _ _ _ _ _ inode_refs with "[$inodes_s //]").
    iIntros "inodes_s Hrest". iNamed "Hrest".
    wpc_pures.
    (* Now we get to the actual size operation. *)
    iApply (wpc_step_strong_mono _ _ _ _ _
           (λ v, ∃ (sz : u64), ⌜ v = #sz ⌝ ∗ Q sz)%I _ _ with "[-HΦ] [HΦ]"); auto.
    2: { iSplit.
         * iNext. iIntros (?) "H". iDestruct "H" as (?) "(%&?)". subst.
           iModIntro. iRight in "HΦ". by iApply "HΦ".
         * iLeft in "HΦ". iIntros. iModIntro. by iApply "HΦ". }
    iApply (wpc_Inode__Size with "[$Hinode]").
    iSplit; first eauto.
    iIntros "!>" (σI mb) "[%Hmb HPI]". iNamed "HPI".
    iInv dirN as (σD) "[>Hdir HPD]".
    (* We need to learn that this inode exists in σD. *)
    rewrite /dir_inv. iNamed "Hdir".
    destruct (Hdom _ Hidx) as [σI' HσI'].
    iDestruct (inode_blocks_lookup with "Hownblocks Hγblocks") as %Hblock.
    simplify_eq.
    iMod fupd_mask_subseteq as "HcloseM"; (* adjust mask *)
        last iMod ("Hfupd" with "[] HPD") as "[HPD HQ]".
    { solve_ndisj. }
    { iPureIntro. eauto. }
    iMod "HcloseM" as "_". iModIntro. iSplitL "Hγblocks HPD".
    { (* re-establish dir_inv *) eauto 10 with iFrame. }
    iModIntro. iSplitL "Hownblocks Hused1".
    { (* re-establish inode invariant *) rewrite /Pinode. eauto 10 with iFrame. }
    iSplit.
    - eauto.
    - iIntros "_". eauto.
  Qed.

  (* these two fupds are easy to prove universally because the change they make
  doesn't affect the free set, which is all that Palloc talks about *)

  Lemma reserve_fupd_Palloc E γused :
    ⊢ reserve_fupd E (Palloc γused).
  Proof.
    iIntros (s s' ma Hma) "HPalloc".
    destruct ma; intuition subst; auto.
    iModIntro.
    rewrite /Palloc /named.
    rewrite alloc_used_reserve //.
  Qed.

  Lemma free_fupd_Palloc E γused :
    ⊢ ∀ a, free_fupd E (Palloc γused) a.
  Proof.
    iIntros (a s s') "HPalloc".
    iModIntro.
    rewrite /Palloc /named.
    rewrite alloc_free_reserved //.
  Qed.

  (*
  Lemma dir_cinv_crash_true E sz σ :
    dir_cinv sz σ false ={E}=∗ dir_cinv sz σ true.
  Proof.
    iNamed 1. rewrite /dir_cinv.
    iMod (alloc_crash_cond_no_later_crash_true with "[] Halloc").
    {
      iIntros (σ0). rewrite /Palloc/named. rewrite used_revert_reserved.
      iIntros "H". eauto.
    }
    iModIntro. iExists _, _. iFrame.
  Qed.
   *)

  Lemma alloc_insert_dom idx (new_addrs old_addrs inode_addrs: gset u64)
        (allocs: gmap nat (gset u64)) :
    old_addrs = ⋃ (snd <$> map_to_list allocs) →
    allocs !! idx = Some inode_addrs →
    new_addrs ∪ old_addrs =
    ⋃ (snd <$> map_to_list (<[idx:=new_addrs ∪ inode_addrs]> allocs)).
  Proof.
    intros -> Hidx.
    revert idx Hidx; induction allocs using map_ind; intros idx Hidx.
    { exfalso. rewrite lookup_empty in Hidx. done. }
    destruct (decide (idx = i)) as [->|Hne].
    - (* Induction reached the updated idx. We bottom out. *)
      rewrite insert_insert. rewrite !map_to_list_insert //.
      rewrite !fmap_cons !union_list_cons /=.
      rewrite lookup_insert in Hidx. simplify_eq/=. set_solver+.
    - (* The updated element is a different one. Recurse. *)
      rewrite insert_commute //. rewrite map_to_list_insert //.
      rewrite map_to_list_insert; last first.
      { rewrite lookup_insert_ne //. }
      rewrite !fmap_cons !union_list_cons /=.
      rewrite -IHallocs; last first.
      { rewrite -Hidx lookup_insert_ne //. }
      set_solver+.
  Qed.

  (* FIXME: in case of failure, the resources put into "Hfupd" are lost! *)
  Theorem wpc_Dir__Append (Q: iProp Σ) l sz b_s b0 (idx: u64) :
    int.nat idx < num_inodes →
    {{{ "#Hdir" ∷ is_dir l sz ∗
        "Hb" ∷ is_block b_s 1 b0 ∗
        "Hfupd" ∷ (∀ σ blocks,
                      ⌜σ.(dir.inodes) !! int.nat idx = Some blocks⌝ -∗
                      ▷ P σ ={⊤ ∖ ↑N}=∗ ▷ P (dir.mk $ <[ int.nat idx := blocks ++ [b0] ]> σ.(dir.inodes)) ∗ Q)
    }}}
      Dir__Append #l #idx (slice_val b_s) @ ⊤
    {{{ (ok: bool), RET #ok; if ok then Q else emp }}}
    {{{ True }}}.
  Proof.
    iIntros (Hidx Φ Φc) "Hpre HΦ"; iNamed "Hpre".
    wpc_call.
    { crash_case; auto. }
    { crash_case; auto. }
    iCache with "HΦ Hfupd".
    { crash_case; auto. }
    wpc_pures.
    iNamed "Hdir". iNamed "Hro_state".
    edestruct (lookup_lt_is_Some_2 inode_refs) as [inode_ref Hinode_ref].
    { rewrite Hlen. done. }
    iDestruct (big_sepL_lookup _ _ _ _ Hinode_ref with "Hinodes") as "Hinode {Hinodes}".
    wpc_frame_seq.
    wp_loadField.
    iMod (readonly_load with "inodes_s") as (qinodes) "{inodes_s} inodes_s".
    wp_apply (wp_SliceGet _ _ _ _ _ inode_refs with "[$inodes_s //]").
    iIntros "inodes_s Hrest". iNamed "Hrest".
    wpc_pures.
    wpc_loadField.
    (* Now we get to the actual append operation. *)
    iApply (wpc_step_strong_mono _ _ _ _ _
           (λ v, ∃ (ok: bool), ⌜ v = #ok ⌝ ∗ if ok then Q else emp)%I _ _ with "[-HΦ] [HΦ]"); auto.
    2: { iSplit.
         * iNext. iIntros (?) "H". iDestruct "H" as (?) "(%&?)". subst.
           iModIntro. iRight in "HΦ". by iApply "HΦ".
         * iLeft in "HΦ". iIntros. iModIntro. by iApply "HΦ". }
    iApply (wpc_Inode__Append inodeN allocN);
      [solve_ndisj|..].
    iFrame "Hinode Hb Halloc".
    iSplit; [ | iSplit; [ | iSplit ] ].
    - iApply reserve_fupd_Palloc.
    - iApply free_fupd_Palloc.
    - eauto.
    - iSplit.
      { (* Failure case *) iNext. iExists _; iSplit; eauto. }
      iIntros "!>" (σ σ' addr' -> Hwf s Hreserved) "(HPinode&>HPalloc)".
      iEval (rewrite /Palloc) in "HPalloc". iNamed "HPalloc".
      iNamed "HPinode".
      iDestruct (inode_used_lookup with "Hused1 Hused2") as %Heq.
      iInv "Hinv" as ([σ0]) "[>Hinner HP]" "Hclose".
      iNamed "Hinner".
      iMod (inode_used_update _ (union {[addr']} σ.(inode.addrs)) with "Hused1 Hused2") as
          "[Hγused Hused]".
      iDestruct (inode_blocks_lookup with "Hownblocks Hγblocks") as %Heq2.
      simplify_eq/=.
      iMod (inode_blocks_update  _ (σ.(inode.blocks) ++ [b0]) with "Hownblocks Hγblocks") as
          "[Hownblocks Hγblocks]".
      iSpecialize ("Hfupd" $! {| dir.inodes := σ0 |}). rewrite Heq2.
      iMod fupd_mask_subseteq as "HcloseM"; last (* adjust mask *)
        iMod ("Hfupd" with "[% //] [$HP]") as "[HP HQ]".
      { solve_ndisj. }
      iMod "HcloseM" as "_".
      simpl. iMod ("Hclose" with "[Hγblocks HP]") as "_".
      { iNext. iExists _. iFrame "HP". rewrite /dir_inv /=. iFrame.
        (* Show that the first 5 inodes are still all allocated. *)
        iPureIntro. intros idx' Hidx'. destruct (decide ((int.nat idx) = idx')) as [->|Hne].
        - rewrite lookup_insert. eauto.
        - rewrite lookup_insert_ne //. apply Hdom. done.
      }
      iModIntro.
      iFrame.
      rewrite /Palloc.
      iSplitR "HQ".
      { iNext. iExists _. iFrame "Hused".
        (* Show that the domain bookeeping worked out. *)
        iPureIntro. split.
        - rewrite map_size_insert_Some //.
        - rewrite alloc_used_insert.
          apply alloc_insert_dom; auto.
      }
      iSplit; eauto.
  Qed.

End goose.

From Perennial.goose_lang Require Import crash_modality recovery_lifting.

Section crash_stable.
  Context `{!heapGS Σ}.
  Context `{!stagedG Σ}.
  Context `{!inG Σ blocksR}.
  Context `{!inG Σ allocsR}.

  Instance allocΨ_crash_stable k:
    IntoCrash (allocΨ k) (λ _, allocΨ k).
  Proof.
    rewrite /IntoCrash. iNamed 1.
    iCrash. iExists _; eauto.
  Qed.

  Instance Palloc_crash_stable γ σ:
    IntoCrash (Palloc γ σ) (λ _, Palloc γ σ).
  Proof. rewrite /IntoCrash. iApply post_crash_nodep. Qed.

  Instance Pinode_crash_stable γblocks γused i s_inode:
    IntoCrash (Pinode γblocks γused i s_inode) (λ _, Pinode γblocks γused i s_inode).
  Proof. rewrite /IntoCrash. iApply post_crash_nodep. Qed.

  Existing Instance inode_cinv_pre_post.

  Global Instance dir_cinv_crash sz σ0 :
    IntoCrash (dir_cinv sz σ0 false) (λ _, (|={⊤}=> dir_cinv sz σ0 true)%I).
  Proof.
    rewrite /IntoCrash /dir_cinv.
    iNamed 1.
    iNamed "Hinodes".
    rewrite (allocator_crash_cond_no_later_stable (λ _, Palloc γused)).
    rewrite /dir_inv.
    iNamed "Hs_inode".
    rewrite /inode_allblocks.
    iPoseProof (post_crash_nodep with "Hγblocks") as "Hγblocks".
    iCrash.
    iExists _, _.
    iMod (alloc_crash_cond_no_later_crash_true with "[] Halloc").
    {
      iIntros (σ0'). rewrite /Palloc/named. rewrite used_revert_reserved.
      iIntros "H". eauto.
    }
    iModIntro.
    iFrame.
    iSplitL "Hinodes".
    { iExists _. iSplit; first eauto. iFrame. }
    eauto.
  Qed.

End crash_stable.

Section recov.
  Context `{!heapGS Σ}.
  Context `{!allocG Σ}.
  Context `{!stagedG Σ}.
  Context `{!inG Σ blocksR}.
  Context `{!inG Σ allocsR}.

  Set Nested Proofs Allowed.

  (* Just a simple example of using idempotence *)
  Theorem wpr_Open (d: ()) (sz: u64) σ0:
    (5 ≤ int.Z sz)%Z →
    dir_cinv (int.Z sz) σ0 true -∗
    wpr NotStuck ⊤
        (Open (disk_val d) #sz)
        (Open (disk_val d) #sz)
        (λ _, True%I)
        (λ _, True%I)
        (λ _ _, True%I).
  Proof using Type*.
    iIntros (Hsz) "Hstart".
    iApply (idempotence_wpr NotStuck ⊤ _ _ (λ _, True)%I (λ _, True)%I (λ _ _, True)%I (λ _, ∃ σ', dir_cinv (int.Z sz) σ' false)%I with "[Hstart] []").
    { wpc_apply (wpc_Open with "Hstart"); auto 10. }
    iModIntro. iIntros (????) "H".
    iDestruct "H" as (σ'') "Hstart".
    (* TODO(Joe): why does iCrash not work after the iNext? *)
    iNext. rewrite dir_cinv_crash. iRevert "Hstart".
    iApply @post_crash_mono.
    iIntros (?) "Hstart _".
    iSplit; first done.
    iMod "Hstart".
    wpc_apply (wpc_Open with "Hstart").
    { eauto. }
    eauto 10.
  Qed.
End recov.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RealmSyncHandlerAux.Spec.
Require Import RealmSyncHandlerAux.Layer.
Require Import RealmSyncHandler.Code.handle_sysreg_access_trap.

Require Import RealmSyncHandler.LowSpecs.handle_sysreg_access_trap.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _assert_cond ↦ gensem assert_cond_spec
      ⊕ _handle_id_sysreg_trap ↦ gensem handle_id_sysreg_trap_spec
      ⊕ _handle_timer_sysreg_trap ↦ gensem handle_timer_sysreg_trap_spec
      ⊕ _handle_icc_el1_sysreg_trap ↦ gensem handle_icc_el1_sysreg_trap_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_assert_cond: block.
    Hypothesis h_assert_cond_s : Genv.find_symbol ge _assert_cond = Some b_assert_cond.
    Hypothesis h_assert_cond_p : Genv.find_funct_ptr ge b_assert_cond
                                 = Some (External (EF_external _assert_cond
                                                  (signature_of_type (Tcons tuint Tnil) tvoid cc_default))
                                        (Tcons tuint Tnil) tvoid cc_default).
    Local Opaque assert_cond_spec.

    Variable b_handle_id_sysreg_trap: block.
    Hypothesis h_handle_id_sysreg_trap_s : Genv.find_symbol ge _handle_id_sysreg_trap = Some b_handle_id_sysreg_trap.
    Hypothesis h_handle_id_sysreg_trap_p : Genv.find_funct_ptr ge b_handle_id_sysreg_trap
                                           = Some (External (EF_external _handle_id_sysreg_trap
                                                            (signature_of_type (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default))
                                                  (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default).
    Local Opaque handle_id_sysreg_trap_spec.

    Variable b_handle_timer_sysreg_trap: block.
    Hypothesis h_handle_timer_sysreg_trap_s : Genv.find_symbol ge _handle_timer_sysreg_trap = Some b_handle_timer_sysreg_trap.
    Hypothesis h_handle_timer_sysreg_trap_p : Genv.find_funct_ptr ge b_handle_timer_sysreg_trap
                                              = Some (External (EF_external _handle_timer_sysreg_trap
                                                               (signature_of_type (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default))
                                                     (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default).
    Local Opaque handle_timer_sysreg_trap_spec.

    Variable b_handle_icc_el1_sysreg_trap: block.
    Hypothesis h_handle_icc_el1_sysreg_trap_s : Genv.find_symbol ge _handle_icc_el1_sysreg_trap = Some b_handle_icc_el1_sysreg_trap.
    Hypothesis h_handle_icc_el1_sysreg_trap_p : Genv.find_funct_ptr ge b_handle_icc_el1_sysreg_trap
                                                = Some (External (EF_external _handle_icc_el1_sysreg_trap
                                                                 (signature_of_type (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default))
                                                       (Tcons Tptr (Tcons tulong Tnil)) tvoid cc_default).
    Local Opaque handle_icc_el1_sysreg_trap_spec.

    Lemma handle_sysreg_access_trap_body_correct:
      forall m d d' env le rec_base rec_offset esr
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTrec: PTree.get _rec le = Some (Vptr rec_base (Int.repr rec_offset)))
             (HPTesr: PTree.get _esr le = Some (Vlong esr))
             (Hspec: handle_sysreg_access_trap_spec0 (rec_base, rec_offset) (VZ64 (Int64.unsigned esr)) d = Some d'),
           exists le', (exec_stmt ge env le ((m, d): mem) handle_sysreg_access_trap_body E0 le' (m, d') Out_normal).
    Proof.
      solve_code_proof Hspec handle_sysreg_access_trap_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.


Require Import Coq.Lists.List.
Require Import Coq.ZArith.BinInt.
Require Import coqutil.Map.Interface.
Require Import riscv.Utility.Monads.
Require Import riscv.Utility.Utility.
Require Import riscv.Spec.Decode.
Require Import riscv.Platform.Memory.
Require Import riscv.Spec.Machine.
Require Import riscv.Platform.RiscvMachine.
Require Import riscv.Utility.MkMachineWidth.

(* Note: Register 0 is not considered valid because it cannot be written *)
Definition valid_register(r: Register): Prop := (0 < r < 32)%Z.

Section Primitives.

  Context {width: Z} {BW: Bitwidth width} {word: word width} {word_ok: word.ok word}.
  Context {Registers: map.map Register word}.
  Context {mem: map.map word byte}.

  Context {M: Type -> Type}.
  Context {MM: Monad M}.

  Class PrimitivesParams(Machine: Type) := {
    (* Abstract predicate specifying when a monadic computation satisfies a
       postcondition when run on given initial machine *)
    mcomp_sat: forall {A: Type}, M A -> Machine -> (A -> Machine -> Prop) -> Prop;

    (* Tells whether the given value can be found in an uninitialized register.
       On instances supporting non-determinism, it returns True for all values.
       On instances without non-determinism, it only accepts a default value, eg 0 *)
    is_initial_register_value: word -> Prop;

    (* tells what happens if an n-byte read at a non-memory address is performed *)
    nonmem_load : forall (n: nat), SourceType -> word -> RiscvMachine -> (HList.tuple byte n -> RiscvMachine -> Prop) -> Prop;

    (* tells what happens if an n-byte write at a non-memory address is performed *)
    nonmem_store: forall (n: nat), SourceType -> word -> HList.tuple byte n -> RiscvMachine -> (RiscvMachine -> Prop) -> Prop;

    (* an invariant which is preserved by each primitive operation
       TODO it might also be useful to have invariants which are only preserved by whole
       instructions, such as eg the concrete nextPc = pc + 4 *)
    valid_machine: Machine -> Prop;
  }.

  Class mcomp_sat_spec{Machine: Type}(p: PrimitivesParams Machine): Prop := {
    spec_Bind{A B: Type}: forall (initialL: Machine) (post: B -> Machine -> Prop)
                                 (m: M A) (f : A -> M B),
        (exists mid: A -> Machine -> Prop,
            mcomp_sat m initialL mid /\
            (forall a middle, mid a middle -> mcomp_sat (f a) middle post)) <->
        mcomp_sat (Bind m f) initialL post;

    spec_Return{A: Type}: forall (initialL: Machine)
                                 (post: A -> Machine -> Prop) (a: A),
        post a initialL <->
        mcomp_sat (Return a) initialL post;
  }.

  (* monadic computations used for specifying the behavior of RiscvMachines should be "sane"
     in the sense that we never step to the empty set (that's not absence of failure, since
     failure is modeled as "steps to no set at all"), and that the trace of events is
     append-only, and that valid_machine is preserved *)
  Definition mcomp_sane{p: PrimitivesParams RiscvMachine}{A: Type}(comp: M A): Prop :=
    forall (st: RiscvMachine) (post: A -> RiscvMachine -> Prop),
      valid_machine st ->
      mcomp_sat comp st post ->
      (exists a st', post a st' /\ valid_machine st') /\
      (mcomp_sat comp st (fun a st' =>
         (post a st' /\ exists diff, st'.(getLog) = diff ++ st.(getLog)) /\ valid_machine st')).

  Context {RVM: RiscvProgram M word}.
  Context {RVS: @riscv.Spec.Machine.RiscvMachine M word _ _ RVM}.

  Class PrimitivesSane(p: PrimitivesParams RiscvMachine): Prop := {
    getRegister_sane: forall r, mcomp_sane (getRegister r);
    setRegister_sane: forall r v, mcomp_sane (setRegister r v);
    loadByte_sane: forall kind addr, mcomp_sane (loadByte kind addr);
    loadHalf_sane: forall kind addr, mcomp_sane (loadHalf kind addr);
    loadWord_sane: forall kind addr, mcomp_sane (loadWord kind addr);
    loadDouble_sane: forall kind addr, mcomp_sane (loadDouble kind addr);
    storeByte_sane: forall kind addr v, mcomp_sane (storeByte kind addr v);
    storeHalf_sane: forall kind addr v, mcomp_sane (storeHalf kind addr v);
    storeWord_sane: forall kind addr v, mcomp_sane (storeWord kind addr v);
    storeDouble_sane: forall kind addr v, mcomp_sane (storeDouble kind addr v);
    makeReservation_sane: forall addr, mcomp_sane (makeReservation addr);
    clearReservation_sane: forall addr, mcomp_sane (clearReservation addr);
    checkReservation_sane: forall addr, mcomp_sane (checkReservation addr);
    getCSRField_sane: forall f, mcomp_sane (getCSRField f);
    setCSRField_sane: forall f v, mcomp_sane (setCSRField f v);
    getPrivMode_sane: mcomp_sane getPrivMode;
    setPrivMode_sane: forall m, mcomp_sane (setPrivMode m);
    fence_sane: forall a b, mcomp_sane (fence a b);
    getPC_sane: mcomp_sane getPC;
    setPC_sane: forall newPc, mcomp_sane (setPC newPc);
    endCycleNormal_sane: mcomp_sane endCycleNormal;
    endCycleEarly_sane: forall A, mcomp_sane (@endCycleEarly _ _ _ _ _ A);
  }.

  Definition spec_load{p: PrimitivesParams RiscvMachine}(n: nat)
             (riscv_load: SourceType -> word -> M (HList.tuple byte n))
             (mem_load: mem -> word -> option (HList.tuple byte n))
    : Prop :=
    forall initialL addr (kind: SourceType) (post: HList.tuple byte n -> RiscvMachine -> Prop),
      (kind = Fetch -> isXAddr4 addr initialL.(getXAddrs)) /\
      ((exists v, mem_load initialL.(getMem) addr = Some v /\
                  post v initialL) \/
       (mem_load initialL.(getMem) addr = None /\
        nonmem_load n kind addr initialL post)) ->
      mcomp_sat (riscv_load kind addr) initialL post.

  (* After an address has been written, we make it non-executable, to make sure a processor
     with an instruction cache won't execute a stale instruction. *)
  Fixpoint invalidateWrittenXAddrs(nBytes: nat)(addr: word)(xAddrs: XAddrs): XAddrs :=
    match nBytes with
    | O => xAddrs
    | S n => removeXAddr addr (invalidateWrittenXAddrs n (word.add addr (word.of_Z 1)) xAddrs)
    end.

  Definition spec_store{p: PrimitivesParams RiscvMachine}(n: nat)
             (riscv_store: SourceType -> word -> HList.tuple byte n -> M unit)
             (mem_store: mem -> word -> HList.tuple byte n -> option mem)
             : Prop :=
    forall initialL addr v (kind: SourceType) (post: unit -> RiscvMachine -> Prop),
      (exists m', mem_store initialL.(getMem) addr v = Some m' /\
                  post tt (withXAddrs (invalidateWrittenXAddrs n addr initialL.(getXAddrs))
                          (withMem m' initialL))) \/
      (mem_store initialL.(getMem) addr v = None /\
       nonmem_store n kind addr v initialL (post tt)) ->
      mcomp_sat (riscv_store kind addr v) initialL post.

  (* primitives_params is a paramater rather than a field because Primitives lives in Prop and
     is opaque, but the fields of primitives_params need to be visible *)
  Class Primitives(primitives_params: PrimitivesParams RiscvMachine): Prop := {
    mcomp_sat_ok :> mcomp_sat_spec primitives_params;
    primitives_sane :> PrimitivesSane primitives_params;

    spec_getRegister: forall (initialL: RiscvMachine) (x: Register)
                             (post: word -> RiscvMachine -> Prop),
        (valid_register x /\
         match map.get initialL.(getRegs) x with
         | Some v => post v initialL
         | None => forall v, is_initial_register_value v -> post v initialL
         end) \/
        (x = Register0 /\ post (word.of_Z 0) initialL) ->
        mcomp_sat (getRegister x) initialL post;

    spec_setRegister: forall initialL x v (post: unit -> RiscvMachine -> Prop),
      (valid_register x /\ post tt (withRegs (map.put initialL.(getRegs) x v) initialL) \/
       x = Register0 /\ post tt initialL) ->
      mcomp_sat (setRegister x v) initialL post;

    spec_loadByte: spec_load 1 (Machine.loadByte (RiscvProgram := RVM)) Memory.loadByte;
    spec_loadHalf: spec_load 2 (Machine.loadHalf (RiscvProgram := RVM)) Memory.loadHalf;
    spec_loadWord: spec_load 4 (Machine.loadWord (RiscvProgram := RVM)) Memory.loadWord;
    spec_loadDouble: spec_load 8 (Machine.loadDouble (RiscvProgram := RVM)) Memory.loadDouble;

    spec_storeByte: spec_store 1 (Machine.storeByte (RiscvProgram := RVM)) Memory.storeByte;
    spec_storeHalf: spec_store 2 (Machine.storeHalf (RiscvProgram := RVM)) Memory.storeHalf;
    spec_storeWord: spec_store 4 (Machine.storeWord (RiscvProgram := RVM)) Memory.storeWord;
    spec_storeDouble: spec_store 8 (Machine.storeDouble (RiscvProgram := RVM)) Memory.storeDouble;

    spec_getPC: forall initialL (post: word -> RiscvMachine -> Prop),
        post initialL.(getPc) initialL ->
        mcomp_sat getPC initialL post;

    spec_setPC: forall initialL v (post: unit -> RiscvMachine -> Prop),
        post tt (withNextPc v initialL) ->
        mcomp_sat (setPC v) initialL post;

    spec_endCycleNormal: forall initialL (post: unit -> RiscvMachine -> Prop),
        post tt (withPc     initialL.(getNextPc)
                (withNextPc (word.add initialL.(getNextPc) (word.of_Z 4))
                            initialL)) ->
        mcomp_sat endCycleNormal initialL post;
  }.

End Primitives.

Arguments PrimitivesParams {_ _ _ _ _} M Machine.


(* Hendra : trim the system to contain only Arithmetic *)
  Import JVM_Dom JVM_Prog.

  Open Scope type_scope.
  Definition JVM_InitCallState :=  JVM_Method * (JVM_OperandStack.t * JVM_LocalVar.t).
  Definition JVM_IntraNormalState := JVM_PC * (JVM_Heap.t * JVM_OperandStack.t * JVM_LocalVar.t).
(* DEX  Definition JVM_IntraExceptionState := JVM_Heap.t * JVM_Location. *)
  Definition JVM_ReturnState := JVM_Heap.t * JVM_ReturnVal.

  Inductive JVM_NormalStep (p:JVM_Program) : JVM_Method -> JVM_IntraNormalState -> JVM_IntraNormalState  -> Prop :=
(* DEX
  | aconst_null : forall h m pc pc' s l,

    instructionAt m pc = Some (JVM_Aconst_null) ->
    next m pc = Some pc' ->

   JVM_NormalStep p m (pc,(h,s,l)) (pc',(h,(Null::s),l))

  | arraylength : forall h m pc pc' s l loc length tp a,

    instructionAt m pc = Some (JVM_Arraylength) ->
    next m pc = Some pc' ->
    JVM_Heap.typeof  h loc = Some (JVM_Heap.LocationArray length tp a) ->

   JVM_NormalStep p m  (pc,(h,(Ref loc::s),l)) (pc',(h,(Num (I length)::s),l))
*)
(*
 | checkcast1 : forall h m pc pc' s l val t,

    instructionAt m pc = Some (JVM_Checkcast t) ->
    next m pc = Some pc' ->
    assign_compatible p h val (JVM_ReferenceType t) ->

   JVM_NormalStep p m (pc,(h,(val::s),l))  (pc',(h,(val::s),l))
*)
  | const : forall h m pc pc' s l t z,

    instructionAt m pc = Some (JVM_Const t z) ->
    next m pc = Some pc' ->
    (   (t=JVM_BYTE /\ -2^7 <= z < 2^7)%Z
     \/ (t=JVM_SHORT /\ -2^15 <= z < 2^15)%Z
     \/ (t=JVM_INT /\ -2^31 <= z < 2^31)%Z   ) ->

   JVM_NormalStep p m (pc,(h,s,l)) (pc',(h,(Num (I (Int.const z))::s),l))

  | dup : forall h m pc pc' s l v,

    instructionAt m pc = Some (JVM_Dup) ->
    next m pc = Some pc' ->

   JVM_NormalStep p m (pc,(h,(v::s),l))  (pc',(h,(v::v::s),l))

  | dup_x1 : forall h m pc pc' s l v1 v2,

    instructionAt m pc = Some JVM_Dup_x1 ->
    next m pc = Some pc' ->

   JVM_NormalStep p m (pc,(h,(v1::v2::s),l)) (pc',(h,(v1::v2::v1::s),l))

  | dup_x2 : forall h m pc pc' s l v1 v2 v3,

    instructionAt m pc = Some JVM_Dup_x2 ->
    next m pc = Some pc' ->

   JVM_NormalStep p  m (pc,(h,(v1::v2::v3::s),l))  (pc',(h,(v1::v2::v3::v1::s),l))

  | dup2 : forall h m pc pc' s l v1 v2,

    instructionAt m pc = Some JVM_Dup2 ->
    next m pc = Some pc' ->

   JVM_NormalStep p m (pc,(h,(v1::v2::s),l)) (pc',(h,(v1::v2::v1::v2::s),l))

  | dup2_x1 : forall h m pc pc' s l v1 v2 v3,

    instructionAt m pc = Some JVM_Dup2_x1 ->
    next m pc = Some pc' ->

   JVM_NormalStep p m (pc,(h,(v1::v2::v3::s),l)) (pc',(h,(v1::v2::v3::v1::v2::s),l))

  | dup2_x2 : forall h m pc pc' s l v1 v2 v3 v4,

    instructionAt m pc = Some JVM_Dup2_x2 ->
    next m pc = Some pc' ->

   JVM_NormalStep p m (pc,(h,(v1::v2::v3::v4::s),l)) (pc',(h,(v1::v2::v3::v4::v1::v2::s),l))
(* DEX
  | getfield : forall h m pc pc' s l loc f v cn,

    instructionAt m pc = Some (JVM_Getfield f) ->
    next m pc = Some pc' ->
    JVM_Heap.typeof h loc = Some (JVM_Heap.LocationObject cn) ->
    defined_field p cn f ->
    JVM_Heap.get h (JVM_Heap.DynamicField loc f) = Some v ->

   JVM_NormalStep p m (pc,(h,(Ref loc::s),l)) (pc',(h,(v::s),l))
*)

  | goto : forall h m pc s l o,

    instructionAt m pc = Some (JVM_Goto o) ->

   JVM_NormalStep p m (pc,(h,s,l)) (JVM_OFFSET.jump pc o,(h,s,l))

  | i2b : forall h m pc pc' s l i,

    instructionAt m pc = Some JVM_I2b ->
    next m pc = Some pc' ->

   JVM_NormalStep p m (pc,(h,(Num (I i)::s),l)) (pc',(h,(Num (I (b2i (i2b i)))::s),l))

  | i2s : forall h m pc pc' s l i,

    instructionAt m pc = Some JVM_I2s ->
    next m pc = Some pc' ->

   JVM_NormalStep p m (pc,(h,(Num (I i)::s),l))  (pc',(h,(Num (I (s2i (i2s i)))::s),l))

  | ibinop : forall h m pc pc' s l op i1 i2,

    instructionAt m pc = Some (JVM_Ibinop op) ->
    next m pc = Some pc' ->
    (* DEX (op = DivInt \/ op = RemInt -> ~ Int.toZ i2 = 0%Z) -> *)

   JVM_NormalStep p m (pc,(h,(Num (I i2)::Num (I i1)::s),l))
                          (pc',(h,(Num (I (SemBinopInt op i1 i2))::s),l))

(* DEX
  | if_acmp_step_jump : forall h m pc s l val2 val1 o cmp,
      instructionAt m pc = Some (JVM_If_acmp cmp o) ->
      SemCompRef cmp val1 val2 ->
  (******************************************************************)
     JVM_NormalStep p m (pc,(h,(val2:: val1::s),l))
                                   (JVM_OFFSET.jump pc o,(h,s,l))

  | if_acmp_step_continue : forall h m pc pc' s l val2 val1 o cmp,
      instructionAt m pc = Some (JVM_If_acmp cmp o) ->
      next m pc = Some pc' ->
      ~ SemCompRef cmp val1 val2 ->
  (******************************************************************)
    JVM_NormalStep p m (pc,(h,(val2::val1::s),l)) (pc',(h,s,l))
*)

  | if_icmp_step_jump : forall h m pc s l cmp i2 i1 o,
      instructionAt m pc = Some (JVM_If_icmp cmp o) ->
      SemCompInt cmp (Int.toZ i1) (Int.toZ i2) ->
  (******************************************************************)
    JVM_NormalStep p m (pc,(h,(Num(I i2)::Num(I i1)::s),l))
                                  (JVM_OFFSET.jump pc o,(h,s,l))

  | if_icmpeq_step_continue : forall h m pc pc' s l cmp i2 i1 o,
      instructionAt m pc = Some (JVM_If_icmp cmp o) ->
      next m pc = Some pc' ->
      ~ SemCompInt cmp (Int.toZ i1) (Int.toZ i2) ->
  (******************************************************************)
    JVM_NormalStep p m (pc,(h,(Num(I i2)::Num(I i1)::s),l))
                                  (pc',(h,s,l))

  | ifeq_step_jump : forall h m pc s l cmp i o,
      instructionAt m pc = Some (JVM_If0 cmp o) ->
      SemCompInt cmp (Int.toZ i) 0 ->
  (******************************************************************)
    JVM_NormalStep p m (pc,(h,(Num(I i)::s),l))
                                  (JVM_OFFSET.jump pc o,(h,s,l))

  | ifeq_step_continue : forall h m pc pc' s l cmp i o,
      instructionAt m pc = Some (JVM_If0 cmp o) ->
      next m pc = Some pc' ->
      ~ SemCompInt cmp (Int.toZ i) 0 ->
  (******************************************************************)
    JVM_NormalStep p m (pc,(h,(Num(I i)::s),l)) (pc',(h,s,l))
(* DEX
  | ifnull_step_jump : forall h m pc s l loc o cmp,
      instructionAt m pc = Some (JVM_Ifnull cmp o) ->
      SemCompRef cmp loc Null ->
  (******************************************************************)
    JVM_NormalStep p m (pc,(h,(loc::s),l))
                                  (JVM_OFFSET.jump pc o,(h,s,l))

  | ifnull_step_continue : forall h m pc pc' s l o loc cmp,
    instructionAt m pc = Some (JVM_Ifnull cmp o) ->
    next m pc = Some pc' ->
    ~ SemCompRef cmp loc Null ->
  (******************************************************************)
    JVM_NormalStep p m (pc,(h,(loc::s),l)) (pc',(h,s,l))
*)

  | iinc_step : forall h m pc s l pc' x z i,
    instructionAt m pc = Some (JVM_Iinc x z) ->

    next m pc = Some pc' ->
    (-2^7 <= z < 2^7)%Z ->
    JVM_METHOD.valid_var m x ->
    JVM_LocalVar.get l x = Some (Num (I i)) ->

   JVM_NormalStep p m (pc,(h,s,l))
                (pc',(h,s,(JVM_LocalVar.update l x (Num (I (Int.add i (Int.const z)))))))

  | ineg_step : forall h m pc s l pc' i,
    instructionAt m pc = Some JVM_Ineg ->
    next m pc = Some pc' ->

   JVM_NormalStep p m (pc,(h,(Num (I i)::s),l)) (pc',(h,(Num (I (Int.neg i))::s),l))

(* DEX
  | instanceof1 : forall h m pc pc' s l loc t,

    instructionAt m pc = Some (JVM_Instanceof t) ->
    next m pc = Some pc' ->
    assign_compatible p h (Ref loc) (JVM_ReferenceType t) ->

   JVM_NormalStep p m (pc,(h,(Ref loc::s),l)) (pc',(h,(Num (I (Int.const 1))::s),l))

  | instanceof2 : forall h m pc pc' s l t v,

    instructionAt m pc = Some (JVM_Instanceof t) ->
    next m pc = Some pc' ->
    isReference v ->
    (~ assign_compatible p h v (JVM_ReferenceType t) \/ v=Null) ->

   JVM_NormalStep p m (pc,(h,(v::s),l)) (pc',(h,(Num (I (Int.const 0))::s),l))
*)

  | lookupswitch1 : forall h m pc s l def listkey i i' o',

    instructionAt m pc = Some (JVM_Lookupswitch def listkey) ->

    List.In (pair i' o')listkey ->
    i' = Int.toZ i ->

   JVM_NormalStep p m (pc,(h,(Num (I i)::s),l)) (JVM_OFFSET.jump pc o',(h,s,l))

  | lookupswitch2 : forall h m pc s l def listkey i,

    instructionAt m pc = Some (JVM_Lookupswitch def listkey) ->
    (forall i' o', List.In (pair i' o')listkey ->  i' <> Int.toZ i) ->

   JVM_NormalStep p m (pc,(h,(Num (I i)::s),l)) (JVM_OFFSET.jump pc def,(h,s,l))
(* DEX
  | new : forall h m pc pc' s l c loc h',

    instructionAt m pc = Some (JVM_New c) ->
    next m pc = Some pc' ->
    JVM_Heap.new h p (JVM_Heap.LocationObject c) = Some (pair loc h') ->

   JVM_NormalStep p m (pc,(h,s,l))
                      (pc',(h',(Ref loc::s),l))

  | newarray : forall h m pc pc' s l t i loc h',

    instructionAt m pc = Some (JVM_Newarray t) ->
    next m pc = Some pc' ->
    (0 <= Int.toZ i)%Z ->
    JVM_Heap.new h p (JVM_Heap.LocationArray i t (m,pc)) = Some (pair loc h') ->

   JVM_NormalStep p m (pc,(h,(Num (I i)::s),l))
                            (pc',(h',(Ref loc::s),l))
*)
  | nop : forall h m pc pc' s l,

    instructionAt m pc = Some JVM_Nop ->
    next m pc = Some pc' ->

   JVM_NormalStep p m (pc,(h,s,l)) (pc',(h,s,l))

  | pop : forall h m pc pc' s l v,

    instructionAt m pc = Some JVM_Pop ->
    next m pc = Some pc' ->

   JVM_NormalStep p m (pc,(h,(v::s),l)) (pc',(h,s,l))

  | pop2 : forall h m pc pc' s l v1 v2,

    instructionAt m pc = Some JVM_Pop2 ->
    next m pc = Some pc' ->

   JVM_NormalStep p m (pc,(h,(v1::v2::s),l)) (pc',(h,s,l))
(* DEX
  | putfield : forall h m pc pc' s l f loc cn v,

    instructionAt m pc = Some (JVM_Putfield f) ->
    next m pc = Some pc' ->
    JVM_Heap.typeof h loc = Some (JVM_Heap.LocationObject cn) ->
    defined_field p cn f ->
    assign_compatible p h v (JVM_FIELDSIGNATURE.type (snd f)) ->

   JVM_NormalStep p m(pc,(h,(v::(Ref loc)::s),l))
                           (pc',(JVM_Heap.update h (JVM_Heap.DynamicField loc f) v,s,l))
*)
  | swap : forall h m pc pc' s l v1 v2,

    instructionAt m pc = Some JVM_Swap ->
    next m pc = Some pc' ->

   JVM_NormalStep p m (pc,(h,(v1::v2::s),l)) (pc',(h,(v2::v1::s),l))

  | tableswitch1 : forall h m pc s l i def low high list_offset,

    instructionAt m pc = Some (JVM_Tableswitch def low high list_offset) ->
    Z_of_nat (length list_offset) = (high - low + 1)%Z ->
    (Int.toZ i < low \/ high < Int.toZ i)%Z ->

   JVM_NormalStep p m (pc,(h,(Num (I i)::s),l)) (JVM_OFFSET.jump pc def,(h,s,l))

  | tableswitch2 : forall h m pc s l n o i def low high list_offset,

    instructionAt m pc = Some (JVM_Tableswitch def low high list_offset) ->
    Z_of_nat (length list_offset) = (high - low + 1)%Z ->
    (low <= Int.toZ i <= high)%Z ->
    (Z_of_nat n = (Int.toZ i) - low)%Z ->
    nth_error list_offset n = Some o ->

   JVM_NormalStep p m (pc,(h,(Num (I i)::s),l)) (JVM_OFFSET.jump pc o,(h,s,l))
(*
  | vaload : forall h m pc pc' s l loc val i length t k a,

    instructionAt m pc = Some (JVM_Vaload k) ->
    next m pc = Some pc' ->
    JVM_Heap.typeof h loc = Some (JVM_Heap.LocationArray length t a) ->
    compat_ArrayKind_type k t ->
    (0 <= Int.toZ i < Int.toZ length)%Z ->
    JVM_Heap.get h (JVM_Heap.ArrayElement loc (Int.toZ i)) = Some val ->
    compat_ArrayKind_value k val ->

    JVM_NormalStep p m
          (pc,(h,((Num (I i))::(Ref loc)::s),l))
          (pc',(h,(conv_for_stack val::s),l))

  | vastore : forall h m pc pc' s l loc val i length t k a,

    instructionAt m pc = Some (JVM_Vastore k) ->
    next m pc = Some pc' ->
    JVM_Heap.typeof h loc = Some (JVM_Heap.LocationArray length t a) ->
    assign_compatible p h val t ->
    (0 <= Int.toZ i < Int.toZ length)%Z ->
    compat_ArrayKind_type k t ->
    compat_ArrayKind_value k val ->

    JVM_NormalStep p m
         (pc,(h,(val::(Num (I i))::(Ref loc)::s),l))
         (pc',(JVM_Heap.update h (JVM_Heap.ArrayElement loc (Int.toZ i)) (conv_for_array val t),s,l))
*)
  | vload : forall h m pc pc' s l x val k,

    instructionAt m pc = Some (JVM_Vload k x) ->
    next m pc = Some pc' ->
    JVM_METHOD.valid_var m x ->
    JVM_LocalVar.get l x = Some val ->
    compat_ValKind_value k val ->

    JVM_NormalStep p m (pc,(h,s,l)) (pc',(h,(val::s),l))

  | vstore : forall h m pc pc' s l l' x v k,

    instructionAt m pc = Some (JVM_Vstore k x) ->
    next m pc = Some pc' ->
    JVM_METHOD.valid_var m x ->
    l' = JVM_LocalVar.update l x v ->
    compat_ValKind_value k v ->

   JVM_NormalStep p m  (pc,(h,(v::s),l)) (pc',(h,s,l'))
.

(* DEX Exception
  Inductive JVMExceptionStep  (p:Program) : Method -> IntraNormalState -> ShortClassName -> Prop :=
  | arraylength_NullPointerException : forall h m pc s l,

    instructionAt m pc = Some Arraylength ->

    JVMExceptionStep p m (pc,(h,(Null::s),l))  NullPointerException

  | athrow_NullPointerException : forall h m pc s l,

    instructionAt m pc = Some Athrow ->

    JVMExceptionStep p m (pc,(h,(Null::s),l)) NullPointerException

  | checkcast_ClassCastException : forall h m pc s l loc t,

    instructionAt m pc = Some (Checkcast t) ->
    ~ assign_compatible p h (Ref loc) (ReferenceType t) ->

    JVMExceptionStep p m (pc,(h,(Ref loc::s),l)) ClassCastException

  | getfield_NullPointerException : forall h m pc s l f ,

    instructionAt m pc = Some (Getfield f) ->

    JVMExceptionStep p m (pc,(h,(Null::s),l)) NullPointerException

 | ibinop_ArithmeticException : forall h m pc s l op i1 i2,

    instructionAt m pc = Some (Ibinop op) ->
    op = DivInt \/ op = RemInt ->
    Int.toZ i2 = 0%Z ->

    JVMExceptionStep p m (pc,(h,(Num (I i2)::Num (I i1)::s),l)) ArithmeticException

  | invokevirtual_NullPointerException : forall h m pc s l mid args,

    instructionAt m pc = Some (Invokevirtual mid) ->
    length args = length (METHODSIGNATURE.parameters (snd mid)) ->

    JVMExceptionStep p m (pc,(h,(args++Null::s),l)) NullPointerException

  | newarray_NegativeArraySizeException : forall h m pc s l t i,

    instructionAt m pc = Some (Newarray t) ->
    (~ 0 <= Int.toZ i)%Z ->

    JVMExceptionStep p m (pc,(h,(Num (I i)::s),l)) NegativeArraySizeException

  | putfield_NullPointerException : forall h m pc s l f v,

    instructionAt m pc = Some (Putfield f) ->

    JVMExceptionStep p m (pc,(h,(v::Null::s),l)) NullPointerException

  | vaload_NullPointerException : forall h m pc s l i k,

    instructionAt m pc = Some (Vaload k) ->

    JVMExceptionStep p m (pc,(h,((Num (I i))::Null::s),l)) NullPointerException

  | vaload_ArrayIndexOutOfBoundsException : forall h m pc s l loc i length t k a,

    instructionAt m pc = Some (Vaload k) ->
    Heap.typeof h loc = Some (Heap.LocationArray length t a) ->
    compat_ArrayKind_type k t ->
    (~ 0 <= Int.toZ i < Int.toZ length)%Z ->

    JVMExceptionStep p m (pc,(h,((Num (I i))::(Ref loc)::s),l)) ArrayIndexOutOfBoundsException

  | vastore_NullPointerException : forall h m pc s l val i k,

    instructionAt m pc = Some (Vastore k) ->
    compat_ArrayKind_value k val ->

    JVMExceptionStep p m (pc,(h,(val::(Num (I i))::Null::s),l)) NullPointerException

  | vastore_ArrayIndexOutOfBoundsException : forall h m pc s l loc val i t length k a,

    instructionAt m pc = Some (Vastore k) ->
    Heap.typeof h loc = Some (Heap.LocationArray length t a) ->
    (~ 0 <= Int.toZ i < Int.toZ length)%Z ->
    compat_ArrayKind_type k t ->
    compat_ArrayKind_value k val ->

    JVMExceptionStep p m (pc,(h,(val::(Num (I i))::(Ref loc)::s),l)) ArrayIndexOutOfBoundsException

  | vastore_ArrayStoreException : forall h m pc s l loc val i t k length a,

    instructionAt m pc = Some (Vastore k) ->
    Heap.typeof h loc = Some (Heap.LocationArray length t a) ->
    ~ assign_compatible p h val t ->
    (0 <= Int.toZ i < Int.toZ length)%Z ->
    compat_ArrayKind_type k t ->
    compat_ArrayKind_value k val ->

    JVMExceptionStep p m (pc,(h,(val::(Num (I i))::(Ref loc)::s),l)) ArrayStoreException
.

  Inductive ExceptionStep (p:Program) : Method -> IntraNormalState -> IntraExceptionState -> Prop :=
  | athrow : forall h m pc s l loc cn,

    instructionAt m pc = Some Athrow ->
    Heap.typeof h loc = Some (Heap.LocationObject cn) ->
    subclass_name p cn javaLangThrowable ->
    ExceptionStep p m (pc,(h,(Ref loc::s),l)) (h,loc)

  | jvm_exception : forall h m pc s l h' loc (e:ShortClassName),

    JVMExceptionStep p m (pc,(h,s,l)) e ->
    Heap.new h p (Heap.LocationObject (javaLang,e)) = Some (loc,h') ->

    ExceptionStep p m (pc,(h,s,l)) (h',loc).
*)

(* DEX Method
  Inductive JVM_CallStep (p:JVM_Program) : JVM_Method -> JVM_IntraNormalState -> JVM_InitCallState -> Prop :=
  | invokestatic : forall h m pc s l mid M args bM,

    instructionAt m pc = Some (JVM_Invokestatic mid) ->
    findMethod p mid = Some M ->
    JVM_METHOD.isNative M = false ->
    length args = length (JVM_METHODSIGNATURE.parameters (snd mid)) ->
    JVM_METHOD.body M = Some bM ->
    JVM_METHOD.isStatic M = true ->

    JVM_CallStep p m (pc,(h,(args++s),l)) (M,(s,(stack2localvar (args++s) (length args))))

  | invokevirtual : forall h m pc s l mid cn M args loc cl bM,

    instructionAt m pc = Some (JVM_Invokevirtual (cn,mid)) ->
    lookup p cn mid (pair cl M) ->
    JVM_Heap.typeof h loc = Some (JVM_Heap.LocationObject cn) ->
    length args = length (JVM_METHODSIGNATURE.parameters mid) ->
    JVM_METHOD.body M = Some bM ->
    JVM_METHOD.isStatic M = false ->

    JVM_CallStep p m (pc,(h,(args++(Ref loc)::s),l)) (M,(s,stack2localvar (args++(Ref loc)::s)  (1+(length args)))).
*)

  Inductive JVM_ReturnStep (p:JVM_Program) : JVM_Method -> JVM_IntraNormalState -> JVM_ReturnState -> Prop :=
  | void_return : forall h m pc s l,

    instructionAt m pc = Some JVM_Return ->
    JVM_METHODSIGNATURE.result (JVM_METHOD.signature m) = None ->

    JVM_ReturnStep p m  (pc,(h,s,l)) (h, Normal None)
  | vreturn : forall h m pc s l val t k,

    instructionAt m pc = Some (JVM_Vreturn k) ->
    JVM_METHODSIGNATURE.result (JVM_METHOD.signature m) = Some t ->
    assign_compatible p h val t ->
    compat_ValKind_value k val ->

    JVM_ReturnStep p m (pc,(h,(val::s),l)) (h,Normal (Some val))
.

(* DEX Method
  Inductive JVM_call_and_return :
    JVM_Method -> JVM_IntraNormalState -> JVM_InitCallState -> JVM_IntraNormalState -> JVM_ReturnState -> JVM_IntraNormalState -> Prop :=
  | call_and_return_void : forall m pc h s l m' l' bm' h'' s' pc',
      next m pc = Some pc' ->
      JVM_METHOD.body m' = Some bm' ->
      JVM_call_and_return
                 m
                 (pc,(h,s,l))
                 (m',(s',l'))
                  (JVM_BYTECODEMETHOD.firstAddress bm',(h,JVM_OperandStack.empty,l'))
                 (h'', Normal None)
                 (pc',(h'',s',l))
  | call_and_return_value : forall m pc h s l m' l' bm' h'' v s' pc',
      next m pc = Some pc' ->
      JVM_METHOD.body m' = Some bm' ->
      JVM_call_and_return
                 m
                 (pc,(h,s,l))
                 (m',(s',l') )
                 (JVM_BYTECODEMETHOD.firstAddress bm',(h,JVM_OperandStack.empty,l'))
                 (h'', Normal (Some v))
                 (pc',(h'',v::s',l)).
*)

(* DEX Exception
  Inductive call_and_return_exception : Method -> IntraNormalState -> InitCallState -> IntraNormalState -> ReturnState -> IntraExceptionState -> Prop :=
  | call_and_return_exception_def : forall m pc h s l m' l' bm' h'' s' loc,
      METHOD.body m' = Some bm' ->
      call_and_return_exception
                 m
                 (pc,(h,s,l))
                 (m',(s',l'))
                 (BYTECODEMETHOD.firstAddress bm',(h,OperandStack.empty,l'))
                 (h'',Exception loc)
                 (h'',loc).
*)
  Inductive JVM_exec_intra (p:JVM_Program) (m:JVM_Method) : JVM_IntraNormalState -> JVM_IntraNormalState -> Prop :=
  | exec_intra_normal : forall s1 s2,
     JVM_NormalStep p m s1 s2 ->
     JVM_exec_intra p m s1 s2
(* DEX Exception
  | exec_exception : forall pc1 h1 h2 loc2 s1 l1 pc',
   ExceptionStep p m (pc1,(h1,s1,l1)) (h2,loc2) ->
   CaughtException p m (pc1,h2,loc2) pc' ->
   exec_intra p m (pc1,(h1,s1,l1)) (pc',(h2,Ref loc2::OperandStack.empty,l1))*).

  Inductive JVM_exec_return (p:JVM_Program) (m:JVM_Method) : JVM_IntraNormalState -> JVM_ReturnState -> Prop :=
  | exec_return_normal : forall s h ov,
     JVM_ReturnStep p m s (h,Normal ov) ->
     JVM_exec_return p m s (h,Normal ov)
(* DEX Exception
 | exec_return_exception : forall pc1 h1 h2 loc2 s1 l1,
     ExceptionStep p m (pc1,(h1,s1,l1)) (h2,loc2) ->
     UnCaughtException  p m (pc1,h2,loc2) ->
     exec_return p m (pc1,(h1,s1,l1)) (h2,Exception loc2)
*).

(* Method
  Inductive JVM_exec_call (p:JVM_Program) (m:JVM_Method) :
   JVM_IntraNormalState -> JVM_ReturnState -> JVM_Method  -> JVM_IntraNormalState -> JVM_IntraNormalState+JVM_ReturnState -> Prop :=
 | exec_call_normal : forall m2 pc1 pc1' h1 s1 l1 os l2 h2 bm2 ov,
     JVM_CallStep p m (pc1,(h1,s1,l1 )) (m2,(os,l2)) ->
     JVM_METHOD.body m2 = Some bm2 ->
     next m pc1 = Some pc1' ->
     JVM_exec_call p m
        (pc1,(h1,s1,l1))
        (h2,Normal ov)
        m2
        (JVM_BYTECODEMETHOD.firstAddress bm2,(h1,JVM_OperandStack.empty,l2))
        (inl _ (pc1',(h2,cons_option ov os,l1)))
(* DEX Exception
 | exec_call_caught : forall m2 pc1 pc1' h1 s1 l1 os l2 h2 loc bm2,
     CallStep p m (pc1,(h1,s1,l1 )) (m2,(os,l2)) ->
     METHOD.body m2 = Some bm2 ->
     CaughtException p m (pc1, h2, loc) pc1' ->
     exec_call p m
        (pc1,(h1,s1,l1))
        (h2,Exception loc)
        m2
        (BYTECODEMETHOD.firstAddress bm2,(h1,OperandStack.empty,l2))
        (inl _(pc1',(h2,Ref loc::nil,l1)))
 | exec_call_uncaught : forall m2 pc1 h1 s1 l1 os l2 h2 loc bm2,
     CallStep p m (pc1,(h1,s1,l1 )) (m2,(os,l2)) ->
     METHOD.body m2 = Some bm2 ->
     UnCaughtException p m (pc1, h2, loc)  ->
     exec_call p m
       (pc1,(h1,s1,l1))
       (h2,Exception loc)
       m2
       (BYTECODEMETHOD.firstAddress bm2,(h1,OperandStack.empty,l2))
       (inr _ (h2,Exception loc))*) .
*)

 Inductive JVM_IntraStep (p:JVM_Program) :
    JVM_Method -> JVM_IntraNormalState -> JVM_IntraNormalState + JVM_ReturnState -> Prop :=
  | IntraStep_res :forall m s ret,
     JVM_exec_return p m s ret ->
     JVM_IntraStep p m s (inr _ ret)
  | IntraStep_intra_step:forall m s1 s2,
     JVM_exec_intra p m s1 s2 ->
     JVM_IntraStep p m s1 (inl _ s2)
(* DEX Method
  | IntraStep_call :forall m m' s1 s' ret' r,
     JVM_exec_call p m s1 ret' m' s' r ->
     TransStep_l (JVM_IntraStep p m') s' (inr _ ret') ->
     JVM_IntraStep p m s1 r*).

 Definition JVM_IntraStepStar p m s r := TransStep_l (JVM_IntraStep p m) s r.

 Definition JVM_IntraStepStar_intra p m s s' := JVM_IntraStepStar p m s (inl _ s').

 Definition JVM_BigStep  p m s ret := JVM_IntraStepStar p m s (inr _ ret).

 Inductive JVM_ReachableStep (P:JVM_Program) :
      (JVM_Method*JVM_IntraNormalState)->(JVM_Method*JVM_IntraNormalState) ->Prop :=
   | ReachableIntra : forall M s s',
       JVM_IntraStep P M s (inl _ s') ->
       JVM_ReachableStep P (M,s) (M,s')
(* DEX Method
   | Reachable_invS : forall M pc h os l M' os' l' bm',
       JVM_CallStep P M (pc,(h,os,l)) (M',(os',l')) ->
       JVM_METHOD.body M' = Some bm' ->
       JVM_ReachableStep P (M, (pc,(h,os,l)))
         (M', (JVM_BYTECODEMETHOD.firstAddress bm',(h,JVM_OperandStack.empty,l')))*).

 Definition JVM_Reachable P M s s' :=
   exists M',  ClosReflTrans (JVM_ReachableStep P) (M,s) (M',s').