KernelInitSep_AI.thy

(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(GD_GPL)
 *)

theory KernelInitSep_AI
imports
  "../../spec/abstract/KernelInit_A"
  "../../lib/sep_algebra/Sep_Algebra_L4v"
  Invariants_AI
begin

(* UNFINISHED; paused project *)

text {* Migration candidates *}

lemma hoare_gen_asmE':
  (* XXX: this should be the non-' version really, which is misnamed *)
  "(P \<Longrightarrow> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>) \<Longrightarrow> \<lbrace>P' and (K P)\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
  by (simp add: validE_R_def validE_def valid_def) blast

lemma unat_less_power_n:
  "n = 2 ^ len_of TYPE('a) \<Longrightarrow> unat (x::'a::len word) < n"
  by (simp add: unat_less_power)

lemma subset_union:
  "S \<subset> T \<Longrightarrow> (S \<union> T) = T"
  by blast

lemma singleton_subsetI:
  "\<lbrakk> i \<in> S ; S - {i} \<noteq> {} \<rbrakk> \<Longrightarrow> {i} \<subset> S"
  by blast

lemma bl_length_set_equal:
  fixes i :: "bool list"
  shows "{x. length x = length i} = {i} \<Longrightarrow> i = []"
  apply (cases i, clarsimp)
  apply (drule_tac x="(\<not>a) # list" in eqset_imp_iff)
  apply simp
  done

lemma bl_length_set_singleton_subset:
  fixes i :: "bool list"
  assumes notnil: "i \<noteq> []"
  shows "{i} \<subset> {x. length x = length i}" (is "_ \<subset> ?s")
  using notnil
proof -
  from notnil obtain b bs where i: "i = b # bs" by (cases i, simp)

  have b: "b # bs \<in> ?s" using i by simp
  have notb: "(\<not>b) # bs \<in> ?s" using i by simp

  from b notb have "?s - {b # bs} \<noteq> {}" by blast

  thus ?thesis using i by (auto intro!: singleton_subsetI)
qed

lemma insert_same_length_id:
  "insert i {x. length x = length i} = {x. length x = length i}"
  by auto


text {*
  Recursive sequence of length n along a ring, starting at p.
  Wrapping permitted. *}
primrec
  len_seq :: "'a::ring_1 \<Rightarrow> nat \<Rightarrow> 'a list"
where
  "len_seq p 0 = []"
| "len_seq p (Suc n) = p # (len_seq (p + 1) n)"

lemma len_seq_length [simp]:
  fixes p :: "'a::ring_1"
  shows "length (len_seq p sz) = sz"
  by (induct sz arbitrary: p, auto)

lemma len_seq_Cons:
  "0 < sz \<Longrightarrow> len_seq p sz = p # len_seq (p+1) (sz - 1)"
  by (induct sz arbitrary: p, auto)

lemma map_fun_Suc_upt_Cons:
  assumes xn: "x \<le> n"
  assumes gf: "\<And>n. g (Suc n) = f n"
  shows "map g [x..<Suc n] = (g x) # map f [x..<n]"
proof -
  have ss: "[Suc x..<Suc n] = map Suc [x..<n]"
    by (subst map_Suc_upt[symmetric], rule refl)
  show ?thesis using xn
    by (simp add: upt_conv_Cons ss gf del: upt_Suc)
qed

lemma len_seq_map_upt_eq:
  fixes p :: "'a::ring_1"
  shows "len_seq p sz = map (\<lambda>n. p + of_nat n) [0..<sz]"
proof (induct sz arbitrary: p)
  case 0 thus ?case by simp
next
  case (Suc sz)
  hence IH: "len_seq (p + 1) sz = map (\<lambda>n. p + 1 + of_nat n) [0..<sz]" by simp
  show ?case
    by (simp only: len_seq.simps IH map_fun_Suc_upt_Cons) fastforce
qed

lemma len_seq_no_wrap:
  fixes p :: "'a :: len word"
  assumes sz: "n < 2 ^ len_of TYPE('a)"
  shows "p \<notin> set (len_seq (p + 1) n)"
proof (rule ccontr, simp)
  assume pin: "p \<in> set (len_seq (p + 1) n)"
  then obtain q where q: "p + 1 + of_nat q = p" and qn: "q < n"
    by (auto simp: len_seq_map_upt_eq)
  hence "of_nat q + 1 = (0 :: 'a word)" by (simp add: add_commute)

  moreover
  from qn have "of_nat q + (1::'a word) \<noteq> 0" using sz
    by (fastforce intro!: less_is_non_zero_p1[where k="of_nat n :: 'a word"]
                 intro: word_of_nat_less simp: unat_of_nat_eq)

  ultimately show False by blast
qed


section {* Definitions *}

subsection {* Partial Validity of Kernel Objects (i.e. cnodes) *}

text {* Same as @{term "well_formed_cnode_n"}, but allow gaps. *}
definition
  bounded_cnode_n :: "nat \<Rightarrow> cnode_contents \<Rightarrow> bool" where
  "bounded_cnode_n n \<equiv> \<lambda>cs. \<forall>x \<in> dom cs. length x = n"

text {* Same as @{term "valid_cs_size"}, but allowing gaps *}
definition
  bounded_cs_size :: "nat \<Rightarrow> cnode_contents \<Rightarrow> bool" where
  "bounded_cs_size sz cs \<equiv> sz < word_bits - cte_level_bits
                           \<and> bounded_cnode_n sz cs"

text {*
  Kernel object respects bounds set by its own size. This is only a problem
  for cnodes.
*}
definition
  bounded_ko :: "kernel_object \<Rightarrow> bool" where
  "bounded_ko ko = (case ko of CNode sz cs \<Rightarrow> bounded_cs_size sz cs
                             | _ \<Rightarrow> True)"

subsection {*
  Types and sizes of abstract kernel objects without checking any
  well-formedness. *}

text {* Like @{term "a_type"}, but don't check wellformed on cnodes *}
definition
  a_base_type :: "Structures_A.kernel_object \<Rightarrow> a_type" where
 "a_base_type ko \<equiv> case ko of
           CNode sz cspace          \<Rightarrow> ACapTable sz
         | TCB tcb                  \<Rightarrow> ATCB
         | Endpoint endpoint        \<Rightarrow> AEndpoint
         | AsyncEndpoint async_ep   \<Rightarrow> AAEP
         | ArchObj ao               \<Rightarrow> AArch (case ao of
           PageTable pt             \<Rightarrow> APageTable
         | PageDirectory pd         \<Rightarrow> APageDirectory
         | DataPage sz              \<Rightarrow> AIntData sz
         | ARM_Structs_A.ASIDPool f \<Rightarrow> AASIDPool)"

lemmas a_base_type_simps [simp] =
  a_base_type_def [split_simps kernel_object.split arch_kernel_obj.split]

text {*
  These correspond to @{term "arch_kobj_size"} and @{term "obj_bits"}, but
  since we can derive all the information necessary from the type, we use the
  type.
  We provide abbreviations for convenience;
  @{text "a_base_type_bits (a_base_type ...)"} is rather verbose.
*}

definition
  aa_base_type_bits :: "aa_type \<Rightarrow> nat" where
  "aa_base_type_bits t \<equiv>
    case t of APageTable \<Rightarrow> 10
            | APageDirectory \<Rightarrow> 14
            | AIntData sz \<Rightarrow> pageBitsForSize sz
            | AASIDPool \<Rightarrow> pageBits"

lemmas aa_base_type_bits_simps [simp] =
  aa_base_type_bits_def [split_simps aa_type.split]

definition
  a_base_type_bits :: "a_type \<Rightarrow> nat" where
  "a_base_type_bits t \<equiv>
    case t of ACapTable sz \<Rightarrow> cte_level_bits + sz
            | ATCB \<Rightarrow> 9
            | AEndpoint \<Rightarrow> 4
            | AAEP \<Rightarrow> 4
            | AArch aot \<Rightarrow> aa_base_type_bits aot"

lemmas a_base_type_bits_simps [simp] =
  a_base_type_bits_def [split_simps a_type.split]

abbreviation
  "t_obj_bits ko \<equiv> a_base_type_bits (a_base_type ko)"

lemmas t_obj_bits_def = a_base_type_bits_def

text {*
  Whether an index is a valid cnode index for the given type, i.e.\ can we set
  that cap to something and end up with a bounded object.
  *}

definition
  abt_valid_cnode_index :: "a_type \<Rightarrow> cnode_index \<Rightarrow> bool" where
  "abt_valid_cnode_index atyp i \<equiv> (case atyp
     of ACapTable sz \<Rightarrow> length i = sz
      | ATCB \<Rightarrow> i \<in> tcb_cnode_index ` {0,1,2,3,4}
      | _ \<Rightarrow> False)"

abbreviation
  "valid_cnode_index ko \<equiv> abt_valid_cnode_index (a_base_type ko)"

lemmas valid_cnode_index_def = abt_valid_cnode_index_def


subsection {* Component structure of objects *}

text {*
  Components available for given object types.
*}

text {*
  What components are available for a given kernel object
  (we should see a subset of these in the ghost state).
  Note that [] is the ``fields'' component, containing unsplittable information for a
  given object, such as non-cap fields of a tcb or all fields of an endpoint. *}

primrec
  aa_base_type_components :: "aa_type \<Rightarrow> component set" where
  "aa_base_type_components AASIDPool = {x. length x = 10}" (* 2^10 components *)
| "aa_base_type_components APageTable = {x. length x = 8}" (* 2^8 components *)
| "aa_base_type_components APageDirectory = {x. length x = 12}" (* 2^12 components *)
| "aa_base_type_components (AIntData sz) = {}" (* no core, type only *)

primrec
  a_base_type_components :: "a_type \<Rightarrow> component set" where
  "a_base_type_components (ACapTable sz) = {x. length x = sz}"
| "a_base_type_components ATCB = insert [] (tcb_cnode_index ` {0,1,2,3,4})"
                                 (* core & 5 caps *)
| "a_base_type_components AEndpoint = {[]}" (* core only *)
| "a_base_type_components AAEP = {[]}" (* core only *)
| "a_base_type_components (AArch aot) = aa_base_type_components aot"

abbreviation
  "ko_components ko \<equiv> a_base_type_components (a_base_type ko)"

text {* Relationship between caps and components. *}

(* XXX: see @{text "nat_to_cref"} *)
definition
  a_base_type_cmp_of :: "a_type \<Rightarrow> cnode_index \<Rightarrow> component" where
  "a_base_type_cmp_of atyp i \<equiv> case atyp of ACapTable _ \<Rightarrow> i
                                          | ATCB \<Rightarrow> i"

abbreviation
  "cmp_of ko \<equiv> a_base_type_cmp_of (a_base_type ko)"


subsection {* Component-wise Combining of Kernel Objects *}

text {*
  Combining objects of the same type (strictly speaking it's a right override,
  although realistically it only makes sense if the first object's components
  are disjoint from those of the second). Crucially, NOT DEFINED for two
  objects of different types, as that makes no sense whatsoever. *}

definition
  ao_override :: "arch_kernel_obj \<Rightarrow> arch_kernel_obj \<Rightarrow> component set
                 \<Rightarrow> arch_kernel_obj" where
  "ao_override obj1 obj2 cmps \<equiv>
     (case obj1
        of ASIDPool o1 \<Rightarrow>
             (case obj2 of ASIDPool o2 \<Rightarrow>
                ASIDPool (\<lambda>bs. if to_bl bs \<in> cmps then o2 bs else o1 bs))
         | PageTable o1 \<Rightarrow>
             (case obj2 of PageTable o2 \<Rightarrow>
                PageTable (\<lambda>bs. if to_bl bs \<in> cmps then o2 bs else o1 bs))
         | PageDirectory o1 \<Rightarrow>
             (case obj2 of PageDirectory o2 \<Rightarrow>
                PageDirectory (\<lambda>bs. if to_bl bs \<in> cmps then o2 bs else o1 bs))
         | DataPage o1 \<Rightarrow> (case obj2 of DataPage o2 \<Rightarrow> DataPage o2))"
           (* DataPage has no core, type only *)

definition
  tcb_override :: "Structures_A.tcb \<Rightarrow> Structures_A.tcb \<Rightarrow> component set
                   \<Rightarrow> Structures_A.tcb" where
  (* 5 fields counted as "core" (component []), plus 5 caps (tcb_cnode_index 0..4) *)
  "tcb_override t1 t2 cmps \<equiv>
     t1\<lparr> tcb_state := tcb_state (if [] \<in> cmps then t2 else t1),
         tcb_fault_handler := tcb_fault_handler (if [] \<in> cmps then t2 else t1),
         tcb_ipc_buffer := tcb_ipc_buffer (if [] \<in> cmps then t2 else t1),
         tcb_context := tcb_context (if [] \<in> cmps then t2 else t1),
         tcb_fault := tcb_fault (if [] \<in> cmps then t2 else t1),
         tcb_ctable := tcb_ctable (if tcb_cnode_index 0 \<in> cmps then t2 else t1),
         tcb_vtable := tcb_vtable (if tcb_cnode_index 1 \<in> cmps then t2 else t1),
         tcb_reply := tcb_reply (if tcb_cnode_index 2 \<in> cmps then t2 else t1),
         tcb_caller := tcb_caller (if tcb_cnode_index 3 \<in> cmps then t2 else t1),
         tcb_ipcframe := tcb_ipcframe (if tcb_cnode_index 4 \<in> cmps then t2 else t1)
       \<rparr>"

definition
  ko_override :: "Structures_A.kernel_object \<Rightarrow> Structures_A.kernel_object
                 \<Rightarrow> component set \<Rightarrow> Structures_A.kernel_object" where
  "ko_override obj1 obj2 cmps =
     (case obj1
        of CNode sz o1 \<Rightarrow>
           (case obj2 of CNode sz2 o2 \<Rightarrow>
              CNode sz2 (\<lambda>bs. if bs \<in> cmps then o2 bs else o1 bs))
         | TCB o1 \<Rightarrow> (case obj2 of TCB o2 \<Rightarrow> TCB (tcb_override o1 o2 cmps))
         | Endpoint o1 \<Rightarrow>
           (case obj2 of Endpoint o2 \<Rightarrow>
              Endpoint (if [] \<in> cmps then o2 else o1)) (* core only *)
         | AsyncEndpoint o1 \<Rightarrow>
           (case obj2 of AsyncEndpoint o2 \<Rightarrow>
              AsyncEndpoint (if [] \<in> cmps then o2 else o1) (* core only *))
         | ArchObj ao1 \<Rightarrow>
           (case obj2 of ArchObj ao2 \<Rightarrow> ArchObj (ao_override ao1 ao2 cmps)))"

text {*
  Object ``cleaning'', i.e. getting the components we don't have into a known
  state. Otherwise if we combine @{text "(cnode1,{to_bl 2, to_bl 3})"} and
  @{text "(cnode2,{to_bl 4, to_bl 5})"} we don't
  know anything about component @{text "to_bl 1"}, and so can't claim commutativity.

  Using undefined everywhere, as expected, except for CNodes where
  CNode undefined is not necessarily well-formed, which affects its type.
  *}

definition
  ao_clean :: "arch_kernel_obj \<Rightarrow> component set \<Rightarrow> arch_kernel_obj" where
  "ao_clean ao cmps \<equiv>
    (case ao
       of ARM_Structs_A.ASIDPool aobj \<Rightarrow>
            ao_override (ARM_Structs_A.ASIDPool undefined) ao cmps
        | PageTable aobj \<Rightarrow> ao_override (PageTable undefined) ao cmps
        | PageDirectory aobj \<Rightarrow> ao_override (PageDirectory undefined) ao cmps
        | DataPage aobj \<Rightarrow> DataPage aobj)" (* type only *)

definition
  ko_clean :: "kernel_object \<Rightarrow> component set \<Rightarrow> kernel_object" where
  "ko_clean ko cmps \<equiv>
    (case ko
       of CNode sz obj \<Rightarrow> ko_override (CNode sz empty) ko cmps
        | TCB obj \<Rightarrow> ko_override (TCB undefined) ko cmps
        | Endpoint obj \<Rightarrow> ko_override (Endpoint undefined) ko cmps
        | AsyncEndpoint obj \<Rightarrow> ko_override (AsyncEndpoint undefined) ko cmps
        | ArchObj obj \<Rightarrow> ArchObj (ao_clean obj cmps))"


text {* Combining objects *}

definition
  ko_combine :: "(kernel_object \<times> component set)
                 \<Rightarrow> (kernel_object \<times> component set)
                 \<Rightarrow> (kernel_object \<times> component set)" where
  "ko_combine kcmp1 kcmp2 \<equiv>
    (case kcmp1 of (o1,cs1) \<Rightarrow> (case kcmp2 of (o2,cs2) \<Rightarrow>
    (ko_override (ko_clean o1 cs1) (ko_clean o2 cs2) cs2, cs1 \<union> cs2)))"


text {* Updating a cap in a specific kernel object *}

text {*
  This is the non-monadic counterpart to @{term set_cap_local}.
  We use silent failure here, since we want generic lemmas to hold, such
  as that @{term set_ko_cap} preserves the kernel object type. If we returned
  undefined, we can't prove those without the extra assumption everywhere that
  @{term "cap_of ko i = Some c"}.
*}

definition (* non-monadic counterpart to set_cap(_local) *)
  set_ko_cap :: "kernel_object \<Rightarrow> cnode_index \<Rightarrow> cap \<Rightarrow> kernel_object" where
  "set_ko_cap ko i cap \<equiv>
    (case ko of CNode sz cn \<Rightarrow> CNode sz (cn(i \<mapsto> cap))
              | TCB tcb \<Rightarrow>
                   (if i = tcb_cnode_index 0 then
                       TCB $ tcb \<lparr> tcb_ctable := cap \<rparr>
                   else if i = tcb_cnode_index 1 then
                       TCB $ tcb \<lparr> tcb_vtable := cap \<rparr>
                   else if i = tcb_cnode_index 2 then
                       TCB $ tcb \<lparr> tcb_reply := cap \<rparr>
                   else if i = tcb_cnode_index 3 then
                       TCB $ tcb \<lparr> tcb_caller := cap \<rparr>
                   else if i = tcb_cnode_index 4 then
                       TCB $ tcb \<lparr> tcb_ipcframe := cap \<rparr>
                   else
                       ko)
              | _ \<Rightarrow> ko)"


subsection {* Object-component Maps *}

text {*
  When we annotate the abstract kernel heap with the components of kernel
  objects we are allowed to access at each address, we get an
  object-component map. This map is the core of the separation logic, since
  it allows us to perform local reasoning beyond the granularity of a kernel
  object. In other words, if we have a kernel object at address p in two
  kheaps, we can still call the heaps disjoint if they are annotated with
  disjoint components.

  In lemmas, ``object-component map'' is typically abbreviated to ``ocm''.
*}

type_synonym
  obj_comp_map = "paddr \<rightharpoonup> (kernel_object \<times> component set)"

definition
  ko_has_cap :: "kernel_object \<Rightarrow> component set \<Rightarrow> cnode_index \<Rightarrow> cap \<Rightarrow> bool"
  where
  "ko_has_cap ko cmps i c \<equiv> cap_of (ko_clean ko cmps) i = Some c \<and>
                            (cmp_of ko i) \<in> cmps"

definition
  "ocm_has_cap ocm p ko cmps i c \<equiv> ocm p = Some (ko, cmps) \<and>
                                   ko_has_cap ko cmps i c"

definition
  obj_comp_map_add :: "obj_comp_map \<Rightarrow> obj_comp_map \<Rightarrow> obj_comp_map" where
  "obj_comp_map_add h1 h2 \<equiv>
     (\<lambda>p. (case h1 p
             of Some oc1 \<Rightarrow> (case h2 p
                              of Some oc2 \<Rightarrow> Some (ko_combine oc1 oc2)
                               | None \<Rightarrow> Some oc1)
              | None \<Rightarrow> h2 p))"

text {*
  Disjunction (per address):
  If it's in one heap but not the other (or in neither),
  consider the object maps disjoint.

  Looking at the objects through only the components we have:
    If the objects have different types, they are not disjoint.
    If the objects have the same type, but the different heaps cover different
    components, then they are disjoint.

  Exceptions to the above when both objects have the same type:
    If an object is structurally unsound (i.e. is a cnode with entries not of
    the right length), we treat the component coverage as if it was
    @{term "UNIV"}.
    If a component set is either @{term "{}"} or includes components outside
    of sane values for the given object type, we treat it as @{term "UNIV"}.

  We need the exceptions in order to be able to define a predicate that says
  ``we have the entire object and all information about it'', and be able to
  detype/retype this object while preserving the frame rule. If we can
  construct anything separate from the entire object that also talks about the
  object's type, we cannot prove the frame rule. This means no objects with no
  components or ficticious components (they convey no information except the
  object type at that address). This also means no magical cnodes where a
  cnode of size 2 can suddenly develop a entry over 9000.
*}

definition
  "sane_components ko cmps \<equiv> bounded_ko ko \<and> cmps \<noteq> {}
                             \<and> cmps \<subseteq> ko_components ko"

definition
  "check_components ko cmps \<equiv> if sane_components ko cmps then cmps else UNIV"

definition
  obj_comp_map_disj :: "obj_comp_map \<Rightarrow> obj_comp_map \<Rightarrow> bool" where
  "obj_comp_map_disj h1 h2 \<equiv>
     (\<forall>p. case (h1 p, h2 p)
            of (Some (o1,c1), Some (o2,c2))
                 \<Rightarrow> a_base_type o1 = a_base_type o2
                    \<and> check_components (ko_clean o1 c1) c1
                      \<inter> check_components (ko_clean o2 c2) c2 = {}
             | _ \<Rightarrow> True)"


subsection {*
  State used for separation algebra; encompasses the object-component map, as well as free and available memory.
*}

datatype sep_state = SepState obj_comp_map "obj_ref set" "obj_ref set"
                           (* comp. map    free mem      avail mem *)

type_synonym
  sep_assert = "sep_state \<Rightarrow> bool"

translations
  (type) "sep_assert" <= (type) "sep_state \<Rightarrow> bool"

text {* SepState accessors *}

definition
  sep_state_ocm :: "sep_state \<Rightarrow> obj_comp_map" where
  "sep_state_ocm s \<equiv> case s of SepState ocm _ _ \<Rightarrow> ocm"

definition
  sep_state_free :: "sep_state \<Rightarrow> obj_ref set" where
  "sep_state_free s \<equiv> case s of SepState _ free _ \<Rightarrow> free"

definition
  sep_state_avail :: "sep_state \<Rightarrow> obj_ref set" where
  "sep_state_avail s \<equiv> case s of SepState _ _ avail \<Rightarrow> avail"

lemmas sep_state_accessors =
  sep_state_ocm_def sep_state_free_def sep_state_avail_def

definition
  lift_sep_state :: "'z ki_state \<Rightarrow> sep_state" where
  "lift_sep_state ki \<equiv>
     let kh = kheap (ki_kernel_state ki)
     in SepState (\<lambda>p. case kh p
                        of Some obj \<Rightarrow> Some (ko_clean obj (ki_components ki p),
                                             ki_components ki p)
                         | _ \<Rightarrow> None)
                 (ki_free_mem ki)
                 (ki_available_mem ki)"

text {*
  Lifting a kernel state @{text "s"} onto an existing kernel init state
  @{text "kis"}. *}
abbreviation
  "kis_lift kis s \<equiv> lift_sep_state (kis\<lparr>ki_kernel_state := s\<rparr>)"

definition
  kheap_shadow :: "obj_comp_map \<Rightarrow> paddr \<Rightarrow> paddr set" where
  "kheap_shadow kh p \<equiv>
     set (len_seq (p+1) (2 ^ t_obj_bits (fst (the (kh p))) - 1))"

definition
  "kheap_shadows kh \<equiv> \<Union>(kheap_shadow kh ` dom kh)"

text {* Addresses used up by objects in the kernel heap *}
definition
  kheap_dom :: "(obj_comp_map) \<Rightarrow> paddr set" where
  "kheap_dom kh \<equiv> dom kh \<union> kheap_shadows kh"

definition
  sep_disj :: "sep_state \<Rightarrow> sep_state \<Rightarrow> bool" where
  (* if we try to combine two sane heaps, a region can't end up being:
     - free in one and available in the other
     - free/available in one and in the heap in the other
     - in both heaps with the same component
     - an object in one heap and a shadow (the Nones that follow an object
       until its last memory address) in the other
  *)
  "sep_disj s1 s2 =
     (case s1 of SepState kh1 free1 avail1 \<Rightarrow>
     (case s2 of SepState kh2 free2 avail2 \<Rightarrow>

     ((free1 \<union> avail1) \<inter> (free2 \<union> avail2) = {} \<and>
      kheap_dom kh1 \<inter> (free2 \<union> avail2) = {} \<and>
      kheap_dom kh2 \<inter> (free1 \<union> avail1) = {} \<and>
      obj_comp_map_disj kh1 kh2 \<and>
      kheap_shadows kh1 \<inter> dom kh2 = {} \<and>
      kheap_shadows kh2 \<inter> dom kh1 = {}) ))"

definition
  sep_add :: "sep_state \<Rightarrow> sep_state \<Rightarrow> sep_state" where
  "sep_add s1 s2 =
     (case s1 of SepState kh1 free1 avail1 \<Rightarrow>
     (case s2 of SepState kh2 free2 avail2 \<Rightarrow>
     SepState (obj_comp_map_add kh1 kh2) (free1 \<union> free2) (avail1 \<union> avail2)
     ))"

definition
  sep_empty :: "sep_state" where
  "sep_empty = SepState empty {} {}"


subsection {* Maps-to Predicates *}

text {* pretty raw function to talk about a single object's components at a given address *}
definition
  sep_map_base :: "paddr \<Rightarrow> kernel_object \<Rightarrow> component set \<Rightarrow> sep_assert" where
  "sep_map_base p ko cmps s \<equiv> (case s of SepState ocm free avail \<Rightarrow>
        ocm p = Some (ko_clean ko cmps, cmps) \<and>
        sane_components (ko_clean ko cmps) cmps \<and>
        dom ocm = {p} \<and> (* sep_conj takes care of shadow intersections *)
        is_aligned p (t_obj_bits ko) \<and>
        free = {} \<and>
        avail = {})"
  (* XXX: can this be the same as the empty assertion when cmps = {}? *)

text {* same thing, but talking about the entire object at an address *}
definition
  sep_map_ko :: "paddr \<Rightarrow> kernel_object \<Rightarrow> sep_assert" where
  "sep_map_ko p ko \<equiv> sep_map_base p ko (ko_components ko)"

text {*
  An object of the specified type with a set cap. We need to specify the type
  in order to be able to reassemble cnodes, and also to not have to prove
  things such as that @{const set_cap} doesn't change the object's type. *}
definition
  sep_map_cap :: "a_type \<Rightarrow> cslot_ptr \<Rightarrow> cap \<Rightarrow> sep_assert" where
  "sep_map_cap atyp cptr cap \<equiv> case cptr of (p,i) \<Rightarrow>
     (\<lambda>s. \<exists>ko. sep_map_base p ko {cmp_of ko i} s \<and>
               a_base_type ko = atyp \<and>
               cap_of ko i = Some cap)"

text {* declaring a region of memory is free (unallocated) *}
definition
  sep_free :: "paddr \<Rightarrow> nat \<Rightarrow> sep_assert" where
  "sep_free p sz s = (case s of SepState ocm free avail \<Rightarrow>
     (dom ocm = {} \<and> free = set (len_seq p sz) \<and> avail = {}))"

text {* declaring a region of memory is available (allocated but untyped) *}
definition
  sep_available :: "paddr \<Rightarrow> nat \<Rightarrow> sep_assert" where
  "sep_available p sz s = (case s of SepState ocm free avail \<Rightarrow>
     (dom ocm = {} \<and> free = {} \<and> avail = set (len_seq p sz)))"


subsection {* Cap-level Updates of the Kernel Init State *}

text {*
  The @{term sep_update_cap} function is equivalent to what
  @{term set_cap_local} does at the monadic kernel state level, but phrased
  non-monadically and more conveniently for the separation state level.
*}

definition
  sep_update_cap :: "cslot_ptr \<Rightarrow> cap \<Rightarrow> sep_state \<Rightarrow> sep_state" where
  "sep_update_cap cp cap s \<equiv> (case cp of (p,i) \<Rightarrow>
     (case s of SepState ocm f a \<Rightarrow>
     SepState (ocm(p \<mapsto> (set_ko_cap (fst (the (ocm p))) i cap,
                        snd (the (ocm p))))) f a ))"



section {* Proofs *} (* ------------------------------------------------- *)

subsection {* Component structure of objects *}

lemma bounded_ko_t_obj_bits:
  "bounded_ko ko \<Longrightarrow> t_obj_bits ko < word_bits"
  by (clarsimp simp: bounded_ko_def cte_level_bits_def word_bits_def
                     bounded_cs_size_def a_base_type_bits_def a_base_type_def
                     pageBitsForSize_def pageBits_def
               split: kernel_object.splits arch_kernel_obj.splits
                      vmpage_size.splits)

lemma tcb_eq: (* so the simplifier doesn't barf on tcb_override_commute *)
  "\<lbrakk> tcb_state (tcb1::Structures_A.tcb) = tcb_state (tcb2::Structures_A.tcb) ;
     tcb_fault_handler tcb1 = tcb_fault_handler tcb2 ;
     tcb_ipc_buffer tcb1 = tcb_ipc_buffer tcb2 ;
     tcb_context tcb1 = tcb_context tcb2 ;
     tcb_fault tcb1 = tcb_fault tcb2 ;
     tcb_ctable tcb1 = tcb_ctable tcb2 ;
     tcb_vtable tcb1 = tcb_vtable tcb2 ;
     tcb_reply tcb1 = tcb_reply tcb2 ;
     tcb_caller tcb1 = tcb_caller tcb2 ;
     tcb_ipcframe tcb1 = tcb_ipcframe tcb2 \<rbrakk> \<Longrightarrow> tcb1 = tcb2"
  by (cases tcb1, cases tcb2) auto

lemma tcb_cnode_index_not_Nil:
  "tcb_cnode_index i \<noteq> []"
  by (clarsimp simp: tcb_cnode_index_def)

lemma tcb_cnode_index_Nil_False [simp]:
  "(tcb_cnode_index i = []) = False"
  "([] = tcb_cnode_index i) = False"
  by (auto simp: tcb_cnode_index_not_Nil tcb_cnode_index_not_Nil[symmetric])


subsection {* Component-wise Combining of Kernel Objects *}

lemma tcb_override_index_simps:
  "tcb_override tcb tcb' {tcb_cnode_index 0}
     = tcb \<lparr>tcb_ctable := tcb_ctable tcb'\<rparr>"
  "tcb_override tcb tcb' {tcb_cnode_index (Suc 0)}
     = tcb \<lparr>tcb_vtable := tcb_vtable tcb'\<rparr>"
  "tcb_override tcb tcb' {tcb_cnode_index 2}
     = tcb \<lparr>tcb_reply := tcb_reply tcb'\<rparr>"
  "tcb_override tcb tcb' {tcb_cnode_index 3}
     = tcb \<lparr>tcb_caller := tcb_caller tcb'\<rparr>"
  "tcb_override tcb tcb' {tcb_cnode_index 4}
     = tcb \<lparr>tcb_ipcframe := tcb_ipcframe tcb'\<rparr>"
  by (simp_all add: tcb_override_def)

lemma tcb_field_cmp_right_simps:
  "[] \<in> cmps \<Longrightarrow> tcb_state (tcb_override tcb tcb' cmps) = tcb_state tcb'"
  "[] \<in> cmps \<Longrightarrow> tcb_fault_handler (tcb_override tcb tcb' cmps)
                   = tcb_fault_handler tcb'"
  "[] \<in> cmps \<Longrightarrow> tcb_ipc_buffer (tcb_override tcb tcb' cmps)
                   = tcb_ipc_buffer tcb'"
  "[] \<in> cmps \<Longrightarrow> tcb_context (tcb_override tcb tcb' cmps)
                   = tcb_context tcb'"
  "[] \<in> cmps \<Longrightarrow> tcb_fault (tcb_override tcb tcb' cmps)
                   = tcb_fault tcb'"
  "tcb_cnode_index 0 \<in> cmps \<Longrightarrow> tcb_ctable (tcb_override tcb tcb' cmps)
                                  = tcb_ctable tcb'"
  "tcb_cnode_index (Suc 0) \<in> cmps \<Longrightarrow> tcb_vtable (tcb_override tcb tcb' cmps)
                                        = tcb_vtable tcb'"
  "tcb_cnode_index 2 \<in> cmps \<Longrightarrow> tcb_reply (tcb_override tcb tcb' cmps)
                                  = tcb_reply tcb'"
  "tcb_cnode_index 3 \<in> cmps \<Longrightarrow> tcb_caller (tcb_override tcb tcb' cmps)
                                  = tcb_caller tcb'"
  "tcb_cnode_index 4 \<in> cmps \<Longrightarrow> tcb_ipcframe (tcb_override tcb tcb' cmps)
                                  = tcb_ipcframe tcb'"
  by (simp_all add: tcb_override_def)

lemma tcb_override_index_cmps_simps:
  "tcb_cnode_index 0 \<in> cmps
   \<Longrightarrow> tcb_override ko (ko'\<lparr>tcb_ctable := cap\<rparr>) cmps
   = tcb_override ko ko' cmps \<lparr>tcb_ctable := cap\<rparr>"
  "tcb_cnode_index (Suc 0) \<in> cmps
   \<Longrightarrow> tcb_override ko (ko'\<lparr>tcb_vtable := cap\<rparr>) cmps
   = tcb_override ko ko' cmps \<lparr>tcb_vtable := cap\<rparr>"
  "tcb_cnode_index 2 \<in> cmps
   \<Longrightarrow> tcb_override ko (ko'\<lparr>tcb_reply := cap\<rparr>) cmps
   = tcb_override ko ko' cmps \<lparr>tcb_reply := cap\<rparr>"
  "tcb_cnode_index 3 \<in> cmps
   \<Longrightarrow> tcb_override ko (ko'\<lparr>tcb_caller := cap\<rparr>) cmps
   = tcb_override ko ko' cmps \<lparr>tcb_caller := cap\<rparr>"
  "tcb_cnode_index 4 \<in> cmps
   \<Longrightarrow> tcb_override ko (ko'\<lparr>tcb_ipcframe := cap\<rparr>) cmps
   = tcb_override ko ko' cmps \<lparr>tcb_ipcframe := cap\<rparr>"
  by (simp_all add: tcb_override_def)

lemma tcb_override_index_sub_cmps_simps:
  "tcb_override ko ko' (cmps - {tcb_cnode_index 0}) \<lparr> tcb_ctable := cap \<rparr>
   = tcb_override ko ko' cmps \<lparr> tcb_ctable := cap \<rparr>"
  "tcb_override ko ko' (cmps - {tcb_cnode_index (Suc 0)}) \<lparr> tcb_vtable := cap \<rparr>
   = tcb_override ko ko' cmps \<lparr> tcb_vtable := cap \<rparr>"
  "tcb_override ko ko' (cmps - {tcb_cnode_index 2}) \<lparr> tcb_reply := cap \<rparr>
   = tcb_override ko ko' cmps \<lparr> tcb_reply := cap \<rparr>"
  "tcb_override ko ko' (cmps - {tcb_cnode_index 3}) \<lparr> tcb_caller := cap \<rparr>
   = tcb_override ko ko' cmps \<lparr> tcb_caller := cap \<rparr>"
  "tcb_override ko ko' (cmps - {tcb_cnode_index 4}) \<lparr> tcb_ipcframe := cap \<rparr>
   = tcb_override ko ko' cmps \<lparr> tcb_ipcframe := cap \<rparr>"
  by (simp_all add: tcb_override_def)

text {*
  Unfolding @{text tcb_override_def} the index is known is a really bad idea
  in terms of simplifier performance in actual lemmas. These rules help avoid
  that scenario. *}
lemmas tcb_override_index_assist = tcb_override_index_simps
         tcb_override_index_cmps_simps tcb_override_index_sub_cmps_simps
         tcb_field_cmp_right_simps

lemma ko_clean_preserves_type [simp]:
  "a_base_type (ko_clean ko cmps) = a_base_type ko"
  by (auto simp: ko_clean_def ko_override_def ao_clean_def ao_override_def
           split: kernel_object.splits arch_kernel_obj.splits)

lemma t_obj_bits_ko_clean_simp [simp]:
  "t_obj_bits (ko_clean ko cmps) = t_obj_bits ko"
  by (clarsimp split: Structures_A.kernel_object.splits arch_kernel_obj.splits)

lemma ko_components_ko_clean_simp [simp]:
  "ko_components (ko_clean ko cmps) = ko_components ko"
  by (clarsimp split: Structures_A.kernel_object.splits arch_kernel_obj.splits)

lemma ko_override_a_base_type [simp]:
  "a_base_type o1 = a_base_type o2
   \<Longrightarrow> a_base_type (ko_override o1 o2 c2) = a_base_type o2"
  by (clarsimp simp: a_base_type_def ko_override_def ao_override_def
               split: kernel_object.splits arch_kernel_obj.splits)

lemma ao_clean_twice [simp]:
  "ao_clean (ao_clean ao cmps) cmps = ao_clean ao cmps"
  by (fastforce split: arch_kernel_obj.splits
                simp: ao_clean_def ao_override_def)

lemma ko_clean_twice_subset:
  "\<lbrakk> cmps' \<subseteq> cmps \<rbrakk> \<Longrightarrow> ko_clean (ko_clean ko cmps) cmps' = ko_clean ko cmps'"
  apply (clarsimp simp: ko_clean_def ao_clean_def ko_override_def
                        ao_override_def
                  split: kernel_object.splits arch_kernel_obj.splits)
  apply (fastforce intro!: tcb_eq simp: tcb_override_def)
  done

lemma ko_clean_twice [simp]:
  "ko_clean (ko_clean ko cmps) cmps = ko_clean ko cmps"
  by (simp add: ko_clean_twice_subset)

lemma ko_clean_id:
  "bounded_ko ko \<Longrightarrow> ko_clean ko (ko_components ko) = ko"
  apply (clarsimp simp: ko_clean_def ko_override_def ao_clean_def
                        ao_override_def bounded_ko_def
                  split: kernel_object.splits arch_kernel_obj.splits)
   apply (clarsimp intro!: ext simp: bounded_cs_size_def bounded_cnode_n_def)
   apply (case_tac "fun bs", simp, clarsimp simp: unat_of_bl_length dom_def)
  apply (fastforce intro!: tcb_eq simp: tcb_override_index_assist)
  done

lemma ko_clean_ko_override_id:
  "\<lbrakk> a_base_type ko = a_base_type ko' ; cmps \<inter> cmps' = {} \<rbrakk>
   \<Longrightarrow> ko_clean (ko_override ko ko' cmps) cmps' = ko_clean ko cmps'"
  apply (cases ko)
      apply (simp_all add: ko_clean_def ko_override_def a_base_type_def
                      split: kernel_object.splits)
      apply fastforce
     apply (rule tcb_eq | fastforce simp: tcb_override_def)+
  apply (case_tac arch_kernel_obj)
  apply (fastforce split: arch_kernel_obj.splits
                   simp: ao_clean_def ao_override_def)+
  done

lemma ao_override_pull_out_ao_clean [simp]:
  "\<lbrakk> a_base_type (ArchObj ao1) = a_base_type (ArchObj ao2) \<rbrakk>
   \<Longrightarrow> ao_override (ao_clean ao1 cmps1) ao2 cmps2
      = ao_clean (ao_override ao1 ao2 cmps2) (cmps1 \<union> cmps2)"
  by (auto simp: ao_clean_def ao_override_def
           split: arch_kernel_obj.splits)

lemma ko_override_pull_out_ko_clean [simp]:
  "\<lbrakk> a_base_type ko1 = a_base_type ko2 \<rbrakk>
   \<Longrightarrow> ko_override (ko_clean ko1 cmps1) ko2 cmps2
      = ko_clean (ko_override ko1 ko2 cmps2) (cmps1 \<union> cmps2)"
  by (clarsimp simp: ko_clean_def ko_override_def a_base_type_def
                  split: kernel_object.splits)
     (auto simp: tcb_override_def)

lemma ko_override_ko_clean_right [simp]:
  "\<lbrakk> a_base_type ko1 = a_base_type ko2 \<rbrakk>
   \<Longrightarrow> (ko_override ko1 (ko_clean ko2 cmps2) cmps2)
      = (ko_override ko1 ko2 cmps2) "
  apply (clarsimp simp: ko_clean_def ko_override_def a_base_type_def
                  split: kernel_object.splits)
    apply (fastforce simp: tcb_override_def)+
  apply (fastforce simp: ao_override_def ao_clean_def
                   split: arch_kernel_obj.splits)
  done

lemma ko_override_self [simp]:
  "ko_override ko ko cmps = ko"
  by (cases ko)
     (auto simp: ko_override_def tcb_override_def ao_override_def
           split: arch_kernel_obj.splits)

lemma cap_of_ko_cleanD:
  "\<lbrakk> cap_of (ko_clean ko cmps) i = Some c ; (cmp_of ko i) \<in> cmps \<rbrakk>
   \<Longrightarrow> cap_of ko i = Some c"
  unfolding cap_of_def ko_clean_def
  by (clarsimp simp: ko_override_def a_base_type_cmp_of_def tcb_cnode_map_def
                     tcb_override_index_assist
               split: kernel_object.splits option.splits split_if_asm)

lemma cap_of_ko_clean_contained_cap:
  "cmp_of ko i \<in> cmps
   \<Longrightarrow> cap_of (ko_clean ko cmps) i = cap_of ko i"
  unfolding cap_of_def ko_clean_def
  by (clarsimp simp: ko_override_def a_base_type_cmp_of_def
               split: kernel_object.splits)
     (fastforce simp: tcb_cnode_map_def a_base_type_cmp_of_def
                      tcb_override_index_assist)

lemma cap_of_ko_clean_same_cap [simp]:
  "cap_of (ko_clean ko {cmp_of ko i}) i = cap_of ko i"
  by (clarsimp simp: cap_of_ko_clean_contained_cap)

lemma ko_clean_one_cap_eq:
  "\<lbrakk> cap_of ko i = Some cap ; cap_of ko' i = Some cap ;
     a_base_type ko = a_base_type ko' ;
     cmp = {cmp_of ko' i} \<rbrakk>
   \<Longrightarrow> ko_clean ko cmp = ko_clean ko' cmp"
  apply (clarsimp simp: ko_clean_def a_base_type_def cap_of_def
                  split: kernel_object.splits)
   apply (fastforce simp: ko_override_def a_base_type_cmp_of_def
                    split: split_if_asm)
  apply (clarsimp simp: tcb_cnode_map_def a_base_type_cmp_of_def
                        ko_override_def tcb_override_index_assist
                  split: split_if_asm)
  done

lemma tcb_override_commute:
  "c1 \<inter> c2 = {}
   \<Longrightarrow> tcb_override (tcb_override undefined tcb1 c1)
                   (tcb_override undefined tcb2 c2) c2
      = tcb_override (tcb_override undefined tcb2 c2)
                     (tcb_override undefined tcb1 c1) c1"
  by (rule tcb_eq)
     (fastforce simp: tcb_override_def)+

lemma tcb_override_assoc:
  "tcb_override (tcb_override (a::Structures_A.tcb) b cs1) c cs2
   = tcb_override a (tcb_override b c cs2) (cs1 \<union> cs2)"
  by (fastforce simp: tcb_override_def)

lemma tcb_override_twice_same [simp]:
  "tcb_override x (tcb_override (x::Structures_A.tcb) y cmps) cmps =
       tcb_override x y cmps"
  by (fastforce simp: tcb_override_def intro!: tcb_eq)

lemma tcb_cnode_map_tcb_override_left:
  "i \<notin> cmps
   \<Longrightarrow> tcb_cnode_map (tcb_override tcb tcb' cmps) i = tcb_cnode_map tcb i"
  apply (clarsimp simp: tcb_cnode_map_def tcb_override_def
                  split: split_if_asm option.splits)
  apply (rule conjI | clarsimp simp: eval_nat_numeral)+
  done

lemma tcb_cnode_map_tcb_override_right:
  "i \<in> cmps
   \<Longrightarrow> tcb_cnode_map (tcb_override tcb tcb' cmps) i = tcb_cnode_map tcb' i"
  by (fastforce simp: tcb_cnode_map_def tcb_override_index_assist
                split: split_if_asm option.splits)

lemmas tcb_cnode_map_tcb_overrides = tcb_cnode_map_tcb_override_right
                                     tcb_cnode_map_tcb_override_left

lemma cap_of_ko_override_left:
  "\<lbrakk> cmp_of ko i \<notin> cmps ; a_base_type ko = a_base_type ko' \<rbrakk>
   \<Longrightarrow> cap_of (ko_override ko ko' cmps) i = cap_of ko i"
  by (clarsimp simp: a_base_type_def cap_of_def ko_clean_def
                     ko_override_def a_base_type_cmp_of_def
                     tcb_cnode_map_tcb_overrides
               split: kernel_object.splits option.splits)

lemma cap_of_ko_override_right:
  "\<lbrakk> cmp_of ko i \<in> cmps ; a_base_type ko = a_base_type ko' \<rbrakk>
   \<Longrightarrow> cap_of (ko_override ko ko' cmps) i = cap_of ko' i"
  by (clarsimp simp: a_base_type_def cap_of_def ko_clean_def
                     ko_override_def a_base_type_cmp_of_def
                     tcb_cnode_map_tcb_overrides
               split: kernel_object.splits option.splits)

lemmas cap_of_ko_overrides = cap_of_ko_override_right cap_of_ko_override_left

lemma cap_of_ko_clean:
  "\<lbrakk> cmp_of ko i \<in> cmps \<rbrakk>
   \<Longrightarrow> cap_of (ko_clean ko cmps) i = cap_of ko i"
  by (clarsimp simp: cap_of_def ko_clean_def a_base_type_cmp_of_def
                     ko_override_def
                     a_base_type_def tcb_cnode_map_tcb_overrides
               split: kernel_object.splits)+

lemma bounded_ko_clean:
  "bounded_ko ko \<Longrightarrow> bounded_ko (ko_clean ko cmps)"
  by (auto simp: bounded_ko_def ko_clean_def ko_override_def
                 bounded_cs_size_def bounded_cnode_n_def
           split: kernel_object.splits split_if_asm)

lemma bounded_ko_override:
  "\<lbrakk> bounded_ko o1 ; bounded_ko o2 ; a_base_type o1 = a_base_type o2 \<rbrakk>
       \<Longrightarrow> bounded_ko (ko_override o1 o2 cmps)"
  by (fastforce simp: bounded_ko_def ko_override_def bounded_cs_size_def
                      a_base_type_def bounded_cnode_n_def
                split: kernel_object.splits split_if_asm)

lemma bounded_ko_clean_ko_override:
  "\<lbrakk> bounded_ko (ko_clean o1 c1) ; bounded_ko (ko_clean o2 c2) ;
     a_base_type o1 = a_base_type o2\<rbrakk>
   \<Longrightarrow> bounded_ko (ko_clean (ko_override o1 o2 c2) (c1 \<union> c2))"
  by (fastforce simp: bounded_ko_def ko_clean_def ko_override_def
                      a_base_type_def bounded_cs_size_def bounded_cnode_n_def
                split: kernel_object.splits option.splits split_if_asm)
  (* XXX: long-running proof *)

lemma sane_components_ko_clean_ko_override:
  "\<lbrakk> sane_components (ko_clean o1 c1) c1 ; sane_components (ko_clean o2 c2) c2;
     a_base_type o1 = a_base_type o2 \<rbrakk>
   \<Longrightarrow> sane_components (ko_clean (ko_override o1 o2 c2) (c1 \<union> c2)) (c1 \<union> c2)"
  by (clarsimp simp: sane_components_def bounded_ko_clean_ko_override)

lemma bounded_ko_clean_ko_overrideD:
  "\<lbrakk> bounded_ko (ko_clean (ko_override o1 o2 c2) (c1 \<union> c2)) ;
     c1 \<inter> c2 = {} ; a_base_type o1 = a_base_type o2 \<rbrakk>
   \<Longrightarrow> bounded_ko (ko_clean o1 c1) \<and> bounded_ko (ko_clean o2 c2)"
  by (fastforce simp: bounded_ko_def a_base_type_def ko_clean_def
                     ko_override_def bounded_cs_size_def bounded_cnode_n_def
               split: kernel_object.splits split_if_asm)

lemma sane_components_ko_clean_ko_overrideD:
  "\<lbrakk> sane_components (ko_clean (ko_override o1 o2 c2) (c1 \<union> c2)) (c1 \<union> c2) ;
     c1 \<inter> c2 = {} ; c1 \<noteq> {} ; c2 \<noteq> {} ; a_base_type o1 = a_base_type o2 \<rbrakk>
   \<Longrightarrow> sane_components (ko_clean o1 c1) c1 \<and>
       sane_components (ko_clean o2 c2) c2"
  by (fastforce simp: sane_components_def dest!: bounded_ko_clean_ko_overrideD)

lemma ko_override_assoc:
  "\<lbrakk> a_base_type o1 = a_base_type o2 ; a_base_type o2 = a_base_type o3 \<rbrakk>
   \<Longrightarrow> ko_override (ko_override o1 o2 cs1) o3 cs2
   = ko_override o1 (ko_override o2 o3 cs2) (cs1 \<union> cs2)"
  unfolding a_base_type_def
  apply (clarsimp split: kernel_object.splits)
      apply (clarsimp intro!: ext simp: ko_override_def tcb_override_assoc)+
  apply (clarsimp split: arch_kernel_obj.splits)
     apply (clarsimp intro!: ext simp: ao_override_def)+
  done

lemma ko_combine_assoc:
  "\<lbrakk> a_base_type o1 = a_base_type o2 ; a_base_type o2 = a_base_type o3 \<rbrakk>
   \<Longrightarrow> ko_combine (ko_combine (o1,c1) (o2,c2)) (o3,c3)
      = ko_combine (o1,c1) (ko_combine (o2,c2) (o3,c3))"
  by (clarsimp simp: ko_combine_def ko_override_assoc Un_assoc)

lemma ko_combine_commute:
  "\<lbrakk> check_components (ko_clean o1 c1) c1
      \<inter> check_components (ko_clean o2 c2) c2 = {} ;
     a_base_type o1 = a_base_type o2 \<rbrakk>
   \<Longrightarrow> ko_combine (o1,c1) (o2,c2) = ko_combine (o2,c2) (o1,c1)"
  unfolding ko_combine_def
  by (clarsimp simp: Un_commute ko_override_def ko_clean_def
                     check_components_def
                     tcb_override_commute ao_clean_def sane_components_def
               split: kernel_object.splits arch_kernel_obj.splits split_if_asm)
     -- "ao_override_def is too much for auto/fastforce above"
     (auto intro!: ext simp: ao_override_def split: split_if_asm)


subsection {*
  Check on Kernel Object and Components for Considering Disjunction *}

lemma check_components_id:
  "\<lbrakk> bounded_ko ko ; cmps \<subseteq> ko_components ko ; cmps \<noteq> {} \<rbrakk>
   \<Longrightarrow> check_components ko cmps = cmps"
  by (clarsimp simp: check_components_def sane_components_def)

lemma check_components_UNIV:
  "check_components ko {} = UNIV"
  "\<not> bounded_ko ko \<Longrightarrow> check_components ko cmps = UNIV"
  "\<not> (cmps \<subseteq> ko_components ko) \<Longrightarrow> check_components ko cmps = UNIV"
  by (auto simp: check_components_def sane_components_def)

lemma check_components_not_empty:
  "check_components ko cmps \<noteq> {}"
  by (clarsimp simp: check_components_def sane_components_def)

lemma check_components_Int_emptyD:
  assumes int: "check_components o1 c1 \<inter> check_components o2 c2 = {}"
  shows "c1 \<noteq> {} \<and> c2 \<noteq> {} \<and> bounded_ko o1 \<and> bounded_ko o2 \<and>
      c1 \<subseteq> ko_components o1 \<and> c2 \<subseteq> ko_components o2 \<and> c1 \<inter> c2 = {}"
proof -

  from int have noteq: "c1 \<noteq> {} \<and> c2 \<noteq> {}"
    by (auto simp: check_components_UNIV check_components_not_empty)

  moreover
  from int have bounded: "bounded_ko o1 \<and> bounded_ko o2"
    by (auto intro: ccontr
             simp: check_components_UNIV check_components_not_empty)
  moreover
  from int have subs: "c1 \<subseteq> ko_components o1" "c2 \<subseteq> ko_components o2"
    by - (rule ccontr,
          simp add: check_components_UNIV check_components_not_empty)+

  ultimately show ?thesis using int
    by (simp add: check_components_id)
qed


subsection {* Updating a cap in a specific kernel object *}

lemma a_base_type_set_ko_cap [simp]:
  "a_base_type (set_ko_cap ko i cap) = a_base_type ko"
  by (cases ko, auto simp: set_ko_cap_def cap_of_def tcb_cnode_map_def)

lemma cap_of_set_ko_cap [simp]:
  "cap_of ko i = Some c \<Longrightarrow> cap_of (set_ko_cap ko i cap) i = Some cap"
  by (cases ko, auto simp: set_ko_cap_def cap_of_def tcb_cnode_map_def
                     split: split_if_asm)

lemma cap_of_set_ko_cap_via_other:
  "\<lbrakk> a_base_type ko = a_base_type ko' ; cap_of ko' i = Some cap' \<rbrakk>
   \<Longrightarrow> cap_of (set_ko_cap ko i cap) i = Some cap"
  by (clarsimp simp: cap_of_def set_ko_cap_def a_base_type_def
                     tcb_cnode_map_def
               split: kernel_object.splits)

lemma bounded_set_ko_cap:
  "\<lbrakk> bounded_ko ko ; cap_of ko i = Some c \<rbrakk>
   \<Longrightarrow> bounded_ko (set_ko_cap ko i cap)"
  by (fastforce simp: bounded_ko_def set_ko_cap_def cap_of_def
                      tcb_cnode_map_def bounded_cs_size_def bounded_cnode_n_def
               split: kernel_object.splits)

lemma bounded_ko_clean_set_ko_cap:
  "\<lbrakk> bounded_ko (ko_clean ko cmps) ; cap_of ko i = Some c ; cmp_of ko i \<in> cmps \<rbrakk>
   \<Longrightarrow> bounded_ko (ko_clean (set_ko_cap ko i cap) cmps)"
  by (fastforce simp: bounded_ko_def set_ko_cap_def cap_of_def ko_clean_def
                      ko_override_def tcb_cnode_map_def a_base_type_cmp_of_def
                      bounded_cs_size_def bounded_cnode_n_def
                split: kernel_object.splits split_if_asm)

lemma ko_override_is_set_ko_cap:
  "\<lbrakk> cap_of ko' i = Some cap' ; a_base_type ko = a_base_type ko' \<rbrakk>
   \<Longrightarrow> ko_override ko ko' {cmp_of ko' i} = set_ko_cap ko i cap'"
  apply (clarsimp simp: set_ko_cap_def cap_of_def ko_override_def
                        a_base_type_def
                  split: kernel_object.splits arch_kernel_obj.splits)
   apply (clarsimp intro!: ext simp: a_base_type_cmp_of_def)
  apply (fastforce simp: tcb_cnode_map_def a_base_type_cmp_of_def
                         tcb_override_index_assist)
  done

lemma ko_override_with_set_ko_cap:
  "\<lbrakk> a_base_type ko = a_base_type ko' ; valid_cnode_index ko' i \<rbrakk>
   \<Longrightarrow> ko_override ko (set_ko_cap ko' i cap) {cmp_of ko' i}
       = set_ko_cap ko i cap"
  apply (clarsimp simp: set_ko_cap_def abt_valid_cnode_index_def
                        a_base_type_def a_base_type_cmp_of_def
                  split: kernel_object.splits)
   apply (fastforce simp: ko_override_def tcb_override_index_assist)+
  done

lemma ko_override_set_ko_cap:
  "\<lbrakk> a_base_type ko = a_base_type ko' ; cmp_of ko i \<in> cmps ;
     cmps \<inter> cmps' = {} ; cap_of (ko_clean ko cmps) i = Some c \<rbrakk>
   \<Longrightarrow>
   (ko_override (ko_clean (set_ko_cap ko i cap) cmps)
                (ko_clean ko' cmps') cmps')
   = (set_ko_cap (ko_override (ko_clean ko cmps)
                              (ko_clean ko' cmps') cmps') i cap)"
  apply (frule (1) cap_of_ko_cleanD)
  apply (clarsimp simp: ko_clean_def ko_override_def a_base_type_def
                        a_base_type_cmp_of_def cap_of_def
                  split: kernel_object.splits option.splits)
   apply (fastforce simp: set_ko_cap_def)
  apply (clarsimp simp: set_ko_cap_def tcb_cnode_map_def split: split_if_asm)
      apply (rule tcb_eq | fastforce simp: tcb_override_def)+
      (* XXX: long-running proof *)
  done

lemma ko_clean_set_ko_cap:
  "\<lbrakk> cmp_of ko i \<in> cmps \<rbrakk>
   \<Longrightarrow>
   ko_clean (set_ko_cap ko i cap) cmps = set_ko_cap (ko_clean ko (cmps)) i cap"
  apply (clarsimp simp: ko_clean_def a_base_type_def a_base_type_cmp_of_def
                        cap_of_def ko_override_def
                  split: kernel_object.splits option.splits)
      apply (fastforce simp: set_ko_cap_def)
     apply (simp_all add: set_ko_cap_def)
  apply (fastforce simp: tcb_override_index_assist)
  done

lemma ko_clean_set_ko_cap': (* more specific version *)
  "\<lbrakk> cmp_of ko i \<in> cmps ; cap_of (set_ko_cap ko i cap) i = Some cap \<rbrakk>
   \<Longrightarrow>
   ko_clean (set_ko_cap ko i cap) cmps
    = set_ko_cap (ko_clean ko (cmps - {cmp_of ko i})) i cap"
  apply (clarsimp simp: ko_clean_def a_base_type_def a_base_type_cmp_of_def
                        cap_of_def ko_override_def
                  split: kernel_object.splits option.splits)
      apply (fastforce simp: set_ko_cap_def)
     apply (simp_all add: set_ko_cap_def)
   apply (clarsimp split: split_if_asm)
  apply (clarsimp split: split_if_asm)
       apply (simp add: tcb_override_index_assist tcb_cnode_map_def)+
  done

lemma ko_clean_set_ko_cap_id:
  "\<lbrakk> cmp_of ko i \<notin> cmps \<rbrakk>
   \<Longrightarrow> ko_clean (set_ko_cap ko i cap) cmps = ko_clean ko cmps"
  apply (cases ko)
      apply (clarsimp simp: set_ko_cap_def ko_clean_def ko_override_def
                            a_base_type_cmp_of_def)
      apply fastforce
     apply (clarsimp simp: set_ko_cap_def ko_clean_def a_base_type_cmp_of_def
                           ko_override_def
                     split: split_if_asm)
     apply (rule conjI | rule tcb_eq | fastforce simp: tcb_override_def)+
    apply (clarsimp simp: set_ko_cap_def)+
  done

lemma valid_cnode_index_cap_of_set_ko_cap:
  "\<lbrakk> valid_cnode_index ko i \<rbrakk>
   \<Longrightarrow> cap_of (set_ko_cap ko i cap) i = Some cap"
  apply (cases ko, simp_all add: abt_valid_cnode_index_def
                                 a_base_type_def set_ko_cap_def cap_of_def
                   split: kernel_object.splits)
  apply (fastforce simp: tcb_override_index_assist tcb_cnode_map_def)
  done

lemma abt_valid_cnode_index_singleton_component_subset:
  "\<lbrakk> abt_valid_cnode_index atyp i ; 0 < length i \<rbrakk>
   \<Longrightarrow> {a_base_type_cmp_of atyp i} \<subset> a_base_type_components atyp"
  apply (clarsimp simp: abt_valid_cnode_index_def a_base_type_cmp_of_def
                  split: a_type.splits)
   apply fastforce
  apply (erule bl_length_set_singleton_subset)
  done

lemma abt_valid_cnode_index_in_components:
  "abt_valid_cnode_index atyp i \<Longrightarrow> i \<in> a_base_type_components atyp"
  by (clarsimp simp: abt_valid_cnode_index_def a_base_type_components_def
               split: a_type.splits)


subsection {* Object-component Maps *}

lemma ocm_disj_empty [simp]:
  "obj_comp_map_disj cmps Map.empty"
  by (auto simp: obj_comp_map_disj_def split: option.splits)

lemma ocm_disj_commute:
  "obj_comp_map_disj h1 h2 = obj_comp_map_disj h2 h1"
  by (fastforce simp: obj_comp_map_disj_def split: option.splits)

lemma ocm_add_empty [simp]:
  "obj_comp_map_add x empty = x"
  by (rule ext, fastforce simp: obj_comp_map_add_def split: option.splits)

lemma dom_ocm_map_add [simp]:
  "dom (obj_comp_map_add kh1 kh2) = dom kh1 \<union> dom kh2"
  by (auto simp: obj_comp_map_add_def dom_def split: option.split)

lemma ocm_a_base_type_eq:
  "\<lbrakk> obj_comp_map_disj kh1 kh2 ; x \<in> dom kh1 ; x \<in> dom kh2 \<rbrakk>
   \<Longrightarrow> a_base_type (fst (the (kh1 x))) = a_base_type (fst (the (kh2 x)))"
  by (clarsimp simp: obj_comp_map_disj_def split: option.splits)

lemma ocm_add_commute:
  "obj_comp_map_disj h1 h2
   \<Longrightarrow> obj_comp_map_add h1 h2 = obj_comp_map_add h2 h1"
  by (fastforce simp: obj_comp_map_add_def obj_comp_map_disj_def
               elim: ko_combine_commute split: option.splits
               intro!: ext)

lemma ocm_add_assoc:
  "\<lbrakk> obj_comp_map_disj x y ; obj_comp_map_disj y z ; obj_comp_map_disj x z \<rbrakk>
   \<Longrightarrow> obj_comp_map_add (obj_comp_map_add x y) z
      = obj_comp_map_add x (obj_comp_map_add y z)"
  by (rule ext)
     (fastforce simp: obj_comp_map_add_def obj_comp_map_disj_def
                     ko_combine_assoc
               split: option.splits)

lemma ocm_disj_add:
  "obj_comp_map_disj y z
   \<Longrightarrow> (obj_comp_map_disj x (obj_comp_map_add y z))
      = (obj_comp_map_disj x y \<and> obj_comp_map_disj x z)"
  apply (rule iffI)
   apply (simp add: obj_comp_map_disj_def obj_comp_map_add_def)
   apply (rule conjI)
    apply (rule allI)
    apply (erule_tac x=p in allE)+
    apply (clarsimp simp: ko_combine_def split: option.splits)
    apply (clarsimp dest!: check_components_Int_emptyD
                    simp: check_components_id)[1]
    apply blast
   apply (rule allI)
   apply (erule_tac x=p in allE)+
   apply (clarsimp simp: ko_combine_def split: option.splits)
   apply (clarsimp dest!: check_components_Int_emptyD
                   simp: check_components_id)
   apply blast
  apply (clarsimp simp: obj_comp_map_disj_def obj_comp_map_add_def)
  apply (erule_tac x=p in allE)+
  apply (case_tac "p \<in> dom z")
   apply (clarsimp simp: dom_def ko_combine_def split: option.splits)
   apply (rename_tac p objz cz objx cx objy cy)
   apply (clarsimp dest!: check_components_Int_emptyD
                   simp: check_components_id)
   apply (auto simp: check_components_id bounded_ko_clean_ko_override
               split: option.splits)
  done

lemma ocm_has_cap_disj_add:
  "\<lbrakk> ocm_has_cap x p ko cmps i c ; obj_comp_map_disj x y \<rbrakk>
   \<Longrightarrow> \<exists>ko' cmps'. ocm_has_cap (obj_comp_map_add x y) p ko' cmps' i c"
  apply (clarsimp simp: ocm_has_cap_def obj_comp_map_add_def
                        obj_comp_map_disj_def
                  split: option.splits)
  apply (clarsimp simp: ko_combine_def ko_has_cap_def)
  apply (erule_tac x=p in allE)
  apply (clarsimp dest!: check_components_Int_emptyD
                  simp: cap_of_ko_clean_contained_cap)
  apply (subst cap_of_ko_override_left)
    apply auto
  done


subsection {* Instantiation to a Separation Algebra. *}

lemma kheap_dom_alt_def:
  "kheap_dom kh \<equiv> \<Union> ((\<lambda>p . set (len_seq p
                                  (2 ^ t_obj_bits (fst (the (kh p))))))
                     ` dom kh)"
  by (rule eq_reflection)
     (auto simp: kheap_dom_def kheap_shadows_def kheap_shadow_def
                 len_seq_Cons)

lemma kheap_shadows_dom_empty [simp]:
  "kheap_shadows empty = {}"
  by (simp add: kheap_shadows_def)

lemma kheap_dom_empty [simp]:
  "kheap_dom empty = {}"
  by (simp add: kheap_dom_def)

lemma sep_state_eq_piecewiseI:
  "\<lbrakk> sep_state_ocm x = sep_state_ocm y ;
     sep_state_free x = sep_state_free y ;
     sep_state_avail x = sep_state_avail y \<rbrakk>
   \<Longrightarrow> x = y"
  by (cases x, cases y)
     (clarsimp simp: sep_state_accessors)

lemma sep_disj_zero:
  "sep_disj x sep_empty"
  by (simp add: sep_disj_def sep_empty_def split: sep_state.splits)

lemma sep_disj_commute:
  "sep_disj x y \<Longrightarrow> sep_disj y x"
  by (cases x, cases y, simp add: sep_disj_def Int_commute ocm_disj_commute)

lemma sep_add_zero:
  "sep_add x sep_empty = x"
  by (cases x, simp add: sep_empty_def sep_add_def)

lemma sep_add_commute:
  "sep_disj x y \<Longrightarrow> sep_add x y = sep_add y x"
  by (fastforce simp: sep_add_def sep_disj_def split: sep_state.splits
               elim: ocm_add_commute)

lemma sep_add_assoc:
  "\<lbrakk> sep_disj x y ; sep_disj y z ; sep_disj x z \<rbrakk>
   \<Longrightarrow> sep_add (sep_add x y) z = sep_add x (sep_add y z)"
  by (auto simp: sep_add_def sep_disj_def ocm_add_assoc
           split: sep_state.splits)

lemma ocm_shadow_eq_both:
  "\<lbrakk> x \<in> dom kh ; x \<in> dom kh' ;
     a_base_type (fst (the (kh x))) = a_base_type (fst (the (kh' x))) \<rbrakk>
   \<Longrightarrow> kheap_shadow kh x = kheap_shadow kh' x"
  by (clarsimp simp: kheap_shadow_def)

lemma kheap_shadow_unchanged:
"\<lbrakk> obj_comp_map_disj kh1 kh2 ; kh1 x \<noteq> None \<rbrakk>
 \<Longrightarrow> kheap_shadow (obj_comp_map_add kh1 kh2) x = kheap_shadow kh1 x"
  unfolding obj_comp_map_add_def
  apply (case_tac "x \<in> dom kh2")
   apply (rule ocm_shadow_eq_both, clarsimp+)
   apply (fastforce dest!: ocm_a_base_type_eq simp: ko_combine_def dom_def)
  apply (rule ocm_shadow_eq_both, auto split: option.splits)
  done

lemma kheap_shadows_ocm_add:
  "obj_comp_map_disj kh1 kh2
   \<Longrightarrow> kheap_shadows (obj_comp_map_add kh1 kh2)
      = (kheap_shadows kh1 \<union> kheap_shadows kh2)"
  apply (clarsimp simp: kheap_shadows_def)
  apply (rule set_eqI)
  apply clarsimp
  apply (rule iffI)
   apply (erule disjE)
    apply (fastforce simp: kheap_shadow_unchanged)
   apply (subst (asm) ocm_add_commute, assumption)
   apply (fastforce simp: kheap_shadow_unchanged ocm_disj_commute)
  apply (erule disjE)
   apply clarsimp
   apply (rule_tac x=xa in bexI)
    apply (simp add: kheap_shadow_unchanged)
   apply clarsimp
  apply (subst disj_commute)
  apply clarsimp
  apply (subst ocm_add_commute, assumption)
  apply (subst (asm) ocm_disj_commute)
  apply (rule_tac x=xa in bexI)
   apply (simp add: kheap_shadow_unchanged)
  apply clarsimp
  done (* yuck. *)

lemma kheap_dom_ocm_add:
  "obj_comp_map_disj kh1 kh2
   \<Longrightarrow> kheap_dom (obj_comp_map_add kh1 kh2) = (kheap_dom kh1 \<union> kheap_dom kh2)"
  by (simp add: kheap_dom_def kheap_shadows_ocm_add Un_ac)

text {*
  I use these to hand-hold tools through the next proof; automated tactics
  just choke.
*}

lemma empty_Inter_UnD:
  "A \<inter> (B \<union> C) = {} \<Longrightarrow> A \<inter> B = {} \<and> A \<inter> C = {}"
  by blast

lemma empty_Inter_UnD_left:
  "(B \<union> C) \<inter> A = {} \<Longrightarrow> B \<inter> A = {} \<and> C \<inter> A = {}"
  by blast

lemma empty_Inter_UnI:
  "\<lbrakk> A \<inter> B = {} ; A \<inter> C = {} \<rbrakk> \<Longrightarrow> A \<inter> (B \<union> C) = {}"
  by blast

lemma empty_Inter_UnI_left:
  "\<lbrakk> A \<inter> C = {} ; B \<inter> C = {} \<rbrakk> \<Longrightarrow> (A \<union> B) \<inter> C = {}"
  by blast

lemma sep_disj_add:
  "sep_disj y z \<Longrightarrow> sep_disj x (sep_add y z) = (sep_disj x y \<and> sep_disj x z)"
  unfolding sep_add_def sep_disj_def
  apply (clarsimp simp: kheap_dom_ocm_add kheap_shadows_ocm_add ocm_disj_add
                  split: sep_state.splits)
  apply (rule iffI)
   apply (clarsimp dest!: empty_Inter_UnD empty_Inter_UnD_left)
   apply ((rule conjI | intro empty_Inter_UnI empty_Inter_UnI_left
           | simp add: Int_commute)+)[1]
   -- "concludes first branch of iffI"
  apply (clarsimp dest!: empty_Inter_UnD empty_Inter_UnD_left)
  apply ((rule conjI | intro empty_Inter_UnI empty_Inter_UnI_left
          | simp add: Int_commute)+)[1]
  done

instantiation sep_state :: stronger_sep_algebra
begin

definition
  "(op +) \<equiv> sep_add"
definition
  "sep_disj_sep_state \<equiv> sep_disj"
definition
  "0 = sep_empty"

instance
  apply default
       apply (unfold plus_sep_state_def sep_disj_sep_state_def
                     zero_sep_state_def)
       apply (blast intro: sep_disj_zero sep_disj_commute sep_add_zero
                           sep_add_commute)+
   apply (blast intro!: sep_add_assoc sep_disj_add)+
  done

end

lemmas sep_disj_defs = sep_disj_sep_state_def sep_disj_def
lemmas sep_add_defs = plus_sep_state_def sep_add_def
lemmas sep_empty_defs = zero_sep_state_def sep_empty_def

lemma sep_state_free_plus [simp]:
  "sep_state_free (x + y) = sep_state_free x \<union> sep_state_free y"
  by (clarsimp simp: sep_state_accessors sep_add_defs split: sep_state.splits)

lemma sep_state_avail_plus [simp]:
  "sep_state_avail (x + y) = sep_state_avail x \<union> sep_state_avail y"
  by (clarsimp simp: sep_state_accessors sep_add_defs split: sep_state.splits)

lemma sep_disj_ocmD:
  "x ## y \<Longrightarrow> obj_comp_map_disj (sep_state_ocm x) (sep_state_ocm y)"
  by (clarsimp simp: sep_disj_defs sep_state_ocm_def split: sep_state.splits)


subsection {* Properties of maps-to predicates *}

subsubsection {* Properties of @{term sep_map_base} *}

lemma sep_map_baseI:
  "\<lbrakk> sep_state_ocm s p = Some (ko_clean ko cmps, cmps) ;
     sane_components (ko_clean ko cmps) cmps ;
     dom (sep_state_ocm s) = {p} ;
     is_aligned p (t_obj_bits ko) ;
     sep_state_free s = {} ;
     sep_state_avail s = {} \<rbrakk>
   \<Longrightarrow> sep_map_base p ko cmps s"
  by (clarsimp simp: sep_map_base_def sep_state_accessors
               split: sep_state.splits)

lemma sep_map_baseD:
  "sep_map_base p ko cmps s
   \<Longrightarrow> sep_state_ocm s p = Some (ko_clean ko cmps, cmps) \<and>
     sane_components (ko_clean ko cmps) cmps \<and>
     dom (sep_state_ocm s) = {p} \<and>
     is_aligned p (t_obj_bits ko) \<and>
     sep_state_free s = {} \<and>
     sep_state_avail s = {}"
  by (fastforce simp: sep_map_base_def sep_state_accessors
               split: sep_state.splits)

lemma (* sanity check *)
  "sep_map_base p ko cmps s \<Longrightarrow> sep_map_base p ko cmps s"
  apply (drule sep_map_baseD, clarsimp)
  apply (rule sep_map_baseI)
  apply auto
  done

lemma sep_map_base_consequences:
  "(sep_map_base p ko cmps \<and>* P) s
   \<Longrightarrow> \<exists>ko' cmps'.
       sane_components (ko_clean ko cmps) cmps \<and>
       sep_state_ocm s p = Some (ko', cmps') \<and>
       cmps \<subseteq> cmps' \<and>
       cmps \<noteq> {} \<and>
       ko_clean ko' cmps' = ko' \<and>
       ko_clean ko' cmps = ko_clean ko cmps \<and>
       a_base_type ko' = a_base_type ko \<and>
       p \<in> dom (sep_state_ocm s) \<and>
       is_aligned p (t_obj_bits ko)"
  apply (clarsimp dest!: sep_conjD
                  simp: sep_disj_defs sep_add_defs sep_state_accessors
                  split: sep_state.splits)
  apply (drule sep_map_baseD)
  apply (clarsimp simp: sep_state_accessors)
  apply (clarsimp simp: obj_comp_map_add_def obj_comp_map_disj_def
                  split: option.splits)
  apply (erule_tac x=p in allE)
  apply (rule conjI, clarsimp simp: sane_components_def)
  apply (clarsimp simp: ko_combine_def)
  apply (drule check_components_Int_emptyD)
  apply clarsimp
  apply (clarsimp simp: ko_clean_twice_subset Int_commute
                        ko_clean_ko_override_id)
  done

lemma sep_map_base_dom:
  "sep_map_base p ko cmps s \<Longrightarrow> dom (sep_state_ocm s) = {p}"
  by (drule sep_map_baseD, simp)

lemma sep_map_base_aligned:
  "sep_map_base p ko cmps s \<Longrightarrow> is_aligned p (t_obj_bits ko)"
  by (drule sep_map_baseD, simp)

lemma sep_map_base_in_dom:
  "sep_map_base p ko cmps s \<Longrightarrow> p \<in> dom (sep_state_ocm s)"
  by (simp add: sep_map_base_dom)

lemma sep_map_base_set_ko_cap_id:
  "cmp_of ko i \<notin> cmps
   \<Longrightarrow> sep_map_base p (set_ko_cap ko i cap) cmps = sep_map_base p ko cmps"
  by (fastforce intro!: ext simp: sep_map_base_def ko_clean_set_ko_cap_id
                cong: sep_state.case_cong)

lemma sep_map_base_lock_type':
  "(sep_map_base p ko cmps \<and>* P) s
   \<Longrightarrow> \<forall>ko'. sep_state_ocm s p = Some (ko', cmps')
            \<longrightarrow> a_base_type ko' = a_base_type ko"
  apply (clarsimp dest!: sep_conjD simp: sep_disj_defs obj_comp_map_disj_def
                         sep_add_defs obj_comp_map_add_def sep_state_accessors
                  split: sep_state.splits)
  apply (erule_tac x=p in allE)
  apply (clarsimp dest!: sep_map_baseD split: option.splits
                  simp: sep_state_accessors ko_combine_def)
  done

lemma sep_map_base_implode_eq:
  "\<lbrakk> a_base_type ko1 = a_base_type ko2 ;
     cmps1 \<inter> cmps2 = {} ; cmps1 \<noteq> {} ; cmps2 \<noteq> {} \<rbrakk>
   \<Longrightarrow> (sep_map_base p ko1 cmps1 \<and>* sep_map_base p ko2 cmps2)
       = sep_map_base p (ko_override ko1 ko2 cmps2) (cmps1 \<union> cmps2)"
  apply (rule ext, rename_tac s)
  apply (rule iffI)
   apply (clarsimp simp: sep_add_defs sep_disj_defs sep_state_accessors
                         sep_map_base_def
                   dest!: sep_conjD sep_map_baseD split: sep_state.splits)
   apply (simp add: obj_comp_map_add_def ko_combine_def
                    sane_components_ko_clean_ko_override)
  apply (clarsimp dest!: sep_map_baseD)
  apply (rule_tac x="SepState [p \<mapsto> (ko_clean ko1 cmps1, cmps1)] {} {}"
              and y="SepState [p \<mapsto> (ko_clean ko2 cmps2, cmps2)] {} {}"
              in sep_conjI)
     apply (fastforce simp: sep_map_base_def
                     dest!: sane_components_ko_clean_ko_overrideD)
    apply (fastforce simp: sep_map_base_def
                    dest!: sane_components_ko_clean_ko_overrideD)
   apply (drule (4) sane_components_ko_clean_ko_overrideD)
     -- "why can't clarsimp apply this with dest!: ?"
   apply (clarsimp simp: sep_disj_defs kheap_shadows_def kheap_shadow_def
                         obj_comp_map_disj_def check_components_def
                         sane_components_def)

   apply (drule bounded_ko_t_obj_bits)+
   apply simp
   apply (drule_tac a="2::nat" in power_strict_increasing, simp)
   apply (drule_tac n="Suc 0" in less_imp_diff_less)
   apply (simp only: word_bits_def)
   apply (blast dest: len_seq_no_wrap)

  apply (clarsimp simp: sep_add_defs sep_state_accessors obj_comp_map_add_def
                        ko_combine_def
                  split: sep_state.splits)
  apply (rule ext)
  apply (auto simp: ko_combine_def split: option.splits)
  done

lemma sep_map_base_subset_explode_eq:
  "\<lbrakk> cmps' \<subseteq> cmps; cmps' \<noteq> {} \<rbrakk>
   \<Longrightarrow> sep_map_base p ko cmps
      = (sep_map_base p ko cmps' \<and>*
         (if cmps = cmps' then \<box> else sep_map_base p ko (cmps - cmps')))"
  apply (simp split: split_if_asm, intro impI)
  apply (subst sep_map_base_implode_eq, fastforce+)
  apply (simp add: subset_union)
  done

lemma sep_map_base_same_types:
  "\<lbrakk> (sep_map_base p ko cmps \<and>* P) s ;
     (sep_map_base p ko cmps \<and>* P) s \<Longrightarrow> (sep_map_base p ko' cmps' \<and>* Q) s \<rbrakk>
   \<Longrightarrow> a_base_type ko = a_base_type ko'"
  by (clarsimp dest!: sep_map_base_consequences)

lemma sep_map_base_set_ko_cap_implode:
  "\<lbrakk> (sep_map_base p ko cmps \<and>*
      sep_map_base p (set_ko_cap ko' i cap) {cmp_of ko' i}) s ;
     cmp_of ko i \<notin> cmps ; valid_cnode_index ko' i \<rbrakk>
   \<Longrightarrow> sep_map_base p (set_ko_cap ko i cap) (cmps \<union> {cmp_of ko i}) s"
  apply (subgoal_tac "a_base_type ko = a_base_type ko'")
   prefer 2
   apply (drule_tac sep_map_base_same_types)
    apply (sep_select_asm 2)
    apply sep_cancel
    apply simp
  apply (subgoal_tac "cmps \<noteq> {}")
   prefer 2
   apply (frule sep_map_base_consequences, clarsimp)
  apply (clarsimp simp: sep_map_base_implode_eq ko_override_with_set_ko_cap)
  done


subsubsection {* Properties of @{term sep_map_cap} *}

lemma sep_map_base_sep_map_capI:
  "\<lbrakk> sep_map_base p ko {cmp} s ; cmp = cmp_of ko i ; cap_of ko i = Some cap \<rbrakk>
   \<Longrightarrow> sep_map_cap (a_base_type ko) (p,i) cap s"
  by (fastforce simp: sep_map_cap_def)

lemma sep_map_base_sep_map_capI':
  "\<lbrakk> (sep_map_base p ko {cmp} \<and>* P) s ; cmp = cmp_of ko i ;
     cap_of ko i = Some cap \<rbrakk>
   \<Longrightarrow> (sep_map_cap (a_base_type ko) (p,i) cap \<and>* P) s"
  by (sep_cancel add: sep_map_base_sep_map_capI) simp

lemma sep_map_capI:
  "\<lbrakk> sep_state_ocm s p = Some (ko_clean ko {cmp_of ko i}, {cmp_of ko i}) ;
     a_base_type ko = atyp ;
     cap_of (ko_clean ko {cmp_of ko i}) i = Some cap ;
     sane_components (ko_clean ko {cmp_of ko i}) {cmp_of ko i};
     dom (sep_state_ocm s) = {p} ;
     is_aligned p (t_obj_bits ko) ;
     sep_state_free s = {} ;
     sep_state_avail s = {} \<rbrakk>
   \<Longrightarrow> sep_map_cap atyp (p,i) cap s"
  unfolding sep_map_cap_def
  by (fastforce intro!: sep_map_baseI
               simp: sane_components_def bounded_ko_clean)

lemma sep_map_capD:
  "sep_map_cap atyp (p,i) cap s
   \<Longrightarrow> \<exists>ko. sep_state_ocm s p = Some (ko, {cmp_of ko i}) \<and>
     ko_clean ko {cmp_of ko i} = ko \<and>
     a_base_type ko = atyp \<and>
     cap_of ko i = Some cap \<and>
     sane_components ko {cmp_of ko i} \<and>
     dom (sep_state_ocm s) = {p} \<and>
     is_aligned p (t_obj_bits ko) \<and>
     sep_state_free s = {} \<and>
     sep_state_avail s = {}"
  unfolding sep_map_cap_def
  by (clarsimp dest!: sep_map_baseD simp: sane_components_def)

lemma (* sanity check *)
  "sep_map_cap atyp (p, i) cap s \<Longrightarrow> sep_map_cap atyp (p, i) cap s"
  apply (drule sep_map_capD, clarsimp)
  apply (rule sep_map_capI)
  apply auto
  done

lemma sep_map_cap_ocm_has_capI:
  "sep_map_cap atyp (p,i) cap s
   \<Longrightarrow> \<exists>ko cmps. ocm_has_cap (sep_state_ocm s) p ko cmps i cap"
  by (fastforce dest: sep_map_capD simp: ocm_has_cap_def ko_has_cap_def)

lemma sep_map_cap'_ocm_has_capI:
  "(sep_map_cap atyp (p,i) cap \<and>* P) s
   \<Longrightarrow> \<exists>ko cmps. ocm_has_cap (sep_state_ocm s) p ko cmps i cap"
  by (fastforce dest!: sep_conjD dest: sep_map_cap_ocm_has_capI
               elim: ocm_has_cap_disj_add split: sep_state.splits
               simp: sep_disj_defs sep_add_defs sep_state_accessors)

lemma sep_map_cap_abt_valid_cnode_index:
  "sep_map_cap atyp (p, i) cap s \<Longrightarrow> abt_valid_cnode_index atyp i"
  by (drule sep_map_capD, clarsimp)
     (clarsimp simp: abt_valid_cnode_index_def sane_components_def
                     a_base_type_def a_base_type_cmp_of_def
                     bounded_ko_def cap_of_def tcb_cnode_map_def
               split: kernel_object.splits)

lemma sep_map_cap_abt_valid_cnode_index':
  "(sep_map_cap atyp (p, i) cap \<and>* P) s \<Longrightarrow> abt_valid_cnode_index atyp i"
  by (clarsimp dest!: sep_conjD simp: sep_map_cap_abt_valid_cnode_index)

lemma sep_map_cap_sep_map_base:
  "\<lbrakk> sep_map_cap atyp (p,i) cap s ; a_base_type ko = atyp \<rbrakk>
   \<Longrightarrow> sep_map_base p (set_ko_cap ko i cap) {cmp_of ko i} s"
  apply (frule sep_map_cap_abt_valid_cnode_index)
  apply (drule sep_map_capD, clarsimp)
  apply (clarsimp simp: sep_map_base_def sep_state_accessors
                  split: sep_state.splits)
  apply (subst ko_clean_one_cap_eq[symmetric])
      apply (simp add: valid_cnode_index_cap_of_set_ko_cap)+
  apply (subst ko_clean_one_cap_eq[symmetric])
      apply (simp add: valid_cnode_index_cap_of_set_ko_cap)+
  done

lemma sep_map_cap_sep_map_base': (* XXX: sep_drule doesn't work with this *)
  "\<lbrakk> (sep_map_cap atyp (p,i) cap \<and>* P) s ; a_base_type ko = atyp \<rbrakk>
   \<Longrightarrow> (sep_map_base p (set_ko_cap ko i cap) {cmp_of ko i} \<and>* P) s"
  by (sep_cancel add: sep_map_cap_sep_map_base)+

lemma sep_map_base_sep_map_cap_implode:
  "\<lbrakk> (sep_map_base p ko cmps \<and>* sep_map_cap atyp (p,i) cap) s ;
     cmp_of ko i \<notin> cmps \<rbrakk>
   \<Longrightarrow> sep_map_base p (set_ko_cap ko i cap) (cmps \<union> {cmp_of ko i}) s"
  apply (sep_frule sep_map_cap_abt_valid_cnode_index')
  apply (subgoal_tac "a_base_type ko = atyp")
   apply (drule (1) sep_map_cap_sep_map_base'[where ko=ko])
   apply (sep_select_asm 2)
   apply (erule (1) sep_map_base_set_ko_cap_implode, simp)
  apply (clarsimp simp: sep_map_cap_def sep_conj_exists)
  apply (sep_select_asm 2)
  apply (erule sep_map_base_same_types)
  apply sep_cancel
  done
  (* FIXME: these rules use cmps \<union> {cmp_of ko i}, but that gets simplified
            to insert {cmp_of ko i} cmps, so rules might not match *)

lemma sep_map_base_sep_map_cap_implode':
  "\<lbrakk> (sep_map_base p ko cmps \<and>* sep_map_cap atyp (p,i) cap \<and>* P) s ;
     cmp_of ko i \<notin> cmps \<rbrakk>
   \<Longrightarrow> (sep_map_base p (set_ko_cap ko i cap) (cmps \<union> {cmp_of ko i}) \<and>* P) s"
  by (sep_cancel add: sep_map_base_sep_map_cap_implode)+

lemma sep_map_base_set_ko_cap_sep_map_cap_explode:
  "\<lbrakk> sep_map_base p (set_ko_cap ko i cap) (cmps \<union> {cmp_of ko i}) s ;
     cmp_of ko i \<notin> cmps ; cmps \<noteq> {} ; valid_cnode_index ko i \<rbrakk>
   \<Longrightarrow> (sep_map_base p ko cmps \<and>* sep_map_cap (a_base_type ko) (p,i) cap) s"
  apply (subst (asm) sep_map_base_subset_explode_eq[where cmps'="cmps"])
    apply fastforce
   apply assumption
  apply (simp split: split_if_asm)
   apply fastforce
  apply (simp add: sep_map_base_set_ko_cap_id insert_subtract_new)
  apply sep_cancel
  apply (fastforce dest!: sep_map_base_sep_map_capI
                   intro: valid_cnode_index_cap_of_set_ko_cap
                   split: split_if_asm)
  done


subsection {* Cap-level Updates of the Kernel Init State *}

lemma sep_map_cap_update_cap:
  "(sep_map_cap atyp p old_cap) s \<Longrightarrow> (sep_map_cap atyp p cap) (sep_update_cap p cap s)"
  apply (cases p)
  apply (clarsimp dest!: sep_map_capD split: sep_state.splits
                  simp: sep_update_cap_def sep_state_accessors
                        sane_components_def)
  apply (rule_tac ko="set_ko_cap ko b cap" in sep_map_capI)
      apply (auto simp: sep_state_accessors sane_components_def
                        ko_clean_set_ko_cap
                  intro: bounded_ko_clean_set_ko_cap bounded_set_ko_cap)
 done

lemma kheap_shadow_upd:
  "\<lbrakk> kh p = Some (ko',cmps') ; a_base_type ko' = a_base_type ko \<rbrakk>
   \<Longrightarrow> kheap_shadow (kh(p \<mapsto> (ko,cmps))) = kheap_shadow kh"
  by (rule ext, auto intro: ocm_shadow_eq_both simp: kheap_shadow_def)

lemma kheap_dom_upd:
  "\<lbrakk> kh p = Some (ko', cmps') ; a_base_type ko' = a_base_type ko \<rbrakk>
   \<Longrightarrow> kheap_dom (kh(p \<mapsto> (ko, cmps))) = kheap_dom kh"
  by (clarsimp simp: kheap_dom_def kheap_shadows_def)
     (fastforce simp only: kheap_shadow_upd)

lemma obj_comp_map_disj_set_ko_cap:
  "\<lbrakk> obj_comp_map_disj x y ; ocm_has_cap x p ko cmps i c \<rbrakk>
   \<Longrightarrow> obj_comp_map_disj (x(p \<mapsto> (set_ko_cap ko i cap, cmps))) y"
  apply (clarsimp simp: obj_comp_map_disj_def split_def ocm_has_cap_def
                     ko_has_cap_def
               dest: cap_of_ko_cleanD split: option.splits)
  apply (erule_tac x=p in allE, clarsimp)
  apply (clarsimp dest!: check_components_Int_emptyD cap_of_ko_cleanD)
  apply (subst check_components_id,
         simp_all add: bounded_ko_clean_set_ko_cap check_components_id)
  apply (subst bounded_ko_clean_set_ko_cap)
   apply simp_all
  apply (drule cap_of_ko_cleanD)
   apply simp
  apply simp
  done (* yuck *)

lemma sep_update_cap_disj:
  "\<lbrakk> x ## y ; ocm_has_cap (sep_state_ocm x) p ko cmps i c \<rbrakk>
   \<Longrightarrow> sep_update_cap (p, i) cap x ## y"
  unfolding ocm_has_cap_def ko_has_cap_def
  apply (clarsimp simp: sep_disj_defs sep_state_accessors sep_update_cap_def
                  split: sep_state.splits)
  apply (subst kheap_dom_upd, assumption)
   apply (fastforce dest!: cap_of_ko_cleanD)
  apply (subst obj_comp_map_disj_set_ko_cap, assumption+)
   apply (fastforce simp: ocm_has_cap_def ko_has_cap_def)
  apply (clarsimp simp: kheap_shadows_def)
  apply (subst kheap_shadow_upd, assumption)
   apply simp
  apply (subst kheap_shadow_upd, assumption)
   apply simp
  apply clarsimp
  apply (rule conjI)
   apply blast
  apply blast
  done (* yuck *)

lemma sep_state_free_sep_update_cap [simp]:
  "sep_state_free (sep_update_cap kcmp cap s) = sep_state_free s"
  by (clarsimp simp: sep_update_cap_def sep_state_accessors
               split: sep_state.splits prod.splits)

lemma sep_state_avail_sep_update_cap [simp]:
  "sep_state_avail (sep_update_cap (p,i) cap s) = sep_state_avail s"
  by (clarsimp simp: sep_update_cap_def sep_state_accessors
               split: sep_state.splits prod.splits)

lemma sep_update_cap_disj_add:
  "\<lbrakk> x ## y ; ocm_has_cap (sep_state_ocm x) p ko cmps i c \<rbrakk>
   \<Longrightarrow> sep_update_cap (p,i) cap (x + y) = sep_update_cap (p,i) cap x + y"
  apply (clarsimp intro!: sep_state_eq_piecewiseI
               simp: sep_disj_defs sep_state_ocm_def sep_update_cap_def
                     sep_add_defs obj_comp_map_add_def ocm_has_cap_def
               split: sep_state.splits option.splits)
  apply (rule conjI)
   apply clarsimp
   apply  (fastforce intro!: ext split: option.splits
               dest!: check_components_Int_emptyD
               simp: ko_has_cap_def obj_comp_map_disj_def
                     ko_combine_def ko_override_set_ko_cap)
   apply (clarsimp)
   apply (rule ext)
   apply clarsimp
   apply (clarsimp simp: ko_has_cap_def obj_comp_map_disj_def
                         ko_combine_def ko_override_set_ko_cap)
   apply (erule_tac x=p in allE)
   apply (subst ko_override_set_ko_cap, simp_all)
   apply clarsimp
   apply (drule check_components_Int_emptyD)
   apply clarsimp
   done

lemma sep_map_cap_update_cap':
  assumes sep: "(sep_map_cap atyp p old_cap \<and>* P) s"
  shows "(sep_map_cap atyp p cap \<and>* P) (sep_update_cap p cap s)"
proof -
  from sep obtain s1 s2 where s: "s = s1 + s2" and s_disj: "s1 ## s2"
    and oldmap: "(sep_map_cap atyp p old_cap) s1" and P: "P s2"
    by (blast dest: sep_conjD)

  let ?s1' = "sep_update_cap p cap s1"

  from oldmap have newmap: "sep_map_cap atyp p cap ?s1'"
    by (fastforce intro: sep_map_cap_update_cap)

  moreover have "?s1' ## s2" using s_disj oldmap
    by (cases p, fastforce dest!: sep_map_capD elim: sep_update_cap_disj
                          simp: ocm_has_cap_def ko_has_cap_def)

  moreover have "sep_update_cap p cap s = sep_update_cap p cap s1 + s2"
    using s oldmap s_disj
    by (cases p, fastforce dest!: sep_map_cap_ocm_has_capI
                          simp: sep_update_cap_disj_add)

  ultimately show ?thesis using s_disj by (blast intro: sep_conjI P)
qed


subsection {* Properties of Lifting Kernel States into Init *}

text {*
  This style of lift-reasoning is used for low-level interaction with other
  wp rules and establishing a link between kernel state operations and
  kernel init state predicates.
*}

lemma dom_ocm_dom_kheap_kis_lift:
  "dom (sep_state_ocm (kis_lift kis s)) = dom (kheap s)"
  by (fastforce simp: sep_state_ocm_def lift_sep_state_def
               split: option.splits)

lemma sep_state_ocm_ki_components:
  "sep_state_ocm (lift_sep_state kis) p = Some (a,b)
   \<Longrightarrow> ki_components kis p = b"
  by (fastforce simp: sep_state_ocm_def lift_sep_state_def
               split: option.splits)

lemma sep_map_base_kis_liftD:
  "sep_map_base p ko cmps (kis_lift kis s)
   \<Longrightarrow> \<exists>ko'. kheap s p = Some ko' \<and>
            dom (kheap s) = {p} \<and>
            is_aligned p (t_obj_bits ko) \<and>
            ki_components kis p = cmps \<and>
            ko_clean ko' cmps = ko_clean ko cmps \<and>
            sane_components (ko_clean ko' cmps) cmps \<and>
            ki_free_mem kis = {} \<and>
            ki_available_mem kis = {}"
  by (auto simp: lift_sep_state_def sep_map_base_def split: option.splits)

lemma sep_map_base_kis_liftI:
  "\<lbrakk> kheap s p = Some ko' ; dom (kheap s) = {p} ;
     is_aligned p (t_obj_bits ko) ;
     ki_components kis p = cmps ;
     ko_clean ko' cmps = ko_clean ko cmps ;
     sane_components (ko_clean ko' cmps) cmps ;
     ki_free_mem kis = {} \<and>
     ki_available_mem kis = {} \<rbrakk>
   \<Longrightarrow> sep_map_base p ko cmps (kis_lift kis s)"
  by (fastforce simp: lift_sep_state_def sep_map_base_def)

lemma sep_map_cap_kis_liftD:
  "sep_map_cap atyp (p,i) cap (kis_lift kis s)
   \<Longrightarrow> \<exists>ko. kheap s p = Some ko \<and>
            dom (kheap s) = {p} \<and>
            is_aligned p (t_obj_bits ko) \<and>
            ki_components kis p = {cmp_of ko i} \<and>
            a_base_type ko = atyp \<and>
            cap_of ko i = Some cap \<and>
            sane_components (ko_clean ko {cmp_of ko i}) {cmp_of ko i} \<and>
            ki_free_mem kis = {} \<and>
            ki_available_mem kis = {}"
proof (clarsimp dest!: sep_map_base_kis_liftD simp: sep_map_cap_def)
  fix x ko'
  assume align: "is_aligned p (t_obj_bits x)"
  assume a: "cap_of x i = Some cap"
  assume b: "ko_clean ko' {cmp_of x i} = ko_clean x {cmp_of x i}"

  hence "a_base_type (ko_clean ko' {cmp_of x i})
          = a_base_type (ko_clean x {cmp_of x i})"
    by simp
  hence ts [simp]: "a_base_type ko' = a_base_type x" (is ?t) by simp

  assume c: "sane_components (ko_clean x {cmp_of x i}) {cmp_of x i}"

  have x: "cmp_of x i = cmp_of ko' i" (is ?x) using b by simp
  moreover
  have "cap_of ko' i = Some cap" (is ?y) using a b
    by - (rule_tac cmps="{cmp_of x i}" in cap_of_ko_cleanD, auto)
  moreover
  have "sane_components (ko_clean ko' {cmp_of ko' i}) {cmp_of ko' i}" (is ?z)
    using c
    by (clarsimp simp: sane_components_def b)
  ultimately
  show "is_aligned p (t_obj_bits ko') \<and> ?x \<and> ?t \<and> ?y \<and> ?z" using align
    by auto
qed

lemma sep_map_cap_kis_liftI:
  "\<lbrakk> kheap s p = Some ko ; dom (kheap s) = {p} ;
     is_aligned p (t_obj_bits ko) ;
     ki_components kis p = {cmp_of ko i} ;
     a_base_type ko = atyp \<and>
     cap_of ko i = Some cap ;
     sane_components (ko_clean ko {cmp_of ko i}) {cmp_of ko i} ;
     ki_free_mem kis = {} ;
     ki_available_mem kis = {} \<rbrakk>
   \<Longrightarrow> sep_map_cap atyp (p,i) cap (kis_lift kis s)"
  apply (clarsimp simp: sep_map_cap_def)
  apply (rule_tac x=ko in exI)
  apply (fastforce intro!: sep_map_base_kis_liftI split: option.splits
                   simp: lift_sep_state_def sep_state_accessors)
  done


end