(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

(*
   Retype refinement
*)

theory Retype_R
imports VSpace_R
begin

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

definition
  APIType_map2 :: "kernel_object + ARM_H.object_type \<Rightarrow> Structures_A.apiobject_type"
where
 "APIType_map2 ty \<equiv> case ty of
      Inr (APIObjectType ArchTypes_H.Untyped) \<Rightarrow> Structures_A.Untyped
    | Inr (APIObjectType ArchTypes_H.TCBObject) \<Rightarrow> Structures_A.TCBObject
    | Inr (APIObjectType ArchTypes_H.EndpointObject) \<Rightarrow> Structures_A.EndpointObject
    | Inr (APIObjectType ArchTypes_H.NotificationObject) \<Rightarrow> Structures_A.NotificationObject
    | Inr (APIObjectType ArchTypes_H.CapTableObject) \<Rightarrow> Structures_A.CapTableObject
    | Inr PageTableObject \<Rightarrow> ArchObject PageTableObj
    | Inr PageDirectoryObject \<Rightarrow> ArchObject PageDirectoryObj
    | Inr LargePageObject \<Rightarrow> ArchObject LargePageObj
    | Inr SectionObject \<Rightarrow> ArchObject SectionObj
    | Inr SuperSectionObject \<Rightarrow> ArchObject SuperSectionObj
    | Inl (KOArch (KOASIDPool _)) \<Rightarrow> ArchObject ASIDPoolObj
    | _ \<Rightarrow> ArchObject SmallPageObj"

lemma placeNewObject_def2:
 "placeNewObject ptr val gb = createObjects' ptr 1 (injectKO val) gb"
   apply (clarsimp simp:placeNewObject_def placeNewObject'_def
     createObjects'_def shiftL_nat)
  done

lemma createObjects_ret:
  "\<lbrakk>n < 2^word_bits;n\<noteq> 0\<rbrakk> \<Longrightarrow>
   \<lbrace>\<top>\<rbrace> createObjects y n ko gbits
   \<lbrace>\<lambda>r s. r = map (\<lambda>p. ptr_add y (p * 2 ^ objBitsKO ko * 2 ^ gbits))
                [0..< n]\<rbrace>"
    unfolding createObjects_def createObjects'_def
  apply (simp add: split_def)
  apply (wp|simp cong: if_cong)+
  apply (clarsimp simp: ptr_add_def upto_enum_def o_def
                        unat_sub word_le_nat_alt
                        power_sub[symmetric]
                        objBits_def[symmetric]
              simp del: upt_Suc)
  apply (clarsimp simp: unat_of_nat_minus_1 word_bits_def
                        shiftl_t2n power_add)
  done

lemma objBitsKO_bounded2[simp]:
  "objBitsKO ko < word_bits"
  by (simp add: objBits_simps' word_bits_def pageBits_def archObjSize_def pdeBits_def pteBits_def
           split: Structures_H.kernel_object.split arch_kernel_object.split)

declare select_singleton_is_return[simp]

definition
  APIType_capBits :: "ARM_H.object_type \<Rightarrow> nat \<Rightarrow> nat"
where
  "APIType_capBits ty us \<equiv> case ty of
      APIObjectType ArchTypes_H.Untyped \<Rightarrow> us
    | APIObjectType ArchTypes_H.TCBObject \<Rightarrow> objBits (makeObject :: tcb)
    | APIObjectType ArchTypes_H.EndpointObject \<Rightarrow> objBits (makeObject :: endpoint)
    | APIObjectType ArchTypes_H.NotificationObject \<Rightarrow> objBits (makeObject :: Structures_H.notification)
    | APIObjectType ArchTypes_H.CapTableObject \<Rightarrow> objBits (makeObject :: cte) + us
    | SmallPageObject \<Rightarrow> pageBitsForSize ARMSmallPage
    | LargePageObject \<Rightarrow> pageBitsForSize ARMLargePage
    | SectionObject \<Rightarrow> pageBitsForSize ARMSection
    | SuperSectionObject \<Rightarrow> pageBitsForSize ARMSuperSection
    | PageTableObject \<Rightarrow> 10
    | PageDirectoryObject \<Rightarrow> 14"

definition
  makeObjectKO :: "bool \<Rightarrow> (kernel_object + ARM_H.object_type) \<rightharpoonup> kernel_object"
where
  "makeObjectKO dev ty \<equiv> case ty of
      Inl KOUserData \<Rightarrow> Some KOUserData
    | Inl (KOArch (KOASIDPool _)) \<Rightarrow> Some (KOArch (KOASIDPool makeObject))
    | Inr (APIObjectType ArchTypes_H.TCBObject) \<Rightarrow> Some (KOTCB makeObject)
    | Inr (APIObjectType ArchTypes_H.EndpointObject) \<Rightarrow> Some (KOEndpoint makeObject)
    | Inr (APIObjectType ArchTypes_H.NotificationObject) \<Rightarrow> Some (KONotification makeObject)
    | Inr (APIObjectType ArchTypes_H.CapTableObject) \<Rightarrow> Some (KOCTE makeObject)
    | Inr PageTableObject \<Rightarrow> Some (KOArch (KOPTE makeObject))
    | Inr PageDirectoryObject \<Rightarrow> Some (KOArch (KOPDE makeObject))
    | Inr SmallPageObject \<Rightarrow> Some (if dev then KOUserDataDevice else KOUserData)
    | Inr LargePageObject \<Rightarrow> Some(if dev then KOUserDataDevice else KOUserData)
    | Inr SectionObject \<Rightarrow> Some (if dev then KOUserDataDevice else KOUserData)
    | Inr SuperSectionObject \<Rightarrow> Some (if dev then KOUserDataDevice else KOUserData)
    | _ \<Rightarrow> None"

text \<open>makeObject etc. lemmas\<close>

lemma NullCap_valid' [iff]: "s \<turnstile>' capability.NullCap"
  unfolding valid_cap'_def by simp

lemma valid_obj_makeObject_cte [simp]:
  "valid_obj' (KOCTE makeObject) s"
  unfolding valid_obj'_def valid_cte'_def
  by (clarsimp simp: makeObject_cte)

lemma valid_obj_makeObject_tcb [simp]:
  "valid_obj' (KOTCB makeObject) s"
  unfolding valid_obj'_def valid_tcb'_def  valid_tcb_state'_def
  by (clarsimp simp: makeObject_tcb makeObject_cte tcb_cte_cases_def minBound_word)

lemma valid_obj_makeObject_endpoint [simp]:
  "valid_obj' (KOEndpoint makeObject) s"
  unfolding valid_obj'_def valid_ep'_def
  by (clarsimp simp: makeObject_endpoint)

lemma valid_obj_makeObject_notification [simp]:
  "valid_obj' (KONotification makeObject) s"
  unfolding valid_obj'_def valid_ntfn'_def
  by (clarsimp simp: makeObject_notification)

lemma valid_obj_makeObject_user_data [simp]:
  "valid_obj' (KOUserData) s"
  unfolding valid_obj'_def by simp

lemma valid_obj_makeObject_user_data_device [simp]:
  "valid_obj' (KOUserDataDevice) s"
  unfolding valid_obj'_def by simp

lemma valid_obj_makeObject_pte[simp]:
  "valid_obj' (KOArch (KOPTE makeObject)) s"
  unfolding valid_obj'_def by (simp add: makeObject_pte)

lemma valid_obj_makeObject_pde[simp]:
  "valid_obj' (KOArch (KOPDE makeObject)) s"
  unfolding valid_obj'_def by (simp add: makeObject_pde)

lemma valid_obj_makeObject_asid_pool[simp]:
  "valid_obj' (KOArch (KOASIDPool makeObject)) s"
  unfolding valid_obj'_def
  by (simp add: makeObject_asidpool Let_def ran_def dom_def)

lemmas valid_obj_makeObject_rules =
  valid_obj_makeObject_user_data valid_obj_makeObject_tcb
  valid_obj_makeObject_endpoint valid_obj_makeObject_notification
  valid_obj_makeObject_cte valid_obj_makeObject_pte valid_obj_makeObject_pde
  valid_obj_makeObject_asid_pool valid_obj_makeObject_user_data_device

text \<open>On the abstract side\<close>

text \<open>Lemmas for createNewObjects etc.\<close>

lemma pspace_dom_upd:
  assumes      orth: "set as \<inter> dom ps = {}"
  shows "pspace_dom (foldr (\<lambda>p ps. ps(p \<mapsto> ko)) as ps) =
       pspace_dom ps \<union> (\<Union>x \<in> set as. fst ` obj_relation_cuts ko x)"
  using orth
  apply (subst foldr_upd_app_if)
  apply (rule set_eqI, simp add: pspace_dom_def)
  apply (rule iffI)
   apply (clarsimp split: if_split_asm)
   apply (rule rev_bexI, erule domI)
   apply (fastforce simp: image_def)
  apply (erule disjE)
   apply clarsimp
   apply (rule rev_bexI)
    apply (clarsimp simp: domIff)
    apply (erule exI)
   apply clarsimp
   apply (intro conjI impI)
    apply (drule equals0D, erule notE, erule IntI, erule domI)
   apply (fastforce simp: image_def)
  apply clarsimp
  apply (rule rev_bexI)
   apply (clarsimp simp: domIff)
   apply (erule(1) notE)
  apply clarsimp
  apply (fastforce simp: image_def)
  done

definition
  "new_cap_addrs \<equiv> \<lambda>n ptr ko. map (\<lambda>p. ptr + ((of_nat p :: word32) << (objBitsKO ko)))
                [0 ..< n]"

definition
  null_filter' :: "('a \<rightharpoonup> cte) \<Rightarrow> ('a \<rightharpoonup> cte)"
where
 "null_filter' f \<equiv> \<lambda>x. if f x = Some (CTE NullCap nullMDBNode) then None else f x"

lemma across_null_filter_eq':
  assumes eq: "null_filter' xs = null_filter' ys"
  shows "\<lbrakk> xs x = Some v; ys x = Some v \<Longrightarrow> R;
           \<lbrakk> v = CTE NullCap nullMDBNode; ys x = None \<rbrakk> \<Longrightarrow> R \<rbrakk>
            \<Longrightarrow> R"
  apply (cases "null_filter' xs x")
   apply (subgoal_tac "null_filter' ys x = None")
    apply (simp add: null_filter'_def split: if_split_asm)
   apply (simp add: eq)
  apply (subgoal_tac "null_filter' ys x = Some a")
   apply (simp add: null_filter'_def split: if_split_asm)
  apply (simp add: eq)
  done

lemma null_filter_parent_of'':
  "\<lbrakk> null_filter' xs = null_filter' ys; xs \<turnstile> x \<leadsto> c; c \<noteq> 0 \<rbrakk>
     \<Longrightarrow> ys \<turnstile> x \<leadsto> c"
  apply (clarsimp simp add: mdb_next_unfold)
  apply (drule arg_cong[where f="\<lambda>xs. xs x"])
  apply (simp add: null_filter'_def nullPointer_def split: if_split_asm)
  done

lemma null_filter_parentOf:
  "\<lbrakk> null_filter' xs = null_filter' ys; xs \<turnstile> x parentOf y \<rbrakk>
      \<Longrightarrow> ys \<turnstile> x parentOf y"
  apply (clarsimp simp add: parentOf_def)
  apply (rule across_null_filter_eq'[where x=x], assumption+)
   apply (erule(1) across_null_filter_eq')
    apply clarsimp
   apply simp
  apply simp
  done

lemma null_filter_descendant:
  "\<lbrakk> null_filter' xs = null_filter' ys; xs \<turnstile> x \<rightarrow> y \<rbrakk>
      \<Longrightarrow> ys \<turnstile> x \<rightarrow> y"
  apply (erule subtree.induct)
   apply (rule subtree.direct_parent)
     apply (erule(2) null_filter_parent_of'')
    apply assumption
   apply (erule(1) null_filter_parentOf)
  apply (erule subtree.trans_parent)
    apply (erule(2) null_filter_parent_of'')
   apply assumption
  apply (erule(1) null_filter_parentOf)
  done

lemma null_filter_descendants_of':
  "null_filter' xs = null_filter' ys
    \<Longrightarrow> descendants_of' x xs = descendants_of' x ys"
  apply (simp add: descendants_of'_def)
  apply (rule set_eqI, rule iffI)
   apply simp
   apply (erule(1) null_filter_descendant)
  apply simp
  apply (erule(1) null_filter_descendant[OF sym])
  done

lemma descendants_of_cte_at':
  "\<lbrakk> p \<in> descendants_of x (cdt s); valid_mdb s \<rbrakk>
  \<Longrightarrow> cte_wp_at (\<lambda>c. c \<noteq> cap.NullCap) p s"
  apply (simp add: descendants_of_def)
  apply (drule tranclD2)
  apply (clarsimp simp: cdt_parent_defs valid_mdb_def mdb_cte_at_def
                  simp del: split_paired_All)
  apply (fastforce elim: cte_wp_at_weakenE)
  done


lemma descendants_of_cte_at2':
  "\<lbrakk> p \<in> descendants_of x (cdt s); valid_mdb s \<rbrakk>
  \<Longrightarrow> cte_wp_at (\<lambda>c. c \<noteq> cap.NullCap) x s"
  apply (simp add: descendants_of_def)
  apply (drule tranclD)
  apply (clarsimp simp: cdt_parent_defs valid_mdb_def mdb_cte_at_def
                  simp del: split_paired_All)
  apply (fastforce elim: cte_wp_at_weakenE)
  done

lemma cte_at_next_slot'':
  notes split_paired_All[simp del] split_paired_Ex[simp del]
  shows "\<lbrakk>valid_list s; valid_mdb s; finite_depth (cdt s)\<rbrakk>
    \<Longrightarrow> next_slot p (cdt_list s) (cdt s) = Some n \<Longrightarrow> cte_wp_at (\<lambda>c. c \<noteq> cap.NullCap) p s"
  apply(simp add: next_slot_def)
  apply(simp split: if_split_asm)
   apply(drule next_childD, simp)
   apply(rule_tac p=n in descendants_of_cte_at2')
    apply(simp add: child_descendant)
   apply(simp)
  apply(subgoal_tac "next_not_child_dom (p, cdt_list s, cdt s)")
   prefer 2
   apply(simp add: next_not_child_termination valid_mdb_def valid_list_def)
  apply(simp split: if_split_asm)
   apply(case_tac "cdt s p")
    apply(simp)
   apply(rule descendants_of_cte_at')
    apply(simp add: descendants_of_def cdt_parent_defs)
    apply(rule r_into_trancl, simp)
   apply(simp)
  apply(drule next_sibD)
  apply(elim exE conjE)
  apply(drule after_in_list_in_list)
  apply(rule descendants_of_cte_at')
   apply(simp add: descendants_of_def cdt_parent_defs)
   apply(rule r_into_trancl, simp)
  apply(simp)
  done


lemma state_relation_null_filterE:
  "\<lbrakk> (s, s') \<in> state_relation; t = kheap_update f (ekheap_update ef s);
     \<exists>f' g' h'.
     t' = s'\<lparr>ksPSpace := f' (ksPSpace s'), gsUserPages := g' (gsUserPages s'),
             gsCNodes := h' (gsCNodes s')\<rparr>;
     null_filter (caps_of_state t) = null_filter (caps_of_state s);
     null_filter' (ctes_of t') = null_filter' (ctes_of s');
     pspace_relation (kheap t) (ksPSpace t');
     ekheap_relation (ekheap t) (ksPSpace t');
     ghost_relation (kheap t) (gsUserPages t') (gsCNodes t'); valid_list s;
     pspace_aligned' s'; pspace_distinct' s'; valid_objs s; valid_mdb s;
     pspace_aligned' t'; pspace_distinct' t';
     mdb_cte_at (swp (cte_wp_at ((\<noteq>) cap.NullCap)) s) (cdt s) \<rbrakk>
      \<Longrightarrow> (t, t') \<in> state_relation"
  apply (clarsimp simp: state_relation_def)
  apply (intro conjI)
    apply (simp add: cdt_relation_def cte_wp_at_caps_of_state)
    apply (elim allEI)
    apply clarsimp
    apply (erule(1) across_null_filter_eq)
     apply simp
     apply (rule null_filter_descendants_of', simp)
    apply simp
    apply (case_tac "cdt s (a, b)")
     apply (subst mdb_cte_at_no_descendants, assumption)
      apply (simp add: cte_wp_at_caps_of_state swp_def)
     apply (cut_tac s="kheap_update f (ekheap_update ef s)"  and
                    s'="s'\<lparr>ksPSpace := f' (ksPSpace s'),
                           gsUserPages := g' (gsUserPages s'),
                           gsCNodes := h' (gsCNodes s')\<rparr>"
            in pspace_relation_ctes_ofI, simp_all)[1]
      apply (simp add: trans_state_update[symmetric] del: trans_state_update)
      apply (erule caps_of_state_cteD)
     apply (clarsimp simp: descendants_of'_def)
     apply (case_tac cte)
     apply (erule Null_not_subtree[rotated])
     apply simp
    apply (drule(1) mdb_cte_atD)
    apply (clarsimp simp: cte_wp_at_caps_of_state)
   apply(simp add: cdt_list_relation_def cte_wp_at_caps_of_state)
   apply(elim allEI)
   apply(clarsimp)
   apply(case_tac "next_slot (a, b) (cdt_list (s)) (cdt s)")
    apply(simp)
   apply(subgoal_tac "cte_wp_at (\<lambda>c. c \<noteq> cap.NullCap) (a, b) s")
    apply(drule_tac f="\<lambda>cs. cs (a, b)" in arg_cong)
    apply(clarsimp simp: cte_wp_at_caps_of_state)
    apply(clarsimp simp: null_filter_def split: if_split_asm)
    apply(drule_tac f="\<lambda>ctes. ctes (cte_map (a, b))" in arg_cong)
    apply(simp add: null_filter'_def cte_wp_at_ctes_of split: if_split_asm)
    apply(frule pspace_relation_cte_wp_at)
       apply(simp add: cte_wp_at_caps_of_state)
      apply(simp)
     apply(simp)
    apply(simp add: cte_wp_at_ctes_of)
   apply (simp add: mdb_cte_at_def)
   apply(frule finite_depth)
   apply(frule(3) cte_at_next_slot'')
   apply simp
  apply (simp add: revokable_relation_def)
  apply (elim allEI, rule impI, drule(1) mp, elim allEI)
  apply (clarsimp elim!: null_filterE)
  apply (drule(3) pspace_relation_cte_wp_at [OF _ caps_of_state_cteD])
  apply (drule_tac f="\<lambda>ctes. ctes (cte_map (a, b))" in arg_cong)
  apply (clarsimp simp: null_filter'_def cte_wp_at_ctes_of
                 split: if_split_asm)
  done

lemma lookupAround2_pspace_no:
  "is_aligned ptr sz \<Longrightarrow>
   (case fst (lookupAround2 (ptr + 2 ^ sz - 1) ps) of None \<Rightarrow> return ()
             | Some (x, y) \<Rightarrow> haskell_assert (x < fromPPtr ptr) [])
      = assert ({ptr..ptr + 2 ^ sz - 1} \<inter> dom ps = {})"
  apply (simp add: assert_def split: option.split)
  apply safe
    apply (clarsimp simp: lookupAround2_None1)
   apply (clarsimp simp: lookupAround2_char1)
  apply (clarsimp simp: lookupAround2_char1)
  apply (drule_tac a=a in equals0D)
  apply (simp add: linorder_not_less)
  apply fastforce
  done

lemma pspace_no_overlap_disjoint':
  "\<lbrakk>pspace_aligned' s;pspace_no_overlap' x n s\<rbrakk>
   \<Longrightarrow> {x .. (x && ~~ mask n) + 2 ^ n  - 1} \<inter> dom (ksPSpace s) = {}"
  unfolding pspace_no_overlap'_def
  apply (rule disjointI)
  apply (rule ccontr)
  apply clarsimp
  apply (elim allE impE notE)
    apply (simp add:field_simps)+
    apply (erule(2) order_trans[OF _ is_aligned_no_overflow,OF _ pspace_alignedD'])
    apply (erule(1) is_aligned_no_overflow[OF pspace_alignedD'])
  apply (erule order_trans)
  apply (simp add:p_assoc_help)
done

lemma foldr_update_ko_wp_at':
  assumes pv: "pspace_aligned' s" "pspace_distinct' s"
     and pv': "pspace_aligned' (ksPSpace_update (\<lambda>x xa. if xa \<in> set addrs then Some obj else ksPSpace s xa) s)"
              "pspace_distinct' (ksPSpace_update (\<lambda>x xa. if xa \<in> set addrs then Some obj else ksPSpace s xa) s)"
      and al: "\<forall>x \<in> set addrs. is_aligned x (objBitsKO obj)"
   shows
  "ko_wp_at' P p (ksPSpace_update (\<lambda>x xa. if xa \<in> set addrs then Some obj else ksPSpace s xa) s)
         = (if p \<in> set addrs then P obj
                         else ko_wp_at' P p s)"
  (is "ko_wp_at' P p ?s' = ?Q")
  apply (clarsimp simp: ko_wp_at'_def projectKOs al)
  apply (intro conjI impI)
   apply safe[1]
   apply (rule pspace_distinctD' [OF _ pv'(2)])
   apply simp
  apply safe[1]
   apply (simp add: ps_clear_def dom_if_Some)
   apply blast
  apply simp
  apply (rule pspace_distinctD' [OF _ pv'(2)])
  apply simp
  done

lemma foldr_update_obj_at':
  assumes pv: "pspace_aligned' s" "pspace_distinct' s"
     and pv': "pspace_aligned' (ksPSpace_update (\<lambda>x xa. if xa \<in> set addrs then Some obj else ksPSpace s xa) s)"
              "pspace_distinct' (ksPSpace_update (\<lambda>x xa. if xa \<in> set addrs then Some obj else ksPSpace s xa) s)"
      and al: "\<forall>x \<in> set addrs. is_aligned x (objBitsKO obj)"
   shows
  "obj_at' P p (ksPSpace_update (\<lambda>x xa. if xa \<in> set addrs then Some obj else ksPSpace s xa) s)
         = (if p \<in> set addrs then (\<exists>obj'. projectKO_opt obj = Some obj' \<and> P obj')
                         else obj_at' P p s)"
  apply (simp only: obj_at'_real_def)
  apply (rule foldr_update_ko_wp_at' [OF pv pv' al])
  done

lemma makeObjectKO_eq:
  assumes x: "makeObjectKO dev tp = Some v"
  shows
  "(v = KOCTE cte) =
       (tp = Inr (APIObjectType ArchTypes_H.CapTableObject) \<and> cte = makeObject)"
  "(v = KOTCB tcb) =
       (tp = Inr (APIObjectType ArchTypes_H.TCBObject) \<and> tcb = makeObject)"
  using x
  by (simp add: makeObjectKO_def eq_commute
         split: apiobject_type.split_asm sum.split_asm kernel_object.split_asm
                ARM_H.object_type.split_asm arch_kernel_object.split_asm)+

lemma pspace_no_overlap_base':
  "\<lbrakk>pspace_aligned' s;pspace_no_overlap' x n s; is_aligned x n \<rbrakk> \<Longrightarrow> ksPSpace s x = None"
  apply (drule(1) pspace_no_overlap_disjoint')
  apply (drule equals0D[where a=x])
  apply (rule ccontr, clarsimp)
  apply (erule is_aligned_get_word_bits)
   apply (erule impE)
   apply (frule mask_out_add_aligned[where q = 0,simplified,symmetric])
   apply (fastforce simp add: is_aligned_no_overflow)
  apply clarsimp+
  done

lemma the_ctes_makeObject:
  "fst (the (tcb_cte_cases n)) makeObject
     = (if tcb_cte_cases n = None
           then fst (the None :: (Structures_H.tcb \<Rightarrow> cte) \<times> ((cte \<Rightarrow> cte) \<Rightarrow> Structures_H.tcb \<Rightarrow> Structures_H.tcb))
                     (makeObject :: tcb)
           else makeObject)"
  apply (simp add: makeObject_tcb)
  apply (clarsimp simp: tcb_cte_cases_def)
  done

lemma cte_wp_at_obj_cases_mask:
  "cte_wp_at' P p s =
       (obj_at' P p s \<or>
          (p && mask tcbBlockSizeBits \<in> dom tcb_cte_cases
             \<and> obj_at' (P \<circ> fst (the (tcb_cte_cases (p && mask tcbBlockSizeBits))))
                     (p && ~~ mask tcbBlockSizeBits) s))"
  apply (simp add: cte_wp_at_obj_cases')
  apply (rule arg_cong [where f="\<lambda>x. F \<or> x" for F])
  apply (rule iffI)
   apply (clarsimp simp: obj_at'_def projectKOs objBits_simps)
   apply (frule(1) tcb_cte_cases_aligned_helpers)
   apply fastforce
  apply (clarsimp simp: obj_at'_def projectKOs objBits_simps)
  apply (rule bexI[where x="p && mask tcbBlockSizeBits"])
   apply (clarsimp simp: subtract_mask)
  apply fastforce
  done

lemma ps_clearD:
  "\<lbrakk> ps_clear x n s; ksPSpace s y = Some v; x < y; y \<le> x + 2 ^ n - 1 \<rbrakk> \<Longrightarrow> False"
  apply (clarsimp simp: ps_clear_def)
  apply (drule_tac a=y in equals0D)
  apply (simp add: dom_def)
  apply fastforce
  done

lemma cte_wp_at_retype':
  assumes ko: "makeObjectKO dev tp = Some obj"
      and pv: "pspace_aligned' s" "pspace_distinct' s"
     and pv': "pspace_aligned' (ksPSpace_update (\<lambda>x xa. if xa \<in> set addrs then Some obj else ksPSpace s xa) s)"
              "pspace_distinct' (ksPSpace_update (\<lambda>x xa. if xa \<in> set addrs then Some obj else ksPSpace s xa) s)"
      and al: "\<forall>x \<in> set addrs. is_aligned x (objBitsKO obj)"
      and pn: "\<forall>x \<in> set addrs. ksPSpace s x = None"
   shows
  "cte_wp_at' P p (ksPSpace_update (\<lambda>x xa. if xa \<in> set addrs then Some obj else ksPSpace s xa) s)
      = (if tp = Inr (APIObjectType ArchTypes_H.CapTableObject) \<and> p \<in> set addrs
           \<or> tp = Inr (APIObjectType ArchTypes_H.TCBObject)
                         \<and> (p && ~~ mask tcbBlockSizeBits \<in> set addrs) \<and> (p && mask tcbBlockSizeBits \<in> dom tcb_cte_cases)
              then P (CTE NullCap nullMDBNode)
              else cte_wp_at' P p s)"
  (is "cte_wp_at' P p ?s' = ?Q")
  apply (subgoal_tac "\<forall>p \<in> set addrs. \<forall>(P :: cte \<Rightarrow> bool). \<not> obj_at' P p s")
   apply (subgoal_tac "\<forall>p \<in> set addrs. \<forall>(P :: tcb \<Rightarrow> bool). \<not> obj_at' P p s")
    apply (subgoal_tac "(\<exists>P :: cte \<Rightarrow> bool. obj_at' P p ?s')
                          \<longrightarrow> (\<not> (\<exists>P :: tcb \<Rightarrow> bool. obj_at' P (p && ~~ mask tcbBlockSizeBits) ?s'))")
     apply (simp only: cte_wp_at_obj_cases_mask foldr_update_obj_at'[OF pv pv' al])
     apply (simp    add: projectKOs the_ctes_makeObject
                         makeObjectKO_eq [OF ko]
                         makeObject_cte dom_def
              split del: if_split
                   cong: if_cong)
     apply (insert al ko)
     apply (simp, safe, simp_all)
      apply fastforce
     apply fastforce
    apply (clarsimp elim!: obj_atE' simp: projectKOs objBits_simps)
    apply (drule ps_clearD[where y=p and n=tcbBlockSizeBits])
       apply simp
      apply (rule order_trans_rules(17))
       apply (clarsimp cong: if_cong)
      apply (rule word_and_le2)
     apply (rule word_neg_and_le[simplified field_simps])
    apply (clarsimp elim!: obj_atE' simp: pn)+
  done

lemma ctes_of_retype:
  assumes ko: "makeObjectKO dev tp = Some obj"
      and pv: "pspace_aligned' s" "pspace_distinct' s"
     and pv': "pspace_aligned' (ksPSpace_update (\<lambda>x xa. if xa \<in> set addrs then Some obj else ksPSpace s xa) s)"
              "pspace_distinct' (ksPSpace_update (\<lambda>x xa. if xa \<in> set addrs then Some obj else ksPSpace s xa) s)"
      and al: "\<forall>x \<in> set addrs. is_aligned x (objBitsKO obj)"
      and pn: "\<forall>x \<in> set addrs. ksPSpace s x = None"
   shows
  "map_to_ctes (\<lambda> xa. if xa \<in> set addrs then Some obj else ksPSpace s xa)
      = (\<lambda>x. if tp = Inr (APIObjectType ArchTypes_H.CapTableObject) \<and> x \<in> set addrs
              \<or> tp = Inr (APIObjectType ArchTypes_H.TCBObject)
                         \<and> (x && ~~ mask tcbBlockSizeBits \<in> set addrs) \<and> (x && mask tcbBlockSizeBits \<in> dom tcb_cte_cases)
             then Some (CTE NullCap nullMDBNode)
             else map_to_ctes (ksPSpace s) x)"
  (is "map_to_ctes ?ps' = ?map'")
  using cte_wp_at_retype' [where P="(=) cte" for cte, OF ko pv pv' al pn]
        arg_cong [where f=Not, OF cte_wp_at_retype' [OF ko pv pv' al pn, where P="\<top>"]]
  apply (simp(no_asm_use) add: cte_wp_at_ctes_of cong: if_cong)
  apply (rule ext)
  apply (case_tac "map_to_ctes ?ps' x")
   apply (simp(no_asm_simp))
   apply (simp split: if_split_asm)
  apply simp
  done

lemma None_ctes_of_cte_at:
  "(None = ctes_of s x) = (\<not> cte_at' x s)"
  by (fastforce simp add: cte_wp_at_ctes_of)

lemma null_filter_ctes_retype:
  assumes ko: "makeObjectKO dev tp = Some obj"
      and pv: "pspace_aligned' s" "pspace_distinct' s"
     and pv': "pspace_aligned' (ksPSpace_update (\<lambda>x xa. if xa \<in> set addrs then Some obj else ksPSpace s xa) s)"
              "pspace_distinct' (ksPSpace_update (\<lambda>x xa. if xa \<in> set addrs then Some obj else ksPSpace s xa) s)"
      and al: "\<forall>x \<in> set addrs. is_aligned x (objBitsKO obj)"
      and pn: "\<forall>x \<in> set addrs. ksPSpace s x = None"
  shows
  "null_filter' (map_to_ctes (foldr (\<lambda>addr. data_map_insert addr obj) addrs (ksPSpace s)))
    = null_filter' (map_to_ctes (ksPSpace s))"
  apply (subst foldr_upd_app_if[folded data_map_insert_def])
  apply (subst ctes_of_retype[OF ko pv pv' al pn])
  apply (rule ext)
  apply (clarsimp simp: null_filter'_def None_ctes_of_cte_at)
  apply (intro conjI impI notI)
   apply (elim cte_wp_atE' disjE conjE)
    apply (simp_all add: pn)
   apply (cut_tac x="ptr'" and v="if ptr' \<in> set addrs then obj else KOTCB tcb"
                in pspace_distinctD'[OF _ pv'(2)])[1]
    apply simp
   apply (insert ko[symmetric],
          simp add: makeObjectKO_def objBits_simps pn
             split: if_split_asm)[1]
   apply (drule(2) tcb_ctes_clear[where s="ksPSpace_update f s" for f s])
    apply simp
   apply fastforce
  apply (cut_tac x="x && ~~ mask tcbBlockSizeBits" in pspace_distinctD'[OF _ pv'(2)])[1]
   apply simp
  apply (elim cte_wp_atE' disjE conjE)
   apply (insert ko[symmetric], simp add: makeObjectKO_def objBits_simps)
   apply clarsimp
   apply (subst(asm) subtract_mask[symmetric],
          erule_tac v="if x \<in> set addrs then KOTCB makeObject else KOCTE cte"
                in tcb_space_clear)
       apply (simp add: is_aligned_mask word_bw_assocs)
      apply assumption
     apply simp
    apply simp
   apply (simp add: pn)
  apply (clarsimp simp: makeObjectKO_def)
  apply (drule(1) tcb_cte_cases_aligned_helpers)
  apply (clarsimp simp: pn)
  done

lemma new_cap_addrs_aligned:
  "\<lbrakk> is_aligned ptr (objBitsKO ko) \<rbrakk>
    \<Longrightarrow> \<forall>x \<in> set (new_cap_addrs n ptr ko). is_aligned x (objBitsKO ko)"
  apply (clarsimp simp: new_cap_addrs_def)
  apply (erule aligned_add_aligned[OF _ is_aligned_shift])
  apply simp
  done

lemma new_cap_addrs_distinct:
  assumes cover: "range_cover ptr sz (objBitsKO ko) n"
  shows "distinct (new_cap_addrs n ptr ko)"
  unfolding new_cap_addrs_def
  apply (simp add: distinct_map)
  apply (rule comp_inj_on[where f=of_nat, unfolded o_def])
   apply (rule subset_inj_on)
    apply (rule word_unat.Abs_inj_on)
   apply (clarsimp simp only: unats_def atLeastLessThan_iff
                  dest!: less_two_pow_divD)
   apply (insert cover)
   apply (erule less_le_trans)
   apply (insert range_cover.range_cover_n_le[OF cover])
   apply (erule le_trans)
   apply (cases "objBitsKO ko = 0")
    apply (simp add:word_bits_def)
   apply (rule less_imp_le)
    apply (rule power_strict_increasing)
    apply (simp add:word_bits_def)
   apply simp
  apply (rule inj_onI)
  apply clarsimp
  apply (drule arg_cong[where f="\<lambda>x. x >> objBitsKO ko"])
  apply (cases "objBitsKO ko = 0")
   apply simp
  apply (subst(asm) shiftl_shiftr_id, simp add: range_cover_def)
   apply (subst word_unat_power, rule of_nat_mono_maybe)
    apply (rule power_strict_increasing)
     apply (simp add: word_bits_def)
    apply simp
   apply (erule order_less_le_trans)
   apply simp
  apply (subst(asm) shiftl_shiftr_id, simp add: range_cover_def)
   apply (subst word_unat_power, rule of_nat_mono_maybe)
    apply (rule power_strict_increasing)
     apply (simp add: word_bits_def)
    apply simp
   apply (erule order_less_le_trans)
   apply simp
  apply assumption
  done

lemma new_cap_addrs_subset:
  assumes range_cover:"range_cover ptr sz (objBitsKO ko) n"
  shows "set (new_cap_addrs n ptr ko) \<subseteq> {ptr .. ptr_add (ptr && ~~ mask sz) (2 ^ sz - 1)}"
  apply (clarsimp simp add: new_cap_addrs_def shiftl_t2n
                            field_simps
                     dest!: less_two_pow_divD)
  apply (intro conjI)
  apply (insert range_cover)
  apply (rule machine_word_plus_mono_right_split[OF range_cover.range_cover_compare])
    apply assumption
    apply simp
    apply (simp add:range_cover_def word_bits_def)
  apply (clarsimp simp:ptr_add_def)
  apply (subst word_plus_and_or_coroll2[symmetric,where w = "mask sz"])
  apply (subst add.commute)
  apply (subst add.assoc)
  apply (rule word_plus_mono_right)
  apply (drule(1) range_cover.range_cover_compare)
  apply (rule iffD1[OF le_m1_iff_lt,THEN iffD2])
    using range_cover
    apply (simp add: p2_gt_0 range_cover_def word_bits_def)
   apply (rule iffD2[OF word_less_nat_alt])
   apply (rule le_less_trans[OF unat_plus_gt])
   using range_cover
   apply (clarsimp simp: range_cover_def)
  apply (insert range_cover)
  apply (rule is_aligned_no_wrap'[OF is_aligned_neg_mask,OF le_refl ])
   apply (simp add:range_cover_def)+
done

definition
  obj_relation_retype :: "Structures_A.kernel_object \<Rightarrow>
                            Structures_H.kernel_object \<Rightarrow> bool"
where
 "obj_relation_retype ko ko' \<equiv>
   obj_bits ko \<ge> objBitsKO ko'
    \<and> (\<forall>p. fst ` obj_relation_cuts ko p
             = {p + x * 2 ^ (objBitsKO ko') | x. x < 2 ^ (obj_bits ko - objBitsKO ko')}
              \<and> (\<forall>x \<in> obj_relation_cuts ko p. snd x ko ko'))"

lemma obj_relation_retype_cutsD:
  "\<lbrakk> (x, P) \<in> obj_relation_cuts ko p; obj_relation_retype ko ko' \<rbrakk>
      \<Longrightarrow> \<exists>y. x = p + y * 2 ^ (objBitsKO ko') \<and> y < 2 ^ (obj_bits ko - objBitsKO ko')
                 \<and> P ko ko'"
  apply (clarsimp simp: obj_relation_retype_def)
  apply (drule spec[where x=p])
  apply clarsimp
  apply (drule(1) bspec)
  apply (drule arg_cong[where f="\<lambda>S. x \<in> S"])
  apply clarsimp
  apply (fastforce simp: image_def)
  done

lemma APIType_map2_Untyped[simp]:
  "(APIType_map2 tp = Structures_A.Untyped)
        = (tp = Inr (APIObjectType ArchTypes_H.Untyped))"
 by (simp add: APIType_map2_def
         split: sum.split object_type.split kernel_object.split arch_kernel_object.splits
                apiobject_type.split)

lemma obj_relation_retype_leD:
  "\<lbrakk> obj_relation_retype ko ko' \<rbrakk>
      \<Longrightarrow> objBitsKO ko' \<le> obj_bits ko"
  by (simp add: obj_relation_retype_def)

lemma obj_relation_retype_default_leD:
  "\<lbrakk> obj_relation_retype (default_object (APIType_map2 ty) dev us) ko;
       ty \<noteq> Inr (APIObjectType ArchTypes_H.Untyped) \<rbrakk>
      \<Longrightarrow> objBitsKO ko \<le> obj_bits_api (APIType_map2 ty) us"
  by (simp add: obj_relation_retype_def objBits_def obj_bits_dev_irr)

lemma makeObjectKO_Untyped:
  "makeObjectKO dev ty = Some v \<Longrightarrow> ty \<noteq> Inr (APIObjectType ArchTypes_H.Untyped)"
  by (clarsimp simp: makeObjectKO_def)

lemma obj_relation_cuts_trivial:
  "ptr \<in> fst ` obj_relation_cuts x ptr"
  apply (case_tac x)
      apply (rename_tac sz cs)
      apply (clarsimp simp:image_def cte_map_def well_formed_cnode_n_def)
      apply (rule_tac x = "replicate sz False" in exI)
      apply clarsimp+
  apply (rename_tac arch_kernel_obj)
  apply (case_tac arch_kernel_obj)
     apply clarsimp
    apply (simp_all add:image_def pageBits_def)
    apply (rule_tac x = 0 in exI, simp)+
  apply (rule p2_gt_0[THEN iffD2])
  apply (rename_tac vmpage_size)
  apply (case_tac vmpage_size)
     apply (clarsimp simp:pageBitsForSize_def)+
  done

lemma obj_relation_retype_addrs_eq:
  assumes not_unt:"ty \<noteq> Inr (APIObjectType ArchTypes_H.Untyped)"
  assumes  amp: "m = 2^ ((obj_bits_api (APIType_map2 ty) us) - (objBitsKO ko)) * n"
  assumes  orr: "obj_relation_retype (default_object (APIType_map2 ty) dev us) ko"
  shows  "\<lbrakk> range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n \<rbrakk> \<Longrightarrow>
   (\<Union>x \<in> set (retype_addrs ptr (APIType_map2 ty) n us).
            fst ` obj_relation_cuts (default_object (APIType_map2 ty) dev us) x)
      = set (new_cap_addrs m ptr ko)"
  apply (rule set_eqI, rule iffI)
   apply (clarsimp simp: retype_addrs_def)
   apply (rename_tac p a b)
   apply (drule obj_relation_retype_cutsD[OF _ orr])
   apply (cut_tac obj_relation_retype_default_leD[OF orr not_unt])
   apply (clarsimp simp: new_cap_addrs_def image_def
                  dest!: less_two_pow_divD)
   apply (rule_tac x="p * 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) + unat y"
                 in rev_bexI)
    apply (simp add: amp obj_bits_api_default_object not_unt obj_bits_dev_irr)
    apply (rule less_le_trans[OF nat_add_left_cancel_less[THEN iffD2]])
    apply (erule unat_mono)
      apply (subst unat_power_lower)
      apply (rule le_less_trans[OF diff_le_self])
      apply (clarsimp simp: range_cover_def
        split: Structures_A.apiobject_type.splits)
    apply (simp add:field_simps,subst mult_Suc[symmetric])
    apply (rule mult_le_mono1)
      apply simp
   apply (simp add: ptr_add_def shiftl_t2n field_simps
                    objBits_def[symmetric] word_unat_power[symmetric])
   apply (simp add: power_add[symmetric])
  apply (clarsimp simp: new_cap_addrs_def retype_addrs_def
                 dest!: less_two_pow_divD)
  apply (rename_tac p)
  apply (cut_tac obj_relation_retype_default_leD[OF orr not_unt])
  apply (cut_tac obj_relation_retype_leD[OF orr])
  apply (case_tac "n = 0")
   apply (simp add:amp)
  apply (case_tac "p = 0")
    apply simp
    apply (rule_tac x = 0 in rev_bexI)
    apply simp+
    apply (rule obj_relation_cuts_trivial)
  apply (rule_tac x="p div (2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko))"
           in rev_bexI)
   apply (simp add:amp)
   apply (rule td_gal_lt[THEN iffD1])
     apply (simp add:field_simps)+
  using orr
  apply (clarsimp simp: obj_relation_retype_def ptr_add_def)
  apply (thin_tac "\<forall>x. P x" for P)
  apply (rule_tac x="of_nat (p mod (2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko)))" in exI)
  apply (simp only: word_unat_power Abs_fnat_homs shiftl_t2n)
  apply (rule conjI)
   apply (rule arg_cong[where f=of_nat])
   apply (subst mult_div_rearrange)
     apply simp
   apply (subst minus_mod_eq_mult_div[symmetric])
     apply (simp add:diff_mult_distrib2)
  apply (rule of_nat_mono_maybe)
   apply (rule power_strict_increasing)
   apply (rule le_less_trans[OF diff_le_self])
  apply (clarsimp simp: range_cover_def obj_bits_api_default_object obj_bits_dev_irr
                        not_unt word_bits_def)+
done

lemma objBits_le_obj_bits_api:
  "makeObjectKO dev ty = Some ko \<Longrightarrow>
   objBitsKO ko \<le> obj_bits_api (APIType_map2 ty) us"
  apply (case_tac ty)
    apply (auto simp: default_arch_object_def pageBits_def archObjSize_def pteBits_def pdeBits_def
                      makeObjectKO_def objBits_simps' APIType_map2_def obj_bits_api_def slot_bits_def
               split: Structures_H.kernel_object.splits arch_kernel_object.splits object_type.splits
                      Structures_H.kernel_object.splits arch_kernel_object.splits apiobject_type.splits)
  done

lemma obj_relation_retype_other_obj:
  "\<lbrakk> is_other_obj_relation_type (a_type ko); other_obj_relation ko ko' \<rbrakk>
      \<Longrightarrow> obj_relation_retype ko ko'"
  apply (simp add: obj_relation_retype_def)
  apply (subgoal_tac "objBitsKO ko' = obj_bits ko")
   apply (clarsimp simp: is_other_obj_relation_type)
  apply (fastforce simp: other_obj_relation_def objBits_simps' archObjSize_def
                  split: Structures_A.kernel_object.split_asm
                         Structures_H.kernel_object.split_asm
                         Structures_H.kernel_object.split
                         arch_kernel_obj.split_asm arch_kernel_object.split)
  done

lemma retype_pspace_relation:
  assumes  sr: "pspace_relation (kheap s) (ksPSpace s')"
      and  vs: "valid_pspace s" "valid_mdb s"
      and vs': "pspace_aligned' s'" "pspace_distinct' s'"
      and  pn: "pspace_no_overlap_range_cover ptr sz s"
      and pn': "pspace_no_overlap' ptr sz s'"
      and  ko: "makeObjectKO dev ty = Some ko"
      and cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n"
      and orr: "obj_relation_retype (default_object (APIType_map2 ty) dev us) ko"
      and num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n"
  shows
  "pspace_relation (foldr (\<lambda>p ps. ps(p \<mapsto> default_object (APIType_map2 ty) dev us))
                              (retype_addrs ptr (APIType_map2 ty) n us) (kheap s))
            (foldr (\<lambda>addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s'))"
  (is "pspace_relation ?ps ?ps'")
  unfolding pspace_relation_def
proof
  have not_unt: "ty \<noteq> Inr (APIObjectType ArchTypes_H.Untyped)"
     by (rule makeObjectKO_Untyped[OF ko])

  have dom_not_ra:
    "\<forall>x \<in> dom (kheap s). x \<notin> set (retype_addrs ptr (APIType_map2 ty) n us)"
    apply clarsimp
    apply (erule(1) pspace_no_overlapC[OF pn _ _ cover vs(1)])
    done

  hence dom_Int_ra:
    "set (retype_addrs ptr (APIType_map2 ty) n us) \<inter> dom (kheap s) = {}"
    by auto

  note pdom = pspace_dom_upd [OF dom_Int_ra, where ko="default_object (APIType_map2 ty) dev us"]

  have pdom': "dom ?ps' = dom (ksPSpace s') \<union> set (new_cap_addrs m ptr ko)"
    by (clarsimp simp add: foldr_upd_app_if[folded data_map_insert_def]
                           dom_if_Some Un_commute
                split del: if_split)

  note not_unt = makeObjectKO_Untyped [OF ko]

  have "pspace_dom (kheap s) = dom (ksPSpace s')"
    using sr by (simp add: pspace_relation_def)

  thus "pspace_dom ?ps = dom ?ps'"
    apply (simp add: pdom pdom')
    apply (rule arg_cong[where f="\<lambda>T. S \<union> T" for S])
    apply (rule obj_relation_retype_addrs_eq[OF not_unt num_r orr cover])
    done

  have dom_same:
    "\<And>x v. kheap s x = Some v \<Longrightarrow> ?ps x = Some v"
    apply (frule bspec [OF dom_not_ra, OF domI])
    apply (simp add: foldr_upd_app_if)
    done
  have cover':"range_cover ptr sz (objBitsKO ko) m"
    by (rule range_cover_rel[OF cover objBits_le_obj_bits_api[OF ko] num_r])
  have dom_same':
    "\<And>x v. ksPSpace s' x = Some v \<Longrightarrow> ?ps' x = Some v"
    apply (clarsimp simp:foldr_upd_app_if[folded data_map_insert_def])
    apply (drule domI[where m = "ksPSpace s'"])
    apply (drule(1) IntI)
    apply (erule_tac A = "A \<inter> B" for A B in in_emptyE[rotated])
    apply (rule disjoint_subset[OF new_cap_addrs_subset[OF cover']])
    apply (clarsimp simp:ptr_add_def field_simps)
    apply (rule pspace_no_overlap_disjoint'[OF vs'(1) pn'])
  done

  show "\<forall>x \<in> dom ?ps. \<forall>(y, P) \<in> obj_relation_cuts (the (?ps x)) x.
                   P (the (?ps x)) (the (?ps' y))"
    using sr
    apply (clarsimp simp: pspace_relation_def)
    apply (simp add: foldr_upd_app_if split: if_split_asm)
     apply (clarsimp simp: foldr_upd_app_if[folded data_map_insert_def])
     apply (rule conjI)
      apply (drule obj_relation_retype_cutsD [OF _ orr], clarsimp)
     apply (rule impI, erule notE)
     apply (simp add: obj_relation_retype_addrs_eq[OF not_unt num_r orr cover,symmetric])
     apply (erule rev_bexI)
     apply (simp add: image_def)
     apply (erule rev_bexI, simp)
    apply (drule bspec, erule domI)
    apply clarsimp
    apply (drule(1) bspec, simp)
    apply (subgoal_tac "a \<in> pspace_dom (kheap s)")
     apply clarsimp
     apply (frule dom_same', simp)
    apply (simp(no_asm) add: pspace_dom_def)
    apply (rule rev_bexI, erule domI)
    apply (simp add: image_def)
    apply (erule rev_bexI, simp)
    done
qed


(*Clagged from Retype_AC*)
lemma foldr_upd_app_if': "foldr (\<lambda>p ps. ps(p := f p)) as g = (\<lambda>x. if x \<in> set as then (f x) else g x)"
  apply (induct as)
   apply simp
  apply simp
  apply (rule ext)
  apply simp
  done

lemma etcb_rel_makeObject: "etcb_relation default_etcb makeObject"
  apply (simp add: etcb_relation_def default_etcb_def)
  apply (simp add: makeObject_tcb default_priority_def default_domain_def)
  done


lemma ekh_at_tcb_at: "valid_etcbs_2 ekh kh \<Longrightarrow> ekh x = Some y  \<Longrightarrow> \<exists>tcb. kh x = Some (TCB tcb)"
  apply (simp add: valid_etcbs_2_def
                   st_tcb_at_kh_def obj_at_kh_def
                   is_etcb_at'_def obj_at_def)
  apply force
  done

lemma default_etcb_default_domain_futz [simp]:
  "default_etcb\<lparr>tcb_domain := default_domain\<rparr> = default_etcb"
unfolding default_etcb_def by simp

lemma retype_ekheap_relation:
  assumes  sr: "ekheap_relation (ekheap s) (ksPSpace s')"
      and  sr': "pspace_relation (kheap s) (ksPSpace s')"
      and  vs: "valid_pspace s" "valid_mdb s"
      and et: "valid_etcbs s"
      and vs': "pspace_aligned' s'" "pspace_distinct' s'"
      and  pn: "pspace_no_overlap_range_cover ptr sz s"
      and pn': "pspace_no_overlap' ptr sz s'"
      and  ko: "makeObjectKO dev ty = Some ko"
      and cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n"
      and orr: "obj_relation_retype (default_object (APIType_map2 ty) dev us) ko"
      and num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n"
  shows
  "ekheap_relation (foldr (\<lambda>p ps. ps(p := default_ext (APIType_map2 ty) default_domain))
                              (retype_addrs ptr (APIType_map2 ty) n us) (ekheap s))
            (foldr (\<lambda>addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s'))"
  (is "ekheap_relation ?ps ?ps'")
  proof -
  have not_unt: "ty \<noteq> Inr (APIObjectType ArchTypes_H.Untyped)"
     by (rule makeObjectKO_Untyped[OF ko])
  show ?thesis
    apply (case_tac "ty \<noteq> Inr (APIObjectType apiobject_type.TCBObject)")
     apply (insert ko)
     apply (cut_tac retype_pspace_relation[OF sr' vs vs' pn pn' ko cover orr num_r])
     apply (simp add: foldr_upd_app_if' foldr_upd_app_if[folded data_map_insert_def])
     apply (simp add: obj_relation_retype_addrs_eq[OF not_unt num_r orr cover,symmetric])
     apply (insert sr)
     apply (clarsimp simp add: ekheap_relation_def
                      pspace_relation_def default_ext_def cong: if_cong
                      split: if_split_asm)
      subgoal by (clarsimp simp add: makeObjectKO_def APIType_map2_def cong: if_cong
                              split: sum.splits Structures_H.kernel_object.splits
                                     arch_kernel_object.splits ARM_H.object_type.splits apiobject_type.splits)

     apply (frule ekh_at_tcb_at[OF et])
     apply (intro impI conjI)
      apply clarsimp
      apply (drule_tac x=a in bspec,force)
      apply (clarsimp simp add: other_obj_relation_def split: if_split_asm)
       apply (case_tac ko,simp_all)
       apply (clarsimp simp add: makeObjectKO_def cong: if_cong split: sum.splits Structures_H.kernel_object.splits
                                 arch_kernel_object.splits ARM_H.object_type.splits
                                 apiobject_type.splits if_split_asm)
      apply (drule_tac x=xa in bspec,simp)
      subgoal by force
     subgoal by force
    apply (simp add: foldr_upd_app_if' foldr_upd_app_if[folded data_map_insert_def])
    apply (simp add: obj_relation_retype_addrs_eq[OF not_unt num_r orr cover,symmetric])
    apply (clarsimp simp add: APIType_map2_def default_ext_def ekheap_relation_def
           default_object_def makeObjectKO_def etcb_rel_makeObject
           cong: if_cong
           split: if_split_asm)
    apply force
  done
qed

lemma pspace_no_overlapD':
  "\<lbrakk> ksPSpace s x = Some ko; pspace_no_overlap' p bits s \<rbrakk>
       \<Longrightarrow> {x .. x + 2 ^ objBitsKO ko - 1} \<inter> {p .. (p && ~~ mask bits) + 2 ^ bits - 1} = {}"
  apply (simp add:pspace_no_overlap'_def)
  apply (intro impI)
  apply (elim allE impE)
  apply (simp add:field_simps)+
done

lemma new_range_subset:
  assumes
        cover: "range_cover ptr sz (objBitsKO ko) n"
    and addr: "x \<in> set (new_cap_addrs n ptr ko)"
  shows       "{x .. x + 2 ^ (objBitsKO ko) - 1} \<subseteq> {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1}"
  (is "?lhs \<subseteq> ?rhs")
proof -
  have base_in: "x \<in> {ptr..ptr_add (ptr && ~~ mask sz) (2 ^ sz - 1)}"
    by (rule set_mp[OF new_cap_addrs_subset[OF cover] addr])
  have aligned: "is_aligned x (objBitsKO ko)"
    apply (insert cover)
    apply (clarsimp simp:range_cover_def)
    apply (drule new_cap_addrs_aligned)
    apply (erule bspec[OF _ addr])
  done
  show ?thesis using base_in aligned addr
    apply (intro range_subsetI)
    apply (clarsimp simp:ptr_add_def field_simps)+
    apply (simp add:x_power_minus_1)
    apply (clarsimp simp:new_cap_addrs_def)
   apply (subst word_plus_and_or_coroll2[symmetric,where w = "mask sz"])
   apply (subst add.commute)
  apply (subst add.assoc)
  apply (subst add.assoc)
  apply (rule word_plus_mono_right)
  apply (simp add:mask_2pm1[symmetric])
    apply (rule iffD2[OF shiftr_mask_cmp[where c = "objBitsKO ko"]])
    apply (insert cover)
      apply (simp add:range_cover_def)
    apply (simp add:range_cover_def word_bits_def)
       apply (subst aligned_shift')
      apply (simp add:mask_lt_2pn range_cover_def word_bits_def )
     apply (drule is_aligned_addD1)
      apply (simp add:range_cover_def)
     apply (rule aligned_add_aligned)
       apply (rule aligned_already_mask)
       apply (fastforce simp:range_cover_def)
      apply (simp_all add: range_cover_def)[3]
   apply (subst shiftr_mask2[symmetric])
    apply (simp add:range_cover_def word_bits_def)
   apply (rule le_shiftr)
   apply (subst le_mask_iff_lt_2n[THEN iffD1])
    apply (simp add:range_cover_def word_bits_def)
   apply (clarsimp simp:word_less_nat_alt)
   apply (rule le_less_trans[OF unat_plus_gt])
   apply (frule(1) range_cover.range_cover_compare)
   apply (clarsimp simp:shiftl_t2n mult.commute range_cover_def)
  apply (rule is_aligned_no_wrap'[OF is_aligned_neg_mask])
    apply (rule le_refl)
   apply (simp add:range_cover_def)
  done
qed

lemma retype_aligned_distinct':
  assumes vs': "pspace_aligned' s'" "pspace_distinct' s'"
      and pn': "pspace_no_overlap' ptr sz s'"
      and cover: "range_cover ptr sz (objBitsKO ko) n "
  shows
  "pspace_distinct' (s' \<lparr>ksPSpace := foldr (\<lambda>addr. data_map_insert addr ko)
                                             (new_cap_addrs n ptr ko) (ksPSpace s')\<rparr>)"
  "pspace_aligned' (s' \<lparr>ksPSpace := foldr (\<lambda>addr. data_map_insert addr ko)
                                             (new_cap_addrs n ptr ko) (ksPSpace s')\<rparr>)"
  (is "pspace_aligned' (s'\<lparr>ksPSpace := ?ps\<rparr>)")
proof -
  have al: "is_aligned ptr (objBitsKO ko)"
    using cover
    by (simp add:cover range_cover_def)
  let ?s' = "s'\<lparr>ksPSpace := ?ps\<rparr>"
  note nc_al = bspec [OF new_cap_addrs_aligned [OF al]]
  note nc_al' = nc_al[unfolded objBits_def]

  show pa': "pspace_aligned' ?s'" using vs'(1)
    apply (subst foldr_upd_app_if[folded data_map_insert_def])
    apply (clarsimp simp add: pspace_aligned'_def nc_al'
                       split: if_split_asm)
    apply (drule bspec, erule domI, simp)
    done

  have okov: "objBitsKO ko < word_bits"
    by (simp add: objBits_def)

  have new_range_disjoint:
    "\<And>x. x \<in> set (new_cap_addrs n ptr ko) \<Longrightarrow>
         ({x .. x + 2 ^ (objBitsKO ko) - 1} - {x}) \<inter> set (new_cap_addrs n ptr ko) = {}"
    apply safe
    apply (rule ccontr)
    apply (frule(2) aligned_neq_into_no_overlap [OF _ nc_al nc_al])
    apply (drule_tac a=xa in equals0D)
    apply (clarsimp simp: field_simps is_aligned_no_overflow [OF nc_al])
    done
  note new_range_sub = new_range_subset [OF cover]

  show pd': "pspace_distinct' ?s'" using vs'(2)
    apply (subst foldr_upd_app_if[folded data_map_insert_def])
    apply (simp add: pspace_distinct'_def dom_if_Some ball_Un)
    apply (intro conjI ballI impI)
      apply (simp add: ps_clear_def dom_if_Some Int_Un_distrib
                       objBits_def[symmetric])
      apply (rule conjI)
       apply (erule new_range_disjoint)
      apply (rule disjoint_subset[OF Diff_subset])
      apply (erule disjoint_subset[OF new_range_sub])
      apply (rule pspace_no_overlap_disjoint'[OF vs'(1) pn'])
    apply (clarsimp simp add: ps_clear_def dom_if_Some Int_Un_distrib)
    apply (rule conjI)
      apply (erule new_range_disjoint)
     apply (rule disjoint_subset[OF Diff_subset])
     apply (erule disjoint_subset[OF new_range_sub])
     apply (rule pspace_no_overlap_disjoint'[OF vs'(1) pn'])
    apply (clarsimp simp add: ps_clear_def dom_if_Some Int_Un_distrib)
    apply (subst Int_commute)
    apply (rule disjoint_subset[OF new_cap_addrs_subset,OF cover])
    apply (subst Int_commute)
    apply (simp add:ptr_add_def field_simps)
    apply (rule disjoint_subset[OF Diff_subset])
    apply (erule pspace_no_overlapD' [OF _ pn'])
    done
qed

definition
  update_gs :: "Structures_A.apiobject_type \<Rightarrow> nat \<Rightarrow> word32 set
                \<Rightarrow> 'a kernel_state_scheme \<Rightarrow> 'a kernel_state_scheme"
where
 "update_gs ty us ptrs \<equiv>
  case ty of
    Structures_A.CapTableObject \<Rightarrow> gsCNodes_update
      (\<lambda>cns x. if x \<in> ptrs then Some us else cns x)
  | ArchObject (SmallPageObj) \<Rightarrow> gsUserPages_update
      (\<lambda>ups x. if x \<in> ptrs then Some ARMSmallPage else ups x)
  | ArchObject (LargePageObj) \<Rightarrow> gsUserPages_update
      (\<lambda>ups x. if x \<in> ptrs then Some ARMLargePage else ups x)
  | ArchObject (SectionObj) \<Rightarrow> gsUserPages_update
      (\<lambda>ups x. if x \<in> ptrs then Some ARMSection else ups x)
  | ArchObject (SuperSectionObj) \<Rightarrow> gsUserPages_update
      (\<lambda>ups x. if x \<in> ptrs then Some ARMSuperSection else ups x)
  | _ \<Rightarrow> id"

lemma ksPSpace_update_gs_eq[simp]:
  "ksPSpace (update_gs ty us ptrs s) = ksPSpace s"
  by (simp add: update_gs_def
           split: Structures_A.apiobject_type.splits aobject_type.splits)

end

global_interpretation update_gs: PSpace_update_eq "update_gs ty us ptrs"
  by (simp add: PSpace_update_eq_def)

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

lemma update_gs_id:
  "tp \<in> no_gs_types \<Longrightarrow> update_gs tp us addrs = id"
  by (simp add: no_gs_types_def update_gs_def
           split: Structures_A.apiobject_type.splits aobject_type.splits)

lemma update_gs_simps[simp]:
  "update_gs Structures_A.apiobject_type.CapTableObject us ptrs =
   gsCNodes_update (\<lambda>cns x. if x \<in> ptrs then Some us else cns x)"
  "update_gs (ArchObject SmallPageObj) us ptrs =
   gsUserPages_update (\<lambda>ups x. if x \<in> ptrs then Some ARMSmallPage else ups x)"
  "update_gs (ArchObject LargePageObj) us ptrs =
   gsUserPages_update (\<lambda>ups x. if x \<in> ptrs then Some ARMLargePage else ups x)"
  "update_gs (ArchObject SectionObj) us ptrs =
   gsUserPages_update (\<lambda>ups x. if x \<in> ptrs then Some ARMSection else ups x)"
  "update_gs (ArchObject SuperSectionObj) us ptrs =
   gsUserPages_update (\<lambda>ups x. if x \<in> ptrs then Some ARMSuperSection
                               else ups x)"
  by (simp_all add: update_gs_def)

lemma retype_state_relation:
  notes data_map_insert_def[simp del]
  assumes  sr:   "(s, s') \<in> state_relation"
      and  vs:   "valid_pspace s" "valid_mdb s"
      and  et:   "valid_etcbs s" "valid_list s"
      and vs':   "pspace_aligned' s'" "pspace_distinct' s'"
      and  pn:   "pspace_no_overlap_range_cover ptr sz s"
      and pn':   "pspace_no_overlap' ptr sz s'"
      and cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n"
      and  ko:   "makeObjectKO dev ty = Some ko"
      and api:   "obj_bits_api (APIType_map2 ty) us \<le> sz"
      and orr:   "obj_relation_retype (default_object (APIType_map2 ty) dev us) ko"
      and num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n"
  shows
  "(ekheap_update
              (\<lambda>_. foldr (\<lambda>p ekh a. if a = p then default_ext (APIType_map2 ty) default_domain else ekh a)
                    (retype_addrs ptr (APIType_map2 ty) n us) (ekheap s))
            s
           \<lparr>kheap :=
              foldr (\<lambda>p. data_map_insert p (default_object (APIType_map2 ty) dev us))
               (retype_addrs ptr (APIType_map2 ty) n us) (kheap s)\<rparr>,
           update_gs (APIType_map2 ty) us (set (retype_addrs ptr (APIType_map2 ty) n us))
            (s'\<lparr>ksPSpace :=
                  foldr (\<lambda>addr. data_map_insert addr ko) (new_cap_addrs m ptr ko)
                   (ksPSpace s')\<rparr>))
          \<in> state_relation"
  (is "(ekheap_update (\<lambda>_. ?eps) s\<lparr>kheap := ?ps\<rparr>, update_gs _ _ _ (s'\<lparr>ksPSpace := ?ps'\<rparr>))
       \<in> state_relation")
  proof (rule state_relation_null_filterE[OF sr refl _ _ _ _ _ _ _ vs'], simp_all add: trans_state_update[symmetric] del: trans_state_update)

  have cover':"range_cover ptr sz (objBitsKO ko) m"
    by (rule range_cover_rel[OF cover objBits_le_obj_bits_api[OF ko] num_r])
  have al':"is_aligned ptr (objBitsKO ko)"
    using cover'
    by (simp add:range_cover_def)
  have sz:"sz < word_bits"
    using cover'
    by (simp add:range_cover_def word_bits_def)
  let ?t = "s\<lparr>kheap := ?ps\<rparr>"
  let ?tp = "APIType_map2 ty"
  let ?al = "retype_addrs ptr ?tp n us"
  let ?t' = "update_gs ?tp us (set ?al) (s'\<lparr>ksPSpace := ?ps'\<rparr>)"

  note pad' = retype_aligned_distinct' [OF vs' pn' cover']
  thus pa': "pspace_aligned' (s'\<lparr>ksPSpace := ?ps'\<rparr>)"
   and pd': "pspace_distinct' (s'\<lparr>ksPSpace := ?ps'\<rparr>)"
    by simp_all

  note pa'' = pa'[simplified foldr_upd_app_if[folded data_map_insert_def]]
  note pd'' = pd'[simplified foldr_upd_app_if[folded data_map_insert_def]]

  note not_unt = makeObjectKO_Untyped [OF ko]
  show "null_filter (caps_of_state ?t) = null_filter (caps_of_state s)"
    apply (rule null_filter_caps_of_state_foldr[folded data_map_insert_def])
     apply (simp add: not_unt)
    apply (rule ballI)
    apply (erule pspace_no_overlapD2 [OF pn _ cover vs(1)])
    done

  have nc_dis: "distinct (new_cap_addrs m ptr ko)"
    by (rule new_cap_addrs_distinct [OF cover'])

  note nc_al = bspec [OF new_cap_addrs_aligned [OF al']]
  note nc_al' = nc_al[unfolded objBits_def]
  show "null_filter' (map_to_ctes ?ps') = null_filter' (ctes_of s')"
    apply (rule null_filter_ctes_retype [OF ko vs' pa'' pd''])
     apply (simp add: nc_al)
    apply clarsimp
    apply (drule subsetD [OF new_cap_addrs_subset [OF cover']])
    apply (insert pspace_no_overlap_disjoint'[OF vs'(1) pn'])
    apply (drule orthD1)
      apply (simp add:ptr_add_def field_simps)
    apply clarsimp
    done

  show "valid_objs s" using vs
    by (clarsimp simp: valid_pspace_def)

  show "valid_mdb s" using vs
    by (clarsimp)

  show "valid_list s" using et
    by (clarsimp)

  show "mdb_cte_at (swp (cte_wp_at ((\<noteq>) cap.NullCap)) s) (cdt s)" using vs
    by (clarsimp simp: valid_mdb_def)

  have pspr: "pspace_relation (kheap s) (ksPSpace s')"
    using sr by (simp add: state_relation_def)

  thus "pspace_relation ?ps ?ps'"
    by (rule retype_pspace_relation [OF _ vs vs' pn pn' ko cover orr num_r,
        folded data_map_insert_def])

  have "ekheap_relation (ekheap (s)) (ksPSpace s')"
  using sr by (simp add: state_relation_def)

  thus "ekheap_relation ?eps ?ps'"
    by (fold fun_upd_apply) (rule retype_ekheap_relation[OF _ pspr vs et(1) vs' pn pn' ko cover orr num_r])

  have pn2: "\<forall>a\<in>set ?al. kheap s a = None"
    by (rule ccontr) (clarsimp simp: pspace_no_overlapD1[OF pn _ cover vs(1)])

  from sr have gr: "ghost_relation (kheap s) (gsUserPages s') (gsCNodes s')"
    by (rule state_relationE)

  show "ghost_relation ?ps (gsUserPages ?t') (gsCNodes ?t')"
  proof (cases ?tp)
    case Untyped thus ?thesis by (simp add: not_unt)
  next
  note data_map_insert_def[simp]

    case TCBObject
    from pn2
    have [simp]: "ups_of_heap ?ps = ups_of_heap (kheap s)"
      by - (rule ext, induct (?al),
            simp_all add: ups_of_heap_def default_object_def TCBObject)
    from pn2
    have [simp]: "cns_of_heap ?ps = cns_of_heap (kheap s)"
      by - (rule ext, induct (?al),
            simp_all add: cns_of_heap_def default_object_def TCBObject)
   note data_map_insert_def[simp del]
    from gr show ?thesis
      by (simp add: ghost_relation_of_heap, simp add: TCBObject update_gs_def)
  next
    case EndpointObject
    from pn2
    have [simp]: "ups_of_heap ?ps = ups_of_heap (kheap s)"
      by - (rule ext, induct (?al),
            simp_all add: ups_of_heap_def default_object_def data_map_insert_def EndpointObject)
    from pn2
    have [simp]: "cns_of_heap ?ps = cns_of_heap (kheap s)"
      by - (rule ext, induct (?al),
            simp_all add: cns_of_heap_def default_object_def data_map_insert_def EndpointObject)
    from gr show ?thesis
      by (simp add: ghost_relation_of_heap,
          simp add: EndpointObject update_gs_def)
  next
   note data_map_insert_def[simp]
    case NotificationObject
    from pn2
    have [simp]: "ups_of_heap ?ps = ups_of_heap (kheap s)"
      by - (rule ext, induct (?al), simp_all add: ups_of_heap_def
                                      default_object_def NotificationObject)
    from pn2
    have [simp]: "cns_of_heap ?ps = cns_of_heap (kheap s)"
      by - (rule ext, induct (?al), simp_all add: cns_of_heap_def
                                      default_object_def NotificationObject)
   note data_map_insert_def[simp del]
    from gr show ?thesis
      by (simp add: ghost_relation_of_heap,
          simp add: NotificationObject update_gs_def)
  next
    case CapTableObject
    note data_map_insert_def[simp]
    from pn2
    have [simp]: "ups_of_heap ?ps = ups_of_heap (kheap s)"
      by - (rule ext, induct (?al), simp_all add: ups_of_heap_def
                                      default_object_def CapTableObject)
    have [simp]: "cns_of_heap ?ps = (\<lambda>x. if x \<in> set ?al then Some us
                                         else cns_of_heap (kheap s) x)"
      by (rule ext, induct (?al),
          simp_all add: cns_of_heap_def wf_empty_bits wf_unique default_object_def CapTableObject)
    note data_map_insert_def[simp del]
    from gr show ?thesis
      by (simp add: ghost_relation_of_heap,
          simp add: CapTableObject update_gs_def ext)
  next
    case (ArchObject ao)
    from pn2
    have [simp]: "cns_of_heap ?ps = cns_of_heap (kheap s)"
      by - (rule ext, induct (?al), simp_all add: cns_of_heap_def data_map_insert_def
                                      default_object_def ArchObject)
    from pn2 gr show ?thesis
      apply (clarsimp simp add: ghost_relation_of_heap)
      apply (rule conjI[rotated])
       apply (simp add: ArchObject update_gs_def split: aobject_type.splits)
      apply (thin_tac "cns_of_heap h = g" for h g)
      apply (drule sym)
      apply (rule ext)
      apply (induct (?al))
       apply (simp add: update_gs_def ArchObject split: aobject_type.splits)
      apply (simp add: update_gs_def ArchObject default_object_def
                       default_arch_object_def ups_of_heap_def
                       data_map_insert_def
                split: aobject_type.splits)
      done
  qed

  show "\<exists>f' g' h'. ?t' =
          s'\<lparr>ksPSpace := f' (ksPSpace s'), gsUserPages := g' (gsUserPages s'),
             gsCNodes := h' (gsCNodes s')\<rparr>"
    apply (clarsimp simp: update_gs_def
                   split: Structures_A.apiobject_type.splits)
    apply (intro conjI impI)
         apply (subst ex_comm, rule_tac x=id in exI,
                subst ex_comm, rule_tac x=id in exI, fastforce)+
     apply (subst ex_comm, rule_tac x=id in exI)
     apply (subst ex_comm)
     apply (rule_tac x="\<lambda>cns x. if x\<in>set ?al then Some us else cns x" in exI,
            simp)
     apply (rule_tac x="\<lambda>x. foldr (\<lambda>addr. data_map_insert addr ko)
                                  (new_cap_addrs m ptr ko) x" in exI, simp)
    apply clarsimp
    apply (rule_tac x="\<lambda>x. foldr (\<lambda>addr. data_map_insert addr ko)
                                 (new_cap_addrs m ptr ko) x" in exI)
    apply (subst ex_comm, rule_tac x=id in exI)
    apply (simp split: aobject_type.splits)
    apply (intro conjI impI)
          apply (rule_tac x="\<lambda>cns x. if x \<in> set ?al then Some ARMSmallPage
                                     else cns x" in exI, simp)
         apply (rule_tac x="\<lambda>cns x. if x \<in> set ?al then Some ARMLargePage
                                    else cns x" in exI, simp)
        apply (rule_tac x="\<lambda>cns x. if x \<in> set ?al then Some ARMSection
                                   else cns x" in exI, simp)
       apply (rule_tac x="\<lambda>cns x. if x \<in> set ?al then Some ARMSuperSection
                                  else cns x" in exI, simp)
      apply (rule_tac x=id in exI, simp)+
    done
qed

lemma new_cap_addrs_fold':
  "1 \<le> n \<Longrightarrow>
   map (\<lambda>n. ptr + (n << objBitsKO ko)) [0.e.n - 1] =
   new_cap_addrs (unat n) ptr ko"
 by (clarsimp simp:new_cap_addrs_def ptr_add_def upto_enum_red'
           shiftl_t2n power_add field_simps)

lemma objBitsKO_gt_0: "0 < objBitsKO ko"
  apply (case_tac ko)
        apply (simp_all add: objBits_simps' pageBits_def)
  apply (rename_tac arch_kernel_object)
  apply (case_tac arch_kernel_object)
    apply (simp_all add:archObjSize_def pageBits_def pteBits_def pdeBits_def)
  done

lemma kheap_ekheap_double_gets: "(\<And>rv erv rv'. pspace_relation rv rv' \<Longrightarrow> ekheap_relation erv rv' \<Longrightarrow> corres r (R rv erv) (R' rv') (b rv erv) (d rv')) \<Longrightarrow>
corres r (\<lambda>s. R (kheap s) (ekheap s) s) (\<lambda>s. R' (ksPSpace s) s) (do x \<leftarrow> gets kheap; xa \<leftarrow> gets ekheap; b x xa od) (gets ksPSpace >>= d)"
  apply (rule corres_symb_exec_l)
     apply (rule corres_guard_imp)
       apply (rule_tac r'= "\<lambda>erv rv'. ekheap_relation erv rv' \<and> pspace_relation x rv'" in corres_split_deprecated)
          apply clarsimp
          apply assumption
         apply (subst corres_gets[where P="\<lambda>s. x = kheap s" and P'=\<top>])
         apply clarsimp
         apply (simp add: state_relation_def)
        apply (wp gets_exs_valid | simp)+
  done

(*

Split out the extended operation that sets the etcb domains.

This allows the existing corres proofs in this file to more-or-less go
through as they stand.

A more principled fix would be to change the abstract spec and
generalise init_arch_objects to initialise other object types.

*)

definition retype_region2_ext :: "obj_ref list \<Rightarrow> Structures_A.apiobject_type \<Rightarrow> unit det_ext_monad" where
  "retype_region2_ext ptrs type \<equiv> modify (\<lambda>s. ekheap_update (foldr (\<lambda>p ekh. (ekh(p := default_ext type default_domain))) ptrs) s)"

crunch all_but_exst[wp]: retype_region2_ext "all_but_exst P"
crunch (empty_fail) empty_fail[wp]: retype_region2_ext

end

interpretation retype_region2_ext_extended: is_extended "retype_region2_ext ptrs type"
  by (unfold_locales; wp)

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

definition
 "retype_region2_extra_ext ptrs type \<equiv>
     when (type = Structures_A.TCBObject) (do
       cdom \<leftarrow> gets cur_domain;
       mapM_x (ethread_set (\<lambda>tcb. tcb\<lparr>tcb_domain := cdom\<rparr>)) ptrs
      od)"

crunch all_but_exst[wp]: retype_region2_extra_ext "all_but_exst P" (wp: mapM_x_wp)
crunch (empty_fail) empty_fail[wp]: retype_region2_extra_ext (wp: mapM_x_wp)

end

interpretation retype_region2_extra_ext_extended: is_extended "retype_region2_extra_ext ptrs type"
  by (unfold_locales; wp)

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

definition
  retype_region2 :: "obj_ref \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> Structures_A.apiobject_type \<Rightarrow> bool \<Rightarrow> (obj_ref list,'z::state_ext) s_monad"
where
  "retype_region2 ptr numObjects o_bits type dev \<equiv> do
    obj_size \<leftarrow> return $ 2 ^ obj_bits_api type o_bits;
    ptrs \<leftarrow> return $ map (\<lambda>p. ptr_add ptr (p * obj_size)) [0..< numObjects];
    when (type \<noteq> Structures_A.Untyped) (do
      kh \<leftarrow> gets kheap;
      kh' \<leftarrow> return $ foldr (\<lambda>p kh. kh(p \<mapsto> default_object type dev o_bits)) ptrs kh;
      do_extended_op (retype_region2_ext ptrs type);
      modify $ kheap_update (K kh')
    od);
    return $ ptrs
  od"

lemma retype_region_ext_modify_kheap_futz:
  "(retype_region2_extra_ext ptrs type :: (unit, det_ext) s_monad) >>= (\<lambda>_. modify (kheap_update f))
 = (modify (kheap_update f) >>= (\<lambda>_. retype_region2_extra_ext ptrs type))"
  apply (clarsimp simp: retype_region_ext_def retype_region2_ext_def retype_region2_extra_ext_def when_def bind_assoc)
  apply (subst oblivious_modify_swap)
   defer
   apply (simp add: bind_assoc)
  apply (rule oblivious_bind)
  apply simp
  apply (rule oblivious_mapM_x)
  apply (clarsimp simp: ethread_set_def set_eobject_def)
  apply (rule oblivious_bind)
   apply (simp add: gets_the_def)
   apply (rule oblivious_bind)
    apply (clarsimp simp: get_etcb_def)
    apply simp
   apply (simp add: modify_def[symmetric])
done

lemmas retype_region_ext_modify_kheap_futz' =
  fun_cong[OF arg_cong[where f=NonDetMonad.bind,
           OF retype_region_ext_modify_kheap_futz[symmetric]], simplified bind_assoc]

lemma foldr_upd_app_if_eta_futz:
  "foldr (\<lambda>p ps. ps(p \<mapsto> f p)) as = (\<lambda>g x. if x \<in> set as then Some (f x) else g x)"
apply (rule ext)
apply (rule foldr_upd_app_if)
done

lemma modify_ekheap_update_comp_futz:
  "modify (ekheap_update (f \<circ> g)) = modify (ekheap_update g) >>= (K (modify (ekheap_update f)))"
by (simp add: o_def modify_def bind_def gets_def get_def put_def)

lemma mapM_x_modify_futz:
  assumes "\<forall>ptr\<in>set ptrs. ekheap s ptr \<noteq> None"
  shows "mapM_x (ethread_set F) (rev ptrs) s
       = modify (ekheap_update (foldr (\<lambda>p ekh. ekh(p := Some (F (the (ekh p))))) ptrs)) s" (is "?lhs ptrs s = ?rhs ptrs s")
using assms
proof(induct ptrs arbitrary: s)
  case Nil thus ?case by (simp add: mapM_x_Nil return_def simpler_modify_def)
next
  case (Cons ptr ptrs s)
  have "?rhs (ptr # ptrs) s
      = (do modify (ekheap_update (foldr (\<lambda>p ekh. ekh(p \<mapsto> F (the (ekh p)))) ptrs));
            modify (ekheap_update (\<lambda>ekh. ekh(ptr \<mapsto> F (the (ekh ptr)))))
        od) s"
    by (simp only: foldr_Cons modify_ekheap_update_comp_futz) simp
  also have "... = (do ?lhs ptrs;
                      modify (ekheap_update (\<lambda>ekh. ekh(ptr \<mapsto> F (the (ekh ptr)))))
                    od) s"
    apply (rule monad_eq_split_tail)
     apply simp
    apply (rule Cons.hyps[symmetric])
    using Cons.prems
    apply force
    done
  also have "... = ?lhs (ptr # ptrs) s"
    apply (simp add: mapM_x_append mapM_x_singleton)
    apply (rule monad_eq_split2[OF refl, where
                 P="\<lambda>s. \<forall>ptr\<in>set (ptr # ptrs). ekheap s ptr \<noteq> None"
             and Q="\<lambda>_ s. ekheap s ptr \<noteq> None"])
      apply (simp add: ethread_set_def
                       assert_opt_def get_etcb_def gets_the_def gets_def get_def modify_def put_def set_eobject_def
                       bind_def fail_def return_def split_def
                split: option.splits)
     apply ((wp mapM_x_wp[OF _ subset_refl] | simp add: ethread_set_def set_eobject_def)+)[1]
    using Cons.prems
    apply force
    done
  finally show ?case by (rule sym)
qed

lemma awkward_fold_futz:
  "fold (\<lambda>p ekh. ekh(p \<mapsto> the (ekh p)\<lparr>tcb_domain := cur_domain s\<rparr>)) ptrs ekh
 = (\<lambda>x. if x \<in> set ptrs then Some ((the (ekh x))\<lparr>tcb_domain := cur_domain s\<rparr>) else ekh x)"
by (induct ptrs arbitrary: ekh) (simp_all add: fun_eq_iff)

lemma retype_region2_ext_retype_region_ext_futz:
  "retype_region2_ext ptrs type >>= (\<lambda>_. retype_region2_extra_ext ptrs type)
 = retype_region_ext ptrs type"
proof(cases type)
  case TCBObject
  have complete_futz:
    "\<And>F x. modify (ekheap_update (\<lambda>_. F (cur_domain x) (ekheap x))) x = modify (ekheap_update (\<lambda>ekh. F (cur_domain x) ekh)) x"
    by (simp add: modify_def get_def get_etcb_def put_def bind_def return_def)
  have second_futz:
  "\<And>f G.
   do modify (ekheap_update f);
      cdom \<leftarrow> gets (\<lambda>s. cur_domain s);
      G cdom
   od =
   do cdom \<leftarrow> gets (\<lambda>s. cur_domain s);
      modify (ekheap_update f);
      G cdom
   od"
    by (simp add: bind_def gets_def get_def return_def simpler_modify_def)
  from TCBObject show ?thesis
    apply (clarsimp simp: retype_region_ext_def retype_region2_ext_def retype_region2_extra_ext_def when_def bind_assoc)
    apply (clarsimp simp: exec_gets fun_eq_iff)
    apply (subst complete_futz)
    apply (simp add: second_futz[simplified] exec_gets)
    apply (simp add: default_ext_def exec_modify)
    apply (subst mapM_x_modify_futz[where ptrs="rev ptrs", simplified])
     apply (simp add: foldr_upd_app_if_eta_futz)
    apply (simp add: modify_def exec_get put_def o_def)
    apply (simp add: foldr_upd_app_if_eta_futz foldr_conv_fold awkward_fold_futz)
    apply (simp cong: if_cong)
    done
qed (auto simp: fun_eq_iff retype_region_ext_def retype_region2_ext_def retype_region2_extra_ext_def
                put_def gets_def get_def bind_def return_def mk_ef_def modify_def foldr_upd_app_if' when_def default_ext_def)

lemma retype_region2_ext_retype_region:
  "(retype_region ptr numObjects o_bits type dev :: (obj_ref list, det_ext) s_monad)
 = (do ptrs \<leftarrow> retype_region2 ptr numObjects o_bits type dev;
       retype_region2_extra_ext ptrs type;
       return ptrs
    od)"
apply (clarsimp simp: retype_region_def retype_region2_def when_def bind_assoc)
 apply safe
 defer
 apply (simp add: retype_region2_extra_ext_def)
apply (subst retype_region_ext_modify_kheap_futz'[simplified bind_assoc])
apply (subst retype_region2_ext_retype_region_ext_futz[symmetric])
apply (simp add: bind_assoc)
done

lemma getObject_tcb_gets:
  "getObject addr >>= (\<lambda>x::tcb. gets proj >>= (\<lambda>y. G x y))
 = gets proj >>= (\<lambda>y. getObject addr >>= (\<lambda>x. G x y))"
by (auto simp: exec_gets fun_eq_iff intro: bind_apply_cong dest!: in_inv_by_hoareD[OF getObject_inv_tcb])

lemma setObject_tcb_gets_ksCurDomain:
  "setObject addr (tcb::tcb) >>= (\<lambda>_. gets ksCurDomain >>= G)
 = gets ksCurDomain >>= (\<lambda>x. setObject addr tcb >>= (\<lambda>_. G x))"
apply (clarsimp simp: exec_gets fun_eq_iff)
apply (rule bind_apply_cong)
 apply simp
apply (drule_tac P1="\<lambda>cdom. cdom = ksCurDomain x" in use_valid[OF _ setObject_cd_inv])
apply (simp_all add: exec_gets)
done

lemma curDomain_mapM_x_futz:
  "curDomain >>= (\<lambda>cdom. mapM_x (threadSet (F cdom)) addrs)
 = mapM_x (\<lambda>addr. curDomain >>= (\<lambda>cdom. threadSet (F cdom) addr)) addrs"
proof(induct addrs)
  case Nil thus ?case
    by (simp add: curDomain_def mapM_x_def sequence_x_def bind_def gets_def get_def return_def)
next
  case (Cons addr addrs)
  have H: "\<And>G. do cdom \<leftarrow> curDomain;
                   _ \<leftarrow> threadSet (F cdom) addr;
                   G cdom
                od
              = do cdom \<leftarrow> curDomain;
                   threadSet (F cdom) addr;
                   cdom \<leftarrow> curDomain;
                   G cdom
                od"
    by (simp add: bind_assoc curDomain_def threadSet_def setObject_tcb_gets_ksCurDomain
                  getObject_tcb_gets double_gets_drop_regets)
  from Cons.hyps show ?case
    apply (simp add: mapM_x_def sequence_x_def)
    apply (simp add: bind_assoc foldr_map o_def)
    apply (subst H)
    apply (simp add: mapM_x_def sequence_x_def)
    done
qed

(*

The existing proof continues below.

*)

lemma modify_ekheap_update_ekheap:
  "modify (\<lambda>s. ekheap_update f s) = do s \<leftarrow> gets ekheap; modify (\<lambda>s'. s'\<lparr>ekheap := f s\<rparr>) od"
by (simp add: modify_def gets_def get_def put_def bind_def return_def split_def fun_eq_iff)

lemma corres_retype':
  assumes    not_zero: "n \<noteq> 0"
  and         aligned: "is_aligned ptr (objBitsKO ko + gbits)"
  and    obj_bits_api: "obj_bits_api (APIType_map2 ty) us =
                        objBitsKO ko + gbits"
  and           check: "(sz < obj_bits_api (APIType_map2 ty)  us)
                           = (sz < objBitsKO ko + gbits)"
  and             usv: "APIType_map2 ty = Structures_A.CapTableObject \<Longrightarrow> 0 < us"
  and              ko: "makeObjectKO dev ty = Some ko"
  and             orr: "obj_bits_api (APIType_map2 ty) us \<le> sz \<Longrightarrow>
                        obj_relation_retype
                          (default_object (APIType_map2 ty) dev us) ko"
  and           cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n"
  shows "corres (\<lambda>rv rv'. rv' = g rv)
  (\<lambda>s. valid_pspace s \<and> pspace_no_overlap_range_cover ptr sz s
     \<and> valid_mdb s \<and> valid_etcbs s \<and> valid_list s)
  (\<lambda>s. pspace_aligned' s \<and> pspace_distinct' s \<and> pspace_no_overlap' ptr sz s)
  (retype_region2 ptr n us (APIType_map2 ty) dev)
  (do addrs \<leftarrow> createObjects ptr n ko gbits;
      _ \<leftarrow> modify (update_gs (APIType_map2 ty) us (set addrs));
      return (g addrs) od)"
  (is "corres ?r ?P ?P' ?C ?A")
proof -
  note data_map_insert_def[simp del]
  have not_zero':"((of_nat n)::word32) \<noteq> 0"
    by (rule range_cover_not_zero[OF not_zero cover])
  have shiftr_not_zero:" ((of_nat n)::word32) << gbits \<noteq> 0"
    apply (rule range_cover_not_zero_shift[OF not_zero cover])
    apply (simp add:obj_bits_api)
    done
  have unat_of_nat_shift:"unat (((of_nat n)::word32) << gbits) =
                          (n * 2^ gbits)"
    apply (rule range_cover.unat_of_nat_n_shift[OF cover])
    using obj_bits_api
    apply simp
    done
  have unat_of_nat_shift':
    "unat (((of_nat n)::word32) * 2^(gbits + objBitsKO ko)) =
     n * 2^(gbits + objBitsKO ko)"
    apply (subst mult.commute)
    apply (simp add:shiftl_t2n[symmetric])
    apply (rule range_cover.unat_of_nat_n_shift[OF cover])
    using obj_bits_api
    apply simp
    done
  have unat_of_nat_n':
    "unat (((of_nat n)::word32) * 2 ^ (gbits + objBitsKO ko)) \<noteq> 0"
    by (simp add:unat_of_nat_shift' not_zero)
  have bound:"obj_bits_api (APIType_map2 ty) us \<le> sz"
    using cover
    by (simp add:range_cover_def)
  have n_estimate: "n < 2 ^ (word_bits - (objBitsKO ko + gbits))"
    apply (rule le_less_trans)
    apply (rule range_cover.range_cover_n_le(2)[OF cover])
    apply (rule power_strict_increasing)
    apply (simp add:obj_bits_api ko)
    apply (rule diff_less_mono)
    using cover obj_bits_api
    apply (simp_all add:range_cover_def ko word_bits_def)
    done

  have set_retype_addrs_fold:
    "image (\<lambda>n. ptr + 2 ^ obj_bits_api (APIType_map2 ty) us * n)
           {x. x \<le> of_nat n - 1} =
     set (retype_addrs ptr (APIType_map2 ty) n us)"
    apply (clarsimp simp: retype_addrs_def image_def Bex_def ptr_add_def
                          Collect_eq)
    apply (rule iffI)
     apply (clarsimp simp: field_simps word_le_nat_alt)
     apply (rule_tac x="unat x" in exI)
     apply (simp add: unat_sub_if_size range_cover.unat_of_nat_n[OF cover]
                      not_le not_zero
               split: if_split_asm)
    apply (clarsimp simp: field_simps word_le_nat_alt)
    apply (rule_tac x="of_nat x" in exI)
    apply (simp add: unat_sub_if_size range_cover.unat_of_nat_n[OF cover])
    apply (rule nat_le_Suc_less_imp)
    apply (metis le_unat_uoi nat_less_le not_le_imp_less)
    done

  have new_caps_adds_fold:
    "map (\<lambda>n. ptr + 2 ^ objBitsKO ko * n) [0.e.2 ^ gbits * of_nat n - 1] =
     new_cap_addrs (2 ^ gbits * n) ptr ko"
    apply (simp add: new_cap_addrs_def shiftl_t2n)
    apply (subgoal_tac "1 \<le> (2::word32) ^ gbits * of_nat n")
     apply (simp add: upto_enum_red' o_def)
     apply (rule arg_cong2[where f=map, OF refl])
     apply (rule arg_cong2[where f=upt, OF refl])
     apply (metis mult.commute shiftl_t2n unat_of_nat_shift)
    using shiftr_not_zero
    apply (simp add: shiftl_t2n)
    apply (metis word_less_1 word_not_le)
    done

  from aligned
  have al': "is_aligned ptr (obj_bits_api (APIType_map2 ty) us)"
     by (simp add: obj_bits_api ko)
  show ?thesis
  apply (simp add: when_def retype_region2_def createObjects'_def
                   createObjects_def aligned obj_bits_api[symmetric]
                   ko[symmetric] al' shiftl_t2n data_map_insert_def[symmetric]
                   is_aligned_mask[symmetric] split_def unless_def
                   lookupAround2_pspace_no check
        split del: if_split)
  apply (subst retype_addrs_fold)+
  apply (subst if_P)
   using ko
   apply (clarsimp simp: makeObjectKO_def)
  apply (simp add: bind_assoc retype_region2_ext_def)
  apply (rule corres_guard_imp)
    apply (subst modify_ekheap_update_ekheap)
    apply (simp only: bind_assoc)
    apply (rule kheap_ekheap_double_gets)
    apply (rule corres_symb_exec_r)
       apply (simp add: not_less modify_modify bind_assoc[symmetric]
                          obj_bits_api[symmetric] shiftl_t2n upto_enum_red'
                           range_cover.unat_of_nat_n[OF cover])
       apply (rule corres_split_nor[OF corres_trivial])
          apply (clarsimp simp: retype_addrs_fold[symmetric] ptr_add_def upto_enum_red' not_zero'
                                range_cover.unat_of_nat_n[OF cover] word_le_sub1
                          simp del: word_of_nat_eq_0_iff)
          apply (rule_tac f=g in arg_cong)
          apply clarsimp
         apply (rename_tac x eps ps)
         apply (rule_tac P="\<lambda>s. x = kheap s \<and> eps = ekheap (s) \<and> ?P s" and
                         P'="\<lambda>s. ps = ksPSpace s \<and> ?P' s" in corres_modify)
         apply (simp add: set_retype_addrs_fold new_caps_adds_fold)
         apply (erule retype_state_relation[OF _ _ _ _ _ _ _ _ _ cover _ _ orr],
                simp_all add: ko not_zero obj_bits_api
                              bound[simplified obj_bits_api ko])[1]
        apply wp+
      apply (clarsimp split: option.splits)
      apply (intro conjI impI)
       apply (clarsimp|wp)+
     apply (clarsimp split: option.splits)
     apply wpsimp
    apply (clarsimp split: option.splits)
    apply (intro conjI impI)
     apply wp
    apply (clarsimp simp:lookupAround2_char1)
    apply wp
    apply (clarsimp simp: obj_bits_api ko)
    apply (drule(1) pspace_no_overlap_disjoint')
    apply (rule_tac x1 = a in ccontr[OF in_empty_interE])
      apply simp
     apply (clarsimp simp: not_less shiftL_nat)
     apply (erule order_trans)
     apply (subst p_assoc_help)
     apply (subst word_plus_and_or_coroll2[symmetric,where w = "mask sz"])
     apply (subst add.commute)
     apply (subst add.assoc)
     apply (rule word_plus_mono_right)
      using cover
      apply -
      apply (rule iffD2[OF word_le_nat_alt])
      apply (subst word_of_nat_minus)
       using not_zero
       apply simp
      apply (rule le_trans[OF unat_plus_gt])
      apply simp
      apply (subst unat_minus_one)
       apply (subst mult.commute)
       apply (rule word_power_nonzero_32)
         apply (rule of_nat_less_pow_32[OF n_estimate])
         apply (simp add:word_bits_def objBitsKO_gt_0 ko)
        apply (simp add:range_cover_def obj_bits_api ko word_bits_def)
       apply (cut_tac not_zero',clarsimp simp:ko)
      apply(clarsimp simp:field_simps ko)
      apply (subst unat_sub[OF word_1_le_power])
       apply (simp add:range_cover_def)
      apply (subst diff_add_assoc[symmetric])
       apply (cut_tac unat_of_nat_n',simp add:ko)
      apply (clarsimp simp: obj_bits_api ko)
      apply (rule diff_le_mono)
      apply (frule range_cover.range_cover_compare_bound)
      apply (cut_tac obj_bits_api unat_of_nat_shift')
      apply (clarsimp simp:add.commute range_cover_def ko)
     apply (rule is_aligned_no_wrap'[OF is_aligned_neg_mask,OF le_refl ])
     apply (simp add:range_cover_def domI)+
  done
qed

lemma createObjects_corres':
  "\<lbrakk>corres r P P' f (createObjects a b ko d); ko = injectKO val\<rbrakk>
   \<Longrightarrow> corres dc P P' f (createObjects' a b ko d)"
  apply (clarsimp simp:corres_underlying_def createObjects_def return_def)
  apply (rule conjI)
  apply (clarsimp simp:bind_def split_def)
    apply (drule(1) bspec)
    apply (clarsimp simp:image_def)
    apply (drule(1) bspec)
    apply clarsimp
    apply (erule bexI[rotated])
    apply simp
  apply (clarsimp simp:bind_def split_def image_def)
  apply (drule(1) bspec|clarsimp)+
  done

lemmas retype_aligned_distinct'' = retype_aligned_distinct'
       [unfolded foldr_upd_app_if[folded data_map_insert_def]]

lemma retype_ko_wp_at':
  assumes vs: "pspace_aligned' s" "pspace_distinct' s"
     and  pn: "pspace_no_overlap' ptr sz s"
   and cover: "range_cover ptr sz (objBitsKO obj) n"
  shows
  "ko_wp_at' P p (s \<lparr>ksPSpace := foldr (\<lambda>addr. data_map_insert addr obj)
                      (new_cap_addrs n ptr obj) (ksPSpace s)\<rparr>)
     = (if p \<in> set (new_cap_addrs n ptr obj) then P obj
                         else ko_wp_at' P p s)"
  apply (subst foldr_upd_app_if[folded data_map_insert_def])
  apply (rule foldr_update_ko_wp_at' [OF vs])
    apply (simp add: retype_aligned_distinct'' [OF vs pn cover])+
  apply (rule new_cap_addrs_aligned)
  using cover
  apply (simp add:range_cover_def cover)
  done

lemma retype_obj_at':
  assumes vs: "pspace_aligned' s" "pspace_distinct' s"
     and  pn: "pspace_no_overlap' ptr sz s"
     and cover: "range_cover ptr sz (objBitsKO obj) n"
  shows
  "obj_at' P p (s \<lparr>ksPSpace := foldr (\<lambda>addr. data_map_insert addr obj)
                      (new_cap_addrs n ptr obj) (ksPSpace s)\<rparr>)
     = (if p \<in> set (new_cap_addrs n ptr obj) then (\<exists>ko. projectKO_opt obj = Some ko \<and> P ko)
                         else obj_at' P p s)"
  unfolding obj_at'_real_def
  apply (rule retype_ko_wp_at'[OF vs pn cover])
done

lemma retype_obj_at_disj':
  assumes vs: "pspace_aligned' s" "pspace_distinct' s"
     and  pn: "pspace_no_overlap' ptr sz s"
     and cover: "range_cover ptr sz (objBitsKO obj) n"
  shows
  "obj_at' P p (s \<lparr>ksPSpace := foldr (\<lambda>addr. data_map_insert addr obj)
                      (new_cap_addrs n ptr obj) (ksPSpace s)\<rparr>)
     = (obj_at' P p s \<or> p \<in> set (new_cap_addrs n ptr obj)
                         \<and> (\<exists>ko. projectKO_opt obj = Some ko \<and> P ko))"
  apply (simp add: retype_obj_at' [OF vs pn cover])
  apply (safe, simp_all)
  apply (drule subsetD [OF new_cap_addrs_subset [OF cover]])
  apply (insert pspace_no_overlap_disjoint' [OF vs(1) pn ])
  apply (clarsimp simp: obj_at'_def)
  apply (rule_tac x1 = p in ccontr[OF in_empty_interE])
    apply (simp add:ptr_add_def p_assoc_help domI)+
  done

declare word_unat_power[symmetric,simp]

lemma createObjects_ko_at_strg:
  fixes ptr :: word32
  assumes    cover: "range_cover ptr sz ((objBitsKO ko) + gbits) n"
  assumes    not_0: "n\<noteq> 0"
  assumes       pi: "projectKO_opt ko  = Some val"
  shows "\<lbrace>\<lambda>s. pspace_no_overlap' ptr sz s \<and> pspace_aligned' s \<and> pspace_distinct' s\<rbrace>
             createObjects ptr n ko gbits
         \<lbrace>\<lambda>r s. \<forall>x \<in> set r. \<forall>offs < 2 ^ gbits. ko_at' val (x + (offs << objBitsKO ko)) s\<rbrace>"
proof -
  have shiftr_not_zero:" 1 \<le> ((of_nat n)::word32) << gbits"
    using range_cover_not_zero_shift[OF not_0 cover,where gbits = gbits]
    apply -
    apply (simp add:word_le_sub1)
    done
  note unat_of_nat_shiftl = range_cover.unat_of_nat_n_shift[OF cover,where gbits = gbits,simplified]
  note word_of_nat_eq_0_iff[simp del]
  have in_new:"\<And>idx offs. \<lbrakk>idx \<le> of_nat n - 1;offs<2 ^ gbits\<rbrakk>
    \<Longrightarrow> ptr + (idx << objBitsKO ko + gbits) + (offs << objBitsKO ko)
        \<in> set (new_cap_addrs (n * 2 ^ gbits) ptr ko)"
      apply (insert range_cover_not_zero[OF not_0 cover] not_0)
      apply (clarsimp simp:new_cap_addrs_def image_def)
      apply (rule_tac x ="unat (2 ^ gbits * idx + offs)" in bexI)
        apply (subst add.commute)
        apply (simp add:shiftl_shiftl[symmetric])
        apply (simp add:shiftl_t2n distrib_left[symmetric])
      apply simp
      apply (rule unat_less_helper)
      apply (rule less_le_trans)
       apply (erule word_plus_strict_mono_right)
       apply (subst distrib_left[where c = "1 :: 32 word",symmetric,simplified])
       apply (subst mult.commute[where a = "2^gbits"])+
       apply (insert cover)
       apply (rule word_mult_le_iff[THEN iffD2])
         apply (simp add:p2_gt_0)
         apply (clarsimp simp:range_cover_def word_bits_def)
         apply (drule range_cover_rel[where sbit' = "objBitsKO ko "])
           apply simp
          apply simp
         apply (rule less_le_trans)
          apply (rule range_cover.range_cover_le_n_less)
           apply simp
          apply (subst unat_power_lower)
           using cover
           apply (clarsimp simp:range_cover_def)
          apply (simp add:field_simps)
          apply (rule unat_le_helper)
          apply (erule order_trans[OF _ word_sub_1_le])
          apply (simp add:range_cover_not_zero[OF not_0 cover])
         apply (simp add:word_bits_def)
        apply (drule range_cover_rel[where sbit' = "objBitsKO ko "])
          apply simp
         apply simp
        apply (erule less_le_trans[OF range_cover.range_cover_le_n_less(1)])
        apply (subst unat_power_lower)
         using cover
         apply (clarsimp simp:range_cover_def)
        apply (simp add:field_simps)
        apply (rule unat_le_helper[OF inc_le])
        apply (simp add:word_leq_minus_one_le)
       apply (simp add:word_bits_def)
      apply (rule no_plus_overflow_neg)
      apply (rule less_le_trans[where y = "of_nat n"])
       apply unat_arith
      using range_cover.range_cover_n_less[OF cover]
     apply (simp add:word_bits_def)
    apply (subst distrib_left[where c = "1 :: 32 word",symmetric,simplified])
   apply (subst mult.commute)
   apply simp
   apply (rule word_mult_le_iff[THEN iffD2])
       apply (simp add:p2_gt_0)
      apply (simp add:range_cover_def word_bits_def)
     apply (drule range_cover_rel[where sbit' = "objBitsKO ko "])
       apply simp
      apply simp
     apply (rule less_le_trans)
     apply (rule range_cover.range_cover_le_n_less)
       apply simp
     apply (subst unat_power_lower)
       using cover
       apply (clarsimp simp:range_cover_def)
      apply (simp add:field_simps)
     apply (rule unat_le_helper)
    apply unat_arith
   apply (simp add:word_bits_def)
   apply (drule range_cover_rel[where sbit' = "objBitsKO ko "])
       apply simp
      apply simp
     apply (rule less_le_trans)
      apply (erule range_cover.range_cover_le_n_less)
     apply (simp add:range_cover.unat_of_nat_n[OF cover])
    apply (simp add: unat_le_helper)
   apply (simp add:word_bits_def)
  apply unat_arith
  done
  show ?thesis
  apply (simp add: split_def createObjects_def lookupAround2_pspace_no
                   alignError_def unless_def createObjects'_def)
  apply (rule hoare_pre)
   apply (wp|simp add:data_map_insert_def[symmetric]
     cong: if_cong del: fun_upd_apply data_map_insert_def)+
   apply (wpc|wp|clarsimp simp del:fun_upd_apply)+
   apply (subst new_cap_addrs_fold'[OF shiftr_not_zero])+
   apply (subst data_map_insert_def[symmetric])+
   apply (subst retype_obj_at_disj')
     apply (simp add:valid_pspace'_def unat_of_nat_shiftl)+
     apply (rule range_cover_rel[OF cover])
     apply simp+
   apply (subst retype_obj_at_disj')
     apply (simp add:valid_pspace'_def unat_of_nat_shiftl)+
     apply (rule range_cover_rel[OF cover])
     apply simp+
  using range_cover.unat_of_nat_n_shift[OF cover,where gbits = gbits,simplified] pi
  apply (simp add: in_new)
  done
qed

lemma createObjects_ko_at:
  fixes ptr :: word32
  assumes    cover: "range_cover ptr sz ((objBitsKO ko) + gbits) n"
  assumes    not_0: "n\<noteq> 0"
  assumes       pi: "projectKO_opt ko = Some val"
  shows "\<lbrace>\<lambda>s. pspace_no_overlap' ptr sz s \<and> valid_pspace' s\<rbrace>
             createObjects ptr n ko gbits
         \<lbrace>\<lambda>r s. \<forall>x \<in> set r. \<forall>offs < 2 ^ gbits. ko_at' val (x + (offs << objBitsKO ko)) s\<rbrace>"
  by (wp createObjects_ko_at_strg[OF cover not_0 pi],fastforce)

lemma createObjects_obj_at:
  fixes ptr :: word32 and val :: "'a :: pspace_storable"
  assumes  cover:"range_cover ptr sz ((objBitsKO ko) + gbits) n"
  and      not_0:"n \<noteq> 0"
  and       pi: "\<exists>(val::'a). projectKO_opt ko = Some val"
  shows "\<lbrace>\<lambda>s. pspace_no_overlap' ptr sz s \<and> valid_pspace' s\<rbrace>
  createObjects ptr n ko gbits \<lbrace>\<lambda>r s. \<forall>x \<in> set r. \<forall>offs < 2 ^ gbits.
                                     obj_at' (\<lambda>(x::'a). True) (x + (offs << objBitsKO ko)) s\<rbrace>"
  apply (rule exE[OF pi])
  apply (erule_tac val1 = x in
    hoare_post_imp [OF _ createObjects_ko_at [OF cover not_0 ],rotated])
  apply (intro allI ballI impI)
  apply (drule(1) bspec)
  apply (drule spec, drule(1) mp)
  apply (clarsimp elim!: obj_at'_weakenE)
  done

(* until we figure out what we really need of page
   mappings it's just alignment, which, fortunately,
   is trivial *)
lemma createObjects_aligned:
  assumes al: "is_aligned ptr (objBitsKO ko + gbits)"
  and bound :"n < 2 ^ word_bits" "n\<noteq>0"
  and bound':"objBitsKO ko + gbits < word_bits"
  shows "\<lbrace>\<top>\<rbrace> createObjects ptr n ko gbits
         \<lbrace>\<lambda>rv s. \<forall>x \<in> set rv. is_aligned x (objBitsKO ko + gbits)\<rbrace>"
  apply (rule hoare_strengthen_post)
   apply (rule createObjects_ret[OF bound])
  apply (clarsimp dest!: less_two_pow_divD)
  apply (rule is_aligned_ptr_add_helper[OF al])
  apply (simp_all add:bound')
  done

lemma createObjects_aligned2:
  "\<lbrace>\<lambda>s. is_aligned ptr (objBitsKO ko + gbits) \<and> n < 2 ^ word_bits \<and> n \<noteq> 0
      \<and> aln < word_bits
      \<and> aln = objBitsKO ko + gbits\<rbrace>
    createObjects ptr n ko gbits
   \<lbrace>\<lambda>rv s. \<forall>x \<in> set rv. is_aligned x aln\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply simp
  apply (rule hoare_pre, wp createObjects_aligned, simp_all)
  done

lemma range_cover_n_wb:
  "range_cover (ptr :: obj_ref) sz us n \<Longrightarrow> n < 2 ^ word_bits"
  apply (rule order_le_less_trans, erule range_cover.range_cover_n_le(2))
  apply (clarsimp simp: range_cover_def)
  apply (simp add: word_bits_def)
  done

lemma createObjects_nonzero:
  assumes not_0: "n \<noteq> 0"
  assumes  cover:"range_cover ptr sz ((objBitsKO ko) + bits) n"
  shows "\<lbrace>\<lambda>s. ptr \<noteq> 0\<rbrace>
            createObjects ptr n ko bits
         \<lbrace>\<lambda>rv s. \<forall>p \<in> set rv. p \<noteq> 0\<rbrace>"
  apply (insert not_0)
  apply (rule hoare_pre)
   apply (rule hoare_gen_asm [where P = "ptr \<noteq> 0"])
   using cover
   apply (clarsimp simp:range_cover_def)
   apply (erule is_aligned_get_word_bits,simp_all)
  apply (rule hoare_post_imp [OF _ createObjects_ret])
    apply (simp add: ptr_add_def)
    apply (intro allI impI ballI)
    apply (simp add:power_add[symmetric] mult.assoc)
    apply (drule(1) range_cover_no_0[OF _ cover])
    apply (simp add: objBits_def)
   apply (simp add: range_cover_n_wb[OF cover])
  apply simp
  done

lemma objBits_if_dev:
    "objBitsKO (if dev then KOUserDataDevice else KOUserData) = pageBits"
  by (simp add: objBitsKO_def)

lemma cwo_ret:
  assumes  cover:"range_cover ptr sz v n"
  assumes not_0:"n\<noteq> 0"
  shows result: "\<lbrace>pspace_no_overlap' ptr sz and valid_pspace' and K (v = 12 + bs)\<rbrace>
           createObjects ptr n (if dev then KOUserDataDevice else KOUserData) bs
          \<lbrace>\<lambda>rv s. \<forall>x\<in>set rv. \<forall>p<2 ^ (v - pageBits).
                 typ_at' (if dev then UserDataDeviceT else UserDataT) (x + p * 2 ^ pageBits) s\<rbrace>"
proof -
  note create_objs_device = hoare_post_imp [OF _ hoare_conj [OF createObjects_ret
     createObjects_ko_at[where val = UserDataDevice,simplified]]]

  note create_objs_normal = hoare_post_imp [OF _ hoare_conj [OF createObjects_ret
     createObjects_ko_at[where val = UserData,simplified]]]

show ?thesis
  apply (cases dev)
   apply (rule hoare_gen_asm)
   apply (rule hoare_pre)
   apply (rule create_objs_device)
         apply (clarsimp simp add: pageBits_def)
         apply (drule bspec, simp, drule spec, drule(1) mp)
         apply (simp add: typ_at'_def obj_at'_real_def objBits_simps pageBits_def shiftl_t2n field_simps)
         apply (erule ko_wp_at'_weakenE)
         apply (clarsimp simp add: projectKO_opts_defs split: kernel_object.splits)
        apply (rule le_less_trans[OF _ power_strict_increasing])
          apply (rule range_cover.range_cover_n_le(1)[OF cover])
         apply (simp add: word_bits_def pageBits_def not_0)+
     apply (rule range_cover_rel[OF cover])
      apply (simp add: objBitsKO_def pageBits_def not_0)+
     using not_0 apply simp_all
    apply (clarsimp simp add: projectKO_def return_def
      projectKO_opts_defs split: kernel_object.splits)
  apply (rule hoare_gen_asm[unfolded K_def])
  apply (rule hoare_pre)
  apply (rule create_objs_normal)
         apply (clarsimp simp add: pageBits_def)
         apply (drule bspec, simp, drule spec, drule(1) mp)
         apply (simp add: typ_at'_def obj_at'_real_def objBits_simps pageBits_def shiftl_t2n field_simps)
         apply (erule ko_wp_at'_weakenE)
         apply (clarsimp simp add: projectKO_opts_defs split: kernel_object.splits)
        apply (rule le_less_trans[OF _ power_strict_increasing])
          apply (rule range_cover.range_cover_n_le(1)[OF cover])
         apply (simp add: word_bits_def pageBits_def not_0)+
     apply (rule range_cover_rel[OF cover])
      apply (simp add: objBitsKO_def pageBits_def not_0)+
     using not_0 apply simp_all
    apply (clarsimp simp add: projectKO_def return_def
      projectKO_opts_defs split: kernel_object.splits)
  done
qed
lemmas capFreeIndex_update_valid_untyped' =
  capFreeIndex_update_valid_cap'[unfolded valid_cap'_def,simplified,THEN conjunct2,THEN conjunct1]

lemma createNewCaps_valid_cap:
  fixes ptr :: word32
  assumes cover: "range_cover ptr sz (APIType_capBits ty us) n "
  assumes not_0: "n \<noteq> 0"
  assumes ct: "ty = APIObjectType ArchTypes_H.CapTableObject \<Longrightarrow> 0 < us"
              "ty = APIObjectType apiobject_type.Untyped \<Longrightarrow> minUntypedSizeBits \<le> us \<and> us \<le> maxUntypedSizeBits"
  assumes ptr: " ptr \<noteq> 0"
  shows "\<lbrace>\<lambda>s. pspace_no_overlap' ptr sz s \<and> valid_pspace' s\<rbrace>
           createNewCaps ty ptr n us dev
         \<lbrace>\<lambda>r s. (\<forall>cap \<in> set r. s \<turnstile>' cap)\<rbrace>"
proof -
  note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
          Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex
  note if_split_def[split del] = if_splits

  show ?thesis
  proof(cases "Types_H.toAPIType ty")
    case None thus ?thesis
      using not_0
      apply (clarsimp simp: createNewCaps_def Arch_createNewCaps_def)
      using cover
      apply (simp add: range_cover_def)
      using cover
      apply (clarsimp simp: ARM_H.toAPIType_def APIType_capBits_def
                     split: ARM_H.object_type.splits)

       \<comment> \<open>SmallPageObject\<close>
       apply wp
        apply (simp add: valid_cap'_def capAligned_def n_less_word_bits
                         ball_conj_distrib)
        apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified]
                 cwo_ret[OF _ not_0]
         | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb)+
       apply (simp add:pageBits_def ptr word_bits_def)
      \<comment> \<open>LargePageObject\<close>
      apply wp
       apply (simp add: valid_cap'_def capAligned_def n_less_word_bits
                        ball_conj_distrib)
       apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified]
                 cwo_ret[OF _ not_0]
         | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb)+
      apply (simp add:pageBits_def ptr word_bits_def)

     \<comment> \<open>SectionObject\<close>
     apply wp
      apply (simp add: valid_cap'_def capAligned_def n_less_word_bits
                       ball_conj_distrib)
      apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified]
                cwo_ret[OF _ not_0]
       | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb)+
     apply (simp add:pageBits_def ptr word_bits_def)

    \<comment> \<open>SuperSectionObject\<close>
    apply wp
     apply (simp add: valid_cap'_def capAligned_def n_less_word_bits
                      ball_conj_distrib)
     apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified]
               cwo_ret[OF _ not_0]
       | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb)+
    apply (simp add:pageBits_def ptr word_bits_def)

   \<comment> \<open>PageTableObject\<close>
    apply wp
     apply (simp add: valid_cap'_def capAligned_def n_less_word_bits)
     apply (simp only: imp_conv_disj page_table_at'_def
                       typ_at_to_obj_at_arches)
     apply (rule hoare_strengthen_post)
      apply (rule hoare_vcg_conj_lift)
       apply (rule createObjects_aligned [OF _ range_cover.range_cover_n_less(1)
           [where 'a=32, unfolded word_bits_len_of, OF cover] not_0])
       apply (simp add:objBits_simps archObjSize_def ptBits_def pageBits_def
                       pdeBits_def pteBits_def)+
      apply (simp add:range_cover_def word_bits_def)
      apply (rule createObjects_obj_at[where 'a =pte, OF _  not_0])
        apply (simp add:objBits_simps archObjSize_def ptBits_def pageBits_def
                        pdeBits_def pteBits_def)+
      apply (simp add: projectKOs projectKO_opt_pte)
     apply simp
    apply (clarsimp simp: objBits_simps archObjSize_def ptBits_def pageBits_def
                          pdeBits_def pteBits_def)
    apply clarsimp
  \<comment> \<open>PageDirectoryObject\<close>
   apply (wp hoare_vcg_const_Ball_lift)
   apply (wp mapM_x_wp' )
   apply (simp add: valid_cap'_def capAligned_def n_less_word_bits)
   apply (simp only: imp_conv_disj page_directory_at'_def
                     typ_at_to_obj_at_arches)
   apply (rule hoare_strengthen_post)
     apply (rule hoare_vcg_conj_lift)
      apply (rule createObjects_aligned [OF _ range_cover.range_cover_n_less(1)
          [where 'a=32, unfolded word_bits_len_of, OF cover] not_0])
       apply (simp add:objBits_simps archObjSize_def ptBits_def pageBits_def pdBits_def
                       pdeBits_def pteBits_def)+
      apply (simp add:range_cover_def word_bits_def)
     apply (rule createObjects_obj_at [where 'a=pde, OF _  not_0])
      apply (simp add:objBits_simps archObjSize_def ptBits_def pageBits_def pdBits_def
                      pdeBits_def pteBits_def)
     apply (simp add: projectKOs projectKO_opt_pde)
    apply simp
   apply (clarsimp simp: objBits_simps archObjSize_def pdBits_def pageBits_def
                         pdeBits_def pteBits_def)
   apply clarsimp
   done
  next
    case (Some a) thus ?thesis
    proof(cases a)
      case Untyped with Some cover ct show ?thesis
        apply (clarsimp simp: Arch_createNewCaps_def createNewCaps_def)
        apply (simp_all add: ARM_H.toAPIType_def fromIntegral_def
                             toInteger_nat fromInteger_nat APIType_capBits_def
                      split: ARM_H.object_type.splits)
        apply wp
        apply (intro ballI)
        apply (clarsimp simp: image_def upto_enum_red' valid_cap'_def capAligned_def
                       split: capability.splits)
        apply (drule word_leq_minus_one_le[rotated])
       apply (rule range_cover_not_zero[OF not_0 cover])
      apply (intro conjI)
         apply (rule is_aligned_add_multI[OF _ le_refl refl])
           apply (fastforce simp:range_cover_def word_bits_def)+
       apply (clarsimp simp:valid_untyped'_def ko_wp_at'_def obj_range'_def)
       apply (drule(1) pspace_no_overlapD'[rotated])
       apply (frule(1) range_cover_cell_subset)
       apply (erule disjE)
        apply (drule psubset_imp_subset)
        apply (drule(1) disjoint_subset2[rotated])
        apply (drule(1) disjoint_subset)
        apply (drule(1) range_cover_subset_not_empty)
        apply clarsimp+
       apply blast
      apply (drule(1) range_cover_no_0[OF ptr _ unat_less_helper])
      apply simp
      done
    next
      case TCBObject with Some cover ct show ?thesis
        including no_pre
        apply (clarsimp simp: Arch_createNewCaps_def createNewCaps_def)
        apply (simp_all add: ARM_H.toAPIType_def
                             fromIntegral_def toInteger_nat fromInteger_nat APIType_capBits_def curDomain_def
                      split: ARM_H.object_type.splits)
        apply (wp mapM_x_wp' hoare_vcg_const_Ball_lift)+
        apply (rule hoare_post_imp)
         prefer 2
         apply (rule createObjects_obj_at [where 'a = "tcb",OF _ not_0])
          using cover
          apply (clarsimp simp: ARM_H.toAPIType_def APIType_capBits_def objBits_simps
                         split: ARM_H.object_type.splits)
         apply (simp add: projectKOs)
        apply (clarsimp simp: valid_cap'_def objBits_simps)
        apply (fastforce intro: capAligned_tcbI)
        done
    next
      case EndpointObject with Some cover ct show ?thesis
        including no_pre
        apply (clarsimp simp: Arch_createNewCaps_def createNewCaps_def)
        apply (simp_all add: ARM_H.toAPIType_def
                             fromIntegral_def toInteger_nat fromInteger_nat APIType_capBits_def
                      split: ARM_H.object_type.splits)
        apply wp
        apply (rule hoare_post_imp)
         prefer 2
         apply (rule createObjects_obj_at [where 'a=endpoint, OF _ not_0])
          using cover
          apply (clarsimp simp: ARM_H.toAPIType_def APIType_capBits_def objBits_simps
                         split: ARM_H.object_type.splits)
         apply (simp add: projectKOs)
        apply (clarsimp simp: valid_cap'_def objBits_simps)
        apply (fastforce intro: capAligned_epI)
        done
    next
      case NotificationObject with Some cover ct show ?thesis
        including no_pre
        apply (clarsimp simp: Arch_createNewCaps_def createNewCaps_def)
        apply (simp_all add: ARM_H.toAPIType_def
                             fromIntegral_def toInteger_nat fromInteger_nat APIType_capBits_def
                      split: ARM_H.object_type.splits)
        apply wp
        apply (rule hoare_post_imp)
         prefer 2
         apply (rule createObjects_obj_at [where 'a="notification", OF _ not_0])
          using cover
          apply (clarsimp simp: ARM_H.toAPIType_def APIType_capBits_def objBits_simps
                         split: ARM_H.object_type.splits)
         apply (simp add: projectKOs)
        apply (clarsimp simp: valid_cap'_def objBits_simps)
        apply (fastforce intro: capAligned_ntfnI)
        done
    next
      case CapTableObject with Some cover ct show ?thesis
        apply (clarsimp simp: Arch_createNewCaps_def createNewCaps_def)
        apply (simp_all add: ARM_H.toAPIType_def
                             fromIntegral_def toInteger_nat fromInteger_nat APIType_capBits_def
                      split: ARM_H.object_type.splits)
        apply wp
         apply (clarsimp simp: ARM_H.toAPIType_def APIType_capBits_def objBits_simps
                        split: ARM_H.object_type.split object_type.splits)
         apply (rule hoare_strengthen_post)
           apply (rule hoare_vcg_conj_lift)
           apply (rule createObjects_aligned [OF _ _ not_0 ])
              apply ((clarsimp simp:objBits_simps range_cover_def range_cover.range_cover_n_less[where 'a=32, unfolded word_bits_len_of, OF cover])+)[3]
            apply (simp add: word_bits_def)
           apply (rule hoare_vcg_conj_lift)
            apply (rule createObjects_ret [OF range_cover.range_cover_n_less(1)[where 'a=32, unfolded word_bits_len_of, OF cover] not_0])
           apply (rule createObjects_obj_at [where 'a=cte, OF _ not_0])
            apply (simp add: objBits_simps APIType_capBits_def)
           apply (simp add: projectKOs)
          apply simp
         apply (clarsimp simp: valid_cap'_def capAligned_def objBits_simps
                        dest!: less_two_pow_divD)
         apply (thin_tac "\<forall>x\<in>S. is_aligned (p x) n" for S p n)
         apply (intro conjI)
           apply ((simp add:range_cover_def word_bits_def)+)[2]
         apply (clarsimp simp: power_sub)
         apply (drule bspec, simp)
         apply (drule_tac x = "addr && mask us" in spec)
         apply (drule mp)
          apply simp
          apply (rule and_mask_less')
          apply (simp add: range_cover_def word_bits_def)
         apply (clarsimp simp add: shiftl_t2n)
        apply simp
        done
    qed
  qed
qed

lemma other_objs_default_relation:
  "\<lbrakk> case ty of Structures_A.EndpointObject \<Rightarrow> ko = injectKO (makeObject :: endpoint)
             | Structures_A.NotificationObject \<Rightarrow> ko = injectKO (makeObject :: Structures_H.notification)
             | Structures_A.TCBObject \<Rightarrow> ko = injectKO (makeObject :: tcb)
             | _ \<Rightarrow> False \<rbrakk> \<Longrightarrow>
    obj_relation_retype (default_object ty dev n) ko"
  apply (rule obj_relation_retype_other_obj)
   apply (clarsimp simp: default_object_def
                         is_other_obj_relation_type_def
                  split: Structures_A.apiobject_type.split_asm)
  apply (clarsimp simp: other_obj_relation_def default_object_def
                        ep_relation_def ntfn_relation_def
                        tcb_relation_def default_tcb_def makeObject_tcb
                        makeObject_cte new_context_def newContext_def
                        default_ep_def makeObject_endpoint default_notification_def
                        makeObject_notification default_ntfn_def
                        fault_rel_optionation_def
                        initContext_def
                        arch_tcb_context_get_def atcbContextGet_def
                        default_arch_tcb_def newArchTCB_def
                        arch_tcb_relation_def
                 split: Structures_A.apiobject_type.split_asm)
  done

lemma captable_relation_retype:
  "n < word_bits \<Longrightarrow>
   obj_relation_retype (default_object Structures_A.CapTableObject dev n) (KOCTE makeObject)"
  apply (clarsimp simp: obj_relation_retype_def default_object_def
                        wf_empty_bits objBits_simps'
                        dom_empty_cnode ex_with_length cte_level_bits_def)
  apply (rule conjI)
   defer
   apply (clarsimp simp: cte_relation_def empty_cnode_def makeObject_cte)
  apply (rule set_eqI, rule iffI)
   apply (clarsimp simp: cte_map_def')
   apply (rule_tac x="of_bl y" in exI)
   apply (simp add: of_bl_length[where 'a=32, folded word_bits_def])
  apply (clarsimp simp: image_def cte_map_def')
  apply (rule_tac x="drop (word_bits - n) (to_bl xa)" in exI)
  apply (simp add: of_drop_to_bl word_bits_def word_size)
  apply (simp add: less_mask_eq)
  done

lemma pagetable_relation_retype:
  "obj_relation_retype (default_object (ArchObject PageTableObj) dev n)
                       (KOArch (KOPTE makeObject))"
  apply (simp add: default_object_def default_arch_object_def
                   makeObject_pte obj_relation_retype_def
                   objBits_simps archObjSize_def
                   pte_relation_def)
  apply (clarsimp simp: range_composition[symmetric]
                        shiftl_t2n field_simps)
  apply (subst image_comp [symmetric, where g=ucast, unfolded o_def])
  apply (simp add: ucast_range_less pteBits_def)
  apply (fastforce simp:pte_relation_aligned_def)
  done

lemma pagedirectory_relation_retype:
  "obj_relation_retype (default_object (ArchObject PageDirectoryObj) dev n)
                       (KOArch (KOPDE makeObject))"
  apply (simp add: default_object_def default_arch_object_def
                   makeObject_pde obj_relation_retype_def
                   objBits_simps archObjSize_def
                   pde_relation_def)
  apply (clarsimp simp: range_composition[symmetric]
                        shiftl_t2n field_simps)
  apply (subst image_comp [symmetric, where g=ucast, unfolded o_def])
  apply (simp add: ucast_range_less pdeBits_def)
  apply (fastforce simp:pde_relation_aligned_def)
  done

lemmas makeObjectKO_simps = makeObjectKO_def[split_simps ARM_H.object_type.split
 apiobject_type.split sum.split kernel_object.split ]

lemma corres_retype:
  assumes         not_zero: "n \<noteq> 0"
  and         aligned: "is_aligned ptr (objBitsKO ko + gbits)"
  and    obj_bits_api: "obj_bits_api (APIType_map2 ty) us = objBitsKO ko + gbits"
  and              tp: "APIType_map2 ty \<in> no_gs_types"
  and              ko: "makeObjectKO dev ty = Some ko"
  and             orr: "obj_bits_api (APIType_map2 ty) us \<le> sz \<Longrightarrow>
                        obj_relation_retype (default_object (APIType_map2 ty) dev us) ko"
  and           cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n"
  shows "corres (=)
  (\<lambda>s. valid_pspace s \<and> pspace_no_overlap_range_cover ptr sz s
     \<and> valid_mdb s \<and> valid_etcbs s \<and> valid_list s)
  (\<lambda>s. pspace_aligned' s \<and> pspace_distinct' s \<and> pspace_no_overlap' ptr sz s
       \<and> (\<exists>val. ko = injectKO val))
  (retype_region2 ptr n us (APIType_map2 ty) dev) (createObjects ptr n ko gbits)"
  apply (rule corres_guard_imp)
    apply (rule_tac F = "(\<exists>val. ko = injectKO val)" in corres_gen_asm2)
    apply (erule exE)
    apply (rule corres_rel_imp)
    apply (rule corres_retype'[where g=id and ty=ty and sz = sz,OF not_zero aligned _ _ _ ko
           ,simplified update_gs_id[OF tp] modify_id_return,simplified])
        using assms
        apply (simp_all add: objBits_def no_gs_types_def)
  apply auto
  done

lemma init_arch_objects_APIType_map2:
  "init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs =
     (case ty of APIObjectType _ \<Rightarrow> return ()
   | _ \<Rightarrow> init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)"
  apply (clarsimp split: ARM_H.object_type.split)
  apply (simp add: init_arch_objects_def APIType_map2_def
            split: apiobject_type.split)
  done

lemma pde_relation_aligned_eq:
  "\<lbrakk>is_aligned (pd::word32) 6; is_aligned pd' 6\<rbrakk>
   \<Longrightarrow> pde_relation_aligned (pd + x >> 2) xa ya =
       pde_relation_aligned (pd' + x >> 2) xa ya"
  apply (clarsimp simp: pde_relation_aligned_def is_aligned_mask mask_def
                 split: ARM_H.pde.splits)
  apply word_bitwise
  apply auto
  done

lemma copyGlobalMappings_corres:
  "corres dc (valid_arch_state and valid_etcbs and pspace_aligned and page_directory_at pd)
             (valid_arch_state' and page_directory_at' pd)
          (copy_global_mappings pd)
          (copyGlobalMappings pd)"
  apply (simp add: copy_global_mappings_def
                   copyGlobalMappings_def
                   objBits_simps archObjSize_def
                   pd_bits_def pdBits_def mapM_x_mapM)
  apply (rule corres_guard_imp)
    apply (rule corres_split_eqr)
       apply (rule_tac F ="is_aligned pd 6 \<and> is_aligned global_pd 6" in corres_gen_asm)
       apply (simp add: liftM_def[symmetric])
       apply (rule_tac S="(=)" and r'=dc
                   and Q="\<lambda>xs s. \<forall>x \<in> set xs. pde_at (global_pd + (x << 2)) s
                                              \<and> pde_at (pd + (x << 2)) s \<and> pspace_aligned s \<and>
                                              valid_etcbs s"
                   and Q'="\<lambda>xs s. \<forall>x \<in> set xs. pde_at' (global_pd + (x << 2)) s
                                              \<and> pde_at' (pd + (x << 2)) s"
                          in corres_mapM_list_all2, (simp add: pdeBits_def)+)
          apply (rule corres_guard_imp, rule corres_split_deprecated)
               apply (erule storePDE_corres[OF _ refl])
              apply (rule corres_rel_imp)
               apply (rule_tac getObject_PDE_corres[OF refl])
              apply clarsimp
              apply (drule(1) pde_relation_aligned_eq)
              apply fastforce
             apply (wp hoare_vcg_const_Ball_lift | simp)+
       apply (simp add: kernel_base_def ARM.pptrBase_def pptrBase_def list_all2_refl pageBits_def)
      apply (rule corres_trivial, clarsimp simp: state_relation_def arch_state_relation_def)
     apply wp+
   apply (clarsimp simp: valid_arch_state_def)
   apply (auto elim: page_directory_pde_atI is_aligned_weaken[OF pd_aligned])[1]
  apply (clarsimp simp: valid_arch_state'_def)
  apply (auto simp: le_less_trans elim!: page_directory_pde_atI'[simplified pageBits_def, simplified])
  done

(* FIXME: move *)
lemma copyGlobalMappings_cte_wp_at[wp]:
  "\<lbrace>\<lambda>s. P (cte_wp_at' P' p s)\<rbrace>
     copyGlobalMappings pd
   \<lbrace>\<lambda>rv s. P (cte_wp_at' P' p s)\<rbrace>"
  apply (simp add: copyGlobalMappings_def)
  apply (wp mapM_x_wp')
  done

crunch ct[wp]: copyGlobalMappings "\<lambda>s. P (ksCurThread s)"
  (wp: setObject_ksPSpace_only updateObject_default_inv mapM_x_wp')

crunch ksCurDomain[wp]: copyGlobalMappings "\<lambda>s. P (ksCurDomain s)"
  (wp: setObject_ksPSpace_only updateObject_default_inv mapM_x_wp')

lemmas copyGlobalMappings_ctes_of[wp]
    = ctes_of_from_cte_wp_at[where Q="\<top>", simplified,
                             OF copyGlobalMappings_cte_wp_at]

lemmas object_splits =
  apiobject_type.split_asm
  ARM_H.object_type.split_asm
  sum.split_asm kernel_object.split_asm
  arch_kernel_object.split_asm

declare hoare_in_monad_post[wp del]
declare univ_get_wp[wp del]
declare result_in_set_wp[wp del]

crunch valid_arch_state'[wp]: copyGlobalMappings "valid_arch_state'"
  (wp: crunch_wps)

lemma nullPointer_0_simp[simp]:
  "(nullPointer = 0) = True"
  by (simp add: nullPointer_def)

lemma descendants_of_retype':
  assumes P: "\<And>p. P p \<Longrightarrow> m p = None"
  shows "descendants_of' p (\<lambda>p. if P p then Some makeObject else m p) =
         descendants_of' p m"
  apply (rule set_eqI)
  apply (simp add: descendants_of'_def)
  apply (rule iffI)
   apply (erule subtree.induct)
    apply (rule direct_parent)
      apply (clarsimp simp: mdb_next_unfold makeObject_cte split: if_split_asm)
     apply assumption
    apply (clarsimp simp: parentOf_def makeObject_cte split: if_split_asm)
   apply (erule trans_parent)
     apply (clarsimp simp: mdb_next_unfold makeObject_cte split: if_split_asm)
    apply assumption
   apply (clarsimp simp: parentOf_def makeObject_cte split: if_split_asm)
  apply (erule subtree.induct)
   apply (rule direct_parent)
     apply (clarsimp simp: mdb_next_unfold dest!: P)
    apply assumption
   apply (fastforce simp: parentOf_def dest!: P)
  apply (erule trans_parent)
    apply (clarsimp simp: mdb_next_unfold dest!: P)
   apply assumption
  apply (fastforce simp: parentOf_def dest!: P)
  done

lemma capRange_Null [simp]: "capRange NullCap = {}"
  by (simp add: capRange_def)

end

locale retype_mdb = vmdb +
  fixes P n
  assumes P: "\<And>p. P p \<Longrightarrow> m p = None"
  assumes 0: "\<not>P 0"
  defines "n \<equiv> \<lambda>p. if P p then Some makeObject else m p"
begin
interpretation Arch . (*FIXME: arch_split*)

lemma no_0_n: "no_0 n"
  using no_0 by (simp add: no_0_def n_def 0)

lemma n_next:
  "n \<turnstile> c \<leadsto> c' = (if P c then c' = 0 else m \<turnstile> c \<leadsto> c')"
  by (simp add: mdb_next_unfold n_def makeObject_cte nullPointer_def)

lemma n_prev:
  "n \<turnstile> c \<leftarrow> c' = (if P c' then c = 0 else m \<turnstile> c \<leftarrow> c')"
  by (simp add: mdb_prev_def n_def makeObject_cte nullPointer_def)

lemma dlist_n: "valid_dlist n"
  using dlist no_0 no_0_n
  apply (simp add: valid_dlist_def2)
  apply (clarsimp simp: n_prev n_next)
  apply (rule conjI)
   apply clarsimp
   apply (erule allE, erule (1) impE)
   apply (erule_tac x=c' in allE)
   apply simp
   apply (drule P)
   apply (simp add: mdb_next_unfold)
  apply clarsimp
  apply (erule allE, erule (1) impE)
  apply (erule_tac x=c' in allE)
  apply simp
  apply (drule P)
  apply (simp add: mdb_prev_def)
  done

lemma n_next_trancl:
  "n \<turnstile> c \<leadsto>\<^sup>+ c' \<Longrightarrow> (if P c then c' = 0 else m \<turnstile> c \<leadsto>\<^sup>+ c')"
  apply (insert no_0_n chain)
  apply (erule trancl_induct)
   apply (fastforce simp: n_next)
  apply (simp split: if_split_asm)
   apply (clarsimp simp: mdb_next_unfold)
  apply (simp add: n_next split: if_split_asm)
  apply (simp add: mdb_chain_0_def)
  apply (drule_tac x=c in bspec)
   apply (drule tranclD)
   apply (clarsimp simp: mdb_next_unfold)
  apply assumption
  done

lemma next_not_P:
  "m \<turnstile> c \<leadsto> c' \<Longrightarrow> \<not>P c"
  by (clarsimp simp: mdb_next_unfold dest!: P)

lemma m_next_trancl:
  "m \<turnstile> c \<leadsto>\<^sup>+ c' \<Longrightarrow> n \<turnstile> c \<leadsto>\<^sup>+ c'"
  apply (erule trancl_induct)
   apply (rule r_into_trancl)
   apply (clarsimp simp: n_next)
   apply (drule next_not_P)
   apply simp
  apply (erule trancl_trans)
  apply (rule r_into_trancl)
  apply (clarsimp simp: n_next)
  apply (drule next_not_P)
  apply simp
  done

lemma P_to_0:
  "P c \<Longrightarrow> n \<turnstile> c \<leadsto>\<^sup>+ 0"
  by (rule r_into_trancl) (simp add: n_next)

lemma n_trancl_eq:
  "n \<turnstile> c \<leadsto>\<^sup>+ c' = (if P c then c' = 0 else m \<turnstile> c \<leadsto>\<^sup>+ c')"
  by (auto dest: m_next_trancl n_next_trancl P_to_0)

lemma n_rtrancl_eq:
  "n \<turnstile> c \<leadsto>\<^sup>* c' = (if P c then c' = 0 \<or> c = c' else m \<turnstile> c \<leadsto>\<^sup>* c')"
  by (auto simp: n_trancl_eq rtrancl_eq_or_trancl)

lemma dom_n:
  "dom n = dom m \<union> Collect P"
  by (auto simp add: n_def)

lemma mdb_chain_0_n: "mdb_chain_0 n"
  using chain
  by (auto simp: mdb_chain_0_def dom_n n_trancl_eq)

lemma n_Some_eq:
  "(n p = Some (CTE cap node)) =
  (if P p then cap = NullCap \<and> node = nullMDBNode
          else m p = Some (CTE cap node))"
  by (auto simp: n_def makeObject_cte)

lemma valid_badges_n: "valid_badges n"
proof -
  from valid
  have "valid_badges m" ..
  thus ?thesis
    apply (clarsimp simp: valid_badges_def)
    apply (simp add: n_Some_eq n_next split: if_split_asm)
    apply fastforce
    done
qed

lemma caps_contained_n: "caps_contained' n"
proof -
  from valid
  have "caps_contained' m" ..
  thus ?thesis
    apply (clarsimp simp: caps_contained'_def)
    apply (simp add: n_Some_eq split: if_split_asm)
    apply fastforce
    done
qed

lemma mdb_chunked_n: "mdb_chunked n"
proof -
  from valid
  have "mdb_chunked m" ..
  thus ?thesis
    apply (clarsimp simp: mdb_chunked_def)
    apply (simp add: n_Some_eq split: if_split_asm)
    apply (simp add: n_Some_eq n_trancl_eq n_rtrancl_eq is_chunk_def)
    apply fastforce
    done
qed

lemma descendants [simp]:
  "descendants_of' p n = descendants_of' p m"
  apply (unfold n_def)
  apply (subst descendants_of_retype')
   apply (erule P)
  apply (rule refl)
  done

lemma untyped_mdb_n: "untyped_mdb' n"
proof -
  from valid
  have "untyped_mdb' m" ..
  thus ?thesis
    apply (clarsimp simp: untyped_mdb'_def)
    apply (simp add: n_Some_eq split: if_split_asm)
    done
qed

lemma untyped_inc_n: "untyped_inc' n"
proof -
  from valid
  have "untyped_inc' m" ..
  thus ?thesis
    apply (clarsimp simp: untyped_inc'_def)
    apply (simp add: n_Some_eq split: if_split_asm)
    apply blast
    done
qed

lemma valid_nullcaps_n: "valid_nullcaps n"
proof -
  from valid
  have "valid_nullcaps m" ..
  thus ?thesis
    apply (clarsimp simp: valid_nullcaps_def)
    apply (simp add: n_Some_eq split: if_split_asm)
    done
qed

lemma ut_rev_n: "ut_revocable' n"
proof -
  from valid
  have "ut_revocable' m" ..
  thus ?thesis
    apply (clarsimp simp: ut_revocable'_def)
    apply (simp add: n_Some_eq split: if_split_asm)
    done
qed

lemma class_links_m:
  "class_links m"
  using valid by (simp add: valid_mdb_ctes_def)

lemma next_not_P2:
  "\<lbrakk> m \<turnstile> p \<leadsto> p'; p' \<noteq> nullPointer \<rbrakk> \<Longrightarrow> \<not> P p'"
  using dlist
  apply (clarsimp simp: mdb_next_unfold)
  apply (erule(1) valid_dlistE)
   apply clarsimp
  apply (clarsimp dest!: P)
  done

lemma class_links_n:
  "class_links n"
  using class_links_m
  apply (simp add: class_links_def)
  apply (elim allEI)
  apply clarsimp
  apply (subgoal_tac "p' \<noteq> nullPointer")
   apply (simp add: n_next split: if_split_asm)
   apply (case_tac cte, case_tac cte')
   apply (clarsimp simp add: n_Some_eq split: if_split_asm)
   apply (drule(1) next_not_P2)
   apply simp
  apply (clarsimp simp: no_0_n nullPointer_def)
  done

lemma irq_control_n:
  "irq_control n"
  apply (clarsimp simp add: irq_control_def)
  apply (simp add: n_Some_eq split: if_split_asm)
  apply (frule irq_revocable, rule irq_control)
  apply clarsimp
  apply (erule (1) irq_controlD, rule irq_control)
  done

lemma dist_z_m: "distinct_zombies m"
  using valid by auto

lemma dist_z_n: "distinct_zombies n"
  using dist_z_m
  apply (simp add: n_def distinct_zombies_def
                   distinct_zombie_caps_def
               split del: if_split)
  apply (erule allEI, erule allEI)
  apply (clarsimp split del: if_split)
  apply (clarsimp split: if_split_asm simp: makeObject_cte)
  apply (clarsimp simp: isCap_simps)
  done

lemma reply_masters_rvk_fb_m: "reply_masters_rvk_fb m"
  using valid by auto

lemma reply_masters_rvk_fb_n: "reply_masters_rvk_fb n"
  using reply_masters_rvk_fb_m
  by (simp add: n_def reply_masters_rvk_fb_def
                ball_ran_eq makeObject_cte isCap_simps)

lemma valid_n:
  "valid_mdb_ctes n"
  by (simp add: valid_mdb_ctes_def dlist_n no_0_n mdb_chain_0_n
                valid_badges_n caps_contained_n untyped_mdb_n
                untyped_inc_n mdb_chunked_n valid_nullcaps_n ut_rev_n
                class_links_n irq_control_n dist_z_n
                reply_masters_rvk_fb_n)

end

definition
  caps_no_overlap'' :: "word32 \<Rightarrow> nat \<Rightarrow> kernel_state \<Rightarrow> bool"
where
 "caps_no_overlap'' ptr sz s \<equiv> \<forall>cte \<in> ran (ctes_of s).
               untypedRange (cteCap cte) \<inter> {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \<noteq> {}
               \<longrightarrow> {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \<subseteq> untypedRange (cteCap cte)"

lemma obj_range'_subset:
  "\<lbrakk>range_cover ptr sz (objBitsKO val) n; ptr' \<in> set (new_cap_addrs n ptr val)\<rbrakk>
   \<Longrightarrow> obj_range' ptr' val \<subseteq> {ptr..(ptr && ~~ mask sz) + 2 ^ sz - 1}"
  unfolding obj_range'_def
  by (rule new_range_subset, auto)

lemma obj_range'_subset_strong:
  assumes "range_cover ptr sz (objBitsKO val) n"
      and "ptr' \<in> set (new_cap_addrs n ptr val)"
  shows "obj_range' ptr' val \<subseteq> {ptr..ptr + (of_nat n * 2 ^ objBitsKO val) - 1}"
proof -
  {
    assume cover: "range_cover ptr sz (objBitsKO val) n"
      and  mem_p: "ptr' \<in> set (new_cap_addrs n ptr val)"
      and  not_0: "n\<noteq> 0"
    note n_less = range_cover.range_cover_n_less[OF cover]
    have unat_of_nat_m1: "unat (of_nat n - (1::machine_word)) < n"
      using not_0 n_less by (simp add:unat_of_nat_minus_1)
    have decomp:
      "of_nat n * 2 ^ objBitsKO val =
       of_nat (n - 1) * 2 ^ objBitsKO val + (2 :: machine_word) ^ objBitsKO val"
      apply (simp add:distrib_right[where b = "1 :: machine_word",simplified,symmetric])
      using not_0 n_less
      apply simp
      done
    have "ptr' + 2 ^ objBitsKO val - 1 \<le> ptr + of_nat n * 2 ^ objBitsKO val - 1"
      using cover
      apply (subst decomp)
      apply (simp add:add.assoc[symmetric])
      apply (simp add:p_assoc_help)
      apply (rule order_trans[OF word_plus_mono_left word_plus_mono_right])
         using mem_p not_0
         apply (clarsimp simp:new_cap_addrs_def shiftl_t2n)
         apply (rule word_plus_mono_right)
          apply (subst mult.commute)
          apply (rule word_mult_le_mono1[OF word_of_nat_le])
            using n_less not_0
            apply (simp add:unat_of_nat_minus_1)
           apply (rule p2_gt_0[THEN iffD2])
           apply (simp add:word_bits_def range_cover_def)
          apply (simp only: word_bits_def[symmetric])
          apply (clarsimp simp: unat_of_nat_minus_1[OF n_less(1) not_0])
          apply (rule nat_less_power_trans2
            [OF range_cover.range_cover_le_n_less(2),OF cover, folded word_bits_def])
           apply (simp add:unat_of_nat_m1 less_imp_le)
          apply (simp add:range_cover_def word_bits_def)
         apply (rule machine_word_plus_mono_right_split[where sz = sz])
          using range_cover.range_cover_compare[OF cover,where p = "unat (of_nat n - (1::machine_word))"]
          apply (clarsimp simp:unat_of_nat_m1)
         apply (simp add:range_cover_def word_bits_def)
        apply (rule olen_add_eqv[THEN iffD2])
        apply (subst add.commute[where a = "2^objBitsKO val - 1"])
        apply (subst p_assoc_help[symmetric])
        apply (rule is_aligned_no_overflow)
        apply (clarsimp simp:range_cover_def word_bits_def)
        apply (erule aligned_add_aligned[OF _  is_aligned_mult_triv2]; simp)
       apply simp
      by (meson assms(1) is_aligned_add is_aligned_mult_triv2 is_aligned_no_overflow' range_cover_def)
  }
  with assms show ?thesis
    unfolding obj_range'_def
    apply -
    apply (frule(1) obj_range'_subset)
    apply (simp add: obj_range'_def)
    apply (cases "n = 0"; clarsimp simp:new_cap_addrs_def)
    done
qed

lemma caps_no_overlapD'':
  "\<lbrakk>cte_wp_at' (\<lambda>cap. cteCap cap = c) q s;caps_no_overlap'' ptr sz s\<rbrakk>
   \<Longrightarrow> untypedRange c \<inter> {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \<noteq> {} \<longrightarrow>
       {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \<subseteq> untypedRange c"
  apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps caps_no_overlap''_def
        simp del:atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
        Int_atLeastAtMost atLeastatMost_empty_iff)
  apply (drule_tac x = cte in bspec)
    apply fastforce
  apply (erule(1) impE)
  apply blast
done

context begin interpretation Arch . (*FIXME: arch_split*)
lemma valid_untyped'_helper:
  assumes valid : "valid_cap' c s"
  and  cte_at : "cte_wp_at' (\<lambda>cap. cteCap cap = c) q s"
  and  cover  : "range_cover ptr sz (objBitsKO val) n"
  and  range  : "caps_no_overlap'' ptr sz s"
  and  pres   : "isUntypedCap c \<longrightarrow> usableUntypedRange c \<inter>  {ptr..ptr + of_nat n * 2 ^ objBitsKO val - 1} = {}"
  shows "\<lbrakk>pspace_aligned' s; pspace_distinct' s; pspace_no_overlap' ptr sz s\<rbrakk>
 \<Longrightarrow> valid_cap' c (s\<lparr>ksPSpace := foldr (\<lambda>addr. data_map_insert addr val) (new_cap_addrs n ptr val) (ksPSpace s)\<rparr>)"
  proof -
  note blah[simp del] = atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
        Int_atLeastAtMost atLeastatMost_empty_iff
  assume pn : "pspace_aligned' s" "pspace_distinct' s"
  and   no_overlap: "pspace_no_overlap' ptr sz s"
  show ?thesis
  using pn pres no_overlap valid cover cte_wp_at_ctes_of[THEN iffD1,OF cte_at]
        caps_no_overlapD''[OF cte_at range]
  apply (clarsimp simp:valid_cap'_def retype_ko_wp_at')
  apply (case_tac "cteCap cte"; simp add: valid_cap'_def cte_wp_at_obj_cases'
                                valid_pspace'_def retype_obj_at_disj'
                         split: zombie_type.split_asm)
   apply (rename_tac arch_capability)
   apply (case_tac arch_capability;
          simp add: retype_obj_at_disj' typ_at_to_obj_at_arches
                    page_table_at'_def page_directory_at'_def split del: if_splits)
    apply (fastforce simp: typ_at_to_obj_at_arches retype_obj_at_disj')
                           unfolding valid_untyped'_def
  apply (intro allI)
  apply (rule ccontr)
  apply clarify
  using cover[unfolded range_cover_def]
  apply (clarsimp simp:isCap_simps retype_ko_wp_at' split:if_split_asm)
   apply (thin_tac "\<forall>x. Q x" for Q)
   apply (frule aligned_untypedRange_non_empty)
    apply (simp add:isCap_simps)
   apply (elim disjE)
    apply (frule(1) obj_range'_subset)
    apply (erule impE)
     apply (drule(1) psubset_subset_trans)
     apply (drule Int_absorb1[OF psubset_imp_subset])
     apply (drule aligned_untypedRange_non_empty)
      apply (simp add:isCap_simps)
     apply (simp add:Int_ac)
    apply (drule(1) subset_trans)
    apply blast
   apply (frule(1) obj_range'_subset_strong)
   apply (drule(1) non_disjoing_subset)
   apply blast
  apply (thin_tac "\<forall>x. Q x" for Q)
  apply (frule aligned_untypedRange_non_empty)
   apply (simp add:isCap_simps)
  apply (frule(1) obj_range'_subset)
  apply (drule(1) subset_trans)
   apply (erule impE)
    apply clarsimp
    apply blast
   apply blast
  done
qed

definition caps_overlap_reserved' :: "word32 set \<Rightarrow> kernel_state \<Rightarrow> bool"
where
 "caps_overlap_reserved' S s \<equiv> \<forall>cte \<in> ran (ctes_of s).
  (isUntypedCap (cteCap cte) \<longrightarrow> usableUntypedRange (cteCap cte) \<inter> S = {})"

lemma createObjects_valid_pspace':
  assumes  mko: "makeObjectKO dev ty = Some val"
  and    not_0: "n \<noteq> 0"
  and    cover: "range_cover ptr sz (objBitsKO val + gbits) n"
  shows "\<lbrace>\<lambda>s. pspace_no_overlap' ptr sz s \<and> valid_pspace' s \<and> caps_no_overlap'' ptr sz s
            \<and> caps_overlap_reserved' {ptr .. ptr + of_nat (n * 2^gbits * 2 ^ objBitsKO val ) - 1} s
            \<and> ptr \<noteq> 0\<rbrace>
  createObjects' ptr n val gbits \<lbrace>\<lambda>r. valid_pspace'\<rbrace>"
  apply (cut_tac not_0)
  apply (simp add: split_def createObjects'_def
                   lookupAround2_pspace_no
                   alignError_def unless_def)
  apply (rule hoare_pre)
   apply (wp|simp cong: if_cong del: data_map_insert_def del:fun_upd_apply)+
   apply (wpc|wp)+
   apply (subst new_cap_addrs_fold')
     apply (simp add:unat_1_0 unat_gt_0)
     apply (rule range_cover_not_zero_shift[OF _  cover])
     apply simp+
   apply (subst new_cap_addrs_fold')
     apply (simp add:unat_1_0 unat_gt_0)
     apply (rule range_cover_not_zero_shift[OF _  cover])
     apply simp+
   apply (subst data_map_insert_def[symmetric])+
  apply (rule impI)
  apply (clarsimp simp: new_cap_addrs_fold'
                        valid_pspace'_def linorder_not_less
                        objBits_def[symmetric])
  apply (simp only: imp_disjL[symmetric] imp_conjL[symmetric] imp_ex[symmetric]
                    range_cover.unat_of_nat_n_shift[OF cover,where gbits=gbits,simplified])
proof (intro conjI impI)

  fix s

  assume pn: "pspace_no_overlap' ptr sz s"
     and vo: "valid_objs' s"
     and ad: "pspace_aligned' s" "pspace_distinct' s"
     and pc: "caps_no_overlap'' ptr sz s"
    and mdb: "valid_mdb' s"
    and p_0: "ptr \<noteq> 0"
    and reserved : "caps_overlap_reserved' {ptr..ptr + of_nat n *2 ^ gbits * 2 ^ objBitsKO val - 1} s"
    and no_0_obj': "no_0_obj' s"
  have obj': "objBitsKO val \<le> sz"
    using cover
    by (simp add:range_cover_def)

  let ?s' = "s\<lparr>ksPSpace := foldr (\<lambda>addr. data_map_insert addr val) (new_cap_addrs (n * 2 ^ gbits) ptr val) (ksPSpace s)\<rparr>"

  note cover' = range_cover_rel[where sbit' = "objBitsKO val",OF cover _ refl,simplified]

  note ad' = retype_aligned_distinct'[OF ad pn cover']

  note shift = range_cover.unat_of_nat_n_shift[OF cover,where gbits=gbits,simplified]

  have al: "is_aligned ptr (objBitsKO val)"
    using cover'
    by (simp add:range_cover_def)

  show pspace_aligned: "pspace_aligned' ?s'"
  using ad' range_cover.unat_of_nat_n_shift[OF cover,where gbits=gbits,simplified]
    by (simp add:field_simps)

  show "pspace_distinct' ?s'"
  using ad' shift
    by (simp add:field_simps)

  note obj_at_disj = retype_obj_at_disj' [OF ad pn cover']

  note obj_at_disj' = obj_at_disj [unfolded foldr_upd_app_if[folded data_map_insert_def]]

  have obj_atC: "\<And>P x. x \<in> set (new_cap_addrs (2 ^ gbits * n) ptr val) \<Longrightarrow> \<not> obj_at' P x s"
    apply (clarsimp simp: obj_at'_def)
    apply (drule subsetD [OF new_cap_addrs_subset [OF cover' ]])
    apply (insert pspace_no_overlap_disjoint' [OF ad(1) pn])
    apply (drule domI[where m = "ksPSpace s"])
    apply (drule(1) orthD2)
    apply (clarsimp simp:ptr_add_def p_assoc_help)
    done

  have valid_cap: "\<And>cap q. \<lbrakk> s \<turnstile>' cap; cte_wp_at' (\<lambda>cte. cteCap cte = cap) q s \<rbrakk>
                      \<Longrightarrow> ?s' \<turnstile>' cap"
     apply (rule valid_untyped'_helper[OF _ _ _ pc _ ad pn ])
          apply simp+
        apply (subst mult.commute)
        apply (rule cover')
       using reserved
     apply (clarsimp simp:caps_overlap_reserved'_def cte_wp_at_ctes_of)
     apply (drule_tac x = cte in bspec)
       apply fastforce
     apply simp
   done

  show valid_objs: "valid_objs' ?s'" using vo
    apply (clarsimp simp: valid_objs'_def
                          foldr_upd_app_if[folded data_map_insert_def]
                   elim!: ranE
                   split: if_split_asm)
     apply (insert sym[OF mko])[1]
     apply (clarsimp simp: makeObjectKO_def
                    split: bool.split_asm sum.split_asm
                           ARM_H.object_type.split_asm
                           apiobject_type.split_asm
                           kernel_object.split_asm
                           arch_kernel_object.split_asm)
    apply (drule bspec, erule ranI)
    apply (subst mult.commute)
    apply (case_tac obj; simp add: valid_obj'_def)
        apply (rename_tac endpoint)
        apply (case_tac endpoint; simp add: valid_ep'_def obj_at_disj')
       apply (rename_tac notification)
       apply (case_tac notification; simp add: valid_ntfn'_def valid_bound_tcb'_def obj_at_disj')
       apply (rename_tac ntfn xa)
       apply (case_tac ntfn, simp_all, (clarsimp simp: obj_at_disj' split:option.splits)+)
      apply (rename_tac tcb)
      apply (case_tac tcb, clarsimp simp add: valid_tcb'_def)
      apply (frule pspace_alignedD' [OF _ ad(1)])
      apply (frule pspace_distinctD' [OF _ ad(2)])
      apply (simp add: objBits_simps)
      apply (subst mult.commute)
      apply (intro conjI ballI)
       apply (clarsimp elim!: ranE)
       apply (rule valid_cap[unfolded foldr_upd_app_if[folded data_map_insert_def]])
        apply (fastforce)
       apply (rule_tac ptr="x + xa" in cte_wp_at_tcbI', assumption+)
        apply fastforce
       apply simp
      apply (rename_tac thread_state mcp priority bool option nat cptr vptr bound user_context)
      apply (case_tac thread_state, simp_all add: valid_tcb_state'_def
                                                  valid_bound_ntfn'_def obj_at_disj'
                                           split: option.splits)[2]
     apply (simp add: valid_cte'_def)
     apply (frule pspace_alignedD' [OF _ ad(1)])
     apply (frule pspace_distinctD' [OF _ ad(2)])
     apply (simp add: objBits_simps')
     apply (subst mult.commute)
     apply (erule valid_cap[unfolded foldr_upd_app_if[folded data_map_insert_def]])
     apply (erule(2) cte_wp_at_cteI'[unfolded cte_level_bits_def])
     apply simp
    apply (rename_tac arch_kernel_object)
    apply (case_tac arch_kernel_object; simp)
      apply (rename_tac asidpool)
      apply (case_tac asidpool, clarsimp simp: page_directory_at'_def
                                               typ_at_to_obj_at_arches
                                               obj_at_disj')
     apply (rename_tac pte)
     apply (case_tac pte; simp add: valid_mapping'_def)
    apply (rename_tac pde)
    apply (case_tac pde; simp add: valid_mapping'_def page_table_at'_def
                                   typ_at_to_obj_at_arches obj_at_disj')
    done
  have not_0: "0 \<notin> set (new_cap_addrs (2 ^ gbits * n) ptr val)"
    using p_0
    apply clarsimp
    apply (drule subsetD [OF new_cap_addrs_subset [OF cover'],rotated])
    apply (clarsimp simp:ptr_add_def)
    done
  show "valid_mdb' ?s'"
    apply (simp add: valid_mdb'_def foldr_upd_app_if[folded data_map_insert_def])
    apply (subst mult.commute)
    apply (subst ctes_of_retype [OF mko ad])
        apply (rule ad'[unfolded foldr_upd_app_if[folded data_map_insert_def]])+
      apply (simp add: objBits_def[symmetric] new_cap_addrs_aligned [OF al])
     apply (rule ballI, drule subsetD [OF new_cap_addrs_subset [OF cover']])
     apply (insert pspace_no_overlap_disjoint' [OF ad(1) pn])
     apply (drule_tac x = x in orthD1)
       apply (simp add:ptr_add_def p_assoc_help)
     apply fastforce
    apply (fold makeObject_cte)
    apply (rule retype_mdb.valid_n)
    apply unfold_locales
      apply (rule mdb[unfolded valid_mdb'_def])
     apply (rule iffD2 [OF None_ctes_of_cte_at[unfolded cte_wp_at_obj_cases'], THEN sym])
     apply (rule notI)
     apply (elim disjE conjE, simp_all add: obj_atC)[1]
       apply (thin_tac "S \<inter> T = {}" for S T)
       apply (clarsimp simp: obj_at'_def projectKOs objBits_simps)
       apply (drule pspace_no_overlapD' [OF _ pn])
       apply (drule subsetD [OF new_cap_addrs_subset[OF cover']])
       apply (frule_tac ptr'=p in mask_in_range)
       apply (drule(1) tcb_cte_cases_aligned_helpers)
       apply (drule_tac x = p in orthD1)
         apply (clarsimp simp:objBits_simps)
       apply (clarsimp simp:ptr_add_def p_assoc_help)
      apply (frule new_range_subset[OF cover'])
      apply (drule bspec [OF new_cap_addrs_aligned[OF al]])
      apply (drule(1) disjoint_subset[rotated])
      apply (drule_tac a=p in equals0D)
      apply (frule_tac ptr'=p in mask_in_range)
      apply (insert sym [OF mko],
             clarsimp simp: objBits_simps makeObjectKO_def obj_at'_def)[1]
     apply (insert sym[OF mko] cover',
            clarsimp simp: obj_at'_def objBits_simps
                           makeObjectKO_def projectKOs)[1]
     apply (drule(1) tcb_cte_cases_aligned_helpers(2))
     apply clarsimp
     apply (drule subsetD [OF new_cap_addrs_subset,rotated])
       apply (simp add:objBits_simps)
     apply (drule orthD1)
       apply (fastforce simp:p_assoc_help ptr_add_def)
     apply fastforce
    apply (simp add: not_0)
    done

  have data_map_ext: "\<And>x y. data_map_insert x y = (\<lambda>m. m (x \<mapsto> y))"
    by (rule ext) simp
  show no_0_obj: "no_0_obj' ?s'"
    using not_0 no_0_obj'
    by (simp add: no_0_obj'_def data_map_ext field_simps foldr_upd_app_other)

qed

abbreviation
 "injectKOS \<equiv> (injectKO :: ('a :: pspace_storable) \<Rightarrow> kernel_object)"

lemma createObjects_valid_pspace_untyped':
  assumes  mko: "makeObjectKO dev ty = Some val"
  and    not_0: "n \<noteq> 0"
  and    cover: "range_cover ptr sz (objBitsKO val + gbits) n"
  shows "\<lbrace>\<lambda>s. pspace_no_overlap' ptr sz s \<and> valid_pspace' s \<and> caps_no_overlap'' ptr sz s \<and> ptr \<noteq> 0
            \<and> caps_overlap_reserved' {ptr .. ptr + of_nat (n * 2^gbits * 2 ^ objBitsKO val ) - 1} s \<rbrace>
  createObjects' ptr n val gbits \<lbrace>\<lambda>r. valid_pspace'\<rbrace>"
  apply (wp createObjects_valid_pspace' [OF mko not_0 cover])
  apply simp
  done

lemma getObject_valid_pde'[wp]:
  "\<lbrace>valid_objs'\<rbrace> getObject x \<lbrace>valid_pde'\<rbrace>"
  apply (rule hoare_chain)
    apply (rule hoare_vcg_conj_lift)
     apply (rule getObject_ko_at, simp)
     apply (simp add: objBits_simps archObjSize_def pdeBits_def)
    apply (rule getObject_inv[where P=valid_objs'])
    apply (simp add: loadObject_default_inv)
   apply simp
  apply (clarsimp simp: projectKOs valid_obj'_def dest!: obj_at_valid_objs')
  done

crunch valid_objs'[wp]: copyGlobalMappings "valid_objs'"
  (ignore: storePDE wp: crunch_wps)
crunch pspace_aligned'[wp]: copyGlobalMappings "pspace_aligned'"
  (wp: crunch_wps)
crunch pspace_distinct'[wp]: copyGlobalMappings "pspace_distinct'"
  (wp: crunch_wps)

lemmas storePDE_valid_mdb[wp]
    = storePDE_ctes[where P=valid_mdb_ctes, folded valid_mdb'_def]
crunch valid_mdb[wp]: copyGlobalMappings "valid_mdb'"
  (wp: crunch_wps)

crunch no_0_obj' [wp]: copyGlobalMappings no_0_obj'
  (wp: crunch_wps)

lemma copyGlobalMappings_valid_pspace[wp]:
  "\<lbrace>valid_pspace'\<rbrace> copyGlobalMappings pd \<lbrace>\<lambda>rv. valid_pspace'\<rbrace>"
  by (simp add: valid_pspace'_def | wp)+

declare bleeding_obvious [simp]

lemma range_cover_new_cap_addrs_compare:
  assumes not_0: "n \<noteq> 0"
  and     cover: "range_cover ptr sz (objBitsKO val + gbits) n"
  and    ptr_in: "p \<in> set (new_cap_addrs (unat (((of_nat n)::word32) << gbits)) ptr val)"
  shows  "p \<le> ptr + of_nat (shiftL n (objBitsKO val + gbits) - Suc 0)"
proof -
  note unat_of_nat_shift = range_cover.unat_of_nat_n_shift[OF cover,where gbits=gbits,simplified]
  have cover' :"range_cover ptr sz (objBitsKO val) (n*2^gbits)"
    by (rule range_cover_rel[OF cover],simp+)
  have upbound:" unat ((((of_nat n)::word32) * 2 ^ gbits)) * unat ((2::word32) ^ objBitsKO val) < 2 ^ word_bits"
    using range_cover.range_cover_le_n_less[OF cover' le_refl] cover'
    apply -
    apply (drule nat_less_power_trans)
     apply (simp add:range_cover_def)
    apply (fold word_bits_def)
    using unat_of_nat_shift not_0
    apply (simp add:field_simps shiftl_t2n)
    done
  have not_0': "(2::word32) ^ (objBitsKO val + gbits) * of_nat n \<noteq> 0"
    apply (rule range_cover_not_zero_shift[OF not_0,unfolded shiftl_t2n,OF _ le_refl])
    apply (rule range_cover_rel[OF cover]; simp)
    done
  have "gbits < word_bits"
    using cover
    by (simp add:range_cover_def word_bits_def)
  thus ?thesis
    apply -
    apply (insert not_0 cover ptr_in)
    apply (frule range_cover.range_cover_le_n_less[OF _ le_refl])
    apply (fold word_bits_def)
    apply (simp add:shiftL_nat )
    apply (simp add:range_cover.unat_of_nat_n_shift)
    apply (clarsimp simp:new_cap_addrs_def shiftl_t2n)
    apply (rename_tac pa)
    apply (rule word_plus_mono_right)
     apply (rule order_trans)
      apply (subst mult.commute)
      apply (rule word_mult_le_iff[THEN iffD2])
         apply (clarsimp simp:p2_gt_0 range_cover_def word_bits_def)
        apply (drule range_cover_rel[where sbit' = "0"])
          apply (simp+)[2]
        apply (erule less_le_trans[OF range_cover.range_cover_le_n_less(2)])
         apply (clarsimp simp:field_simps power_add)
         apply (rule unat_le_helper)
         apply (rule of_nat_mono_maybe_le[THEN iffD1])
           using range_cover.range_cover_le_n_less[OF cover' le_refl]
           apply (simp_all only:word_bits_def[symmetric])
        apply simp
       apply (drule nat_less_power_trans)
        apply (simp add:range_cover_def word_bits_def)
       apply (rule less_le_trans[OF mult_less_mono1])
         apply (rule unat_mono)
         apply (rule_tac y1= "pa" in  of_nat_mono_maybe'[THEN iffD1,rotated -1])
           apply (assumption)
          apply (simp add:word_bits_def)
         apply (simp add:word_bits_def)
        apply simp
       using unat_of_nat_shift
       apply (simp add:field_simps shiftl_t2n)
      apply simp
     apply (rule word_less_sub_1)
     apply (simp add:power_add field_simps)
     apply (subst mult.assoc[symmetric])
     apply (rule word_mult_less_mono1)
       apply (rule word_of_nat_less)
       using unat_of_nat_shift
       apply (simp add:shiftl_t2n field_simps)
      apply (meson less_exp objBitsKO_bounded2 of_nat_less_pow_32 word_gt_a_gt_0)
     using upbound
     apply (simp add:word_bits_def)
    apply (rule machine_word_plus_mono_right_split[where sz = sz])
     apply (rule less_le_trans[rotated -1])
      apply (rule range_cover.range_cover_compare_bound[OF cover'])
     apply (simp add: unat_minus_one[OF not_0'])
     using range_cover.unat_of_nat_n_shift[OF cover le_refl]
     apply (simp add:shiftl_t2n power_add field_simps)
    apply (simp add:range_cover_def word_bits_def)
    done
qed

lemma createObjects_orig_ko_wp_at2':
  "\<lbrace>\<lambda>s. range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0
      \<and> pspace_aligned' s \<and> pspace_distinct' s
      \<and> P (ko_wp_at' P' p s)
      \<and> (P' val \<longrightarrow> P True)
      \<and> pspace_no_overlap' ptr sz s\<rbrace>
  createObjects' ptr n val gbits \<lbrace>\<lambda>r s. P (ko_wp_at' P' p s)\<rbrace>"
   apply (simp add: createObjects'_def lookupAround2_pspace_no
                    alignError_def unless_def split_def del:fun_upd_apply)
   apply (rule hoare_grab_asm)+
   apply (subst new_cap_addrs_fold')
     apply (drule range_cover_not_zero_shift[rotated])
     apply (rule le_add2)
     apply (simp add:word_le_sub1 del:fun_upd_apply)+
   apply (rule hoare_pre)
    apply (wp|simp cong: if_cong del: data_map_insert_def fun_upd_apply)+
   apply (wpc|wp)+
   apply (clarsimp simp:valid_pspace'_def linorder_not_less simp del:fun_upd_apply)
   apply (subgoal_tac " range_cover ptr sz (objBitsKO val) (unat (of_nat n << gbits))")
    apply (subst data_map_insert_def[symmetric])+
    apply (subst retype_ko_wp_at',simp+)+
    apply clarsimp
   apply (cases "P' val")
    apply simp
   apply clarsimp
   apply (frule(1) subsetD [OF new_cap_addrs_subset])
   apply (drule(1) pspace_no_overlap_disjoint')
   apply (simp add:lookupAround2_None1)
   apply (intro conjI impI allI)
     apply (drule_tac x = p in spec)
     apply (erule impE)
      apply (erule(1) range_cover_new_cap_addrs_compare[rotated])
      apply simp
     apply (fastforce simp: ko_wp_at'_def)
   apply (drule_tac x = p in orthD1)
   apply (clarsimp simp:ptr_add_def p_assoc_help)
   apply (simp add:dom_def)
   apply (fastforce simp:ko_wp_at'_def)
  apply (rule range_cover_rel)
     apply (simp)+
  apply (subst mult.commute)
  apply (erule range_cover.unat_of_nat_n_shift)
  apply simp
  done


lemma createObjects_orig_obj_at2':
  "\<lbrace>\<lambda>s. n \<noteq> 0
      \<and> range_cover ptr sz (objBitsKO val + gbits) n
      \<and> pspace_aligned' s \<and> pspace_distinct' s
      \<and> P (obj_at' P' p s)
      \<and> \<not> (case_option False P' (projectKO_opt val))
      \<and> pspace_no_overlap' ptr sz s\<rbrace>
  createObjects' ptr n val gbits \<lbrace>\<lambda>r s. P (obj_at' P' p s)\<rbrace>"
  unfolding obj_at'_real_def
  by (wp createObjects_orig_ko_wp_at2') auto

lemma createObjects_orig_cte_wp_at2':
  "\<lbrace>\<lambda>s. P (cte_wp_at' P' p s)
      \<and> n \<noteq> 0
      \<and> range_cover ptr sz (objBitsKO val + gbits) n
      \<and> pspace_aligned' s \<and> pspace_distinct' s
      \<and> \<not> (case_option False P' (projectKO_opt val))
      \<and> (\<forall>(getF, setF) \<in> ran tcb_cte_cases.
              \<not> (case_option False (P' \<circ> getF) (projectKO_opt val)))
      \<and> pspace_no_overlap' ptr sz s\<rbrace>
  createObjects' ptr n val gbits \<lbrace>\<lambda>r s. P (cte_wp_at' P' p s)\<rbrace>"
  apply (simp add: cte_wp_at'_obj_at')
  apply (rule handy_prop_divs)
   apply (wp createObjects_orig_obj_at2'[where sz = sz], simp)
  apply (simp add: tcb_cte_cases_def)
  including no_pre
  apply (wp handy_prop_divs createObjects_orig_obj_at2'[where sz = sz]
             | simp add: o_def cong: option.case_cong)+
  done

lemma threadSet_cte_wp_at2'T:
  assumes "\<forall>tcb. \<forall>(getF, setF) \<in> ran tcb_cte_cases. getF (F tcb) = getF tcb"
  shows "\<lbrace>\<lambda>s. P (cte_wp_at' P' p s)\<rbrace> threadSet F t \<lbrace>\<lambda>rv s. P (cte_wp_at' P' p s)\<rbrace>"
  using assms by (rule threadSet_cte_wp_at'T)

lemmas threadSet_cte_wp_at2' =
  threadSet_cte_wp_at2'T [OF all_tcbI, OF ball_tcb_cte_casesI]

lemma createNewCaps_cte_wp_at2:
  "\<lbrace>\<lambda>s. P (cte_wp_at' P' p s) \<and> \<not> P' makeObject
      \<and> n \<noteq> 0
      \<and> range_cover ptr sz (APIType_capBits ty objsz) n
      \<and> pspace_aligned' s \<and> pspace_distinct' s
      \<and> pspace_no_overlap' ptr sz s\<rbrace>
     createNewCaps ty ptr n objsz dev
   \<lbrace>\<lambda>rv s. P (cte_wp_at' P' p s)\<rbrace>"
  including no_pre
  apply (simp add: createNewCaps_def createObjects_def ARM_H.toAPIType_def
           split del: if_split)
  apply (case_tac ty; simp add: createNewCaps_def createObjects_def Arch_createNewCaps_def
                           split del: if_split cong: if_cong)
        apply (rename_tac apiobject_type)
        apply (case_tac apiobject_type; simp split del: if_split)
            apply (rule hoare_pre, wp, simp add:createObjects_def)
           apply ((wp createObjects_orig_cte_wp_at2'[where sz = sz]
                     mapM_x_wp' threadSet_cte_wp_at2')+
                   | assumption
                   | clarsimp simp: APIType_capBits_def
                                    projectKOs projectKO_opts_defs
                                    makeObject_tcb tcb_cte_cases_def
                                    pageBits_def archObjSize_def ptBits_def
                                    pdBits_def createObjects_def curDomain_def
                                    Let_def objBits_if_dev
                         split del: if_split
                   | simp add: objBits_simps pteBits_def pdeBits_def)+
  done

lemma createObjects_orig_obj_at':
  "\<lbrace>\<lambda>s. n \<noteq> 0
      \<and> range_cover ptr sz (objBitsKO val + gbits) n
      \<and> pspace_aligned' s \<and> pspace_distinct' s
      \<and> obj_at' P p s
      \<and> pspace_no_overlap' ptr sz s\<rbrace>
  createObjects' ptr n val gbits \<lbrace>\<lambda>r. obj_at' P p\<rbrace>"
   apply (rule hoare_grab_asm)+
   apply (clarsimp simp: createObjects'_def)
   apply (subst new_cap_addrs_fold')
     apply (simp add:unat_1_0 unat_gt_0)
     apply (rule range_cover_not_zero_shift)
     apply simp+
    apply (wp|simp add:split_def cong: if_cong del: data_map_insert_def fun_upd_apply)+
   apply (wpc|wp|simp del: fun_upd_apply data_map_insert_def)+
   apply (simp only: alignError_def, wp)
  apply (subst data_map_insert_def[symmetric])+
  apply clarsimp
  apply (subgoal_tac "range_cover ptr sz (objBitsKO val) (unat (of_nat n << gbits))")
  apply (subst retype_obj_at',simp+)+
  apply (intro conjI impI allI)
    apply (clarsimp simp:obj_at'_real_def ko_wp_at'_def)
    apply (frule(1) subsetD [OF new_cap_addrs_subset])
    apply (drule(1) pspace_no_overlap_disjoint')
   apply (simp add:lookupAround2_None1)
     apply (drule_tac x = p in spec)
     apply (erule impE)
      apply (erule(1) range_cover_new_cap_addrs_compare[rotated])
       apply simp
     apply simp
  apply (frule(1) subsetD [OF new_cap_addrs_subset])
  apply (drule(1) pspace_no_overlap_disjoint')
   apply (drule_tac x = p in orthD1)
   apply (clarsimp simp:ptr_add_def p_assoc_help)
   apply (simp add:dom_def obj_at'_real_def ko_wp_at'_def)
  apply (rule range_cover_rel)
     apply (simp)+
  apply (subst mult.commute)
  apply (erule range_cover.unat_of_nat_n_shift)
  apply simp
  done

crunch ko_wp_at'[wp]: doMachineOp "\<lambda>s. P (ko_wp_at' P' p s)"

lemma createObjects_orig_cte_wp_at':
  "\<lbrace>\<lambda>s. range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0
      \<and> pspace_aligned' s \<and> pspace_distinct' s
      \<and> cte_wp_at' P p s
      \<and> pspace_no_overlap' ptr sz s\<rbrace>
  createObjects' ptr n val gbits \<lbrace>\<lambda>r s. cte_wp_at' P p s\<rbrace>"
  apply (simp add: cte_wp_at'_obj_at' tcb_cte_cases_def)
  apply (rule hoare_pre, wp hoare_vcg_disj_lift createObjects_orig_obj_at'[where sz = sz])
  apply clarsimp
  done

lemma createNewCaps_cte_wp_at':
  "\<lbrace>\<lambda>s. cte_wp_at' P p s
      \<and> range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0
      \<and> pspace_aligned' s \<and> pspace_distinct' s
      \<and> pspace_no_overlap' ptr sz s\<rbrace>
     createNewCaps ty ptr n us dev
   \<lbrace>\<lambda>rv. cte_wp_at' P p\<rbrace>"
  apply (simp add: createNewCaps_def ARM_H.toAPIType_def
              split del: if_split)
  apply (case_tac ty; simp add: Arch_createNewCaps_def
                           split del: if_split)
        apply (rename_tac apiobject_type)
        apply (case_tac apiobject_type; simp split del: if_split)
            apply (rule hoare_pre, wp, simp)
           apply (wp createObjects_orig_cte_wp_at'[where sz = sz] mapM_x_wp'
                     threadSet_cte_wp_at'T
                  | clarsimp simp: objBits_simps APIType_capBits_def createObjects_def curDomain_def
                    pageBits_def ptBits_def pdBits_def archObjSize_def pteBits_def pdeBits_def
                  | intro conjI impI
                  | force simp: tcb_cte_cases_def)+
  done

lemma createObjects_obj_at_other:
  assumes cover: "range_cover ptr sz (objBitsKO val + gbits) n"
  and     not_0: "n\<noteq> 0"
  shows  "\<lbrace>\<lambda>s. obj_at' P p s \<and> valid_pspace' s \<and> pspace_no_overlap' ptr sz s\<rbrace>
  createObjects ptr n val gbits \<lbrace>\<lambda>_. obj_at' P p\<rbrace>"
  apply (simp add: createObjects_def)
  apply (wp createObjects_orig_obj_at'[where sz = sz])
  using cover not_0
  apply (clarsimp simp: cover not_0 valid_pspace'_def pspace_no_overlap'_def)
  done

lemma valid_cap'_range_no_overlap:
  "\<lbrakk>untypedRange c \<inter> {ptr..(ptr && ~~ mask sz) + 2 ^ sz - 1} = {}; s \<turnstile>' c;
    valid_pspace' s; pspace_no_overlap' ptr sz s;
    range_cover ptr sz (objBitsKO val) n\<rbrakk>
   \<Longrightarrow> s\<lparr>ksPSpace := foldr (\<lambda>addr. data_map_insert addr val)
                           (new_cap_addrs n ptr val) (ksPSpace s)\<rparr> \<turnstile>' c"
  apply (cases c; simp add: valid_cap'_def cte_wp_at_obj_cases' valid_pspace'_def retype_obj_at_disj'
                       split: zombie_type.split_asm
                       del: Int_atLeastAtMost)[1]
  apply (rename_tac arch_capability)
  apply (case_tac arch_capability;
          simp add: retype_obj_at_disj' typ_at_to_obj_at_arches
                    page_table_at'_def page_directory_at'_def)
   apply (fastforce simp: typ_at_to_obj_at_arches retype_obj_at_disj')
  apply (rename_tac word nat1 nat2)
  apply (clarsimp simp:valid_untyped'_def retype_ko_wp_at'
        simp del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
        Int_atLeastAtMost atLeastatMost_empty_iff)
  apply (frule aligned_untypedRange_non_empty)
   apply (simp add:isCap_simps)
  apply (intro conjI impI)
   apply (intro allI)
   apply (drule_tac x = ptr' in spec)
   apply (rule ccontr)
   apply (clarsimp simp del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
                             Int_atLeastAtMost atLeastatMost_empty_iff)
   apply (erule disjE)
    apply (drule(2) disjoint_subset2 [OF obj_range'_subset])
    apply (drule(1) disjoint_subset2[OF psubset_imp_subset])
    apply (simp add: Int_absorb ptr_add_def p_assoc_help
                del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
                     Int_atLeastAtMost atLeastatMost_empty_iff)
   apply (drule(1) obj_range'_subset)
   apply (drule_tac A'=" {word + of_nat nat2..word + 2 ^ nat1 - 1}" in disjoint_subset[rotated])
    apply clarsimp
    apply (rule is_aligned_no_wrap')
     apply (fastforce simp:capAligned_def)
    apply (erule of_nat_less_pow_32)
    apply (simp add:capAligned_def)
   apply (drule(1) disjoint_subset2)
   apply blast
  apply (intro allI)
  apply (drule_tac x = ptr' in spec)
  apply (rule ccontr)
  apply (clarsimp simp del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
                            Int_atLeastAtMost atLeastatMost_empty_iff)
  apply (drule(2) disjoint_subset2 [OF obj_range'_subset])
  apply (drule(1) disjoint_subset2)
  apply (simp add: Int_absorb ptr_add_def p_assoc_help
              del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
                   Int_atLeastAtMost atLeastatMost_empty_iff)
  done

lemma createObjects_cte_wp_at':
  "\<lbrakk>range_cover ptr sz (objBitsKO val + gbits) n; n \<noteq> 0\<rbrakk>
  \<Longrightarrow>\<lbrace>\<lambda>s. cte_wp_at' P p s \<and> valid_pspace' s \<and> pspace_no_overlap' ptr sz s\<rbrace>
  createObjects' ptr n val gbits
  \<lbrace>\<lambda>_. cte_wp_at' P p\<rbrace>"
  apply (clarsimp simp: valid_def cte_wp_at_obj_cases')
  apply (erule disjE)
   apply (erule use_valid[OF _ ])
    apply (rule createObjects_orig_obj_at')
   apply fastforce
  apply clarsimp
  apply (drule_tac x = na in bspec)
   apply clarsimp
  apply clarsimp
  apply (drule use_valid[OF _ createObjects_orig_obj_at'])
   apply fastforce
  apply simp
  done

lemma createNewCaps_cte_wp_at:
  assumes cover: "range_cover ptr sz (APIType_capBits ty us) n"
  and not_0 : "n \<noteq> 0"
  shows "\<lbrace>\<lambda>s. cte_wp_at' P p s \<and> valid_pspace' s \<and> pspace_no_overlap' ptr sz s\<rbrace>
  createNewCaps ty ptr n us dev
  \<lbrace>\<lambda>_. cte_wp_at' P p\<rbrace>"
  apply (wp createNewCaps_cte_wp_at')
  apply (auto simp: cover not_0)
  done

lemma createObjects_ret2:
  "\<lbrace>(\<lambda>s. P (map (\<lambda>p. ptr_add y (p * 2 ^ (objBitsKO ko + gbits)))
                    [0..<n]))
        and K (n < 2 ^ word_bits \<and> n \<noteq> 0)\<rbrace>
      createObjects y n ko gbits \<lbrace>\<lambda>rv s. P rv\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (rule hoare_chain)
    apply (rule hoare_vcg_conj_lift)
     apply (rule createObjects_ret)
      apply simp+
    apply (rule hoare_vcg_prop)
   defer
   apply (clarsimp simp: power_add mult.commute mult.left_commute | assumption)+
  done

lemma state_refs_ko_wp_at_eq:
  "state_refs_of' s = (\<lambda>x. {r. ko_wp_at' (\<lambda>ko. r \<in> refs_of' ko) x s})"
  apply (rule ext)
  apply (simp add: state_refs_of'_def ko_wp_at'_def
            split: option.split)
  done

lemma createObjects_state_refs_of'':
  "\<lbrace>\<lambda>s. n \<noteq> 0
        \<and> range_cover ptr sz (objBitsKO val + gbits) n
        \<and> P (state_refs_of' s) \<and> refs_of' val = {}
        \<and> pspace_aligned' s \<and> pspace_distinct' s
        \<and> pspace_no_overlap' ptr sz s\<rbrace>
     createObjects' ptr n val gbits
   \<lbrace>\<lambda>rv s. P (state_refs_of' s)\<rbrace>"
   apply (clarsimp simp:valid_def lookupAround2_pspace_no state_refs_ko_wp_at_eq)
   apply (erule ssubst[where P = P,rotated])
   apply (rule ext)
   apply (rule set_eqI)
   apply clarsimp
   apply (intro iffI,rule ccontr)
     apply (drule_tac P1="\<lambda>x. \<not> x" in use_valid[OF _ createObjects_orig_ko_wp_at2'[where sz = sz]])
     apply simp
     apply (intro conjI)
     apply simp+
   apply (drule_tac P1="\<lambda>x. x" in use_valid[OF _ createObjects_orig_ko_wp_at2'[where sz = sz]])
     apply simp+
  done

crunch state_refs_of'[wp]: copyGlobalMappings "\<lambda>s. P (state_refs_of' s)"
  (wp: crunch_wps)

lemma createNewCaps_state_refs_of':
  assumes cover: "range_cover ptr sz (APIType_capBits ty us) n"
  and     not_0: "n \<noteq> 0"
  shows
  "\<lbrace>\<lambda>s. valid_pspace' s \<and> pspace_no_overlap' ptr sz s
        \<and> P (state_refs_of' s)\<rbrace>
     createNewCaps ty ptr n us dev
   \<lbrace>\<lambda>rv s. P (state_refs_of' s)\<rbrace>"
  unfolding createNewCaps_def
  apply (clarsimp simp: ARM_H.toAPIType_def
             split del: if_split)
  apply (cases ty; simp add: createNewCaps_def Arch_createNewCaps_def
                        split del: if_split)
        apply (rename_tac apiobject_type)
        apply (case_tac apiobject_type; simp split del: if_split)
            apply (rule hoare_pre, wp, simp)
           apply (insert cover not_0)
           apply (wp mapM_x_wp' createObjects_state_refs_of'' threadSet_state_refs_of'
                    | simp add: not_0 pspace_no_overlap'_def objBitsKO_def APIType_capBits_def
                                valid_pspace'_def makeObject_tcb makeObject_endpoint objBits_def
                                makeObject_notification pageBits_def ptBits_def pdBits_def
                                archObjSize_def createObjects_def curDomain_def
                                pdeBits_def pteBits_def
             | intro conjI impI)+
  done

lemma createObjects_iflive':
  "\<lbrace>\<lambda>s. if_live_then_nonz_cap' s \<and> \<not> live' val
        \<and> n \<noteq> 0
        \<and> range_cover ptr sz (objBitsKO val + gbits) n
        \<and> pspace_aligned' s \<and> pspace_distinct' s
        \<and> pspace_no_overlap' ptr sz s\<rbrace>
     createObjects' ptr n val gbits
   \<lbrace>\<lambda>rv s. if_live_then_nonz_cap' s\<rbrace>"
  apply (rule hoare_pre)
   apply (simp only: if_live_then_nonz_cap'_def
                     ex_nonz_cap_to'_def imp_conv_disj)
   apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift
             hoare_vcg_ex_lift createObjects_orig_ko_wp_at2'
             createObjects_orig_cte_wp_at')
  apply clarsimp
  apply (intro conjI allI impI)
  apply simp_all
  apply (rule ccontr)
  apply clarsimp
  apply (drule(1) if_live_then_nonz_capE')
  apply (fastforce simp: ex_nonz_cap_to'_def)
  done

crunch ksReadyQueues[wp]: copyGlobalMappings "\<lambda>s. P (ksReadyQueues s)"
  (wp: updateObject_default_inv crunch_wps)
crunch ksReadyQueuesL1[wp]: copyGlobalMappings "\<lambda>s. P (ksReadyQueuesL1Bitmap s)"
  (wp: updateObject_default_inv crunch_wps)
crunch ksReadyQueuesL2[wp]: copyGlobalMappings "\<lambda>s. P (ksReadyQueuesL2Bitmap s)"
  (wp: updateObject_default_inv crunch_wps)

crunch valid_idle'[wp]: copyGlobalMappings "valid_idle'"
  (simp: objBits_simps archObjSize_def
     wp: updateObject_default_inv crunch_wps setObject_idle' refl)

crunch iflive'[wp]: copyGlobalMappings "if_live_then_nonz_cap'"
  (wp: crunch_wps)

lemma createNewCaps_iflive'[wp]:
  assumes cover: "range_cover ptr sz (APIType_capBits ty us) n"
  and     not_0: "n \<noteq> 0"
  shows
  "\<lbrace>\<lambda>s. valid_pspace' s \<and> pspace_no_overlap' ptr sz s
        \<and> if_live_then_nonz_cap' s\<rbrace>
     createNewCaps ty ptr n us dev
   \<lbrace>\<lambda>rv s. if_live_then_nonz_cap' s\<rbrace>"
  unfolding createNewCaps_def
  apply (insert cover)
  apply (clarsimp simp: toAPIType_def ARM_H.toAPIType_def)
  apply (cases ty, simp_all add: createNewCaps_def Arch_createNewCaps_def
                      split del: if_split)
        apply (rename_tac apiobject_type)
        apply (case_tac apiobject_type, simp_all split del: if_split)[1]
            apply (rule hoare_pre, wp, simp)
           apply (wp mapM_x_wp' createObjects_iflive' threadSet_iflive'
                | simp add: not_0 pspace_no_overlap'_def createObjects_def
                                valid_pspace'_def makeObject_tcb makeObject_endpoint
                                 makeObject_notification objBitsKO_def
                                 APIType_capBits_def objBits_def pageBits_def
                                 archObjSize_def ptBits_def pdBits_def
                                 pteBits_def pdeBits_def
                                 curDomain_def split del:if_split
                | simp split: if_split
                | fastforce)+
  done

lemma createObjects_pspace_only:
  "\<lbrakk> \<And>f s. P (ksPSpace_update f s) = P s \<rbrakk>
   \<Longrightarrow> \<lbrace>P\<rbrace> createObjects' ptr n val gbits \<lbrace>\<lambda>rv. P\<rbrace>"
  apply (simp add: createObjects_def createObjects'_def unless_def alignError_def
                   split_def lookupAround2_pspace_no)
  apply wpsimp
  done

lemma createObjects'_qs[wp]:
  "\<lbrace>\<lambda>s. P (ksReadyQueues s)\<rbrace> createObjects' ptr n val gbits \<lbrace>\<lambda>rv s. P (ksReadyQueues s)\<rbrace>"
  by (rule createObjects_pspace_only, simp)

lemma createObjects'_qsL1[wp]:
  "\<lbrace>\<lambda>s. P (ksReadyQueuesL1Bitmap s)\<rbrace> createObjects' ptr n val gbits \<lbrace>\<lambda>rv s. P (ksReadyQueuesL1Bitmap s)\<rbrace>"
  by (rule createObjects_pspace_only, simp)

lemma createObjects'_qsL2[wp]:
  "\<lbrace>\<lambda>s. P (ksReadyQueuesL2Bitmap s)\<rbrace> createObjects' ptr n val gbits \<lbrace>\<lambda>rv s. P (ksReadyQueuesL2Bitmap s)\<rbrace>"
  by (rule createObjects_pspace_only, simp)

(* FIXME move these 2 to TcbAcc_R *)
lemma threadSet_qsL1[wp]:
  "\<lbrace>\<lambda>s. P (ksReadyQueuesL1Bitmap s)\<rbrace> threadSet f t \<lbrace>\<lambda>rv s. P (ksReadyQueuesL1Bitmap s)\<rbrace>"
  by (simp add: threadSet_def | wp updateObject_default_inv)+

lemma threadSet_qsL2[wp]:
  "\<lbrace>\<lambda>s. P (ksReadyQueuesL2Bitmap s)\<rbrace> threadSet f t \<lbrace>\<lambda>rv s. P (ksReadyQueuesL2Bitmap s)\<rbrace>"
  by (simp add: threadSet_def | wp updateObject_default_inv)+

crunches createObjects, createNewCaps
  for qs[wp]: "\<lambda>s. P (ksReadyQueues s)"
  and qsL1[wp]: "\<lambda>s. P (ksReadyQueuesL1Bitmap s)"
  and qsL2[wp]: "\<lambda>s. P (ksReadyQueuesL2Bitmap s)"
  (simp: crunch_simps wp: crunch_wps)

lemma sch_act_wf_lift_asm:
  assumes tcb: "\<And>P t. \<lbrace>st_tcb_at' P t and Q \<rbrace> f \<lbrace>\<lambda>rv. st_tcb_at' P t\<rbrace>"
  assumes tcbDomain: "\<And>P t. \<lbrace>obj_at' (\<lambda>tcb. P (tcbDomain tcb)) t and Q\<rbrace> f \<lbrace>\<lambda>rv. obj_at' (\<lambda>tcb. P (tcbDomain tcb)) t\<rbrace>"
  assumes kCT: "\<And>P. \<lbrace>\<lambda>s. P (ksCurThread s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksCurThread s)\<rbrace>"
  assumes kCD: "\<And>P. \<lbrace>\<lambda>s. P (ksCurDomain s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksCurDomain s)\<rbrace>"
  assumes ksA: "\<And>P. \<lbrace>\<lambda>s. P (ksSchedulerAction s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksSchedulerAction s)\<rbrace>"
  shows
  "\<lbrace>\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and> Q s\<rbrace>
  f
  \<lbrace>\<lambda>rv s. sch_act_wf (ksSchedulerAction s) s\<rbrace>"
  apply (clarsimp simp: valid_def)
  apply (frule use_valid [OF _ ksA])
   prefer 2
   apply assumption
  apply (frule_tac P1="(=) (ksCurThread s)" in use_valid [OF _ kCT])
   apply (rule refl)
  apply (frule_tac P1="(=) (ksCurDomain s)" in use_valid [OF _ kCD])
   apply (rule refl)
  apply (case_tac "ksSchedulerAction s")
    apply (simp add: ct_in_state'_def)
    apply (drule use_valid [OF _ tcb])
     apply simp
    apply simp
   apply simp
  apply (clarsimp simp: tcb_in_cur_domain'_def)
  apply (frule use_valid [OF _ tcb], fastforce)
  apply (frule use_valid [OF _ tcbDomain], fastforce)
  apply auto
  done

lemma valid_queues_lift_asm':
  assumes tat: "\<And>d p t. \<lbrace>\<lambda>s. \<not> obj_at' (inQ d p) t s \<and> Q d p s\<rbrace> f \<lbrace>\<lambda>_ s. \<not> obj_at' (inQ d p) t s\<rbrace>"
  and     prq: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueues s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueues s)\<rbrace>"
  shows   "\<lbrace>\<lambda>s. valid_queues' s \<and> (\<forall>d p. Q d p s)\<rbrace> f \<lbrace>\<lambda>_. valid_queues'\<rbrace>"
  apply (simp only: valid_queues'_def imp_conv_disj)
  apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift
            tat prq)
  apply simp
  done

lemma createObjects'_ct[wp]:
  "\<lbrace>\<lambda>s. P (ksCurThread s)\<rbrace> createObjects' p n v us \<lbrace>\<lambda>rv s. P (ksCurThread s)\<rbrace>"
  by (rule createObjects_pspace_only, simp)

crunches createObjects, doMachineOp, createNewCaps
  for ct[wp]: "\<lambda>s. P (ksCurThread s)"
  and ksCurDomain[wp]: "\<lambda>s. P (ksCurDomain s)"
  (wp: crunch_wps simp: crunch_simps)

lemma copyGlobalMappings_ko_wp_at:
  "\<lbrace>(\<lambda>s. P (ko_wp_at' P' p s)) and K (\<forall>pde_x :: pde. P' (injectKO pde_x) = v)\<rbrace>
     copyGlobalMappings pd
   \<lbrace>\<lambda>rv s. P (ko_wp_at' P' p s)\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (simp add: copyGlobalMappings_def storePDE_def)
  apply (wp mapM_x_wp' setObject_ko_wp_at)
      apply simp
     apply (simp add: objBits_simps archObjSize_def)
    apply (simp add: pdeBits_def)
   apply (simp cong: if_cong split del: if_split)
   apply (wp getObject_inv loadObject_default_inv | simp split del: if_split)+
   apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs)
  apply (wp | simp)+
  done

lemma threadSet_ko_wp_at2':
  "\<lbrace>\<lambda>s. P (ko_wp_at' P' p s) \<and> (\<forall>tcb_x :: tcb. P' (injectKO (F tcb_x)) = P' (injectKO tcb_x))\<rbrace>
     threadSet F ptr
   \<lbrace>\<lambda>_ s. P (ko_wp_at' P' p s)\<rbrace>"
apply (simp add: threadSet_def split del: if_split)
apply (wp setObject_ko_wp_at getObject_tcb_wp | simp add: objBits_simps')+
apply (auto simp: ko_wp_at'_def obj_at'_def projectKOs)
done

lemma threadSet_ko_wp_at2'_futz:
  "\<lbrace>\<lambda>s. P (ko_wp_at' P' p s) \<and> obj_at' Q ptr s
         \<and> (\<forall>tcb_x :: tcb. Q tcb_x \<longrightarrow> P' (injectKO (F tcb_x)) = P' (injectKO tcb_x))\<rbrace>
     threadSet F ptr
   \<lbrace>\<lambda>_ s. P (ko_wp_at' P' p s)\<rbrace>"
apply (simp add: threadSet_def split del: if_split)
apply (wp setObject_ko_wp_at getObject_tcb_wp | simp add: objBits_simps')+
apply (auto simp: ko_wp_at'_def obj_at'_def projectKOs)
done

lemma mapM_x_threadSet_createNewCaps_futz:
  "\<lbrace>\<lambda>s. P (ko_wp_at' P' p s) \<and> (\<forall>addr\<in>set addrs. obj_at' (\<lambda>tcb. \<not>tcbQueued tcb \<and> tcbState tcb = Inactive) addr s)
         \<and> (\<forall>tcb_x :: tcb. tcbQueued (F tcb_x) = tcbQueued tcb_x \<and> tcbState (F tcb_x) = tcbState tcb_x)
         \<and> (\<forall>tcb_x :: tcb. \<not> tcbQueued tcb_x \<and> tcbState tcb_x = Inactive \<longrightarrow> P' (injectKO (F tcb_x)) = P' (injectKO tcb_x))\<rbrace>
     mapM_x (threadSet F) addrs
   \<lbrace>\<lambda>_ s. P (ko_wp_at' P' p s)\<rbrace>" (is "\<lbrace>?PRE\<rbrace> _ \<lbrace>\<lambda>_. ?POST\<rbrace>")
  apply (rule mapM_x_inv_wp[where P="?PRE"])
    apply simp
   apply (rule hoare_pre)
   apply (wp hoare_vcg_ball_lift threadSet_ko_wp_at2'[where P="id", simplified]
      | wp (once) threadSet_ko_wp_at2'_futz[where Q="\<lambda>tcb. \<not>tcbQueued tcb \<and> tcbState tcb = Inactive"]
      | simp)+
  done

lemma createObjects_makeObject_not_tcbQueued:
  assumes "range_cover ptr sz (objBitsKO tcb) n"
  assumes "n \<noteq> 0" "tcb = injectKO (makeObject::tcb)"
  shows "\<lbrace>\<lambda>s. pspace_no_overlap' ptr sz s \<and> pspace_aligned' s \<and> pspace_distinct' s\<rbrace>
           createObjects ptr n tcb 0
         \<lbrace>\<lambda>rv s. \<forall>addr\<in>set rv. obj_at' (\<lambda>tcb. \<not> tcbQueued tcb \<and> tcbState tcb = Structures_H.thread_state.Inactive) addr s\<rbrace>"
  apply (rule hoare_strengthen_post[OF createObjects_ko_at_strg[where 'a=tcb]])
  using assms
  apply (auto simp: obj_at'_def projectKO_opt_tcb objBitsKO_def
                    objBits_def makeObject_tcb)
  done

lemma createObjects_ko_wp_at2:
  "\<lbrace>\<lambda>s. range_cover ptr sz (objBitsKO ko + gbits) n \<and> n \<noteq> 0
      \<and> pspace_aligned' s \<and> pspace_distinct' s
      \<and> P (ko_wp_at' P' p s)
      \<and> (P' ko \<longrightarrow> P True)
      \<and> pspace_no_overlap' ptr sz s\<rbrace>
    createObjects ptr n ko gbits
   \<lbrace>\<lambda>_ s. P (ko_wp_at' P' p s)\<rbrace>"
apply (simp add: createObjects_def)
apply (wp createObjects_orig_ko_wp_at2')
apply auto
done

lemma createNewCaps_ko_wp_atQ':
  "\<lbrace>(\<lambda>s. P (ko_wp_at' P' p s)
       \<and> range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0
       \<and> pspace_aligned' s \<and> pspace_distinct' s
       \<and> pspace_no_overlap' ptr sz s)
       and K (\<forall>pde_x :: pde. P' (injectKO pde_x)
                   \<longrightarrow> (\<forall>pde_y :: pde. P' (injectKO pde_y)))
       and K (\<forall>d (tcb_x :: tcb). \<not>tcbQueued tcb_x \<and> tcbState tcb_x = Inactive
                   \<longrightarrow> P' (injectKO (tcb_x \<lparr> tcbDomain := d \<rparr>)) = P' (injectKO tcb_x))
       and K (\<forall>v. makeObjectKO d (Inr ty) = Some v
                 \<longrightarrow> P' v \<longrightarrow> P True)\<rbrace>
     createNewCaps ty ptr n us d
   \<lbrace>\<lambda>rv s. P (ko_wp_at' P' p s)\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply (clarsimp simp: createNewCaps_def ARM_H.toAPIType_def
             split del: if_split)
  apply (cases ty, simp_all add: Arch_createNewCaps_def
                      split del: if_split)
        apply (rename_tac apiobject_type)
        apply (case_tac apiobject_type, simp_all split del: if_split)[1]
            apply (rule hoare_pre, wp, simp)
           apply ((wp mapM_x_threadSet_createNewCaps_futz
                     mapM_x_wp'
                     createObjects_obj_at
                     createObjects_ko_wp_at2 createObjects_makeObject_not_tcbQueued
                     copyGlobalMappings_ko_wp_at[where v="\<forall>pde :: pde. P' (injectKO pde)"]
                   | simp add: makeObjectKO_def objBitsKO_def archObjSize_def APIType_capBits_def
                               objBits_def pageBits_def pdBits_def ptBits_def curDomain_def
                               pteBits_def pdeBits_def
                          split del: if_split
                   | split if_split_asm[where Q=d]
                   | intro conjI impI | fastforce)+)
  done


lemmas createNewCaps_ko_wp_at'
    = createNewCaps_ko_wp_atQ'[simplified, unfolded fold_K]

lemmas createNewCaps_obj_at2 =
   createNewCaps_ko_wp_at'
      [where P'="\<lambda>ko. \<exists>obj :: ('a :: pspace_storable).
                   projectKO_opt ko = Some obj \<and> P' obj" for P',
       folded obj_at'_real_def,
       unfolded pred_conj_def, simplified]

lemma createNewCaps_obj_at'':
  "\<lbrace>\<lambda>s. obj_at' (P :: ('a :: pspace_storable) \<Rightarrow> bool) p s
       \<and> range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0
       \<and> pspace_aligned' s \<and> pspace_distinct' s
       \<and> pspace_no_overlap' ptr sz s
       \<and> (koType(TYPE('a)) = koType(TYPE(pde))
               \<longrightarrow> (\<forall>x. P x)
                \<and> (\<forall>pde :: pde. \<exists>x :: 'a. injectKO x = injectKO pde))
       \<and> (\<forall>tcb d. \<not>tcbQueued tcb \<and> tcbState tcb = Inactive \<longrightarrow> ((\<exists>obj :: 'a. injectKOS obj = KOTCB (tcb\<lparr>tcbDomain := d\<rparr>) \<and> P obj) \<longleftrightarrow> (\<exists>obj :: 'a. injectKOS obj = KOTCB tcb \<and> P obj)))\<rbrace>
     createNewCaps ty ptr n us d
   \<lbrace>\<lambda>rv s. obj_at' P p s\<rbrace>"
  apply (simp add: obj_at'_real_def)
  apply (wp createNewCaps_ko_wp_at')
  apply clarsimp
  apply (intro conjI impI)
    apply simp+
    apply clarsimp
  apply (clarsimp simp: projectKOs dest!: iffD1 [OF project_koType, OF exI])
  apply (clarsimp simp:project_inject)+
done

lemma createNewCaps_obj_at':
  "\<lbrace>\<lambda>s. obj_at' (P :: ('a :: pspace_storable) \<Rightarrow> bool) p s
       \<and> range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0
       \<and> pspace_aligned' s \<and> pspace_distinct' s
       \<and> pspace_no_overlap' ptr sz s
       \<and> koType(TYPE('a)) \<noteq> koType(TYPE(pde))
       \<and> (\<forall>tcb d. \<not>tcbQueued tcb \<and> tcbState tcb = Inactive \<longrightarrow> ((\<exists>obj :: 'a. injectKOS obj = KOTCB (tcb\<lparr>tcbDomain := d\<rparr>) \<and> P obj) \<longleftrightarrow> (\<exists>obj :: 'a. injectKOS obj = KOTCB tcb \<and> P obj)))\<rbrace>
     createNewCaps ty ptr n us d
   \<lbrace>\<lambda>rv s. obj_at' P p s\<rbrace>"
  by (wp createNewCaps_obj_at'', auto)

lemmas createNewCaps_pred_tcb_at'
     = createNewCaps_obj_at'[where P="\<lambda>ko. (Q :: 'a :: type \<Rightarrow> bool) (proj (tcb_to_itcb' ko))" for Q proj,
                             folded pred_tcb_at'_def, simplified]

lemma createNewCaps_cur:
  "\<lbrakk>range_cover ptr sz (APIType_capBits ty us) n ; n \<noteq> 0\<rbrakk> \<Longrightarrow>
   \<lbrace>\<lambda>s. valid_pspace' s \<and>
        pspace_no_overlap' ptr sz s \<and>
        cur_tcb' s\<rbrace>
      createNewCaps ty ptr n us d
   \<lbrace>\<lambda>rv. cur_tcb'\<rbrace>"
  apply (rule hoare_post_imp [where Q="\<lambda>rv s. \<exists>t. ksCurThread s = t \<and> tcb_at' t s"])
   apply (simp add: cur_tcb'_def)
  apply (wp hoare_vcg_ex_lift createNewCaps_obj_at')
  apply (clarsimp simp: pspace_no_overlap'_def cur_tcb'_def valid_pspace'_def)
  apply auto
  done

crunch ksInterrupt[wp]: createNewCaps "\<lambda>s. P (ksInterruptState s)"
  (simp: crunch_simps unless_def
     wp: setObject_ksInterrupt updateObject_default_inv crunch_wps)

lemma createNewCaps_ifunsafe':
  "\<lbrace>\<lambda>s. valid_pspace' s \<and>
        pspace_no_overlap' ptr sz s \<and>
        range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0 \<and>
        if_unsafe_then_cap' s\<rbrace>
      createNewCaps ty ptr n us d
   \<lbrace>\<lambda>rv s. if_unsafe_then_cap' s\<rbrace>"
  apply (simp only: if_unsafe_then_cap'_def ex_cte_cap_to'_def
                    imp_conv_disj)
  apply (rule hoare_pre)
   apply (rule hoare_use_eq_irq_node' [OF createNewCaps_ksInterrupt])
   apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift
             createNewCaps_cte_wp_at2 hoare_vcg_ex_lift)
  apply (simp add: makeObject_cte pspace_no_overlap'_def
                   valid_pspace'_def)
  apply auto
  done

lemma createObjects_nosch'[wp]:
  "\<lbrace>\<lambda>s. P (ksSchedulerAction s)\<rbrace>
     createObjects' ptr n val gbits
   \<lbrace>\<lambda>rv s. P (ksSchedulerAction s)\<rbrace>"
  by (rule createObjects_pspace_only, simp)

crunches copyGlobalMappings, createObjects, createNewCaps
  for nosch[wp]: "\<lambda>s. P (ksSchedulerAction s)"
  and it[wp]: "\<lambda>s. P (ksIdleThread s)"
  (wp: setObject_ksPSpace_only updateObject_default_inv mapM_x_wp')

lemma createObjects_idle':
  "\<lbrace>valid_idle' and valid_pspace' and pspace_no_overlap' ptr sz
        and (\<lambda>s. \<not> case_option False (\<lambda>cte. ksIdleThread s \<in> capRange (cteCap cte))
                        (projectKO_opt val)
               \<and> (\<forall>(getF, setF) \<in> ran tcb_cte_cases.
                 \<not> case_option False (\<lambda>tcb. ksIdleThread s \<in> capRange (cteCap (getF tcb)))
                        (projectKO_opt val)))
        and K (range_cover ptr sz (objBitsKO val + gbits) n  \<and> n \<noteq> 0)\<rbrace>
  createObjects' ptr n val gbits
  \<lbrace>\<lambda>rv. valid_idle'\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (rule hoare_pre)
   apply (clarsimp simp add: valid_idle'_def pred_tcb_at'_def)
   apply (rule hoare_vcg_conj_lift)
    apply (rule hoare_as_subst [OF createObjects'_it])
    apply (wp createObjects_orig_obj_at'
              createObjects_orig_cte_wp_at2'
              hoare_vcg_all_lift | simp)+
  apply (clarsimp simp: valid_idle'_def projectKOs o_def
                        pred_tcb_at'_def valid_pspace'_def
                  cong: option.case_cong)
  apply auto
  done

lemma createNewCaps_idle'[wp]:
  "\<lbrace>valid_idle' and valid_pspace' and pspace_no_overlap' ptr sz
       and K (range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0)\<rbrace>
   createNewCaps ty ptr n us d
   \<lbrace>\<lambda>rv. valid_idle'\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (clarsimp simp: createNewCaps_def ARM_H.toAPIType_def
             split del: if_split)
  apply (cases ty, simp_all add: Arch_createNewCaps_def
                      split del: if_split)
         apply (rename_tac apiobject_type)
         apply (case_tac apiobject_type, simp_all split del: if_split)[1]
             apply (wp, simp)
           including no_pre
           apply (wp mapM_x_wp'
                     createObjects_idle'
                     threadSet_idle'
                   | simp add: projectKO_opt_tcb projectKO_opt_cte
                               makeObject_cte makeObject_tcb archObjSize_def
                               tcb_cte_cases_def objBitsKO_def APIType_capBits_def
                               ptBits_def pdBits_def pageBits_def objBits_def
                               createObjects_def pteBits_def pdeBits_def
                   | intro conjI impI
                   | fastforce simp: curDomain_def)+
  done

crunch ksArch[wp]: createNewCaps "\<lambda>s. P (ksArchState s)"
  (simp: crunch_simps unless_def wp: crunch_wps)
crunch it[wp]: createNewCaps "\<lambda>s. P (ksIdleThread s)"
  (simp: crunch_simps unless_def wp: crunch_wps updateObject_default_inv)
crunch gsMaxObjectSize[wp]: createNewCaps "\<lambda>s. P (gsMaxObjectSize s)"
  (simp: crunch_simps unless_def wp: crunch_wps updateObject_default_inv)

lemma createNewCaps_global_refs':
  "\<lbrace>\<lambda>s. range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0
       \<and> pspace_aligned' s \<and> pspace_distinct' s
       \<and> pspace_no_overlap' ptr sz s \<and> valid_global_refs' s
       \<and> 0 < gsMaxObjectSize s\<rbrace>
     createNewCaps ty ptr n us d
   \<lbrace>\<lambda>rv. valid_global_refs'\<rbrace>"
  apply (simp add: valid_global_refs'_def valid_cap_sizes'_def valid_refs'_def)
  apply (rule_tac Q="\<lambda>rv s. \<forall>ptr. \<not> cte_wp_at' (\<lambda>cte. (kernel_data_refs \<inter> capRange (cteCap cte) \<noteq> {}
        \<or> 2 ^ capBits (cteCap cte) > gsMaxObjectSize s)) ptr s \<and> global_refs' s \<subseteq> kernel_data_refs"
                 in hoare_post_imp)
   apply (auto simp: cte_wp_at_ctes_of linorder_not_less elim!: ranE)[1]
  apply (rule hoare_pre)
   apply (simp add: global_refs'_def)
   apply (rule hoare_use_eq [where f=ksArchState, OF createNewCaps_ksArch])
   apply (rule hoare_use_eq [where f=ksIdleThread, OF createNewCaps_it])
   apply (rule hoare_use_eq [where f=irq_node', OF createNewCaps_ksInterrupt])
   apply (rule hoare_use_eq [where f=gsMaxObjectSize], wp)
   apply (wp hoare_vcg_all_lift createNewCaps_cte_wp_at2[where sz=sz])
  apply (clarsimp simp: cte_wp_at_ctes_of global_refs'_def
                        makeObject_cte)
  apply (auto simp: linorder_not_less ball_ran_eq)
  done

lemma koTypeOf_eq_UserDataT:
  "(koTypeOf ko = UserDataT)
        = (ko = KOUserData)"
  by (cases ko, simp_all)

lemma createNewCaps_valid_arch_state:
  "\<lbrace>(\<lambda>s. valid_arch_state' s \<and> valid_pspace' s \<and> pspace_no_overlap' ptr sz s
        \<and> (tp = APIObjectType ArchTypes_H.CapTableObject \<longrightarrow> us > 0))
       and K (range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0)\<rbrace>
     createNewCaps ty ptr n us d
   \<lbrace>\<lambda>rv. valid_arch_state'\<rbrace>"
  apply (simp add: valid_arch_state'_def
                   valid_asid_table'_def
                   valid_global_pts'_def
                   page_table_at'_def
                   page_directory_at'_def
                   typ_at_to_obj_at_arches)
  apply (rule hoare_pre)
   apply (rule hoare_use_eq [where f=ksArchState, OF createNewCaps_ksArch])
   apply (wp hoare_vcg_const_Ball_lift
             hoare_vcg_prop
             createNewCaps_obj_at''
             createNewCaps_ko_wp_at'
             hoare_vcg_all_lift
             hoare_vcg_const_imp_lift)
  apply (clarsimp simp: valid_pspace'_def o_def)
  apply (intro conjI)
  apply auto
  done

lemma valid_irq_node_lift_asm:
  assumes x: "\<And>P. \<lbrace>\<lambda>s. P (irq_node' s)\<rbrace> f \<lbrace>\<lambda>rv s. P (irq_node' s)\<rbrace>"
  assumes y: "\<And>p. \<lbrace>real_cte_at' p and Q\<rbrace> f \<lbrace>\<lambda>rv. real_cte_at' p\<rbrace>"
  shows      "\<lbrace>\<lambda>s. valid_irq_node' (irq_node' s) s \<and> Q s\<rbrace> f \<lbrace>\<lambda>rv s. valid_irq_node' (irq_node' s) s\<rbrace>"
  apply (simp add: valid_irq_node'_def)
  apply (rule hoare_pre)
   apply (rule hoare_use_eq_irq_node' [OF x])
   apply (wp hoare_vcg_all_lift y)
  apply simp
  done

lemma valid_irq_handlers_cte_wp_at_form':
  "valid_irq_handlers' = (\<lambda>s. \<forall>irq. irq_issued' irq s \<or>
                               (\<forall>p. \<not> cte_wp_at' (\<lambda>cte. cteCap cte = IRQHandlerCap irq) p s))"
  by (auto simp: valid_irq_handlers'_def cteCaps_of_def cte_wp_at_ctes_of
                 fun_eq_iff ran_def)

lemma createNewCaps_irq_handlers':
  "\<lbrace>valid_irq_handlers' and pspace_no_overlap' ptr sz
       and pspace_aligned' and pspace_distinct'
       and K (range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0)\<rbrace>
     createNewCaps ty ptr n us d
   \<lbrace>\<lambda>rv. valid_irq_handlers'\<rbrace>"
  apply (simp add: valid_irq_handlers_cte_wp_at_form' irq_issued'_def)
   apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift
             createNewCaps_cte_wp_at2)
  apply (clarsimp simp: makeObject_cte)
  apply auto
  done

lemma valid_pde_mappings'_def3:
  "valid_pde_mappings' =
     (\<lambda>s. \<forall>x. \<not> obj_at' (Not \<circ> valid_pde_mapping' (x && mask pdBits)) x s)"
  apply (simp add: valid_pde_mappings'_def)
  apply (rule ext, rule iff_allI)
  apply (auto simp: obj_at'_def projectKOs)
  done

lemma createObjects'_pde_mappings'[wp]:
  "\<lbrace>\<lambda>s. valid_pde_mappings' s \<and> range_cover ptr sz (objBitsKO val + gbits) n  \<and> n \<noteq> 0
            \<and> pspace_aligned' s \<and> pspace_distinct' s
            \<and> pspace_no_overlap' ptr sz s
            \<and> (\<forall>pde. projectKO_opt val = Some pde \<longrightarrow> pde = InvalidPDE)\<rbrace>
       createObjects' ptr n val gbits
   \<lbrace>\<lambda>_. valid_pde_mappings'\<rbrace>"
  apply (simp only: valid_pde_mappings'_def3 all_simps(1)[symmetric])
  apply (rule hoare_vcg_all_lift)
  apply (wp createObjects_orig_obj_at2')
  apply (clarsimp simp: projectKO_opt_pde o_def
                 split: Structures_H.kernel_object.split_asm
                        arch_kernel_object.split_asm)
  apply auto
  done

lemma createObjects_pde_mappings'[wp]:
  "\<lbrace>\<lambda>s. valid_pde_mappings' s \<and> range_cover ptr sz (objBitsKO ko + gbits) n  \<and> n \<noteq> 0
            \<and> pspace_aligned' s \<and> pspace_distinct' s
            \<and> pspace_no_overlap' ptr sz s
            \<and> (\<forall>pde. projectKO_opt ko = Some pde \<longrightarrow> pde = InvalidPDE)\<rbrace>
       createObjects ptr n ko gbits
   \<lbrace>\<lambda>_. valid_pde_mappings'\<rbrace>"
  by (simp add: createObjects_def objBits_def | intro conjI | wp | clarsimp)+

lemma getObject_valid_pde_mapping':
  "\<lbrace>valid_pde_mappings' and K (p && mask pdBits = p')\<rbrace> getObject p \<lbrace>\<lambda>pde s. valid_pde_mapping' p' pde\<rbrace>"
  apply (wp getPDE_wp)
  apply (clarsimp simp: valid_pde_mappings'_def)
  done

lemma copyGlobalMappings_pde_mappings':
  "\<lbrace>valid_pde_mappings' and (\<lambda>s. is_aligned (armKSGlobalPD (ksArchState s)) pdBits)
        and K (is_aligned pd pdBits)\<rbrace> copyGlobalMappings pd \<lbrace>\<lambda>rv. valid_pde_mappings'\<rbrace>"
  apply (simp add: copyGlobalMappings_def objBits_simps archObjSize_def)
  apply wp
   apply (rule_tac P="is_aligned globalPD pdBits \<and> is_aligned pd pdBits"
                in hoare_gen_asm)
   apply (rule mapM_x_wp[where S="{x. x < 2 ^ (pdBits - 2)}"])
    apply (wp getObject_valid_pde_mapping' | simp)+
     apply clarsimp
     apply (drule(1) is_aligned_add_helper[OF _ shiftl_less_t2n])
      apply (simp add: pdBits_def pageBits_def pdeBits_def)
     apply (drule(1) is_aligned_add_helper[OF _ shiftl_less_t2n])
      apply (simp add: pdBits_def pageBits_def pdeBits_def)
     apply (simp add: pdeBits_def)
    apply simp
   apply (clarsimp simp: pdBits_def pdeBits_def le_less_trans)
  apply wp
  apply clarsimp
  done

lemma mapM_x_copyGlobalMappings_pde_mappings':
  "\<lbrace>valid_pde_mappings' and (\<lambda>s. is_aligned (armKSGlobalPD (ksArchState s)) pdBits)
        and K (\<forall>x \<in> set xs. is_aligned x pdBits)\<rbrace>
      mapM_x copyGlobalMappings xs \<lbrace>\<lambda>rv. valid_pde_mappings'\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (rule hoare_strengthen_post)
   apply (rule mapM_x_wp [OF _ subset_refl])
   apply (wp copyGlobalMappings_pde_mappings' | simp)+
  done

lemma createNewCaps_pde_mappings'[wp]:
  "\<lbrace>\<lambda>s. valid_pde_mappings' s \<and> range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0
            \<and> valid_arch_state' s
            \<and> pspace_aligned' s \<and> pspace_distinct' s
            \<and> pspace_no_overlap' ptr sz s\<rbrace>
       createNewCaps ty ptr n us d
   \<lbrace>\<lambda>_. valid_pde_mappings'\<rbrace>"
  apply (simp add: createNewCaps_def Arch_createNewCaps_def Let_def
              split del: if_split cong: option.case_cong
                                        object_type.case_cong)
  apply (rule hoare_pre)
   apply (wp mapM_x_copyGlobalMappings_pde_mappings' | wpc
         | simp split del: if_split)+
    apply (rule_tac P="range_cover ptr sz (APIType_capBits ty us) n \<and> n\<noteq> 0" in hoare_gen_asm)
    apply (rule hoare_strengthen_post)
     apply (rule createObjects_aligned, simp+)
        apply (simp add: objBits_simps pdBits_def pageBits_def archObjSize_def APIType_capBits_def
                         range_cover_def pdeBits_def)
       apply (rule range_cover.range_cover_n_less[where 'a=32, folded word_bits_def],fastforce+)
     apply (simp add: objBits_simps pdBits_def pageBits_def archObjSize_def APIType_capBits_def range_cover_def word_bits_def
                      pteBits_def pdeBits_def)+
   apply (wp mapM_x_wp[OF _ subset_refl] | wpc | simp add: curDomain_def)+
  apply (clarsimp simp: projectKOs)
  apply (simp add: objBits_simps pdBits_def pageBits_def archObjSize_def APIType_capBits_def)
  apply (case_tac ty; simp)
        apply (rename_tac apiobject_type)
        apply (case_tac apiobject_type)
  apply (auto simp: ARM_H.toAPIType_def objBits_simps ptBits_def pageBits_def pteBits_def pdeBits_def
                    makeObject_pde valid_arch_state'_def pdBits_def page_directory_at'_def)
  done

lemma createObjects'_irq_states' [wp]:
  "\<lbrace>valid_irq_states'\<rbrace> createObjects' a b c d \<lbrace>\<lambda>_. valid_irq_states'\<rbrace>"
  apply (simp add: createObjects'_def split_def)
  apply (wp hoare_unless_wp|wpc|simp add: alignError_def)+
  apply fastforce
  done

crunch irq_states' [wp]: createNewCaps valid_irq_states'
  (wp: crunch_wps no_irq no_irq_clearMemory simp: crunch_simps unless_def)

crunch ksMachine[wp]: createObjects "\<lambda>s. P (ksMachineState s)"
  (simp: crunch_simps unless_def)
crunch cur_domain[wp]: createObjects "\<lambda>s. P (ksCurDomain s)"
  (simp: unless_def)

lemma createNewCaps_valid_queues':
  "\<lbrace>valid_queues' and pspace_no_overlap' ptr sz
       and pspace_aligned' and pspace_distinct'
       and K (range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0)\<rbrace>
     createNewCaps ty ptr n us d
   \<lbrace>\<lambda>rv. valid_queues'\<rbrace>"
  apply (wp valid_queues_lift_asm' [OF createNewCaps_obj_at2])
  apply (clarsimp simp: projectKOs)
  apply (simp add: makeObjectKO_def
            split: object_type.split_asm
                   apiobject_type.split_asm)
  apply (clarsimp simp: inQ_def)
  apply (auto simp: makeObject_tcb
             split: object_type.splits apiobject_type.splits)
  done

lemma createNewCaps_valid_queues:
  "\<lbrace>valid_queues and pspace_no_overlap' ptr sz
       and pspace_aligned' and pspace_distinct'
       and K (range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0)\<rbrace>
     createNewCaps ty ptr n us d
   \<lbrace>\<lambda>rv. valid_queues\<rbrace>"
apply (rule hoare_gen_asm)
apply (wp valid_queues_lift_asm createNewCaps_obj_at2[where sz=sz])
apply (clarsimp simp: projectKO_opts_defs)
apply (simp add: inQ_def)
apply (wp createNewCaps_pred_tcb_at'[where sz=sz] | simp)+
done

lemma mapM_x_threadSet_valid_pspace:
  "\<lbrace>valid_pspace' and K (curdom \<le> maxDomain)\<rbrace>
    mapM_x (threadSet (tcbDomain_update (\<lambda>_. curdom))) addrs \<lbrace>\<lambda>y. valid_pspace'\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (wp mapM_x_wp' threadSet_valid_pspace')
  apply simp_all
  done

lemma createNewCaps_valid_pspace:
  assumes  not_0: "n \<noteq> 0"
  and      cover: "range_cover ptr sz (APIType_capBits ty us) n"
  shows "\<lbrace>\<lambda>s. pspace_no_overlap' ptr sz s \<and> valid_pspace' s
  \<and> caps_no_overlap'' ptr sz s \<and> ptr \<noteq> 0 \<and> caps_overlap_reserved' {ptr..ptr + of_nat n * 2^(APIType_capBits ty us) - 1} s \<and> ksCurDomain s \<le> maxDomain\<rbrace>
  createNewCaps ty ptr n us dev \<lbrace>\<lambda>r. valid_pspace'\<rbrace>"
  unfolding createNewCaps_def Arch_createNewCaps_def
  using valid_obj_makeObject_rules
  apply (clarsimp simp: ARM_H.toAPIType_def
             split del: if_split cong: option.case_cong)
  apply (cases ty, simp_all split del: if_split)
        apply (rename_tac apiobject_type)
        apply (case_tac apiobject_type, simp_all split del: if_split)
            apply (rule hoare_pre, wp, clarsimp)
           apply (insert cover)
           apply (wp createObjects_valid_pspace_untyped' [OF _ not_0 , where ty="Inr ty" and sz = sz]
                     mapM_x_threadSet_valid_pspace mapM_x_wp'
                 | simp add: makeObjectKO_def archObjSize_def APIType_capBits_def
                             objBits_simps pageBits_def pdBits_def ptBits_def not_0
                             createObjects_def curDomain_def
                             pteBits_def pdeBits_def
                 | intro conjI impI
                 | simp add: power_add field_simps)+
done

lemma copyGlobalMappings_inv[wp]:
  "\<lbrace>\<lambda>s. P (ksMachineState s)\<rbrace>
    copyGlobalMappings newPD
   \<lbrace>\<lambda>_ s. P (ksMachineState s)\<rbrace>"
  by (simp add: copyGlobalMappings_def storePDE_def split_def
      | wp mapM_x_wp_inv setObject_ksMachine updateObject_default_inv)+

lemma doMachineOp_return_foo:
  "doMachineOp (do x\<leftarrow>a;return () od) = (do (doMachineOp a); return () od)"
  apply (clarsimp simp: doMachineOp_def bind_def gets_def
                        get_def return_def select_f_def split_def simpler_modify_def)
  apply (rule ext)+
  apply simp
  apply (rule set_eqI)
  apply clarsimp
  done

lemma doMachineOp_mapM_x_wp:
  assumes empty_fail:"\<And>x. empty_fail (f x)"
  assumes valid: "\<And>z. \<lbrace>P\<rbrace> doMachineOp (f z) \<lbrace>\<lambda>y. P\<rbrace>"
  shows "\<lbrace>P\<rbrace> doMachineOp (mapM_x f xs) \<lbrace>\<lambda>y. P\<rbrace>"
  apply (clarsimp simp: mapM_x_mapM doMachineOp_return_foo)
  apply (subst doMachineOp_mapM)
  apply (wp valid empty_fail mapM_wp' | simp)+
  done


lemma createNewCaps_vms:
  "\<lbrace>pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz and
    K (range_cover ptr sz (APIType_capBits ty us) n \<and> 0 < n) and
    valid_machine_state'\<rbrace>
   createNewCaps ty ptr n us dev
   \<lbrace>\<lambda>archCaps. valid_machine_state'\<rbrace>"
  apply (clarsimp simp: valid_machine_state'_def pointerInDeviceData_def
                        Arch_createNewCaps_def createNewCaps_def pointerInUserData_def
                        typ_at'_def createObjects_def doMachineOp_return_foo
                  split del: if_split)
  apply (rule hoare_pre)
   apply (wpc
         | wp hoare_vcg_const_Ball_lift hoare_vcg_disj_lift
           hoare_vcg_all_lift
           doMachineOp_ko_wp_at' createObjects_orig_ko_wp_at2'[where sz = sz]
           hoare_vcg_all_lift
           doMachineOp_mapM_x_wp dmo_lift' mapM_x_wp' copyGlobalMappings_ko_wp_at threadSet_ko_wp_at2'
         | clarsimp simp: createObjects_def Arch_createNewCaps_def curDomain_def Let_def
                          pteBits_def pdeBits_def
               split del: if_split
         | assumption)+
  apply (case_tac ty)
   apply (auto simp: APIType_capBits_def archObjSize_def objBits_simps pageBits_def ptBits_def
                     pdBits_def ARM_H.toAPIType_def object_type.splits pteBits_def pdeBits_def)
  done

lemma createObjects_pspace_domain_valid':
  "\<lbrace>\<lambda>s. range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0
      \<and> {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \<inter> kernel_data_refs = {}
      \<and> pspace_domain_valid s\<rbrace>
       createObjects' ptr n val gbits
   \<lbrace>\<lambda>_. pspace_domain_valid\<rbrace>"
  apply (simp add: createObjects'_def split_def unless_def)
  apply (rule hoare_pre)
   apply (wp | wpc | simp only: alignError_def haskell_assert_def)+
  apply (clarsimp simp: new_cap_addrs_fold' unat_1_0 unat_gt_0
                        range_cover_not_zero_shift
                        caps_overlap_reserved'_def)
  apply (simp add: pspace_domain_valid_def foldr_upd_app_if
                   fun_upd_def[symmetric])
  apply (subgoal_tac " \<forall>x \<in> set (new_cap_addrs (unat (of_nat n << gbits)) ptr
                           val). {x..x + 2 ^ objBitsKO val - 1}
                                \<subseteq> {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1}")
   apply blast

  apply (rule ballI)
  apply (rule new_range_subset)
   apply (erule range_cover_rel, simp+)
  apply (simp add: range_cover.unat_of_nat_n_shift field_simps)
  done

lemma createObjects_pspace_domain_valid:
  "\<lbrace>\<lambda>s. range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0
      \<and> {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \<inter> kernel_data_refs = {}
      \<and> pspace_domain_valid s\<rbrace>
       createObjects ptr n val gbits
   \<lbrace>\<lambda>_. pspace_domain_valid\<rbrace>"
  apply (simp add: createObjects_def)
  apply (wp createObjects_pspace_domain_valid'[where sz=sz])
  apply (simp add: objBits_def)
  done

crunch pspace_domain_valid[wp]: copyGlobalMappings "pspace_domain_valid"
  (wp: crunch_wps)

lemma createNewCaps_pspace_domain_valid[wp]:
  "\<lbrace>pspace_domain_valid and K ({ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1}
            \<inter> kernel_data_refs = {}
        \<and> range_cover ptr sz (APIType_capBits ty us) n \<and> 0 < n)\<rbrace>
    createNewCaps ty ptr n us dev
   \<lbrace>\<lambda>rv. pspace_domain_valid\<rbrace>"
  apply (simp add: createNewCaps_def)
  apply (rule hoare_pre)
   apply (wp createObjects_pspace_domain_valid[where sz=sz]
            mapM_x_wp'
        | wpc | simp add: Arch_createNewCaps_def curDomain_def Let_def
                     split del: if_split)+
  apply (simp add: ARM_H.toAPIType_def
            split: object_type.splits)
  apply (auto simp: objBits_simps APIType_capBits_def pageBits_def
                    pteBits_def pdeBits_def
                    archObjSize_def ptBits_def pdBits_def)
  done

crunch cur_domain[wp]: createNewCaps "\<lambda>s. P (ksCurDomain s)"
  (wp: crunch_wps)

(* FIXME: move *)
lemma ct_idle_or_in_cur_domain'_lift_futz:
  assumes a: "\<And>P. \<lbrace>\<lambda>s. P (ksCurDomain s)\<rbrace>       f \<lbrace>\<lambda>_ s. P (ksCurDomain s)\<rbrace>"
  assumes b: "\<And>P. \<lbrace>\<lambda>s. P (ksSchedulerAction s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksSchedulerAction s)\<rbrace>"
  assumes c: "\<And>P. \<lbrace>\<lambda>s. P (ksIdleThread s)\<rbrace>      f \<lbrace>\<lambda>_ s. P (ksIdleThread s)\<rbrace>"
  assumes d: "\<And>P. \<lbrace>\<lambda>s. P (ksCurThread s)\<rbrace>       f \<lbrace>\<lambda>_ s. P (ksCurThread s)\<rbrace>"
  assumes e: "\<And>d t. \<lbrace>\<lambda>s. obj_at' (\<lambda>tcb. tcbState tcb \<noteq> Inactive \<and> d = tcbDomain tcb) t s \<and> Q s\<rbrace>
                            f
                     \<lbrace>\<lambda>_. obj_at' (\<lambda>tcb. tcbState tcb \<noteq> Inactive \<and> d = tcbDomain tcb) t\<rbrace>"
  shows "\<lbrace>ct_idle_or_in_cur_domain' and ct_active' and Q\<rbrace> f \<lbrace>\<lambda>_. ct_idle_or_in_cur_domain'\<rbrace>"
proof -
  from e have e':
    "\<And>d t. \<lbrace>\<lambda>s. obj_at' (\<lambda>tcb. tcbState tcb \<noteq> Inactive \<and> d = tcbDomain tcb) t s \<and> Q s\<rbrace>
              f
            \<lbrace>\<lambda>_. obj_at' (\<lambda>tcb. d = tcbDomain tcb) t\<rbrace>"
    apply (rule hoare_strengthen_post)
    apply (auto simp: obj_at'_def)
    done
  show ?thesis
    apply (simp add: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def)
    apply (rule hoare_pre)
    apply (wps a b c d)
    apply (wp static_imp_wp e' hoare_vcg_disj_lift)
    apply (auto simp: obj_at'_def ct_in_state'_def projectKOs st_tcb_at'_def)
    done
qed

lemma createNewCaps_ct_idle_or_in_cur_domain':
  "\<lbrace>ct_idle_or_in_cur_domain' and pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz and ct_active' and K (range_cover ptr sz (APIType_capBits ty us) n \<and> 0 < n) \<rbrace>
    createNewCaps ty ptr n us dev
   \<lbrace>\<lambda>rv. ct_idle_or_in_cur_domain'\<rbrace>"
apply (wp ct_idle_or_in_cur_domain'_lift_futz createNewCaps_obj_at'[where sz=sz] | simp)+
done

lemma sch_act_wf_lift_asm_futz:
  assumes tcb: "\<And>P t. \<lbrace>st_tcb_at' P t and Q \<rbrace> f \<lbrace>\<lambda>rv. st_tcb_at' P t\<rbrace>"
  assumes tcbDomain: "\<And>P t. \<lbrace>obj_at' (\<lambda>tcb. runnable' (tcbState tcb) \<longrightarrow> P (tcbDomain tcb)) t and Q\<rbrace> f \<lbrace>\<lambda>rv. obj_at' (\<lambda>tcb. runnable' (tcbState tcb) \<longrightarrow> P (tcbDomain tcb)) t\<rbrace>"
  assumes kCT: "\<And>P. \<lbrace>\<lambda>s. P (ksCurThread s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksCurThread s)\<rbrace>"
  assumes kCD: "\<And>P. \<lbrace>\<lambda>s. P (ksCurDomain s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksCurDomain s)\<rbrace>"
  assumes ksA: "\<And>P. \<lbrace>\<lambda>s. P (ksSchedulerAction s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksSchedulerAction s)\<rbrace>"
  shows
  "\<lbrace>\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and> Q s\<rbrace>
  f
  \<lbrace>\<lambda>rv s. sch_act_wf (ksSchedulerAction s) s\<rbrace>"
  apply (clarsimp simp: valid_def)
  apply (frule use_valid [OF _ ksA])
   prefer 2
   apply assumption
  apply (frule_tac P1="(=) (ksCurThread s)" in use_valid [OF _ kCT])
   apply (rule refl)
  apply (frule_tac P1="(=) (ksCurDomain s)" in use_valid [OF _ kCD])
   apply (rule refl)
  apply (case_tac "ksSchedulerAction s")
    apply (simp add: ct_in_state'_def)
    apply (drule use_valid [OF _ tcb])
     apply simp
    apply simp
   apply simp
  apply (clarsimp simp: tcb_in_cur_domain'_def)
  apply (frule use_valid [OF _ tcb], fastforce)
  apply simp
  apply (rename_tac word)
  apply (subgoal_tac "(obj_at' (\<lambda>tcb. runnable' (tcbState tcb) \<longrightarrow> ksCurDomain b = tcbDomain tcb) word and Q) s")
   apply (drule use_valid [OF _ tcbDomain], fastforce)
    apply (auto simp: st_tcb_at'_def o_def obj_at'_def ko_wp_at'_def)
  done

lemma createNewCaps_sch_act_wf:
  "\<lbrace>(\<lambda>s. sch_act_wf (ksSchedulerAction s) s) and pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz and K (range_cover ptr sz (APIType_capBits ty us) n \<and> 0 < n)\<rbrace>
     createNewCaps ty ptr n us dev
   \<lbrace>\<lambda>_ s. sch_act_wf (ksSchedulerAction s) s\<rbrace>"
  apply (wp sch_act_wf_lift_asm_futz
            createNewCaps_pred_tcb_at'[where sz=sz]
            createNewCaps_obj_at'[where sz=sz]
       | simp)+
  done

lemma createObjects'_ksDomSchedule[wp]:
  "\<lbrace>\<lambda>s. P (ksDomSchedule s)\<rbrace> createObjects' ptr numObjects val gSize \<lbrace>\<lambda>_ s. P (ksDomSchedule s)\<rbrace>"
  apply (simp add: createObjects'_def unless_def alignError_def)
  apply (wp | wpc)+
  apply simp
  done

lemma createObjects'_ksDomScheduleIdx[wp]:
  "\<lbrace>\<lambda>s. P (ksDomScheduleIdx s)\<rbrace> createObjects' ptr numObjects val gSize \<lbrace>\<lambda>_ s. P (ksDomScheduleIdx s)\<rbrace>"
  apply (simp add: createObjects'_def unless_def alignError_def)
  apply (wp | wpc)+
  apply simp
  done

crunch ksDomSchedule[wp]: copyGlobalMappings "\<lambda>s. P (ksDomSchedule s)"
  (wp: setObject_ksPSpace_only updateObject_default_inv mapM_x_wp')

crunch ksDomSchedule[wp]: createNewCaps "\<lambda>s. P (ksDomSchedule s)"
  (wp: mapM_x_wp' simp: crunch_simps)

crunch ksDomScheduleIdx[wp]: createNewCaps "\<lambda>s. P (ksDomScheduleIdx s)"
  (wp: mapM_x_wp' simp: crunch_simps)

lemma createObjects_null_filter':
  "\<lbrace>\<lambda>s. P (null_filter' (ctes_of s)) \<and> makeObjectKO dev ty = Some val \<and>
        range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0 \<and>
        pspace_aligned' s \<and> pspace_distinct' s \<and> pspace_no_overlap' ptr sz s\<rbrace>
   createObjects' ptr n val gbits
   \<lbrace>\<lambda>addrs a. P (null_filter' (ctes_of a))\<rbrace>"
   apply (clarsimp simp: createObjects'_def split_def)
   apply (wp hoare_unless_wp|wpc
          | clarsimp simp:haskell_assert_def alignError_def
            split del: if_splits simp del:fun_upd_apply)+
   apply (subst new_cap_addrs_fold')
     apply (simp add:unat_1_0 unat_gt_0)
     apply (rule range_cover_not_zero_shift)
     apply fastforce+
   apply (subst new_cap_addrs_fold')
    apply (simp add:unat_1_0 unat_gt_0)
    apply (rule range_cover_not_zero_shift)
      apply simp
     apply assumption
    apply simp
   apply (subst data_map_insert_def[symmetric])+
   apply (frule(2) retype_aligned_distinct'[where ko = val])
    apply (erule range_cover_rel)
     apply simp+
   apply (frule(2) retype_aligned_distinct'(2)[where ko = val])
    apply (erule range_cover_rel)
     apply simp+
   apply (frule null_filter_ctes_retype
     [where addrs = "(new_cap_addrs (unat (((of_nat n)::word32) << gbits)) ptr val)"])
          apply assumption+
     apply (clarsimp simp:field_simps foldr_upd_app_if[folded data_map_insert_def] shiftl_t2n range_cover.unat_of_nat_shift)+
    apply (rule new_cap_addrs_aligned[THEN bspec])
    apply (erule range_cover.aligned[OF range_cover_rel])
     apply simp+
   apply (clarsimp simp:shiftl_t2n field_simps range_cover.unat_of_nat_shift)
   apply (drule subsetD[OF new_cap_addrs_subset,rotated])
    apply (erule range_cover_rel)
     apply simp
    apply simp
   apply (rule ccontr)
   apply clarify
   apply (frule(1) pspace_no_overlapD')
   apply (erule_tac B = "{x..x+2^objBitsKO y - 1}" in in_empty_interE[rotated])
    apply (drule(1) pspace_alignedD')
    apply (clarsimp)
    apply (erule is_aligned_no_overflow)
    apply (simp del:atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
        Int_atLeastAtMost atLeastatMost_empty_iff add:Int_ac ptr_add_def p_assoc_help)
  apply (simp add:field_simps foldr_upd_app_if[folded data_map_insert_def] shiftl_t2n)
  apply auto
  done

lemma createNewCaps_null_filter':
  "\<lbrace>(\<lambda>s. P (null_filter' (ctes_of s)))
      and pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz
      and K (range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0) \<rbrace>
     createNewCaps ty ptr n us dev
   \<lbrace>\<lambda>_ s. P (null_filter' (ctes_of s))\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (simp add: createNewCaps_def toAPIType_def
                   Arch_createNewCaps_def
               split del: if_split cong: option.case_cong)
  apply (cases ty, simp_all split del: if_split)
          apply (rename_tac apiobject_type)
          apply (case_tac apiobject_type, simp_all split del: if_split)
              apply (rule hoare_pre, wp,simp)
             apply (simp add: createObjects_def makeObjectKO_def
                              APIType_capBits_def objBits_def pageBits_def
                              archObjSize_def ptBits_def pdBits_def curDomain_def
                              objBits_if_dev
                       split del: if_split
                    | wp createObjects_null_filter'[where ty = "Inr ty" and sz = sz and dev=dev]
                         copyGlobalMappings_ctes_of threadSet_ctes_of mapM_x_wp'
                    | simp add: objBits_simps pteBits_def pdeBits_def
                    | fastforce)+
  done

crunch gsUntypedZeroRanges[wp]: createNewCaps "\<lambda>s. P (gsUntypedZeroRanges s)"
  (wp: crunch_wps simp: crunch_simps unless_def)

lemma untyped_ranges_zero_inv_null_filter:
  "untyped_ranges_zero_inv (option_map cteCap o null_filter' ctes)
    = untyped_ranges_zero_inv (option_map cteCap o ctes)"
  apply (simp add: untyped_ranges_zero_inv_def fun_eq_iff null_filter'_def)
  apply clarsimp
  apply (rule_tac f="\<lambda>caps. x = ran caps" for caps in arg_cong)
  apply (clarsimp simp: fun_eq_iff map_comp_def untypedZeroRange_def)
  done

lemma untyped_ranges_zero_inv_null_filter_cteCaps_of:
  "untyped_ranges_zero_inv (cteCaps_of s)
    = untyped_ranges_zero_inv (option_map cteCap o null_filter' (ctes_of s))"
  by (simp add: untyped_ranges_zero_inv_null_filter cteCaps_of_def)

lemma createNewCaps_urz:
  "\<lbrace>untyped_ranges_zero'
      and pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz
      and K (range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0) \<rbrace>
   createNewCaps ty ptr n us dev
   \<lbrace>\<lambda>archCaps. untyped_ranges_zero'\<rbrace>"
  apply (simp add: untyped_ranges_zero_inv_null_filter_cteCaps_of)
  apply (rule hoare_pre)
   apply (rule untyped_ranges_zero_lift)
    apply (wp createNewCaps_null_filter')+
  apply (auto simp: o_def)
  done

lemma createNewCaps_invs':
  "\<lbrace>(\<lambda>s. invs' s \<and> ct_active' s \<and> pspace_no_overlap' ptr sz s
        \<and> caps_no_overlap'' ptr sz s \<and> ptr \<noteq> 0
        \<and> {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \<inter> kernel_data_refs = {}
        \<and> caps_overlap_reserved' {ptr..ptr + of_nat n * 2^(APIType_capBits ty us) - 1} s
        \<and> (ty = APIObjectType ArchTypes_H.CapTableObject \<longrightarrow> us > 0)
        \<and> gsMaxObjectSize s > 0)
       and K (range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0)\<rbrace>
     createNewCaps ty ptr n us dev
   \<lbrace>\<lambda>rv. invs'\<rbrace>"
  (is "\<lbrace>?P and K ?Q\<rbrace> ?f \<lbrace>\<lambda>rv. invs'\<rbrace>")
proof (rule hoare_gen_asm, erule conjE)
  assume cover: "range_cover ptr sz (APIType_capBits ty us) n" and not_0: "n \<noteq> 0"
  have cnc_ct_not_inQ:
    "\<lbrace>ct_not_inQ and valid_pspace' and pspace_no_overlap' ptr sz\<rbrace>
     createNewCaps ty ptr n us dev \<lbrace>\<lambda>_. ct_not_inQ\<rbrace>"
    unfolding ct_not_inQ_def
    apply (rule_tac Q="\<lambda>s. ksSchedulerAction s = ResumeCurrentThread
                             \<longrightarrow> (obj_at' (Not \<circ> tcbQueued) (ksCurThread s) s
                                  \<and> valid_pspace' s \<and> pspace_no_overlap' ptr sz s)"
                    in hoare_pre_imp, clarsimp)
    apply (rule hoare_convert_imp [OF createNewCaps_nosch])
    apply (rule hoare_weaken_pre)
     apply (wps createNewCaps_ct)
     apply (wp createNewCaps_obj_at')
    using cover not_0
    apply (fastforce simp: valid_pspace'_def)
    done
  show "\<lbrace>?P\<rbrace>
     createNewCaps ty ptr n us dev
   \<lbrace>\<lambda>rv. invs'\<rbrace>"
  apply (simp add: invs'_def valid_state'_def
                   pointerInUserData_def typ_at'_def)
    apply (rule hoare_pre)
     apply (wp createNewCaps_valid_pspace [OF not_0 cover]
               createNewCaps_state_refs_of' [OF cover not_0 ]
               createNewCaps_iflive' [OF cover not_0 ]
               irqs_masked_lift
               createNewCaps_ifunsafe'
               createNewCaps_cur [OF cover not_0]
               createNewCaps_global_refs'
               createNewCaps_valid_arch_state
               valid_irq_node_lift_asm [unfolded pred_conj_def, OF _ createNewCaps_obj_at']
               createNewCaps_irq_handlers' createNewCaps_vms
               createNewCaps_valid_queues
               createNewCaps_valid_queues'
               createNewCaps_pred_tcb_at' cnc_ct_not_inQ
               createNewCaps_ct_idle_or_in_cur_domain'
               createNewCaps_sch_act_wf
               createNewCaps_urz[where sz=sz]
           | simp)+
  using not_0
  apply (clarsimp simp: valid_pspace'_def)
  using cover
  apply (intro conjI)
   apply simp_all
  done
qed

lemma createObjects_pred_tcb_at':
  "\<lbrace>pred_tcb_at' proj P t and K (range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0)
     and pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz\<rbrace>
  createObjects ptr n val gbits \<lbrace>\<lambda>rv. pred_tcb_at' proj P t\<rbrace>"
  apply (simp add: pred_tcb_at'_def createObjects_def)
  apply (wp createObjects_orig_obj_at')
  apply auto
  done

lemma createObjects_ex_cte_cap_to [wp]:
  "\<lbrace>\<lambda>s. range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0 \<and> pspace_aligned' s \<and>
        pspace_distinct' s \<and> ex_cte_cap_to' p s \<and> pspace_no_overlap' ptr sz s\<rbrace>
  createObjects ptr n val gbits \<lbrace>\<lambda>r. ex_cte_cap_to' p\<rbrace>"
  apply (simp add: ex_cte_cap_to'_def createObjects_def)
  apply (rule hoare_lift_Pf2 [where f="irq_node'"])
   apply (wp hoare_vcg_ex_lift createObjects_orig_cte_wp_at'[where sz = sz])
   apply simp
  apply wp
  done

lemma createObjects_orig_obj_at3:
  "\<lbrace>\<lambda>s. obj_at' P p s \<and> range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0 \<and>
        pspace_aligned' s \<and>
        pspace_distinct' s \<and> pspace_no_overlap' ptr sz s\<rbrace>
  createObjects ptr n val gbits \<lbrace>\<lambda>r. obj_at' P p\<rbrace>"
  by (wp createObjects_orig_obj_at'[where sz = sz] | simp add: createObjects_def)+

lemma createObjects_sch:
  "\<lbrace>(\<lambda>s. sch_act_wf (ksSchedulerAction s) s) and pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz
      and K (range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0)\<rbrace>
  createObjects ptr n val gbits
  \<lbrace>\<lambda>rv s. sch_act_wf (ksSchedulerAction s) s\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (wp sch_act_wf_lift_asm createObjects_pred_tcb_at' createObjects_orig_obj_at3 | force)+
  done

lemma createObjects_queues:
  "\<lbrace>\<lambda>s. valid_queues s \<and>  pspace_aligned' s \<and> pspace_distinct' s \<and>
        pspace_no_overlap' ptr sz s \<and> range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0\<rbrace>
  createObjects ptr n val gbits
  \<lbrace>\<lambda>rv. valid_queues\<rbrace>"
  apply (wp valid_queues_lift_asm [unfolded pred_conj_def, OF createObjects_orig_obj_at3]
            createObjects_pred_tcb_at' [unfolded pred_conj_def])
      apply fastforce
     apply wp+
  apply fastforce
  done

lemma createObjects_queues':
  assumes no_tcb: "\<And>t. projectKO_opt val \<noteq> Some (t::tcb)"
  shows
  "\<lbrace>\<lambda>s. valid_queues' s \<and>  pspace_aligned' s \<and> pspace_distinct' s \<and>
        pspace_no_overlap' ptr sz s \<and> range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0\<rbrace>
  createObjects ptr n val gbits
  \<lbrace>\<lambda>rv. valid_queues'\<rbrace>"
  apply (simp add: createObjects_def)
  apply (wp valid_queues_lift_asm')
    apply (wp createObjects_orig_obj_at2')
    apply clarsimp
    apply assumption
   apply wp
  apply (clarsimp simp: no_tcb split: option.splits)
  apply fastforce
  done

lemma createObjects_no_cte_ifunsafe':
  assumes no_cte: "\<And>c. projectKO_opt val \<noteq> Some (c::cte)"
  assumes no_tcb: "\<And>t. projectKO_opt val \<noteq> Some (t::tcb)"
  shows
  "\<lbrace>\<lambda>s. valid_pspace' s \<and>
       pspace_no_overlap' ptr sz s \<and>
       range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0 \<and>
       if_unsafe_then_cap' s\<rbrace>
      createObjects ptr n val gbits
   \<lbrace>\<lambda>rv s. if_unsafe_then_cap' s\<rbrace>"
  apply (simp only: if_unsafe_then_cap'_def ex_cte_cap_to'_def
                    imp_conv_disj)
  apply (rule hoare_pre)
   apply (rule hoare_use_eq_irq_node' [OF createObjects_ksInterrupt])
   apply (simp add: createObjects_def)
   apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift hoare_vcg_imp_lift
             createObjects_orig_cte_wp_at2' hoare_vcg_ex_lift)
  apply (simp add: valid_pspace'_def disj_imp)
  apply (simp add: split_def no_cte no_tcb split: option.splits)
  apply auto
  done

lemma createObjects_no_cte_valid_global:
  assumes no_cte: "\<And>c. projectKO_opt val \<noteq> Some (c::cte)"
  assumes no_tcb: "\<And>t. projectKO_opt val \<noteq> Some (t::tcb)"
  shows "\<lbrace>\<lambda>s. pspace_aligned' s \<and> pspace_distinct' s \<and>
        pspace_no_overlap' ptr sz s \<and>
        range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0 \<and>
        valid_global_refs' s\<rbrace>
      createObjects ptr n val gbits
   \<lbrace>\<lambda>rv s. valid_global_refs' s\<rbrace>"
  apply (simp add: valid_global_refs'_def valid_cap_sizes'_def valid_refs'_def)
  apply (rule_tac Q="\<lambda>rv s. \<forall>ptr. \<not> cte_wp_at' (\<lambda>cte. (kernel_data_refs \<inter> capRange (cteCap cte) \<noteq> {}
        \<or> 2 ^ capBits (cteCap cte) > gsMaxObjectSize s)) ptr s \<and> global_refs' s \<subseteq> kernel_data_refs"
                 in hoare_post_imp)
   apply (auto simp: cte_wp_at_ctes_of linorder_not_less elim!: ranE)[1]
  apply (rule hoare_pre)
   apply (simp add: global_refs'_def)
   apply (rule hoare_use_eq [where f=ksArchState, OF createObjects_ksArch])
   apply (rule hoare_use_eq [where f=ksIdleThread, OF createObjects_it])
   apply (rule hoare_use_eq [where f=irq_node', OF createObjects_ksInterrupt])
   apply (rule hoare_use_eq [where f=gsMaxObjectSize], wp)
   apply (simp add: createObjects_def)
   apply (wp hoare_vcg_all_lift createObjects_orig_cte_wp_at2')
  apply (simp add: no_cte no_tcb split_def cte_wp_at_ctes_of split: option.splits)
  apply (clarsimp simp: global_refs'_def)
  apply (auto simp: ball_ran_eq linorder_not_less[symmetric])
  done

lemma createObjects'_typ_at:
  "\<lbrace>\<lambda>s. n \<noteq> 0 \<and>
        range_cover ptr sz (objBitsKO val + gbits) n \<and>
        typ_at' T p s \<and>
        pspace_aligned' s \<and> pspace_distinct' s \<and>
        pspace_no_overlap' ptr sz s\<rbrace>
  createObjects' ptr n val gbits \<lbrace>\<lambda>r s. typ_at' T p s\<rbrace>"
  apply (rule hoare_grab_asm)+
  apply (simp add: createObjects'_def lookupAround2_pspace_no
                    alignError_def unless_def split_def typ_at'_def)
   apply (subst new_cap_addrs_fold')
     apply (simp add: unat_1_0 unat_gt_0)
     apply (rule range_cover_not_zero_shift)
     apply simp+
  apply (rule hoare_pre)
    apply (wp|simp cong: if_cong del: data_map_insert_def fun_upd_apply)+
    apply (wpc|wp)+
  apply (subst data_map_insert_def[symmetric])
  apply clarsimp
  apply (subgoal_tac "range_cover ptr sz (objBitsKO val) (unat (of_nat n << gbits))")
    apply (subst data_map_insert_def[symmetric])+
    apply (subst retype_ko_wp_at',simp+)+
    apply clarsimp
   apply (frule(1) subsetD [OF new_cap_addrs_subset])
   apply (drule(1) pspace_no_overlap_disjoint')
   apply (simp add: lookupAround2_None1)
   apply (intro conjI impI allI)
     apply (drule_tac x = p in spec)
     apply (erule impE)
      apply (erule(1) range_cover_new_cap_addrs_compare[rotated])
      apply simp
     apply (fastforce simp: ko_wp_at'_def)
   apply (drule_tac x = p in orthD1)
   apply (clarsimp simp: ptr_add_def p_assoc_help)
   apply (simp add: dom_def)
   apply (fastforce simp: ko_wp_at'_def)
  apply (rule range_cover_rel)
     apply (simp)+
  apply (subst mult.commute)
  apply (erule range_cover.unat_of_nat_n_shift)
  apply simp
  done

lemma createObjects_valid_arch:
  "\<lbrace>\<lambda>s. valid_arch_state' s \<and> pspace_aligned' s \<and> pspace_distinct' s \<and>
        pspace_no_overlap' ptr sz s \<and> range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0 \<rbrace>
      createObjects ptr n val gbits
   \<lbrace>\<lambda>rv s. valid_arch_state' s\<rbrace>"
  apply (simp add: valid_arch_state'_def valid_asid_table'_def
                   page_directory_at'_def valid_global_pts'_def
                   page_table_at'_def)
  apply (rule hoare_pre)
   apply (rule hoare_use_eq [where f=ksArchState, OF createObjects_ksArch])
    apply (simp add: createObjects_def)
    apply (wp createObjects'_typ_at hoare_vcg_all_lift hoare_vcg_const_imp_lift
              hoare_vcg_const_Ball_lift)
  apply (simp add: o_def)
  apply auto
  done

lemma createObjects_irq_state:
  "\<lbrace>\<lambda>s. pspace_aligned' s \<and> pspace_distinct' s \<and>
        pspace_no_overlap' ptr sz s \<and>
        range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0 \<and>
        valid_irq_node' (irq_node' s) s\<rbrace>
      createObjects ptr n val gbits
   \<lbrace>\<lambda>rv s. valid_irq_node' (irq_node' s) s\<rbrace>"
  apply (wp valid_irq_node_lift_asm [unfolded pred_conj_def, OF _ createObjects_orig_obj_at3])
  apply auto
  done

lemma createObjects_no_cte_irq_handlers:
  assumes no_cte: "\<And>c. projectKO_opt val \<noteq> Some (c::cte)"
  assumes no_tcb: "\<And>t. projectKO_opt val \<noteq> Some (t::tcb)"
  shows
  "\<lbrace>\<lambda>s. pspace_aligned' s \<and> pspace_distinct' s \<and>
        pspace_no_overlap' ptr sz s \<and>
        range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0 \<and>
        valid_irq_handlers' s\<rbrace>
      createObjects ptr n val gbits
   \<lbrace>\<lambda>rv s.  valid_irq_handlers' s\<rbrace>"
  apply (simp add: valid_irq_handlers_cte_wp_at_form' createObjects_def irq_issued'_def)
   apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift
             createObjects_orig_cte_wp_at2')
  apply (clarsimp simp: no_cte no_tcb split_def split: option.splits)
  apply auto
  done

lemma createObjects_cur':
  "\<lbrace>\<lambda>s. pspace_aligned' s \<and> pspace_distinct' s \<and>
        pspace_no_overlap' ptr sz s \<and> range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0 \<and>
        cur_tcb' s\<rbrace>
      createObjects ptr n val gbits
   \<lbrace>\<lambda>rv s. cur_tcb' s\<rbrace>"
  apply (rule hoare_post_imp [where Q="\<lambda>rv s. \<exists>t. ksCurThread s = t \<and> tcb_at' t s"])
   apply (simp add: cur_tcb'_def)
  apply (wp hoare_vcg_ex_lift createObjects_orig_obj_at3)
  apply (clarsimp simp: cur_tcb'_def)
  apply auto
  done

lemma createObjects_vms'[wp]:
  "\<lbrace>(\<lambda>_.  (range_cover ptr sz  (objBitsKO val + gbits) n \<and> 0 < n)) and pspace_aligned' and
     pspace_distinct' and pspace_no_overlap' ptr sz and valid_machine_state'\<rbrace>
      createObjects ptr n val gbits
   \<lbrace>\<lambda>rv. valid_machine_state'\<rbrace>"
  apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def
                   typ_at'_def)
  apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift createObjects_orig_ko_wp_at2'
         | simp add: createObjects_def)+
  apply auto
  done

lemma createObjects_ct_idle_or_in_cur_domain':
  "\<lbrace>ct_active' and valid_pspace' and pspace_no_overlap' ptr sz
       and ct_idle_or_in_cur_domain'
       and K (range_cover ptr sz (objBitsKO val + gSize) n \<and> n \<noteq> 0)\<rbrace>
     createObjects ptr n val gSize
   \<lbrace>\<lambda>_. ct_idle_or_in_cur_domain'\<rbrace>"
apply (rule hoare_gen_asm)
apply (wp ct_idle_or_in_cur_domain'_lift_futz createObjects_obj_at_other[where sz=sz])
apply simp_all
done

lemma untyped_zero_ranges_cte_def:
  "untyped_ranges_zero_inv (cteCaps_of s) rs
    = (\<forall>r. (\<exists>p. cte_wp_at' (\<lambda>cte. untypedZeroRange (cteCap cte) = Some r) p s)
        = (r \<in> rs))"
  apply (clarsimp simp: untyped_ranges_zero_inv_def cte_wp_at_ctes_of
                        cteCaps_of_def set_eq_iff ran_def map_comp_Some_iff)
  apply (safe, metis+)
  done

crunch gsUntypedZeroRanges[wp]: createObjects "\<lambda>s. P (gsUntypedZeroRanges s)"
  (simp: unless_def)

lemma createObjects_untyped_ranges_zero':
  assumes moKO: "makeObjectKO dev ty = Some val"
  shows
  "\<lbrace>ct_active' and valid_pspace' and pspace_no_overlap' ptr sz
       and untyped_ranges_zero'
       and K (range_cover ptr sz (objBitsKO val + gSize) n \<and> n \<noteq> 0)\<rbrace>
     createObjects ptr n val gSize
   \<lbrace>\<lambda>_. untyped_ranges_zero'\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (simp add: untyped_zero_ranges_cte_def iff_conv_conj_imp
                   createObjects_def)
  apply (simp only: imp_conv_disj not_all not_ex)
  apply (rule hoare_pre)
   apply (wp hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_conj_lift
             hoare_vcg_disj_lift createObjects_orig_cte_wp_at2'[where sz=sz])
  apply (clarsimp simp: valid_pspace'_def)
  apply (cut_tac moKO[symmetric])
  apply (simp add: makeObjectKO_def projectKO_opt_tcb projectKO_opt_cte
                   split: sum.split_asm kernel_object.split_asm
                          arch_kernel_object.split_asm
                          object_type.split_asm apiobject_type.split_asm)
   apply (simp add: makeObject_tcb tcb_cte_cases_def makeObject_cte
                    untypedZeroRange_def)
  apply (simp add: makeObject_cte untypedZeroRange_def)
  done

lemma createObjects_no_cte_invs:
  assumes moKO: "makeObjectKO dev ty = Some val"
  assumes no_cte: "\<And>c. projectKO_opt val \<noteq> Some (c::cte)"
  assumes no_tcb: "\<And>t. projectKO_opt val \<noteq> Some (t::tcb)"
  shows
  "\<lbrace>\<lambda>s. range_cover ptr sz ((objBitsKO val) + gbits) n \<and> n \<noteq> 0 \<and> invs' s \<and> ct_active' s
        \<and> pspace_no_overlap' ptr sz s \<and> ptr \<noteq> 0
        \<and> {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \<inter> kernel_data_refs = {}
        \<and> caps_overlap_reserved' {ptr..ptr + of_nat (n * 2 ^ gbits * 2 ^ objBitsKO val) - 1} s
        \<and> caps_no_overlap'' ptr sz s \<and>
       refs_of' val = {} \<and> \<not> live' val
            \<and> (\<forall>pde. projectKO_opt val = Some pde \<longrightarrow> pde = InvalidPDE)\<rbrace>
  createObjects ptr n val gbits
  \<lbrace>\<lambda>rv. invs'\<rbrace>"
proof -
  have co_ct_not_inQ:
    "\<lbrakk>range_cover ptr sz ((objBitsKO val) + gbits) n; n \<noteq> 0\<rbrakk> \<Longrightarrow>
     \<lbrace>\<lambda>s. ct_not_inQ s \<and> pspace_no_overlap' ptr sz s \<and> valid_pspace' s\<rbrace>
      createObjects ptr n val gbits \<lbrace>\<lambda>_. ct_not_inQ\<rbrace>"
    (is "\<lbrakk> _; _ \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. ct_not_inQ s \<and> ?REST s\<rbrace> _ \<lbrace>_\<rbrace>")
    apply (simp add: ct_not_inQ_def)
    apply (rule_tac Q="\<lambda>s. (ksSchedulerAction s = ResumeCurrentThread) \<longrightarrow>
                             (obj_at' (Not \<circ> tcbQueued) (ksCurThread s) s \<and> ?REST s)"
             in hoare_pre_imp, clarsimp)
    apply (rule hoare_convert_imp [OF createObjects_nosch])
    apply (rule hoare_weaken_pre)
     apply (wps createObjects_ct)
     apply (wp createObjects_obj_at_other)
      apply (simp)+
    done
  show ?thesis
  apply (rule hoare_grab_asm)+
   apply (clarsimp simp: invs'_def valid_state'_def)
   apply wp
   apply (rule hoare_pre)
   apply (rule hoare_vcg_conj_lift)
   apply (simp add: createObjects_def,wp createObjects_valid_pspace_untyped')
   apply (wp assms | simp add: objBits_def)+
   apply (wp createObjects_sch createObjects_queues)
   apply (rule hoare_vcg_conj_lift)
    apply (simp add: createObjects_def)
    apply (wp createObjects_state_refs_of'')
   apply (rule hoare_vcg_conj_lift)
    apply (simp add: createObjects_def)
    apply (wp createObjects_iflive')
   apply (wp createObjects_no_cte_ifunsafe' irqs_masked_lift
             createObjects_idle' createObjects_no_cte_valid_global
             createObjects_valid_arch createObjects_irq_state
             createObjects_no_cte_irq_handlers createObjects_cur'
             createObjects_queues' [OF no_tcb]
             assms | simp add: objBits_def )+
  apply (rule hoare_vcg_conj_lift)
   apply (simp add: createObjects_def)
   apply (wp createObjects_idle')
   apply (wp createObjects_no_cte_ifunsafe' irqs_masked_lift
             createObjects_idle' createObjects_no_cte_valid_global
             createObjects_valid_arch createObjects_irq_state
             createObjects_no_cte_irq_handlers createObjects_cur'
             createObjects_queues' [OF no_tcb] assms
             createObjects_pspace_domain_valid co_ct_not_inQ
             createObjects_ct_idle_or_in_cur_domain'
             createObjects_untyped_ranges_zero'[OF moKO]
         | simp)+
  apply clarsimp
  apply ((intro conjI; assumption?); simp add: valid_pspace'_def objBits_def)
  apply (fastforce simp add: no_cte no_tcb split_def split: option.splits)
  apply (clarsimp simp: invs'_def no_tcb valid_state'_def no_cte  split: option.splits)
  done
qed

lemma corres_retype_update_gsI:
  assumes not_zero: "n \<noteq> 0"
  and      aligned: "is_aligned ptr (objBitsKO ko + gbits)"
  and obj_bits_api: "obj_bits_api (APIType_map2 ty) us =
                     objBitsKO ko + gbits"
  and        check: "sz < obj_bits_api (APIType_map2 ty) us \<longleftrightarrow>
                     sz < objBitsKO ko + gbits"
  and          usv: "APIType_map2 ty = Structures_A.CapTableObject \<Longrightarrow> 0 < us"
  and           ko: "makeObjectKO dev ty = Some ko"
  and          orr: "obj_bits_api (APIType_map2 ty) us \<le> sz \<Longrightarrow>
                     obj_relation_retype
                       (default_object (APIType_map2 ty) dev us) ko"
  and        cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n"
  and            f: "f = update_gs (APIType_map2 ty) us"
  shows "corres (\<lambda>rv rv'. rv' = g rv)
         (\<lambda>s. valid_pspace s \<and> pspace_no_overlap_range_cover ptr sz s
            \<and> valid_mdb s \<and> valid_etcbs s \<and> valid_list s)
         (\<lambda>s. pspace_aligned' s \<and> pspace_distinct' s \<and>
              pspace_no_overlap' ptr sz s)
         (retype_region2 ptr n us (APIType_map2 ty) dev)
         (do addrs \<leftarrow> createObjects ptr n ko gbits;
             _ \<leftarrow> modify (f (set addrs));
             return (g addrs)
          od)"
  using corres_retype' [OF not_zero aligned obj_bits_api check usv ko orr cover]
  by (simp add: f)

lemma gcd_corres: "corres (=) \<top> \<top> (gets cur_domain) curDomain"
  by (simp add: curDomain_def state_relation_def)

lemma retype_region2_extra_ext_mapM_x_corres:
  shows "corres dc
           (valid_etcbs and (\<lambda>s. \<forall>addr\<in>set addrs. tcb_at addr s))
           (\<lambda>s. \<forall>addr\<in>set addrs. tcb_at' addr s)
           (retype_region2_extra_ext addrs Structures_A.apiobject_type.TCBObject)
           (mapM_x (\<lambda>addr. do cdom \<leftarrow> curDomain;
                              threadSet (tcbDomain_update (\<lambda>_. cdom)) addr
                           od)
             addrs)"
  apply (rule corres_guard_imp)
    apply (simp add: retype_region2_extra_ext_def curDomain_mapM_x_futz[symmetric] when_def)
    apply (rule corres_split_eqr[OF _ gcd_corres])
      apply (rule_tac S="Id \<inter> {(x, y). x \<in> set addrs}"
                  and P="\<lambda>s. (\<forall>t \<in> set addrs. tcb_at t s) \<and> valid_etcbs s"
                  and P'="\<lambda>s. \<forall>t \<in> set addrs. tcb_at' t s"
                   in corres_mapM_x)
          apply simp
          apply (rule corres_guard_imp)
            apply (rule ethread_set_corres, simp_all add: etcb_relation_def non_exst_same_def)[1]
            apply (case_tac tcb')
            apply simp
           apply fastforce
          apply fastforce
         apply (wp hoare_vcg_ball_lift | simp)+
      apply auto[1]
     apply (wp | simp add: curDomain_def)+
  done

lemma retype_region2_extra_ext_trivial:
  "ty \<noteq> APIType_map2 (Inr (APIObjectType apiobject_type.TCBObject))
      \<Longrightarrow> retype_region2_extra_ext ptrs ty = return ()"
by (simp add: retype_region2_extra_ext_def when_def APIType_map2_def)

lemma retype_region2_ext_retype_region_ArchObject_PageDirectoryObj:
  "retype_region ptr n us (APIType_map2 (Inr PageDirectoryObject)) dev =
  (retype_region2 ptr n us (APIType_map2 (Inr PageDirectoryObject)) dev :: obj_ref list det_ext_monad)"
by (simp add: retype_region2_ext_retype_region retype_region2_extra_ext_def when_def APIType_map2_def)

lemma retype_region2_valid_etcbs[wp]:"\<lbrace>valid_etcbs\<rbrace> retype_region2 a b c d dev \<lbrace>\<lambda>_. valid_etcbs\<rbrace>"
  apply (simp add: retype_region2_def)
  apply (simp add: retype_region2_ext_def bind_assoc)
  apply wp
  apply (clarsimp simp del: fun_upd_apply)
  apply (blast intro: valid_etcb_fold_update)
  done

lemma retype_region2_obj_at:
  assumes tytcb: "ty = Structures_A.apiobject_type.TCBObject"
  shows "\<lbrace>\<top>\<rbrace> retype_region2 ptr n us ty dev \<lbrace>\<lambda>rv s. \<forall>x \<in> set rv. tcb_at x s\<rbrace>"
  using tytcb unfolding retype_region2_def
  apply (simp only: return_bind bind_return foldr_upd_app_if fun_app_def K_bind_def)
  apply (wp dxo_wp_weak | simp)+
  apply (auto simp: obj_at_def default_object_def is_tcb_def)
  done

lemma createObjects_tcb_at':
  "\<lbrakk>range_cover ptr sz (objBitsKO (injectKOS (makeObject::tcb))) n; n \<noteq> 0\<rbrakk> \<Longrightarrow>
   \<lbrace>\<lambda>s. pspace_no_overlap' ptr sz s \<and> pspace_aligned' s \<and> pspace_distinct' s\<rbrace>
   createObjects ptr n (KOTCB makeObject) 0 \<lbrace>\<lambda>ptrs s. \<forall>addr\<in>set ptrs. tcb_at' addr s\<rbrace>"
  apply (rule hoare_strengthen_post[OF createObjects_ko_at_strg[where val = "(makeObject :: tcb)"]])
  apply (auto simp: obj_at'_def projectKOs project_inject objBitsKO_def objBits_def makeObject_tcb)
  done

lemma init_arch_objects_APIType_map2_noop:
  "tp \<noteq> Inr PageDirectoryObject
   \<longrightarrow> init_arch_objects (APIType_map2 tp) ptr n m addrs
    = return ()"
  apply (simp add: init_arch_objects_def APIType_map2_def)
  apply (cases tp, simp_all split: kernel_object.split arch_kernel_object.split
    object_type.split apiobject_type.split)
  done

lemma data_page_relation_retype:
  "obj_relation_retype (ArchObj (DataPage False pgsz)) KOUserData"
  "obj_relation_retype (ArchObj (DataPage True pgsz)) KOUserDataDevice"
  apply (simp_all add: obj_relation_retype_def
                   objBits_simps archObjSize_def
                   pbfs_atleast_pageBits)
   apply (clarsimp simp: image_def)+
  done

lemma corres_retype_region_createNewCaps:
  "corres ((\<lambda>r r'. length r = length r' \<and> list_all2 cap_relation r r')
               \<circ> map (\<lambda>ref. default_cap (APIType_map2 (Inr ty)) ref us dev))
            (\<lambda>s. valid_pspace s \<and> valid_mdb s \<and> valid_etcbs s \<and> valid_list s \<and> valid_arch_state s
                   \<and> caps_no_overlap y sz s \<and> pspace_no_overlap_range_cover y sz s
                   \<and> caps_overlap_reserved {y..y + of_nat n * 2 ^ (obj_bits_api (APIType_map2 (Inr ty)) us) - 1} s
                   \<and> (\<exists>slot. cte_wp_at (\<lambda>c. up_aligned_area y sz \<subseteq> cap_range c \<and> cap_is_device c = dev) slot s)
                   \<and> (APIType_map2 (Inr ty) = Structures_A.CapTableObject \<longrightarrow> 0 < us))
            (\<lambda>s. pspace_aligned' s \<and> pspace_distinct' s \<and> pspace_no_overlap' y sz s
                  \<and> valid_pspace' s \<and> valid_arch_state' s
                  \<and> range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \<and> n\<noteq> 0)
            (do x \<leftarrow> retype_region y n us (APIType_map2 (Inr ty)) dev :: obj_ref list det_ext_monad;
                init_arch_objects (APIType_map2 (Inr ty)) y n us x;
                return x od)
            (createNewCaps ty y n us dev)"
  apply (rule_tac F="range_cover y sz
                       (obj_bits_api (APIType_map2 (Inr ty)) us) n \<and>
                     n \<noteq> 0 \<and>
                     (APIType_map2 (Inr ty) = Structures_A.CapTableObject
                       \<longrightarrow> 0 < us)"
            in corres_req, simp)
  apply (clarsimp simp add: createNewCaps_def toAPIType_def
                 split del: if_split cong: if_cong)
  apply (subst init_arch_objects_APIType_map2)
  apply (cases ty, simp_all add: Arch_createNewCaps_def
                      split del: if_split)
        apply (rename_tac apiobject_type)
        apply (case_tac apiobject_type, simp_all split del: if_split)
            \<comment> \<open>Untyped\<close>
            apply (simp     add: retype_region_def obj_bits_api_def
                                 APIType_map2_def
                      split del: if_split
                           cong: if_cong)
            apply (subst upto_enum_red')
             apply (drule range_cover_not_zero[rotated])
              apply simp
             apply unat_arith
            apply (clarsimp simp: list_all2_same enum_word_def  range_cover.unat_of_nat_n
                                  list_all2_map1 list_all2_map2
                                  ptr_add_def fromIntegral_def toInteger_nat fromInteger_nat)
            apply (subst unat_of_nat_minus_1)
              apply (rule le_less_trans[OF range_cover.range_cover_n_le(2) power_strict_increasing])
                apply simp
               apply (clarsimp simp: range_cover_def)
               apply (arith+)[4]
           \<comment> \<open>TCB, EP, NTFN\<close>
           apply (simp_all add: retype_region2_ext_retype_region bind_cong[OF curDomain_mapM_x_futz refl, unfolded bind_assoc]
                     split del: if_split)[9] (* not PageDirectoryObject *)
           apply (rule corres_guard_imp)
             apply (rule corres_split_eqr)
                apply (rule corres_split_nor)
                   apply (rule corres_trivial, simp)
                   apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2
                  objBits_simps APIType_map2_def)
                  apply (simp add: APIType_map2_def)
                  apply (rule retype_region2_extra_ext_mapM_x_corres)
                 apply wp
                apply wp
               apply (rule corres_retype[where 'a = tcb],
                      simp_all add: obj_bits_api_def objBits_simps' pageBits_def
                                   APIType_map2_def makeObjectKO_def
                                   other_objs_default_relation)[1]
               apply (fastforce simp: range_cover_def)
              apply ((wp retype_region2_obj_at | simp add: APIType_map2_def)+)[1]
             apply ((wp createObjects_tcb_at'[where sz=sz] | simp add: APIType_map2_def objBits_simps' obj_bits_api_def)+)[1]
            apply simp
           apply simp
          apply (subst retype_region2_extra_ext_trivial)
           apply (simp add: APIType_map2_def)
          apply (simp add: liftM_def[symmetric] split del: if_split)
          apply (rule corres_rel_imp)
           apply (rule corres_guard_imp)
             apply (rule corres_retype[where 'a = endpoint],
                    simp_all add: obj_bits_api_def objBits_simps' pageBits_def
                                  APIType_map2_def makeObjectKO_def
                                  other_objs_default_relation)[1]
             apply (fastforce simp: range_cover_def)
            apply simp
           apply simp
          apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2
                                objBits_simps APIType_map2_def)
         apply (subst retype_region2_extra_ext_trivial)
          apply (simp add: APIType_map2_def)
         apply (simp add: liftM_def[symmetric] split del: if_split)
         apply (rule corres_rel_imp)
          apply (rule corres_guard_imp)
            apply (rule corres_retype[where 'a = notification],
                   simp_all add: obj_bits_api_def objBits_simps' pageBits_def
                                 APIType_map2_def makeObjectKO_def
                                 other_objs_default_relation)[1]
            apply (fastforce simp: range_cover_def)
           apply simp
          apply simp
         apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2
                               objBits_simps APIType_map2_def)
        \<comment> \<open>CapTable\<close>
        apply (subst retype_region2_extra_ext_trivial)
         apply (simp add: APIType_map2_def)
        apply (subst bind_assoc_reverse[of "createObjects y n (KOCTE makeObject) us"])
        apply (subst liftM_def
               [of "map (\<lambda>addr. capability.CNodeCap addr us 0 0)", symmetric])
        apply simp
        apply (rule corres_rel_imp)
         apply (rule corres_guard_imp)
           apply (rule corres_retype_update_gsI,
                 simp_all add: obj_bits_api_def objBits_simps' pageBits_def
                               APIType_map2_def makeObjectKO_def slot_bits_def
                               field_simps ext)[1]
            apply (simp add: range_cover_def)
           apply (rule captable_relation_retype,simp add: range_cover_def word_bits_def)
          apply simp
         apply simp
        apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2
                              objBits_simps allRights_def APIType_map2_def
                   split del: if_split)
          \<comment> \<open>SmallPageObject\<close>
       apply (subst retype_region2_extra_ext_trivial)
        apply (simp add: APIType_map2_def)
       apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split)
       apply (rule corres_rel_imp)
        apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split)
        apply (rule corres_guard_imp)
          apply (rule corres_retype_update_gsI,
                 simp_all add: APIType_map2_def makeObjectKO_def
                     arch_default_cap_def obj_bits_api_def3
                     default_object_def default_arch_object_def pageBits_def
                     ext objBits_simps range_cover.aligned,
                     simp_all add: data_page_relation_retype)[1]
         apply simp+
       apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def
                vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same)
         \<comment> \<open>LargePageObject\<close>
      apply (subst retype_region2_extra_ext_trivial)
       apply (simp add: APIType_map2_def)
      apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split)
      apply (rule corres_rel_imp)
       apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split)
       apply (rule corres_guard_imp)
         apply (rule corres_retype_update_gsI,
                simp_all add: APIType_map2_def makeObjectKO_def
                    arch_default_cap_def obj_bits_api_def3
                    default_object_def default_arch_object_def pageBits_def
                    ext objBits_simps range_cover.aligned,
                    simp_all add: data_page_relation_retype)[1]
        apply simp+
      apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def
               vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same)
        \<comment> \<open>SectionObject\<close>
     apply (subst retype_region2_extra_ext_trivial)
      apply (simp add: APIType_map2_def)
     apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split)
     apply (rule corres_rel_imp)
      apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split)
      apply (rule corres_guard_imp)
        apply (rule corres_retype_update_gsI,
               simp_all add: APIType_map2_def makeObjectKO_def
                   arch_default_cap_def obj_bits_api_def3
                   default_object_def default_arch_object_def pageBits_def
                   ext objBits_simps range_cover.aligned,
                   simp_all add: data_page_relation_retype)[1]
       apply simp+
     apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def
              vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same)
    \<comment> \<open>SuperSectionObject\<close>
    apply (subst retype_region2_extra_ext_trivial)
     apply (simp add: APIType_map2_def)
    apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split)
    apply (rule corres_rel_imp)
     apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split)
     apply (rule corres_guard_imp)
       apply (rule corres_retype_update_gsI,
              simp_all add: APIType_map2_def makeObjectKO_def
                  arch_default_cap_def obj_bits_api_def3
                  default_object_def default_arch_object_def pageBits_def
                  ext objBits_simps range_cover.aligned,
                  simp_all add: data_page_relation_retype)[1]
      apply simp+
    apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def
             vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same)
  \<comment> \<open>PageTable\<close>
   apply (subst retype_region2_extra_ext_trivial)
    apply (simp add: APIType_map2_def)
   apply (simp_all add: corres_liftM2_simp[unfolded liftM_def])
   apply (rule corres_guard_imp)
    apply (simp add: init_arch_objects_APIType_map2_noop)
    apply (rule corres_rel_imp)
       apply (rule corres_retype[where 'a =pte],
            simp_all add: APIType_map2_def obj_bits_api_def
                          default_arch_object_def objBits_simps
                          archObjSize_def ptBits_def pageBits_def
                          pteBits_def pdeBits_def
                          makeObjectKO_def range_cover.aligned)[1]
     apply (rule pagetable_relation_retype)
    apply (wp | simp)+
    apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same
                          APIType_map2_def arch_default_cap_def)
   apply simp+
  \<comment> \<open>PageDirectory\<close>
  apply (rule corres_guard_imp)
    apply (rule corres_split_eqr)
       apply (simp add: init_arch_objects_def APIType_map2_def
                        bind_assoc)
       apply (rule corres_split_nor)
          apply (simp add: liftM_def[symmetric] o_def list_all2_map1
                           list_all2_map2 list_all2_same
                           arch_default_cap_def mapM_x_mapM)
          apply (simp add: dc_def[symmetric])
          apply (rule corres_machine_op)
          apply (rule corres_Id)
            apply (simp add: shiftl_t2n shiftL_nat
                             pdBits_def ptBits_def pageBits_def pt_bits_def)
            defer
            apply simp
           apply (simp add: mapM_discarded[where g = "return ()",simplified,symmetric])
           apply (rule no_fail_pre)
            apply (wp no_fail_mapM|clarsimp)+
          apply (simp add: mapM_x_mapM)
          apply (rule corres_underlying_split[where r' = dc])
             apply (rule_tac Q="\<lambda>xs s. (\<forall>x \<in> set xs. page_directory_at x s)
                                    \<and> valid_arch_state s \<and> pspace_aligned s \<and> valid_etcbs s"
                          and Q'="\<lambda>xs s. (\<forall>x \<in> set xs. page_directory_at' x s) \<and> valid_arch_state' s"
                          in corres_mapM_list_all2[where r'=dc and S="(=)"])
                  apply simp+
                apply (rule corres_guard_imp, rule copyGlobalMappings_corres)
                 apply simp+
               apply (wp hoare_vcg_const_Ball_lift | simp)+
             apply (simp add: list_all2_same)
            apply (rule corres_return[where P =\<top> and P'=\<top>,THEN iffD2])
            apply simp
           apply wp+
       apply (rule corres_retype[where ty = "Inr PageDirectoryObject" and 'a = pde
                    , simplified, folded retype_region2_ext_retype_region_ArchObject_PageDirectoryObj],
              simp_all add: APIType_map2_def obj_bits_api_def
                            default_arch_object_def objBits_simps
                            archObjSize_def pdBits_def pageBits_def
                            pteBits_def pdeBits_def
                            makeObjectKO_def)[1]
        apply (simp add: range_cover_def)+
       apply (rule pagedirectory_relation_retype)
      apply (wp | simp)+
      apply (rule hoare_vcg_conj_lift)
       apply (rule hoare_post_imp)
        prefer 2
        apply (rule hoare_vcg_conj_lift)
         apply (rule retype_region_obj_at)
         apply (simp add: APIType_map2_def)
        apply (subst APIType_map2_def, simp)
        apply (rule retype_region_ret)
       apply (clarsimp simp: retype_addrs_def obj_bits_api_def APIType_map2_def
                  default_arch_object_def default_object_def)
       apply (clarsimp simp: obj_at_def a_type_def)
      apply (wp retype_region_valid_arch retype_region_aligned|simp)+
     apply (clarsimp simp: objBits_simps retype_addrs_def obj_bits_api_def
                           APIType_map2_def default_arch_object_def default_object_def)
     apply (rule hoare_vcg_conj_lift)
      apply (rule hoare_post_imp)
       prefer 2
       apply (rule hoare_vcg_conj_lift)
        apply (rule createObjects_ko_at[where sz = sz and 'a = pde])
          apply (simp add: objBits_simps archObjSize_def pdBits_def
                           pteBits_def pdeBits_def
                           pageBits_def page_directory_at'_def)+
        apply (simp add: projectKOs)
       apply (rule createObjects_aligned)
          apply (simp add: objBits_simps archObjSize_def pdBits_def
                        pageBits_def page_directory_at'_def)+
          apply (simp add: range_cover_def pteBits_def pdeBits_def)
         apply (rule le_less_trans[OF range_cover.range_cover_n_le(2) power_strict_increasing])
           apply simp
          apply (clarsimp simp: range_cover_def word_bits_def)
          apply arith+
       apply (simp add: objBits_simps archObjSize_def pdBits_def
                        pageBits_def page_directory_at'_def)+
       apply (simp add: range_cover_def word_bits_def pteBits_def pdeBits_def)
      apply clarsimp
      apply (drule (1) bspec)+
      apply (simp add: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def
                       ptBits_def APIType_map2_def default_arch_object_def default_object_def
                       archObjSize_def)
      apply (clarsimp simp: objBits_simps archObjSize_def pdBits_def
                            pageBits_def page_directory_at'_def
                            pteBits_def pdeBits_def)
      apply (drule_tac x = ya in spec)
      apply (clarsimp simp:typ_at'_def obj_at'_real_def)
      apply (erule ko_wp_at'_weakenE)
      apply (clarsimp simp: projectKOs)
     apply (wp createObjects_valid_arch)
    apply (auto simp: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def ptBits_def
                      APIType_map2_def default_arch_object_def default_object_def archObjSize_def
                      pteBits_def pdeBits_def
                      pd_bits_def fromIntegral_def toInteger_nat fromInteger_nat)
 done

end
end