From iris.algebra Require Import frac.
From iris.proofmode Require Import tactics.
From iris.base_logic Require Import invariants.
Require Import Eqdep_dec List.
From cap_machine Require Import rules logrel.
From cap_machine Require Export addr_reg_sample region_macros contiguous stack_macros_helpers malloc fetch
     awkward_example_helpers.
From cap_machine.rules Require Import rules_StoreU_derived rules_LoadU_derived.

Section stack_macros.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          {stsg : STSG Addr region_type Σ} {heapg : heapG Σ}
          {nainv: logrel_na_invs Σ}
          `{MP: MachineParameters}.

  (* --------------------------------------------------------------------------------- *)
  (* ------------------------------------- MALLOC ------------------------------------ *)
  (* --------------------------------------------------------------------------------- *)

  (* malloc stores the result in r_t1, rather than a user chosen destination.
     f_m is the offset of the malloc capability *)
  Definition malloc_instrs f_m size :=
    fetch_instrs f_m ++
    [move_r r_t5 r_t0;
    move_r r_t3 r_t1;
    move_z r_t1 size;
    move_r r_t0 PC;
    lea_z r_t0 3;
    jmp r_t3;
    move_r r_t0 r_t5;
    move_z r_t5 0].

  Definition malloc f_m size a : iProp Σ :=
    ([∗ list] a_i;w_i ∈ a;(malloc_instrs f_m size), a_i ↦ₐ w_i)%I.

  (* malloc spec *)
  Lemma malloc_spec W size cont a pc_p pc_g pc_b pc_e a_first a_last
        b_link e_link a_link f_m a_entry mallocN b_m e_m EN rmap φ :
    isCorrectPC_range pc_p pc_g pc_b pc_e a_first a_last →
    contiguous_between a a_first a_last →
    withinBounds (RW, Global, b_link, e_link, a_entry) = true →
    (a_link + f_m)%a = Some a_entry →
    dom (gset RegName) rmap = all_registers_s ∖ {[ PC; r_t0 ]} →
    ↑mallocN ⊆ EN →
    size > 0 →

    (* malloc program and subroutine *)
    ▷ malloc f_m size a
    ∗ na_inv logrel_nais mallocN (malloc_inv b_m e_m)
    ∗ na_own logrel_nais EN
    (* we need to assume that the malloc capability is in the linking table at offset f_m *)
    ∗ ▷ pc_b ↦ₐ inr (RO,Global,b_link,e_link,a_link)
    ∗ ▷ a_entry ↦ₐ inr (E,Global,b_m,e_m,b_m)
    (* register state *)
    ∗ ▷ PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,a_first)
    ∗ ▷ r_t0 ↦ᵣ cont
    ∗ ▷ ([∗ map] r_i↦w_i ∈ rmap, r_i ↦ᵣ w_i)
    (* current world *)
    ∗ ▷ region W
    ∗ ▷ sts_full_world W
    (* continuation *)
    ∗ ▷ (PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,a_last) ∗ malloc f_m size a
         ∗ pc_b ↦ₐ inr (RO,Global,b_link,e_link,a_link)
         ∗ a_entry ↦ₐ inr (E,Global,b_m,e_m,b_m)
         (* the newly allocated region *)
         ∗ (∃ (b e : Addr),
            ⌜(b + size)%a = Some e⌝
            ∗ r_t1 ↦ᵣ inr (RWX,Global,b,e,b)
            ∗ [[b,e]] ↦ₐ [[region_addrs_zeroes b e]])
         ∗ r_t0 ↦ᵣ cont
         ∗ na_own logrel_nais EN
         ∗ ([∗ map] r_i↦w_i ∈ (<[r_t2:=inl 0%Z]>
                               (<[r_t3:=inl 0%Z]>
                                (<[r_t4:=inl 0%Z]>
                                 (<[r_t5:=inl 0%Z]> (delete r_t1 rmap))))), r_i ↦ᵣ w_i)
         (* the newly allocated region is fresh in the current world *)
         (* ∗ ⌜Forall (λ a, a ∉ dom (gset Addr) (std W)) (region_addrs b e)⌝ *)
         ∗ region W
         ∗ sts_full_world W
         -∗ WP Seq (Instr Executable) {{ φ }})
    ⊢
      WP Seq (Instr Executable) {{ λ v, φ v ∨ ⌜v = FailedV⌝ }}.
  Proof.
    iIntros (Hvpc Hcont Hwb Ha_entry Hrmap_dom HmallocN Hsize)
            "(>Hprog & #Hmalloc & Hna & >Hpc_b & >Ha_entry & >HPC & >Hr_t0 & >Hregs & Hr & Hsts & Hφ)".
    (* extract necessary registers from regs *)
    iDestruct (big_sepL2_length with "Hprog") as %Hlength.
    assert (is_Some (rmap !! r_t1)) as [rv1 ?]. by rewrite elem_of_gmap_dom Hrmap_dom; set_solver.
    iDestruct (big_sepM_delete _ _ r_t1 with "Hregs") as "[Hr_t1 Hregs]"; eauto.
    assert (is_Some (rmap !! r_t2)) as [rv2 ?]. by rewrite elem_of_gmap_dom Hrmap_dom; set_solver.
    iDestruct (big_sepM_delete _ _ r_t2 with "Hregs") as "[Hr_t2 Hregs]". by rewrite lookup_delete_ne //.
    assert (is_Some (rmap !! r_t3)) as [rv3 ?]. by rewrite elem_of_gmap_dom Hrmap_dom; set_solver.
    iDestruct (big_sepM_delete _ _ r_t3 with "Hregs") as "[Hr_t3 Hregs]". by rewrite !lookup_delete_ne //.
    assert (is_Some (rmap !! r_t5)) as [rv5 ?]. by rewrite elem_of_gmap_dom Hrmap_dom; set_solver.
    iDestruct (big_sepM_delete _ _ r_t5 with "Hregs") as "[Hr_t5 Hregs]". by rewrite !lookup_delete_ne //.
    destruct a as [|a l];[inversion Hlength|].
    apply contiguous_between_cons_inv_first in Hcont as Heq. subst.
    (* fetch f *)
    iDestruct (contiguous_between_program_split with "Hprog") as (fetch_prog rest link)
                                                                   "(Hfetch & Hprog & #Hcont)";[apply Hcont|].
    iDestruct "Hcont" as %(Hcont_fetch & Hcont_rest & Heqapp & Hlink).
    iApply (fetch_spec with "[- $HPC $Hfetch $Hr_t1 $Hr_t2 $Hr_t3 $Ha_entry $Hpc_b]");
      [|apply Hcont_fetch|apply Hwb|apply Ha_entry|].
    { intros mid Hmid. apply isCorrectPC_inrange with a_first a_last; auto.
      apply contiguous_between_bounds in Hcont_rest. revert Hcont_rest Hmid; clear. solve_addr. }
    iNext. iIntros "(HPC & Hfetch& Hr_t1 & Hr_t2 & Hr_t3 & Hpc_b & Ha_entry)".
    iDestruct (big_sepL2_length with "Hprog") as %Hlength_rest.
    assert (isCorrectPC_range pc_p pc_g pc_b pc_e link a_last) as Hvpc_rest.
    { intros mid Hmid. apply isCorrectPC_inrange with a_first a_last; auto. revert Hmid Hlink;clear. solve_addr. }
    destruct rest as [|a l'];[inversion Hlength_rest|].
    apply contiguous_between_cons_inv_first in Hcont_rest as Heq. subst.
    (* move r_t5 r_t0 *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iApply (wp_move_success_reg with "[$HPC $Hi $Hr_t5 $Hr_t0]");
      [apply decode_encode_instrW_inv|iCorrectPC link a_last|iContiguous_next Hcont_rest 0|auto|..].
    iEpilogue "(HPC & Hprog_done & Hr_t5 & Hr_t0)". iCombine "Hprog_done" "Hfetch" as "Hprog_done".
    (* move r_t3 r_t1 *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iApply (wp_move_success_reg with "[$HPC $Hi $Hr_t3 $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC link a_last|iContiguous_next Hcont_rest 1|auto|..].
    iEpilogue "(HPC & Hi & Hr_t3 & Hr_t1)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* move r_t1 size *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iApply (wp_move_success_z with "[$HPC $Hi $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC link a_last|iContiguous_next Hcont_rest 2|auto|..].
    iEpilogue "(HPC & Hi & Hr_t1)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* move r_t0 PC *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iApply (wp_move_success_reg_fromPC with "[$HPC $Hi $Hr_t0]");
      [apply decode_encode_instrW_inv|iCorrectPC link a_last|iContiguous_next Hcont_rest 3|auto|..].
    iEpilogue "(HPC & Hi & Hr_t0)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* lea r_t0 3 *)
    destruct l';[inversion Hlength_rest|]. destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    assert ((a1 + 3)%a = Some a4) as Hlea.
    { apply (contiguous_between_incr_addr_middle _ _ _ 3 3 a1 a4) in Hcont_rest; auto. }
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr_t0]");
      [apply decode_encode_instrW_inv|iCorrectPC link a_last|iContiguous_next Hcont_rest 4|apply Hlea|auto..].
    { apply contiguous_between_length in Hcont.
      apply isCorrectPC_range_perm in Hvpc; [|revert Hcont; clear; solve_addr].
      destruct Hvpc as [-> | [-> | ->] ]; auto. }
    { apply contiguous_between_length in Hcont.
      apply isCorrectPC_range_perm in Hvpc; [|revert Hcont; clear; solve_addr].
      destruct Hvpc as [-> | [-> | ->] ]; auto. }
    iEpilogue "(HPC & Hi & Hr_t0)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* jmp r_t3 *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iApply (wp_jmp_success with "[$HPC $Hi $Hr_t3]");
      [apply decode_encode_instrW_inv|iCorrectPC link a_last|].
    iEpilogue "(HPC & Hi & Hr_t3) /="; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* we are now ready to use the malloc subroutine spec. For this we prepare the registers *)
    iDestruct (big_sepM_insert _ _ r_t3 with "[$Hregs $Hr_t3]") as "Hregs".
      by rewrite lookup_delete_ne // lookup_delete.
    iDestruct (big_sepM_insert _ _ r_t2 with "[$Hregs $Hr_t2]") as "Hregs".
      by rewrite lookup_insert_ne // lookup_delete_ne // lookup_delete_ne // lookup_delete.
    rewrite -(delete_insert_ne _ r_t5 r_t3) // insert_delete.
    rewrite -(delete_insert_ne _ r_t5 r_t2) // (insert_commute _ r_t2 r_t3) //.
    rewrite insert_delete.
    iDestruct (big_sepM_insert _ _ r_t5 with "[$Hregs $Hr_t5]") as "Hregs".
      by rewrite lookup_delete. rewrite insert_delete.
    iApply (wp_wand with "[-]").
    iApply (simple_malloc_subroutine_spec with "[- $Hmalloc $Hna $Hregs $Hr_t0 $HPC $Hr_t1]"); auto.
    { rewrite !dom_insert_L dom_delete_L Hrmap_dom.
      rewrite !difference_difference_L !singleton_union_difference_L !all_registers_union_l.
      f_equal. set_solver-. }
    iNext.
    rewrite updatePcPerm_cap_non_E.
    2: { eapply isCorrectPC_range_npE; eauto.
         generalize (contiguous_between_length _ _ _ Hcont_rest). cbn.
         clear; solve_addr. }
    iIntros "((Hna & Hregs) & Hr_t0 & HPC & Hbe) /=".
    iDestruct "Hbe" as (b e z Hbe Hbounds Hpos Hsizebe) "(Hr_t1 & Hbe)". inversion Hbe; subst z.
    iDestruct (big_sepM_delete _ _ r_t3 with "Hregs") as "[Hr_t3 Hregs]".
      by rewrite lookup_insert_ne // lookup_insert //.
      rewrite delete_insert_ne // delete_insert_delete.
      repeat (rewrite delete_insert_ne //;[]). rewrite delete_insert_delete.
    iDestruct (big_sepM_delete _ _ r_t5 with "Hregs") as "[Hr_t5 Hregs]".
      by (repeat (rewrite lookup_insert_ne //;[]); rewrite lookup_insert //).
      repeat (rewrite delete_insert_ne //;[]). rewrite delete_insert_delete.
    (* move r_t0 r_t5 *)
    iPrologue "Hprog".
    iApply (wp_move_success_reg with "[$HPC $Hi $Hr_t0 $Hr_t5]");
      [apply decode_encode_instrW_inv|iCorrectPC link a_last|iContiguous_next Hcont_rest 6|auto|..].
    iEpilogue "(HPC & Hi & Hr_t0 & Hr_t5)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* move r_t5 0 *)
    destruct l';[| by inversion Hlength_rest].
    iPrologue "Hprog".
    apply contiguous_between_last with (ai:=a5) in Hcont_rest as Hlast;[|auto].
    iApply (wp_move_success_z with "[$HPC $Hi $Hr_t5]");
      [apply decode_encode_instrW_inv|iCorrectPC link a_last|apply Hlast|auto|..].
    iEpilogue "(HPC & Hi & Hr_t5)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* continuation *)
    iApply "Hφ".
    iFrame "HPC". iSplitL "Hprog_done".
    { rewrite Heqapp. repeat (iDestruct "Hprog_done" as "[$ Hprog_done]"). iFrame. done. }
    iFrame.
    iDestruct (big_sepM_insert _ _ r_t5 with "[$Hregs $Hr_t5]") as "Hregs".
      repeat (rewrite lookup_insert_ne //;[]). apply lookup_delete.
    iDestruct (big_sepM_insert _ _ r_t3 with "[$Hregs $Hr_t3]") as "Hregs".
      repeat (rewrite lookup_insert_ne //;[]).
      rewrite lookup_delete_ne // lookup_delete //.
    repeat (rewrite (insert_commute _ r_t5) //;[]).
    rewrite insert_delete -(delete_insert_ne _ _ r_t5) //.
    rewrite (insert_commute _ r_t5 r_t2) // (delete_insert_ne _ r_t3 r_t2)//.
    rewrite (insert_commute _ r_t4 r_t2) // insert_insert.
    rewrite (insert_commute _ r_t3 r_t2) //.
    rewrite -(delete_insert_ne _ r_t3) // insert_delete.
    iFrame.
    iExists b,e. iFrame. auto. auto.
  Qed.

  (* ---------------------------------------- CRTCLS ------------------------------------ *)
  (* The following macro creates a closure with one variable. A more general create closure would
     allow for more than one variable in the closure, but this is so far not necessary for our
     examples. The closure allocates a new region with a capability to the closure code, the closure
     variable, and the closure activation *)

  (* encodings of closure activation code *)
  Definition v1 := encodeInstr (Mov r_t1 (inr PC)).
  Definition v2 := encodeInstr (Lea r_t1 (inl 7%Z)).
  Definition v3 := encodeInstr (Load r_env r_t1).
  Definition v4 := encodeInstr (Lea r_t1 (inl (-1)%Z)).
  Definition v5 := encodeInstr (Load r_t1 r_t1).
  Definition v6 := encodeInstr (Jmp r_t1).

  (* crtcls instructions *)
  (* f_m denotes the offset to the malloc capability in the lookup table *)
  (* crtcls assumes that the code lies in register r_t1 and the variable lies in r_t2 *)
  Definition crtcls_instrs f_m :=
    [move_r r_t6 r_t1;
    move_r r_t7 r_t2] ++
    malloc_instrs f_m 8%nat ++
    [store_z r_t1 v1;
    lea_z r_t1 1;
    store_z r_t1 v2;
    lea_z r_t1 1;
    store_z r_t1 v3;
    lea_z r_t1 1;
    store_z r_t1 v4;
    lea_z r_t1 1;
    store_z r_t1 v5;
    lea_z r_t1 1;
    store_z r_t1 v6;
    lea_z r_t1 1;
    store_r r_t1 r_t6;
    move_z r_t6 0;
    lea_z r_t1 1;
    store_r r_t1 r_t7;
    move_z r_t7 0;
    lea_z r_t1 (-7)%Z;
    restrict_z r_t1 global_e].

  Definition crtcls f_m a : iProp Σ :=
    ([∗ list] a_i;w_i ∈ a;(crtcls_instrs f_m), a_i ↦ₐ w_i)%I.

  (* crtcls spec *)
  Lemma crtcls_spec W f_m wvar wcode a pc_p pc_g pc_b pc_e
        a_first a_last b_link a_link e_link a_entry b_m e_m mallocN EN rmap cont φ :
    isCorrectPC_range pc_p pc_g pc_b pc_e a_first a_last →
    contiguous_between a a_first a_last →
    withinBounds (RW, Global, b_link, e_link, a_entry) = true →
    (a_link + f_m)%a = Some a_entry →
    dom (gset RegName) rmap = all_registers_s ∖ {[ PC; r_t0; r_t1; r_t2 ]} →
    isLocalWord wcode = false → (* the closure must be a Global Word! *)
    isLocalWord wvar = false → (* the closure must be a Global Word! *)
    ↑mallocN ⊆ EN →

      ▷ crtcls f_m a
    ∗ ▷ PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,a_first)
    ∗ na_inv logrel_nais mallocN (malloc_inv b_m e_m)
    ∗ na_own logrel_nais EN
    (* we need to assume that the malloc capability is in the linking table at offset 0 *)
    ∗ ▷ pc_b ↦ₐ inr (RO,Global,b_link,e_link,a_link)
    ∗ ▷ a_entry ↦ₐ inr (E,Global,b_m,e_m,b_m)
    (* register state *)
    ∗ ▷ r_t0 ↦ᵣ cont
    ∗ ▷ r_t1 ↦ᵣ wcode
    ∗ ▷ r_t2 ↦ᵣ wvar
    ∗ ▷ ([∗ map] r_i↦w_i ∈ rmap, r_i ↦ᵣ w_i)
    (* current world *)
    ∗ ▷ region W
    ∗ ▷ sts_full_world W
    (* continuation *)
    ∗ ▷ (PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,a_last) ∗ crtcls f_m a
         ∗ pc_b ↦ₐ inr (RO,Global,b_link,e_link,a_link)
         ∗ a_entry ↦ₐ inr (E,Global,b_m,e_m,b_m)
         (* the newly allocated region *)
         ∗ (∃ (b e : Addr), ⌜(b + 8)%a = Some e⌝ ∧ r_t1 ↦ᵣ inr (E,Global,b,e,b)
         ∗ [[b,e]] ↦ₐ [[ [inl v1;inl v2;inl v3;inl v4;inl v5;inl v6;wcode;wvar] ]]
         ∗ r_t0 ↦ᵣ cont
         ∗ r_t2 ↦ᵣ inl 0%Z
         ∗ na_own logrel_nais EN
         ∗ ([∗ map] r_i↦w_i ∈ <[r_t3:=inl 0%Z]>
                               (<[r_t4:=inl 0%Z]>
                                (<[r_t5:=inl 0%Z]>
                                 (<[r_t6:=inl 0%Z]>
                                  (<[r_t7:=inl 0%Z]> rmap)))), r_i ↦ᵣ w_i)
         (* the newly allocated region is fresh in the current world *)
         (* ∗ ⌜Forall (λ a, a ∉ dom (gset Addr) (std W)) (region_addrs b e)⌝ *)
         ∗ region W
         ∗ sts_full_world W)
         -∗ WP Seq (Instr Executable) {{ φ }})
    ⊢
      WP Seq (Instr Executable) {{ λ v, φ v ∨ ⌜v = FailedV⌝ }}.
  Proof.
    iIntros (Hvpc Hcont Hwb Ha_entry Hrmap_dom Hlocal Hlocal' HmallocN)
            "(>Hprog & >HPC & #Hmalloc & Hna & >Hpc_b & >Ha_entry & >Hr_t0 & >Hr_t1 & >Hr_t2 & >Hregs & Hr & Hsts & Hφ)".
    (* get some registers out of regs *)
    iDestruct (big_sepL2_length with "Hprog") as %Hlength.
    assert (is_Some (rmap !! r_t6)) as [rv6 ?]. by rewrite elem_of_gmap_dom Hrmap_dom; set_solver.
    iDestruct (big_sepM_delete _ _ r_t6 with "Hregs") as "[Hr_t6 Hregs]"; eauto.
    assert (is_Some (rmap !! r_t7)) as [rv7 ?]. by rewrite elem_of_gmap_dom Hrmap_dom; set_solver.
    iDestruct (big_sepM_delete _ _ r_t7 with "Hregs") as "[Hr_t7 Hregs]". by rewrite lookup_delete_ne //.
    destruct a as [|a l];[inversion Hlength|].
    apply contiguous_between_cons_inv_first in Hcont as Heq. subst.
    (* move r_t6 r_t1 *)
    destruct l;[inversion Hlength|].
    iPrologue "Hprog".
    iApply (wp_move_success_reg with "[$HPC $Hi $Hr_t6 $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC a_first a_last|iContiguous_next Hcont 0|].
    iEpilogue "(HPC & Hprog_done & Hr_t6 & Hr_t1)".
    (* move r_t7 r_t2 *)
    destruct l;[inversion Hlength|].
    iPrologue "Hprog".
    iApply (wp_move_success_reg with "[$HPC $Hi $Hr_t7 $Hr_t2]");
      [apply decode_encode_instrW_inv|iCorrectPC a_first a_last|iContiguous_next Hcont 1|].
    iEpilogue "(HPC & Hi & Hr_t7 & Hr_t2)"; iCombine "Hi Hprog_done" as "Hprog_done".
    assert (contiguous_between (a0 :: l) a0 a_last) as Hcont'.
    { apply contiguous_between_cons_inv in Hcont as [_ (? & ? & Hcont)].
      apply contiguous_between_cons_inv in Hcont as [_ (? & ? & Hcont)].
      pose proof (contiguous_between_cons_inv_first _ _ _ _ Hcont). subst. apply Hcont. }
    (* malloc 8 *)
    iDestruct (contiguous_between_program_split with "Hprog") as
        (malloc_prog rest link) "(Hmalloc_prog & Hprog & #Hcont)";[apply Hcont'|].
    iDestruct "Hcont" as %(Hcont_fetch & Hcont_rest & Heqapp & Hlink).
    (* we start by putting the registers back together *)
    iDestruct (big_sepM_insert with "[$Hregs $Hr_t6]") as "Hregs".
      by rewrite lookup_delete_ne // lookup_delete.
      rewrite delete_commute // insert_delete.
    iDestruct (big_sepM_insert with "[$Hregs $Hr_t7]") as "Hregs".
      by rewrite lookup_insert_ne // lookup_delete.
      rewrite insert_commute // insert_delete.
    assert (∀ (r:RegName), r ∈ ({[PC;r_t0;r_t1;r_t2]} : gset RegName) → rmap !! r = None) as Hnotin_rmap.
    { intros r Hr. eapply (@not_elem_of_dom _ _ (gset RegName)). typeclasses eauto.
      rewrite Hrmap_dom. set_solver. }
    iDestruct (big_sepM_insert with "[$Hregs $Hr_t2]") as "Hregs".
      by rewrite !lookup_insert_ne //; apply Hnotin_rmap; set_solver.
    iDestruct (big_sepM_insert with "[$Hregs $Hr_t1]") as "Hregs".
      by rewrite !lookup_insert_ne //; apply Hnotin_rmap; set_solver.
    (* apply the malloc spec *)
    rewrite -/(malloc _ _ _ _).
    iApply (malloc_spec with "[- $HPC $Hmalloc $Hna $Hpc_b $Ha_entry $Hr_t0 $Hregs $Hr $Hsts $Hmalloc_prog]");
      [|apply Hcont_fetch|apply Hwb|apply Ha_entry| |auto|lia|..].
    { intros mid Hmid. apply isCorrectPC_inrange with a_first a_last; auto.
      apply contiguous_between_bounds in Hcont_rest.
      apply contiguous_between_incr_addr with (i:=2) (ai:=a0) in Hcont;auto.
      revert Hcont Hcont_rest Hmid; clear. solve_addr. }
    { rewrite !dom_insert_L. rewrite Hrmap_dom.
      repeat (rewrite singleton_union_difference_L all_registers_union_l).
      f_equal. clear; set_solver. }
    iNext. iIntros "(HPC & Hmalloc_prog & Hpc_b & Ha_entry & Hbe & Hr_t0 & Hna & Hregs & Hr & Hsts)".
    iDestruct "Hbe" as (b e Hbe) "(Hr_t1 & Hbe)".
    rewrite delete_insert_delete.
    rewrite (delete_insert_ne _ r_t1 r_t2) //.
    repeat (rewrite (insert_commute _ _ r_t2) //;[]).
    rewrite insert_insert.
    (* we now want to infer a list of contiguous addresses between b and e *)
    assert (b < e)%a as Hlt;[solve_addr|].
    assert (contiguous (region_addrs b e)) as Hcontbe';[apply region_addrs_contiguous|].
    apply contiguous_iff_contiguous_between in Hcontbe'. destruct Hcontbe' as [b' [e' Hcontbe] ].
    assert (exists l, l = region_addrs b e) as [h Heqh];[eauto|].
    rewrite -Heqh in Hcontbe.
    rewrite /region_mapsto /region_addrs_zeroes -Heqh.
    assert (region_size b e = 8) as ->.
    { rewrite /region_size. revert Hbe; clear; solve_addr. }
    simpl.
    (* prepare the execution of the rest of the program *)
    iDestruct (big_sepL2_length with "Hprog") as %Hlength_rest.
    assert (isCorrectPC_range pc_p pc_g pc_b pc_e link a_last) as Hvpc_rest.
    { intros mid Hmid. apply isCorrectPC_inrange with a_first a_last; auto.
      apply contiguous_between_incr_addr with (i:=2) (ai:=a0) in Hcont;auto.
      revert Hcont Hmid Hlink;clear. solve_addr. }
    destruct rest as [|a1 l'];[inversion Hlength_rest|].
    apply contiguous_between_cons_inv_first in Hcont_rest as Heq. subst link.
    iDestruct (big_sepL2_length with "Hbe") as %Hlengthbe.
    destruct h;[inversion Hlengthbe|].
    apply region_addrs_first in Hlt as Hfirst. rewrite -Heqh in Hfirst; inversion Hfirst. subst a2.
    apply contiguous_between_cons_inv_first in Hcontbe as Heq. subst b'.
    assert (∀ i a', (b :: h) !! i = Some a' -> withinBounds (RWX, Global, b, e, a') = true) as Hwbbe.
    { intros i a' Hsome. apply andb_true_intro.
      apply contiguous_between_incr_addr with (i:=i) (ai:=a') in Hcontbe;[|congruence].
      apply lookup_lt_Some in Hsome. rewrite Heqh region_addrs_length in Hsome.
      revert Hsome Hcontbe Hbe. rewrite /region_size. clear; intros. split;[apply Z.leb_le|apply Z.ltb_lt];solve_addr.
    }
    iCombine "Hmalloc_prog" "Hprog_done" as "Hprog_done".
    (* store r_t1 v1 *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iDestruct "Hbe" as "[Hb Hbe]".
    iApply (wp_store_success_z with "[$HPC $Hi $Hr_t1 $Hb]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 0|..].
    { split;auto. apply Hwbbe with 0. auto. }
    iEpilogue "(HPC & Hi & Hr_t1 & Heb)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* lea r_t1 1 *)
    destruct l';[inversion Hlength_rest|].
    destruct h;[inversion Hlengthbe|].
    iPrologue "Hprog".
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 1|iContiguous_next Hcontbe 0|simpl;auto..].
    iEpilogue "(HPC & Hi & Hr_t1)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* store r_t1 v2 *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iDestruct "Hbe" as "[Hb Hbe]".
    iApply (wp_store_success_z with "[$HPC $Hi $Hr_t1 $Hb]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 2|..].
    { split;auto. apply Hwbbe with 1. auto. }
    iEpilogue "(HPC & Hi & Hr_t1 & Hb)"; iCombine "Hi" "Hprog_done" as "Hprog_done"; iCombine "Hb" "Heb" as "Heb".
    (* lea r_t1 1 *)
    destruct l';[inversion Hlength_rest|].
    destruct h;[inversion Hlengthbe|].
    iPrologue "Hprog".
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 3|iContiguous_next Hcontbe 1|simpl;auto..].
    iEpilogue "(HPC & Hi & Hr_t1)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* store r_t1 v3 *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iDestruct "Hbe" as "[Hb Hbe]".
    iApply (wp_store_success_z with "[$HPC $Hi $Hr_t1 $Hb]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 4|..].
    { split;auto. apply Hwbbe with 2. auto. }
    iEpilogue "(HPC & Hi & Hr_t1 & Hb)"; iCombine "Hi" "Hprog_done" as "Hprog_done"; iCombine "Hb" "Heb" as "Heb".
    (* lea r_t1 1 *)
    destruct l';[inversion Hlength_rest|].
    destruct h;[inversion Hlengthbe|].
    iPrologue "Hprog".
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 5|iContiguous_next Hcontbe 2|simpl;auto..].
    iEpilogue "(HPC & Hi & Hr_t1)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* store r_t1 v4 *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iDestruct "Hbe" as "[Hb Hbe]".
    iApply (wp_store_success_z with "[$HPC $Hi $Hr_t1 $Hb]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 6|..].
    { split;auto. apply Hwbbe with 3. auto. }
    iEpilogue "(HPC & Hi & Hr_t1 & Hb)"; iCombine "Hi" "Hprog_done" as "Hprog_done"; iCombine "Hb" "Heb" as "Heb".
    (* lea r_t1 1 *)
    destruct l';[inversion Hlength_rest|].
    destruct h;[inversion Hlengthbe|].
    iPrologue "Hprog".
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 7|iContiguous_next Hcontbe 3|simpl;auto..].
    iEpilogue "(HPC & Hi & Hr_t1)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* store r_t1 v5 *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iDestruct "Hbe" as "[Hb Hbe]".
    iApply (wp_store_success_z with "[$HPC $Hi $Hr_t1 $Hb]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 8|..].
    { split;auto. apply Hwbbe with 4. auto. }
    iEpilogue "(HPC & Hi & Hr_t1 & Hb)"; iCombine "Hi" "Hprog_done" as "Hprog_done"; iCombine "Hb" "Heb" as "Heb".
    (* lea r_t1 1 *)
    destruct l';[inversion Hlength_rest|].
    destruct h;[inversion Hlengthbe|].
    iPrologue "Hprog".
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 9|iContiguous_next Hcontbe 4|simpl;auto..].
    iEpilogue "(HPC & Hi & Hr_t1)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* store r_t1 v6 *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iDestruct "Hbe" as "[Hb Hbe]".
    iApply (wp_store_success_z with "[$HPC $Hi $Hr_t1 $Hb]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 10|..].
    { split;auto. apply Hwbbe with 5. auto. }
    iEpilogue "(HPC & Hi & Hr_t1 & Hb)"; iCombine "Hi" "Hprog_done" as "Hprog_done"; iCombine "Hb" "Heb" as "Heb".
    (* lea r_t1 1 *)
    destruct l';[inversion Hlength_rest|].
    destruct h;[inversion Hlengthbe|].
    iPrologue "Hprog".
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 11|iContiguous_next Hcontbe 5|simpl;auto..].
    iEpilogue "(HPC & Hi & Hr_t1)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* store r_t1 r_t6 *)
    (* first we must extract r_t6 *)
    iDestruct (big_sepM_delete _ _ r_t6 with "Hregs") as "[Hr_t6 Hregs]".
      by rewrite !lookup_insert_ne // lookup_delete_ne // lookup_insert //.
    (* then we can store *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iDestruct "Hbe" as "[Hb Hbe]".
    iApply (wp_store_success_reg with "[$HPC $Hi $Hr_t6 $Hr_t1 $Hb]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 12|..].
    { split;auto. apply Hwbbe with 6. auto. }
    { destruct wcode;auto. destruct c,p,p,p,p,l0;auto;inversion Hlocal'. }

    iEpilogue "(HPC & Hi & Hr_t6 & Hr_t1 & Hb)"; iCombine "Hi" "Hprog_done" as "Hprog_done"; iCombine "Hb" "Heb" as "Heb".
    (* move r_t6 0 *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iApply (wp_move_success_z with "[$HPC $Hi $Hr_t6]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 13|auto..].
    iEpilogue "(HPC & Hi & Hr_t6)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* lea r_t1 1 *)
    destruct l';[inversion Hlength_rest|].
    destruct h;[inversion Hlengthbe|].
    iPrologue "Hprog".
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 14|iContiguous_next Hcontbe 6|simpl;auto..].
    iEpilogue "(HPC & Hi & Hr_t1)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* store r_t1 r_t7 *)
    (* first we must extract r_t7 *)
    iDestruct (big_sepM_delete _ _ r_t7 with "Hregs") as "[Hr_t7 Hregs]".
      rewrite lookup_delete_ne // !lookup_insert_ne // lookup_delete_ne //
              lookup_insert_ne // lookup_insert //.
    (* then we can store *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iDestruct "Hbe" as "[Hb Hbe]".
    iApply (wp_store_success_reg with "[$HPC $Hi $Hr_t7 $Hr_t1 $Hb]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 15|..].
    { split;auto. apply Hwbbe with 7. auto. }
    { destruct wvar;auto. destruct c,p,p,p,p,l0;auto;inversion Hlocal. }
    iEpilogue "(HPC & Hi & Hr_t7 & Hr_t1 & Hb)"; iCombine "Hi" "Hprog_done" as "Hprog_done"; iCombine "Hb" "Heb" as "Heb".
    (* move r_t7 0 *)
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    iApply (wp_move_success_z with "[$HPC $Hi $Hr_t7]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 16|auto..].
    iEpilogue "(HPC & Hi & Hr_t7)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* put r_t6 and r_t7 back *)
    iDestruct (big_sepM_insert with "[$Hregs $Hr_t7]") as "Hregs". by rewrite lookup_delete.
    rewrite insert_delete.
    iDestruct (big_sepM_insert with "[$Hregs $Hr_t6]") as "Hregs". by rewrite lookup_insert_ne // lookup_delete.
    rewrite -(delete_insert_ne _ r_t6) // insert_delete.
    iClear "Hbe".
    (* lea r_t1 -7 *)
    destruct h;[|inversion Hlengthbe].
    destruct l';[inversion Hlength_rest|].
    iPrologue "Hprog".
    apply contiguous_between_last with (ai:=a23) in Hcontbe as Hnext; auto.
    assert ((a23 + (-7))%a = Some b) as Hlea.
    { apply contiguous_between_length in Hcontbe. revert Hbe Hnext Hcontbe; clear. solve_addr. }
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|iContiguous_next Hcont_rest 17|apply Hlea|simpl;auto..].
    iEpilogue "(HPC & Hi & Hr_t1)";iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* restrict r_t1 (Global,E) *)
    destruct l';[|inversion Hlength_rest].
    apply contiguous_between_last with (ai:=a26) in Hcont_rest as Hlast; auto.
    iPrologue "Hprog". iClear "Hprog".
    iApply (wp_restrict_success_z with "[$HPC $Hi $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC a1 a_last|apply Hlast|auto..].
    { rewrite decode_encode_permPair_inv. auto. }
    rewrite decode_encode_permPair_inv.
    iEpilogue "(HPC & Hi & Hr_t1)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* continuation *)
    iApply "Hφ".
    iFrame "HPC Hpc_b Ha_entry". iSplitL "Hprog_done".
    { rewrite Heqapp.
      do 22 iDestruct "Hprog_done" as "[$ Hprog_done]". iFrame. done.
    }
    iExists b,e. iSplitR;auto.
    iFrame "Hr_t1 Hr_t0".
    iSplitL "Heb".
    { rewrite -Heqh. do 7 iDestruct "Heb" as "[$ Heb]". iFrame. done. }
    iDestruct (big_sepM_delete _ _ r_t2 with "Hregs") as "[Hr_t2 Hregs]".
      by do 2 (rewrite lookup_insert_ne //); rewrite lookup_insert //.
    iFrame "Hr Hsts Hr_t2 Hna".
    repeat (rewrite delete_insert_ne //; []). rewrite delete_insert_delete.
    rewrite !delete_insert_ne // !delete_notin; [| apply Hnotin_rmap; set_solver ..].
    repeat (rewrite (insert_commute _ r_t6) //;[]). rewrite insert_insert.
    repeat (rewrite (insert_commute _ r_t7) //;[]). rewrite insert_insert. eauto.
  Qed.

  (* ------------------------------- Closure Activation --------------------------------- *)

  Lemma closure_activation_spec pc_p pc_g b_cls e_cls r1v renvv wcode wenv φ :
    readAllowed pc_p = true →
    isCorrectPC_range pc_p pc_g b_cls e_cls b_cls e_cls →
    pc_p ≠ E →
    PC ↦ᵣ inr (pc_p, pc_g, b_cls, e_cls, b_cls)
    ∗ r_t1 ↦ᵣ r1v
    ∗ r_env ↦ᵣ renvv
    ∗ [[b_cls, e_cls]]↦ₐ[[ [inl v1; inl v2; inl v3; inl v4; inl v5; inl v6; wcode; wenv] ]]
    ∗ (  PC ↦ᵣ updatePcPerm wcode
       ∗ r_t1 ↦ᵣ wcode
       ∗ r_env ↦ᵣ wenv
       ∗ [[b_cls, e_cls]]↦ₐ[[ [inl v1; inl v2; inl v3; inl v4; inl v5; inl v6; wcode; wenv] ]]
       -∗ WP Seq (Instr Executable) {{ φ }})
    ⊢
      WP Seq (Instr Executable) {{ φ }}.
  Proof.
    iIntros (Hrpc Hvpc HnpcE) "(HPC & Hr1 & Hrenv & Hcode & Hcont)".
    rewrite /region_mapsto.
    iDestruct (big_sepL2_length with "Hcode") as %Hcls_len. simpl in Hcls_len.
    assert (b_cls + 8 = Some e_cls)%a as Hbe.
    { rewrite region_addrs_length /region_size in Hcls_len.
      revert Hcls_len; clear; solve_addr. }
    assert (contiguous_between (region_addrs b_cls e_cls) b_cls e_cls) as Hcont_cls.
    { apply contiguous_between_of_region_addrs; auto. revert Hbe; clear; solve_addr. }
    pose proof (region_addrs_NoDup b_cls e_cls) as Hcls_nodup.
    iDestruct (big_sepL2_split_at 6 with "Hcode") as "[Hprog Hcls_data]".
    cbn [take drop].
    destruct (region_addrs b_cls e_cls) as [| ? ll]; [by inversion Hcls_len|].
    pose proof (contiguous_between_cons_inv_first _ _ _ _ Hcont_cls). subst.
    do 7 (destruct ll as [| ? ll]; [by inversion Hcls_len|]).
    destruct ll;[| by inversion Hcls_len]. cbn [take drop].
    iDestruct "Hcls_data" as "(Hcls_ptr & Hcls_env & _)".
    (* move r_t1 PC *)
    iPrologue "Hprog".
    iApply (wp_move_success_reg_fromPC with "[$HPC $Hi $Hr1]");
      [apply decode_encode_instrW_inv|  iCorrectPC b_cls e_cls |
       iContiguous_next Hcont_cls 0 |  ..].
    iEpilogue "(HPC & Hprog_done & Hr1)".
    (* lea r_t1 7 *)
    iPrologue "Hprog".
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr1]");
      [apply decode_encode_instrW_inv | iCorrectPC b_cls e_cls |
       iContiguous_next Hcont_cls 1 | | done | ..].
    { eapply contiguous_between_incr_addr_middle' with (i:=0); eauto.
      cbn. clear. lia. }
    { destruct pc_p; simpl in *; try discriminate; auto. }
    iEpilogue "(HPC & Hi & Hr1)". iCombine "Hi Hprog_done" as "Hprog_done".
    (* load r_env r_t1 *)
    iPrologue "Hprog".
    (* FIXME: tedious & fragile *)
    assert ((a5 =? a0)%a = false) as H_5_0.
    { apply Z.eqb_neq. intros Heqb. assert (a5 = a0) as ->. revert Heqb; clear; solve_addr.
      exfalso. by pose proof (NoDup_lookup _ 2 7 _ Hcls_nodup eq_refl eq_refl). }
    iApply (wp_load_success with "[$HPC $Hi $Hrenv $Hr1 Hcls_env]");
      [apply decode_encode_instrW_inv | iCorrectPC b_cls e_cls |
       split;[done|] | iContiguous_next Hcont_cls 2 | ..].
    { eapply contiguous_between_middle_bounds' in Hcont_cls as [? ?].
      by eapply le_addr_withinBounds; eauto. repeat constructor. }
    { rewrite H_5_0. iFrame. }
    iEpilogue "(HPC & Hrenv & Hi & Hr1 & Hcls_env)". rewrite H_5_0.
    iCombine "Hi Hprog_done" as "Hprog_done".
    (* lea r_t1 (-1) *)
    iPrologue "Hprog".
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr1]");
      [apply decode_encode_instrW_inv | iCorrectPC b_cls e_cls |
       iContiguous_next Hcont_cls 3 | | done | ..].
    { assert ((a4 + 1)%a = Some a5) as HH. by iContiguous_next Hcont_cls 6.
      instantiate (1 := a4). revert HH. clear; solve_addr. }
    { destruct pc_p; simpl in *; try discriminate; auto. }
    iEpilogue "(HPC & Hi & Hr1)". iCombine "Hi Hprog_done" as "Hprog_done".
    (* load r_t1 r_t1 *)
    iPrologue "Hprog".
    (* FIXME: tedious & fragile *)
    assert ((a4 =? a2)%a = false) as H_4_2.
    { apply Z.eqb_neq. intros Heqb. assert (a4 = a2) as ->. revert Heqb; clear; solve_addr.
      exfalso. by pose proof (NoDup_lookup _ 4 6 _ Hcls_nodup eq_refl eq_refl). }
    iApply (wp_load_success_same with "[$HPC $Hi $Hr1 Hcls_ptr]");
      [(* FIXME *) auto | apply decode_encode_instrW_inv | iCorrectPC b_cls e_cls |
       auto | | iContiguous_next Hcont_cls 4 | ..].
    { eapply contiguous_between_middle_bounds' in Hcont_cls as [? ?].
      by eapply le_addr_withinBounds; eauto. repeat constructor. }
    { rewrite H_4_2. iFrame. }
    iEpilogue "(HPC & Hr1 & Hi & Hcls_ptr)". rewrite H_4_2.
    iCombine "Hi Hprog_done" as "Hprog_done".
    (* jmp r_t1 *)
    iPrologue "Hprog".
    iApply (wp_jmp_success with "[$HPC $Hi $Hr1]");
      [apply decode_encode_instrW_inv | iCorrectPC b_cls e_cls | .. ].
    iEpilogue "(HPC & Hi & Hr1)".

    iApply "Hcont". do 4 (iDestruct "Hprog_done" as "(? & Hprog_done)"). iFrame.
  Qed.

End stack_macros.


Require Import Kami.AllNotations.

Require Import ProcKami.FU.

Import ListNotations.

Section trap.
  Context {procParams: ProcParams}.
  Variable ty: Kind -> Type.

  Local Open Scope kami_expr.
  Local Open Scope kami_action.

  Local Definition NumInterrupts := 12.
  Local Definition NumDelegs  := 16.

  Local Definition isInterruptSelect
    (k : Kind)
    (f : bool -> ActionT ty k)
    (isInterrupt : Bool @# ty)
    :  ActionT ty k
    := If isInterrupt
         then f true
         else f false
         as res;
       Ret #res.

  Local Definition delegModeSelect
    (k : Kind)
    (f : nat -> ActionT ty k)
    (delegMode : PrivMode @# ty)
    :  ActionT ty k
    := If delegMode == $MachineMode
         then f MachineMode
         else
           If delegMode == $SupervisorMode
             then f SupervisorMode
             else f UserMode
             as res;
           Ret #res
         as res;
       Ret #res.

  Local Definition delegated (deleg : Array NumDelegs Bool @# ty) (trap : Trap @# ty) : Bool @# ty
    := deleg@[trap].

  Local Definition delegModeAux
    (trap : Trap @# ty)
    :  list ((PrivMode @# ty) * (Array NumDelegs Bool @# ty)) -> PrivMode @# ty
    := fold_right
         (fun deleg lowerMode
           => IF delegated (snd deleg) trap
                then lowerMode
                else fst deleg)
         $UserMode.

  Local Definition delegMode
    (mdeleg : Array NumDelegs Bool @# ty)
    (sdeleg : Array NumDelegs Bool @# ty)
    (trap : Trap @# ty)
    :  PrivMode @# ty
    := delegModeAux trap [($MachineMode, mdeleg); ($SupervisorMode, sdeleg)].

  Local Definition getModePrefix (mode : nat) : string
    := if Nat.eqb mode MachineMode then "m"
         else if Nat.eqb mode SupervisorMode then "s" else "u".

  Local Definition delegName (mode : nat) (isInterrupt : bool) : string
    := @^((getModePrefix mode) ++ (if isInterrupt then "i" else "e") ++ "deleg")%string.

  Local Definition getDelegMode
    (trap : Trap @# ty)
    :  forall isInterrupt : Bool @# ty, ActionT ty PrivMode
    := isInterruptSelect
         (fun isInterrupt : bool
           => let delegSz : nat
                := if isInterrupt then NumInterrupts else NumDelegs in
              Read mdeleg'
                :  Bit delegSz
                <- (delegName MachineMode isInterrupt);
              Read sdeleg'
                :  Bit delegSz
                <- (delegName SupervisorMode isInterrupt);
              LET mdeleg : Array NumDelegs Bool <- unpack _ (ZeroExtendTruncLsb _ #mdeleg');
              LET sdeleg : Array NumDelegs Bool <- unpack _ (ZeroExtendTruncLsb _ #sdeleg');
              Ret (delegMode #mdeleg #sdeleg trap)).

  Local Definition getInterruptEnable
    (mip : Array NumInterrupts Bool @# ty)
    (mie : Array NumInterrupts Bool @# ty)
    (interrupt : Interrupt @# ty)
    :  Bool @# ty
    := mip@[interrupt] && mie@[interrupt].

  Local Definition PriorityBitStringSz : nat := 1 + PrivModeWidth + TrapSz + 0.

  Local Definition PriorityBitString := Bit PriorityBitStringSz.

  Local Definition getPriorityBitString
    (status : Bool @# ty) (* pending and enabled. *)
    (delegMode : PrivMode @# ty)
    (trap : Trap @# ty)
    :  PriorityBitString @# ty
    := {< pack status, delegMode, trap >}.

  Local Definition getPriorityInterrupt
    (mip : Array NumInterrupts Bool @# ty)
    (mie : Array NumInterrupts Bool @# ty)
    (mideleg : Array NumDelegs Bool @# ty)
    (sideleg : Array NumDelegs Bool @# ty)
    :  PriorityBitString ## ty :=
    fold_tree
      (fun (priorityBitStringExpr : PriorityBitString ## ty)
        (accExpr : PriorityBitString ## ty) =>
        LETE acc <- accExpr;
        LETE priorityBitString <- priorityBitStringExpr;
        RetE
          (IF #acc <= #priorityBitString
            then #priorityBitString
            else #acc))
      (RetE $0)
      (map
        (fun trap : nat =>
          RetE (getPriorityBitString
            (getInterruptEnable mip mie $trap)
            (delegMode mideleg sideleg $trap)
            $trap))
        (seq 0 (NumInterrupts - 1))).

  (* returns either mip or mie. *)
  Local Definition readInterruptStatus
    (suffix : string)
    :  ActionT ty (Array NumInterrupts Bool)
    := Read mei : Bool <- @^("mei" ++ suffix);
       Read msi : Bool <- @^("msi" ++ suffix);
       Read mti : Bool <- @^("mti" ++ suffix);
       Read sei : Bool <- @^("sei" ++ suffix);
       Read ssi : Bool <- @^("ssi" ++ suffix);
       Read sti : Bool <- @^("sti" ++ suffix);
       Read uei : Bool <- @^("uei" ++ suffix);
       Read usi : Bool <- @^("usi" ++ suffix);
       Read uti : Bool <- @^("uti" ++ suffix);
       Ret (ARRAY {#usi; #ssi; $$false; #msi;
                   #uti; #sti; $$false; #mti;
                   #uei; #sei; $$false; #mei}
            : Array NumInterrupts Bool @# ty).

  Local Definition getPPWidth (mode : nat) : nat
    := if Nat.eqb mode MachineMode then 2
         else if Nat.eqb mode SupervisorMode then 1
           else 0.

  Local Definition updateTrapStack
    (delegMode : nat)
    (isInterrupt : Bool @# ty)
    (currMode : PrivMode @# ty)
    :  ActionT ty Void
    := Read ie : Bool <- @^(getModePrefix delegMode ++ "ie");
       Write @^(getModePrefix delegMode ++ "pie") : Bool <- #ie;
       Write @^(getModePrefix delegMode ++ "ie") : Bool <- $$false;
       Read extRegs: ExtensionsReg <- @^"extRegs";
       LET extensions: Extensions <- ExtRegToExt #extRegs;
       Write @^(getModePrefix delegMode ++ "pp")
         :  Bit (getPPWidth delegMode)
         <- ZeroExtendTruncLsb (getPPWidth delegMode) (modeFix #extensions currMode);
       Write @^"mode" : PrivMode <- modeFix #extensions $delegMode;
       If isInterrupt
         then
           Write @^"isWfi" : Bool <- $$false;
           Retv;
       Retv.

  Local Definition getExceptionValue
             (exception: Exception @# ty)
             (pc: VAddr @# ty)
             (inst: Inst @# ty)
             (update_pkt : ExecUpdPkt @# ty)
             (next_pc: VAddr @# ty)
             (exceptionUpper: Bool @# ty) :=
    LETC currPc <- SignExtendTruncLsb Rlen pc;
    LETC currPc2 <- (#currPc + IF exceptionUpper then $2 else $0);
    LETC nextPc <- SignExtendTruncLsb Rlen next_pc;
    LETC memAddr <- (update_pkt @% "val2" @% "data" @% "data");
    RetE
      (ZeroExtendTruncLsb Xlen
        (Switch exception Retn Data With {
          ($InstAddrMisaligned : Exception @# ty) ::= #nextPc;
          ($InstAccessFault: Exception @# ty) ::= #currPc2;
          ($Breakpoint: Exception @# ty) ::= #currPc;
          ($InstPageFault: Exception @# ty) ::= #currPc2;
          ($IllegalInst: Exception @# ty) ::= ZeroExtendTruncLsb Rlen inst;
          ($LoadAddrMisaligned: Exception @# ty) ::= #memAddr;
          ($SAmoAddrMisaligned: Exception @# ty) ::= #memAddr;
          ($LoadAccessFault: Exception @# ty) ::= #memAddr;
          ($SAmoAccessFault: Exception @# ty) ::= #memAddr;
          ($LoadPageFault: Exception @# ty) ::= #memAddr;
          ($SAmoPageFault: Exception @# ty) ::= #memAddr
        })).

  Local Definition setTrapContext
    (delegMode : nat)
    (isInterrupt : Bool @# ty)
    (xlen : XlenValue @# ty)
    (trap: Trap @# ty)
    (pc: VAddr @# ty)
    (inst: Inst @# ty)
    (updatePkt : ExecUpdPkt @# ty)
    (nextPc: VAddr @# ty)
    (exceptionUpper: Bool @# ty)
    :  ActionT ty VAddr
    := Read tvecMode : Bit 2 <- @^(getModePrefix delegMode ++ "tvec_mode");
       Read tvecBase : Bit (Xlen - 2) <- @^(getModePrefix delegMode ++ "tvec_base");
       LET addrBase : VAddr <- xlen_sign_extend Xlen xlen #tvecBase << ($2 : Bit 2 @# ty);
       LET addrOffset : VAddr <- xlen_sign_extend Xlen xlen trap << ($2 : Bit 2 @# ty);
       LETA trapValue : Bit Xlen
         <- convertLetExprSyntax_ActionT
              (getExceptionValue trap pc inst updatePkt nextPc exceptionUpper);
       LET finalTrapValue: Bit Xlen <- IF isInterrupt then $0 else #trapValue;
       LET nextPc
         :  VAddr
         <- IF #tvecMode == $0
              then #addrBase
              else (#addrBase + #addrOffset);
       Write @^(getModePrefix delegMode ++ "epc") : VAddr <- pc;
       Write @^(getModePrefix delegMode ++ "cause_interrupt") : Bool <- isInterrupt;
       Write @^(getModePrefix delegMode ++ "cause_code")
         :  Bit (Xlen - 1)
         <- ZeroExtendTruncLsb (Xlen - 1) trap;
       Write @^(getModePrefix delegMode ++ "tval") : Bit Xlen <- #finalTrapValue;
       Ret #nextPc.

  Local Definition trapAction
    (delegMode : nat)
    (isInterrupt : Bool @# ty)
    (xlen : XlenValue @# ty)
    (debug : Bool @# ty)
    (currMode : PrivMode @# ty)
    (pc : VAddr @# ty)
    (trap : Trap @# ty)
    (inst: Inst @# ty)
    (updatePkt: ExecUpdPkt @# ty)
    (returnPc: VAddr @# ty)
    (exceptionUpper: Bool @# ty)
    :  ActionT ty VAddr
    := LETA _ <- updateTrapStack delegMode isInterrupt currMode;
       setTrapContext delegMode isInterrupt xlen trap pc inst updatePkt returnPc exceptionUpper.

  Definition enterDebugMode
    (mode : PrivMode @# ty)
    (pc : VAddr @# ty)
    (cause : Bit 3 @# ty)
    :  ActionT ty Void
    := Write @^"dpc" : Bit Xlen <- SignExtendTruncLsb Xlen pc;
       Write @^"prv" : Bit 2 <- ZeroExtendTruncLsb PrivModeWidth mode;
       Write @^"cause" : Bit 3 <- cause;
       Write @^"debugMode" : Bool <- $$true;
       Retv.

  Definition exitDebugMode
    (dpc : Bit Xlen @# ty)
    (prv : Bit 2 @# ty)
    :  ActionT ty Void
    := Write @^"mode" : PrivMode <- ZeroExtendTruncLsb PrivModeWidth prv;
       Write @^"debugMode" : Bool <- $$ false;
       Retv.

  Definition trapException
    (xlen : XlenValue @# ty)
    (debug : Bool @# ty)
    (currMode : PrivMode @# ty)
    (pc : VAddr @# ty)
    (exception : Exception @# ty)
    (inst: Inst @# ty)
    (updatePkt: ExecUpdPkt @# ty)
    (returnPc: VAddr @# ty)
    (exceptionUpper: Bool @# ty)
    :  ActionT ty VAddr
    := LETA delegMode
         :  PrivMode
         <- getDelegMode exception $$false;
       LETA nextPc
         :  VAddr
         <- delegModeSelect
              (fun delegMode : nat
                => If $delegMode >= currMode
                     then
                       trapAction delegMode $$false xlen debug currMode
                         pc exception inst updatePkt returnPc exceptionUpper
                     else Ret returnPc
                     as nextPc;
                   Ret #nextPc)
              #delegMode;
       Ret #nextPc.

  Definition trapInterrupt
    (xlen : XlenValue @# ty)
    (debug : Bool @# ty)
    (currMode : PrivMode @# ty)
    (pc : VAddr @# ty)
    :  ActionT ty (Maybe VAddr)
    := LETA mip : Array NumInterrupts Bool <- readInterruptStatus "p";
       LETA mie : Array NumInterrupts Bool <- readInterruptStatus "e";
       Read mideleg : Bit NumInterrupts <- @^"mideleg";
       Read sideleg : Bit NumInterrupts <- @^"sideleg";
       LETA priorityBitString
         :  PriorityBitString
         <- convertLetExprSyntax_ActionT
              (getPriorityInterrupt #mip #mie
                (unpack (Array NumDelegs Bool) (ZeroExtendTruncLsb NumDelegs #mideleg))
                (unpack (Array NumDelegs Bool) (ZeroExtendTruncLsb NumDelegs #sideleg)));
       LET trap : Interrupt <- UniBit (TruncLsb TrapSz _) #priorityBitString;
       LET trapIsPendingAndEnabled : Bool
         <- (UniBit (TruncMsb (PrivModeWidth + TrapSz + 0) 1) #priorityBitString) == $1;
       LETA delegMode
         :  PrivMode
         <- getDelegMode #trap $$true;
       LETA trapsEnabled
         :  Bool
         <- delegModeSelect
              (fun delegMode : nat
                => Read enabled : Bool <- @^(getModePrefix delegMode ++ "ie");
                   Ret #enabled)
              #delegMode;
       LET shouldTrap : Bool
         <- ((#delegMode > currMode) || (#delegMode == currMode && #trapsEnabled)) &&
            #trapIsPendingAndEnabled;
       If #shouldTrap
         then
           delegModeSelect
             (fun delegMode : nat
               => trapAction delegMode $$true xlen debug currMode pc (unsafeTruncLsb TrapSz #trap) $0
                    $$(getDefaultConst ExecUpdPkt) $0 $$false)
             #delegMode
         else Ret $$(getDefaultConst VAddr)
         as nextPc;
       Ret (STRUCT {
         "valid" ::= #shouldTrap;
         "data"  ::= #nextPc
       } : Maybe VAddr @# ty).

  Local Close Scope kami_action.
  Local Close Scope kami_expr.

End trap.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Tahina Ramananandro, Reservoir Labs Inc.                   *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** The Linear2 intermediate language: abstract syntax and semantics *)

(** The Linear2 language is a variant of Linear where two executions
    of the same code happen "in parallel" on two different memory
    states. It is needed in some verified separate compilation
    contexts where the source code has to run on the memory state
    without argument locations at the module boundary, when the
    initial memory state is provided by arbitrary assembly code.
*)

Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Op.
Require Import Locations.
Require Import LTL.
Require Import Conventions.

Require Import Linear.
Require Import Morphisms.

Inductive invar_stackframe: stackframe -> stackframe -> Prop :=
| invar_stackframe_intro
    fh sph rsh ch
    fl spl rsl cl
    (f_eq: fh = fl)
    (sp_lessdef: Val.lessdef sph spl)
    (rs_lessdef: forall l, Val.lessdef (rsh l) (rsl l))
    (c_eq: ch = cl)
  :
    invar_stackframe
      (Stackframe fh sph rsh ch)
      (Stackframe fl spl rsl cl)
.

Global Instance invar_stackframe_refl:
  Reflexive invar_stackframe.
Proof.
  red. intro x.
  destruct x.
  econstructor; eauto.
Qed.

Definition invar_stack := list_forall2 invar_stackframe.

Global Instance invar_stack_refl: Reflexive invar_stack.
Proof.
  red. intro x.
  induction x; econstructor; eauto.
  reflexivity.
Qed.

Section WITHMEMORYMODELOPS.
Context  `{memory_model_ops: Mem.MemoryModelOps}.

Inductive invar: state -> state -> Prop :=
| invar_state
    stackh fh sph ch rsh mh
    stackl fl spl cl rsl ml
    (stack_inv: invar_stack stackh stackl)
    (f_eq: fh = fl)
    (sp_lessdef: Val.lessdef sph spl)
    (c_eq: ch = cl)
    (rs_lessdef: forall l, Val.lessdef (rsh l) (rsl l))
    (m_ext: Mem.extends mh ml)
  :
    invar
      (State stackh fh sph ch rsh mh)
      (State stackl fl spl ch rsl ml)
| invar_callstate
    stackh fh rsh mh
    stackl fl rsl ml
    (stack_inv: invar_stack stackh stackl)
    (f_eq: fh = fl)
    (rs_lessdef: forall l, Val.lessdef (rsh l) (rsl l))
    (m_ext: Mem.extends mh ml)
  :
    invar
      (Callstate stackh fh rsh mh)
      (Callstate stackl fl rsl ml)
| invar_returnstate
    stackh rsh mh
    stackl rsl ml
    (stack_inv: invar_stack stackh stackl)
    (rs_lessdef: forall l, Val.lessdef (rsh l) (rsl l))
    (m_ext: Mem.extends mh ml)
  :
    invar
      (Returnstate stackh rsh mh)
      (Returnstate stackl rsl ml)
.

Context `{memory_model: !Mem.MemoryModel mem}.

Global Instance invar_refl: Reflexive invar.
Proof.
  red.
  intro x. destruct x.
  {
    econstructor; eauto; try reflexivity.
    apply Mem.extends_refl.
  }
  {
    econstructor; eauto; try reflexivity.
    apply Mem.extends_refl.
  }
  {
    econstructor; eauto; try reflexivity.
    apply Mem.extends_refl.
  }
Qed.

End WITHMEMORYMODELOPS.

Section WITHCONFIG.
Context `{external_calls_prf: ExternalCalls}.

Record state: Type := State
  {
    state_higher: Linear.state;
    state_lower:  Linear.state;
    state_ge: Linear.genv;
    state_init_ls: locset;
    state_invariant: invar state_higher state_lower
  }.

Record step (ge: genv) (before: state) (t: trace) (after: state): Prop :=
  {
    step_ge_eq_before: ge = state_ge before;
    step_ge_eq_after: ge = state_ge after;
    step_init_ls_eq: state_init_ls after = state_init_ls before;
    step_high: Linear.step (state_init_ls before) ge (state_higher before) t (state_higher after);
    step_low: Linear.step (state_init_ls before) ge (state_lower before) t (state_lower after)
  }.

(* Whole-program case *)

Inductive initial_state (p: program) (s: state): Prop :=
| initial_state_intro
    (init_higher: Linear.initial_state p (state_higher s))
    (init_lower: Linear.initial_state p (state_lower s))
    (init_ls: state_init_ls s = Locmap.init Vundef)
.

Inductive final_state (s: state) (i: int): Prop :=
| final_state_intro
    j (fin_higher: Linear.final_state (state_higher s) j)
    (fin_lower: Linear.final_state (state_lower s) i)
.

Definition semantics (p: program) :=
  Semantics step (initial_state p) final_state (Genv.globalenv p).

(* Whole-program Linear trivially forward-simulates into Linear2:
   the two executions are actually the same as the Linear one.
*)

Record whole_program_invariant (ge: genv) (u: unit) (s: Linear.state) (s2: state): Prop :=
{
  wp_inv_state_higher_eq:
    state_higher s2 = s;
  wp_inv_state_lower_eq:
    state_lower s2 = s;
  wp_inv_ge_eq:
    state_ge s2 = ge;
  wp_inv_init_ls_eq:
    state_init_ls s2 = Locmap.init Vundef
}.

Theorem whole_program_linear_to_linear2 p:
  forward_simulation
    (Linear.semantics p)
    (semantics p)
.
Proof.
  apply Forward_simulation with
    (order := fun _ _ => False)
      (match_states := whole_program_invariant (Genv.globalenv p)).
  constructor.
  * constructor. contradiction.
  * intros s1 H.
    exists tt.
    eexists (State s1 s1 (Genv.globalenv p) (Locmap.init Vundef) _).
    split.
    { econstructor; eauto. }
    econstructor; eauto.
  * inversion 1; subst.
    simpl.
    intros.
    econstructor; eauto.
    congruence.
  * simpl.
    intros s1 t s1' H i s2 H0.
    inversion H0; subst.
    exists tt.
    eexists (State s1' s1' (Genv.globalenv p) (Locmap.init Vundef) _).
    split.
    {
      left.
      eapply plus_one.
      econstructor; simpl; eauto; congruence.
    }
    econstructor; eauto.
  * reflexivity.
Grab Existential Variables.
eauto.
reflexivity.
eauto.
reflexivity.
Defined.

End WITHCONFIG.


Require Import Rupicola.Lib.Api.

Inductive annotation {width: Z} {BW: Bitwidth width} {word: word.word width} : Type :=
| Reserved : word -> annotation
| Borrowed : word -> annotation
| Owned : annotation
.

Section KVStore.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.
  Local Notation annotation := (@annotation _ BW word).

  Definition AnnotatedValue_gen {value}
             (Value : word -> value -> mem -> Prop)
             (addr : word) (av : annotation * value)
    : mem -> Prop :=
    match (fst av) with
    | Reserved pv => (emp (addr = pv) * Value pv (snd av))%sep
    | Borrowed pv => emp (addr = pv)
    | Owned => Value addr (snd av)
    end.

  Class kv_ops :=
    { map_init : func;
      get : func;
      put : func; }.

  Class kv_parameters
        {ops : kv_ops} {key value : Type}
        {Value : word -> value -> mem -> Prop} :=
    { map_gen : forall value, map.map key value;
      map := map_gen value;
      annotated_map := map_gen (annotation * value);
      init_map_size_in_bytes : nat;
      key_eqb : key -> key -> bool;
      Key : word -> key -> mem -> Prop;
      Map_gen :
        forall value (Value : word -> value ->
                              mem -> Prop),
          word -> map.rep (map:=map_gen value) ->
          mem -> Prop;
      Map : _ -> map -> _ -> _ := Map_gen value Value;
      AnnotatedMap : _ -> annotated_map -> _ -> _ :=
        Map_gen (annotation * value)
                (AnnotatedValue_gen Value);
    }.

  Class kv_parameters_ok
        {ops : kv_ops} {key value Value}
        {p : @kv_parameters ops key value Value} :=
    { map_ok_gen : forall value, map.ok (map_gen value);
      map_ok : map.ok map := map_ok_gen value;
      annotated_map_ok : map.ok annotated_map :=
        map_ok_gen (annotation * value);
      key_eq_dec :
        forall x y : key, BoolSpec (x = y) (x <> y) (key_eqb x y);
      Map_put_impl1 :
        forall value Value pm
               (m : map.rep (map:=map_gen value))
               k v1 v2 R1 R2,
          (forall pv,
              Lift1Prop.impl1
                (sep (Value pv v1) R1)
                (sep (Value pv v2) R2)) ->
          Lift1Prop.impl1
            (sep (Map_gen value Value pm (map.put m k v1)) R1)
            (sep (Map_gen value Value pm (map.put m k v2)) R2);
      Map_fold_iff1 :
        forall value1 value2 Value1 Value2 (f : value1 -> value2),
          (forall pv v,
              Lift1Prop.iff1 (Value1 pv v) (Value2 pv (f v))) ->
          forall pm m,
            Lift1Prop.iff1
              (Map_gen value1 Value1 pm m)
              (Map_gen value2 Value2 pm
                       (map.fold
                          (fun m' k v => map.put m' k (f v))
                          map.empty m)); }.

  Section specs.
    Context {ops key value Value}
            {kvp : @kv_parameters ops key value Value}.

    Instance spec_of_map_init : spec_of "map_init" :=
      fun functions =>
        forall p start R tr mem,
          (* { p -> start } *)
          (* space must already be allocated at start *)
          (truncated_scalar
             access_size.word p (word.unsigned start)
           * Lift1Prop.ex1
               (fun xs: list _ =>
                  sep (emp (length xs = init_map_size_in_bytes))
                      (array ptsto (word.of_Z 1) start xs))
           * R)%sep mem ->
          WeakestPrecondition.call
            functions "map_init" tr mem [p]
            (fun tr' mem' rets =>
               tr = tr'
               /\ rets = []
               /\ (Map p map.empty * R)%sep mem').

    (* get returns a pair; a boolean (true if there was an error) and a value,
       which is meaningless if there was an error. *)
    Instance spec_of_map_get : spec_of "get" :=
      fun functions =>
        forall pm m pk k R tr mem,
          sep (sep (AnnotatedMap pm m) (Key pk k)) R mem ->
          WeakestPrecondition.call
            functions "get" tr mem [pm; pk]
            (fun tr' mem' rets =>
               tr = tr'
               /\ length rets = 2%nat
               /\ let err := hd (word.of_Z 0) rets in
                  let pv := hd (word.of_Z 0) (tl rets) in
                  match map.get m k with
                  | Some (a, v) =>
                    err = word.of_Z 0
                    /\ (match a with
                        | Borrowed pv' => pv = pv'
                        | Reserved pv' => pv = pv'
                        | Owned => True
                        end)
                    /\ (AnnotatedMap
                          pm (match a with
                              | Borrowed _ => m
                              | Reserved _ => m
                              | Owned => map.put m k (Reserved pv, v)
                              end) * Key pk k * R)%sep mem'
                  | None =>
                    (* if k not \in m, err = true and no change *)
                    err = word.of_Z 1
                    /\ (AnnotatedMap pm m * Key pk k * R)%sep mem'
                  end).

    (* put returns a boolean indicating whether the key was already
       present. If true, the original value pointer now points to the old
       value. *)
    Instance spec_of_map_put : spec_of "put" :=
      fun functions =>
        forall pm m pk k pv v R tr mem,
          (AnnotatedMap pm m
           * Key pk k * Value pv v * R)%sep mem ->
          WeakestPrecondition.call
            functions "put" tr mem [pm; pk; pv]
            (fun tr' mem' rets =>
               tr = tr'
               /\ length rets = 1%nat
               /\ let was_overwrite := hd (word.of_Z 0) rets in
                  match map.get m k with
                  | Some (a, old_v) =>
                    match a with
                    | Borrowed _ => True (* no guarantees *)
                    | Reserved pv' =>
                      was_overwrite = word.of_Z 1
                      /\ (AnnotatedMap pm (map.put m k (Reserved pv', v))
                          * Key pk k * Value pv old_v * R)%sep mem'
                    | Owned =>
                      was_overwrite = word.of_Z 1
                      /\ (AnnotatedMap pm (map.put m k (Owned, v))
                          * Key pk k * Value pv old_v * R)%sep mem'
                    end
                  | None =>
                    (* if there was no previous value, the map consumes both
                       the key and value memory *)
                    was_overwrite = word.of_Z 0
                    /\ (AnnotatedMap pm (map.put m k (Owned, v))
                        * R)%sep mem'
                  end).
  End specs.
End KVStore.


From stbor.lang Require Export lang.

Set Default Proof Using "Type".

(** Wellformedness *)
Class Wellformed A := Wf : A → Prop.
Existing Class Wf.

Definition wf_mem_tag (h: mem) (nxtp: ptr_id) :=
  ∀ l l' pid, h !! l = Some (ScPtr l' (Tagged pid)) → (pid < nxtp)%nat.

Definition stack_item_included (stk: stack) (nxtp: ptr_id) (nxtc: call_id) :=
  ∀ si, si ∈ stk → match si.(tg) with
                    | Tagged t => (t < nxtp)%nat
                    | _ => True
                   end ∧
                   match si.(protector) with
                    | Some c => (c < nxtc)%nat
                    | _ => True
                   end.

Definition is_tagged (it: item) :=
  match it.(tg) with Tagged _ => True | _ => False end.
Instance is_tagged_dec: Decision (is_tagged it).
Proof. intros. rewrite /is_tagged. case tg; solve_decision. Defined.
Definition stack_item_tagged_NoDup (stk : stack) :=
  NoDup (fmap tg (filter is_tagged stk)).

Definition wf_stack_item (α: stacks) (nxtp: ptr_id) (nxtc: call_id) :=
  ∀ l stk, α !! l = Some stk → stack_item_included stk nxtp nxtc ∧ stack_item_tagged_NoDup stk.
Definition wf_non_empty (α: stacks) :=
  ∀ l stk, α !! l = Some stk → stk ≠ [].
Definition wf_no_dup (α: stacks) :=
  ∀ l stk, α !! l = Some stk → NoDup stk.
Definition wf_cid_incl (cids: call_id_stack) (nxtc: call_id) :=
  ∀ c : call_id, c ∈ cids → (c < nxtc)%nat.

Record state_wf' (s: state) := {
  state_wf_dom : dom (gset loc) s.(shp) ≡ dom (gset loc) s.(sst);
  state_wf_mem_tag : wf_mem_tag s.(shp) s.(snp);
  state_wf_stack_item : wf_stack_item s.(sst) s.(snp) s.(snc);
  state_wf_non_empty : wf_non_empty s.(sst);
  state_wf_cid_no_dup : NoDup s.(scs) ;
  state_wf_cid_agree: wf_cid_incl s.(scs) s.(snc);
  (* state_wf_cid_non_empty : s.(scs) ≠ []; *)
  (* state_wf_no_dup : wf_no_dup σ.(cst).(sst); *)
}.

Instance state_wf : Wellformed state :=  state_wf'.
Instance config_wf : Wellformed config := λ cfg, Wf cfg.(cst).

Fixpoint active_SRO (stk: stack) : gset ptr_id :=
  match stk with
  | [] => ∅
  | it :: stk =>
    match it.(perm) with
    | SharedReadOnly => match it.(tg) with
                        | Tagged t => {[t]} ∪ active_SRO stk
                        | Untagged => active_SRO stk
                        end
    | _ => ∅
    end
  end.

Notation terminal e := (is_Some (to_result e)).
Lemma expr_terminal_False (e: expr) : ¬ terminal e ↔ to_result e = None.
Proof.
  split.
  - destruct (to_result e) eqn:Eqv; [|done].
    intros TERM. exfalso. apply TERM. by eexists.
  - intros Eq1 [? Eq2]. by rewrite Eq1 in Eq2.
Qed.

(** IntoResult is like IntoVal but works with our parameterized semantics. *)
Class IntoResult (e: expr) (r: result) := into_result : of_result r = e.
Global Instance val_into_result (v: value) : IntoResult v v.
Proof. done. Qed.
Global Instance place_into_result l tg ty : IntoResult (Place l tg ty) (PlaceR l tg ty).
Proof. done. Qed.
Global Instance result_into_result r : IntoResult (of_result r) r.
Proof. done. Qed.

Lemma into_result_terminal e r :
  IntoResult e r → terminal e.
Proof. intros <-. destruct r; eauto. Qed.

(** Thread steps *)
Inductive tstep (fns: fn_env) (eσ1 eσ2 : expr * state) : Prop :=
| ThreadStep ev efs
    (PRIM: prim_step (Λ:= bor_ectx_lang fns) eσ1.1 eσ1.2 ev eσ2.1 eσ2.2 efs)
.

Notation "x ~{ fn }~> y" := (tstep fn x y) (at level 70, format "x  ~{ fn }~>  y").
Notation "x ~{ fn }~>* y" := (rtc (tstep fn) x y)
  (at level 70, format "x  ~{ fn }~>*  y").
Notation "x ~{ fn }~>+ y" := (tc (tstep fn) x y)
  (at level 70, format "x  ~{ fn }~>+  y").

Definition reducible fs e σ := (∃ e' σ', (e,σ) ~{fs}~> (e', σ')).
Definition never_stuck fs e σ :=
  ∀ e' σ', (e, σ) ~{fs}~>* (e', σ') → terminal e' ∨ reducible fs  e' σ'.

Definition init_expr := (Call #["main"] []).
Definition init_state := (mkState ∅ ∅ [O] O 1).

(*=================================== UNUSED =================================*)
(* Implicit Type (ρ: cfg bor_lang). *)

(* TODO: this may need strengthening *)
(* Definition cfg_wf' ρ : Prop := Wf ρ.2. *)
(* Instance cfg_wf : Wellformed (cfg bor_lang) :=  cfg_wf'. *)

(* Definition threads_terminal' (el: list expr) := ∀ e, e ∈ el → terminal e. *)
(* Instance threads_terminal : Terminal (list expr) := threads_terminal'. *)
(* Definition cfg_terminal' ρ : Prop := terminal ρ.1. *)
(* Instance cfg_terminal : Terminal (cfg bor_lang) := cfg_terminal'. *)


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export close_type_sys.
Require Export Peano.
(** printing #  $\times$ #×# *)
(** printing <=>  $\Leftrightarrow$ #⇔# *)
(** printing ~<~  $\preceq$ *)
(** printing ~=~  $\sim$ *)
(** printing ===>  $\Downarrow$ *)
(** printing [[  $[$ *)
(** printing ]]  $]$ *)
(** printing \\  $\backslash$ *)
(** printing mkc_axiom   $\mathtt{Ax}$ *)
(** printing mkc_base    $\mathtt{Base}$ *)
(** printing mkc_int     $\intg$ *)
(** printing mkc_integer $\mathtt{int}$ *)
(* begin hide *)

Lemma defines_only_universes_univi {o} :
  forall lib i, @defines_only_universes o lib (univi lib i).
Proof.
  unfold defines_only_universes; sp.
  allrw @univi_exists_iff; sp.
  exists j; sp.
Qed.

Lemma defines_only_universes_univ {o} :
  forall lib, @defines_only_universes o lib (univ lib).
Proof.
  unfold defines_only_universes, univ; sp.
  induction i; allsimpl; sp.
  exists i; sp.
Qed.

(* end hide *)

(**

  We prove that all the Nuprl universes satisfy the type system
  properties.

*)

Lemma univi_type_system {o} :
  forall lib (i : nat), @type_system o lib (univi lib i).
Proof.
  induction i using comp_ind_type.
  unfold type_system; sp.

  - unfold uniquely_valued, eq_term_equals; sp.
    allrw @univi_exists_iff; sp.
    spcast; computes_to_eqval.
    allrw; sp.

  - introv q h.
    allrw @univi_exists_iff; exrepnd.
    exists j; sp.
    rw <- h; auto.

  - unfold type_symmetric; sp.
    allrw @univi_exists_iff; sp.
    exists j; sp.

  - unfold type_transitive; sp.
    allrw @univi_exists_iff; sp.
    spcast; computes_to_eqval.
    eexists; sp; spcast; sp.

  - unfold type_value_respecting; sp.
    allrw @univi_exists_iff; sp.
    exists j; sp; thin_trivials.
    spcast; apply cequivc_uni with (t := T); auto.

  - unfold term_symmetric, term_equality_symmetric; sp.
    allrw @univi_exists_iff; sp; spcast.
    discover; sp.
    allrw.
    exists eqa; auto.
    generalize (@close_type_system o lib (univi lib j)); intro k.
    repeat (dest_imp k hyp).
    apply defines_only_universes_univi.
    inversion k; sp.

  - unfold term_transitive, term_equality_transitive; sp.
    allrw @univi_exists_iff; sp.
    discover; sp; spcast.
    allrw.
    generalize (@close_type_system o lib (univi lib j)); intro k.
    repeat (dest_imp k hyp).
    apply defines_only_universes_univi.
    inversion k; sp.
    exists eqa0.
    apply uniquely_valued_trans4 with (T2 := t2) (eq1 := eqa); sp.

  - unfold term_value_respecting, term_equality_respecting; sp.
    allrw @univi_exists_iff; sp.
    discover; sp; spcast; GC.
    allrw.
    exists eqa.
    generalize (@close_type_system o lib (univi lib j)); intro k.
    repeat (dest_imp k hyp).
    apply defines_only_universes_univi.
    inversion k; sp.
Qed.

(* begin hide *)

Lemma nuprli_type_system {o} :
  forall lib (i : nat), @type_system o lib (nuprli lib i).
Proof.
  unfold nuprli; sp.
  apply close_type_system.
  apply univi_type_system.
  apply defines_only_universes_univi.
Qed.

Lemma nuprli_uniquely_valued {o} :
  forall lib i1 i2 (T T' : @CTerm o) eq eq',
    nuprli lib i1 T T' eq
    -> nuprli lib i2 T T' eq'
    -> eq_term_equals eq eq'.
Proof.
  sp.
  assert (nuprli lib (i2 + i1) T T' eq) as c1 by (apply typable_in_higher_univ; auto).
  assert (nuprli lib (i1 + i2) T T' eq') as c2 by (apply typable_in_higher_univ; auto).
  assert (i1 + i2 = i2 + i1) as e by omega.
  rww e.
  generalize (@nuprli_type_system o lib (i2 + i1)); intro nts.
  destruct nts; sp.
  unfold uniquely_valued in u.
  apply u with (T := T) (T' := T'); auto.
Qed.

Lemma nuprli_type_transitive {o} :
  forall lib i1 i2 (T1 T2 T3 : @CTerm o) eq,
    nuprli lib i1 T1 T2 eq
    -> nuprli lib i2 T2 T3 eq
    -> {i : nat & nuprli lib i T1 T3 eq # i1 <= i # i2 <= i}.
Proof.
  sp.
  assert (nuprli lib (i1 + i2) T1 T2 eq) as c1 by (apply typable_in_higher_univ_r; auto).
  assert (nuprli lib (i1 + i2) T2 T3 eq) as c2 by (apply typable_in_higher_univ; auto).
  exists (i1 + i2); sp; try omega.
  generalize (@nuprli_type_system o lib (i1 + i2)); intro nts.
  destruct nts; sp.
  apply p2 with (T2 := T2); sp.
Qed.

Lemma univi_uniquely_valued {o} :
  forall lib i1 i2 (T T' : @CTerm o) eq eq',
    univi lib i1 T T' eq
    -> univi lib i2 T T' eq'
    -> eq_term_equals eq eq'.
Proof.
  sp.
  assert (univi lib (i2 + i1) T T' eq) as c1 by (apply uni_in_higher_univ; auto).
  assert (univi lib (i1 + i2) T T' eq') as c2 by (apply uni_in_higher_univ; auto).
  assert (i1 + i2 = i2 + i1) as e by omega.
  rww e.
  generalize (@univi_type_system o lib (i2 + i1)); intro uts.
  destruct uts; sp.
  unfold uniquely_valued in u.
  apply u with (T := T) (T' := T'); auto.
Qed.

(* end hide *)

(**

  We prove that that [univ] satisfies the type system properties.

*)

Lemma univ_type_system {o} : forall lib, @type_system o lib (univ lib).
Proof.
  unfold univ, type_system; sp.

  - unfold uniquely_valued; sp.
    apply (univi_uniquely_valued lib) with (i1 := i0) (i2 := i) (T := T) (T' := T'); auto.

  - unfold type_extensionality; sp.
    exists i.
    generalize (@univi_type_system o lib i); intro uts.
    dest_ts uts.
    unfold type_extensionality in ts_ext.
    apply ts_ext with (eq := eq); auto.

  - unfold type_symmetric; sp.
    exists i.
    generalize (@univi_type_system o lib i); intro uts.
    dest_ts uts; auto.

  - unfold type_transitive; introv u1 u2; exrepnd.
    apply uni_in_higher_univ with (k := i0) in u0.
    apply uni_in_higher_univ_r with (k := i) in u2.
    exists (i0 + i).
    generalize (@univi_type_system o lib (i0 + i)); intro uts.
    dest_ts uts; auto.
    apply ts_tyt with (T2 := T2); auto.

  - unfold type_value_respecting; sp.
    exists i.
    generalize (@univi_type_system o lib i); intro uts.
    dest_ts uts; sp.

  - unfold term_symmetric, term_equality_symmetric; introv u e1; exrepnd.
    generalize (@univi_type_system o lib i); intro uts.
    dest_ts uts; sp.
    apply ts_tes in u0.
    apply u0; auto.

  - unfold term_transitive, term_equality_transitive; introv u e1 e2; exrepnd.
    generalize (@univi_type_system o lib i); intro uts.
    dest_ts uts; sp.
    apply ts_tet in u0.
    apply u0 with (t2 := t2); auto.

  - unfold term_value_respecting, term_equality_respecting; introv u e1 c1; exrepnd.
    generalize (@univi_type_system o lib i); intro uts.
    dest_ts uts; sp.
    apply ts_tev in u0.
    apply u0; auto.
Qed.

(**

  Finally, we prove that that [nuprl] satisfies the type system properties.

*)

Lemma nuprl_type_system {p} : forall lib, @type_system p lib (nuprl lib).
Proof.
  introv.
  apply close_type_system.
  apply univ_type_system.
  apply defines_only_universes_univ.
Qed.

(* begin hide *)

(** Here is a tactic to use the fact that nuprl is a type system *)
Ltac nts :=
  match goal with
      [ p : POpid , lib : library |- _ ] =>
      pose proof (@nuprl_type_system p lib) as nts;
        destruct nts as [ nts_uv nts ];
        destruct nts as [ nts_ext nts ];
        destruct nts as [ nts_tys nts ];
        destruct nts as [ nts_tyt nts ];
        destruct nts as [ nts_tyv nts ];
        destruct nts as [ nts_tes nts ];
        destruct nts as [ nts_tet nts_tev ]
  end.

Lemma nuprl_refl {p} :
  forall lib (t1 t2 : @CTerm p) eq,
    nuprl lib t1 t2 eq -> nuprl lib t1 t1 eq.
Proof.
  intros.
  nts.
  assert (nuprl lib t2 t1 eq); sp.
  use_trans t2; sp.
Qed.

Lemma nuprl_sym {p} :
  forall lib (t1 t2 : @CTerm p) eq,
    nuprl lib t1 t2 eq -> nuprl lib t2 t1 eq.
Proof.
  intros; nts; sp.
Qed.

Lemma nuprl_trans {p} :
  forall lib (t1 t2 t3 : @CTerm p) eq1 eq2,
    nuprl lib t1 t2 eq1 -> nuprl lib t2 t3 eq2 -> nuprl lib t1 t3 eq1.
Proof.
  introv n1 n2; nts.
  use_trans t2; sp.
  use_ext eq2; sp.
  apply uniquely_valued_eq with (ts := nuprl lib) (T := t2) (T1 := t3) (T2 := t1); sp.
Qed.

Lemma nuprl_uniquely_valued {p} :
  forall lib (t : @CTerm p) eq1 eq2,
    nuprl lib t t eq1
    -> nuprl lib t t eq2
    -> eq_term_equals eq1 eq2.
Proof.
  introv n1 n2; nts.
  apply nts_uv with (T := t) (T' := t); sp.
Qed.

Lemma nuprl_value_respecting_left {p} :
  forall lib (t1 t2 t3 : @CTerm p) eq,
    nuprl lib t1 t2 eq
    -> cequivc lib t1 t3
    -> nuprl lib t3 t2 eq.
Proof.
  intros.
  nts.
  assert (nuprl lib t1 t3 eq) as eq13
    by (apply nts_tyv; auto; apply nts_tyt with (T2 := t2); auto).
  apply nts_tyt with (T2 := t1); auto.
Qed.

Lemma nuprl_value_respecting_right {p} :
  forall lib t1 t2 t3 eq,
    @nuprl p lib t1 t2 eq
    -> cequivc lib t2 t3
    -> nuprl lib t1 t3 eq.
Proof.
  intros.
  nts.
  assert (nuprl lib t2 t3 eq) as eq23
    by (apply nts_tyv; auto; apply nts_tyt with (T2 := t1); auto).
  apply nts_tyt with (T2 := t2); auto.
Qed.

Lemma nuprl_eq_implies_eqorceq_refl {p} :
  forall lib T1 T2 eq t1 t2,
    @nuprl p lib T1 T2 eq
    -> eq t1 t2
    -> eqorceq lib eq t1 t1 # eqorceq lib eq t2 t2.
Proof.
  introv n e.
  nts; sp; left.
  unfold term_transitive, term_equality_transitive in nts_tet.
  apply nts_tet with (t2 := t2) (T := T1) (T' := T2); sp.
  unfold term_symmetric, term_equality_symmetric in nts_tes.
  apply nts_tes with (T := T1) (T' := T2); sp.
  unfold term_transitive, term_equality_transitive in nts_tet.
  apply nts_tet with (t2 := t1) (T := T1) (T' := T2); sp.
  unfold term_symmetric, term_equality_symmetric in nts_tes.
  apply nts_tes with (T := T1) (T' := T2); sp.
Qed.

(* end hide *)


(* Class Cl (a : Type).
Parameter A : Type.
Instance cl_a : Cl A.

Parameter Foo Bar : Type -> Type.

Parameter conv : forall {k} `{Cl k}, Foo k -> Bar k.
Parameter func : Bar A -> bool.

Coercion conv : Foo >-> Bar.

Fail Definition test (b : Foo A) : bool := func b. *)

Class Cl (a : Type).
Parameter A : Type.
Declare Instance cl_a : Cl A.

Parameter Foo Bar : Type -> Type.

Parameter conv : forall {k} `{Cl k}, Foo k -> Bar k.
Parameter func : forall {a}, Bar a -> bool.

SubClass FooA := Foo A.
SubClass BarA := Bar A.
Coercion conv_A := conv : FooA -> BarA.
(* Not used, doesn't help *)
(* Coercion bar_a_back := @id _ : BarA -> Bar A.
Coercion foo_a_back := @id _ : FooA -> Foo A. *)

(* Not usable, it violates uniform inheritance *)
(* Coercion conv_A' := conv : Foo A -> Bar A. *)

Definition test1 (b : FooA) : bool := func b.
Fail Definition test2 (b : Foo A) : bool := func b.
(* Print Coercion Paths Foo BarA. *)

Definition func_A : Bar A -> bool := func.

Definition test_3 (b : FooA) : bool := func_A b.
Fail Definition test_4 (b : Foo A) : bool := func_A b.

Definition func_A_1 : BarA -> bool := func.

Definition test_5 (b : FooA) : bool := func_A_1 b.
Fail Definition test_6 (b : Foo A) : bool := func_A_1 b.


Require Import VST.floyd.base2.
Require Import VST.floyd.fieldlist.
Require Import VST.floyd.computable_theorems.
Import compcert.lib.Maps.
Open Scope nat.

Inductive ListType: list Type -> Type :=
  | Nil: ListType nil
  | Cons: forall {A B} (a: A) (b: ListType B), ListType (A :: B).

Fixpoint ListTypeGen {A} (F: A -> Type) (f: forall A, F A) (l: list A) : ListType (map F l) :=
  match l with
  | nil => Nil
  | cons h t => Cons (f h) (ListTypeGen F f t)
  end.

Lemma ListTypeGen_preserve: forall A F f1 f2 (l: list A),
  (forall a, In a l -> f1 a = f2 a) ->
  ListTypeGen F f1 l = ListTypeGen F f2 l.
Proof.
  intros.
  induction l.
  + reflexivity.
  + simpl.
    rewrite H, IHl.
    - reflexivity.
    - intros; apply H; simpl; tauto.
    - simpl; left; auto.
Defined.

Definition decay' {X} {F: Type} {l: list X} (v: ListType (map (fun _ => F) l)): list F.
  remember (map (fun _ : X => F) l) eqn:E.
  revert l E.
  induction v; intros.
  + exact nil.
  + destruct l; inversion E.
    specialize (IHv l H1).
    rewrite H0 in a.
    exact (a :: IHv).
Defined.

Fixpoint decay'' {X} {F: Type} (l0 : list Type) (v: ListType l0) :
  forall (l: list X), l0 = map (fun _ => F) l -> list F :=
  match v in ListType l1
    return forall l2, l1 = map (fun _ => F) l2 -> list F
  with
  | Nil => fun _ _ => nil
  | Cons A B a b =>
    fun (l1 : list X) (E0 : A :: B = map (fun _ : X => F) l1) =>
    match l1 as l2 return (A :: B = map (fun _ : X => F) l2 -> list F) with
    | nil => fun _ => nil (* impossible case *)
    | x :: l2 =>
       fun E1 : A :: B = map (fun _ : X => F) (x :: l2) =>
       (fun
          X0 : map (fun _ : X => F) (x :: l2) =
               map (fun _ : X => F) (x :: l2) -> list F =>
        X0 eq_refl)
         match
           E1 in (_ = y)
           return (y = map (fun _ : X => F) (x :: l2) -> list F)
         with
         | eq_refl =>
             fun H0 : A :: B = map (fun _ : X => F) (x :: l2) =>
              (fun (H3 : A = F) (H4 : B = map (fun _ : X => F) l2) =>
                  (eq_rect A (fun A0 : Type => A0) a F H3) :: (decay'' B b l2 H4))
                 (f_equal
                    (fun e : list Type =>
                     match e with
                     | nil => A
                     | T :: _ => T
                     end) H0)
                (f_equal
                   (fun e : list Type =>
                    match e with
                    | nil => B
                    | _ :: l3 => l3
                    end) H0)
         end
    end E0
  end.

Definition decay {X} {F: Type} {l: list X} (v: ListType (map (fun _ => F) l)): list F :=
  let l0 := map (fun _ => F) l in
  let E := @eq_refl _ (map (fun _ => F) l) : l0 = map (fun _ => F) l in
  decay'' l0 v l E.

Lemma decay_spec: forall A F f l,
  decay (ListTypeGen (fun _: A => F) f l) = map f l.
Proof.
  intros.
  unfold decay.
  induction l.
  + simpl.
    reflexivity.
  + simpl.
    f_equal.
    auto.
Defined.

Section COMPOSITE_ENV.
Context {cs: compspecs}.

Lemma type_ind: forall P : type -> Prop,
  (forall t,
  match t with
  | Tarray t0 _ _ => P t0
  | Tstruct id _ => let m := co_members (get_co id) in Forall (fun it => P (field_type (name_member it) m)) m
  | Tunion id _ => let m := co_members (get_co id) in Forall (fun it => P (field_type (name_member it) m)) m
  | _ => True
  end -> P t) ->
  forall t, P t.
Proof.
  intros P IH_TYPE.
  intros.
  remember (rank_type cenv_cs t) as n eqn: RANK'.
  assert (rank_type cenv_cs t <= n)%nat as RANK.
  subst. apply le_n.
  clear RANK'.
  revert t RANK.
  induction n;
  intros;
  specialize (IH_TYPE t); destruct t;
  try solve [specialize (IH_TYPE I); auto].
  + (* Tarray level 0 *)
    simpl in RANK. inv RANK.
  + (* Tstruct level 0 *)
    simpl in RANK.
    unfold get_co in IH_TYPE.
    destruct (cenv_cs ! i); [inv RANK | apply IH_TYPE; simpl; constructor].
  + (* Tunion level 0 *)
    simpl in RANK.
    unfold get_co in IH_TYPE.
    destruct (cenv_cs ! i); [inv RANK | apply IH_TYPE].
    simpl; constructor.
  + (* Tarray level positive *)
    simpl in RANK.
    specialize (IHn t).
    apply IH_TYPE, IHn.
    apply le_S_n; auto.
  + (* Tstruct level positive *)
    simpl in RANK.
    pose proof get_co_members_no_replicate i.
    unfold get_co in *.
    destruct (cenv_cs ! i) as [co |] eqn:CO; [| apply IH_TYPE; simpl; constructor].
    apply IH_TYPE; clear IH_TYPE.
    apply Forall_forall.
    intros ? ?; simpl.
    * apply IHn.
       pose proof In_field_type _ _ H H0.
    simpl in H1; rewrite H1.
    apply rank_type_members with (ce := cenv_cs) in H0.
    rewrite <- co_consistent_rank in H0.
    eapply le_trans; [eassumption |].
    apply le_S_n; auto.
    exact (cenv_consistent i co CO).
  + (* Tunion level positive *)
    simpl in RANK.
    pose proof get_co_members_no_replicate i.
    unfold get_co in *.
    destruct (cenv_cs ! i) as [co |] eqn:CO; [| apply IH_TYPE; simpl; constructor].
    apply IH_TYPE; clear IH_TYPE.
    apply Forall_forall.
    intros ? ?; simpl.
    apply IHn.
    pose proof In_field_type _ _ H H0.
    simpl in H1; rewrite H1.
    apply rank_type_members with (ce := cenv_cs) in H0.
    rewrite <- co_consistent_rank in H0.
    eapply le_trans; [eassumption |].
    apply le_S_n; auto.
    exact (cenv_consistent i co CO).
Defined.

Ltac type_induction t :=
  pattern t;
  match goal with
  | |- ?P t =>
    apply type_ind; clear t;
    let t := fresh "t" in
    intros t IH;
    let id := fresh "id" in
    let a := fresh "a" in
    destruct t as [| | | | | | | id a | id a]
  end.

Variable A: type -> Type.

Definition A_members (ms: members) (m: member) : Type :=
    A (field_type (name_member m) ms).

Definition FT_aux id :=
    let m := co_members (get_co id) in ListType (map (fun it => A (field_type (name_member it) m)) m).

Variable F_ByValue: forall t: type, A t.
Variable F_Tarray: forall t n a, A t -> A (Tarray t n a).
Variable F_Tstruct: forall id a, FT_aux id -> A (Tstruct id a).
Variable F_Tunion: forall id a, FT_aux id -> A (Tunion id a).

Fixpoint type_func_rec (n: nat) (t: type): A t :=
  match n with
  | 0 =>
    match t as t0 return A t0 with
    | Tstruct id a =>
       match cenv_cs ! id with
       | None => let m := co_members (get_co id) in
                       F_Tstruct id a (ListTypeGen (fun it => A (field_type (name_member it) m))
                                     (fun it => F_ByValue (field_type (name_member it) m)) m)
       | _ => F_ByValue (Tstruct id a)
       end
    | Tunion id a =>
       match cenv_cs ! id with
       | None => let m := co_members (get_co id) in
                      F_Tunion id a (ListTypeGen (fun it => A (field_type (name_member it) m))
                                     (fun it => F_ByValue (field_type (name_member it) m)) m)
       | _ => F_ByValue (Tunion id a)
       end
    | t' => F_ByValue t'
    end
  | S n' =>
    match t as t0 return A t0 with
    | Tarray t0 n a => F_Tarray t0 n a (type_func_rec n' t0)
    | Tstruct id a =>  let m := co_members (get_co id) in
                            F_Tstruct id a (ListTypeGen (fun it => A (field_type (name_member it) m))
                                        (fun it => type_func_rec n' (field_type (name_member it) m)) m)
    | Tunion id a =>  let m := co_members (get_co id) in
                            F_Tunion id a (ListTypeGen (fun it => A (field_type (name_member it) m))
                                        (fun it => type_func_rec n' (field_type (name_member it) m)) m)
    | t' => F_ByValue t'
    end
  end.

Definition type_func t := type_func_rec (rank_type cenv_cs t) t.

Lemma rank_type_Tstruct: forall id a co, cenv_cs ! id = Some co ->
  rank_type cenv_cs (Tstruct id a) = S (co_rank (get_co id)).
Proof.
  intros.
  unfold get_co; simpl.
  destruct (cenv_cs ! id); auto; congruence.
Defined.

Lemma rank_type_Tunion: forall id a co, cenv_cs ! id = Some co ->
  rank_type cenv_cs (Tunion id a) = S (co_rank (get_co id)).
Proof.
  intros.
  unfold get_co; simpl.
  destruct (cenv_cs ! id); auto; congruence.
Defined.

Lemma type_func_rec_rank_irrelevent: forall t n n0,
  n >= rank_type cenv_cs t ->
  n0 >= rank_type cenv_cs t ->
  type_func_rec n t = type_func_rec n0 t.
Proof.
 (* DON'T USE lia IN THIS PROOF!
   We want the proof to compute reasonably efficiently.
*)
  intros t.
  type_induction t;
  intros;
  try solve [destruct n; simpl; auto; destruct n0; simpl; auto].
  + (* Tarray *)
    destruct n; simpl in H; try solve [inv H].
    destruct n0; simpl in H; try solve [inv H0].
    simpl. f_equal.
    apply IH; apply le_S_n; auto.
  + (* Tstruct *)
    destruct (cenv_cs ! id) as [co |] eqn: CO.
    - erewrite rank_type_Tstruct in H by eauto.
      erewrite rank_type_Tstruct in H0 by eauto.
      clear co CO.
    destruct n; simpl in H; try solve [inv H].
    destruct n0; simpl in H; try solve [inv H0].
      simpl.
      f_equal.
      apply ListTypeGen_preserve.
      intros m Hin.
      simpl in IH.
      generalize (Forall_forall1 _ _ IH); clear IH; intro IH.
      specialize (IH _ Hin n n0).
      apply le_S_n in H; apply le_S_n in H0.
      assert (H3 := rank_type_members cenv_cs _ _ Hin).
      pose proof get_co_members_no_replicate id.
      pose proof In_field_type _ _ H1 Hin.
      rewrite <- (co_consistent_rank cenv_cs (get_co id) (get_co_consistent _)) in H3.
      unfold field_type in H2.
      apply IH;
       (eapply le_trans; [ | eassumption]; rewrite H2; auto).
    - destruct n, n0; simpl;  unfold FT_aux in *;
      generalize (F_Tstruct id a) as FF; unfold get_co;
      rewrite CO; intros; auto.
  + (* Tunion *)
    destruct (cenv_cs ! id) as [co |] eqn: CO.
    - erewrite rank_type_Tunion in H by eauto.
      erewrite rank_type_Tunion in H0 by eauto.
      clear co CO.
    destruct n; simpl in H; try solve [inv H].
    destruct n0; simpl in H; try solve [inv H0].
      simpl.
      f_equal.
      apply ListTypeGen_preserve.
      intros m Hin.
      generalize (Forall_forall1 _ _ IH); clear IH; intro IH.
      specialize (IH _ Hin n n0).
      apply le_S_n in H; apply le_S_n in H0.
      assert (H3 := rank_type_members cenv_cs _ _ Hin).
      pose proof get_co_members_no_replicate id.
      pose proof In_field_type _ _ H1 Hin.
      rewrite <- (co_consistent_rank cenv_cs (get_co id) (get_co_consistent _)) in H3.
      apply IH;
       (eapply le_trans; [ | eassumption]; rewrite H2; auto).
    - destruct n, n0; simpl;  unfold FT_aux in *;
      generalize (F_Tunion id a) as FF; unfold get_co;
      rewrite CO; intros; auto.
Defined.

Definition FTI_aux id :=
    let m := co_members (get_co id) in
    (ListTypeGen (fun it => A (field_type (name_member it) m)) (fun it => type_func (field_type (name_member it) m)) m).

Lemma type_func_eq: forall t,
  type_func t =
  match t as t0 return A t0 with
  | Tarray t0 n a => F_Tarray t0 n a (type_func t0)
  | Tstruct id a => F_Tstruct id a (FTI_aux id)
  | Tunion id a => F_Tunion id a (FTI_aux id)
  | t' => F_ByValue t'
  end.
Proof.
  intros.
  type_induction t; try reflexivity.
  + (* Tstruct *)
    unfold type_func in *.
    simpl type_func_rec.
    destruct (cenv_cs ! id) as [co |] eqn:CO; simpl.
    - f_equal.
      apply ListTypeGen_preserve; intro m.
      unfold get_co; rewrite CO.
      intro Hin.
      generalize (Forall_forall1 _ _ IH); clear IH; intro IH.
      apply type_func_rec_rank_irrelevent.
      * assert (H0 := get_co_members_no_replicate id).
        unfold get_co in H0; rewrite CO in H0.
        rewrite (In_field_type _ _ H0 Hin).
        rewrite (co_consistent_rank cenv_cs _
                           (cenv_consistent id co CO)).
        eapply rank_type_members; eauto.
      * apply le_n.
    - rewrite CO.
      f_equal.
      unfold FTI_aux, get_co; rewrite CO.
      reflexivity.
  + (* Tunion *)
    unfold type_func in *.
    simpl type_func_rec.
    destruct (cenv_cs ! id) as [co |] eqn:CO; simpl.
    - f_equal.
      apply ListTypeGen_preserve; intro m.
      unfold get_co; rewrite CO.
      intro Hin.
      generalize (Forall_forall1 _ _ IH); clear IH; intro IH.
      apply type_func_rec_rank_irrelevent.
      * assert (H0 := get_co_members_no_replicate id).
        unfold get_co in H0; rewrite CO in H0.
        rewrite (In_field_type _ _ H0 Hin).
        rewrite (co_consistent_rank cenv_cs _
                           (cenv_consistent id co CO)).
        eapply rank_type_members; eauto.
      * apply le_n.
    - rewrite CO.
      f_equal.
      unfold FTI_aux, get_co; rewrite CO.
      reflexivity.
Defined.

End COMPOSITE_ENV.

Arguments type_func {cs} A F_ByValue F_Tarray F_Tstruct F_Tunion t / .

Ltac type_induction t :=
  pattern t;
  match goal with
  | |- ?P t =>
    apply type_ind; clear t;
    let t := fresh "t" in
    intros t IH;
    let id := fresh "id" in
    let a := fresh "a" in
    destruct t as [| | | | | | | id a | id a]
  end.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import RVIC2.Specs.rvic_clear_flag.
Require Import RVIC2.LowSpecs.rvic_clear_flag.
Require Import RVIC2.RefProof.RefRel.

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

Section Refine.

  Hint Unfold
       interrupt_bitmap_dword_spec
       interrupt_bit_spec
       get_bitmap_loc_spec
       atomic_bit_clear_release_64_spec
    .

  Lemma shiftl4:
    forall n, Z.shiftl n 4 = n * 16.
  Proof.
    intros. Local Transparent Z.shiftl.
    unfold Z.shiftl; simpl. omega.
    Local Opaque Z.shiftl.
  Qed.

  Lemma rvic_clear_flag_spec_exists:
    forall habd habd'  labd intid bitmap
      (Hspec: rvic_clear_flag_spec intid bitmap habd = Some habd')
      (Hrel: relate_RData habd labd),
    exists labd', rvic_clear_flag_spec0 intid bitmap labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    intros. inv Hrel. destruct bitmap.
    unfold rvic_clear_flag_spec, rvic_clear_flag_spec0 in *.
    repeat autounfold in *. simpl in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; bool_rel; simpl in *; srewrite;
        repeat (simpl_htarget; grewrite; simpl in * ).
    - (solve_bool_range; grewrite). (solve_bool_range; grewrite). (solve_bool_range; grewrite).
      extract_if. rewrite shiftl4. apply andb_true_iff; split; bool_rel; omega. grewrite.
      (solve_bool_range; grewrite). rewrite a_plus_16; try omega.
      repeat (simpl_htarget; grewrite; simpl in * ).
      eexists; split. reflexivity. constructor.
      rewrite a_plus_16'; try omega. reflexivity.
    - (solve_bool_range; grewrite). (solve_bool_range; grewrite). (solve_bool_range; grewrite).
      extract_if. rewrite shiftl4. apply andb_true_iff; split; bool_rel; omega. grewrite.
      (solve_bool_range; grewrite). rewrite a_plus_16; try omega.
      repeat (simpl_htarget; grewrite; simpl in * ).
      eexists; split. reflexivity. constructor.
      rewrite a_plus_16'; try omega. reflexivity.
  Qed.

End Refine.