Invariants_AI.thy

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

theory Invariants_AI
imports ArchInvariants_AI
begin

arch_requalify_types
  iarch_tcb

arch_requalify_consts (A)
  arch_cap_is_device
  ASIDPoolObj

(* we need to know the sizes of arch objects in the generic context *)
arch_requalify_facts (A)
  cte_level_bits_def
  tcb_bits_def
  endpoint_bits_def
  ntfn_bits_def

arch_requalify_consts
  not_kernel_window
  global_refs
  arch_obj_bits_type
  is_nondevice_page_cap
  state_hyp_refs_of
  hyp_refs_of
  hyp_live

  wellformed_acap
  valid_arch_cap
  valid_arch_cap_ref
  acap_class
  valid_ipc_buffer_cap
  arch_valid_obj
  valid_asid_map
  valid_vspace_obj
  valid_arch_tcb
  valid_arch_idle

  valid_arch_state
  valid_vspace_objs
  valid_arch_caps
  valid_global_objs
  valid_kernel_mappings
  equal_kernel_mappings
  valid_global_vspace_mappings
  pspace_in_kernel_window

  valid_vs_lookup
  user_mem
  device_mem
  device_region
  tcb_arch_ref

  valid_arch_mdb
  arch_tcb_to_iarch_tcb

  vs_lookup
  vs_lookup_pages

arch_requalify_facts
  valid_arch_sizes
  aobj_bits_T
  valid_arch_cap_def2
  idle_global
  valid_ipc_buffer_cap_null
  valid_arch_cap_typ
  valid_vspace_obj_typ
  arch_kobj_size_bounded
  global_refs_lift
  aobj_at_default_arch_cap_valid
  aobj_ref_default
  wf_acap_rights_update_id
  physical_arch_cap_has_ref
  wellformed_arch_default
  valid_vspace_obj_default'
  typ_at_pg
  state_hyp_refs_of_elemD
  ko_at_state_hyp_refs_ofD
  hyp_sym_refs_obj_atD
  hyp_sym_refs_ko_atD
  state_hyp_refs_of_pspaceI
  state_hyp_refs_update
  hyp_refs_of_hyp_live
  hyp_refs_of_hyp_live_obj
  hyp_refs_of_simps
  tcb_arch_ref_simps
  hyp_live_tcb_simps
  hyp_live_tcb_def
  wellformed_arch_pspace
  wellformed_arch_typ
  valid_arch_tcb_pspaceI
  valid_arch_tcb_lift
  obj_ref_not_arch_gen_ref
  arch_gen_ref_not_obj_ref
  arch_gen_obj_refs_inD
  same_aobject_same_arch_gen_refs
  valid_arch_mdb_eqI
  iarch_tcb_context_set
  iarch_tcb_set_registers

lemmas [simp] =
  tcb_bits_def
  endpoint_bits_def
  ntfn_bits_def
  iarch_tcb_context_set
  iarch_tcb_set_registers

lemmas [intro!] = idle_global wf_acap_rights_update_id

lemmas [simp] = wf_acap_rights_update_id state_hyp_refs_update
                tcb_arch_ref_simps hyp_live_tcb_simps hyp_refs_of_simps


\<comment> \<open>---------------------------------------------------------------------------\<close>
section "Invariant Definitions for Abstract Spec"

definition
  "is_ep ko \<equiv> case ko of Endpoint p \<Rightarrow> True | _ \<Rightarrow> False"
definition
  "is_ntfn ko \<equiv> case ko of Notification p \<Rightarrow> True | _ \<Rightarrow> False"
definition
  "is_tcb ko \<equiv> case ko of TCB t \<Rightarrow> True | _ \<Rightarrow> False"
definition
  "is_cap_table bits ko \<equiv>
   case ko of CNode sz cs \<Rightarrow> bits = sz \<and> well_formed_cnode_n bits cs
            | _ \<Rightarrow> False"



abbreviation
  "ep_at \<equiv> obj_at is_ep"
abbreviation
  "ntfn_at \<equiv> obj_at is_ntfn"
abbreviation
  "tcb_at \<equiv> obj_at is_tcb"
abbreviation
  "cap_table_at bits \<equiv> obj_at (is_cap_table bits)"
abbreviation
  "real_cte_at cref \<equiv> cap_table_at (length (snd cref)) (fst cref)"


(*
  'itcb' is a projection of the "mostly preserved" fields of 'tcb'. Many
  functions in the spec will leave these fields of a TCB unchanged. The 'crunch'
  tool is easily able to ascertain this from the types of the fields.

  The 'itcb' record is closely associated with the 'pred_tcb_at' definition.
  'pred_tcb_at' is used to assert an arbitrary predicate over the fields in
  'itcb' for a TCB. Before the introduction of this data structure 'st_tcb_at'
  was defined directly. It is now an abbreviation of a partial application of
  the 'pred_tcb_at' function, specifically a partial application to the
  projection function 'itcb_state'.

  The advantage of this approach is that we an assert 'pred_tcb_at proj P t' is
  preserved across calls to many functions. We get "for free" that 'st_tcb_at P
  t' is also preserved. In the future we may introduce other abbreviations that
  assert preservation over other fields in the TCB record.
 *)
record itcb =
  itcb_state         :: thread_state
  itcb_fault_handler :: cap_ref
  itcb_ipc_buffer    :: vspace_ref
  itcb_fault         :: "fault option"
  itcb_bound_notification     :: "obj_ref option"
  itcb_mcpriority    :: priority
  itcb_arch          :: iarch_tcb

abbreviation
  "tcb_iarch tcb \<equiv> arch_tcb_to_iarch_tcb (tcb_arch tcb)"

definition
  tcb_to_itcb :: "tcb \<Rightarrow> itcb"
where
  "tcb_to_itcb tcb \<equiv>
     \<lparr> itcb_state              = tcb_state tcb,
       itcb_fault_handler      = tcb_fault_handler tcb,
       itcb_ipc_buffer         = tcb_ipc_buffer tcb,
       itcb_fault              = tcb_fault tcb,
       itcb_bound_notification = tcb_bound_notification tcb,
       itcb_mcpriority         = tcb_mcpriority tcb,
       itcb_arch               = tcb_iarch tcb \<rparr>"

(*
  The simplification rules below are used to help produce lemmas that talk about
  fields of the 'tcb' data structure rather than the 'itcb' data structure when
  the lemma refers to a predicate of the form 'pred_tcb_at proj P t'.

  e.g. You might have a lemma that has an assumption
    \<And>tcb. itcb_state (tcb_to_itcb (f tcb)) = itcb_state (tcb_to_itcb tcb)

  This simplifies to:
    \<And>tcb. tcb_state (f tcb) = tcb_state tcb
*)

(* Need one of these simp rules for each field in 'itcb' *)
lemma tcb_to_itcb_simps[simp]:
  "itcb_state (tcb_to_itcb tcb) = tcb_state tcb"
  "itcb_fault_handler (tcb_to_itcb tcb) = tcb_fault_handler tcb"
  "itcb_ipc_buffer (tcb_to_itcb tcb) = tcb_ipc_buffer tcb"
  "itcb_fault (tcb_to_itcb tcb) = tcb_fault tcb"
  "itcb_bound_notification (tcb_to_itcb tcb) = tcb_bound_notification tcb"
  "itcb_mcpriority (tcb_to_itcb tcb) = tcb_mcpriority tcb"
  "itcb_arch (tcb_to_itcb tcb) = tcb_iarch tcb"
  by (auto simp: tcb_to_itcb_def)

(* This is used to assert whether an itcb projection is affected by a tcb
   field update, such as tcb_arch_update. *)
abbreviation
  "proj_not_field proj field_upd \<equiv>
     \<forall>f tcb. proj (tcb_to_itcb ((field_upd f) tcb)) = proj (tcb_to_itcb tcb)"

definition
  pred_tcb_at :: "(itcb \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> machine_word \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "pred_tcb_at proj test \<equiv> obj_at (\<lambda>ko. \<exists>tcb. ko = TCB tcb \<and> test (proj (tcb_to_itcb tcb)))"

abbreviation "st_tcb_at \<equiv> pred_tcb_at itcb_state"
abbreviation "bound_tcb_at \<equiv> pred_tcb_at itcb_bound_notification"
abbreviation "mcpriority_tcb_at \<equiv> pred_tcb_at itcb_mcpriority"
abbreviation "arch_tcb_at \<equiv> pred_tcb_at itcb_arch"

(* sseefried: 'st_tcb_at_def' only exists to make existing proofs go through. Use 'pred_tcb_at_def' from now on. *)
lemma st_tcb_at_def: "st_tcb_at test \<equiv> obj_at (\<lambda>ko. \<exists>tcb. ko = TCB tcb \<and> test (tcb_state tcb))"
  by (simp add: pred_tcb_at_def)

text \<open>cte with property at\<close>

definition
  cte_wp_at :: "(cap \<Rightarrow> bool) \<Rightarrow> cslot_ptr \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "cte_wp_at P p s \<equiv> \<exists>cap. fst (get_cap p s) = {(cap,s)} \<and> P cap"

abbreviation
  cte_at :: "cslot_ptr \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "cte_at \<equiv> cte_wp_at \<top>"

lemma cte_wp_at_lift:
  "\<lbrakk>cte_wp_at P p s ; \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> cte_wp_at Q p s"
  by (fastforce simp: cte_wp_at_def)


subsection "Valid caps and objects"

primrec
  untyped_range :: "cap \<Rightarrow> machine_word set"
where
  "untyped_range (cap.UntypedCap dev p n f)             = {p..p + (1 << n) - 1}"
| "untyped_range (cap.NullCap)                          = {}"
| "untyped_range (cap.EndpointCap r badge rights)       = {}"
| "untyped_range (cap.NotificationCap r badge rights)   = {}"
| "untyped_range (cap.CNodeCap r bits guard)            = {}"
| "untyped_range (cap.ThreadCap r)                      = {}"
| "untyped_range (cap.DomainCap)                        = {}"
| "untyped_range (cap.ReplyCap r master rights)         = {}"
| "untyped_range (cap.IRQControlCap)                    = {}"
| "untyped_range (cap.IRQHandlerCap irq)                = {}"
| "untyped_range (cap.Zombie r b n)                     = {}"
| "untyped_range (cap.ArchObjectCap cap)                = {}"

primrec (nonexhaustive)
  usable_untyped_range :: "cap \<Rightarrow> machine_word set"
where
 "usable_untyped_range (UntypedCap _ p n f) =
  (if f < 2^n  then {p+of_nat f .. p + 2 ^ n - 1} else {})"

definition
  "obj_range p obj \<equiv> {p .. p + 2^obj_bits obj - 1}" (* FIXME mask_range *)

definition
  "pspace_no_overlap S \<equiv>
           \<lambda>s. \<forall>x ko. kheap s x = Some ko \<longrightarrow>
                {x .. x + (2 ^ obj_bits ko - 1)} \<inter> S = {}" (* FIXME obj_range *)

definition
  "valid_untyped c \<equiv> \<lambda>s.
  \<forall>p obj.
     kheap s p = Some obj \<longrightarrow>
     obj_range p obj \<inter> untyped_range c \<noteq> {} \<longrightarrow>
     ( obj_range p obj \<subseteq> untyped_range c \<and> usable_untyped_range c \<inter> obj_range p obj = {} )"

primrec
  cap_bits :: "cap \<Rightarrow> nat"
where
  "cap_bits NullCap = 0"
| "cap_bits (UntypedCap dev r b f) = b"
| "cap_bits (EndpointCap r b R) = obj_bits (Endpoint undefined)"
| "cap_bits (NotificationCap r b R) = obj_bits (Notification undefined)"
| "cap_bits (CNodeCap r b m) = cte_level_bits + b"
| "cap_bits (ThreadCap r) = obj_bits (TCB undefined)"
| "cap_bits (DomainCap) = 0"
| "cap_bits (ReplyCap r m R) = obj_bits (TCB undefined)"
| "cap_bits (Zombie r zs n) =
    (case zs of None \<Rightarrow> obj_bits (TCB undefined)
            | Some n \<Rightarrow> cte_level_bits + n)"
| "cap_bits (IRQControlCap) = 0"
| "cap_bits (IRQHandlerCap irq) = 0"
| "cap_bits (ArchObjectCap x) = arch_obj_size x"

fun
  cap_is_device :: "cap \<Rightarrow> bool"
where
  "cap_is_device (cap.UntypedCap dev r b f) = dev"
| "cap_is_device (cap.ArchObjectCap x) = arch_cap_is_device x"
| "cap_is_device _ = False"

definition
  "cap_aligned c \<equiv>
   is_aligned (obj_ref_of c) (cap_bits c) \<and> cap_bits c < word_bits"


text \<open>
  Below, we define several predicates for capabilities on the abstract specification.
  Please note that we distinguish between well-formedness predicates,
  which merely refine the basic type and are independent of the kernel state,
  and the validity of the capability references,
  which necessarily depends on the current kernel state.

  Eventually, we will combine all predicates into @{text valid_cap}.
\<close>


definition
  wellformed_cap :: "cap \<Rightarrow> bool"
where
  "wellformed_cap c \<equiv>
  case c of
    UntypedCap dev p sz idx \<Rightarrow> untyped_min_bits \<le> sz
  | NotificationCap r badge rights \<Rightarrow> AllowGrant \<notin> rights \<and> AllowGrantReply \<notin> rights
  | CNodeCap r bits guard \<Rightarrow> bits \<noteq> 0 \<and> length guard \<le> word_bits
  | IRQHandlerCap irq \<Rightarrow> irq \<le> maxIRQ
  | Zombie r b n \<Rightarrow> (case b of None \<Rightarrow> n \<le> 5
                                          | Some b \<Rightarrow> n \<le> 2 ^ b \<and> b \<noteq> 0)
  | ArchObjectCap ac \<Rightarrow> wellformed_acap ac
  | ReplyCap t master rights \<Rightarrow> AllowWrite \<in> rights \<and> AllowRead \<notin> rights \<and>
      AllowGrantReply \<notin> rights
  | _ \<Rightarrow> True"

definition
  valid_cap_ref :: "cap \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "valid_cap_ref c s \<equiv> case c of
    NullCap \<Rightarrow> True
  | UntypedCap dev p b idx \<Rightarrow> valid_untyped c s \<and> idx \<le> 2^ b \<and> p \<noteq> 0
  | EndpointCap r badge rights \<Rightarrow> ep_at r s
  | NotificationCap r badge rights \<Rightarrow> ntfn_at r s
  | CNodeCap r bits guard \<Rightarrow> cap_table_at bits r s
  | ThreadCap r \<Rightarrow> tcb_at r s
  | DomainCap \<Rightarrow> True
  | ReplyCap r m rights \<Rightarrow> tcb_at r s
  | IRQControlCap \<Rightarrow> True
  | IRQHandlerCap irq \<Rightarrow> True
  | Zombie r b n \<Rightarrow>
      (case b of None \<Rightarrow> tcb_at r s | Some b \<Rightarrow> cap_table_at b r s)
  | ArchObjectCap ac \<Rightarrow> valid_arch_cap_ref ac s"


definition
  valid_cap :: "cap \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "valid_cap c s \<equiv> cap_aligned c \<and> (case c of
    NullCap \<Rightarrow> True
  | UntypedCap dev p b f \<Rightarrow> valid_untyped c s \<and> untyped_min_bits \<le> b \<and> f \<le> 2 ^ b \<and> p \<noteq> 0
  | EndpointCap r badge rights \<Rightarrow> ep_at r s
  | NotificationCap r badge rights \<Rightarrow>
         ntfn_at r s \<and> AllowGrant \<notin> rights \<and> AllowGrantReply \<notin> rights
  | CNodeCap r bits guard \<Rightarrow>
         cap_table_at bits r s \<and> bits \<noteq> 0 \<and> length guard \<le> word_bits
  | ThreadCap r \<Rightarrow> tcb_at r s
  | DomainCap \<Rightarrow> True
  | ReplyCap r m rights \<Rightarrow> tcb_at r s
                        \<and> AllowWrite \<in> rights \<and> AllowRead \<notin> rights \<and> AllowGrantReply \<notin> rights
  | IRQControlCap \<Rightarrow> True
  | IRQHandlerCap irq \<Rightarrow> irq \<le> maxIRQ
  | Zombie r b n \<Rightarrow>
         (case b of None \<Rightarrow> tcb_at r s \<and> n \<le> 5
                  | Some b \<Rightarrow> cap_table_at b r s \<and> n \<le> 2 ^ b \<and> b \<noteq> 0)
  | ArchObjectCap ac \<Rightarrow> valid_arch_cap ac s)"


abbreviation
  valid_cap_syn :: "'z::state_ext state \<Rightarrow> cap \<Rightarrow> bool" ("_ \<turnstile> _" [60, 60] 61)
where
  "s \<turnstile> c \<equiv> valid_cap c s"

definition
  "valid_caps cs s \<equiv> \<forall>slot cap. cs slot = Some cap \<longrightarrow> valid_cap cap s"

primrec
  cap_class :: "cap \<Rightarrow> capclass"
where
  "cap_class (cap.NullCap)                          = NullClass"
| "cap_class (cap.UntypedCap dev p n f)             = PhysicalClass"
| "cap_class (cap.EndpointCap ref badge r)          = PhysicalClass"
| "cap_class (cap.NotificationCap ref badge r)     = PhysicalClass"
| "cap_class (cap.CNodeCap ref n bits)              = PhysicalClass"
| "cap_class (cap.ThreadCap ref)                    = PhysicalClass"
| "cap_class (cap.DomainCap)                        = DomainClass"
| "cap_class (cap.Zombie r b n)                     = PhysicalClass"
| "cap_class (cap.IRQControlCap)                    = IRQClass"
| "cap_class (cap.IRQHandlerCap irq)                = IRQClass"
| "cap_class (cap.ReplyCap tcb m rights)            = ReplyClass tcb"
| "cap_class (cap.ArchObjectCap cap)                = acap_class cap"


definition
  valid_cs_size :: "nat \<Rightarrow> cnode_contents \<Rightarrow> bool" where
  "valid_cs_size sz cs \<equiv>
  sz < word_bits - cte_level_bits \<and> well_formed_cnode_n sz cs"

definition
  valid_cs :: "nat \<Rightarrow> cnode_contents \<Rightarrow> 'z::state_ext state \<Rightarrow> bool" where
  "valid_cs sz cs s \<equiv> (\<forall>cap \<in> ran cs. s \<turnstile> cap) \<and> valid_cs_size sz cs"

definition
  valid_tcb_state :: "thread_state \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "valid_tcb_state ts s \<equiv> case ts of
    BlockedOnReceive ref sp \<Rightarrow> ep_at ref s
  | BlockedOnSend ref sp \<Rightarrow> ep_at ref s
  | BlockedOnNotification ref \<Rightarrow> ntfn_at ref s
  | _ \<Rightarrow> True"

abbreviation
  "inactive st \<equiv> st = Inactive"

abbreviation
  "halted st \<equiv> case st of
                     Inactive \<Rightarrow> True
                   | IdleThreadState \<Rightarrow> True
                   | _ \<Rightarrow> False"

text \<open>
  For each slot in the tcb, we give the accessor function, the update function and
  The invariant that should be verified about that slot.

  The invariant parameters are: thread_ptr, thread_state, cap_in_that_slot
\<close>
(* WARNING to anyone who would like to add an invariant to ctable slot:
   During deletion procedure, any type of cap can land in that slot *)
definition
  tcb_cap_cases ::
  "cap_ref \<rightharpoonup> ((tcb \<Rightarrow> cap) \<times>
               ((cap \<Rightarrow> cap) \<Rightarrow> tcb \<Rightarrow> tcb) \<times>
               (obj_ref \<Rightarrow> thread_state \<Rightarrow> cap \<Rightarrow> bool))"
where
  "tcb_cap_cases \<equiv>
   [tcb_cnode_index 0 \<mapsto> (tcb_ctable, tcb_ctable_update, (\<lambda>_ _. \<top>)),
    tcb_cnode_index 1 \<mapsto> (tcb_vtable, tcb_vtable_update,
                          (\<lambda>_ _. is_valid_vtable_root or ((=) NullCap))),
    tcb_cnode_index 2 \<mapsto> (tcb_reply, tcb_reply_update,
                          (\<lambda>t st c. (is_master_reply_cap c \<and> obj_ref_of c = t
                                     \<and> AllowGrant \<in> cap_rights c)
                                  \<or> (halted st \<and> (c = NullCap)))),
    tcb_cnode_index 3 \<mapsto> (tcb_caller, tcb_caller_update,
                          (\<lambda>_ st. case st of
                                    BlockedOnReceive e data \<Rightarrow>
                                      (=) NullCap
                                  | _ \<Rightarrow> is_reply_cap or (=) NullCap)),
    tcb_cnode_index 4 \<mapsto> (tcb_ipcframe, tcb_ipcframe_update,
                          (\<lambda>_ _. is_nondevice_page_cap or ((=) NullCap)))]"

definition
  valid_fault :: "ExceptionTypes_A.fault \<Rightarrow> bool"
where
  "valid_fault f \<equiv>
   \<forall>mw b n g. f = (ExceptionTypes_A.CapFault mw b
                     (ExceptionTypes_A.GuardMismatch n g)) \<longrightarrow> length g\<le>word_bits"

definition
  valid_bound_ntfn :: "machine_word option \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "valid_bound_ntfn ntfn_opt s \<equiv> case ntfn_opt of
                                 None \<Rightarrow> True
                               | Some a \<Rightarrow> ntfn_at a s"

definition
  valid_bound_tcb :: "machine_word option \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "valid_bound_tcb tcb_opt s \<equiv> case tcb_opt of
                                 None \<Rightarrow> True
                               | Some t \<Rightarrow> tcb_at t s"


definition
  valid_ntfn :: "notification \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "valid_ntfn ntfn s \<equiv> (case ntfn_obj ntfn of
    IdleNtfn \<Rightarrow>  True
  | WaitingNtfn ts \<Rightarrow>
      (ts \<noteq> [] \<and> (\<forall>t \<in> set ts. tcb_at t s)
       \<and> distinct ts
       \<and> (case ntfn_bound_tcb ntfn of Some tcb \<Rightarrow> ts = [tcb] | _ \<Rightarrow> True))
  | ActiveNtfn b \<Rightarrow> True)
 \<and> valid_bound_tcb (ntfn_bound_tcb ntfn) s"

definition
  valid_tcb :: "obj_ref \<Rightarrow> tcb \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "valid_tcb p t s \<equiv>
     (\<forall>(getF, setF, restr) \<in> ran tcb_cap_cases.
       s \<turnstile> getF t \<and> restr p (tcb_state t) (getF t))
     \<and> valid_ipc_buffer_cap (tcb_ipcframe t) (tcb_ipc_buffer t)
     \<and> valid_tcb_state (tcb_state t) s
     \<and> (case tcb_fault t of Some f \<Rightarrow> valid_fault f | _ \<Rightarrow> True)
     \<and> length (tcb_fault_handler t) = word_bits
     \<and> valid_bound_ntfn (tcb_bound_notification t) s
     \<and> valid_arch_tcb (tcb_arch t) s"

definition
  tcb_cap_valid :: "cap \<Rightarrow> cslot_ptr \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "tcb_cap_valid cap ptr s \<equiv> tcb_at (fst ptr) s \<longrightarrow>
     st_tcb_at (\<lambda>st. case tcb_cap_cases (snd ptr) of
                          Some (getF, setF, restr) \<Rightarrow> restr (fst ptr) st cap
                        | None \<Rightarrow> True)
               (fst ptr) s
      \<and> (snd ptr = tcb_cnode_index 4 \<longrightarrow>
           (\<forall>tcb. ko_at (TCB tcb) (fst ptr) s
                   \<longrightarrow> valid_ipc_buffer_cap cap (tcb_ipc_buffer tcb)))"

definition
  valid_ep :: "endpoint \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "valid_ep ep s \<equiv> case ep of
    IdleEP \<Rightarrow> True
  | SendEP ts \<Rightarrow>
      (ts \<noteq> [] \<and> (\<forall>t \<in> set ts. tcb_at t s) \<and> distinct ts)
  | RecvEP ts \<Rightarrow>
      (ts \<noteq> [] \<and> (\<forall>t \<in> set ts. tcb_at t s) \<and> distinct ts)"

definition
  valid_obj :: "obj_ref \<Rightarrow> kernel_object \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "valid_obj ptr ko s \<equiv> case ko of
    Endpoint p \<Rightarrow> valid_ep p s
  | Notification p \<Rightarrow> valid_ntfn p s
  | TCB t \<Rightarrow> valid_tcb ptr t s
  | CNode sz cs \<Rightarrow> valid_cs sz cs s
  | ArchObj ao \<Rightarrow> arch_valid_obj ao s"

definition
  valid_objs :: "'z::state_ext state \<Rightarrow> bool"
where
  "valid_objs s \<equiv> \<forall>ptr \<in> dom $ kheap s. \<exists>obj. kheap s ptr = Some obj \<and> valid_obj ptr obj s"

text \<open>simple kernel objects\<close>

lemma obj_at_eq_helper:
  "\<lbrakk> \<And>obj. P obj = P' obj \<rbrakk> \<Longrightarrow> obj_at P = obj_at P'"
  apply (rule ext)+
  apply (simp add: obj_at_def)
  done

lemma is_ep_def2: "(is_ep ko) = bound (partial_inv Endpoint ko)"
  by (auto simp: is_ep_def split: kernel_object.splits)

lemma ep_at_def2: "ep_at = (obj_at (\<lambda>ko. bound (partial_inv Endpoint ko)))"
  by (rule obj_at_eq_helper, simp add: is_ep_def2)

lemma is_ntfn_def2: "(is_ntfn ko) = bound (partial_inv Notification ko)"
  by (auto simp: is_ntfn_def split: kernel_object.splits)

lemma ntfn_at_def2: "ntfn_at = (obj_at (\<lambda>ko. bound (partial_inv Notification ko)))"
  by (rule obj_at_eq_helper, simp add: is_ntfn_def2)

definition
  valid_simple_obj :: "kernel_object \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "valid_simple_obj ko s \<equiv> case ko of
    Endpoint p \<Rightarrow> valid_ep p s
  | Notification p \<Rightarrow> valid_ntfn p s
  | TCB t \<Rightarrow> True
  | CNode sz cs \<Rightarrow> True
  | ArchObj ao \<Rightarrow> arch_valid_obj ao s"

definition
  valid_simple_objs :: "'z::state_ext state \<Rightarrow> bool"
where
  "valid_simple_objs s \<equiv> \<forall>ptr \<in> dom $ kheap s. \<exists>obj. kheap s ptr = Some obj \<and> valid_simple_obj obj s"

lemma valid_obj_imp_valid_simple: "valid_obj p ko s \<Longrightarrow> valid_simple_obj ko s"
  by (clarsimp simp: valid_obj_def valid_simple_obj_def split: kernel_object.splits)

lemma valid_objs_imp_valid_simple_objs: "valid_objs s \<Longrightarrow> valid_simple_objs s"
  by (fastforce simp: valid_obj_imp_valid_simple valid_objs_def valid_simple_objs_def
                split: kernel_object.splits)

declare valid_simple_obj_def[simp]

lemma valid_ep_def2: "valid_ep = (\<lambda>x s. valid_simple_obj (Endpoint x) s)"
  by simp

lemma valid_ntfn_def2: "valid_ntfn = (\<lambda>x s. valid_simple_obj (Notification x) s)"
  by simp

lemma valid_simple_kheap:"\<lbrakk>kheap s p = Some v ;
                 a_type v \<in> {AEndpoint, ANTFN} \<rbrakk>\<Longrightarrow> valid_obj p v s = valid_simple_obj v s"
  by (auto simp: valid_obj_imp_valid_simple valid_obj_def a_type_def
           split: kernel_object.splits if_splits)

abbreviation
  "simple_typ_at \<equiv> obj_at (\<lambda>ob. a_type ob \<in> {AEndpoint, ANTFN})"

text \<open>symref related definitions\<close>

definition
  tcb_st_refs_of :: "thread_state  \<Rightarrow> (obj_ref \<times> reftype) set"
where
  "tcb_st_refs_of z \<equiv> case z of
    (Running)                 => {}
  | (Inactive)                => {}
  | (Restart)                 => {}
  | (BlockedOnReply)          => {}
  | (IdleThreadState)         => {}
  | (BlockedOnReceive x payl) => {(x, TCBBlockedRecv)}
  | (BlockedOnSend x payl)    => {(x, TCBBlockedSend)}
  | (BlockedOnNotification x) => {(x, TCBSignal)}"

definition
  ep_q_refs_of   :: "endpoint      \<Rightarrow> (obj_ref \<times> reftype) set"
where
  "ep_q_refs_of x \<equiv> case x of
    IdleEP    => {}
  | (RecvEP q) => set q \<times> {EPRecv}
  | (SendEP q) => set q \<times> {EPSend}"

definition
  ntfn_q_refs_of  :: "ntfn                   \<Rightarrow> (obj_ref \<times> reftype) set"
where
  "ntfn_q_refs_of x \<equiv> case x of
     IdleNtfn         => {}
  | (WaitingNtfn q)   => set q \<times> {NTFNSignal}
  | (ActiveNtfn b)  => {}"

(* FIXME-NTFN: two new functions: ntfn_bound_refs and tcb_bound_refs, include below by union *)

definition
  ntfn_bound_refs :: "obj_ref option \<Rightarrow> (obj_ref \<times> reftype) set"
where
  "ntfn_bound_refs t \<equiv> case t of
     Some tcb \<Rightarrow> {(tcb, NTFNBound)}
   | None \<Rightarrow> {}"

definition
  tcb_bound_refs :: "obj_ref option \<Rightarrow> (obj_ref \<times> reftype) set"
where
  "tcb_bound_refs a \<equiv> case a of
     Some ntfn \<Rightarrow> {(ntfn, TCBBound)}
   | None \<Rightarrow> {}"

definition (* ARMHYP *)
  refs_of :: "kernel_object \<Rightarrow> (obj_ref \<times> reftype) set"
where
  "refs_of x \<equiv> case x of
     CNode sz fun      => {}
   | TCB tcb           => tcb_st_refs_of (tcb_state tcb) \<union> tcb_bound_refs (tcb_bound_notification tcb)
   | Endpoint ep       => ep_q_refs_of ep
   | Notification ntfn => ntfn_q_refs_of (ntfn_obj ntfn) \<union> ntfn_bound_refs (ntfn_bound_tcb ntfn)
   | ArchObj ao        => {}"

definition
  state_refs_of :: "'z::state_ext state \<Rightarrow> obj_ref \<Rightarrow> (obj_ref \<times> reftype) set"
where
 "state_refs_of s \<equiv> \<lambda>x. case (kheap s x) of Some ko \<Rightarrow> refs_of ko | None \<Rightarrow> {}"

definition all_refs_of :: "kernel_object \<Rightarrow> (obj_ref \<times> reftype) set"
where "all_refs_of x \<equiv> refs_of x \<union> hyp_refs_of x"

definition
  state_all_refs_of :: "'z::state_ext state \<Rightarrow> obj_ref \<Rightarrow> (obj_ref \<times> reftype) set"
where
 "state_all_refs_of s \<equiv> \<lambda>x. case (kheap s x) of Some ko \<Rightarrow> refs_of ko | None \<Rightarrow> {}"

text "objects live in device_region or non_device_region"

definition
  pspace_respects_device_region:: "'z::state_ext state \<Rightarrow> bool"
where
 "pspace_respects_device_region \<equiv> \<lambda>s. (dom (user_mem s)) \<subseteq> - (device_region s)
 \<and> (dom (device_mem s)) \<subseteq> (device_region s)"


primrec
  live0 :: "kernel_object \<Rightarrow> bool"
where
  "live0 (CNode sz fun)      = False"
| "live0 (TCB tcb)           = (bound (tcb_bound_notification tcb) \<or> (tcb_state tcb \<noteq> Inactive \<and>
                               tcb_state tcb \<noteq> IdleThreadState))"
| "live0 (Endpoint ep)       = (ep \<noteq> IdleEP)"
| "live0 (Notification ntfn) = (bound (ntfn_bound_tcb ntfn) \<or> (\<exists>ts. ntfn_obj ntfn = WaitingNtfn ts))"
| "live0 (ArchObj ao)        = False"

definition live :: "kernel_object \<Rightarrow> bool"
where
 "live ko \<equiv> case ko of
     CNode sz fun      => False
   | TCB tcb           => live0 ko \<or> hyp_live ko
   | Endpoint ep       => live0 ko
   | Notification ntfn => live0 ko
   | ArchObj ao        => hyp_live ko"

lemma a_type_arch_live:
  "a_type ko = AArch tp \<Longrightarrow> \<not> live0 ko"
  by (simp add: a_type_def
         split: Structures_A.kernel_object.split_asm)

fun
  zobj_refs :: "cap \<Rightarrow> obj_ref set"
where
  "zobj_refs (Zombie r b n) = {}"
| "zobj_refs x                  = obj_refs x"

definition
  ex_nonz_cap_to :: "obj_ref \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
 "ex_nonz_cap_to ref \<equiv> (\<lambda>s. \<exists>cref. cte_wp_at (\<lambda>c. ref \<in> zobj_refs c) cref s)"

text \<open>All live objects have caps. The contrapositive
        of this is significant in establishing invariants
        over retype. The exception are objects that are
        not in the scope of any untyped capability, as
        these can never be retyped.\<close>
definition
  if_live_then_nonz_cap :: "'z::state_ext state \<Rightarrow> bool"
where
 "if_live_then_nonz_cap s \<equiv>
    \<forall>ptr. obj_at live ptr s \<longrightarrow> ex_nonz_cap_to ptr s"

primrec
  cte_refs :: "cap \<Rightarrow> (irq \<Rightarrow> obj_ref) \<Rightarrow> cslot_ptr set"
where
  "cte_refs (UntypedCap dev p n fr) f            = {}"
| "cte_refs (NullCap) f                          = {}"
| "cte_refs (EndpointCap r badge rights) f       = {}"
| "cte_refs (NotificationCap r badge rights) f   = {}"
| "cte_refs (CNodeCap r bits guard) f            =
     {r} \<times> {xs. length xs = bits}"
| "cte_refs (ThreadCap r) f                      =
     {r} \<times> (dom tcb_cap_cases)"
| "cte_refs (DomainCap) f                        = {}"
| "cte_refs (Zombie r b n) f                     =
     {r} \<times> {xs. length xs = (zombie_cte_bits b) \<and>
                unat (of_bl xs :: machine_word) < n}"
| "cte_refs (IRQControlCap) f                    = {}"
| "cte_refs (IRQHandlerCap irq) f                = {(f irq, [])}"
| "cte_refs (ReplyCap tcb master rights) f       = {}"
| "cte_refs (ArchObjectCap cap) f                = {}"

definition
  ex_cte_cap_wp_to :: "(cap \<Rightarrow> bool) \<Rightarrow> cslot_ptr \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
 "ex_cte_cap_wp_to P ptr \<equiv> \<lambda>s. \<exists>cref.
        cte_wp_at (\<lambda>c. P c \<and> ptr \<in> cte_refs c (interrupt_irq_node s)) cref s"

abbreviation
 "ex_cte_cap_to \<equiv> ex_cte_cap_wp_to \<top>"

(* All non-Null caps live either in capability tables to which there
   are appropriate existing capabilities. *)

definition
  appropriate_cte_cap :: "cap \<Rightarrow> cap \<Rightarrow> bool"
where
 "appropriate_cte_cap cap cte_cap \<equiv>
  case cap of
    NullCap \<Rightarrow> True
  | NotificationCap _ _ _ \<Rightarrow> True
  | _ \<Rightarrow> cap_irqs cte_cap = {}"

definition
  if_unsafe_then_cap :: "'z::state_ext state \<Rightarrow> bool"
where
 "if_unsafe_then_cap s \<equiv> \<forall>cref cap. caps_of_state s cref = Some cap
                         \<longrightarrow> cap \<noteq> NullCap
                        \<longrightarrow> ex_cte_cap_wp_to (appropriate_cte_cap cap) cref s"

text \<open>All zombies are final.\<close>
definition
  zombies_final :: "'z::state_ext state \<Rightarrow> bool"
where
 "zombies_final \<equiv>
  \<lambda>s. \<forall>p. cte_wp_at is_zombie p s \<longrightarrow> cte_wp_at (\<lambda>cap. is_final_cap' cap s) p s"

definition
  valid_pspace :: "'z::state_ext state \<Rightarrow> bool"
where
  "valid_pspace \<equiv> valid_objs and pspace_aligned and
                  pspace_distinct and if_live_then_nonz_cap
                  and zombies_final
                  and (\<lambda>s. sym_refs (state_refs_of s))
                  and (\<lambda>s. sym_refs (state_hyp_refs_of s))" (* ARMHYP *)

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

definition
  untyped_mdb :: "cdt \<Rightarrow> (cslot_ptr \<rightharpoonup> cap) \<Rightarrow> bool"
where
 "untyped_mdb m cs \<equiv>
  \<forall>ptr ptr' cap cap'.
      cs ptr = Some cap \<longrightarrow> is_untyped_cap cap \<longrightarrow>
      cs ptr' = Some cap' \<longrightarrow> obj_refs cap' \<inter> untyped_range cap \<noteq> {} \<longrightarrow>
      ptr' \<in> descendants_of ptr m"

text "inclusion properties on untyped caps"
definition
  untyped_inc :: "cdt \<Rightarrow> (cslot_ptr \<rightharpoonup> cap) \<Rightarrow> bool"
where
  "untyped_inc m cs \<equiv>
  \<forall>p p' c c'.
     cs p = Some c \<longrightarrow> is_untyped_cap c \<longrightarrow>
     cs p' = Some c' \<longrightarrow> is_untyped_cap c' \<longrightarrow>
     (untyped_range c \<subseteq> untyped_range c' \<or>
      untyped_range c' \<subseteq> untyped_range c \<or>
      untyped_range c \<inter> untyped_range c' = {}) \<and>
     (untyped_range c \<subset> untyped_range c' \<longrightarrow> (p \<in> descendants_of p' m \<and> untyped_range c \<inter> usable_untyped_range c' = {})) \<and>
     (untyped_range c' \<subset> untyped_range c \<longrightarrow> (p' \<in> descendants_of p m \<and> untyped_range c' \<inter> usable_untyped_range c = {})) \<and>
     (untyped_range c = untyped_range c' \<longrightarrow>
       (p' \<in> descendants_of p m \<and> usable_untyped_range c = {} \<or> p \<in> descendants_of p' m \<and> usable_untyped_range c' = {} \<or> p = p'))"

definition
  "cap_range c \<equiv> untyped_range c \<union> obj_refs c"

definition
  descendants_inc :: "cdt \<Rightarrow> (cslot_ptr \<rightharpoonup> cap) \<Rightarrow> bool"
where
  "descendants_inc m cs \<equiv>
  \<forall>p p'. p \<in> descendants_of p' m \<longrightarrow> (cap_class (the (cs p)) = cap_class (the (cs p')) \<and> cap_range (the (cs p)) \<subseteq> cap_range (the (cs p')))"

abbreviation
  "awaiting_reply ts \<equiv> ts = BlockedOnReply"

definition
  "valid_ioc s \<equiv>
   \<forall>p. is_original_cap s p \<longrightarrow> cte_wp_at (\<lambda>x. x \<noteq> NullCap)  p s"

definition
  "is_reply_cap_to t \<equiv>  \<lambda>cap. \<exists>rights. cap = ReplyCap t False rights"

definition
  "is_master_reply_cap_to t \<equiv>  \<lambda>cap. \<exists>rights. cap = ReplyCap t True rights"

definition
  "has_reply_cap t s \<equiv> \<exists>p. cte_wp_at (is_reply_cap_to t) p s"

definition
  "mdb_cte_at ct_at m \<equiv> \<forall>p c. m c = Some p \<longrightarrow> ct_at p \<and> ct_at c"

definition
  "no_mloop m \<equiv> \<forall>p. \<not> m \<Turnstile> p \<rightarrow> p"

definition
  "ut_revocable r cs \<equiv> \<forall>p cap. cs p = Some cap \<longrightarrow> is_untyped_cap cap \<longrightarrow> r p"

definition
  "irq_revocable r cs \<equiv> \<forall>p. cs p = Some IRQControlCap \<longrightarrow> r p"

definition
  "reply_master_revocable r cs \<equiv> \<forall>p cap. cs p = Some cap \<longrightarrow>
                                          is_master_reply_cap cap \<longrightarrow> r p"

definition reply_caps_mdb
where
  "reply_caps_mdb m cs \<equiv> \<forall>ptr t rights.
     cs ptr = Some (ReplyCap t False rights) \<longrightarrow>
     (\<exists>ptr' rights'. m ptr = Some ptr' \<and> cs ptr' = Some (ReplyCap t True rights'))"

lemma reply_caps_mdbE:
  assumes hyp:"reply_caps_mdb m cs"
  assumes side_hyp: "cs slot = Some (ReplyCap t False R)"
  obtains ptr R' where "m slot = Some ptr" and "cs ptr = Some (ReplyCap t True R')"
  using side_hyp hyp by (fastforce simp:reply_caps_mdb_def)

definition
  "reply_masters_mdb m cs \<equiv> \<forall>ptr t rights.
     cs ptr = Some (ReplyCap t True rights) \<longrightarrow> m ptr = None \<and>
     (\<forall>ptr'\<in>descendants_of ptr m. \<exists>rights'. cs ptr' = Some (ReplyCap t False rights'))"

definition
  "reply_mdb m cs \<equiv> reply_caps_mdb m cs \<and> reply_masters_mdb m cs"

definition
  "valid_mdb \<equiv> \<lambda>s. mdb_cte_at (swp (cte_wp_at ((\<noteq>) NullCap)) s) (cdt s) \<and>
                   untyped_mdb (cdt s) (caps_of_state s) \<and> descendants_inc (cdt s) (caps_of_state s) \<and>
                   no_mloop (cdt s) \<and> untyped_inc (cdt s) (caps_of_state s) \<and>
                   ut_revocable (is_original_cap s) (caps_of_state s) \<and>
                   irq_revocable (is_original_cap s) (caps_of_state s) \<and>
                   reply_master_revocable (is_original_cap s) (caps_of_state s) \<and>
                   reply_mdb (cdt s) (caps_of_state s) \<and>
                   valid_arch_mdb (is_original_cap s) (caps_of_state s)"

abbreviation
  "idle_tcb_at \<equiv> pred_tcb_at (\<lambda>t. (itcb_state t, itcb_bound_notification t, itcb_arch t))"

definition
  "valid_idle \<equiv>
     \<lambda>s. idle_tcb_at (\<lambda>(st, ntfn, arch). idle st \<and> ntfn = None \<and> valid_arch_idle arch)
                     (idle_thread s) s
         \<and> idle_thread s = idle_thread_ptr"

definition
  "only_idle \<equiv> \<lambda>s. \<forall>t. st_tcb_at idle t s \<longrightarrow> t = idle_thread s"

definition
  "valid_reply_masters \<equiv> \<lambda>s. \<forall>p t. cte_wp_at (is_master_reply_cap_to t) p s \<longrightarrow>
                                     p = (t, tcb_cnode_index 2)"

definition
 "reply_cap_get_tcb cap \<equiv> case cap of (ReplyCap t _ _) \<Rightarrow> t"

lemma reply_cap_get_tcb_simp[simp]: "reply_cap_get_tcb (ReplyCap t m R) = t"
 by (simp add: reply_cap_get_tcb_def)


definition
  "unique_reply_caps cs \<equiv>
   \<forall>ptr ptr' t R R'.
       cs ptr = Some (ReplyCap t False R) \<longrightarrow>
       cs ptr' = Some (ReplyCap t False R') \<longrightarrow> ptr = ptr'"

definition
  "valid_reply_caps \<equiv> \<lambda>s.
       (\<forall>t. has_reply_cap t s \<longrightarrow> st_tcb_at awaiting_reply t s) \<and>
       unique_reply_caps (caps_of_state s)"

definition
  valid_refs :: "obj_ref set \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "valid_refs R \<equiv> \<lambda>s. \<forall>cref. \<not>cte_wp_at (\<lambda>c. R \<inter> cap_range c \<noteq> {}) cref s"

text "caps point at objects in the kernel window"
definition
  cap_refs_in_kernel_window :: "'z::state_ext state \<Rightarrow> bool"
where
 "cap_refs_in_kernel_window \<equiv> \<lambda>s. valid_refs (not_kernel_window s) s"


definition
  valid_global_refs :: "'z::state_ext state \<Rightarrow> bool"
where
  "valid_global_refs \<equiv> \<lambda>s. valid_refs (global_refs s) s"

definition
  valid_irq_node :: "'z::state_ext state \<Rightarrow> bool"
where
  "valid_irq_node \<equiv> \<lambda>s. inj (interrupt_irq_node s)
      \<and> (\<forall>irq. cap_table_at 0 (interrupt_irq_node s irq) s)"

definition
  irq_issued :: "irq \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "irq_issued irq \<equiv> \<lambda>s. interrupt_states s irq = irq_state.IRQSignal"

definition
  valid_irq_handlers :: "'z::state_ext state \<Rightarrow> bool"
where
  "valid_irq_handlers \<equiv> \<lambda>s. \<forall>cap \<in> ran (caps_of_state s). \<forall>irq \<in> cap_irqs cap. irq_issued irq s"

definition valid_irq_masks :: "(irq \<Rightarrow> irq_state) \<Rightarrow> (irq \<Rightarrow> bool) \<Rightarrow> bool" where
  "valid_irq_masks table masked \<equiv> \<forall>irq. table irq = IRQInactive \<longrightarrow> masked irq"

definition valid_irq_states :: "'z::state_ext state \<Rightarrow> bool" where
  "valid_irq_states \<equiv> \<lambda>s.
    valid_irq_masks (interrupt_states s) (irq_masks (machine_state s))"

definition "cap_range_respects_device_region c s \<equiv>
  if (cap_is_device c) then cap_range c \<subseteq> device_region s
  else cap_range c \<subseteq> - device_region s"

definition
  cap_refs_respects_device_region :: "'z::state_ext state \<Rightarrow> bool"
where
 "cap_refs_respects_device_region \<equiv> \<lambda>s. \<forall>cref.
   \<not> cte_wp_at (\<lambda>c. \<not> cap_range_respects_device_region  c s) cref s"

definition
  "valid_machine_state \<equiv>
   \<lambda>s. \<forall>p. in_user_frame p (s::'z::state_ext state) \<or> underlying_memory (machine_state s) p = 0"

definition
  valid_state :: "'z::state_ext state \<Rightarrow> bool"
where
  "valid_state \<equiv> valid_pspace
                  and valid_mdb
                  and valid_ioc
                  and valid_idle
                  and only_idle
                  and if_unsafe_then_cap
                  and valid_reply_caps
                  and valid_reply_masters
                  and valid_global_refs
                  and valid_arch_state
                  and valid_irq_node
                  and valid_irq_handlers
                  and valid_irq_states
                  and valid_machine_state
                  and valid_vspace_objs
                  and valid_arch_caps
                  and valid_global_objs
                  and valid_kernel_mappings
                  and equal_kernel_mappings
                  and valid_asid_map
                  and valid_global_vspace_mappings
                  and pspace_in_kernel_window
                  and cap_refs_in_kernel_window
                  and pspace_respects_device_region
                  and cap_refs_respects_device_region"

definition
 "ct_in_state test \<equiv> \<lambda>s. st_tcb_at test (cur_thread s) s"

definition
  "cur_tcb s \<equiv> tcb_at (cur_thread s) s"

definition
  invs :: "'z::state_ext state \<Rightarrow> bool" where
  "invs \<equiv> valid_state and cur_tcb"


subsection "Derived concepts"

definition
  untyped_children_in_mdb :: "'z::state_ext state \<Rightarrow> bool"
where
 "untyped_children_in_mdb s \<equiv>
    \<forall>ptr ptr' cap. (cte_wp_at ((=) cap) ptr s \<and> is_untyped_cap cap
                     \<and> cte_wp_at (\<lambda>cap'. obj_refs cap' \<inter> untyped_range cap \<noteq> {}) ptr' s)
                     \<longrightarrow> ptr' \<in> descendants_of ptr (cdt s)"

definition
  "caps_contained s \<equiv> \<forall>c p c' p'.
  cte_wp_at ((=) c) p s \<longrightarrow>
  cte_wp_at ((=) c') p' s \<longrightarrow>
  obj_ref_of c' \<in> untyped_range c \<longrightarrow>
  (is_cnode_cap c' \<or> is_thread_cap c') \<longrightarrow>
  obj_ref_of c' + obj_size c' - 1 \<in> untyped_range c"

definition
  "obj_bits_type T \<equiv> case T of
    ACapTable n \<Rightarrow> cte_level_bits + n
  | AGarbage n \<Rightarrow> n
  | ATCB \<Rightarrow> obj_bits (TCB undefined)
  | AEndpoint \<Rightarrow> obj_bits (Endpoint undefined)
  | ANTFN \<Rightarrow> obj_bits (Notification undefined)
  | AArch T' \<Rightarrow> arch_obj_bits_type T'"

definition
  "typ_range p T \<equiv> {p .. p + 2^obj_bits_type T - 1}" (* FIXME mask_range *)

abbreviation
  "active st \<equiv> st = Running \<or> st = Restart"

abbreviation
  "simple st \<equiv> st = Inactive \<or>
                 st = Running \<or>
                 st = Restart \<or>
                 idle st \<or> awaiting_reply st"
abbreviation
  "ct_active \<equiv> ct_in_state active"

abbreviation
  "ct_running  \<equiv> ct_in_state  (\<lambda>st. st = Running)"

abbreviation
  "ct_idle \<equiv> ct_in_state idle"

abbreviation(input)
 "all_invs_but_sym_refs
    \<equiv> valid_objs and pspace_aligned and pspace_distinct and valid_ioc
       and if_live_then_nonz_cap and zombies_final
       and valid_mdb and valid_idle and only_idle and if_unsafe_then_cap
       and valid_reply_caps and valid_reply_masters and valid_global_refs
       and valid_arch_state and valid_machine_state and valid_irq_states
       and valid_irq_node and valid_irq_handlers and valid_vspace_objs
       and valid_arch_caps and valid_global_objs and valid_kernel_mappings
       and equal_kernel_mappings and valid_asid_map and valid_global_vspace_mappings
       and pspace_in_kernel_window and cap_refs_in_kernel_window
       and pspace_respects_device_region and cap_refs_respects_device_region
       and cur_tcb"


\<comment> \<open>---------------------------------------------------------------------------\<close>
section "Lemmas"

lemma valid_bound_ntfn_None[simp]:
  "valid_bound_ntfn None = \<top>"
  by (auto simp: valid_bound_ntfn_def)

lemma valid_bound_ntfn_Some[simp]:
  "valid_bound_ntfn (Some x) = ntfn_at x"
  by (auto simp: valid_bound_ntfn_def)

lemma valid_bound_tcb_None[simp]:
  "valid_bound_tcb None = \<top>"
  by (auto simp: valid_bound_tcb_def)

lemma valid_bound_tcb_Some[simp]:
  "valid_bound_tcb (Some x) = tcb_at x"
  by (auto simp: valid_bound_tcb_def)

lemmas wellformed_cap_simps = wellformed_cap_def[split_simps cap.split]

lemmas valid_cap_ref_simps =
  valid_cap_ref_def[split_simps cap.split]

lemmas valid_cap_simps = valid_cap_def[split_simps cap.split]

lemma is_ep:
  "is_ep ko = (\<exists>ep. ko = Endpoint ep)"
  unfolding is_ep_def by (cases ko) auto

lemma is_ntfn:
  "is_ntfn ko = (\<exists>ep. ko = Notification ep)"
  unfolding is_ntfn_def by (cases ko) auto

lemma is_tcb:
  "is_tcb ko = (\<exists>tcb. ko = TCB tcb)"
  unfolding is_tcb_def by (cases ko) auto

lemma is_cap_table:
  "is_cap_table bits ko =
  (\<exists>cs. ko = CNode bits cs \<and> well_formed_cnode_n bits cs)"
  unfolding is_cap_table_def by (cases ko) auto

lemmas is_obj_defs = is_ep is_ntfn is_tcb is_cap_table

\<comment> \<open>sanity check\<close>
lemma obj_at_get_object:
  "obj_at P ref s \<Longrightarrow> fst (get_object ref s) \<noteq> {}"
  by (auto simp: obj_at_def get_object_def gets_def get_def
                 return_def assert_def bind_def)

lemma ko_at_tcb_at:
  "ko_at (TCB t) p s \<Longrightarrow> tcb_at p s"
  by (simp add: obj_at_def is_tcb)

lemma tcb_at_def:
  "tcb_at t s = (\<exists>tcb. get_tcb t s = Some tcb)"
  by (simp add: obj_at_def get_tcb_def is_tcb_def
           split: option.splits kernel_object.splits)

lemma pred_tcb_def2:
  "pred_tcb_at proj test addr s = (\<exists>tcb. (get_tcb addr s) = Some tcb \<and> test (proj (tcb_to_itcb tcb)))"
  by (simp add: obj_at_def pred_tcb_at_def get_tcb_def
            split: option.splits kernel_object.splits)

(* sseefried: 'st_tcb_def2' only exists to make existing proofs go through. Can use 'pred_tcb_at_def2' instead *)
lemmas st_tcb_def2 = pred_tcb_def2[where proj=itcb_state,simplified]

lemma tcb_at_typ:
  "tcb_at = typ_at ATCB"
  apply (rule obj_at_eq_helper)
  apply (simp add: is_tcb_def a_type_def
            split: kernel_object.splits)
  done

lemma ntfn_at_typ:
  "ntfn_at = typ_at ANTFN"
  apply (rule obj_at_eq_helper)
  apply (simp add: is_ntfn_def a_type_def
            split: kernel_object.splits)
  done

lemma ep_at_typ:
  "ep_at = typ_at AEndpoint"
  apply (rule obj_at_eq_helper)
  apply (simp add: is_ep_def a_type_def
            split: kernel_object.splits)
  done

lemma length_set_helper:
  "({x :: 'a list. length x = l} = {x. length x = l'}) = (l = l')"
  apply (rule iffI, simp_all)
  apply (cases "replicate l undefined \<in> {x :: 'a list. length x = l}")
   apply simp
  apply (subst(asm) mem_simps)
  apply simp
  done

lemma cap_table_at_typ:
  "cap_table_at n = typ_at (ACapTable n)"
  apply (rule obj_at_eq_helper)
  apply (case_tac obj, simp_all add: is_cap_table_def a_type_def
                                     well_formed_cnode_n_def)
  apply (auto simp: length_set_helper)
  done

lemma cte_at_def:
  "cte_at p s \<equiv> \<exists>cap. fst (get_cap p s) = {(cap,s)}"
  by (simp add: cte_wp_at_def)

lemma valid_cap_def2:
  "s \<turnstile> c \<equiv> cap_aligned c \<and> wellformed_cap c \<and> valid_cap_ref c s"
  apply (rule eq_reflection)
  apply (cases c)
          apply (simp_all add: valid_cap_simps wellformed_cap_simps
                               valid_cap_ref_simps
                        split: option.splits)
    apply (fastforce+)
  by (simp add: valid_arch_cap_def2)

lemma valid_capsD:
  "\<lbrakk>caps_of_state s p = Some cap; valid_caps (caps_of_state s) s\<rbrakk>
   \<Longrightarrow> valid_cap cap s"
  by (cases p, simp add: valid_caps_def)

lemma tcb_cnode_index_distinct[simp]:
  "(tcb_cnode_index n = tcb_cnode_index m)
       = ((of_nat n :: 3 word) = (of_nat m :: 3 word))"
  by (simp add: tcb_cnode_index_def)


lemma tcb_cap_cases_simps[simp]:
  "tcb_cap_cases (tcb_cnode_index 0) =
   Some (tcb_ctable, tcb_ctable_update, (\<lambda>_ _. \<top>))"
  "tcb_cap_cases (tcb_cnode_index (Suc 0)) =
   Some (tcb_vtable, tcb_vtable_update, (\<lambda>_ _. is_valid_vtable_root or ((=) NullCap)))"
  "tcb_cap_cases (tcb_cnode_index 2) =
   Some (tcb_reply, tcb_reply_update,
         (\<lambda>t st c. (is_master_reply_cap c \<and> obj_ref_of c = t \<and> AllowGrant \<in> cap_rights c) \<or>
                   (halted st \<and> (c = NullCap))))"
  "tcb_cap_cases (tcb_cnode_index 3) =
   Some (tcb_caller, tcb_caller_update,
         (\<lambda>_ st. case st of
                   BlockedOnReceive e data \<Rightarrow> ((=) NullCap)
                 | _ \<Rightarrow> is_reply_cap or ((=) NullCap)))"
  "tcb_cap_cases (tcb_cnode_index 4) =
   Some (tcb_ipcframe, tcb_ipcframe_update,
         (\<lambda>_ _. is_nondevice_page_cap or ((=) cap.NullCap)))"
  by (simp add: tcb_cap_cases_def)+

lemma ran_tcb_cap_cases:
  "ran (tcb_cap_cases) =
    {(tcb_ctable, tcb_ctable_update, (\<lambda>_ _. \<top>)),
     (tcb_vtable, tcb_vtable_update, (\<lambda>_ _. is_valid_vtable_root or ((=) NullCap))),
     (tcb_reply, tcb_reply_update, (\<lambda>t st c.
                                       (is_master_reply_cap c \<and> obj_ref_of c = t
                                        \<and> AllowGrant \<in> cap_rights c)
                                     \<or> (halted st \<and> (c = NullCap)))),
     (tcb_caller, tcb_caller_update, (\<lambda>_ st. case st of
                                       Structures_A.BlockedOnReceive e data \<Rightarrow>
                                         ((=) NullCap)
                                     | _ \<Rightarrow> is_reply_cap or ((=) NullCap))),
     (tcb_ipcframe, tcb_ipcframe_update, (\<lambda>_ _. is_nondevice_page_cap or ((=) NullCap)))}"
  by (simp add: tcb_cap_cases_def insert_commute)

lemma tcb_cnode_map_tcb_cap_cases:
  "tcb_cnode_map tcb = (\<lambda>bl. map_option (\<lambda>x. fst x tcb) (tcb_cap_cases bl))"
  by (rule ext) (simp add: tcb_cnode_map_def tcb_cap_cases_def)

lemma ran_tcb_cnode_map:
  "ran (tcb_cnode_map t) =
   {tcb_vtable t, tcb_ctable t, tcb_caller t, tcb_reply t, tcb_ipcframe t}"
  by (fastforce simp: tcb_cnode_map_def)


lemma st_tcb_idle_cap_valid_Null [simp]:
  "st_tcb_at (idle or inactive) (fst sl) s \<longrightarrow>
   tcb_cap_valid NullCap sl s"
  by (fastforce simp: tcb_cap_valid_def tcb_cap_cases_def
                      pred_tcb_at_def obj_at_def
                      valid_ipc_buffer_cap_null)


lemma valid_objsI [intro]:
  "(\<And>obj x. kheap s x = Some obj \<Longrightarrow> valid_obj x obj s) \<Longrightarrow> valid_objs s"
  unfolding valid_objs_def by auto

lemma valid_objsE [elim]:
  "\<lbrakk> valid_objs s; kheap s x = Some obj; valid_obj x obj s \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  unfolding valid_objs_def by (auto simp: dom_def)

lemma valid_obj_arch_valid_obj:
  "valid_obj p (ArchObj ao) s = arch_valid_obj ao s"
  by (simp add: valid_obj_def)


lemma obj_at_ko_at:
  "obj_at P p s \<Longrightarrow> \<exists>ko. ko_at ko p s \<and> P ko"
  by (auto simp add: obj_at_def)

lemma tcb_st_refs_of_simps[simp]: (* ARMHYP add TCBHypRef? *)
 "tcb_st_refs_of (Running)               = {}"
 "tcb_st_refs_of (Inactive)              = {}"
 "tcb_st_refs_of (Restart)               = {}"
 "tcb_st_refs_of (BlockedOnReply)        = {}"
 "tcb_st_refs_of (IdleThreadState)       = {}"
 "\<And>x. tcb_st_refs_of (BlockedOnReceive x payl')  = {(x, TCBBlockedRecv)}"
 "\<And>x. tcb_st_refs_of (BlockedOnSend x payl)  = {(x, TCBBlockedSend)}"
 "\<And>x. tcb_st_refs_of (BlockedOnNotification x) = {(x, TCBSignal)}"
  by (auto simp: tcb_st_refs_of_def)

lemma ep_q_refs_of_simps[simp]:
 "ep_q_refs_of  IdleEP    = {}"
 "\<And>q. ep_q_refs_of (RecvEP q) = set q \<times> {EPRecv}"
 "\<And>q. ep_q_refs_of (SendEP q) = set q \<times> {EPSend}"
  by (auto simp: ep_q_refs_of_def)

lemma ntfn_q_refs_of_simps[simp]:
 "ntfn_q_refs_of IdleNtfn        = {}"
 "ntfn_q_refs_of (WaitingNtfn q)   = set q \<times> {NTFNSignal}"
 "ntfn_q_refs_of (ActiveNtfn b)  = {}"
  by (auto simp: ntfn_q_refs_of_def)

lemma ntfn_bound_refs_simps[simp]:
  "ntfn_bound_refs (Some t) = {(t, NTFNBound)}"
  "ntfn_bound_refs None = {}"
  by (auto simp: ntfn_bound_refs_def)

lemma tcb_bound_refs_simps[simp]:
  "tcb_bound_refs (Some a) = {(a, TCBBound)}"
  "tcb_bound_refs None = {}"
  by (auto simp: tcb_bound_refs_def)

lemma tcb_bound_refs_def2:
  "tcb_bound_refs a = set_option a \<times> {TCBBound}"
by (simp add: tcb_bound_refs_def split: option.splits)

lemma refs_of_simps[simp]:
 "refs_of (CNode sz cs)       = {}"
 "refs_of (TCB tcb)           = tcb_st_refs_of (tcb_state tcb) \<union> tcb_bound_refs (tcb_bound_notification tcb)"
 "refs_of (Endpoint ep)       = ep_q_refs_of ep"
 "refs_of (Notification ntfn) = ntfn_q_refs_of (ntfn_obj ntfn) \<union> ntfn_bound_refs (ntfn_bound_tcb ntfn)"
 "refs_of (ArchObj ao)        = {}"
  by (auto simp: refs_of_def)


lemma refs_of_rev:
 "(x, TCBBlockedRecv) \<in> refs_of ko =
    (\<exists>tcb. ko = TCB tcb \<and> (\<exists>pl. tcb_state tcb = BlockedOnReceive x pl))"
 "(x, TCBBlockedSend) \<in> refs_of ko =
    (\<exists>tcb. ko = TCB tcb \<and> (\<exists>pl. tcb_state tcb = BlockedOnSend x pl))"
 "(x, TCBSignal) \<in> refs_of ko =
    (\<exists>tcb. ko = TCB tcb \<and> (tcb_state tcb = BlockedOnNotification x))"
 "(x, EPRecv) \<in> refs_of ko =
    (\<exists>ep. ko = Endpoint ep \<and> (\<exists>q. ep = RecvEP q \<and> x \<in> set q))"
 "(x, EPSend) \<in> refs_of ko =
    (\<exists>ep. ko = Endpoint ep \<and> (\<exists>q. ep = SendEP q \<and> x \<in> set q))"
 "(x, NTFNSignal) \<in> refs_of ko =
    (\<exists>ntfn. ko = Notification ntfn \<and> (\<exists>q. ntfn_obj ntfn = WaitingNtfn q \<and> x \<in> set q))"
 "(x, TCBBound) \<in>  refs_of ko =
    (\<exists>tcb. ko = TCB tcb \<and> (tcb_bound_notification tcb = Some x))"
 "(x, NTFNBound) \<in> refs_of ko =
    (\<exists>ntfn. ko = Notification ntfn \<and> (ntfn_bound_tcb ntfn = Some x))"
  by (auto simp:  refs_of_def
                     tcb_st_refs_of_def
                     ep_q_refs_of_def
                     ntfn_q_refs_of_def
                     ntfn_bound_refs_def
                     tcb_bound_refs_def
              split: kernel_object.splits
                     thread_state.splits
                     endpoint.splits
                     ntfn.splits
                     option.split)

lemma st_tcb_at_refs_of_rev:
  "obj_at (\<lambda>ko. (x, TCBBlockedRecv) \<in> refs_of ko) t s
     = st_tcb_at (\<lambda>ts. \<exists>pl. ts = BlockedOnReceive x pl) t s"
  "obj_at (\<lambda>ko. (x, TCBBlockedSend) \<in> refs_of ko) t s
     = st_tcb_at (\<lambda>ts. \<exists>pl. ts = BlockedOnSend x pl   ) t s"
  "obj_at (\<lambda>ko. (x, TCBSignal) \<in> refs_of ko) t s
     = st_tcb_at (\<lambda>ts.      ts = BlockedOnNotification x) t s"
  by (simp add: refs_of_rev pred_tcb_at_def)+

lemma state_refs_of_elemD:
  "\<lbrakk> ref \<in> state_refs_of s x \<rbrakk> \<Longrightarrow> obj_at (\<lambda>obj. ref \<in> refs_of obj) x s"
  by (clarsimp simp add: state_refs_of_def obj_at_def
                  split: option.splits)

lemma state_refs_of_eqD:
  "\<lbrakk> state_refs_of s x = S; S \<noteq> {} \<rbrakk> \<Longrightarrow> obj_at (\<lambda>obj. refs_of obj = S) x s"
  by (clarsimp simp add: state_refs_of_def obj_at_def
                  split: option.splits)

lemma obj_at_state_refs_ofD:
  "obj_at P p s \<Longrightarrow> \<exists>ko. P ko \<and> state_refs_of s p = refs_of ko"
  apply (clarsimp simp: obj_at_def state_refs_of_def)
  apply fastforce
  done

lemma ko_at_state_refs_ofD:
  "ko_at ko p s \<Longrightarrow> state_refs_of s p = refs_of ko"
  by (clarsimp dest!: obj_at_state_refs_ofD)


definition
  "tcb_ntfn_is_bound ntfn ko = (case ko of TCB tcb \<Rightarrow> tcb_bound_notification tcb = ntfn | _ \<Rightarrow> False)"

lemma st_tcb_at_state_refs_ofD:
  "st_tcb_at P t s \<Longrightarrow> \<exists>ts ntfnptr. P ts \<and> obj_at (tcb_ntfn_is_bound ntfnptr) t s
          \<and> state_refs_of s t = (tcb_st_refs_of ts \<union> tcb_bound_refs ntfnptr)"
  by (auto simp: pred_tcb_at_def obj_at_def tcb_ntfn_is_bound_def
                 state_refs_of_def)

lemma bound_tcb_at_state_refs_ofD:
  "bound_tcb_at P t s \<Longrightarrow> \<exists>ts ntfnptr. P ntfnptr \<and> obj_at (tcb_ntfn_is_bound ntfnptr) t s
          \<and> state_refs_of s t = (tcb_st_refs_of ts \<union> tcb_bound_refs ntfnptr)"
  by (auto simp: pred_tcb_at_def obj_at_def tcb_ntfn_is_bound_def
                 state_refs_of_def)

lemma sym_refs_obj_atD:
  "\<lbrakk> obj_at P p s; sym_refs (state_refs_of s) \<rbrakk> \<Longrightarrow>
     \<exists>ko. P ko \<and> state_refs_of s p = refs_of ko \<and>
        (\<forall>(x, tp)\<in>refs_of ko. obj_at (\<lambda>ko. (p, symreftype tp) \<in> refs_of ko) x s)"
  apply (drule obj_at_state_refs_ofD)
  apply (erule exEI, clarsimp)
  apply (drule sym, simp)
  apply (drule(1) sym_refsD)
  apply (erule state_refs_of_elemD)
  done

lemma sym_refs_ko_atD:
  "\<lbrakk> ko_at ko p s; sym_refs (state_refs_of s) \<rbrakk> \<Longrightarrow>
     state_refs_of s p = refs_of ko \<and>
     (\<forall>(x, tp)\<in>refs_of ko.  obj_at (\<lambda>ko. (p, symreftype tp) \<in> refs_of ko) x s)"
  by (drule(1) sym_refs_obj_atD, simp)

lemma sym_refs_st_tcb_atD:
  "\<lbrakk> st_tcb_at P t s; sym_refs (state_refs_of s) \<rbrakk> \<Longrightarrow>
     \<exists>ts ntfn. P ts \<and> obj_at (tcb_ntfn_is_bound ntfn) t s
        \<and> state_refs_of s t = tcb_st_refs_of ts \<union> tcb_bound_refs ntfn
        \<and> (\<forall>(x, tp)\<in>tcb_st_refs_of ts \<union> tcb_bound_refs ntfn. obj_at (\<lambda>ko. (t, symreftype tp) \<in> refs_of ko) x s)"
  apply (drule st_tcb_at_state_refs_ofD)
  apply (erule exE)+
  apply (rule_tac x=ts in exI)
  apply (rule_tac x=ntfnptr in exI)
  apply clarsimp
  apply (frule obj_at_state_refs_ofD)
  apply (drule (1)sym_refs_obj_atD)
  apply auto
  done

lemma pspace_alignedE [elim]:
  "\<lbrakk> pspace_aligned s;
   x \<in> dom (kheap s); is_aligned x (obj_bits (the (kheap s x))) \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  unfolding pspace_aligned_def by auto

lemma ex_nonz_cap_toE:
  "\<lbrakk> ex_nonz_cap_to p s; \<And>cref. cte_wp_at (\<lambda>c. p \<in> zobj_refs c) cref s \<Longrightarrow> Q \<rbrakk>
    \<Longrightarrow> Q"
  by (fastforce simp: ex_nonz_cap_to_def)

lemma refs_of_live:
  "refs_of ko \<noteq> {} \<Longrightarrow> live ko"
  apply (cases ko, simp_all)
    apply (rename_tac tcb_ext)
     apply (case_tac "tcb_state tcb_ext", simp_all add: live_def)
    apply (fastforce simp: tcb_bound_refs_def)+
  apply (rename_tac notification)
  apply (case_tac "ntfn_obj notification", simp_all)
   apply (fastforce simp: ntfn_bound_refs_def)+
  done

lemma hyp_refs_of_live:
  "hyp_refs_of ko \<noteq> {} \<Longrightarrow> live ko"
  by (cases ko, simp_all add: live_def hyp_refs_of_hyp_live)

lemma refs_of_live_obj:
  "\<lbrakk> obj_at P p s; \<And>ko. \<lbrakk> P ko; refs_of ko = {} \<rbrakk> \<Longrightarrow> False \<rbrakk> \<Longrightarrow> obj_at live p s"
  by (fastforce simp: obj_at_def intro!: refs_of_live)

lemma hyp_refs_of_live_obj:
  "\<lbrakk> obj_at P p s; \<And>ko. \<lbrakk> P ko; hyp_refs_of ko = {}\<rbrakk> \<Longrightarrow> False  \<rbrakk> \<Longrightarrow> obj_at live p s"
  by (fastforce simp: obj_at_def intro!: hyp_refs_of_live)


lemma if_live_then_nonz_capD:
  assumes x: "if_live_then_nonz_cap s" "obj_at P p s"
  assumes y: "\<And>obj. \<lbrakk> P obj; kheap s p = Some obj \<rbrakk> \<Longrightarrow> live obj"
  shows "ex_nonz_cap_to p s" using x
  apply (clarsimp simp: if_live_then_nonz_cap_def)
  apply (erule allE[where x=p])
  apply (fastforce simp: obj_at_def dest!: y)
  done

lemma if_live_then_nonz_capD2:
  "\<lbrakk> if_live_then_nonz_cap s; kheap s p = Some obj;
     live obj \<rbrakk> \<Longrightarrow> ex_nonz_cap_to p s"
  apply (subgoal_tac "ko_at obj p s")
   apply (erule(1) if_live_then_nonz_capD)
   apply simp
  apply (simp add: obj_at_def)
  done

lemma caps_of_state_cte_wp_at:
 "caps_of_state s = (\<lambda>p. if (\<exists>cap. cte_wp_at ((=) cap) p s)
                         then Some (THE cap. cte_wp_at ((=) cap) p s)
                         else None)"
  by (rule ext) (clarsimp simp: cte_wp_at_def caps_of_state_def)

lemma cte_wp_at_caps_of_state:
 "cte_wp_at P p s = (\<exists>cap. caps_of_state s p = Some cap \<and> P cap)"
  by (clarsimp simp add: cte_wp_at_def caps_of_state_def)

lemmas ex_cte_cap_to_def =
  ex_cte_cap_wp_to_def[where P="\<top>", simplified simp_thms]

lemma ex_cte_cap_wp_to_weakenE:
  "\<lbrakk> ex_cte_cap_wp_to P p s;
      \<And>cte_cap. \<lbrakk> P cte_cap; p \<in> cte_refs cte_cap (interrupt_irq_node s) \<rbrakk> \<Longrightarrow> Q cte_cap \<rbrakk>
       \<Longrightarrow> ex_cte_cap_wp_to Q p s"
  apply (simp add: ex_cte_cap_wp_to_def)
  apply (elim exEI)
  apply (clarsimp simp: cte_wp_at_caps_of_state)
  done

lemma if_unsafe_then_capD:
  "\<lbrakk> cte_wp_at P p s; if_unsafe_then_cap s; \<And>cap. P cap \<Longrightarrow> cap \<noteq> NullCap \<rbrakk>
     \<Longrightarrow> ex_cte_cap_wp_to (\<lambda>cap. \<exists>cap'. P cap' \<and> appropriate_cte_cap cap' cap) p s"
  apply (clarsimp simp: cte_wp_at_caps_of_state)
  apply (unfold if_unsafe_then_cap_def)
  apply (elim allE, drule(1) mp)
  apply (auto elim!: ex_cte_cap_wp_to_weakenE)
  done

lemma zombies_finalD:
  "\<lbrakk> cte_wp_at P p s; zombies_final s; \<And>cap. P cap \<Longrightarrow> is_zombie cap \<rbrakk>
     \<Longrightarrow> cte_wp_at (\<lambda>cap. is_final_cap' cap s) p s"
  unfolding zombies_final_def
  apply (drule spec, erule mp)
  apply (clarsimp simp: cte_wp_at_def)
  done


lemma physical_valid_cap_not_empty_range:
  "\<lbrakk>valid_cap cap s; cap_class cap = PhysicalClass\<rbrakk> \<Longrightarrow> cap_range cap \<noteq> {}"
  apply (case_tac cap)
   apply (simp_all add:cap_range_def valid_cap_simps cap_aligned_def is_aligned_no_overflow)
  apply (rename_tac arch_cap)
  apply (clarsimp simp: physical_arch_cap_has_ref)
  done

lemma valid_ioc_def2:
  "valid_ioc s \<equiv>
   \<forall>p. is_original_cap s p \<longrightarrow> null_filter (caps_of_state s) p \<noteq> None"
  apply (rule eq_reflection)
  apply (clarsimp simp add: valid_ioc_def)
  apply (intro iff_allI weak_imp_cong refl)
  apply (clarsimp simp: null_filter_def cte_wp_at_caps_of_state)
  apply fastforce
  done

lemma valid_reply_capsD:
  "\<lbrakk> has_reply_cap t s; valid_reply_caps s \<rbrakk>
    \<Longrightarrow> st_tcb_at awaiting_reply t s"
  unfolding valid_reply_caps_def
  by simp

lemma reply_master_caps_of_stateD:
  "\<And>slot. \<lbrakk> valid_reply_masters s; caps_of_state s slot = Some (ReplyCap t True rights)\<rbrakk>
   \<Longrightarrow> slot = (t, tcb_cnode_index 2)"
  by (simp add: valid_reply_masters_def cte_wp_at_caps_of_state is_master_reply_cap_to_def
           del: split_paired_All)

lemma has_reply_cap_cte_wpD:
  "\<And>t slot. cte_wp_at (is_reply_cap_to t) slot s \<Longrightarrow> has_reply_cap t s"
  by (fastforce simp: has_reply_cap_def)

lemma reply_cap_doesnt_exist_strg:
  "(valid_reply_caps s \<and> st_tcb_at (Not \<circ> awaiting_reply) t s)
      \<longrightarrow> \<not> has_reply_cap t s"
  by (clarsimp dest!: valid_reply_capsD
                simp: st_tcb_def2)

(*FIXME destruction rule argument order is wrong *)
lemma mdb_cte_atD:
  "\<lbrakk> m c = Some p; mdb_cte_at ct_at m \<rbrakk>
     \<Longrightarrow> ct_at p \<and> ct_at c"
  by (simp add: mdb_cte_at_def)

lemma zobj_refs_to_obj_refs:
  "(x \<in> zobj_refs cap) = (x \<in> obj_refs cap \<and> \<not> is_zombie cap)"
  by (cases cap, simp_all add: is_zombie_def)

lemma idle_no_refs:
  "valid_idle s \<Longrightarrow> state_refs_of s (idle_thread s) = {}"
  apply (clarsimp simp: valid_idle_def)
  apply (clarsimp simp: pred_tcb_at_def obj_at_def tcb_ntfn_is_bound_def state_refs_of_def)
  done

lemma idle_not_queued: (* ARMHYP? *)
  "\<lbrakk>valid_idle s; sym_refs (state_refs_of s);
   state_refs_of s ptr = queue \<times> {rt}\<rbrakk> \<Longrightarrow>
   idle_thread s \<notin> queue"
  by (frule idle_no_refs, fastforce simp: valid_idle_def sym_refs_def)

lemma idle_not_queued': (* ARMHYP? *)
  "\<lbrakk>valid_idle s; sym_refs (state_refs_of s);
   state_refs_of s ptr = insert t queue \<times> {rt}\<rbrakk> \<Longrightarrow>
   idle_thread s \<notin> queue"
  by (frule idle_no_refs, fastforce simp: valid_idle_def sym_refs_def)

lemma mdb_cte_atI:
  "\<lbrakk> \<And>c p. m c = Some p \<Longrightarrow> ct_at p \<and> ct_at c \<rbrakk>
     \<Longrightarrow> mdb_cte_at ct_at m"
  by (simp add: mdb_cte_at_def)

lemma only_idleD:
  "\<lbrakk> st_tcb_at idle t s; only_idle s \<rbrakk> \<Longrightarrow> t = idle_thread s"
  by (simp add: only_idle_def)

lemma only_idleI:
  "(\<And>t. st_tcb_at idle t s \<Longrightarrow> t = idle_thread s) \<Longrightarrow> only_idle s"
  by (simp add: only_idle_def)

lemma valid_refs_def2:
  "valid_refs R = (\<lambda>s. \<forall>c \<in> ran (caps_of_state s). R \<inter> cap_range c = {})"
  apply (simp add: valid_refs_def cte_wp_at_caps_of_state ran_def)
  apply (rule ext, fastforce)
  done

lemma idle_no_ex_cap:
  "\<lbrakk>valid_global_refs s; valid_objs s\<rbrakk> \<Longrightarrow>
   \<not> ex_nonz_cap_to (idle_thread s) s"
  apply (simp add: ex_nonz_cap_to_def valid_global_refs_def valid_refs_def2 cte_wp_at_caps_of_state
              del: split_paired_Ex split_paired_All)
  apply (intro allI notI impI)
  apply (drule bspec, blast)
  apply (clarsimp simp: cap_range_def zobj_refs_to_obj_refs)
  by blast

lemma caps_of_state_cteD:
  "caps_of_state s p = Some cap \<Longrightarrow> cte_wp_at ((=) cap) p s"
  by (simp add: cte_wp_at_caps_of_state)

lemma untyped_mdb_alt:
  "untyped_mdb (cdt s) (caps_of_state s) = untyped_children_in_mdb s"
  apply (simp add: untyped_children_in_mdb_def untyped_mdb_def cte_wp_at_caps_of_state)
  apply fastforce
  done

lemma untyped_children_in_mdbE:
  assumes x: "untyped_children_in_mdb s" "cte_wp_at ((=) cap) ptr s"
             "is_untyped_cap cap" "cte_wp_at P ptr' s"
  assumes y: "\<And>cap'. \<lbrakk> cte_wp_at ((=) cap') ptr' s; P cap' \<rbrakk> \<Longrightarrow>
                 obj_refs cap' \<inter> untyped_range cap \<noteq> {}"
  assumes z: "ptr' \<in> descendants_of ptr (cdt s) \<Longrightarrow> Q"
  shows Q using x
  apply (clarsimp simp: untyped_children_in_mdb_def
                  simp del: split_paired_All split_paired_Ex)
  apply (erule allE[where x=ptr], erule allE[where x=ptr'], erule impE)
   apply (rule exI, (erule conjI)+)
   apply (clarsimp simp: cte_wp_at_def y)
  apply (erule z)
  done

lemma cte_wp_at_cases:
  "cte_wp_at P t s = ((\<exists>sz fun cap. kheap s (fst t) = Some (CNode sz fun) \<and>
                                    well_formed_cnode_n sz fun \<and>
                                    fun (snd t) = Some cap \<and> P cap) \<or>
                      (\<exists>tcb get set restr. kheap s (fst t) = Some (TCB tcb) \<and>
                             tcb_cap_cases (snd t) = Some (get, set, restr) \<and>
                             P (get tcb)))"
  apply (cases t)
  apply (cases "kheap s (fst t)")
   apply (simp add: cte_wp_at_def get_cap_def
                    get_object_def gets_def get_def return_def assert_def
                    fail_def bind_def)
  apply (simp add: cte_wp_at_def get_cap_def tcb_cnode_map_def bind_def
                   get_object_def assert_opt_def return_def gets_def get_def
                   assert_def fail_def dom_def
              split: if_split_asm kernel_object.splits
                     option.splits)
  apply (simp add: tcb_cap_cases_def)
  done

lemma cte_wp_at_cases2:
  "cte_wp_at P t s =
   ((\<exists>sz fun cap. kheap s (fst t) = Some (CNode sz fun) \<and>
                  well_formed_cnode_n sz fun \<and> fun (snd t) = Some cap \<and> P cap) \<or>
    (\<exists>tcb cap. kheap s (fst t) = Some (TCB tcb) \<and>
               (tcb_cnode_map tcb (snd t) = Some cap \<and> P cap)))"
  by (auto simp add: cte_wp_at_cases tcb_cap_cases_def tcb_cnode_map_def)

lemma cte_wp_at_pspaceI:
  "\<lbrakk> cte_wp_at P slot s; kheap s = kheap s' \<rbrakk> \<Longrightarrow> cte_wp_at P slot s'"
  by (simp add: cte_wp_at_cases)

(* generic consequence of architecture-specific details *)
lemma (in Arch) valid_arch_cap_pspaceI:
  "\<lbrakk> valid_arch_cap acap s; kheap s = kheap s' \<rbrakk> \<Longrightarrow> valid_arch_cap acap s'"
  unfolding valid_arch_cap_def
  by (auto intro: obj_at_pspaceI split: arch_cap.split)

requalify_facts Arch.valid_arch_cap_pspaceI

lemma valid_cap_pspaceI:
  "\<lbrakk> s \<turnstile> cap; kheap s = kheap s' \<rbrakk> \<Longrightarrow> s' \<turnstile> cap"
  unfolding valid_cap_def
  apply (cases cap)
  by (auto intro: obj_at_pspaceI cte_wp_at_pspaceI valid_arch_cap_pspaceI
            simp: obj_range_def valid_untyped_def pred_tcb_at_def
           split: option.split sum.split)

(* FIXME-NTFN: ugly proof *)
lemma valid_obj_pspaceI:
  "\<lbrakk> valid_obj ptr obj s; kheap s = kheap s' \<rbrakk> \<Longrightarrow> valid_obj ptr obj s'"
  unfolding valid_obj_def
  apply (cases obj)
      apply (auto simp add: valid_ntfn_def valid_cs_def valid_tcb_def valid_ep_def
                            valid_tcb_state_def pred_tcb_at_def valid_bound_ntfn_def
                            valid_bound_tcb_def wellformed_arch_pspace
                 intro: obj_at_pspaceI valid_cap_pspaceI valid_arch_tcb_pspaceI
                 split: ntfn.splits endpoint.splits
                        thread_state.splits option.split
          | auto split: kernel_object.split)+
done

lemma valid_objs_pspaceI:
  "\<lbrakk> valid_objs s; kheap s = kheap s' \<rbrakk> \<Longrightarrow> valid_objs s'"
  unfolding valid_objs_def
  by (auto intro: valid_obj_pspaceI dest!: bspec [OF _ domI])

lemma state_refs_of_pspaceI:
  "\<lbrakk> P (state_refs_of s); kheap s = kheap s' \<rbrakk> \<Longrightarrow> P (state_refs_of s')"
  unfolding state_refs_of_def
  by simp

lemma distinct_pspaceI:
  "pspace_distinct s \<Longrightarrow> kheap s = kheap s' \<Longrightarrow> pspace_distinct s'"
  by (simp add: pspace_distinct_def)

lemma iflive_pspaceI:
  "if_live_then_nonz_cap s \<Longrightarrow> kheap s = kheap s' \<Longrightarrow> if_live_then_nonz_cap s'"
  unfolding if_live_then_nonz_cap_def ex_nonz_cap_to_def
  by (fastforce simp: obj_at_def intro: cte_wp_at_pspaceI)

lemma cte_wp_at_pspace:
  "kheap s = kheap s' \<Longrightarrow> cte_wp_at P p s = cte_wp_at P p s'"
  by (fastforce elim!: cte_wp_at_pspaceI)

lemma caps_of_state_pspace:
  assumes x: "kheap s = kheap s'"
  shows      "caps_of_state s = caps_of_state s'"
  by (simp add: caps_of_state_cte_wp_at cte_wp_at_pspace [OF x] cong: if_cong)

lemma ifunsafe_pspaceI:
  "if_unsafe_then_cap s \<Longrightarrow> kheap s = kheap s' \<Longrightarrow> interrupt_irq_node s = interrupt_irq_node s'
       \<Longrightarrow> if_unsafe_then_cap s'"
  unfolding if_unsafe_then_cap_def ex_cte_cap_wp_to_def
  apply (frule caps_of_state_pspace)
  by (auto simp: cte_wp_at_cases)

lemma valid_idle_pspaceI:
  "valid_idle s \<Longrightarrow> \<lbrakk>kheap s = kheap s'; idle_thread s = idle_thread s'\<rbrakk> \<Longrightarrow> valid_idle s'"
  unfolding valid_idle_def pred_tcb_at_def
  by (fastforce elim!: obj_at_pspaceI cte_wp_at_pspaceI)

lemma gen_obj_refs_Int:
  "(gen_obj_refs cap \<inter> gen_obj_refs cap' = {})
     = (obj_refs cap \<inter> obj_refs cap' = {}
            \<and> cap_irqs cap \<inter> cap_irqs cap' = {}
            \<and> arch_gen_refs cap \<inter> arch_gen_refs cap' = {})"
  by (simp add: gen_obj_refs_def Int_Un_distrib Int_Un_distrib2
                image_Int[symmetric] Int_image_empty)

lemma is_final_cap'_def2:
  "is_final_cap' cap =
    (\<lambda>s. \<exists>cref. \<forall>cref'. cte_wp_at (\<lambda>c. gen_obj_refs cap \<inter> gen_obj_refs c \<noteq> {}) cref' s
                  = (cref' = cref))"
  apply (rule ext)
  apply (auto simp: is_final_cap'_def cte_wp_at_def
                    set_eq_iff)
  done

lemma zombies_final_pspaceI:
  assumes x: "zombies_final s"
      and y: "kheap s = kheap s'"
  shows      "zombies_final s'"
  using x unfolding zombies_final_def is_final_cap'_def2
  by (simp only: cte_wp_at_pspace [OF y])

lemma pspace_pspace_update:
  "kheap (kheap_update (\<lambda>a. ps) s) = ps" by simp

lemma valid_pspace_eqI:
  "\<lbrakk> valid_pspace s; kheap s = kheap s' \<rbrakk> \<Longrightarrow> valid_pspace s'"
  unfolding valid_pspace_def
  by (auto simp: pspace_aligned_def
           intro: valid_objs_pspaceI state_refs_of_pspaceI state_hyp_refs_of_pspaceI
                  distinct_pspaceI iflive_pspaceI
                  ifunsafe_pspaceI zombies_final_pspaceI)

lemma cte_wp_caps_of_lift:
  assumes c: "\<And>p P. cte_wp_at P p s = cte_wp_at P p s'"
  shows "caps_of_state s = caps_of_state s'"
  apply (rule ext)
  apply (case_tac "caps_of_state s' x")
   apply (rule classical)
   apply (clarsimp dest!: caps_of_state_cteD simp add: c)
   apply (simp add: cte_wp_at_caps_of_state)
  apply clarsimp
  apply (clarsimp dest!: caps_of_state_cteD simp add: c [symmetric])
  apply (simp add: cte_wp_at_caps_of_state)
  done

lemma ex_cte_cap_to_pres:
  assumes x: "\<And>P p. \<lbrace>cte_wp_at P p\<rbrace> f \<lbrace>\<lambda>rv. cte_wp_at P p\<rbrace>"
  assumes irq: "\<And>P. \<lbrace>\<lambda>s. P (interrupt_irq_node s)\<rbrace> f \<lbrace>\<lambda>rv s. P (interrupt_irq_node s)\<rbrace>"
  shows      "\<lbrace>ex_cte_cap_wp_to P p\<rbrace> f \<lbrace>\<lambda>rv. ex_cte_cap_wp_to P p\<rbrace>"
  by (simp add: ex_cte_cap_wp_to_def,
      wp hoare_vcg_ex_lift hoare_use_eq[where f=interrupt_irq_node, OF irq, OF x])

lemma valid_mdb_eqI:
  assumes "valid_mdb s"
  assumes c: "\<And>p P. cte_wp_at P p s = cte_wp_at P p s'"
  assumes "cdt s = cdt s'"
  assumes "is_original_cap s = is_original_cap s'"
  shows "valid_mdb s'" using assms
  apply (simp add: valid_mdb_def)
   apply (rule conjI)
   apply (force simp add: valid_mdb_def swp_def mdb_cte_at_def)
  apply (clarsimp simp add: cte_wp_caps_of_lift [OF c] valid_arch_mdb_eqI)
  done

lemma set_object_at_obj:
  "\<lbrace> \<lambda>s. obj_at P p s \<and> (p = r \<longrightarrow> P obj) \<rbrace> set_object r obj \<lbrace> \<lambda>rv. obj_at P p \<rbrace>"
  by (clarsimp simp: valid_def in_monad obj_at_def set_object_def get_object_def)

lemma set_object_at_obj1:
  "P obj \<Longrightarrow> \<lbrace> obj_at P p \<rbrace> set_object r obj \<lbrace> \<lambda>rv. obj_at P p \<rbrace>"
  by (clarsimp simp: valid_def in_monad obj_at_def set_object_def get_object_def)

lemma set_object_at_obj2:
  "(\<And>ko. Q ko \<Longrightarrow> \<not>P ko) \<Longrightarrow>
  \<lbrace> obj_at P p and obj_at Q r \<rbrace> set_object r obj \<lbrace> \<lambda>rv. obj_at P p \<rbrace>"
  by (clarsimp simp: valid_def in_monad obj_at_def set_object_def get_object_def)

lemma test:
  "\<lbrace> ep_at p and tcb_at r \<rbrace> set_object r obj \<lbrace> \<lambda>rv. ep_at p \<rbrace>"
  apply (rule set_object_at_obj2)
  apply (clarsimp simp: is_obj_defs)
  done

text \<open>Lemmas about well-formed states\<close>

lemma valid_pspaceI [intro]:
  "\<lbrakk> valid_objs s; pspace_aligned s; sym_refs (state_refs_of s); sym_refs (state_hyp_refs_of s);
     pspace_distinct s; if_live_then_nonz_cap s; zombies_final s \<rbrakk>
     \<Longrightarrow> valid_pspace s"
  unfolding valid_pspace_def by simp

lemma valid_pspaceE [elim?]:
  assumes vp: "valid_pspace s"
  and     rl: "\<lbrakk> valid_objs s; pspace_aligned s;
                 sym_refs (state_refs_of s);  sym_refs (state_hyp_refs_of s);
                 pspace_distinct s; if_live_then_nonz_cap s;
                 zombies_final s \<rbrakk> \<Longrightarrow> R"
  shows    R
  using vp
  unfolding valid_pspace_def by (auto intro: rl)

lemma valid_objs_valid_cs [dest?]:
  assumes vp: "valid_objs s"
  and    ran: "CNode sz ct \<in> ran (kheap s)"
  shows  "valid_cs sz ct s"
  using vp ran unfolding valid_objs_def
  by (auto simp: valid_obj_def ran_def dom_def)

lemma valid_pspace_valid_cs [dest?]:
  assumes vp: "valid_pspace s"
  and    ran: "CNode sz ct \<in> ran (kheap s)"
  shows  "valid_cs sz ct s"
  using vp
  by (rule valid_pspaceE)
     (simp add: valid_objs_valid_cs ran)

lemma valid_pspace_aligned:
  assumes vp: "valid_pspace s"
  and    lup: "kheap s addr = Some ko"
  shows  "is_aligned addr (obj_bits ko)"
  using vp
  apply (rule valid_pspaceE)
  apply (unfold pspace_aligned_def)
  apply (drule bspec [OF _ domI])
   apply (rule lup)
  apply (simp add: lup)
  done

lemma valid_pspace_valid_cs_size [intro?]:
  assumes ran: "CNode sz cs \<in> ran (kheap s)"
  and      vp: "valid_pspace s"
  shows  "valid_cs_size sz cs"
  using valid_pspace_valid_cs [OF vp ran]
  unfolding valid_cs_def ..

lemma valid_objs_valid_cs_size [intro?]:
  assumes ran: "CNode sz cs \<in> ran (kheap s)"
  and      vp: "valid_objs s"
  shows  "valid_cs_size sz cs"
  using valid_objs_valid_cs [OF vp ran]
  unfolding valid_cs_def ..

lemma valid_cs_size_objsI [intro?]:
  "\<lbrakk> valid_objs s; kheap s r = Some (CNode sz ps) \<rbrakk>
  \<Longrightarrow> valid_cs_size sz ps"
  by (drule ranI, erule valid_objs_valid_cs_size)

lemma valid_cs_sizeI [intro?]:
  "\<lbrakk> valid_pspace s; kheap s r = Some (CNode sz ps) \<rbrakk>
  \<Longrightarrow> valid_cs_size sz ps"
  by (drule ranI, erule valid_pspace_valid_cs_size)

lemma wf_cs_insert:
  "\<lbrakk> well_formed_cnode_n sz cs; cs ref \<noteq> None \<rbrakk> \<Longrightarrow> well_formed_cnode_n sz (cs (ref \<mapsto> val))"
  apply (clarsimp simp: well_formed_cnode_n_def)
  apply (subst insert_absorb, simp_all)
  apply (drule domI, fastforce)
  done

lemma obj_bits_CNode:
  "\<lbrakk> valid_cs_size sz ps; ps cref = Some cap \<rbrakk> \<Longrightarrow>
  obj_bits (CNode sz ps) = cte_level_bits + length cref"
  by (auto simp: valid_cs_size_def well_formed_cnode_n_def)

lemma obj_bits_CNode':
  "\<lbrakk> valid_cs_size sz ps; cref \<in> dom ps \<rbrakk> \<Longrightarrow>
  obj_bits (CNode sz ps) = cte_level_bits + length cref"
  by (drule domD, erule exE, rule obj_bits_CNode)

lemma valid_cs_sizeE [elim]:
  assumes "valid_cs_size sz cs"
  and     "\<lbrakk> sz < word_bits - cte_level_bits; dom cs = {x. length x = sz};
            obj_bits (CNode sz cs) = cte_level_bits + sz\<rbrakk>
           \<Longrightarrow> R"
  shows "R"
  using assms
  by (auto simp: valid_cs_size_def well_formed_cnode_n_def)

lemma valid_obj_sizes:
  assumes vp: "valid_objs s"
  and     ko: "ko \<in> ran (kheap s)"
  shows   "obj_bits ko < word_bits"
proof (cases ko)
  case CNode
  thus ?thesis using vp ko
    by (auto dest!: valid_objs_valid_cs_size)
next
  case (ArchObj ako)
  show ?thesis using ArchObj by (simp only: valid_arch_sizes)
qed (auto elim: valid_pspaceE
          simp: valid_arch_sizes[unfolded word_bits_conv] word_bits_conv)

lemma valid_pspace_obj_sizes:
  assumes vp: "valid_pspace s"
  and     ko: "ko \<in> ran (kheap s)"
  shows   "obj_bits ko < word_bits" using assms
  by - (rule valid_obj_sizes, auto simp: valid_pspace_def)

lemma valid_objs_replicate:
  assumes aligned: "pspace_aligned s"
  assumes valid: "valid_objs s"
  and     dom:   "x \<in> dom (kheap s)"
  shows   "to_bl x = (take (word_bits - (obj_bits (the (kheap s x)))) (to_bl x)) @
                     replicate (obj_bits (the (kheap s x))) False"
proof -
  let ?a = "obj_bits (the (kheap s x))"

  from aligned have "is_aligned x ?a" using dom
    unfolding pspace_aligned_def ..

  thus ?thesis
    proof (rule is_aligned_replicate[where 'a=machine_word_len, folded word_bits_def])
  show "obj_bits (the (kheap s x)) \<le> word_bits"
    by (rule order_less_imp_le, rule valid_obj_sizes [OF _ dom_ran]) fact+
  qed
qed

lemma valid_pspace_replicate:
  assumes "valid_pspace s"
  and     "x \<in> dom (kheap s)"
  shows   "to_bl x = (take (word_bits - (obj_bits (the (kheap s x)))) (to_bl x)) @
                     replicate (obj_bits (the (kheap s x))) False"
  using assms
  by - (rule valid_objs_replicate, auto simp: valid_pspace_def)

lemma valid_objs_captable_dom_length:
  assumes "valid_objs s"
  assumes "CNode sz ct \<in> ran (kheap s)"
  assumes ct: "ct y \<noteq> None"
  shows "length y < word_bits - cte_level_bits"
proof -
  have "valid_cs_size sz ct" by (rule valid_objs_valid_cs_size) fact+
  thus ?thesis using ct
    by (auto simp: valid_cs_size_def well_formed_cnode_n_def)
qed

lemma valid_pspace_captable_dom_length:
  assumes "valid_pspace s"
  and     "CNode sz ct \<in> ran (kheap s)"
  and     "ct y \<noteq> None"
  shows "length y < word_bits - cte_level_bits"
  using assms
  by - (rule valid_objs_captable_dom_length, auto simp: valid_pspace_def)

lemma valid_objs_replicate':
  assumes valid: "valid_objs s"
  and   aligned: "pspace_aligned s"
  and     dom:   "x \<in> dom (kheap s)"
  and      l1:   "l1 = word_bits - (obj_bits (the (kheap s x)))"
  and      l2:   "l2 = (obj_bits (the (kheap s x)))"
  and      yv:   "y = (to_bl x)"
  shows   "to_bl x = (take l1 y) @ replicate l2 False"
  by ((subst l1 l2 yv)+, rule valid_objs_replicate) fact+

lemma valid_pspace_replicate':
  assumes valid: "valid_pspace s"
  and     dom:   "x \<in> dom (kheap s)"
  and      l1:   "l1 = word_bits - (obj_bits (the (kheap s x)))"
  and      l2:   "l2 = (obj_bits (the (kheap s x)))"
  and      yv:   "y = (to_bl x)"
  shows   "to_bl x = (take l1 y) @ replicate l2 False"
  by ((subst l1 l2 yv)+, rule valid_pspace_replicate) fact+

lemma pspace_replicate_dom:
  assumes "valid_pspace s"
  and pv: "kheap s (of_bl x) = Some (CNode sz ct)"
  shows   "replicate (obj_bits (CNode sz ct) - cte_level_bits) False \<in> dom ct"
proof -
  have "valid_cs_size sz ct"
    by (rule valid_cs_sizeI) fact+

  thus ?thesis
    by (rule valid_cs_sizeE) simp
qed

lemma obj_at_valid_objsE:
  "\<lbrakk> obj_at P p s; valid_objs s;
    \<And>ko. \<lbrakk> kheap s p = Some ko; P ko; valid_obj p ko s \<rbrakk> \<Longrightarrow> Q
  \<rbrakk> \<Longrightarrow> Q"
  by (auto simp: valid_objs_def obj_at_def dom_def)

lemma valid_CNodeCapE:
  assumes p: "s \<turnstile> CNodeCap ptr cbits guard" "valid_objs s" "pspace_aligned s"
  assumes R: "\<And>cs. \<lbrakk> 0 < cbits; kheap s ptr = Some (CNode cbits cs);
               \<forall>cap\<in>ran cs. s \<turnstile> cap; dom cs = {x. length x = cbits};
               is_aligned ptr (cte_level_bits + cbits); cbits < word_bits - cte_level_bits
              \<rbrakk> \<Longrightarrow> P"
  shows "P"
  using p
  apply (clarsimp simp: pspace_aligned_def valid_cap_def)
  apply (erule (1) obj_at_valid_objsE)
  apply (drule bspec, blast)
  apply (clarsimp simp add: is_cap_table)
  apply (clarsimp simp: valid_obj_def valid_cs_def well_formed_cnode_n_def)
  apply (erule valid_cs_sizeE)
  apply (clarsimp simp: cap_aligned_def)
  apply (erule (5) R)
  done

lemma cap_table_at_cte_at:
  "\<lbrakk> cap_table_at cbits ptr s; length offset = cbits \<rbrakk>
  \<Longrightarrow> cte_at (ptr, offset) s"
  apply (clarsimp simp: obj_at_def cte_wp_at_cases is_cap_table
                        well_formed_cnode_n_def length_set_helper)
  apply (rule domD, simp)
  done

declare map_nth_0 [simp del]

lemma valid_cs_sizeE2:
  assumes v: "valid_cs_size sz cs"
  assumes c: "cref \<in> dom cs"
  assumes R: "\<lbrakk>length cref \<le> word_bits - cte_level_bits;
               dom cs = {x. length x = length cref};
               obj_bits (CNode sz cs) = cte_level_bits + length cref\<rbrakk> \<Longrightarrow> R"
  shows "R"
proof -
  from v have sz:
    "sz < word_bits - cte_level_bits"
    "dom cs = {x. length x = sz}"
    "obj_bits (CNode sz cs) = cte_level_bits + sz"
    by auto
  with c
  have "sz = length cref" by auto
  with sz
  show ?thesis
    by - (rule R, auto)
qed

lemma pred_tcb_weakenE:
  "\<lbrakk> pred_tcb_at proj P t s; \<And>tcb . P (proj tcb) \<Longrightarrow> P' (proj tcb) \<rbrakk> \<Longrightarrow> pred_tcb_at proj P' t s"
  by (auto simp: pred_tcb_at_def elim: obj_at_weakenE)

lemma pred_tcb_at_pure:
  "pred_tcb_at g (\<lambda>a. P) (f s) s = (tcb_at (f s) s \<and> P)"
  unfolding pred_tcb_at_def
  apply (clarsimp simp add: obj_at_def)
  apply (rule iffI)
   apply clarsimp
   apply (auto simp: is_tcb_def split: kernel_object.splits)[1]
  apply clarsimp
  apply (case_tac ko; simp_all)
     apply (auto simp: is_tcb_def split: kernel_object.splits)
  done

(* sseefried:
     This lemma exists only to make existing proofs go through more easily.
     Replacing 'st_tcb_at_weakenE' with 'pred_tcb_at_weakenE' in a proof
     should yield the same result.
*)
lemma st_tcb_weakenE:
  "\<lbrakk> st_tcb_at P t s; \<And>st . P st \<Longrightarrow> P' st \<rbrakk> \<Longrightarrow> st_tcb_at P' t s"
  by (auto simp: pred_tcb_weakenE)

lemma tcb_at_st_tcb_at:
  "tcb_at = st_tcb_at (\<lambda>_. True)"
  apply (rule ext)+
  apply (simp add: tcb_at_def pred_tcb_at_def obj_at_def is_tcb_def)
  apply (rule arg_cong [where f=Ex], rule ext)
  apply (case_tac ko, simp_all)
  done

lemma pred_tcb_at_tcb_at:
  "pred_tcb_at proj P t s \<Longrightarrow> tcb_at t s"
  by (auto simp: tcb_at_def pred_tcb_at_def obj_at_def is_tcb)

lemmas st_tcb_at_tcb_at = pred_tcb_at_tcb_at[where proj=itcb_state, simplified]

lemma st_tcb_at_opeqI:
  "\<lbrakk> st_tcb_at ((=) st) t s ; test st \<rbrakk> \<Longrightarrow> st_tcb_at test t s"
  by (fastforce simp add: pred_tcb_def2)

lemma cte_wp_at_weakenE:
  "\<lbrakk> cte_wp_at P t s; \<And>c. P c \<Longrightarrow> P' c \<rbrakk> \<Longrightarrow> cte_wp_at P' t s"
  by (simp add: cte_wp_at_def) blast

lemma le_minus_minus:
  "\<lbrakk> a \<le> b - c; (c :: ('a :: len) word) \<le> b \<rbrakk> \<Longrightarrow> c \<le> b - a"
  by (simp add: word_le_nat_alt unat_sub)

lemma tcb_at_cte_at:
  "\<lbrakk> tcb_at t s; ref \<in> dom tcb_cap_cases \<rbrakk> \<Longrightarrow> cte_at (t, ref) s"
  by (clarsimp simp: obj_at_def cte_wp_at_cases is_tcb)

lemma cte_at_cases:
  "cte_at t s = ((\<exists>sz fun. kheap s (fst t) = Some (CNode sz fun) \<and>
                        well_formed_cnode_n sz fun \<and>
                        (snd t) \<in> dom fun) \<or>
                (\<exists>tcb. kheap s (fst t) = Some (TCB tcb) \<and>
                         (snd t \<in> dom tcb_cap_cases)))"
  by (auto simp add: cte_wp_at_cases dom_def)

lemma cte_atE [consumes 1, case_names CNode TCB, elim?]:
  assumes cat: "cte_at t s"
  and     rct: "\<And>sz fun. \<lbrakk>kheap s (fst t) = Some (CNode sz fun); snd t \<in> dom fun\<rbrakk> \<Longrightarrow> R"
  and    rtcb: "\<And>tcb. \<lbrakk>kheap s (fst t) = Some (TCB tcb); snd t \<in> dom tcb_cap_cases \<rbrakk> \<Longrightarrow> R"
  shows "R"
  using cat by (auto simp: cte_at_cases intro: rct rtcb)

lemma cte_wp_atE:
  "\<lbrakk>cte_wp_at P t s;
  \<And>sz fun cte. \<lbrakk>kheap s (fst t) = Some (CNode sz fun); well_formed_cnode_n sz fun;
                fun (snd t) = Some cte; P cte\<rbrakk> \<Longrightarrow> R;
  \<And>tcb getF setF restr. \<lbrakk>kheap s (fst t) = Some (TCB tcb);
                          tcb_cap_cases (snd t) = Some (getF, setF, restr); P (getF tcb) \<rbrakk> \<Longrightarrow> R \<rbrakk>
  \<Longrightarrow> R"
  by (fastforce simp: cte_wp_at_cases dom_def)

lemma cte_wp_at_cteI:
  "\<lbrakk>kheap s (fst t) = Some (CNode sz fun); well_formed_cnode_n sz fun; fun (snd t) = Some cte; P cte\<rbrakk>
  \<Longrightarrow> cte_wp_at P t s"
  by (auto simp: cte_wp_at_cases dom_def well_formed_cnode_n_def length_set_helper)

lemma cte_wp_at_tcbI:
  "\<lbrakk>kheap s (fst t) = Some (TCB tcb); tcb_cap_cases (snd t) = Some (getF, setF); P (getF tcb) \<rbrakk>
  \<Longrightarrow> cte_wp_at P t s"
  by (auto simp: cte_wp_at_cases dom_def)

lemma ko_at_obj_congD:
  "\<lbrakk> ko_at k1 p s; ko_at k2 p s \<rbrakk> \<Longrightarrow> k1 = k2"
  unfolding obj_at_def
  by simp

lemma not_obj_at_strengthen:
  "obj_at (Not \<circ> P) p s \<Longrightarrow> \<not> obj_at P p s"
  by (clarsimp simp: obj_at_def)

lemma not_pred_tcb_at_strengthen:
  "pred_tcb_at proj (Not \<circ> P) p s \<Longrightarrow> \<not> pred_tcb_at proj P p s"
  apply (simp add: pred_tcb_at_def)
  apply (strengthen not_obj_at_strengthen)
  apply (fastforce simp add: comp_def obj_at_def)
  done

text \<open>using typ_at triples to prove other triples\<close>

lemma cte_at_typ:
  "cte_at p = (\<lambda>s. typ_at (ACapTable (length (snd p))) (fst p) s
                \<or> (typ_at ATCB (fst p) s \<and> snd p \<in> dom tcb_cap_cases))"
  apply (rule ext)
  apply (simp add: cte_at_cases obj_at_def)
  apply (rule arg_cong2[where f="(\<or>)"])
   apply (safe, simp_all add: a_type_def DomainI)
    apply (clarsimp simp add: a_type_def well_formed_cnode_n_def length_set_helper)
    apply (drule_tac m="fun" in domI)
    apply simp
   apply (case_tac ko, simp_all)
   apply (simp add: well_formed_cnode_n_def length_set_helper split: if_split_asm)
  apply (case_tac ko, simp_all split: if_split_asm)
  done

lemma valid_cte_at_typ:
  assumes P: "\<And>T p. \<lbrace>typ_at T p\<rbrace> f \<lbrace>\<lambda>rv. typ_at T p\<rbrace>"
  shows      "\<lbrace>cte_at c\<rbrace> f \<lbrace>\<lambda>rv. cte_at c\<rbrace>"
  unfolding cte_at_typ
  apply (rule hoare_vcg_disj_lift [OF P])
  apply (rule hoare_vcg_conj_lift [OF P])
  apply (rule hoare_vcg_prop)
  done

lemma length_helper:
  "\<exists>y. length y = n"
  apply (rule_tac x="replicate n x" in exI)
  apply simp
  done

lemma pspace_typ_at:
  "kheap s p = Some obj \<Longrightarrow> \<exists>T. typ_at T p s"
  by (clarsimp simp: obj_at_def)


lemma obj_bits_T:
  "obj_bits v = obj_bits_type (a_type v)"
  apply (cases v, simp_all add: obj_bits_type_def a_type_def)
  apply (rule aobj_bits_T)
  done


lemma obj_range_T:
  "obj_range p v = typ_range p (a_type v)"
  by (simp add: obj_range_def typ_range_def obj_bits_T)

lemma valid_untyped_T:
  "valid_untyped c =
  (\<lambda>s. \<forall>T p. \<not>typ_at T p s \<or> typ_range p T \<inter> untyped_range c = {} \<or>
         (typ_range p T \<subseteq> untyped_range c \<and> typ_range p T \<inter> usable_untyped_range c = {}))"
  apply (simp add: valid_untyped_def obj_range_T obj_at_def)
  apply (rule ext)
  apply (rule iffI)
    apply clarsimp
    apply (elim allE)
    apply (erule(1) impE)+
      apply fastforce
  apply clarsimp
    apply (elim allE disjE)
    apply (erule(1) impE)
    apply fastforce+
  done

lemma valid_untyped_typ:
  assumes P: "\<And>P T p. \<lbrace>\<lambda>s. P (typ_at T p s)\<rbrace> f \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
  shows "\<lbrace>valid_untyped (UntypedCap dev r n fr)\<rbrace> f
         \<lbrace>\<lambda>rv. valid_untyped (UntypedCap dev r n fr)\<rbrace>"
  unfolding valid_untyped_T
  apply (rule hoare_vcg_all_lift)
  apply (rule hoare_vcg_all_lift)
  apply (rule hoare_vcg_disj_lift [OF P])
  apply (rule hoare_vcg_prop)
  done

lemma cap_aligned_Null [simp]:
  "cap_aligned (NullCap)"
  by (simp add: cap_aligned_def word_bits_def is_aligned_def)


lemma valid_cap_typ:
  assumes P: "\<And>P T p. \<lbrace>\<lambda>s. P (typ_at T p s)\<rbrace> f \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
  shows      "\<lbrace>\<lambda>s. valid_cap c s\<rbrace> f \<lbrace>\<lambda>rv s. valid_cap c s\<rbrace>"
  apply (simp add: valid_cap_def)
  apply (rule hoare_vcg_conj_lift)
   apply (simp add: valid_def)
  apply (case_tac c,
         simp_all add: valid_cap_def P P[where P=id, simplified]
                       ep_at_typ tcb_at_typ ntfn_at_typ
                       cap_table_at_typ hoare_vcg_prop)
      apply (rule hoare_vcg_conj_lift [OF valid_untyped_typ[OF P]])
      apply (simp add: valid_def)
     apply (rule hoare_vcg_conj_lift [OF P hoare_vcg_prop])+
   apply (rename_tac option nat)
   apply (case_tac option, simp_all add: tcb_at_typ cap_table_at_typ)[1]
    apply (rule hoare_vcg_conj_lift [OF P])
    apply (rule hoare_vcg_prop)
   apply (rule hoare_vcg_conj_lift [OF P])
   apply (rule hoare_vcg_prop)
  apply (wp valid_arch_cap_typ P)
  done

lemma valid_tcb_state_typ:
  assumes P: "\<And>T p. \<lbrace>typ_at T p\<rbrace> f \<lbrace>\<lambda>rv. typ_at T p\<rbrace>"
  shows      "\<lbrace>\<lambda>s. valid_tcb_state st s\<rbrace> f \<lbrace>\<lambda>rv s. valid_tcb_state st s\<rbrace>"
  by (case_tac st,
      simp_all add: valid_tcb_state_def hoare_TrueI
                    ep_at_typ P tcb_at_typ ntfn_at_typ)

lemma ntfn_at_typ_at:
  "(\<And>T p. \<lbrace>typ_at T p\<rbrace> f \<lbrace>\<lambda>rv. typ_at T p\<rbrace>) \<Longrightarrow> \<lbrace>ntfn_at c\<rbrace> f \<lbrace>\<lambda>rv. ntfn_at c\<rbrace>"
  by (simp add: ntfn_at_typ)

lemma valid_tcb_typ:
  assumes P: "\<And>P T p. \<lbrace>\<lambda>s. P (typ_at T p s)\<rbrace> f \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
  shows      "\<lbrace>\<lambda>s. valid_tcb p tcb s\<rbrace> f \<lbrace>\<lambda>rv s. valid_tcb p tcb s\<rbrace>"
  apply (simp add: valid_tcb_def valid_bound_ntfn_def split_def)
  apply (wp valid_tcb_state_typ valid_cap_typ P hoare_vcg_const_Ball_lift
            valid_case_option_post_wp ntfn_at_typ_at valid_arch_tcb_lift)
  done

lemma valid_cs_typ:
  assumes P: "\<And>P T p. \<lbrace>\<lambda>s. P (typ_at T p s)\<rbrace> f \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
  shows      "\<lbrace>\<lambda>s. valid_cs sz cs s\<rbrace> f \<lbrace>\<lambda>rv s. valid_cs sz cs s\<rbrace>"
  apply (simp add: valid_cs_def)
  apply (rule hoare_vcg_conj_lift [OF _ hoare_vcg_prop])
  apply (rule hoare_vcg_const_Ball_lift)
  apply (rule valid_cap_typ [OF P])
  done

lemma valid_ep_typ:
  assumes P: "\<And>p. \<lbrace>typ_at ATCB p\<rbrace> f \<lbrace>\<lambda>rv. typ_at ATCB p\<rbrace>"
  shows      "\<lbrace>\<lambda>s. valid_ep ep s\<rbrace> f \<lbrace>\<lambda>rv s. valid_ep ep s\<rbrace>"
  apply (case_tac ep,
         simp_all add: valid_ep_def hoare_TrueI tcb_at_typ)
   apply (rule hoare_vcg_conj_lift [OF hoare_vcg_prop])
   apply (rule hoare_vcg_conj_lift [OF _ hoare_vcg_prop])
   apply (rule hoare_vcg_const_Ball_lift [OF P])
  apply (rule hoare_vcg_conj_lift [OF hoare_vcg_prop])
  apply (rule hoare_vcg_conj_lift [OF _ hoare_vcg_prop])
  apply (rule hoare_vcg_const_Ball_lift [OF P])
  done

lemma valid_ntfn_typ:
  assumes P: "\<And>p. \<lbrace>typ_at ATCB p\<rbrace> f \<lbrace>\<lambda>rv. typ_at ATCB p\<rbrace>"
  shows      "\<lbrace>\<lambda>s. valid_ntfn ntfn s\<rbrace> f \<lbrace>\<lambda>rv s. valid_ntfn ntfn s\<rbrace>"
  apply (case_tac "ntfn_obj ntfn",
         simp_all add: valid_ntfn_def valid_bound_tcb_def hoare_TrueI tcb_at_typ)
    defer 2
    apply ((case_tac "ntfn_bound_tcb ntfn", simp_all add: hoare_TrueI tcb_at_typ P)+)[2]
  apply (rule hoare_vcg_conj_lift [OF hoare_vcg_prop])+
  apply (rule hoare_vcg_conj_lift)
   apply (rule hoare_vcg_const_Ball_lift [OF P])
  apply (rule hoare_vcg_conj_lift [OF hoare_vcg_prop])
  apply (case_tac "ntfn_bound_tcb ntfn", simp_all add: hoare_TrueI tcb_at_typ P)
  apply (rule hoare_vcg_conj_lift [OF hoare_vcg_prop], simp add: P)
  done

lemma valid_obj_typ:
  assumes P: "\<And>P p T. \<lbrace>\<lambda>s. P (typ_at T p s)\<rbrace> f \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
  shows      "\<lbrace>\<lambda>s. valid_obj p ob s\<rbrace> f \<lbrace>\<lambda>rv s. valid_obj p ob s\<rbrace>"
  apply (case_tac ob, simp_all add: valid_obj_def P P [where P=id, simplified]
         wellformed_arch_typ
         valid_cs_typ valid_tcb_typ valid_ep_typ valid_ntfn_typ)
  done

lemma valid_irq_node_typ:
  assumes P: "\<And>p. \<lbrace>\<lambda>s. typ_at (ACapTable 0) p s\<rbrace> f \<lbrace>\<lambda>rv s. typ_at (ACapTable 0) p s\<rbrace>"
  assumes Q: "\<And>P. \<lbrace>\<lambda>s. P (interrupt_irq_node s)\<rbrace> f \<lbrace>\<lambda>rv s. P (interrupt_irq_node s)\<rbrace>"
  shows      "\<lbrace>valid_irq_node\<rbrace> f \<lbrace>\<lambda>rv. valid_irq_node\<rbrace>"
  apply (simp add: valid_irq_node_def cap_table_at_typ)
  apply (wp Q hoare_use_eq [OF Q P] hoare_vcg_all_lift)
  done

lemma wf_cs_upd:
  "\<lbrakk> cs x = Some y \<rbrakk> \<Longrightarrow>
     well_formed_cnode_n n (cs (x \<mapsto> z)) = well_formed_cnode_n n cs"
  apply (clarsimp simp: well_formed_cnode_n_def)
  apply (subst insert_absorb)
   apply (erule domI)
  apply (rule refl)
  done


lemma cte_wp_at_valid_objs_valid_cap:
  "\<lbrakk> cte_wp_at P p s; valid_objs s \<rbrakk> \<Longrightarrow> \<exists>cap. P cap \<and> valid_cap cap s"
  apply (clarsimp simp: cte_wp_at_cases valid_objs_def)
  apply (erule disjE)
   apply clarsimp
   apply (drule bspec, erule domI)
   apply (clarsimp simp: valid_obj_def valid_cs_def)
   apply (drule bspec, erule ranI)
   apply fastforce
  apply clarsimp
  apply (drule bspec, erule domI)
  apply (clarsimp simp: valid_obj_def valid_tcb_def)
  apply (fastforce simp: ran_def)
  done

lemma is_cap_simps:
  "is_cnode_cap cap = (\<exists>r bits g. cap = CNodeCap r bits g)"
  "is_thread_cap cap = (\<exists>r. cap = ThreadCap r)"
  "is_domain_cap cap = (cap = DomainCap)"
  "is_untyped_cap cap = (\<exists>dev r bits f. cap = UntypedCap dev r bits f)"
  "is_ep_cap cap = (\<exists>r b R. cap = EndpointCap r b R)"
  "is_ntfn_cap cap = (\<exists>r b R. cap = NotificationCap r b R)"
  "is_zombie cap = (\<exists>r b n. cap = Zombie r b n)"
  "is_arch_cap cap = (\<exists>a. cap = ArchObjectCap a)"
  "is_reply_cap cap = (\<exists>x R. cap = ReplyCap x False R)"
  "is_master_reply_cap cap = (\<exists>x R. cap = ReplyCap x True R)"
  by (cases cap, auto simp: is_zombie_def is_arch_cap_def
                            is_reply_cap_def is_master_reply_cap_def)+


lemma wf_unique:
  "well_formed_cnode_n bits f \<Longrightarrow>
  (THE n. well_formed_cnode_n n f) = bits"
  by (clarsimp simp: well_formed_cnode_n_def length_set_helper)

lemma wf_obj_bits:
  "well_formed_cnode_n bits f \<Longrightarrow> obj_bits (CNode bits f) = cte_level_bits + bits"
  by simp

lemma wf_cs_n_unique:
  "\<lbrakk> well_formed_cnode_n n f; well_formed_cnode_n n' f \<rbrakk>
  \<Longrightarrow> n = n'"
  by (clarsimp simp: well_formed_cnode_n_def length_set_helper)


lemma typ_at_range:
  "\<lbrakk> typ_at T p s; pspace_aligned s; valid_objs s \<rbrakk> \<Longrightarrow> typ_range p T \<noteq> {}"
  apply (erule (1) obj_at_valid_objsE)
  apply (clarsimp simp: pspace_aligned_def)
  apply (drule bspec)
   apply blast
  apply clarsimp
  apply (case_tac ko)
       apply (clarsimp simp: a_type_def split: if_split_asm)
        apply (clarsimp simp: typ_range_def obj_bits_type_def)
        apply (erule notE)
        apply (erule is_aligned_no_overflow)
       apply (clarsimp simp: valid_obj_def valid_cs_def valid_cs_size_def)
      apply (auto simp: a_type_def typ_range_def  obj_bits_type_def
                        aobj_bits_T
                  dest!: is_aligned_no_overflow
               | simp)+
  done

lemma typ_at_eq_kheap_obj:
  "typ_at ATCB p s \<longleftrightarrow> (\<exists>tcb. kheap s p = Some (TCB tcb))"
  "typ_at AEndpoint p s \<longleftrightarrow> (\<exists>ep. kheap s p = Some (Endpoint ep))"
  "typ_at ANTFN p s \<longleftrightarrow> (\<exists>ntfn. kheap s p = Some (Notification ntfn))"
  "typ_at (ACapTable n) p s \<longleftrightarrow>
   (\<exists>cs. kheap s p = Some (CNode n cs) \<and> well_formed_cnode_n n cs)"
  "typ_at (AGarbage n) p s \<longleftrightarrow>
   (\<exists>cs. n \<ge> cte_level_bits \<and> kheap s p = Some (CNode (n - cte_level_bits) cs) \<and> \<not> well_formed_cnode_n (n - cte_level_bits) cs)"
  by ((clarsimp simp add: obj_at_def a_type_def; rule iffI; clarsimp),
      case_tac ko; fastforce simp: wf_unique
                             split: if_split_asm kernel_object.splits)+

lemma a_type_ACapTableE:
  "\<lbrakk>a_type ko = ACapTable n;
    (!!cs. \<lbrakk>ko = CNode n cs; well_formed_cnode_n n cs\<rbrakk> \<Longrightarrow> R)\<rbrakk>
   \<Longrightarrow> R"
  by (case_tac ko, simp_all add: a_type_simps split: if_split_asm)

lemma a_type_AGarbageE:
  "\<lbrakk>a_type ko = AGarbage n;
    (!!cs. \<lbrakk>n \<ge> cte_level_bits; ko = CNode (n - cte_level_bits) cs; \<not>well_formed_cnode_n (n - cte_level_bits) cs\<rbrakk> \<Longrightarrow> R)\<rbrakk>
   \<Longrightarrow> R"
  by (case_tac ko, simp_all add: a_type_simps split: if_split_asm, fastforce)

lemma a_type_ATCBE:
  "\<lbrakk>a_type ko = ATCB; (!!tcb. ko = TCB tcb \<Longrightarrow> R)\<rbrakk> \<Longrightarrow> R"
  by (case_tac ko, simp_all add: a_type_simps split: if_split_asm)

lemma a_type_AEndpointE:
  "\<lbrakk>a_type ko = AEndpoint; (!!ep. ko = Endpoint ep \<Longrightarrow> R)\<rbrakk> \<Longrightarrow> R"
  by (case_tac ko, simp_all add: a_type_simps split: if_split_asm)

lemma a_type_ANTFNE:
  "\<lbrakk>a_type ko = ANTFN; (!!ntfn. ko = Notification ntfn \<Longrightarrow> R)\<rbrakk> \<Longrightarrow> R"
  by (case_tac ko, simp_all add: a_type_simps split: if_split_asm)

lemmas a_type_elims[elim!] =
   a_type_ACapTableE a_type_AGarbageE a_type_ATCBE
   a_type_AEndpointE a_type_ANTFNE

lemma valid_objs_caps_contained:
  "\<lbrakk> valid_objs s; pspace_aligned s \<rbrakk> \<Longrightarrow> caps_contained s"
  unfolding caps_contained_def
  apply (intro allI impI)
  apply (drule (1) cte_wp_at_valid_objs_valid_cap)
  apply (drule (1) cte_wp_at_valid_objs_valid_cap)
  apply clarsimp
  apply (case_tac c, simp_all)
  apply (erule disjE)
   apply (clarsimp simp: valid_cap_def is_cap_simps)
   apply (clarsimp simp: valid_untyped_T)
   apply (simp add: cap_table_at_typ)
   apply (erule allE, erule allE, erule (1) impE)
   apply (drule (2) typ_at_range)
   apply (clarsimp simp: typ_range_def obj_bits_type_def)
   apply fastforce
  apply (clarsimp simp: valid_cap_def is_cap_simps)
  apply (clarsimp simp: valid_untyped_T)
  apply (simp add: tcb_at_typ)
  apply (erule allE, erule allE, erule (1) impE)
  apply (drule (2) typ_at_range)
  apply (clarsimp simp: typ_range_def obj_bits_type_def)
  apply fastforce
  done

lemma P_null_filter_caps_of_cte_wp_at:
  "\<not> P NullCap \<Longrightarrow>
   (null_filter (caps_of_state s) x \<noteq> None \<and> P (the (null_filter (caps_of_state s) x)))
     = (cte_wp_at P x s)"
  by (simp add: cte_wp_at_caps_of_state null_filter_def, fastforce)

lemma cte_wp_at_cte_at:
  "cte_wp_at P p s \<Longrightarrow> cte_at p s"
  by (erule cte_wp_at_weakenE, rule TrueI)

lemma real_cte_at_cte:
  "real_cte_at cref s \<Longrightarrow> cte_at cref s"
  by (cases cref, clarsimp simp: cap_table_at_cte_at)

lemma real_cte_tcb_valid:
  "real_cte_at ptr s \<longrightarrow> tcb_cap_valid cap ptr s"
  by (clarsimp simp: tcb_cap_valid_def obj_at_def is_cap_table is_tcb)

lemma swp_cte_at_caps_of:
  "swp (cte_wp_at P) s = (\<lambda>p. \<exists>c. caps_of_state s p = Some c \<and> P c)"
  apply (rule ext)
  apply (simp add: cte_wp_at_caps_of_state swp_def)
  done

lemma valid_mdb_def2:
  "valid_mdb = (\<lambda>s. mdb_cte_at (\<lambda>p. \<exists>c. caps_of_state s p = Some c \<and> NullCap \<noteq> c) (cdt s) \<and>
                    untyped_mdb (cdt s) (caps_of_state s) \<and> descendants_inc (cdt s) (caps_of_state s) \<and>
                    no_mloop (cdt s) \<and> untyped_inc (cdt s) (caps_of_state s) \<and>
                    ut_revocable (is_original_cap s) (caps_of_state s) \<and>
                    irq_revocable (is_original_cap s) (caps_of_state s) \<and>
                    reply_master_revocable (is_original_cap s) (caps_of_state s) \<and>
                    reply_mdb (cdt s) (caps_of_state s) \<and>
                    valid_arch_mdb (is_original_cap s) (caps_of_state s))"
  by (auto simp add: valid_mdb_def swp_cte_at_caps_of)

lemma cte_wp_valid_cap:
  "\<lbrakk> cte_wp_at ((=) c) p s; valid_objs s \<rbrakk> \<Longrightarrow> s \<turnstile> c"
  apply (simp add: cte_wp_at_cases)
  apply (erule disjE)
   apply clarsimp
   apply (simp add: valid_objs_def dom_def)
   apply (erule allE, erule impE, fastforce)
   apply (fastforce simp: ran_def valid_obj_def valid_cs_def)
  apply clarsimp
  apply (simp add: valid_objs_def dom_def)
  apply (erule allE, erule impE, fastforce)
  apply (fastforce simp: ran_def valid_obj_def valid_tcb_def)
  done

lemma cte_wp_tcb_cap_valid:
  "\<lbrakk> cte_wp_at ((=) c) p s; valid_objs s \<rbrakk> \<Longrightarrow> tcb_cap_valid c p s"
  apply (clarsimp simp: tcb_cap_valid_def obj_at_def
                        pred_tcb_at_def cte_wp_at_cases)
  apply (erule disjE, (clarsimp simp: is_tcb)+)
  apply (erule(1) valid_objsE)
  apply (clarsimp simp: valid_obj_def valid_tcb_def)
  apply (drule bspec, erule ranI, simp)
  apply clarsimp
  done

lemma caps_of_state_cte_at:
  "caps_of_state s p = Some c \<Longrightarrow> cte_at p s"
  by (simp add: cte_wp_at_caps_of_state)

lemma cte_wp_cte_at:
  "cte_wp_at P p s \<Longrightarrow> cte_at p s"
  by (auto simp add: cte_wp_at_cases)


context pspace_update_eq begin

interpretation Arch_pspace_update_eq ..

lemma valid_space_update [iff]:
  "valid_pspace (f s) = valid_pspace s"
  by (fastforce intro: valid_pspace_eqI simp: pspace)

lemmas obj_at_update [iff] = obj_at_update
lemmas arch_valid_obj_update [iff] = arch_valid_obj_update

lemma cte_wp_at_update [iff]:
  "cte_wp_at P p (f s) = cte_wp_at P p s"
  by (fastforce intro: cte_wp_at_pspaceI simp: pspace)

lemma iflive_update [iff]:
  "if_live_then_nonz_cap (f s) = if_live_then_nonz_cap s"
  by (simp add: if_live_then_nonz_cap_def ex_nonz_cap_to_def)

lemma valid_objs_update [iff]:
  "valid_objs (f s) = valid_objs s"
  by (fastforce intro: valid_objs_pspaceI simp: pspace)

lemma pspace_aligned_update [iff]:
  "pspace_aligned (f s) = pspace_aligned s"
  by (simp add: pspace_aligned_def pspace)

lemma pspace_distinct_update [iff]:
  "pspace_distinct (f s) = pspace_distinct s"
  by (simp add: pspace_distinct_def pspace)

lemma pred_tcb_at_update [iff]:
  "pred_tcb_at proj P p (f s) = pred_tcb_at proj P p s"
  by (simp add: pred_tcb_at_def)

lemma valid_cap_update [iff]:
  "(f s) \<turnstile> c = s \<turnstile> c"
  by (auto intro: valid_cap_pspaceI simp: pspace)

lemmas get_cap_update [iff] = get_cap_update
lemmas caps_of_state_update [iff] = caps_of_state_update

lemma valid_refs_update [iff]:
  "valid_refs R (f s) = valid_refs R s"
  by (simp add: valid_refs_def)

lemma has_reply_cap_update [iff]:
  "has_reply_cap t (f s) = has_reply_cap t s"
  by (simp add: has_reply_cap_def)

lemma valid_reply_caps_update [iff]:
  "valid_reply_caps (f s) = valid_reply_caps s"
  by (simp add: valid_reply_caps_def)

lemma valid_reply_masters_update [iff]:
  "valid_reply_masters (f s) = valid_reply_masters s"
  by (simp add: valid_reply_masters_def)

lemmas in_user_frame_update[iff] = in_user_frame_update
lemmas in_device_frame_update[iff] = in_device_frame_update

end


context p_arch_update_eq begin

interpretation Arch_p_arch_update_eq f ..

declare equal_kernel_mappings_update [iff]

lemma valid_vspace_objs_update [iff]:
  "valid_vspace_objs (f s) = valid_vspace_objs s"
  by (simp add: valid_vspace_objs_def arch pspace)

lemma valid_arch_cap_update [iff]:
  "valid_arch_caps (f s) = valid_arch_caps s"
  by (simp add: valid_arch_caps_def pspace arch)

lemma valid_global_objs_update [iff]:
  "valid_global_objs (f s) = valid_global_objs s"
  by (simp add: valid_global_objs_def arch)

lemma valid_global_vspace_mappings_update [iff]:
  "valid_global_vspace_mappings (f s) = valid_global_vspace_mappings s"
  unfolding valid_global_vspace_mappings_def by (simp add: arch Let_def)

lemma pspace_in_kernel_window_update [iff]:
  "pspace_in_kernel_window (f s) = pspace_in_kernel_window s"
  by (simp add: pspace_in_kernel_window_def arch pspace)

lemma cap_refs_in_kernel_window_update [iff]:
  "cap_refs_in_kernel_window (f s) = cap_refs_in_kernel_window s"
  by (simp add: cap_refs_in_kernel_window_def arch pspace)

end


context p_arch_idle_update_eq begin

interpretation Arch_p_arch_idle_update_eq f ..

lemma ifunsafe_update [iff]:
  "if_unsafe_then_cap (f s) = if_unsafe_then_cap s"
  by (simp add: if_unsafe_then_cap_def ex_cte_cap_wp_to_def irq)

lemma valid_global_refs_update [iff]:
  "valid_global_refs (f s) = valid_global_refs s"
  by (simp add: valid_global_refs_def arch idle)

lemma valid_asid_map_update [iff]:
  "valid_asid_map (f s) = valid_asid_map s"
  by (simp add: valid_asid_map_def vspace_at_asid_def arch)

lemma valid_arch_state_update [iff]:
  "valid_arch_state (f s) = valid_arch_state s"
  by (simp add: valid_arch_state_def arch pspace split: option.split)

lemma valid_idle_update [iff]:
  "valid_idle (f s) = valid_idle s"
  by (auto intro: valid_idle_pspaceI simp: pspace idle)

lemma valid_kernel_mappings_update [iff]:
  "valid_kernel_mappings (f s) = valid_kernel_mappings s"
  by (simp add: valid_kernel_mappings_def
                pspace arch)

lemma only_idle_update [iff]:
  "only_idle (f s) = only_idle s"
  by (simp add: only_idle_def idle)

lemma valid_irq_node_update[iff]:
  "valid_irq_node (f s) = valid_irq_node s"
  by (simp add: valid_irq_node_def irq)

end

lemma (in irq_states_update_eq) irq_issued_update [iff]:
  "irq_issued irq (f s) = irq_issued irq s"
  by (simp add: irq_issued_def int)

lemma (in pspace_int_update_eq) valid_irq_handlers_update [iff]:
  "valid_irq_handlers (f s) = valid_irq_handlers s"
  by (simp add: valid_irq_handlers_def)

context arch_idle_update_eq begin
interpretation Arch_arch_idle_update_eq f ..
lemmas global_refs_update[iff] = global_refs_update
end

interpretation revokable_update:
  p_arch_idle_update_int_eq "is_original_cap_update f"
  by unfold_locales auto

sublocale Arch \<subseteq> revokable_update: Arch_p_arch_idle_update_int_eq "is_original_cap_update f" ..

interpretation machine_state_update:
  p_arch_idle_update_int_eq "machine_state_update f"
  by unfold_locales auto

sublocale Arch \<subseteq> machine_state_update: Arch_p_arch_idle_update_int_eq "machine_state_update f" ..

interpretation cdt_update:
  p_arch_idle_update_int_eq "cdt_update f"
  by unfold_locales auto

sublocale Arch \<subseteq> cdt_update: Arch_p_arch_idle_update_int_eq "cdt_update f" ..

interpretation cur_thread_update:
  p_arch_idle_update_int_eq "cur_thread_update f"
  by unfold_locales auto

sublocale Arch \<subseteq> cur_thread_update: Arch_p_arch_idle_update_int_eq "cur_thread_update f" ..

interpretation more_update:
  p_arch_idle_update_int_eq "trans_state f"
  by unfold_locales auto

sublocale Arch \<subseteq> more_update: Arch_p_arch_idle_update_int_eq "trans_state f" ..

interpretation interrupt_update:
  p_arch_idle_update_eq "interrupt_states_update f"
  by unfold_locales auto

sublocale Arch \<subseteq> interrupt_update: Arch_p_arch_idle_update_eq "interrupt_states_update f" ..

interpretation irq_node_update:
  pspace_int_update_eq "interrupt_irq_node_update f"
  by unfold_locales auto

sublocale Arch \<subseteq> irq_node_update: Arch_pspace_update_eq "interrupt_irq_node_update f" ..

interpretation arch_update:
  pspace_int_update_eq "arch_state_update f"
  by unfold_locales auto

sublocale Arch \<subseteq> arch_update: Arch_pspace_update_eq "arch_state_update f" ..

interpretation irq_node_update_arch:
  p_arch_update_eq "interrupt_irq_node_update f"
  by unfold_locales auto

sublocale Arch \<subseteq> irq_node_update_arch: Arch_p_arch_update_eq "interrupt_irq_node_update f" ..

lemma obj_ref_in_untyped_range:
  "\<lbrakk> is_untyped_cap c; cap_aligned c \<rbrakk> \<Longrightarrow> obj_ref_of c \<in> untyped_range c"
  apply (clarsimp simp: is_cap_simps cap_aligned_def)
  apply (erule is_aligned_no_overflow)
  done

lemma untyped_range_non_empty:
  "\<lbrakk> is_untyped_cap c; cap_aligned c \<rbrakk> \<Longrightarrow> untyped_range c \<noteq> {}"
  by (blast dest: obj_ref_in_untyped_range)

lemma valid_mdb_cur [iff]:
  "valid_mdb (cur_thread_update f s) = valid_mdb s"
  by (auto elim!: valid_mdb_eqI)

lemma valid_mdb_more_update [iff]:
  "valid_mdb (trans_state f s) = valid_mdb s"
  by (auto elim!: valid_mdb_eqI)

lemma valid_mdb_machine [iff]:
  "valid_mdb (machine_state_update f s) = valid_mdb s"
  by (auto elim: valid_mdb_eqI)

lemma valid_refs_cte:
  assumes "\<And>P p. cte_wp_at P p s = cte_wp_at P p s'"
  shows "valid_refs R s = valid_refs R s'"
  by (simp add: valid_refs_def assms)

lemma valid_refs_cte_lift:
  assumes ctes: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
  shows "\<lbrace>\<lambda>s. valid_refs R s\<rbrace> f \<lbrace>\<lambda>_ s. valid_refs R s\<rbrace>"
  apply (simp add: valid_refs_def2)
  apply (rule ctes)
  done


lemma valid_global_refs_cte:
  assumes "\<And>P p. cte_wp_at P p s = cte_wp_at P p s'"
  assumes "global_refs s = global_refs s'"
  shows "valid_global_refs s = valid_global_refs s'"
  apply (simp add: valid_global_refs_def)
  by (simp add: valid_global_refs_def assms valid_refs_def)


lemma valid_global_refs_cte_lift:
  assumes ctes: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
  assumes arch: "\<And>P. \<lbrace>\<lambda>s. P (arch_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (arch_state s)\<rbrace>"
  assumes idle: "\<And>P. \<lbrace>\<lambda>s. P (idle_thread s)\<rbrace> f \<lbrace>\<lambda>_ s. P (idle_thread s)\<rbrace>"
  assumes irq: "\<And>P. \<lbrace>\<lambda>s. P (interrupt_irq_node s)\<rbrace> f \<lbrace>\<lambda>_ s. P (interrupt_irq_node s)\<rbrace>"
  shows "\<lbrace>valid_global_refs\<rbrace> f \<lbrace>\<lambda>_. valid_global_refs\<rbrace>"
  unfolding valid_global_refs_def valid_refs_def2
  apply (rule hoare_lift_Pf [where f="caps_of_state", OF _ ctes])
  apply (rule global_refs_lift[OF arch idle irq])
  done


lemma has_reply_cap_cte_lift:
  assumes ctes: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
  shows "\<lbrace>\<lambda>s. P (has_reply_cap t s)\<rbrace> f \<lbrace>\<lambda>_ s. P (has_reply_cap t s)\<rbrace>"
  unfolding has_reply_cap_def
  by (simp add: cte_wp_at_caps_of_state, rule ctes)

lemma valid_reply_caps_st_cte_lift:
  assumes ctes: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
  assumes tcbs: "\<And>P t. \<lbrace>st_tcb_at P t\<rbrace> f \<lbrace>\<lambda>_. st_tcb_at P t\<rbrace>"
  shows "\<lbrace>valid_reply_caps\<rbrace> f \<lbrace>\<lambda>_. valid_reply_caps\<rbrace>"
  unfolding valid_reply_caps_def
  apply (rule hoare_vcg_conj_lift)
   apply (rule hoare_vcg_all_lift)
   apply (subst disj_not1 [THEN sym])+
   apply (rule hoare_vcg_disj_lift)
    apply (rule has_reply_cap_cte_lift)
    apply (rule ctes)
   apply (rule tcbs)
  apply (rule ctes)
  done

lemma valid_reply_masters_cte:
  assumes "\<And>P p. cte_wp_at P p s = cte_wp_at P p s'"
  shows "valid_reply_masters s = valid_reply_masters s'"
  by (simp add: valid_reply_masters_def assms tcb_at_typ)

lemma valid_reply_masters_cte_lift:
  assumes ctes: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
  shows "\<lbrace>valid_reply_masters\<rbrace> f \<lbrace>\<lambda>_. valid_reply_masters\<rbrace>"
  unfolding valid_reply_masters_def
  apply (rule hoare_vcg_all_lift)+
  apply (subst disj_not1 [THEN sym])+
  apply (rule hoare_vcg_disj_lift)
   apply (simp add: cte_wp_at_caps_of_state)
   apply (rule ctes)
  apply wp
  done

lemma pred_tcb_at_disj:
  "(pred_tcb_at proj P t s \<or> pred_tcb_at proj Q t s) = pred_tcb_at proj (\<lambda>a. P a \<or> Q a) t s"
  by (fastforce simp add: pred_tcb_at_def obj_at_def)

lemma dom_empty_cnode: "dom (empty_cnode us) = {x. length x = us}"
  unfolding empty_cnode_def
  by (simp add: dom_def)

lemma obj_at_default_cap_valid:
  "\<lbrakk>obj_at (\<lambda>ko. ko = default_object ty dev us) x s;
   ty = CapTableObject \<Longrightarrow> 0 < us;
   ty \<noteq> Untyped; ty \<noteq> ArchObject ASIDPoolObj;
   cap_aligned (default_cap ty x us dev)\<rbrakk>
  \<Longrightarrow> s \<turnstile> default_cap ty x us dev"
  unfolding valid_cap_def
  by (clarsimp elim!: obj_at_weakenE
      intro!: aobj_at_default_arch_cap_valid
      simp: default_object_def dom_empty_cnode well_formed_cnode_n_def
            is_tcb is_ep is_ntfn is_cap_table
            a_type_def obj_at_def
     split: apiobject_type.splits
            option.splits)


lemma obj_ref_default [simp]:
  "obj_ref_of (default_cap ty x us dev) = x"
  by (cases ty, auto simp: aobj_ref_default)

lemma valid_pspace_aligned2 [elim!]:
  "valid_pspace s \<Longrightarrow> pspace_aligned s"
  by (simp add: valid_pspace_def)

lemma valid_pspace_distinct [elim!]:
  "valid_pspace s \<Longrightarrow> pspace_distinct s"
  by (simp add: valid_pspace_def)

lemma ctable_vtable_neq [simp]:
  "get_tcb_ctable_ptr ptr \<noteq> get_tcb_vtable_ptr ptr"
  unfolding get_tcb_ctable_ptr_def get_tcb_vtable_ptr_def
  by simp

lemma ep_at_typ_at:
  "(\<And>T p. \<lbrace>typ_at T p\<rbrace> f \<lbrace>\<lambda>rv. typ_at T p\<rbrace>) \<Longrightarrow> \<lbrace>ep_at c\<rbrace> f \<lbrace>\<lambda>rv. ep_at c\<rbrace>"
  by (simp add: ep_at_typ)

lemma tcb_at_typ_at:
  "(\<And>T p. \<lbrace>typ_at T p\<rbrace> f \<lbrace>\<lambda>rv. typ_at T p\<rbrace>) \<Longrightarrow> \<lbrace>tcb_at c\<rbrace> f \<lbrace>\<lambda>rv. tcb_at c\<rbrace>"
  by (simp add: tcb_at_typ)

lemma cap_table_at_typ_at:
  "(\<And>T p. \<lbrace>typ_at T p\<rbrace> f \<lbrace>\<lambda>rv. typ_at T p\<rbrace>) \<Longrightarrow> \<lbrace>cap_table_at n c\<rbrace> f \<lbrace>\<lambda>rv. cap_table_at n c\<rbrace>"
  by (simp add: cap_table_at_typ)


lemmas abs_typ_at_lifts  =
  ep_at_typ_at ntfn_at_typ_at tcb_at_typ_at
  cap_table_at_typ_at
  valid_tcb_state_typ valid_cte_at_typ valid_ntfn_typ
  valid_ep_typ valid_cs_typ valid_untyped_typ
  valid_tcb_typ valid_obj_typ valid_cap_typ valid_vspace_obj_typ

lemma valid_idle_lift:
  assumes "\<And>P t. \<lbrace>idle_tcb_at P t\<rbrace> f \<lbrace>\<lambda>_. idle_tcb_at P t\<rbrace>"
  assumes "\<And>P. \<lbrace>\<lambda>s. P (idle_thread s)\<rbrace> f \<lbrace>\<lambda>_ s. P (idle_thread s)\<rbrace>"
  shows "\<lbrace>valid_idle\<rbrace> f \<lbrace>\<lambda>_. valid_idle\<rbrace>"
  apply (simp add: valid_idle_def)
  apply (rule hoare_lift_Pf [where f="idle_thread"])
   apply (rule hoare_vcg_conj_lift | rule assms)+
  done


lemmas caps_of_state_valid_cap = cte_wp_valid_cap [OF caps_of_state_cteD]

(* generic consequence of architecture-specific details *)
lemma (in Arch) obj_ref_is_arch:
  "\<lbrakk>aobj_ref c = Some r; valid_arch_cap c s\<rbrakk> \<Longrightarrow> \<exists> ako. kheap s r = Some (ArchObj ako)"
  by (auto simp: valid_arch_cap_def obj_at_def valid_arch_cap_ref_def
           split: arch_cap.splits if_splits)

requalify_facts Arch.obj_ref_is_arch


lemma obj_ref_is_tcb:
  "\<lbrakk> r \<in> obj_refs cap; tcb_at r s; s \<turnstile> cap \<rbrakk> \<Longrightarrow>
  is_thread_cap cap \<or> is_zombie cap"
  by (auto simp: valid_cap_def is_cap_simps obj_at_def is_obj_defs a_type_def
          split: cap.splits
           dest: obj_ref_is_arch)

lemma obj_ref_is_cap_table:
  "\<lbrakk> r \<in> obj_refs cap; cap_table_at n r s; s \<turnstile> cap \<rbrakk> \<Longrightarrow>
  is_cnode_cap cap \<or> is_zombie cap"
  by (auto simp: valid_cap_def is_cap_simps obj_at_def is_obj_defs a_type_def
           dest: obj_ref_is_arch
           split: cap.splits if_split_asm)

lemma ut_revocableD:
  "\<lbrakk> cs p = Some cap; is_untyped_cap cap; ut_revocable r cs \<rbrakk> \<Longrightarrow> r p"
  by (auto simp: ut_revocable_def)

lemma untyped_range_is_untyped_cap [elim!]:
  "untyped_range cap \<noteq> {} \<Longrightarrow> is_untyped_cap cap"
  by (cases cap) auto

lemma not_is_untyped_no_range [elim!]:
  "\<not>is_untyped_cap cap \<Longrightarrow> untyped_range cap = {}"
  by (cases cap) auto

lemma untyped_mdbD:
  "\<lbrakk> cs ptr = Some cap; is_untyped_cap cap; cs ptr' = Some cap';
     obj_refs cap' \<inter> untyped_range cap \<noteq> {}; untyped_mdb m cs \<rbrakk>
  \<Longrightarrow> ptr' \<in> descendants_of ptr m"
  unfolding untyped_mdb_def by blast

lemma untyped_incD:
  "\<lbrakk> cs p = Some c; is_untyped_cap c; cs p' = Some c'; is_untyped_cap c'; untyped_inc m cs \<rbrakk> \<Longrightarrow>
  (untyped_range c \<subseteq> untyped_range c' \<or> untyped_range c' \<subseteq> untyped_range c \<or> untyped_range c \<inter> untyped_range c' = {}) \<and>
  (untyped_range c \<subset> untyped_range c' \<longrightarrow> (p \<in> descendants_of p' m \<and> untyped_range c \<inter> usable_untyped_range c' = {})) \<and>
  (untyped_range c' \<subset> untyped_range c \<longrightarrow> (p' \<in> descendants_of p m \<and> untyped_range c' \<inter> usable_untyped_range c = {})) \<and>
  (untyped_range c = untyped_range c' \<longrightarrow> (p' \<in> descendants_of p m \<and> usable_untyped_range c = {}
  \<or> p \<in> descendants_of p' m \<and> usable_untyped_range c' = {} \<or> p = p'))"
  unfolding untyped_inc_def
  apply (drule_tac x = p in spec)
  apply (drule_tac x = p' in spec)
  apply (elim allE impE)
    apply simp+
  done

lemma cte_wp_at_norm:
  "cte_wp_at P p s \<Longrightarrow> \<exists>c. cte_wp_at ((=) c) p s \<and> P c"
  by (auto simp add: cte_wp_at_cases)

lemma valid_mdb_arch_state [simp]:
  "valid_mdb (arch_state_update f s) = valid_mdb s"
  by (auto elim!: valid_mdb_eqI)

lemma valid_idle_arch_state [simp]:
  "valid_idle (arch_state_update f s) = valid_idle s"
  by (simp add: valid_idle_def)

lemma if_unsafe_then_cap_arch_state [simp]:
  "if_unsafe_then_cap (arch_state_update f s) = if_unsafe_then_cap s"
  by (simp add: if_unsafe_then_cap_def ex_cte_cap_wp_to_def)

lemma swp_cte_at_arch_update [iff]:
  "swp cte_at (s\<lparr>arch_state := a\<rparr>) = swp cte_at s"
  by (simp add: cte_wp_at_cases swp_def)

lemma swp_caps_of_state_arch_update [iff]:
  "caps_of_state (s\<lparr>arch_state := a\<rparr>) = caps_of_state s"
  apply (rule cte_wp_caps_of_lift)
  apply (simp add: cte_wp_at_cases)
  done

lemma is_master_reply_cap_NullCap:
  "is_master_reply_cap NullCap = False"
  by (simp add: is_cap_simps)

lemma unique_reply_capsD:
  "\<lbrakk> unique_reply_caps cs; reply_masters_mdb m cs;
     cs master = Some (ReplyCap t True rights);
     sl\<in>descendants_of master m; sl'\<in>descendants_of master m \<rbrakk>
   \<Longrightarrow> sl = sl'"
  apply (simp add: reply_masters_mdb_def
           del: split_paired_All)
  apply (drule_tac x=master in spec)
  apply (drule_tac x=t in spec)
  apply (clarsimp simp del: split_paired_All)
  apply (frule_tac x=sl in bspec,assumption)
  apply (drule_tac x=sl' in bspec,assumption)
  by (clarsimp simp add: unique_reply_caps_def is_cap_simps
           simp del: split_paired_All)

(* FIXME: duplicated with caps_of_state_valid_cap *)
lemmas caps_of_state_valid =  caps_of_state_valid_cap

lemma valid_reply_mastersD:
  "\<lbrakk> cte_wp_at (is_master_reply_cap_to t) p s; valid_reply_masters s \<rbrakk>
   \<Longrightarrow> p = (t, tcb_cnode_index 2)"
  by (simp add: valid_reply_masters_def del: split_paired_All)

lemma valid_reply_mastersD':
  "\<lbrakk> cte_wp_at ((=) (ReplyCap t True R)) p s; valid_reply_masters s \<rbrakk>
   \<Longrightarrow> p = (t, tcb_cnode_index 2)"
  by (fastforce simp add: valid_reply_masters_def is_master_reply_cap_to_def
                simp del: split_paired_All
                elim: cte_wp_at_lift
                elim!: impE)


lemma valid_cap_aligned:
  "s \<turnstile> cap \<Longrightarrow> cap_aligned cap"
  by (simp add: valid_cap_def)

lemma valid_pspace_vo [elim!]:
  "valid_pspace s \<Longrightarrow> valid_objs s"
  by (simp add: valid_pspace_def)

lemma pred_tcb_at_conj_strg:
  "pred_tcb_at proj P t s \<and> pred_tcb_at proj Q t s \<longrightarrow> pred_tcb_at proj (\<lambda>a. P a \<and> Q a) t s"
  by (clarsimp simp: pred_tcb_at_def obj_at_def)

lemma real_cte_at_typ_valid:
  "\<lbrace>typ_at (ACapTable (length (snd p))) (fst p)\<rbrace>
     f
   \<lbrace>\<lambda>rv. typ_at (ACapTable (length (snd p))) (fst p)\<rbrace>
   \<Longrightarrow> \<lbrace>real_cte_at p\<rbrace> f \<lbrace>\<lambda>rv. real_cte_at p\<rbrace>"
  by (simp add: cap_table_at_typ)

lemma dmo_aligned[wp]:
  "do_machine_op f \<lbrace>pspace_aligned\<rbrace>"
  apply (simp add: do_machine_op_def split_def)
  apply wpsimp
  done

lemma cte_wp_at_eqD2:
  "\<lbrakk>cte_wp_at ((=) c) p s; cte_wp_at P p s \<rbrakk> \<Longrightarrow> P c"
  by (auto elim!: cte_wp_atE split: if_split_asm)

lemma not_pred_tcb:
  "(\<not>pred_tcb_at proj P t s) = (\<not>tcb_at t s \<or> pred_tcb_at proj (\<lambda>a. \<not>P a) t s)"
  apply (simp add: pred_tcb_at_def obj_at_def is_tcb_def)
  apply (auto split: kernel_object.splits)
  done


lemma only_idle_arch [iff]:
  "only_idle (arch_state_update f s) = only_idle s"
  by (simp add: only_idle_def)

(* TODO: move to Wellform before the instantiation. should be instantiated retroactively, but isn't. *)
(* FIXME: would be nice to be in the iff-set. *)
lemma (in pspace_update_eq) state_refs_update:
  "state_refs_of (f s) = state_refs_of s"
  by (simp add: state_refs_of_def pspace cong: option.case_cong)

lemmas (in pspace_update_eq) state_hyp_refs_update[iff] = state_hyp_refs_update[OF  pspace]

declare more_update.state_refs_update[iff]
declare more_update.state_hyp_refs_update[iff]

lemma zombies_final_arch_update [iff]:
  "zombies_final (arch_state_update f s) = zombies_final s"
  by (simp add: zombies_final_def is_final_cap'_def)

lemma zombies_final_more_update [iff]:
  "zombies_final (trans_state f s) = zombies_final s"
  by (simp add: zombies_final_def is_final_cap'_def)

lemmas state_refs_arch_update [iff] = arch_update.state_refs_update

lemmas state_hyp_refs_arch_update [iff] = arch_update.state_hyp_refs_update

lemma valid_ioc_arch_state_update[iff]:
  "valid_ioc (arch_state_update f s) = valid_ioc s"
  by (simp add: valid_ioc_def)

lemma valid_ioc_more_update[iff]:
  "valid_ioc (trans_state f s) = valid_ioc s"
  by (simp add: valid_ioc_def)

lemma valid_ioc_interrupt_states_update[iff]:
  "valid_ioc (interrupt_states_update f s) = valid_ioc s"
  by (simp add: valid_ioc_def)
lemma valid_ioc_machine_state_update[iff]:
  "valid_ioc (machine_state_update f s) = valid_ioc s"
  by (simp add: valid_ioc_def)
lemma valid_ioc_cur_thread_update[iff]:
  "valid_ioc (cur_thread_update f s) = valid_ioc s"
  by (simp add: valid_ioc_def)

lemma vms_ioc_update[iff]:
  "valid_machine_state (is_original_cap_update f s::'z::state_ext state) = valid_machine_state s"
  by (simp add: valid_machine_state_def)+

lemma valid_machine_state_more_update[iff]:
  "valid_machine_state (trans_state f s) = valid_machine_state s"
  by (simp add: valid_machine_state_def)

lemma only_idle_lift_weak:
  assumes "\<And>Q P t. \<lbrace>\<lambda>s. Q (st_tcb_at P t s)\<rbrace> f \<lbrace>\<lambda>_ s. Q (st_tcb_at P t s)\<rbrace>"
  assumes "\<And>P. \<lbrace>\<lambda>s. P (idle_thread s)\<rbrace> f \<lbrace>\<lambda>_ s. P (idle_thread s)\<rbrace>"
  shows "\<lbrace>only_idle\<rbrace> f \<lbrace>\<lambda>_. only_idle\<rbrace>"
  apply (simp add: only_idle_def)
  apply (rule hoare_vcg_all_lift)
  apply (rule hoare_lift_Pf [where f="idle_thread"])
   apply (rule assms)+
  done

lemma only_idle_lift:
  assumes T: "\<And>P T p. \<lbrace>\<lambda>s. P (typ_at T p s)\<rbrace> f \<lbrace>\<lambda>_ s. P (typ_at T p s)\<rbrace>"
  assumes s: "\<And>P t. \<lbrace>st_tcb_at P t\<rbrace> f \<lbrace>\<lambda>_. st_tcb_at P t\<rbrace>"
  assumes i: "\<And>P. \<lbrace>\<lambda>s. P (idle_thread s)\<rbrace> f \<lbrace>\<lambda>_ s. P (idle_thread s)\<rbrace>"
  shows "\<lbrace>only_idle\<rbrace> f \<lbrace>\<lambda>_. only_idle\<rbrace>"
  apply (simp add: only_idle_def)
  apply (rule hoare_vcg_all_lift)
  apply (subst imp_conv_disj not_pred_tcb)+
  apply (rule hoare_vcg_disj_lift)+
    apply (simp add: tcb_at_typ)
    apply (rule T)
   apply (rule s)
  apply (rule hoare_lift_Pf [where f="idle_thread"])
   apply (rule assms)+
  done


lemma cap_rights_update_id [intro!, simp]:
  "wellformed_cap c \<Longrightarrow> cap_rights_update (cap_rights c) c = c"
  unfolding cap_rights_update_def
  by (cases c) (auto simp: wellformed_cap_simps split: bool.split)

lemma cap_mask_UNIV [simp]:
  "wellformed_cap c \<Longrightarrow> mask_cap UNIV c = c"
  by (simp add: mask_cap_def)

lemma wf_empty_bits:
  "well_formed_cnode_n bits (empty_cnode bits)"
  by (simp add: well_formed_cnode_n_def empty_cnode_def dom_def)

lemma well_formed_cnode_valid_cs_size:
  "valid_cs_size bits s \<Longrightarrow> well_formed_cnode_n bits s"
  by (clarsimp simp: valid_cs_size_def)

lemma empty_cnode_bits:
  "obj_bits (CNode n (empty_cnode n)) = cte_level_bits + n"
  by (simp add: wf_empty_bits)

lemma irq_revocableD:
  "\<lbrakk> cs p = Some IRQControlCap; irq_revocable (is_original_cap s) cs \<rbrakk> \<Longrightarrow> is_original_cap s p"
  by (fastforce simp add: irq_revocable_def simp del: split_paired_All)

lemma invs_valid_stateI [elim!]:
  "invs s \<Longrightarrow> valid_state s"
  by (simp add: invs_def)

lemma tcb_at_invs [elim!]:
  "invs s \<Longrightarrow> tcb_at (cur_thread s) s"
  by (simp add: invs_def cur_tcb_def)

lemma valid_irq_states_more_update[iff]:
  "valid_irq_states (trans_state f s) = valid_irq_states s"
  by (simp add: valid_irq_states_def)


lemma invs_valid_objs [elim!]:
  "invs s \<Longrightarrow> valid_objs s"
  by (simp add: invs_def valid_state_def valid_pspace_def)

lemma invs_psp_aligned [elim!]:
  "invs s \<Longrightarrow> pspace_aligned s"
  by (simp add: invs_def valid_state_def valid_pspace_def)

lemma invs_mdb [elim!]:
  "invs s \<Longrightarrow> valid_mdb s"
  by (simp add: invs_def valid_state_def)

lemma invs_mdb_cte [elim!]:
  "invs s \<Longrightarrow> mdb_cte_at (swp (cte_wp_at ((\<noteq>) NullCap)) s) (cdt s)"
  by (simp add: invs_def valid_state_def valid_mdb_def)

lemma invs_valid_pspace [elim!]:
  "invs s \<Longrightarrow> valid_pspace s"
  by (simp add: invs_def valid_state_def)

lemma invs_arch_state [elim!]:
  "invs s \<Longrightarrow> valid_arch_state s"
  by (simp add: invs_def valid_state_def)

lemma invs_cur [elim!]:
  "invs s \<Longrightarrow> cur_tcb s"
  by (simp add: invs_def)

lemma invs_distinct [elim!]:
  "invs s \<Longrightarrow> pspace_distinct s"
  by (simp add: invs_def valid_state_def valid_pspace_def)

lemma invs_iflive [elim!]:
  "invs s \<Longrightarrow> if_live_then_nonz_cap s"
  by (simp add: invs_def valid_state_def valid_pspace_def)

lemma invs_sym_refs [elim!]:
  "invs s \<Longrightarrow> sym_refs (state_refs_of s)"
  by (simp add: invs_def valid_state_def valid_pspace_def)

lemma invs_hyp_sym_refs [elim!]:
  "invs s \<Longrightarrow> sym_refs (state_hyp_refs_of s)"
  by (simp add: invs_def valid_state_def valid_pspace_def)

lemma invs_valid_reply_caps [elim!]:
  "invs s \<Longrightarrow> valid_reply_caps s"
  by (simp add: invs_def valid_state_def)

lemma invs_valid_reply_masters [elim!]:
  "invs s \<Longrightarrow> valid_reply_masters s"
  by (simp add: invs_def valid_state_def)

lemma invs_vobjs_strgs:
  "invs s \<longrightarrow> valid_objs s"
  by auto

lemma invs_valid_global_refs [elim!]:
  "invs s \<Longrightarrow> valid_global_refs s"
  by (simp add: invs_def valid_state_def)

lemma invs_zombies [elim!]:
  "invs s \<Longrightarrow> zombies_final s"
  by (simp add: invs_def valid_state_def valid_pspace_def)

lemma objs_valid_tcb_ctable:
  "\<lbrakk>valid_objs s; get_tcb t s = Some tcb\<rbrakk> \<Longrightarrow> s \<turnstile> tcb_ctable tcb"
  apply (clarsimp simp: get_tcb_def split: option.splits kernel_object.splits)
  apply (erule cte_wp_valid_cap[rotated])
  apply (rule cte_wp_at_tcbI[where t="(a, b)" for a b, where b3="tcb_cnode_index 0"])
    apply fastforce+
  done

lemma invs_valid_tcb_ctable:
  "\<lbrakk>invs s; get_tcb t s = Some tcb\<rbrakk> \<Longrightarrow> s \<turnstile> tcb_ctable tcb"
  apply (drule invs_valid_stateI)
  apply (clarsimp simp: valid_state_def valid_pspace_def objs_valid_tcb_ctable)
  done

lemma invs_vspace_objs [elim!]:
  "invs s \<Longrightarrow> valid_vspace_objs s"
  by (simp add: invs_def valid_state_def)

lemma invs_valid_idle[elim!]:
  "invs s \<Longrightarrow> valid_idle s"
  by (fastforce simp: invs_def valid_state_def)


lemma simple_st_tcb_at_state_refs_ofD:
  "st_tcb_at simple t s \<Longrightarrow> bound_tcb_at (\<lambda>x. tcb_bound_refs x = state_refs_of s t) t s"
  by (fastforce simp: pred_tcb_at_def obj_at_def state_refs_of_def)


lemma active_st_tcb_at_state_refs_ofD:
  "st_tcb_at active t s \<Longrightarrow> bound_tcb_at (\<lambda>x. tcb_bound_refs x = state_refs_of s t) t s"
  by (fastforce simp: pred_tcb_at_def obj_at_def state_refs_of_def)

lemma cur_tcb_revokable [iff]:
  "cur_tcb (is_original_cap_update f s) = cur_tcb s"
  by (simp add: cur_tcb_def)

lemma cur_tcb_arch [iff]:
  "cur_tcb (arch_state_update f s) = cur_tcb s"
  by (simp add: cur_tcb_def)

lemma invs_valid_global_objs[elim!]:
  "invs s \<Longrightarrow> valid_global_objs s"
  by (clarsimp simp: invs_def valid_state_def)

lemma get_irq_slot_real_cte:
  "\<lbrace>invs\<rbrace> get_irq_slot irq \<lbrace>real_cte_at\<rbrace>"
  apply (simp add: get_irq_slot_def)
  apply wp
  apply (clarsimp simp: invs_def valid_state_def
    valid_irq_node_def)
  done

lemma all_invs_but_sym_refs_check:
  "(all_invs_but_sym_refs and sym_refs \<circ> state_refs_of and sym_refs o state_hyp_refs_of) = invs"
  by (simp add: invs_def valid_state_def valid_pspace_def
                o_def pred_conj_def conj_comms)


lemma invs_valid_asid_map[elim!]:
  "invs s \<Longrightarrow> valid_asid_map s"
  by (simp add: invs_def valid_state_def)

lemma invs_equal_kernel_mappings[elim!]:
  "invs s \<Longrightarrow> equal_kernel_mappings s"
  by (simp add:invs_def valid_state_def)

lemma invs_valid_irq_node[elim!]:
  "invs s \<Longrightarrow> valid_irq_node s"
  by (simp add: invs_def valid_state_def)

lemma invs_ifunsafe[elim!]:
  "invs s \<Longrightarrow> if_unsafe_then_cap s"
  by (simp add: invs_def valid_state_def valid_pspace_def)

lemma cte_wp_at_cap_aligned:
  "\<lbrakk>cte_wp_at P p s; invs s\<rbrakk> \<Longrightarrow> \<exists>c. P c \<and> cap_aligned c"
  apply (drule (1) cte_wp_at_valid_objs_valid_cap [OF _ invs_valid_objs])
  apply (fastforce simp: valid_cap_def)
  done

lemma cte_wp_at_cap_aligned':
  "\<lbrakk>cte_wp_at ((=) cap) p s; invs s\<rbrakk> \<Longrightarrow> cap_aligned cap"
  apply (drule (1) cte_wp_at_valid_objs_valid_cap [OF _ invs_valid_objs])
  apply (fastforce simp: valid_cap_def)
  done

locale invs_locale =
  fixes ex_inv :: "'z::state_ext state \<Rightarrow> bool"
  assumes dmo_ex_inv[wp]: "\<And>f. \<lbrace>invs and ex_inv\<rbrace> do_machine_op f \<lbrace>\<lambda>rv::unit. ex_inv\<rbrace>"
  assumes cap_insert_ex_inv[wp]: "\<And>cap src dest.
  \<lbrace>ex_inv and invs and K (src \<noteq> dest)\<rbrace>
      cap_insert cap src dest
  \<lbrace>\<lambda>_.ex_inv\<rbrace>"
  assumes cap_delete_one_ex_inv[wp]: "\<And>cap.
   \<lbrace>ex_inv and invs\<rbrace> cap_delete_one cap \<lbrace>\<lambda>_.ex_inv\<rbrace>"

  assumes set_endpoint_ex_inv[wp]: "\<And>a b.\<lbrace>ex_inv\<rbrace> set_endpoint a b \<lbrace>\<lambda>_.ex_inv\<rbrace>"
  assumes sts_ex_inv[wp]: "\<And>a b. \<lbrace>ex_inv\<rbrace> set_thread_state a b \<lbrace>\<lambda>_.ex_inv\<rbrace>"

  assumes setup_caller_cap_ex_inv[wp]: "\<And>send receive grant. \<lbrace>ex_inv and valid_mdb\<rbrace> setup_caller_cap send receive grant \<lbrace>\<lambda>_.ex_inv\<rbrace>"
  assumes do_ipc_transfer_ex_inv[wp]: "\<And>a b c d e. \<lbrace>ex_inv and valid_objs and valid_mdb\<rbrace> do_ipc_transfer a b c d e \<lbrace>\<lambda>_.ex_inv\<rbrace>"

  assumes thread_set_ex_inv[wp]: "\<And>a b. \<lbrace>ex_inv\<rbrace> thread_set a b \<lbrace>\<lambda>_.ex_inv\<rbrace>"


lemma invs_locale_trivial:
  "invs_locale \<top>"
  by (unfold_locales; wp)

lemma in_dxo_pspaceD:
  "((), s') \<in> fst (do_extended_op f s) \<Longrightarrow> kheap s' = kheap s"
  by (clarsimp simp: do_extended_op_def select_f_def in_monad)

lemma in_dxo_cdtD:
  "((), s') \<in> fst (do_extended_op f s) \<Longrightarrow> cdt s' = cdt s"
  by (clarsimp simp: do_extended_op_def select_f_def in_monad)

lemma in_dxo_revokableD:
  "((), s') \<in> fst (do_extended_op f s) \<Longrightarrow> is_original_cap s' = is_original_cap s"
  by (clarsimp simp: do_extended_op_def select_f_def in_monad)

lemma in_dxo_cur_threadD:
  "((), s') \<in> fst (do_extended_op f s) \<Longrightarrow> cur_thread s' = cur_thread s"
  by (clarsimp simp: do_extended_op_def select_f_def in_monad)

lemma in_dxo_idle_threadD:
  "((), s') \<in> fst (do_extended_op f s) \<Longrightarrow> idle_thread s' = idle_thread s"
  by (clarsimp simp: do_extended_op_def select_f_def in_monad)

lemma in_dxo_machine_stateD:
  "((), s') \<in> fst (do_extended_op f s) \<Longrightarrow> machine_state s' = machine_state s"
  by (clarsimp simp: do_extended_op_def select_f_def in_monad)

lemma in_dxo_irq_nodeD:
  "((), s') \<in> fst (do_extended_op f s) \<Longrightarrow> interrupt_irq_node s' = interrupt_irq_node s"
  by (clarsimp simp: do_extended_op_def select_f_def in_monad)

lemma in_dxo_interruptD:
  "((), s') \<in> fst (do_extended_op f s) \<Longrightarrow> interrupt_states s' = interrupt_states s"
  by (clarsimp simp: do_extended_op_def select_f_def in_monad)

lemma in_dxo_archD:
  "((), s') \<in> fst (do_extended_op f s) \<Longrightarrow> arch_state s' = arch_state s"
  by (clarsimp simp: do_extended_op_def select_f_def in_monad)

lemma sym_refs_bound_tcb_atD:
  "\<lbrakk>bound_tcb_at P t s; sym_refs (state_refs_of s)\<rbrakk>
    \<Longrightarrow> \<exists>ts ntfnptr.
        P ntfnptr \<and>
        obj_at (tcb_ntfn_is_bound ntfnptr) t s \<and>
        state_refs_of s t = tcb_st_refs_of ts \<union> tcb_bound_refs ntfnptr \<and>
        (\<forall>(x, tp)\<in>tcb_st_refs_of ts \<union> tcb_bound_refs ntfnptr.
            obj_at (\<lambda>ko. (t, symreftype tp) \<in> refs_of ko) x s)"
  apply (drule bound_tcb_at_state_refs_ofD)
  apply (erule exE)+
  apply (rule_tac x=ts in exI)
  apply (rule_tac x=ntfnptr in exI)
  apply clarsimp
  apply (frule obj_at_state_refs_ofD)
  apply (drule (1)sym_refs_obj_atD)
  apply auto
  done

lemma max_ipc_length_unfold:
  "max_ipc_length = 128"
  by (simp add: max_ipc_length_def cap_transfer_data_size_def msg_max_length_def msg_max_extra_caps_def)

lemma valid_mask_vm_rights[simp]:
  "mask_vm_rights V R \<in> valid_vm_rights"
  by (simp add: mask_vm_rights_def)

lemma invs_pspace_in_kernel_window[elim!]:
  "invs s \<Longrightarrow> pspace_in_kernel_window s"
  by (simp add: invs_def valid_state_def)

lemmas invs_implies =
  invs_equal_kernel_mappings
  invs_arch_state
  invs_valid_asid_map
  invs_valid_global_objs
  invs_vspace_objs
  invs_psp_aligned
  invs_distinct
  invs_cur
  invs_iflive
  invs_ifunsafe
  invs_valid_global_refs
  invs_valid_idle
  invs_valid_irq_node
  invs_mdb
  invs_valid_objs
  invs_valid_pspace
  invs_valid_reply_caps
  invs_valid_reply_masters
  invs_valid_stateI
  invs_zombies
  invs_hyp_sym_refs
  invs_sym_refs
  tcb_at_invs
  invs_pspace_in_kernel_window

(* Pull invs out of a complex goal and prove it only once. Use as (strengthen invs_strengthen)+,
   best in combination with simp and potentially conj_cong. *)
lemma invs_strengthen:
  "invs s \<Longrightarrow> P s \<longrightarrow> invs s"
  "invs s \<and> (P s \<longrightarrow> Q s) \<Longrightarrow> P s \<longrightarrow> invs s \<and> Q s"
  "invs s \<and> (P s \<longrightarrow> Q s) \<Longrightarrow> P s \<longrightarrow> Q s \<and> invs s"
  "invs s \<and> (P s \<longrightarrow> Q s) \<Longrightarrow> P s \<longrightarrow> (invs and Q) s"
  "invs s \<and> (P s \<longrightarrow> Q s) \<Longrightarrow> P s \<longrightarrow> (Q and invs) s"
  by auto

end