(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory
  InitVSpace_SI
imports
  "DSpecProofs.Invocation_DP"
  "DSpecProofs.Arch_DP"
  ObjectInitialised_SI
  RootTask_SI
  SysInit_SI
  DuplicateCaps_SI
  Sep_Algebra.Sep_Fold_Cancel
  Sep_Algebra.Sep_Util
  "HOL-Library.Multiset"
  Mapped_Separating_Conjunction
  AInvs.Rights_AI
  Lib.Guess_ExI
begin

context begin interpretation Arch . (*FIXME: arch_split*)

declare
  object_at_predicate_lift[simp]
  opt_cap_object_slot[simp]
  opt_cap_object_slotE[elim]
  slots_of_object_slot[simp]
  slots_of_object_slotE[elim]
  object_at_cdl_objects[simp]

(* Abbreviations for commonly appearing expressions involving virtual addresses and slots *)
(* TODO: use pd_size, pt_size, small_frame_size instead of magic numbers *)
abbreviation
  "pd_slot_of_pt_vaddr vaddr \<equiv> vaddr >> 20 :: machine_word"
abbreviation
  "pt_slot_of_vaddr vaddr \<equiv> (vaddr >> 12) && 0xFF :: machine_word"
abbreviation
  "pt_vaddr_of_pd_slot pd_slot \<equiv> of_nat pd_slot << 20 :: machine_word"
abbreviation
  "frame_vaddr_of_slots pd_slot pt_slot \<equiv>
    pt_vaddr_of_pd_slot pd_slot + (of_nat pt_slot << small_frame_size) :: machine_word"

(* FIXME: MOVE (Lib) *)
lemma singleton_eq[simp]: "(\<lambda>v. if v = x then Some y else None) = [x \<mapsto> y]"
  by (clarsimp simp: fun_upd_def)

lemma map_add_simp [simp]: "(\<lambda>p. if p = p' then Some v else f p) = f ++ [p' \<mapsto> v] "
  by (intro ext iffI; clarsimp simp: map_add_def split: option.splits)

lemma list_all_spec: "list_all P xs \<Longrightarrow> x \<in> set xs \<Longrightarrow> P x"
  by (simp add: list_all_iff)
(* /MOVE *)

lemma empty_cap_map_shiftr_NullCap:
  "empty_cap_map 12 (unat ((vaddr :: word32) >> 20)) = Some NullCap"
  apply (clarsimp simp:empty_cap_map_def)
  apply (rule unat_less_helper)
  apply simp
  apply (subst word32_less_sub_le[where n=12, simplified, symmetric])
   apply (simp add: word_bits_def)
  apply (simp add: shiftr_shiftr le_mask_iff[where n=12, unfolded mask_def, simplified])
  apply (rule shiftr_eq_0)
  apply simp
  done

lemma object_slot_initialised_lookup:
  "\<lbrakk>t spec_ptr = Some ptr; opt_cap (spec_ptr,slot) spec = Some cap\<rbrakk>
   \<Longrightarrow> object_slot_initialised spec t spec_ptr slot = (ptr, slot) \<mapsto>c cap_transform t cap"
  apply (clarsimp simp: object_slot_initialised_def
                        object_initialised_general_def opt_cap_def slots_of_def
                 split: option.splits)
  apply (intro ext iffI)
   apply (drule sep_map_c_sep_map_s[where cap = "cap_transform t cap"])
    apply (simp add: spec2s_def update_slots_def object_slots_def split: cdl_object.splits)
   apply simp
  apply (subst (asm) sep_map_c_def2)
  apply (clarsimp simp: spec2s_def sep_map_s_def sep_map_general_def object_to_sep_state_def)
  apply (rule ext)
  apply (clarsimp simp: object_project_def object_slots_object_clean)
  apply (clarsimp simp: update_slots_def object_slots_def split: cdl_object.splits)
  done

lemma seL4_Page_Map_object_initialised_sep:
  "\<lbrace>\<guillemotleft>object_slot_initialised spec t spec_pd_ptr (unat (vaddr >> 20)) \<and>*
    object_slot_empty spec t (cap_object pt_cap) (unat (pt_slot_of_vaddr vaddr)) \<and>*
    (si_cnode_id , offset sel4_page si_cnode_size) \<mapsto>c
      FrameCap dev page_ptr vm_read_write n Real None \<and>*
    (si_cnode_id , offset sel4_pd si_cnode_size) \<mapsto>c (PageDirectoryCap pd_ptr Real None) \<and>*
    si_objects \<and>* R\<guillemotright> and
  K(pd_at spec_pd_ptr spec \<and>
    opt_cap (spec_pd_ptr, unat (vaddr >> 20)) spec = Some pt_cap \<and>
    pt_cap = PageTableCap spec_pt_ptr Fake None \<and>
    opt_cap (spec_pt_ptr, unat (pt_slot_of_vaddr vaddr)) spec
      = Some (FrameCap False spec_page_ptr (validate_vm_rights rights) n Fake None) \<and>
    cdl_objects spec (cap_object pt_cap) = Some cap_obj \<and>
    sel4_page < 2 ^ si_cnode_size \<and>
    vaddr = frame_vaddr_of_slots (unat (pd_slot_of_pt_vaddr vaddr))
                                 (unat (pt_slot_of_vaddr vaddr)) \<and>
    sel4_pd < 2 ^ si_cnode_size \<and>
    object_slots (object_default_state cap_obj) (unat (pt_slot_of_vaddr vaddr)) = Some cap_slots \<and>
    (n = 12 \<or> n = 16) \<and>
    t (cap_object pt_cap) = Some pt_ptr \<and>
    t spec_pd_ptr = Some pd_ptr \<and>
    t spec_page_ptr = Some page_ptr)\<rbrace>
     seL4_Page_Map sel4_page sel4_pd vaddr rights vmattribs
   \<lbrace>\<lambda>rv. \<guillemotleft>object_slot_initialised spec t spec_pd_ptr (unat (vaddr >> 20)) \<and>*
   object_slot_initialised spec t (cap_object pt_cap) (unat (pt_slot_of_vaddr vaddr)) \<and>*
   (si_cnode_id , offset sel4_page si_cnode_size) \<mapsto>c
      FrameCap dev page_ptr vm_read_write n Real None \<and>*
   (si_cnode_id , offset sel4_pd si_cnode_size) \<mapsto>c (PageDirectoryCap pd_ptr Real None) \<and>*
   si_objects \<and>* R\<guillemotright>\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (wp sep_wp: seL4_Page_Map_wp[where n=n and cnode_cap= si_cspace_cap and
                                           root_size = si_cnode_size and pt_ptr = pt_ptr])
          apply fastforce+
     apply (simp add: word_bits_def guard_equal_si_cspace_cap)+
  apply clarsimp
  apply sep_cancel+
  apply (clarsimp simp: si_objects_def sep_conj_assoc sep_state_projection2_def root_tcb_def
                        update_slots_def)
  apply sep_cancel+
  apply (clarsimp simp: object_slot_empty_def object_fields_empty_def
                        object_initialised_general_def si_objects_def cdl_lookup_pd_slot_def
                        root_tcb_def update_slots_def validate_vm_rights_inter_rw)
  apply (sep_drule sep_map_c_sep_map_s)
   apply (clarsimp, fastforce)
  apply (clarsimp simp: object_slot_initialised_lookup shiftr_less cap_object_def)
  apply sep_solve
  done

lemma seL4_PageTable_Map_object_initialised_sep:
  "\<lbrace>\<guillemotleft>object_slot_empty spec t pd_id (unat (shiftr vaddr 20)) \<and>*
   (si_cnode_id, offset sel4_pt si_cnode_size) \<mapsto>c (PageTableCap pt_ptr Real None) \<and>*
   (si_cnode_id, offset sel4_pd si_cnode_size) \<mapsto>c (PageDirectoryCap pd_ptr Real None) \<and>*
    si_objects \<and>* R\<guillemotright> and K(
    well_formed spec \<and>
    pd_at pd_id spec \<and>
    opt_cap (pd_id, unat (shiftr vaddr 20)) spec = Some (PageTableCap pt_id Fake None) \<and>

    sel4_pt < 2 ^ si_cnode_size \<and>
    sel4_pd < 2 ^ si_cnode_size \<and>

    t pd_id = Some pd_ptr \<and>
    t pt_id = Some pt_ptr)\<rbrace>
     seL4_PageTable_Map sel4_pt sel4_pd vaddr vmattribs
  \<lbrace>\<lambda>rv. \<guillemotleft>object_slot_initialised spec t pd_id (unat (shiftr vaddr 20)) \<and>*
   (si_cnode_id, offset sel4_pt si_cnode_size) \<mapsto>c (PageTableCap pt_ptr Real None) \<and>*
   (si_cnode_id, offset sel4_pd si_cnode_size) \<mapsto>c (PageDirectoryCap pd_ptr Real None) \<and>*
    si_objects \<and>* R\<guillemotright>\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (clarsimp simp: object_slot_initialised_lookup cap_transform_def
                        update_cap_object_def object_at_def is_pd_def)
  apply (clarsimp split:cdl_object.split_asm)
  apply (wp add: seL4_Page_Table_Map[where cnode_cap = si_cspace_cap
                                       and root_size = si_cnode_size
                                       and ptr = pt_ptr
                                       and pd_ptr = pd_ptr,
                                     sep_wandise])
         apply (simp add: word_bits_def guard_equal_si_cspace_cap)+
  apply (clarsimp simp: si_objects_def  sep_state_projection2_def object_slot_empty_def
                        object_fields_empty_def object_initialised_general_def cdl_lookup_pd_slot_def
                        root_tcb_def update_slots_def)
  apply sep_cancel+
  apply (sep_drule sep_map_c_sep_map_s)
   apply (fastforce simp: object_default_state_def object_type_def default_object_def
                          object_slots_def empty_cap_map_shiftr_NullCap)
  by sep_solve

lemma assert_opt_validI:
  assumes w: "\<And>a. r = Some a \<Longrightarrow> \<lbrace>P\<rbrace> f a \<lbrace>Q\<rbrace>"
  shows "\<lbrace>P\<rbrace> (assert_opt r) >>= f \<lbrace>Q\<rbrace>"
  using w
  by (clarsimp simp:assert_opt_def split:option.split)

lemma sep_caps_at_split: "a \<in> A \<Longrightarrow>
  si_caps_at t orig_caps spec dev A = (
  si_cap_at t orig_caps spec dev a \<and>* si_caps_at t orig_caps spec dev (A - {a}))"
  apply (simp add:si_caps_at_def)
  apply (subst sep.prod.union_disjoint [where A = "{a}", simplified, symmetric])
   apply simp
  apply (simp add:insert_absorb)
  done

lemma duplicate_frame_cap_sep:
  "\<lbrace>\<guillemotleft>(si_cnode_id, unat free_cptr) \<mapsto>c NullCap \<and>*
    si_caps_at t orig_caps spec dev {obj_id. real_object_at obj_id spec} \<and>* si_objects \<and>* R\<guillemotright> and K (
    well_formed spec \<and>
    unat free_cptr < 2 ^ si_cnode_size \<and>
    frame_at obj_id spec)\<rbrace>
      duplicate_cap spec orig_caps (obj_id, free_cptr)
  \<lbrace>\<lambda>_.
   \<guillemotleft>si_cap_at t (map_of [(obj_id, free_cptr)]) spec dev obj_id
    \<and>* si_caps_at t orig_caps spec dev {obj_id. real_object_at obj_id spec}
    \<and>* si_objects
    \<and>* R\<guillemotright>\<rbrace>"
  apply (wp sep_wp: duplicate_cap_sep_general[
        where free_cptr=free_cptr and
          free_cptrs="[free_cptr]" and
          obj_ids="obj_id # (sorted_list_of_set (dom (cdl_objects spec) - {obj_id}))" and
          spec=spec and
          obj_id=obj_id and
          obj_filter=frame_at])
  apply (clarsimp simp: object_at_def wf_obj_filter_frame_at, intro conjI)
   apply sep_solve
  apply fastforce
  done

lemma si_caps_at_take_2:
  "\<lbrakk>well_formed spec;
    pd_at spec_pd_ptr spec;
    frame_at spec_pt_section_ptr spec\<rbrakk>
   \<Longrightarrow> si_caps_at t orig_caps spec dev {obj_id. real_object_at obj_id spec} =
           (si_cap_at t orig_caps spec dev spec_pd_ptr \<and>*
            si_cap_at t orig_caps spec dev spec_pt_section_ptr \<and>*
            si_caps_at t orig_caps spec dev ({obj_id. real_object_at obj_id spec} -
                                                      {spec_pd_ptr} - {spec_pt_section_ptr}))"
  apply (frule (1) object_at_real_object_at)
  apply (frule (1) object_at_real_object_at[where obj_id=spec_pt_section_ptr])
  apply (clarsimp simp: object_at_def is_pd_def is_frame_def is_pt_def split: cdl_object.split_asm)
  by (metis sep_caps_at_split[where a="spec_pd_ptr"]
            sep_caps_at_split[where a="spec_pt_section_ptr"]
            cdl_object.exhaust mem_Collect_eq member_remove option.inject remove_def)

lemma si_caps_at_take_2_not_object_at:
  "\<lbrakk>well_formed spec;
    cdl_objects spec spec_pd_ptr = Some pd;
    is_pd pd;
    cdl_objects spec spec_pt_section_ptr = Some frame;
    is_frame frame\<rbrakk>
   \<Longrightarrow> si_caps_at t orig_caps spec dev {obj_id. real_object_at obj_id spec} =
           (si_cap_at t orig_caps spec dev spec_pd_ptr \<and>*
            si_cap_at t orig_caps spec dev spec_pt_section_ptr \<and>*
            si_caps_at t orig_caps spec dev ({obj_id. real_object_at obj_id spec} -
                                                      {spec_pd_ptr} - {spec_pt_section_ptr}))"
  by (erule si_caps_at_take_2; fastforce simp: object_at_def)

lemma si_caps_at_take_2':
  "\<lbrakk>well_formed spec;
      pd_at spec_pd_ptr spec;
      pt_at spec_pt_section_ptr spec \<rbrakk>
   \<Longrightarrow> si_caps_at t orig_caps spec dev {obj_id. real_object_at obj_id spec} =
           (si_cap_at t orig_caps spec dev spec_pd_ptr \<and>*
            si_cap_at t orig_caps spec dev spec_pt_section_ptr \<and>*
            si_caps_at t orig_caps spec dev ({obj_id. real_object_at obj_id spec} -
                                                      {spec_pd_ptr} - {spec_pt_section_ptr}))"
  apply (frule (1) object_at_real_object_at)
  apply (frule (1) object_at_real_object_at[where obj_id=spec_pt_section_ptr])
  apply (clarsimp simp: object_at_def is_pd_def is_frame_def is_pt_def split: cdl_object.split_asm)
  by (metis sep_caps_at_split[where a="spec_pd_ptr"]
            sep_caps_at_split[where a="spec_pt_section_ptr"]
            cdl_object.exhaust mem_Collect_eq member_remove option.inject remove_def)

lemma frame_at_default_cap[simp]:
  "well_formed spec \<Longrightarrow>
   is_frame frame \<Longrightarrow>
   cdl_objects spec (cap_object frame_cap) = Some frame \<Longrightarrow>
   opt_cap (parent_id, slot) spec = Some frame_cap \<Longrightarrow>
   is_fake_frame_cap frame_cap \<Longrightarrow>
   t (cap_object frame_cap) = Some ptr' \<Longrightarrow>
   default_cap (object_type frame) {ptr'} (object_size_bits frame) False
     = conjure_real_frame_cap frame_cap t"
  apply (clarsimp simp: si_caps_at_take_2  si_cap_at_def object_type_is_object object_at_def
                        default_cap_def object_type_def wf_frame_cap_frame_size_bits
                        offset_slot_si_cnode_size' vm_read_write_def si_objects_def)
  apply (clarsimp simp: is_frame_def split: cdl_object.splits)
  apply (clarsimp split: cdl_cap.splits cdl_frame_cap_type.splits option.splits)
  apply (drule_tac frame=x8 in wf_frame_cap_frame_size_bits)
  by (fastforce simp: vm_read_write_def conjure_real_frame_cap_def dev_of_def)+

lemma is_frame_default_cap[simp]:
  "well_formed spec \<Longrightarrow>
   frame_at (cap_object frame_cap) spec \<Longrightarrow>
   cdl_objects spec (cap_object frame_cap) = Some obj \<Longrightarrow>
   opt_cap (parent_id, slot) spec = Some frame_cap \<Longrightarrow>
   is_fake_frame_cap frame_cap \<Longrightarrow>
   t (cap_object frame_cap) = Some ptr' \<Longrightarrow>
   default_cap (object_type obj) {ptr'} (object_size_bits obj) False
     = conjure_real_frame_cap frame_cap t"
  by (fastforce dest!: frame_at_default_cap simp: object_at_def)

lemma pt_slot_compute[simp]:
  "pt_slot < 2 ^ 8 \<Longrightarrow> unat (pt_slot_of_vaddr (frame_vaddr_of_slots pd_slot pt_slot)) = pt_slot"
  apply (clarsimp simp:pt_size_def small_frame_size_def)
  apply (rule of_nat_inverse)
   apply (drule of_nat_mono_maybe[rotated,where 'a=32])
    apply simp
   apply word_bitwise
   apply simp
  apply simp
  done

lemma pd_slot_compute_from_pt[simp]:
  "pd_slot < 2 ^ 12 \<Longrightarrow>
   pt_slot < 2 ^ 8 \<Longrightarrow>
   unat (pd_slot_of_pt_vaddr (frame_vaddr_of_slots pd_slot pt_slot)) = pd_slot"
  apply (clarsimp simp: cdl_lookup_pd_slot_def pt_size_def small_frame_size_def)
  apply (rule of_nat_inverse)
   apply (drule of_nat_mono_maybe[rotated,where 'a=32],simp)+
   apply (subst is_aligned_add_or [where n=20])
     apply (rule is_aligned_shiftl, simp)
    apply (rule shiftl_less_t2n, simp+)
   apply (clarsimp simp: shiftr_over_or_dist)
   apply (subst shiftl_shiftr_id, simp+)
   apply (clarsimp simp: shiftl_shiftr2)
   apply (subst le_mask_iff [THEN iffD1])
    apply (clarsimp simp: mask_def plus_one_helper)
   apply clarsimp
  apply (clarsimp simp: word_bits_len_of)
  done

lemma pd_slot_compute_inverse[simp]:
  "pd_slot < 2 ^ 12 \<Longrightarrow>
   unat (pd_slot_of_pt_vaddr (pt_vaddr_of_pd_slot pd_slot)) = pd_slot"
  apply (clarsimp simp: cdl_lookup_pd_slot_def pt_size_def small_frame_size_def)
  apply (rule of_nat_inverse)
   apply (drule of_nat_mono_maybe[rotated, where 'a=32], simp)+
   apply (word_bitwise, clarsimp, clarsimp)
  done

lemma object_slot_empty_translate_exists:
  "(object_slot_empty spec t pt_id pt_slot) s \<Longrightarrow>
   (object_slot_empty spec t pt_id pt_slot) s \<and> t pt_id \<noteq> None"
  by (clarsimp simp: object_slot_empty_def object_initialised_general_def)

lemma object_slot_initialised_translate_exists:
  "(object_slot_initialised spec t pt_id pt_slot) s \<Longrightarrow>
   (object_slot_initialised spec t pt_id pt_slot) s \<and> t pt_id \<noteq> None"
  by (clarsimp simp: object_slot_initialised_def object_initialised_general_def)

lemma si_cap_at_translate_exists:
 "si_cap_at t f spec dev page_id s \<Longrightarrow>
  si_cap_at t f spec dev page_id s \<and> t page_id \<noteq> None"
  by (clarsimp simp: si_cap_at_def)

lemmas translate_exists = si_cap_at_translate_exists object_slot_initialised_translate_exists
                          object_slot_empty_translate_exists

lemma si_caps_at_less_si_cnode_size:
  "(si_caps_at t orig_caps spec dev xs \<and>* R) s \<Longrightarrow>
   orig_caps ptr = Some v \<Longrightarrow>
   ptr \<in> xs \<Longrightarrow>
   v < 2 ^ si_cnode_size"
  by (clarsimp simp: sep_caps_at_split si_cap_at_def sep_conj_def)

lemma si_caps_at_less_translate_exists:
  "(si_caps_at t orig_caps spec dev xs \<and>* R) s \<Longrightarrow>
  ptr \<in> xs \<Longrightarrow>
  t ptr \<noteq> None"
  by (clarsimp simp: sep_caps_at_split si_cap_at_def sep_conj_def)

lemma map_page_wp:
  "\<lbrakk>well_formed spec; pd_at spec_pd_ptr spec\<rbrakk> \<Longrightarrow>
    \<lbrace>\<guillemotleft>object_slot_initialised spec t spec_pd_ptr (unat (vaddr >> 20)) \<and>*
      object_slot_empty spec t pt_id pt_slot \<and>*
      (si_cnode_id, unat free_cptr) \<mapsto>c NullCap \<and>*
      si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
      si_objects \<and>* R\<guillemotright> and
      K (page_cap = fake_frame_cap False page_id (validate_vm_rights rights) n \<and>
         (n = 12 \<or> n = (16 :: nat)) \<and>
         opt_cap (spec_pd_ptr, pd_slot) spec = Some pt_cap \<and>
         pt_cap = PageTableCap pt_id Fake None \<and>
         opt_cap (pt_id, pt_slot) spec = Some page_cap \<and>
         vaddr = frame_vaddr_of_slots pd_slot pt_slot \<and>
         pt_slot < 2 ^ 8 \<and>
         pd_slot < 2 ^ 12 \<and>
         the (orig_caps spec_pd_ptr) < 2 ^ si_cnode_size \<and>
         free_cptr < 2 ^ si_cnode_size)\<rbrace>
    map_page spec orig_caps page_id spec_pd_ptr rights vaddr free_cptr
    \<lbrace>\<lambda>_. \<guillemotleft>object_slot_initialised spec t spec_pd_ptr (unat (vaddr >> 20)) \<and>*
          object_slot_initialised spec t pt_id pt_slot \<and>*
          (si_cnode_id, unat free_cptr) \<mapsto>c conjure_real_frame_cap page_cap t \<and>*
          si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
          si_objects \<and>* R\<guillemotright>\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (frule well_formed_pt_cap_pt_at[where cap=pt_cap],
         fastforce, clarsimp simp: is_fake_pt_cap_def)
  apply (elim conjE)
  apply (clarsimp simp: map_page_def dest!: domE)
  apply (wp)
         apply (clarsimp simp: object_at_def)
         apply (wp sep_wp: seL4_Page_Map_object_initialised_sep
                             [where n=n and
                                    spec=spec and
                                    cap_obj="the (cdl_objects spec pt_id)" and
                                    spec_pd_ptr=spec_pd_ptr and
                                    pt_ptr="the (t pt_id)" and
                                    pt_cap=pt_cap and
                                    spec_page_ptr=page_id and
                                    page_ptr="the (t page_id)" and
                                    t=t and
                                    pd_ptr="the (t spec_pd_ptr)"]
                           duplicate_frame_cap_sep)+
  apply clarsimp
  apply (intro conjI, sep_cancel+, intro conjI)
          apply (sep_simp si_caps_at_take_2 si_cap_at_def)
          apply (clarsimp simp: offset_slot_si_cnode_size' vm_read_write_def
                                conjure_real_frame_cap_def dev_of_def
                                is_frame_default_cap[where frame_cap=page_cap])
          apply sep_solve
         apply (fastforce simp: object_at_def pt_size_def pt_has_slots
                         intro: object_slots_object_default_state_NullCap')+
  by (sep_map thms: translate_exists, fastforce simp: unat_less_2_si_cnode_size')+

(***********************************************************
         * Mapping a frame inside a page directory *
************************************************************)
lemma map_page_in_pd_wp:
  "\<lbrakk>well_formed spec; pd_at pd_id spec\<rbrakk> \<Longrightarrow>
    \<lbrace>\<guillemotleft>object_slot_empty spec t pd_id pd_slot \<and>*
      (si_cnode_id, unat free_cptr) \<mapsto>c NullCap \<and>*
      si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
      si_objects \<and>* R\<guillemotright> and
      K (    page_cap = fake_frame_cap False page_id (validate_vm_rights rights) n \<and>
             (n = 20 \<or> n = (24 :: nat)) \<and>
             pd_slot = unat (pd_slot_of_pt_vaddr vaddr) \<and>
             opt_cap (pd_id, pd_slot) spec = Some page_cap \<and>
             pd_slot < 2 ^ 12 \<and>
             the (orig_caps pd_id) < 2 ^ si_cnode_size \<and>
             free_cptr < 2 ^ si_cnode_size)\<rbrace>
    map_page spec orig_caps page_id pd_id rights vaddr free_cptr
    \<lbrace>\<lambda>_. \<guillemotleft>object_slot_initialised spec t pd_id pd_slot \<and>*
          (si_cnode_id, unat free_cptr) \<mapsto>c conjure_real_frame_cap page_cap t \<and>*
          si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
          si_objects \<and>* R\<guillemotright>\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (elim conjE)
  apply (clarsimp simp: map_page_def dest!: domE)
  apply (intro assert_opt_validI)
  apply wp
     apply (clarsimp simp: object_at_def)
     apply (wp sep_wp: seL4_Section_Map_wp[where pd_ptr="the (t pd_id)" and
                                                 frame_ptr="the (t page_id)" and
                                                 cnode_cap=si_cspace_cap and
                                                 root_size=si_cnode_size and
                                                 n=n];
            fastforce simp: word_bits_def intro!: guard_equal_si_cspace_cap)
    apply (wp sep_wp: duplicate_frame_cap_sep)+
  apply (clarsimp, intro conjI impI, clarsimp simp: si_objects_def cdl_lookup_pd_slot_def)
   apply sep_cancel+
   apply (sep_map thms: translate_exists)
   apply (sep_simp si_cap_at_def object_at_def object_slot_empty_eq)
   apply (sep_drule sep_map_c_sep_map_s)
    apply (clarsimp simp: opt_cap_def object_default_state_def is_pd_def object_type_def
                          default_object_def
                    split: cdl_object.splits)
    apply (clarsimp simp: object_slots_def empty_cap_map_def, fastforce)
   apply sep_cancel+
   apply (clarsimp simp: si_caps_at_take_2_not_object_at offset_slot_si_cnode_size' si_cap_at_def
                         frame_at_default_cap[where frame_cap=page_cap] cap_object_def
                         object_at_def conjure_real_frame_cap_def dev_of_def
                         root_tcb_def update_slots_def)
   apply sep_cancel+
   apply (fastforce simp: object_slot_initialised_lookup shiftr_less cap_object_def
                          validate_vm_rights_inter_rw)
  by (fastforce simp: unat_less_2_si_cnode_size')

(***********************************************************
      * Mapping a page table inside a page directory *
************************************************************)

lemma map_page_table_in_pd_wp:
  "\<lbrakk>well_formed spec; pd_at pd_id spec\<rbrakk> \<Longrightarrow>
    \<lbrace>\<guillemotleft>object_slot_empty spec t pd_id pd_slot \<and>*
      si_caps_at t orig_caps spec dev {obj_id. real_object_at obj_id spec} \<and>*
      si_objects \<and>* R\<guillemotright> and
      K ((n = 20 \<or> n = 24) \<and>
         opt_cap (pd_id, pd_slot) spec = Some (PageTableCap spec_pt_section_ptr Fake None) \<and>
         pd_slot < 2 ^ 12 \<and>
         vaddr = pt_vaddr_of_pd_slot pd_slot)\<rbrace>
    map_page_table spec orig_caps spec_pt_section_ptr pd_id rights vaddr
    \<lbrace>\<lambda>_. \<guillemotleft>object_slot_initialised spec t pd_id pd_slot \<and>*
          si_caps_at t orig_caps spec dev {obj_id. real_object_at obj_id spec} \<and>*
          si_objects \<and>* R\<guillemotright>\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (clarsimp simp: map_page_table_def dest!: domE)
  apply (intro assert_opt_validI)
  apply wp
    apply (clarsimp simp: object_at_def)
    apply (wp sep_wp:
              seL4_PageTable_Map_object_initialised_sep[where pt_ptr ="the (t spec_pt_section_ptr)"
                                                        and   pd_ptr ="the (t pd_id)"])+
  apply (clarsimp, intro conjI impI)
         apply sep_cancel+
         apply (sep_simp si_caps_at_take_2' si_cap_at_def offset_slot_si_cnode_size')
         apply sep_solve
        apply assumption+
  by (sep_simp si_caps_at_less_si_cnode_size[rotated 2, OF pt_at_is_real]
               si_caps_at_less_si_cnode_size[rotated 2, OF pd_at_is_real]
               si_caps_at_less_translate_exists[rotated, OF pt_at_is_real]
               si_caps_at_less_translate_exists[rotated, OF pd_at_is_real])+

(***********************************************************
              * Mapping a page table slot *
************************************************************)

lemma map_page_table_slot_wp:
  "\<lbrakk>well_formed spec; pd_at pd_id spec\<rbrakk> \<Longrightarrow>
   \<lbrace>\<guillemotleft>object_slot_initialised spec t pd_id pd_slot \<and>*
     object_slot_empty spec t (cap_object pt_cap) pt_slot \<and>*
     (si_cnode_id, unat free_cptr) \<mapsto>c NullCap \<and>*
     si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
     si_objects \<and>* R\<guillemotright> and K (
      opt_cap (pd_id, pd_slot) spec = Some pt_cap \<and>
      pt_at (cap_object pt_cap) spec \<and>
      opt_cap (pt_id, pt_slot) spec = Some page_cap \<and>
      cptr_map (pt_id, pt_slot) = free_cptr \<and>
      pt_cap = PageTableCap pt_id Fake None \<and>
      ((page_cap = fake_frame_cap False page_id (validate_vm_rights rights) n \<and> (n = 12 \<or> n = 16))
       \<or> page_cap = NullCap) \<and>
      free_cptr < 2 ^ si_cnode_size \<and>
      pd_slot < 2 ^ 12 \<and>
      pt_slot < 2 ^ 8 \<and>
      vaddr = pt_vaddr_of_pd_slot pd_slot)\<rbrace>
    map_page_table_slot spec orig_caps pd_id pt_id vaddr cptr_map pt_slot
    \<lbrace>\<lambda>_. \<guillemotleft>object_slot_initialised spec t pd_id pd_slot \<and>*
          object_slot_initialised spec t (cap_object pt_cap) pt_slot \<and>*
          si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
          si_objects \<and>* (si_cnode_id, unat free_cptr) \<mapsto>c conjure_real_frame_cap page_cap t \<and>* R\<guillemotright>\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (clarsimp simp: map_page_table_slot_def is_fake_pt_cap_def  dest!: domE split: cdl_cap.splits)
  apply (intro conjI impI)
   apply (wp sep_wp: map_page_wp[where n=n and page_cap=page_cap])
   apply (clarsimp, intro conjI; clarsimp?)
           apply sep_solve
          apply (clarsimp simp: cap_rights_def)
         apply fastforce+
   apply (subst (asm) sep_caps_at_split[where a=pd_id], clarsimp simp: object_at_real_object_at)
   apply (sep_simp si_cap_at_def)
  apply (wp, clarsimp simp: conjure_real_frame_cap_def)
  apply sep_cancel+
  by (fastforce simp: object_slot_empty_initialised_NullCap object_at_def is_tcb_def)

(***********************************************************
  * Mapping a page directory slot that contains a frame *
************************************************************)

lemma map_page_directory_slot_page_wp:
 "frame_at page_id spec \<Longrightarrow>
  \<lbrace>\<guillemotleft>(object_slot_empty spec t pd_id pd_slot \<and>* (si_cnode_id, unat free_cptr) \<mapsto>c NullCap \<and>*
    si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>* si_objects \<and>* R)\<guillemotright> and
   K (page_cap = fake_frame_cap False page_id (validate_vm_rights rights) n \<and> well_formed spec \<and>
      pd_at pd_id spec \<and> (n = 20 \<or> n = 24) \<and> cptr_map (pd_id, pd_slot) = free_cptr \<and>
      pd_slot = unat (pd_slot_of_pt_vaddr vaddr) \<and> opt_cap (pd_id, pd_slot) spec = Some page_cap \<and>
      pd_slot < 2 ^ 12 \<and> the (orig_caps pd_id) < 2 ^ si_cnode_size \<and>
      free_cptr < 2 ^ si_cnode_size)\<rbrace>
    map_page_directory_slot spec orig_caps pd_id cptr_map pd_slot
  \<lbrace>\<lambda>_. \<guillemotleft>(object_slot_initialised spec t pd_id pd_slot \<and>*
        (si_cnode_id, unat free_cptr) \<mapsto>c conjure_real_frame_cap page_cap t \<and>*
        si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>* si_objects \<and>* R)\<guillemotright>\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (clarsimp simp: map_page_directory_slot_def)
  apply (intro conjI impI)
   apply (fastforce simp: object_at_def dest: not_frame_and_pt)
  apply (wp sep_wp: map_page_in_pd_wp[where n=n])
  apply clarsimp
  apply (intro conjI)
      apply sep_solve
     apply (fastforce simp: cap_rights_def pt_size_def small_frame_size_def)+
  done

lemma object_fields_empty_initialised_pt:
  "\<lbrakk>well_formed spec; pt_at obj_id spec\<rbrakk> \<Longrightarrow>
   object_fields_empty spec t obj_id = object_fields_initialised spec t obj_id"
  apply (clarsimp simp: object_at_def object_type_is_object)
  apply (frule (1) well_formed_object_slots)
  apply (clarsimp simp: object_fields_empty_def object_fields_initialised_def
                        object_initialised_general_def object_at_def object_type_is_object)
  apply (subst sep_map_f_object_size_bits_pt, simp+)
  done

lemma object_fields_empty_initialised_pd:
  "\<lbrakk>well_formed spec; pd_at obj_id spec\<rbrakk> \<Longrightarrow>
   object_fields_empty spec t obj_id = object_fields_initialised spec t obj_id"
  apply (clarsimp simp: object_at_def object_type_is_object)
  apply (frule (1) well_formed_object_slots)
  apply (clarsimp simp: object_fields_empty_def object_fields_initialised_def
                        object_initialised_general_def object_at_def object_type_is_object)
  apply (subst sep_map_f_object_size_bits_pd, simp+)
  done

lemma pt_NullCap_empty_init:
  "well_formed spec \<Longrightarrow>
   pt_at obj_id spec \<Longrightarrow>
   cap_at (\<lambda>x. x = NullCap) (obj_id, slot) spec \<Longrightarrow>
   object_slot_empty spec t obj_id slot = object_slot_initialised spec t obj_id slot"
  apply (rule object_slot_empty_initialised_NullCap)
    apply fastforce
   apply (clarsimp simp: object_at_def is_pt_def is_tcb_def  split: cdl_object.splits)
   apply (metis cdl_object.exhaust)
  apply (clarsimp simp: cap_at_def)
  done

lemma pd_NullCap_empty_init:
  "well_formed spec \<Longrightarrow>
   pd_at obj_id spec \<Longrightarrow>  cap_at (\<lambda>x. x = NullCap) (obj_id, slot) spec \<Longrightarrow>
   object_slot_empty spec t obj_id slot = object_slot_initialised spec t obj_id slot"
  apply (rule object_slot_empty_initialised_NullCap)
    apply clarsimp
   apply (clarsimp simp: object_at_def is_pd_def is_tcb_def  split: cdl_object.splits)
   apply (metis cdl_object.exhaust)
  apply (clarsimp simp: cap_at_def)
  done

(***********************************************************
* Mapping a page directory slot that contains a page table *
************************************************************)

lemma map_page_directory_slot_pt_wp:
  "pt_at pt_id spec \<Longrightarrow>
   \<lbrace>\<guillemotleft>object_slot_empty spec t pd_id slot \<and>*
     si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
     si_objects \<and>*
     sep_map_list_conj ((\<lambda>x. (si_cnode_id, unat x) \<mapsto>c NullCap) o cptr_map o (Pair pt_id))
                       [slot <- page_slots. cap_at ((\<noteq>) NullCap) (pt_id, slot) spec]  \<and>*
     object_empty spec t pt_id \<and>* R\<guillemotright> and K (
       (\<forall>n \<in> range cptr_map. n < 2 ^ si_cnode_size) \<and>
       pt_cap = PageTableCap pt_id Fake None  \<and>
       well_formed spec \<and>
       slot < 0x1000 \<and> (n = 12 \<or> n = (16 :: nat)) \<and>
       pd_at pd_id spec \<and>
       page_slots = slots_of_list spec pt_id \<and>
       opt_cap (pd_id, slot) spec = Some pt_cap)\<rbrace>
    map_page_directory_slot spec orig_caps pd_id  cptr_map slot
    \<lbrace>\<lambda>_. \<guillemotleft>sep_map_list_conj (\<lambda>x. (si_cnode_id, unat (cptr_map (pt_id, x)))
                                 \<mapsto>c conjure_real_frame_cap (the_cap spec pt_id x) t)
                            [slot <- page_slots. cap_at ((\<noteq>) NullCap) (pt_id, slot) spec] \<and>*
          object_initialised spec t pt_id  \<and>* object_slot_initialised spec t pd_id slot \<and>*
          si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
          si_objects \<and>* R\<guillemotright>\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (clarsimp simp: map_page_directory_slot_def)
  apply (rule hoare_name_pre_state)
  apply (wp map_page_table_slot_wp[where pt_cap=pt_cap,
                                   simplified sep_wp_simp, THEN sep_hoare_fold_mapM_x]
            map_page_table_in_pd_wp[sep_wandise])+
  apply (clarsimp, intro conjI impI)
      apply sep_cancel+
      apply (clarsimp simp: pt_size_def small_frame_size_def word_of_nat_less word_bits_def
                            unat_of_nat32)
      apply (sep_fold_cancel, rule sep_map_sep_foldI)
       apply (clarsimp simp: map_def comp_def object_empty_decomp object_initialised_decomp
                             object_empty_slots_empty_initialised object_fields_empty_initialised_pt
                             object_slots_initialised_decomp object_slots_empty_decomp sep_conj_ac)
       apply sep_cancel+
       apply (clarsimp simp: well_formed_finite sep.prod.union_diff2 sep_list_conj_sep_map_set_conj
                             well_formed_distinct_slots_of_list
                             sep_map_set_conj_set_cong
                               [OF split_filter_set
                                     [where xs="dom (slots_of pt_id spec)" and
                                            P="\<lambda>slot. cap_at ((\<noteq>) NullCap) (pt_id, slot) spec"]])
       apply sep_cancel+
       apply (fastforce elim: sep_map_set_conj_match
                        simp: pt_NullCap_empty_init not_cap_at_cap_not_at eq_commute)
      apply clarsimp
      apply (intro conjI)
        apply (clarsimp simp: object_at_def cap_at_def)
       apply clarsimp
       apply (erule wf_cap_in_pt_is_frame; fastforce simp: cap_at_def)
      apply (frule well_formed_slot_object_size_bits_pt[where obj_id=pt_id,
                                                        simplified is_pt_pt_size])
  by (fastforce simp: cap_at_def opt_cap_def pt_size_def small_frame_size_def)+

(***********************************************************
              * Mapping a page directory *
************************************************************)

lemma map_page_directory_wp_expanded:
  "\<lbrakk>well_formed spec; pd_at pd_id spec; pd_slots = slots_of_list spec pd_id;
    list_all (\<lambda>n. n < 2 ^ 12) pd_slots; \<forall>ptr. cptr_map ptr < 2 ^ si_cnode_size;
    the (orig_caps pd_id) < 2 ^ si_cnode_size\<rbrakk> \<Longrightarrow>
    \<lbrace>\<guillemotleft>si_objects \<and>*
      si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
      \<And>* map (\<lambda>x.
          let pt_id = get_obj pd_id x spec in
          object_slot_empty spec t pd_id x \<and>*
          object_empty spec t pt_id \<and>*
          sep_map_set_conj (\<lambda>y. (si_cnode_id, unat (cptr_map (pt_id, y))) \<mapsto>c NullCap)
                           {slot \<in> dom (slots_of pt_id spec).
                             cap_at ((\<noteq>) NullCap) (pt_id, slot) spec})
        [slot <- pd_slots. cap_object_from_slot pd_id slot pt_at spec] \<and>*
      \<And>* map (\<lambda>x.
          let frame_id = get_obj pd_id x spec in
          (si_cnode_id, unat (cptr_map (pd_id, x))) \<mapsto>c NullCap \<and>*
          object_slot_empty spec t pd_id x)
        [slot <- pd_slots. cap_object_from_slot pd_id slot frame_at spec] \<and>*
      R\<guillemotright>\<rbrace>
      map_page_directory spec orig_caps cptr_map pd_id
    \<lbrace>\<lambda>_. \<guillemotleft>si_objects \<and>*
          si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
          \<And>* map (\<lambda>x.
              let pt_id = get_obj pd_id x spec in
              object_slot_initialised spec t pd_id x \<and>*
              object_initialised spec t pt_id \<and>*
              sep_map_set_conj (\<lambda>y. (si_cnode_id, unat (cptr_map (pt_id, y)))
                                    \<mapsto>c conjure_real_frame_cap (the_cap spec pt_id y) t)
                               {slot \<in> dom (slots_of pt_id spec).
                                 cap_at ((\<noteq>) NullCap) (pt_id, slot) spec})
             [slot <- pd_slots. cap_object_from_slot pd_id slot pt_at spec] \<and>*
          \<And>* map (\<lambda>x.
              let frame_id = get_obj pd_id x spec in
              (si_cnode_id, unat (cptr_map (pd_id, x)))
                \<mapsto>c conjure_real_frame_cap (the_cap spec pd_id x) t \<and>*
              object_slot_initialised spec t pd_id x)
             [slot <- pd_slots. cap_object_from_slot pd_id slot frame_at spec] \<and>*
          R\<guillemotright>\<rbrace>"
  apply (clarsimp simp: map_page_directory_def Let_unfold)
  apply wp
    apply (rule sep_hoare_fold_mapM_x[OF map_page_directory_slot_pt_wp
                                          [where t=t and
                                                 page_slots="slots_of_list spec pt_id" and
                                                 pt_id="get_obj pd_id slot spec"
                                                 for pt_id slot,
                                           simplified sep_wp_simp],
                                          simplified fun_app_def])
    apply (clarsimp simp: opt_cap_def cap_at_def)
    apply (fastforce dest: Some_to_the)
   apply (rule sep_hoare_fold_mapM_x[OF map_page_directory_slot_page_wp
                                          [where t=t and
                                                 rights="cap_rights cap" and
                                                 n="cap_size_bits cap" and
                                                 page_id="get_obj pd_id slot spec"
                                                 for slot cap,
                                           simplified sep_wp_simp],
                                          simplified fun_app_def])
   apply (clarsimp simp: cap_at_def)
   apply (fastforce dest: Some_to_the)
  apply clarsimp
  apply (sep_fold_cancel, rule sep_map_sep_foldI)
   apply (clarsimp simp: cap_at_def)
   apply sep_cancel+
   apply (sep_fold_cancel, rule sep_map_sep_foldI)
    apply (clarsimp simp: sep_list_conj_sep_map_set_conj well_formed_distinct_slots_of_list
                          well_formed_finite)
    apply sep_solve
   apply (intro conjI)
       apply (fastforce dest: Some_to_the)
      apply (fastforce elim: list_all_spec)+
   apply clarsimp
   apply (erule wf_pt_in_pd_fake_and_none; fastforce)
  apply (clarsimp, intro conjI)
      apply (drule wf_frame_cap_in_pd; (fastforce simp: cap_at_def)?)
     apply (drule wf_frame_cap_in_pd; (fastforce simp: cap_at_def)?)
    apply (rule pd_slot_compute_inverse[symmetric], clarsimp)
  by (fastforce simp: cap_at_def elim: list_all_spec)+

lemma slots_of_pd_split:
  "\<lbrakk>well_formed spec; pd_at pd_id spec\<rbrakk> \<Longrightarrow>
   dom (slots_of pd_id spec) =
    {slot \<in> dom (slots_of pd_id spec). cap_at (\<lambda>c. c \<noteq> NullCap \<and> pt_at (cap_object c) spec)
                                              (pd_id, slot) spec} \<union>
    {slot \<in> dom (slots_of pd_id spec). cap_at (\<lambda>c. c \<noteq> NullCap \<and> frame_at (cap_object c) spec)
                                              (pd_id, slot) spec} \<union>
    {slot \<in> dom (slots_of pd_id spec). cap_at (\<lambda>c. c = NullCap) (pd_id, slot) spec}"
  apply (intro set_eqI iffI; clarsimp)
   apply (clarsimp simp: slots_of_def cap_at_def opt_cap_object_slot_simp
                   split: option.splits)
   apply (fastforce dest: well_formed_pd_frame_or_pt)+
  done

lemma wf_split_slots_of_pd:
  "\<lbrakk>well_formed spec; pd_at pd_id spec\<rbrakk> \<Longrightarrow>
   sep_map_set_conj P (dom (slots_of pd_id spec)) =
    (sep_map_set_conj P
      {slot \<in> dom (slots_of pd_id spec). cap_at (\<lambda>c. c \<noteq> NullCap \<and> pt_at (cap_object c) spec)
                                                (pd_id, slot) spec} \<and>*
     sep_map_set_conj P
      {slot \<in> dom (slots_of pd_id spec). cap_at (\<lambda>c. c \<noteq> NullCap \<and> frame_at (cap_object c) spec)
                                                (pd_id, slot) spec} \<and>*
     sep_map_set_conj P
      {slot \<in> dom (slots_of pd_id spec). cap_at (\<lambda>c. c = NullCap) (pd_id, slot) spec})"
  apply clarsimp
  apply (subst slots_of_pd_split)
    apply (clarsimp simp: sep.prod.union_disjoint well_formed_finite[where obj_id=pd_id]
                          cap_at_def)+
  apply (subst sep.prod.union_disjoint)
     apply (clarsimp simp: well_formed_finite[where obj_id=pd_id])+
   apply (intro set_eqI iffI; clarsimp)
  apply (subst sep.prod.union_disjoint)
     apply (clarsimp simp: well_formed_finite[where obj_id=pd_id])+
   apply (intro set_eqI iffI; clarsimp)
   apply (fastforce dest: well_formed_pd_frame_or_pt)
  apply (clarsimp simp: sep_conj_ac)
  done

lemma wf_pd_pt_obj_inj:
  "\<lbrakk>well_formed spec; pd_at pd_id spec\<rbrakk>
   \<Longrightarrow> inj_on (ref_obj spec pd_id)
             {slot \<in> dom (slots_of pd_id spec). cap_object_from_slot pd_id slot pt_at spec}"
  supply object_type_is_object[simp]
  apply (clarsimp simp: inj_on_def cap_ref_object_def object_at_def)
  apply (frule_tac obj_id=pd_id and slot=y in well_formed_types_match)
     apply fastforce+
  using object_type_is_object(9) object_type_object_at(9) wf_pd_cap_has_object apply blast
  apply clarsimp+
  apply (frule_tac obj_id=pd_id and slot=x in well_formed_types_match, fastforce+)
  using object_type_is_object(9) object_type_object_at(9) wf_pd_cap_has_object apply blast
  apply (clarsimp simp: cap_type_def split: cdl_cap.splits)
  apply (frule_tac obj_id=pd_id and obj_id'=pd_id and slot=x and slot'=y in
                   well_formed_fake_pt_caps_unique)
         apply fastforce+
     apply (erule well_formed_pt_cap_is_fake_pt_cap, fastforce+)
    apply (erule well_formed_pt_cap_is_fake_pt_cap, fastforce+)
  done

lemma sep_map_pd_slots_inj[simp]:
  "well_formed spec \<Longrightarrow>
   pd_at pd_id spec \<Longrightarrow>
   (SETSEPCONJ x | x \<in> dom (slots_of pd_id spec) \<and> cap_object_from_slot pd_id x pt_at spec.
      P (cap_object (the_cap spec pd_id x))) =
   sep_map_set_conj P
     {obj. \<exists>slot. slot \<in> dom (slots_of pd_id spec) \<and>
                  cap_object_from_slot pd_id slot pt_at spec \<and>
                  obj = cap_object (the_cap spec pd_id slot)}"
  apply (subgoal_tac "{obj. \<exists>slot. slot \<in> dom (slots_of pd_id spec) \<and>
                                   cap_object_from_slot pd_id slot pt_at spec \<and>
                                   obj = cap_object (the_cap spec pd_id slot)} =
                      ref_obj spec pd_id ` {slot \<in> dom (slots_of pd_id spec).
                                              cap_object_from_slot pd_id slot pt_at spec}")
   prefer 2
   apply (clarsimp simp: cap_ref_object_def)
   apply blast
  apply clarsimp
  apply (subst sep.prod.reindex)
   apply (erule (1) wf_pd_pt_obj_inj)
  apply (clarsimp simp: cap_ref_object_def)
  done

lemma opt_cap_cap_at_simp: "(opt_cap ref spec = Some cap) = cap_at (\<lambda>x. x = cap) ref spec"
  by (clarsimp simp: cap_at_def)

(***********************************************************
* Mapping a page directory, with cleaner pre/postcondition *
************************************************************)

lemma map_page_directory_wp:
  "\<lbrakk>well_formed spec; pd_at pd_id spec; pd_slots = slots_of_list spec pd_id;
    list_all (\<lambda>n. n < 2 ^ 12) pd_slots; \<forall>ptr. cptr_map ptr < 2 ^ si_cnode_size;
    the (orig_caps pd_id) < 2 ^ si_cnode_size\<rbrakk> \<Longrightarrow>
     \<lbrace>\<guillemotleft>si_objects \<and>*
       si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
       object_empty spec t pd_id \<and>*
       frame_duplicates_empty cptr_map pd_id spec \<and>*
       slots_in_object_empty (\<lambda>cap. cap \<noteq> NullCap \<and> pt_at (cap_object cap) spec) pd_id spec t \<and>*
       R\<guillemotright>\<rbrace>
     map_page_directory spec orig_caps cptr_map pd_id
     \<lbrace>\<lambda>_. \<guillemotleft>si_objects \<and>*
           si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
           object_initialised spec t pd_id \<and>*
           frame_duplicates_copied cptr_map pd_id spec t \<and>*
           slots_in_object_init (\<lambda>cap. cap \<noteq> NullCap \<and> pt_at (cap_object cap) spec) pd_id spec t \<and>*
           R\<guillemotright>\<rbrace>"
  apply (wp map_page_directory_wp_expanded[sep_wandise])
  apply sep_cancel+
  apply (clarsimp simp: Let_unfold cap_at_def wf_split_slots_of_pd object_slots_empty_decomp
                        object_empty_decomp[where spec_object_id=pd_id]
                        sep_list_conj_sep_map_set_conj slots_in_object_empty_def
                        frame_duplicates_empty_def cap_ref_object_def
                        well_formed_distinct_slots_of_list well_formed_finite
                        object_initialised_decomp[where spec_object_id=pd_id]
                        frame_duplicates_copied_def object_slots_initialised_decomp
                        object_fields_empty_initialised_pd object_empty_slots_empty_initialised)
  apply sep_cancel+
  apply (subst (asm) sep_map_set_conj_subst[OF pd_NullCap_empty_init];
         clarsimp simp: opt_cap_cap_at_simp)
  apply sep_cancel
  apply (clarsimp simp: slots_in_object_init_def)
  apply (fold cap_ref_object_def)
  apply (erule sep_map_set_elim)
   apply (clarsimp simp: image_def)
   apply (intro set_eqI iffI; clarsimp simp: cap_at_def)
  apply blast
  done

lemma set_asid_wp:
   "\<lbrace>\<guillemotleft>si_caps_at t orig_caps spec dev {obj_id. real_object_at obj_id spec} \<and>*
      si_objects \<and>* R\<guillemotright> and K(
     well_formed spec \<and>
     pd_at obj_id spec)\<rbrace>
    set_asid spec orig_caps obj_id
    \<lbrace>\<lambda>rv. \<guillemotleft>si_caps_at t orig_caps spec dev {obj_id. real_object_at obj_id spec} \<and>*
           si_objects \<and>* R\<guillemotright>\<rbrace>"
  apply (rule hoare_gen_asm, clarsimp)
  apply (frule (1) object_at_real_object_at)
  apply (rule valid_si_caps_at_si_cap_at [where obj_id=obj_id], clarsimp+)
  apply (clarsimp simp: si_cap_at_def sep_conj_assoc sep_conj_exists)
  apply (subst ex_conj_increase)+
  apply (rule hoare_vcg_ex_lift)+
  apply (rename_tac kobj_id)
  apply (rule hoare_grab_asm)+
  apply wpsimp
   apply (clarsimp simp: set_asid_def)
   apply (wp add: hoare_drop_imps
            sep_wp: seL4_ASIDPool_Assign_wp [where
                    cnode_cap = si_cspace_cap and
                    cnode_id = si_cnode_id and
                    root_size = si_cnode_size and
                    tcb = "obj_tcb root_tcb" and
                    p = si_asidpool_id and
                    base = si_asidpool_base and
                    pd = "the (t obj_id)"],
        (simp add: guard_equal_si_cspace_cap')+)
  apply (subst offset_slot_si_cnode_size', simp)+
  apply (simp add: si_objects_def si_asid_def default_cap_def object_at_object_type)
  apply sep_solve
  done

lemma cap_transform_empty_cap_map [simp]:
  "cap_transform t \<circ>\<^sub>M empty_cap_map n = empty_cap_map n"
  apply (rule ext)
  apply (clarsimp simp: cap_transform_def empty_cap_map_def update_cap_object_def)
  done

lemma spec2s_default_tcb [simp]:
  "spec2s t (Tcb (default_tcb domain)) = Tcb (default_tcb domain)"
  apply (clarsimp simp: spec2s_def object_slots_def update_slots_def default_tcb_def cap_transform_def)
  apply (rule ext)
  apply clarsimp
  done

(* MoveMe *)
lemma object_default_state_spec2s:
  "object_default_state obj = obj \<Longrightarrow> spec2s t obj = obj"
  apply (clarsimp simp: object_default_state_def2 split: cdl_object.splits)
      apply (metis spec2s_default_tcb)
     apply (clarsimp simp: spec2s_def object_slots_def empty_cnode_def empty_irq_node_def
                           cdl_cnode.splits)+
  done

lemma object_empty_initialised_default_state:
  "object_at (\<lambda>obj. object_default_state obj = obj) obj_id spec \<Longrightarrow>
  object_empty spec t obj_id = object_initialised spec t obj_id"
  apply (clarsimp simp: object_empty_def object_initialised_def object_initialised_general_def object_at_def)
  apply (frule object_default_state_spec2s [where t=t])
  apply clarsimp
  done

lemma not_object_at:
  "(\<not> object_at P obj_id spec) \<Longrightarrow> cdl_objects spec obj_id = Some object \<Longrightarrow>
   object_at (\<lambda>obj. \<not>P obj) obj_id spec "
  apply (clarsimp simp: object_at_def)
  done

definition parent_obj_of :: "cdl_object_id \<Rightarrow> cdl_object_id \<Rightarrow> cdl_state \<Rightarrow> bool" where
  "parent_obj_of parent_obj child_obj spec \<equiv>
      (\<exists>slot \<in> dom (slots_of parent_obj spec).
           cap_at (\<lambda>cap. cap_has_object cap \<and> cap_object cap = child_obj) (parent_obj, slot) spec)"

definition pd_equiv_class :: "cdl_state \<Rightarrow> (cdl_object_id \<times> cdl_object_id) set" where
  "pd_equiv_class spec \<equiv>
    {(x,y). pt_at x spec \<and> pt_at y spec \<and>
            (\<exists>obj. pd_at obj spec \<and> parent_obj_of obj x spec \<and> parent_obj_of obj y spec)}"

lemma pd_equiv_sym:
  "sym (pd_equiv_class spec)"
  apply (clarsimp simp: sym_def pd_equiv_class_def)
  by blast

lemma pt_parents_eq:
  "\<lbrakk>well_formed spec; pd_at obj_id spec; pd_at obj_id' spec; pt_at pt spec;
    parent_obj_of obj_id pt spec; parent_obj_of obj_id' pt spec\<rbrakk>
   \<Longrightarrow> obj_id = obj_id'"
  apply (clarsimp simp: parent_obj_of_def cap_at_def)
  apply (frule well_formed_fake_pt_caps_unique[where obj_id=obj_id and obj_id'=obj_id'])
         apply assumption+
     apply (metis (full_types) cap_has_object_not_NullCap cap_type_simps(8)
                               well_formed_pt_cap_is_fake_pt_cap wf_pt_in_pd_fake_and_none)
    apply (metis (full_types) cap_has_object_not_NullCap cap_type_simps(8)
                              well_formed_pt_cap_is_fake_pt_cap wf_pt_in_pd_fake_and_none)
   apply fastforce+
  done

lemma pd_equiv_trans:
  "well_formed spec \<Longrightarrow> trans (pd_equiv_class spec)"
  apply (clarsimp simp: trans_def pd_equiv_class_def)
  apply (rule_tac x=obj in exI)
  apply (clarsimp)
  using pt_parents_eq by blast

abbreviation (input)
  "object_in_cap P ref spec \<equiv> cap_at (\<lambda>cap. cap \<noteq> NullCap \<and> P (cap_object cap)) ref spec"

(* Looking up PTs of a PD is injective, except when both have none *)
lemma pd_pts_inj_or_empty:
  "\<lbrakk>well_formed spec; pd_at x spec; pd_at y spec;
    {obj. \<exists>slot. slot \<in> dom (slots_of x spec) \<and>
                 object_in_cap (\<lambda>obj. pt_at obj spec) (x, slot) spec \<and> obj = ref_obj spec x slot} =
    {obj. \<exists>slot. slot \<in> dom (slots_of y spec) \<and>
                object_in_cap (\<lambda>obj. pt_at obj spec) (y, slot) spec \<and> obj = ref_obj spec y slot};
    x \<noteq> y\<rbrakk> \<Longrightarrow>
  {obj. \<exists>slot. slot \<in> dom (slots_of x spec) \<and>
               object_in_cap (\<lambda>obj. pt_at obj spec) (x, slot) spec \<and> obj = ref_obj spec x slot} = {}"
  apply (clarsimp simp: cap_at_def cap_ref_object_def)
  apply (drule_tac x="cap_object cap" in eqset_imp_iff)
  apply (frule pt_parents_eq[where obj_id = x and obj_id' = y];
         fastforce simp: parent_obj_of_def cap_at_def wf_pd_cap_has_object)
  done

lemma wf_pd_equiv_parentD:
  "\<lbrakk>(pt, pt') \<in> pd_equiv_class spec; well_formed spec; pd_at pd spec; parent_obj_of pd pt spec\<rbrakk>
    \<Longrightarrow> parent_obj_of pd pt' spec"
  apply (clarsimp simp: pd_equiv_class_def)
  apply (frule_tac obj_id=obj and obj_id'=pd and pt=pt in pt_parents_eq; fastforce)
  done

lemma pd_equiv_ptsD: "pts \<in> pd_equiv_class spec \<Longrightarrow> pt_at (fst pts) spec \<and> pt_at (snd pts) spec"
  by (clarsimp simp: pd_equiv_class_def split: prod.splits)

(* Grouping PTs by their parent PD is the same as taking the PT children of each parent PD *)
lemma pd_quotient_eq_pts_of_pds:
  "well_formed spec \<Longrightarrow>
   image (\<lambda>pd.{ref_obj spec pd slot | slot. slot \<in> dom (slots_of pd spec) \<and>
                             object_in_cap (\<lambda>obj. pt_at obj spec) (pd, slot) spec})
                             {obj. pd_at obj spec} - {{}} =
   {x. pt_at x spec \<and> (\<exists>obj. pd_at obj spec \<and>
     (\<exists>slot\<in>dom (slots_of obj spec). cap_at cap_has_object (obj, slot) spec
                                    \<and> ref_obj spec obj slot = x))} // pd_equiv_class spec - {{}}"
  apply (clarsimp simp: image_def quotient_def Image_def cong: SUP_cong_simp)
  apply (intro set_eqI iffI; clarsimp simp: cap_at_def)
   apply (guess_exI)
   apply safe
     apply (fastforce simp: wf_pd_cap_has_object cap_ref_object_def)
    apply (clarsimp simp: pd_equiv_class_def cap_ref_object_def)
    apply (guess_exI, clarsimp)
    apply (intro conjI; fastforce simp: wf_pd_cap_has_object cap_ref_object_def
                                        cap_at_def parent_obj_of_def)
   apply (clarsimp simp: cap_ref_object_def)
   apply (frule_tac pd=xa in wf_pd_equiv_parentD; clarsimp?)
    apply (fastforce simp: wf_pd_cap_has_object cap_ref_object_def cap_at_def parent_obj_of_def)
   apply (drule pd_equiv_ptsD, clarsimp simp: parent_obj_of_def cap_at_def)
   apply (rule_tac x=slota in exI)
   apply (fastforce simp: wf_pd_cap_has_object cap_ref_object_def
                          pd_equiv_class_def cap_at_def parent_obj_of_def)
  apply (rule_tac x=obj in exI)
  apply (clarsimp simp: cap_ref_object_def)
  apply (intro set_eqI iffI; clarsimp)
   apply (frule_tac pd=obj and pt'=xa in wf_pd_equiv_parentD; clarsimp?)
    apply (fastforce simp: parent_obj_of_def cap_at_def)
   apply (drule pd_equiv_ptsD, clarsimp simp: parent_obj_of_def cap_at_def)
   apply (rule_tac x=slota in exI)
   apply (fastforce simp: wf_pd_cap_has_object cap_ref_object_def
      pd_equiv_class_def cap_at_def parent_obj_of_def)
  apply (clarsimp simp: pd_equiv_class_def)
  apply (rule_tac x=obj in exI)
  apply (clarsimp simp: parent_obj_of_def cap_at_def)
  apply (metis (full_types) domI wf_pd_cap_has_object)
  done

lemma well_formed_pd_slots:
  "\<lbrakk>well_formed spec; pd_at obj_id spec\<rbrakk> \<Longrightarrow>
   \<forall>slot \<in> dom (slots_of obj_id spec). slot < 2 ^ 12"
  by (fastforce simp: Ball_def elim: well_formed_pd_slot_limited)

lemma well_formed_pt_not_in_pd_empty_init:
 "\<lbrakk>well_formed spec; pt_at x spec;
   (\<forall>obj. pd_at obj spec \<longrightarrow> (\<forall>slot\<in>dom (slots_of obj spec). cap_at cap_has_object (obj, slot) spec
                         \<longrightarrow> ref_obj spec obj slot \<noteq> x))\<rbrakk>
   \<Longrightarrow> object_empty spec t x = object_initialised spec t x"
  apply (rule object_empty_initialised_default_state)
  apply (rule ccontr)
  apply (drule not_object_at, fastforce)
  apply (frule (2) well_formed_cap_to_non_empty_pt)
  apply clarsimp
  apply (erule_tac x=pd_id in allE, clarsimp)
  apply (clarsimp simp: object_at_def)
  apply (case_tac "cap \<noteq> NullCap")
   apply (frule well_formed_types_match[symmetric], fastforce+)
   apply (fastforce dest: opt_cap_dom_slots_of
                    simp: cap_at_def cap_ref_object_def object_at_def object_type_is_object)+
  done

lemma refl_on_pd_parent[simp]:
  "refl_on {pt_id. pt_at pt_id spec \<and>
                   (\<exists>obj. pd_at obj spec \<and> parent_obj_of obj pt_id spec)}
           (pd_equiv_class spec)"
  by (clarsimp simp: pd_equiv_class_def refl_on_def, fastforce)

lemma pt_parents_pd_pts_empty:
  "well_formed spec \<Longrightarrow>
   (SETSEPCONJ pd_id | pd_at pd_id spec.
        slots_in_object_empty (\<lambda>cap. cap \<noteq> NullCap \<and> pt_at (cap_object cap) spec) pd_id spec t) =
   (SETSEPCONJ pt_id | pt_at pt_id spec \<and> (\<exists>obj. pd_at obj spec \<and> parent_obj_of obj pt_id spec).
        object_empty spec t pt_id)"
  apply (rule sym, subst sep_map_set_quotient_split[where R="pd_equiv_class spec"])
    apply fastforce
   apply (rule equivI; clarsimp simp: pd_equiv_sym[simplified fun_app_def] pd_equiv_trans)
  apply (clarsimp simp: slots_in_object_empty_def, rule sym, subst sep_map_set_squash)
    apply clarsimp
    apply (drule_tac x=x and y=y in pd_pts_inj_or_empty, clarsimp+)
    apply blast
   apply fastforce
  apply (rule sym)
  apply (rule sep_map_set_conj_cong_empty_eq)
    apply clarsimp+
  apply (rule box_equals[OF pd_quotient_eq_pts_of_pds[symmetric]], assumption)
   apply (clarsimp simp: parent_obj_of_def, intro set_eqI iffI;
          clarsimp simp: quotient_def Image_def)
    apply (guess_exI, clarsimp)
    apply (guess_exI, clarsimp)
    apply (clarsimp simp: cap_ref_object_def)
    apply (metis (mono_tags, lifting) cap_at_def domI option.sel)
   apply (guess_exI, clarsimp)
   apply (guess_exI, clarsimp)
   apply (clarsimp simp: cap_ref_object_def)
   apply (metis (mono_tags, lifting) cap_at_def domI option.sel)
  apply blast
  done

lemma pt_parents_pd_pts_init:
  "well_formed spec \<Longrightarrow>
   (SETSEPCONJ pd_id | pd_at pd_id spec.
        slots_in_object_init (\<lambda>cap. cap \<noteq> NullCap \<and> pt_at (cap_object cap) spec) pd_id spec t) =
   (SETSEPCONJ pt_id | pt_at pt_id spec \<and> (\<exists>obj. pd_at obj spec \<and> parent_obj_of obj pt_id spec).
        object_initialised spec t pt_id)"
  apply (rule sym, subst sep_map_set_quotient_split[where R="pd_equiv_class spec"])
    apply (clarsimp)
   apply (rule equivI; clarsimp simp: pd_equiv_sym[simplified fun_app_def] pd_equiv_trans)
  apply (clarsimp simp: slots_in_object_init_def, rule sym, subst sep_map_set_squash)
    apply clarsimp
    apply (drule_tac x=x and y=y in pd_pts_inj_or_empty, clarsimp+)
    apply blast
   apply clarsimp
  apply (rule sym)
  apply (rule sep_map_set_conj_cong_empty_eq)
    apply clarsimp+
  apply (rule box_equals [OF pd_quotient_eq_pts_of_pds[symmetric]], assumption)
   apply (clarsimp simp: parent_obj_of_def, intro set_eqI iffI;
          clarsimp simp: quotient_def Image_def)
    apply (guess_exI, clarsimp)
    apply (guess_exI, clarsimp)
    apply (clarsimp simp: cap_ref_object_def)
    apply (metis (mono_tags, lifting) cap_at_def domI option.sel)
   apply (guess_exI, clarsimp)
   apply (guess_exI, clarsimp)
   apply (clarsimp simp: cap_ref_object_def)
   apply (metis (mono_tags, lifting) cap_at_def domI option.sel)
  apply blast
  done

(***********************************************************
              * Initialising all page directories *
************************************************************)

lemma init_vspace_sep:
  "\<lbrace>\<guillemotleft>si_objects \<and>*
     si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
     objects_empty spec t {obj_id. table_at obj_id spec} \<and>*
     (SETSEPCONJ x | pd_at x spec.
        frame_duplicates_empty (make_frame_cap_map obj_ids free_cptrs spec) x spec) \<and>*
     R\<guillemotright> and K (
      well_formed spec \<and>
      set obj_ids = dom (cdl_objects spec) \<and>
      distinct obj_ids \<and>
      card (\<Union> (set ` get_frame_caps spec ` {obj. pd_at obj spec})) \<le> length free_cptrs \<and>
      list_all (\<lambda>n. n < 2 ^ si_cnode_size) free_cptrs \<and>
      (\<forall>p. p \<in> {obj_id. pd_at obj_id spec} \<longrightarrow> the (orig_caps p) < 2 ^ si_cnode_size))\<rbrace>
   init_vspace spec orig_caps obj_ids free_cptrs
   \<lbrace>\<lambda>_. \<guillemotleft>si_objects \<and>*
         si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
         objects_initialised spec t {obj_id. table_at obj_id spec} \<and>*
         (SETSEPCONJ x | pd_at x spec.
            frame_duplicates_copied (make_frame_cap_map obj_ids free_cptrs spec) x spec t) \<and>*
         R\<guillemotright>\<rbrace>"
  apply (rule hoare_gen_asm, clarsimp)
  apply (clarsimp simp: objects_empty_def objects_initialised_def)
  apply (subst sep_map_set_conj_set_disjoint, simp+,
         clarsimp simp: object_at_def object_type_is_object)+
  apply (clarsimp simp: init_vspace_def sep_conj_assoc)
  apply (wp sep_hoare_fold_mapM_x[OF map_page_directory_wp[simplified sep_wp_simp]], simp+)
     apply (frule_tac obj_id=x in well_formed_pd_slots; clarsimp)
     using Ball_set apply fastforce
    apply (clarsimp simp: make_frame_cap_map_def si_cnode_size_def split: option.splits)
    apply (meson list_all_spec map_of_SomeD set_zip_rightD)
   apply (fastforce elim: list_all_spec)
  apply sep_flatten
  apply sep_fold_cancel
  apply (rule sep_map_set_sep_foldI)
   apply (clarsimp simp: sep.prod.distrib)+
  apply sep_cancel+
    (* Split PTs into those which have a parent and those which do not *)
  apply (clarsimp simp: sep_map_set_conj_restrict
                          [where t="\<lambda>pt_id. (\<exists>obj. pd_at obj spec \<and> parent_obj_of obj pt_id spec)"
                             and xs="{obj_id. pt_at obj_id spec}"])
  apply (clarsimp simp: pt_parents_pd_pts_empty pt_parents_pd_pts_init, sep_cancel+)
  apply (subst (asm) sep_map_set_conj_subst[OF well_formed_pt_not_in_pd_empty_init])
     apply fastforce+
   apply (clarsimp simp: parent_obj_of_def)
   apply (erule_tac x=obj in allE, drule mp, assumption, clarsimp simp: cap_at_def)
   apply (fastforce simp: cap_ref_object_def)
  by sep_solve

lemma init_pd_asids_sep:
  "\<lbrace>\<guillemotleft>si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
     si_objects \<and>* R\<guillemotright> and K(well_formed spec)\<rbrace>
   init_pd_asids spec orig_caps obj_ids
   \<lbrace>\<lambda>_. \<guillemotleft>si_caps_at t orig_caps spec False {obj_id. real_object_at obj_id spec} \<and>*
         si_objects \<and>* R\<guillemotright>\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (clarsimp simp: init_pd_asids_def)
  apply (rule mapM_x_wp', clarsimp)
  apply (wp sep_wp: set_asid_wp [where t=t], simp+, sep_solve)
  done

end

end