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

theory StateRelation_C
imports Wellformed_C
begin

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

definition
  "lifth p s \<equiv> the (clift (t_hrs_' s) p)"

definition
  "array_relation r n a c \<equiv> \<forall>i \<le> n. r (a i) (index c (unat i))"

(* used for bound ntfn/tcb *)
definition
  "option_to_ctcb_ptr x \<equiv> case x of None \<Rightarrow> NULL | Some t \<Rightarrow> tcb_ptr_to_ctcb_ptr t"

definition
  byte_to_word_heap :: "(word32 \<Rightarrow> word8) \<Rightarrow> (word32 \<Rightarrow> 10 word \<Rightarrow> word32)"
  where
  "byte_to_word_heap m base off \<equiv> let (ptr :: word32) = base + (ucast off * 4) in
                                       word_rcat [m (ptr + 3), m (ptr + 2), m (ptr + 1), m ptr]"

definition
  heap_to_user_data :: "(word32 \<Rightarrow> kernel_object option) \<Rightarrow> (word32 \<Rightarrow> word8) \<Rightarrow> (word32 \<Rightarrow> (10 word \<Rightarrow> word32) option)"
  where
  "heap_to_user_data hp bhp \<equiv> \<lambda>p. let (uhp :: word32 \<Rightarrow> user_data option) = (projectKO_opt \<circ>\<^sub>m hp) in
                                      option_map (\<lambda>_. byte_to_word_heap bhp p) (uhp p)"

definition
  heap_to_device_data :: "(word32 \<Rightarrow> kernel_object option) \<Rightarrow> (word32 \<Rightarrow> word8) \<Rightarrow> (word32 \<Rightarrow> (10 word \<Rightarrow> word32) option)"
  where
  "heap_to_device_data hp bhp \<equiv> \<lambda>p. let (uhp :: word32 \<Rightarrow> user_data_device option) = (projectKO_opt \<circ>\<^sub>m hp) in
                                      option_map (\<lambda>_. byte_to_word_heap bhp p) (uhp p)"

definition
  cmap_relation :: "(word32 \<rightharpoonup> 'a) \<Rightarrow> 'b typ_heap \<Rightarrow> (word32 \<Rightarrow> 'b ptr) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
  where
  "cmap_relation as cs addr_fun rel \<equiv>
          (addr_fun ` (dom as) = dom cs) \<and>
          (\<forall>x \<in> dom as. rel (the (as x)) (the (cs (addr_fun x))))"

definition
  carray_map_relation :: "nat \<Rightarrow> (word32 \<rightharpoonup> ('a :: pre_storable))
    \<Rightarrow> ('b ptr \<Rightarrow> bool) \<Rightarrow> (word32 \<Rightarrow> 'b ptr) \<Rightarrow> bool"
where
  "carray_map_relation bits as cs addr_fun \<equiv>
    (\<forall>p. (is_aligned p bits \<and> (\<forall>p'. p' && ~~ mask bits = p \<and> is_aligned p' (objBits (the (as p')))
        \<longrightarrow> p' \<in> dom as)) \<longleftrightarrow> cs (addr_fun p))"

definition
  cvariable_array_map_relation :: "(word32 \<rightharpoonup> 'a) \<Rightarrow> ('a \<Rightarrow> nat)
    \<Rightarrow> (word32 \<Rightarrow> ('c :: c_type) ptr) \<Rightarrow> heap_typ_desc \<Rightarrow> bool"
where
  "cvariable_array_map_relation amap szs ptrfun htd
    \<equiv> \<forall>p v. amap p = Some v \<longrightarrow> h_t_array_valid htd (ptrfun p) (szs v)"

definition
  asid_map_pd_to_hwasids :: "(asid \<rightharpoonup> hw_asid \<times> obj_ref) \<Rightarrow> (obj_ref \<Rightarrow> hw_asid set)"
where
 "asid_map_pd_to_hwasids mp \<equiv> \<lambda>pd. {hwasid. (hwasid, pd) \<in> ran mp}"

definition
  pd_pointer_to_asid_slot :: "obj_ref \<rightharpoonup> pde_C ptr"
where
 "pd_pointer_to_asid_slot pd \<equiv> if is_aligned pd pdBits then Some (Ptr (pd + 0x3FC0)) else None"

definition
  pde_stored_asid :: "pde_C \<rightharpoonup> hw_asid"
where
 "pde_stored_asid pde \<equiv> if pde_get_tag pde = scast pde_pde_invalid
                             \<and> to_bool (stored_asid_valid_CL (pde_pde_invalid_lift pde))
                        then Some (ucast (stored_hw_asid_CL (pde_pde_invalid_lift pde)))
                        else None"

end

text \<open>
  Conceptually, the constant armKSKernelVSpace_C resembles ghost state.
  The constant specifies the use of certain address ranges, or ``windows''.
  It is the very nature of these ranges is that they remain fixed
  after initialization.
  Hence, it is not necessary to carry this value around
  as part of the actual state.
  Rather, we simply fix it in a locale for the state relation.

  Note that this locale does not build on @{text kernel}
  but @{text substitute_pre}.
  Hence, we can later base definitions for the ADT on it,
  which can subsequently be instantiated for
  @{text kernel_all_global_addresses} as well as @{text kernel_all_substitute}.
\<close>
locale state_rel = Arch + substitute_pre + (*FIXME: arch_split*)
  fixes armKSKernelVSpace_C :: "machine_word \<Rightarrow> arm_vspace_region_use"

locale kernel = kernel_all_substitute + state_rel

context state_rel
begin

abbreviation armUSGlobalPD_Ptr :: "(pde_C[2048]) ptr" where
  "armUSGlobalPD_Ptr \<equiv> pd_Ptr (symbol_table ''armUSGlobalPD'')"

(* relates fixed adresses *)
definition
  "carch_globals s \<equiv>
    armUSGlobalPD s = ptr_val armUSGlobalPD_Ptr"

(* FIXME ARMHYP is this the right place? MOVE? *)
definition
  cur_vcpu_relation :: "(32 word \<times> bool) option \<Rightarrow> vcpu_C ptr \<Rightarrow> 32 word \<Rightarrow> bool"
where
  "cur_vcpu_relation akscurvcpu cvcpu cactive \<equiv>
    case akscurvcpu
      of Some acurvcpu \<Rightarrow> cvcpu = Ptr (fst acurvcpu) \<and> cvcpu \<noteq> NULL \<and> cactive = from_bool (snd acurvcpu)
       | None \<Rightarrow> cvcpu = NULL \<and> cactive = 0"

(* FIXME ARMHYP armUSGlobalPD points to page full of invalid PDEs, i.e. it's all zero *)
(* FIXME ARMHYP TODO armKSGICVCPUNumListRegs \<le> GIC_VCPU_MAX_NUM_LR (64): missing invariant upstream?  *)
definition
  carch_state_relation :: "Arch.kernel_state \<Rightarrow> globals \<Rightarrow> bool"
where
  "carch_state_relation astate cstate \<equiv>
  armKSNextASID_' cstate = armKSNextASID astate \<and>
  armKSKernelVSpace astate = armKSKernelVSpace_C \<and>
  array_relation ((=) \<circ> option_to_0) 0xFF (armKSHWASIDTable astate) (armKSHWASIDTable_' cstate) \<and>
  array_relation ((=) \<circ> option_to_ptr) (2^asid_high_bits - 1) (armKSASIDTable astate) (armKSASIDTable_' cstate) \<and>
  (asid_map_pd_to_hwasids (armKSASIDMap astate))
       = set_option \<circ> (pde_stored_asid  \<circ>\<^sub>m clift (t_hrs_' cstate) \<circ>\<^sub>m pd_pointer_to_asid_slot) \<and>
  carch_globals astate \<and>
  gic_vcpu_num_list_regs_' cstate = of_nat (armKSGICVCPUNumListRegs astate) \<and>
  cur_vcpu_relation (armHSCurVCPU astate) (armHSCurVCPU_' cstate) (armHSVCPUActive_' cstate)"

end

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

definition
  cmachine_state_relation :: "machine_state \<Rightarrow> globals \<Rightarrow> bool"
where
  "cmachine_state_relation s s' \<equiv>
  irq_masks s = irq_masks (phantom_machine_state_' s') \<and>
  irq_state s = irq_state (phantom_machine_state_' s') \<and>
  device_state s = device_state (phantom_machine_state_' s') \<and>
  exclusive_state s = exclusive_state (phantom_machine_state_' s') \<and>
  machine_state_rest s = machine_state_rest (phantom_machine_state_' s')"

definition
  "globals_list_id_fudge = id"

type_synonym ('a, 'b) ltyp_heap = "'a ptr \<rightharpoonup> 'b"

abbreviation
  map_to_tcbs :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> word32 \<rightharpoonup> tcb"
  where
  "map_to_tcbs hp \<equiv> projectKO_opt \<circ>\<^sub>m hp"

abbreviation
  map_to_eps :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> word32 \<rightharpoonup> endpoint"
  where
  "map_to_eps hp \<equiv> projectKO_opt \<circ>\<^sub>m hp"

abbreviation
  map_to_ntfns :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> word32 \<rightharpoonup> notification"
  where
  "map_to_ntfns hp \<equiv> projectKO_opt \<circ>\<^sub>m hp"

abbreviation
  map_to_pdes :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> word32 \<rightharpoonup> pde"
  where
  "map_to_pdes hp \<equiv> projectKO_opt \<circ>\<^sub>m hp"

abbreviation
  map_to_ptes :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> word32 \<rightharpoonup> pte"
  where
  "map_to_ptes hp \<equiv> projectKO_opt \<circ>\<^sub>m hp"

abbreviation
  map_to_asidpools :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> word32 \<rightharpoonup> asidpool"
  where
  "map_to_asidpools hp \<equiv> projectKO_opt \<circ>\<^sub>m hp"

abbreviation
  map_to_user_data :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> word32 \<rightharpoonup> user_data"
  where
  "map_to_user_data hp \<equiv> projectKO_opt \<circ>\<^sub>m hp"

abbreviation
  map_to_vcpus :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> word32 \<rightharpoonup> vcpu"
  where
  "map_to_vcpus hp \<equiv> projectKO_opt \<circ>\<^sub>m hp"

abbreviation
  map_to_user_data_device :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> word32 \<rightharpoonup> user_data_device"
  where
  "map_to_user_data_device hp \<equiv> projectKO_opt \<circ>\<^sub>m hp"

definition
  cmdbnode_relation :: "Structures_H.mdbnode \<Rightarrow> mdb_node_C \<Rightarrow> bool"
where
  "cmdbnode_relation amdb cmdb \<equiv> amdb = mdb_node_to_H (mdb_node_lift cmdb)"

definition
  ccte_relation :: "Structures_H.cte \<Rightarrow> cte_C \<Rightarrow> bool"
where
  "ccte_relation acte ccte \<equiv> Some acte = option_map cte_to_H (cte_lift ccte)
                             \<and> c_valid_cte ccte"

lemma ccte_relation_c_valid_cte: "ccte_relation  c c' \<Longrightarrow> c_valid_cte c'"
  by (simp add: ccte_relation_def)

definition
  tcb_queue_relation' :: "(tcb_C \<Rightarrow> tcb_C ptr) \<Rightarrow> (tcb_C \<Rightarrow> tcb_C ptr) \<Rightarrow> (tcb_C ptr \<Rightarrow> tcb_C option) \<Rightarrow> word32 list \<Rightarrow> tcb_C ptr \<Rightarrow> tcb_C ptr \<Rightarrow> bool"
  where
  "tcb_queue_relation' getNext getPrev hp queue qhead end \<equiv>
  (end = (if queue = [] then NULL else (tcb_ptr_to_ctcb_ptr (last queue))))
  \<and> tcb_queue_relation getNext getPrev hp queue NULL qhead"

fun
  register_from_H :: "register \<Rightarrow> word32"
  where
    "register_from_H ARM_HYP.R0 = scast Kernel_C.R0"
  | "register_from_H ARM_HYP.R1 = scast Kernel_C.R1"
  | "register_from_H ARM_HYP.R2 = scast Kernel_C.R2"
  | "register_from_H ARM_HYP.R3 = scast Kernel_C.R3"
  | "register_from_H ARM_HYP.R4 = scast Kernel_C.R4"
  | "register_from_H ARM_HYP.R5 = scast Kernel_C.R5"
  | "register_from_H ARM_HYP.R6 = scast Kernel_C.R6"
  | "register_from_H ARM_HYP.R7 = scast Kernel_C.R7"
  | "register_from_H ARM_HYP.R8 = scast Kernel_C.R8"
  | "register_from_H ARM_HYP.R9 = scast Kernel_C.R9"
  | "register_from_H ARM_HYP.SL = scast Kernel_C.R10"
  | "register_from_H ARM_HYP.FP = scast Kernel_C.R11"
  | "register_from_H ARM_HYP.IP = scast Kernel_C.R12"
  | "register_from_H ARM_HYP.SP = scast Kernel_C.SP"
  | "register_from_H ARM_HYP.LR = scast Kernel_C.LR"
  | "register_from_H ARM_HYP.NextIP = scast Kernel_C.NextIP"
  | "register_from_H ARM_HYP.CPSR = scast Kernel_C.CPSR"
  | "register_from_H ARM_HYP.TPIDRURW = scast Kernel_C.TPIDRURW"
  | "register_from_H ARM_HYP.TPIDRURO = scast Kernel_C.TPIDRURO"
  | "register_from_H ARM_HYP.FaultIP = scast Kernel_C.FaultIP"

definition
  ccontext_relation :: "(MachineTypes.register \<Rightarrow> word32) \<Rightarrow> user_context_C \<Rightarrow> bool"
where
  "ccontext_relation regs uc \<equiv>  \<forall>r. regs r = index (registers_C uc) (unat (register_from_H r))"

primrec
  cthread_state_relation_lifted :: "Structures_H.thread_state \<Rightarrow>
   (thread_state_CL \<times> seL4_Fault_CL option) \<Rightarrow> bool"
where
  "cthread_state_relation_lifted (Structures_H.Running) ts'
     = (tsType_CL (fst ts') = scast ThreadState_Running)"
| "cthread_state_relation_lifted (Structures_H.Restart) ts'
     = (tsType_CL (fst ts') = scast ThreadState_Restart)"
| "cthread_state_relation_lifted (Structures_H.Inactive) ts'
     = (tsType_CL (fst ts') = scast ThreadState_Inactive)"
| "cthread_state_relation_lifted (Structures_H.IdleThreadState) ts'
     = (tsType_CL (fst ts') = scast ThreadState_IdleThreadState)"
| "cthread_state_relation_lifted (Structures_H.BlockedOnReply) ts'
     = (tsType_CL (fst ts') = scast ThreadState_BlockedOnReply)"
| "cthread_state_relation_lifted (Structures_H.BlockedOnReceive oref cg) ts'
     = (tsType_CL (fst ts') = scast ThreadState_BlockedOnReceive
        \<and> oref = blockingObject_CL (fst ts')
        \<and> cg = to_bool (blockingIPCCanGrant_CL (fst ts')))"
| "cthread_state_relation_lifted (Structures_H.BlockedOnSend oref badge cg cgr isc) ts'
     = (tsType_CL (fst ts') = scast ThreadState_BlockedOnSend
        \<and> oref = blockingObject_CL (fst ts')
        \<and> badge = blockingIPCBadge_CL (fst ts')
        \<and> cg    = to_bool (blockingIPCCanGrant_CL (fst ts'))
        \<and> cgr   = to_bool (blockingIPCCanGrantReply_CL (fst ts'))
        \<and> isc   = to_bool (blockingIPCIsCall_CL (fst ts')))"
| "cthread_state_relation_lifted (Structures_H.BlockedOnNotification oref) ts'
     = (tsType_CL (fst ts') = scast ThreadState_BlockedOnNotification
        \<and> oref = blockingObject_CL (fst ts'))"

definition
  cthread_state_relation :: "Structures_H.thread_state \<Rightarrow>
  (thread_state_C \<times> seL4_Fault_C) \<Rightarrow> bool"
where
  "cthread_state_relation \<equiv> \<lambda>a (cs, cf).
  cthread_state_relation_lifted a (thread_state_lift cs, seL4_Fault_lift cf)"

definition "is_cap_fault cf \<equiv>
  (case cf of (SeL4_Fault_CapFault _) \<Rightarrow> True
  | _ \<Rightarrow> False)"

lemma is_cap_fault_simp: "is_cap_fault cf = (\<exists> x. cf=SeL4_Fault_CapFault x)"
  by (simp add: is_cap_fault_def split:seL4_Fault_CL.splits)

definition
  message_info_to_H :: "seL4_MessageInfo_C \<Rightarrow> Types_H.message_info"
  where
  "message_info_to_H mi \<equiv> Types_H.message_info.MI (length_CL (seL4_MessageInfo_lift mi))
                                                  (extraCaps_CL (seL4_MessageInfo_lift mi))
                                                  (capsUnwrapped_CL (seL4_MessageInfo_lift mi))
                                                  (label_CL (seL4_MessageInfo_lift mi))"

fun
  lookup_fault_to_H :: "lookup_fault_CL \<Rightarrow> lookup_failure"
  where
  "lookup_fault_to_H Lookup_fault_invalid_root = InvalidRoot"
  | "lookup_fault_to_H (Lookup_fault_guard_mismatch lf) =
                      (GuardMismatch (unat (bitsLeft_CL lf)) (guardFound_CL lf) (unat (bitsFound_CL lf)))"
  | "lookup_fault_to_H (Lookup_fault_depth_mismatch lf) =
                      (DepthMismatch (unat (lookup_fault_depth_mismatch_CL.bitsLeft_CL lf))
                                     (unat (lookup_fault_depth_mismatch_CL.bitsFound_CL lf)))"
  | "lookup_fault_to_H (Lookup_fault_missing_capability lf) =
                        (MissingCapability (unat (lookup_fault_missing_capability_CL.bitsLeft_CL lf)))"

fun
  fault_to_H :: "seL4_Fault_CL \<Rightarrow> lookup_fault_CL \<Rightarrow> fault option"
where
  "fault_to_H SeL4_Fault_NullFault lf = None"
  | "fault_to_H (SeL4_Fault_CapFault cf) lf
           = Some (CapFault (seL4_Fault_CapFault_CL.address_CL cf) (to_bool (inReceivePhase_CL cf)) (lookup_fault_to_H lf))"
  | "fault_to_H (SeL4_Fault_VMFault vf) lf
           = Some (ArchFault (VMFault (seL4_Fault_VMFault_CL.address_CL vf) [instructionFault_CL vf, FSR_CL vf]))"
  | "fault_to_H (SeL4_Fault_UnknownSyscall us) lf
           = Some (UnknownSyscallException (syscallNumber_CL us))"
  | "fault_to_H (SeL4_Fault_UserException ue) lf
          = Some (UserException (number_CL ue) (code_CL ue))"
  | "fault_to_H (SeL4_Fault_VCPUFault vf) lf
          = Some (ArchFault (VCPUFault (seL4_Fault_VCPUFault_CL.hsr_CL vf)))"
  | "fault_to_H (SeL4_Fault_VGICMaintenance vf) lf
          = Some (ArchFault (VGICMaintenance (if seL4_Fault_VGICMaintenance_CL.idxValid_CL vf = 1
                                              then Some (seL4_Fault_VGICMaintenance_CL.idx_CL vf)
                                              else None)))"
  | "fault_to_H (SeL4_Fault_VPPIEvent irq) lf
          = Some (ArchFault (VPPIEvent (ucast (seL4_Fault_VPPIEvent_CL.irq_w_CL irq))))"

definition
  cfault_rel :: "Fault_H.fault option \<Rightarrow> seL4_Fault_CL option \<Rightarrow> lookup_fault_CL option \<Rightarrow> bool"
where
  "cfault_rel af cf lf \<equiv> \<exists>cf'. cf = Some cf' \<and>
         (if (is_cap_fault cf') then (\<exists>lf'. lf = Some lf' \<and> fault_to_H cf' lf' = af)
           else (fault_to_H cf' undefined = af))"

definition
  carch_tcb_relation :: "Structures_H.arch_tcb \<Rightarrow> arch_tcb_C \<Rightarrow> bool"
where
  "carch_tcb_relation aarch_tcb carch_tcb \<equiv>
      ccontext_relation (atcbContextGet aarch_tcb) (tcbContext_C carch_tcb)
    \<and> option_to_ptr (atcbVCPUPtr aarch_tcb) = tcbVCPU_C carch_tcb"

definition
  ctcb_relation :: "Structures_H.tcb \<Rightarrow> tcb_C \<Rightarrow> bool"
where
  "ctcb_relation atcb ctcb \<equiv>
       tcbFaultHandler atcb = tcbFaultHandler_C ctcb
     \<and> cthread_state_relation (tcbState atcb) (tcbState_C ctcb, tcbFault_C ctcb)
     \<and> tcbIPCBuffer atcb    = tcbIPCBuffer_C ctcb
     \<and> carch_tcb_relation (tcbArch atcb) (tcbArch_C ctcb)
     \<and> tcbQueued atcb       = to_bool (tcbQueued_CL (thread_state_lift (tcbState_C ctcb)))
     \<and> ucast (tcbDomain atcb) = tcbDomain_C ctcb
     \<and> ucast (tcbPriority atcb) = tcbPriority_C ctcb
     \<and> ucast (tcbMCP atcb) = tcbMCP_C ctcb
     \<and> tcbTimeSlice atcb    = unat (tcbTimeSlice_C ctcb)
     \<and> cfault_rel (tcbFault atcb) (seL4_Fault_lift (tcbFault_C ctcb))
                  (lookup_fault_lift (tcbLookupFailure_C ctcb))
     \<and> option_to_ptr (tcbBoundNotification atcb) = tcbBoundNotification_C ctcb"

abbreviation
  "ep_queue_relation' \<equiv> tcb_queue_relation' tcbEPNext_C tcbEPPrev_C"

definition
  cendpoint_relation :: "tcb_C typ_heap \<Rightarrow> Structures_H.endpoint \<Rightarrow> endpoint_C \<Rightarrow> bool"
where
  "cendpoint_relation h ntfn cep \<equiv>
     let cstate = endpoint_CL.state_CL (endpoint_lift cep);
         chead  = (Ptr o epQueue_head_CL o endpoint_lift) cep;
         cend   = (Ptr o epQueue_tail_CL o endpoint_lift) cep in
       case ntfn of
         IdleEP \<Rightarrow> cstate = scast EPState_Idle \<and> ep_queue_relation' h [] chead cend
       | SendEP q \<Rightarrow> cstate = scast EPState_Send \<and> ep_queue_relation' h q chead cend
       | RecvEP q \<Rightarrow> cstate = scast EPState_Recv \<and> ep_queue_relation' h q chead cend"

definition
  cnotification_relation :: "tcb_C typ_heap \<Rightarrow> Structures_H.notification \<Rightarrow>
                              notification_C \<Rightarrow> bool"
where
  "cnotification_relation h antfn cntfn \<equiv>
     let cntfn'  = notification_lift cntfn;
         cstate = notification_CL.state_CL cntfn';
         chead  = (Ptr o ntfnQueue_head_CL) cntfn';
         cend   = (Ptr o ntfnQueue_tail_CL) cntfn';
         cbound = ((Ptr o ntfnBoundTCB_CL) cntfn' :: tcb_C ptr)
     in
       (case ntfnObj antfn of
         IdleNtfn \<Rightarrow> cstate = scast NtfnState_Idle \<and> ep_queue_relation' h [] chead cend
       | WaitingNtfn q \<Rightarrow> cstate = scast NtfnState_Waiting \<and> ep_queue_relation' h q chead cend
       | ActiveNtfn msgid \<Rightarrow> cstate = scast NtfnState_Active \<and>
                           msgid = ntfnMsgIdentifier_CL cntfn' \<and>
                           ep_queue_relation' h [] chead cend)
       \<and> option_to_ctcb_ptr (ntfnBoundTCB antfn) = cbound"

definition
  "hap_from_vm_rights R \<equiv> case R of
    VMNoAccess \<Rightarrow> 0
  | VMKernelOnly \<Rightarrow> 0
  | VMReadOnly \<Rightarrow> 1
  | VMReadWrite \<Rightarrow> 3"

definition
  "memattr_from_cacheable c \<equiv> case c of
    True \<Rightarrow> 0xf
  | False \<Rightarrow> 0"

definition
  cpde_relation :: "pde \<Rightarrow> pde_C \<Rightarrow> bool"
where
  "cpde_relation pde cpde \<equiv>
  (let cpde' = pde_lift cpde in
  case pde of
    InvalidPDE \<Rightarrow>
      (\<exists>inv. cpde' = Some (Pde_pde_invalid inv)) \<comment> \<open>seL4 uses invalid PDEs to stash other info\<close>
  | PageTablePDE table \<Rightarrow>
    cpde' = Some (Pde_pde_coarse
      \<lparr> pde_pde_coarse_CL.address_CL = table \<rparr>)
  | SectionPDE frame cacheable xn rights \<Rightarrow>
    cpde' = Some (Pde_pde_section
     \<lparr> pde_pde_section_CL.XN_CL = of_bool xn,
       contiguous_hint_CL = 0,
       pde_pde_section_CL.address_CL = frame,
       AF_CL = 1,
       SH_CL = 0,
       HAP_CL = hap_from_vm_rights rights,
       MemAttr_CL = memattr_from_cacheable cacheable \<rparr>)
  | SuperSectionPDE frame cacheable xn rights \<Rightarrow>
    cpde' = Some (Pde_pde_section
     \<lparr> pde_pde_section_CL.XN_CL = of_bool xn,
       contiguous_hint_CL = 1,
       pde_pde_section_CL.address_CL = frame,
       AF_CL = 1,
       SH_CL = 0,
       HAP_CL = hap_from_vm_rights rights,
       MemAttr_CL = memattr_from_cacheable cacheable \<rparr>)
  )"

definition
  cpte_relation :: "pte \<Rightarrow> pte_C \<Rightarrow> bool"
where
  "cpte_relation pte cpte \<equiv>
  (let cpte' = pte_lift cpte in
  case pte of
    InvalidPTE \<Rightarrow>
      (cpte' = Some (Pte_pte_invalid))
  | SmallPagePTE frame cacheable xn rights \<Rightarrow>
    cpte' = Some (Pte_pte_small
     \<lparr> pte_pte_small_CL.XN_CL = of_bool xn,
       contiguous_hint_CL = 0,
       pte_pte_small_CL.address_CL = frame,
       AF_CL = 1,
       SH_CL = 0,
       HAP_CL = hap_from_vm_rights rights,
       MemAttr_CL = memattr_from_cacheable cacheable \<rparr>)
  | LargePagePTE frame cacheable xn rights \<Rightarrow>
    cpte' = Some (Pte_pte_small
     \<lparr> pte_pte_small_CL.XN_CL = of_bool xn,
       contiguous_hint_CL = 1,
       pte_pte_small_CL.address_CL = frame,
       AF_CL = 1,
       SH_CL = 0,
       HAP_CL = hap_from_vm_rights rights,
       MemAttr_CL = memattr_from_cacheable cacheable \<rparr>)
  )"

(* Invalid PTEs map to invalid PTEs (sanity check?) *)
lemma pte_0:
  "index (pte_C.words_C cpte) 0 = 0 \<and> index (pte_C.words_C cpte) 1 = 0 \<Longrightarrow>
   pte_lift cpte = Some (Pte_pte_invalid)"
  by (simp add: pte_lift_def pte_get_tag_def pte_pte_invalid_def)

definition
  casid_pool_relation :: "asidpool \<Rightarrow> asid_pool_C \<Rightarrow> bool"
where
  "casid_pool_relation asid_pool casid_pool \<equiv>
  case asid_pool of ASIDPool pool \<Rightarrow>
  case casid_pool of asid_pool_C.asid_pool_C cpool \<Rightarrow>
  array_relation ((=) \<circ> option_to_ptr) (2^asid_low_bits - 1) pool cpool"

definition
  cvcpu_regs_relation :: "vcpu \<Rightarrow> vcpu_C \<Rightarrow> bool"
where
  "cvcpu_regs_relation vcpu cvcpu \<equiv>
    \<forall>r. regs_C cvcpu.[fromEnum r] = vcpuRegs vcpu r"

definition cvcpu_vppi_masked_relation :: "vcpu \<Rightarrow> vcpu_C \<Rightarrow> bool" where
  "cvcpu_vppi_masked_relation vcpu cvcpu \<equiv>
     \<forall>vppi. (vppi_masked_C cvcpu).[fromEnum vppi]
            = from_bool (vcpuVPPIMasked vcpu vppi)"

definition
  virq_to_H :: "virq_C \<Rightarrow> virq"
where
  "virq_to_H virq = (virq_C.words_C virq).[0]"

definition
  cvgic_relation :: "gicvcpuinterface \<Rightarrow> gicVCpuIface_C \<Rightarrow> bool"
where
  "cvgic_relation vgic cvgic \<equiv>
       gicVCpuIface_C.hcr_C cvgic = vgicHCR vgic
     \<and> gicVCpuIface_C.vmcr_C cvgic = vgicVMCR vgic
     \<and> gicVCpuIface_C.apr_C cvgic = vgicAPR vgic
     \<and> (\<forall>i\<le>63. vgicLR vgic i = virq_to_H ((gicVCpuIface_C.lr_C cvgic).[i]))
     \<and> (\<forall>i\<ge>64. vgicLR vgic i = 0)"
(* FIXME ARM_HYP: if we know the range is 64, we should change the index type from nat to 6 word *)

definition
  cvcpu_relation :: "vcpu \<Rightarrow> vcpu_C \<Rightarrow> bool"
where
  "cvcpu_relation vcpu cvcpu \<equiv>
     vcpuTCB_C cvcpu = option_to_ctcb_ptr (vcpuTCBPtr vcpu)
     \<and> cvcpu_regs_relation vcpu cvcpu
     \<and> cvgic_relation (vcpuVGIC vcpu) (vgic_C cvcpu)
     \<and> cvcpu_vppi_masked_relation vcpu cvcpu
     \<and> last_pcount_C (virtTimer_C cvcpu) = vtimerLastPCount (vcpuVTimer vcpu)"

definition
  cuser_user_data_relation :: "(10 word \<Rightarrow> word32) \<Rightarrow> user_data_C \<Rightarrow> bool"
where
  "cuser_user_data_relation f ud \<equiv> \<forall>off. f off = index (user_data_C.words_C ud) (unat off)"

definition
  cuser_user_data_device_relation :: "(10 word \<Rightarrow> word32) \<Rightarrow> user_data_device_C \<Rightarrow> bool"
where
  "cuser_user_data_device_relation f ud \<equiv> True"

abbreviation
  "cpspace_cte_relation ah ch \<equiv> cmap_relation (map_to_ctes ah) (clift ch) Ptr ccte_relation"

abbreviation
  "cpspace_tcb_relation ah ch \<equiv> cmap_relation (map_to_tcbs ah) (clift ch) tcb_ptr_to_ctcb_ptr ctcb_relation"

abbreviation
  "cpspace_ep_relation ah ch \<equiv> cmap_relation (map_to_eps ah) (clift ch) Ptr (cendpoint_relation (clift ch))"

abbreviation
  "cpspace_ntfn_relation ah ch \<equiv> cmap_relation (map_to_ntfns ah) (clift ch) Ptr (cnotification_relation (clift ch))"

abbreviation
  "cpspace_pde_relation ah ch \<equiv> cmap_relation (map_to_pdes ah) (clift ch) Ptr cpde_relation"

abbreviation
  "cpspace_pte_relation ah ch \<equiv> cmap_relation (map_to_ptes ah) (clift ch) Ptr cpte_relation"

abbreviation
  "cpspace_asidpool_relation ah ch \<equiv> cmap_relation (map_to_asidpools ah) (clift ch) Ptr casid_pool_relation"

abbreviation
  "cpspace_vcpu_relation ah ch \<equiv> cmap_relation (map_to_vcpus ah) (clift ch) Ptr cvcpu_relation"

abbreviation
  "cpspace_user_data_relation ah bh ch \<equiv> cmap_relation (heap_to_user_data ah bh) (clift ch) Ptr cuser_user_data_relation"

abbreviation
  "cpspace_device_data_relation ah bh ch \<equiv> cmap_relation (heap_to_device_data ah bh) (clift ch) Ptr cuser_user_data_device_relation"

abbreviation
  "cpspace_pde_array_relation ah ch \<equiv> carray_map_relation pdBits (map_to_pdes ah) (h_t_valid (hrs_htd ch) c_guard) pd_Ptr"

abbreviation
  "cpspace_pte_array_relation ah ch \<equiv> carray_map_relation ptBits (map_to_ptes ah) (h_t_valid (hrs_htd ch) c_guard) pt_Ptr"

definition
  cpspace_relation :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> (word32 \<Rightarrow> word8) \<Rightarrow> heap_raw_state \<Rightarrow> bool"
where
  "cpspace_relation ah bh ch \<equiv>
  cpspace_cte_relation ah ch \<and> cpspace_tcb_relation ah ch \<and> cpspace_ep_relation ah ch \<and> cpspace_ntfn_relation ah ch \<and>
  cpspace_pde_relation ah ch \<and> cpspace_pte_relation ah ch \<and> cpspace_asidpool_relation ah ch \<and>
  cpspace_user_data_relation ah bh ch \<and> cpspace_device_data_relation ah bh ch \<and>
  cpspace_pde_array_relation ah ch \<and> cpspace_pte_array_relation ah ch \<and>
  cpspace_vcpu_relation ah ch"

abbreviation
  "sched_queue_relation' \<equiv> tcb_queue_relation' tcbSchedNext_C tcbSchedPrev_C"

abbreviation
  end_C :: "tcb_queue_C \<Rightarrow> tcb_C ptr"
where
 "end_C == tcb_queue_C.end_C"

definition
  cready_queues_index_to_C :: "domain \<Rightarrow> priority \<Rightarrow> nat"
where
  "cready_queues_index_to_C qdom prio \<equiv> (unat qdom) * numPriorities + (unat prio)"

definition cready_queues_relation ::
  "tcb_C typ_heap \<Rightarrow> (tcb_queue_C[num_tcb_queues]) \<Rightarrow> (domain \<times> priority \<Rightarrow> ready_queue) \<Rightarrow> bool"
where
  "cready_queues_relation h_tcb queues aqueues \<equiv>
     \<forall>qdom prio. ((qdom \<ge> ucast minDom \<and> qdom \<le> ucast maxDom \<and>
                  prio \<ge> ucast minPrio \<and> prio \<le> ucast maxPrio) \<longrightarrow>
       (let cqueue = index queues (cready_queues_index_to_C qdom prio) in
            sched_queue_relation' h_tcb (aqueues (qdom, prio)) (head_C cqueue) (end_C cqueue)))
        \<and> (\<not> (qdom \<ge> ucast minDom \<and> qdom \<le> ucast maxDom \<and>
                  prio \<ge> ucast minPrio \<and> prio \<le> ucast maxPrio) \<longrightarrow> aqueues (qdom, prio) = [])"

abbreviation
  "cte_array_relation astate cstate
    \<equiv> cvariable_array_map_relation (gsCNodes astate) (\<lambda>n. 2 ^ n)
        cte_Ptr (hrs_htd (t_hrs_' cstate))"

abbreviation
  "tcb_cte_array_relation astate cstate
    \<equiv> cvariable_array_map_relation (map_to_tcbs (ksPSpace astate))
        (\<lambda>x. 5) cte_Ptr (hrs_htd (t_hrs_' cstate))"

fun
  irqstate_to_C :: "irqstate \<Rightarrow> word32"
  where
  "irqstate_to_C IRQInactive = scast Kernel_C.IRQInactive"
  | "irqstate_to_C IRQSignal = scast Kernel_C.IRQSignal"
  | "irqstate_to_C IRQTimer = scast Kernel_C.IRQTimer"
  | "irqstate_to_C irqstate.IRQReserved = scast Kernel_C.IRQReserved"

definition
  cinterrupt_relation :: "interrupt_state \<Rightarrow> 'a ptr \<Rightarrow> (word32[192]) \<Rightarrow> bool"
where
  "cinterrupt_relation airqs cnode cirqs \<equiv>
     cnode = Ptr (intStateIRQNode airqs) \<and>
     (\<forall>irq \<le> (ucast Kernel_C.maxIRQ).
       irqstate_to_C (intStateIRQTable airqs irq) = index cirqs (unat irq))"

definition
  cscheduler_action_relation :: "Structures_H.scheduler_action \<Rightarrow> tcb_C ptr \<Rightarrow> bool"
where
  "cscheduler_action_relation a p \<equiv> case a of
     ResumeCurrentThread \<Rightarrow> p = NULL
   | ChooseNewThread \<Rightarrow> p = Ptr 1
   | SwitchToThread p' \<Rightarrow> p = tcb_ptr_to_ctcb_ptr p'"

definition
  dom_schedule_entry_relation :: "8 word \<times> 32 word \<Rightarrow> dschedule_C \<Rightarrow> bool"
where
  "dom_schedule_entry_relation adomSched cdomSched \<equiv>
     ucast (fst adomSched) = dschedule_C.domain_C cdomSched \<and>
     (snd adomSched) = dschedule_C.length_C cdomSched"

definition
  cdom_schedule_relation :: "(8 word \<times> 32 word) list \<Rightarrow> (dschedule_C['b :: finite]) \<Rightarrow> bool"
where
  "cdom_schedule_relation adomSched cdomSched \<equiv>
     length adomSched = card (UNIV :: 'b set) \<and>
     (\<forall>n \<le> length adomSched. dom_schedule_entry_relation (adomSched ! n) (index cdomSched n))"

definition
  ghost_size_rel :: "cghost_state \<Rightarrow> nat \<Rightarrow> bool"
where
  "ghost_size_rel gs maxSize = ((gs_get_assn cap_get_capSizeBits_'proc gs = 0
            \<and> maxSize = card (UNIV :: word32 set))
    \<or> (maxSize > 0 \<and> maxSize = unat (gs_get_assn cap_get_capSizeBits_'proc gs)))"

definition
  cbitmap_L1_relation :: "machine_word['dom::finite] \<Rightarrow> (domain \<Rightarrow> machine_word) \<Rightarrow> bool"
where
  "cbitmap_L1_relation cbitmap1 abitmap1 \<equiv>
    \<forall>d. (d \<le> maxDomain \<longrightarrow> cbitmap1.[unat d] = abitmap1 d) \<and>
        (\<not> d \<le> maxDomain \<longrightarrow> abitmap1 d = 0)"

definition
  cbitmap_L2_relation :: "machine_word['i::finite]['dom::finite]
                          \<Rightarrow> ((domain \<times> nat) \<Rightarrow> machine_word) \<Rightarrow> bool"
where
  "cbitmap_L2_relation cbitmap2 abitmap2 \<equiv>
    \<forall>d i. ((d \<le> maxDomain \<and> i < l2BitmapSize)
            \<longrightarrow> cbitmap2.[unat d].[i] = abitmap2 (d, i)) \<and>
           ((\<not> (d \<le> maxDomain \<and> i < l2BitmapSize))
            \<longrightarrow>  abitmap2 (d, i) = 0)"

end (* interpretation Arch . (*FIXME: arch_split*) *)

definition
   region_is_bytes' :: "word32 \<Rightarrow> nat \<Rightarrow> heap_typ_desc \<Rightarrow> bool"
where
  "region_is_bytes' ptr sz htd \<equiv> \<forall>z\<in>{ptr ..+ sz}. \<forall> td. td \<noteq> typ_uinfo_t TYPE (word8) \<longrightarrow>
    (\<forall>n b. snd (htd z) n \<noteq> Some (td, b))"

abbreviation
  region_is_bytes :: "word32 \<Rightarrow> nat \<Rightarrow> globals myvars \<Rightarrow> bool"
where
  "region_is_bytes ptr sz s \<equiv> region_is_bytes' ptr sz (hrs_htd (t_hrs_' (globals s)))"

abbreviation(input)
  "heap_list_is_zero hp ptr n \<equiv> heap_list hp n ptr = replicate n 0"

abbreviation
  "region_is_zero_bytes ptr n x \<equiv> region_is_bytes ptr n x
      \<and> heap_list_is_zero (hrs_mem (t_hrs_' (globals x))) ptr n"

definition
  region_actually_is_bytes' :: "addr \<Rightarrow> nat \<Rightarrow> heap_typ_desc \<Rightarrow> bool"
where
  "region_actually_is_bytes' ptr len htd
    = (\<forall>x \<in> {ptr ..+ len}. htd x
        = (True, [0 \<mapsto> (typ_uinfo_t TYPE(8 word), True)]))"

abbreviation
  "region_actually_is_bytes ptr len s
    \<equiv> region_actually_is_bytes' ptr len (hrs_htd (t_hrs_' (globals s)))"

lemmas region_actually_is_bytes_def = region_actually_is_bytes'_def

abbreviation
  "region_actually_is_zero_bytes ptr len s
    \<equiv> region_actually_is_bytes ptr len s
        \<and> heap_list_is_zero (hrs_mem (t_hrs_' (globals s))) ptr len"

definition
  zero_ranges_are_zero
where
  "zero_ranges_are_zero rs hrs
    = (\<forall>(start, end) \<in> rs. region_actually_is_bytes' start (unat ((end + 1) - start)) (hrs_htd hrs)
        \<and> heap_list_is_zero (hrs_mem hrs) start (unat ((end + 1) - start)))"

context state_rel begin

\<comment> \<open>The IRQ node is a global array of CTEs.\<close>
abbreviation intStateIRQNode_array_Ptr :: "(cte_C[256]) ptr" where
  "intStateIRQNode_array_Ptr \<equiv> Ptr (symbol_table ''intStateIRQNode'')"

\<comment> \<open>But for compatibility with older proofs (written when the IRQ Node was a global pointer
    initialised during boot), it is sometimes convenient to treat the IRQ node pointer as
    a pointer to a CTE.\<close>
abbreviation intStateIRQNode_Ptr :: "cte_C ptr" where
  "intStateIRQNode_Ptr \<equiv> Ptr (symbol_table ''intStateIRQNode'')"

definition
  cstate_relation :: "KernelStateData_H.kernel_state \<Rightarrow> globals \<Rightarrow> bool"
where
  cstate_relation_def:
  "cstate_relation astate cstate \<equiv>
     let cheap = t_hrs_' cstate in
       cpspace_relation (ksPSpace astate) (underlying_memory (ksMachineState astate)) cheap \<and>
       cready_queues_relation (clift cheap)
                             (ksReadyQueues_' cstate)
                             (ksReadyQueues astate) \<and>
       zero_ranges_are_zero (gsUntypedZeroRanges astate) cheap \<and>
       cbitmap_L1_relation (ksReadyQueuesL1Bitmap_' cstate) (ksReadyQueuesL1Bitmap astate) \<and>
       cbitmap_L2_relation (ksReadyQueuesL2Bitmap_' cstate) (ksReadyQueuesL2Bitmap astate) \<and>
       ksCurThread_' cstate = (tcb_ptr_to_ctcb_ptr (ksCurThread astate)) \<and>
       ksIdleThread_' cstate = (tcb_ptr_to_ctcb_ptr (ksIdleThread astate)) \<and>
       cinterrupt_relation (ksInterruptState astate) intStateIRQNode_array_Ptr (intStateIRQTable_' cstate) \<and>
       cscheduler_action_relation (ksSchedulerAction astate)
                                 (ksSchedulerAction_' cstate) \<and>
       carch_state_relation (ksArchState astate) cstate \<and>
       cmachine_state_relation (ksMachineState astate) cstate \<and>
       cte_array_relation astate cstate \<and>
       tcb_cte_array_relation astate cstate \<and>
       apsnd fst (ghost'state_' cstate) = (gsUserPages astate, gsCNodes astate) \<and>
       ghost_size_rel (ghost'state_' cstate) (gsMaxObjectSize astate) \<and>
       ksWorkUnitsCompleted_' cstate = ksWorkUnitsCompleted astate \<and>
       h_t_valid (hrs_htd (t_hrs_' cstate)) c_guard intStateIRQNode_array_Ptr \<and>
       ptr_span intStateIRQNode_array_Ptr \<subseteq> kernel_data_refs \<and>
       h_t_valid (hrs_htd (t_hrs_' cstate)) c_guard armUSGlobalPD_Ptr \<and>
       ptr_span armUSGlobalPD_Ptr \<subseteq> kernel_data_refs \<and>
       htd_safe domain (hrs_htd (t_hrs_' cstate)) \<and>
       -domain \<subseteq> kernel_data_refs \<and>
       globals_list_distinct (- kernel_data_refs) symbol_table globals_list \<and>
       cdom_schedule_relation (ksDomSchedule astate)
                              Kernel_C.kernel_all_global_addresses.ksDomSchedule \<and>
       ksDomScheduleIdx_' cstate = of_nat (ksDomScheduleIdx astate) \<and>
       ksCurDomain_' cstate = ucast (ksCurDomain astate) \<and>
       ksDomainTime_' cstate = ksDomainTime astate"

end

definition
  ccap_relation :: "capability \<Rightarrow> cap_C \<Rightarrow> bool"
where
  "ccap_relation acap ccap \<equiv> (Some acap = option_map cap_to_H (cap_lift ccap))
                             \<and> (c_valid_cap ccap)"

lemma ccap_relation_c_valid_cap: "ccap_relation  c c' \<Longrightarrow> c_valid_cap c'"
  by (simp add: ccap_relation_def)

context begin interpretation Arch .
fun
  arch_fault_to_fault_tag :: "arch_fault \<Rightarrow> word32"
  where
  "arch_fault_to_fault_tag (VMFault a b) = scast seL4_Fault_VMFault"
| "arch_fault_to_fault_tag (VCPUFault a) = scast seL4_Fault_VCPUFault"
| "arch_fault_to_fault_tag (VGICMaintenance a) = scast seL4_Fault_VGICMaintenance"
| "arch_fault_to_fault_tag (VPPIEvent a) = scast seL4_Fault_VPPIEvent"
end

fun
  fault_to_fault_tag :: "fault \<Rightarrow> word32"
where
  "  fault_to_fault_tag (CapFault a b c) = scast seL4_Fault_CapFault"
  | "fault_to_fault_tag (ArchFault f)    = arch_fault_to_fault_tag f"
  | "fault_to_fault_tag (UnknownSyscallException a) = scast seL4_Fault_UnknownSyscall"
  | "fault_to_fault_tag (UserException a b) = scast seL4_Fault_UserException"

lemmas seL4_Faults = seL4_Fault_UserException_def
                     seL4_Fault_UnknownSyscall_def
                     seL4_Fault_CapFault_def

lemmas seL4_Arch_Faults = seL4_Fault_VMFault_def
                          seL4_Fault_VCPUFault_def
                          seL4_Fault_VGICMaintenance_def
                          seL4_Fault_VPPIEvent_def

(* Return relations *)

record errtype =
  errfault :: "seL4_Fault_CL option"
  errlookup_fault :: "lookup_fault_CL option"
  errsyscall :: syscall_error_C

primrec
  lookup_failure_rel :: "lookup_failure \<Rightarrow> word32 \<Rightarrow> errtype \<Rightarrow> bool"
where
  "lookup_failure_rel InvalidRoot fl es = (fl = scast EXCEPTION_LOOKUP_FAULT \<and> errlookup_fault es = Some Lookup_fault_invalid_root)"
| "lookup_failure_rel (GuardMismatch bl gf sz) fl es = (fl = scast EXCEPTION_LOOKUP_FAULT \<and>
    (\<exists>lf. errlookup_fault es = Some (Lookup_fault_guard_mismatch lf) \<and>
          guardFound_CL lf = gf \<and> unat (bitsLeft_CL lf) = bl \<and> unat (bitsFound_CL lf) = sz))"
| "lookup_failure_rel (DepthMismatch bl bf) fl es = (fl = scast EXCEPTION_LOOKUP_FAULT \<and>
    (\<exists>lf. errlookup_fault es = Some (Lookup_fault_depth_mismatch lf) \<and>
          unat (lookup_fault_depth_mismatch_CL.bitsLeft_CL lf) = bl
        \<and> unat (lookup_fault_depth_mismatch_CL.bitsFound_CL lf) = bf))"
| "lookup_failure_rel (MissingCapability bl) fl es = (fl = scast EXCEPTION_LOOKUP_FAULT \<and>
    (\<exists>lf. errlookup_fault es = Some (Lookup_fault_missing_capability lf) \<and>
          unat (lookup_fault_missing_capability_CL.bitsLeft_CL lf) = bl))"

definition
  syscall_error_to_H :: "syscall_error_C \<Rightarrow> lookup_fault_CL option \<Rightarrow> syscall_error option"
where
 "syscall_error_to_H se lf \<equiv>
    if type_C se = scast seL4_InvalidArgument
         then Some (InvalidArgument (unat (invalidArgumentNumber_C se)))
    else if type_C se = scast seL4_InvalidCapability
         then Some (InvalidCapability (unat (invalidCapNumber_C se)))
    else if type_C se = scast seL4_IllegalOperation then Some IllegalOperation
    else if type_C se = scast seL4_RangeError
         then Some (RangeError (rangeErrorMin_C se) (rangeErrorMax_C se))
    else if type_C se = scast seL4_AlignmentError then Some AlignmentError
    else if type_C se = scast seL4_FailedLookup
         then option_map (FailedLookup (to_bool (failedLookupWasSource_C se))
                           o lookup_fault_to_H) lf
    else if type_C se = scast seL4_TruncatedMessage then Some TruncatedMessage
    else if type_C se = scast seL4_DeleteFirst then Some DeleteFirst
    else if type_C se = scast seL4_RevokeFirst then Some RevokeFirst
    else if type_C se = scast seL4_NotEnoughMemory then Some (NotEnoughMemory (memoryLeft_C se))
    else None"

lemmas syscall_error_type_defs
    = seL4_AlignmentError_def seL4_DeleteFirst_def seL4_FailedLookup_def
      seL4_IllegalOperation_def seL4_InvalidArgument_def seL4_InvalidCapability_def
      seL4_NotEnoughMemory_def seL4_RangeError_def seL4_RevokeFirst_def
      seL4_TruncatedMessage_def

lemma
  syscall_error_to_H_cases:
 "type_C se = scast seL4_InvalidArgument
     \<Longrightarrow> syscall_error_to_H se lf = Some (InvalidArgument (unat (invalidArgumentNumber_C se)))"
 "type_C se = scast seL4_InvalidCapability
     \<Longrightarrow> syscall_error_to_H se lf =  Some (InvalidCapability (unat (invalidCapNumber_C se)))"
 "type_C se = scast seL4_IllegalOperation
     \<Longrightarrow> syscall_error_to_H se lf = Some IllegalOperation"
 "type_C se = scast seL4_RangeError
     \<Longrightarrow> syscall_error_to_H se lf = Some (RangeError (rangeErrorMin_C se) (rangeErrorMax_C se))"
 "type_C se = scast seL4_AlignmentError
     \<Longrightarrow> syscall_error_to_H se lf = Some AlignmentError"
 "type_C se = scast seL4_FailedLookup
     \<Longrightarrow> syscall_error_to_H se lf =  option_map (FailedLookup (to_bool (failedLookupWasSource_C se))
                           o lookup_fault_to_H) lf"
 "type_C se = scast seL4_TruncatedMessage
     \<Longrightarrow> syscall_error_to_H se lf = Some TruncatedMessage"
 "type_C se = scast seL4_DeleteFirst
     \<Longrightarrow> syscall_error_to_H se lf = Some DeleteFirst"
 "type_C se = scast seL4_RevokeFirst
     \<Longrightarrow> syscall_error_to_H se lf = Some RevokeFirst"
 "type_C se = scast seL4_NotEnoughMemory
     \<Longrightarrow> syscall_error_to_H se lf = Some (NotEnoughMemory (memoryLeft_C se))"
  by (simp add: syscall_error_to_H_def syscall_error_type_defs)+

definition
  syscall_error_rel :: "syscall_error \<Rightarrow> word32 \<Rightarrow> errtype \<Rightarrow> bool" where
 "syscall_error_rel se fl es \<equiv> fl = scast EXCEPTION_SYSCALL_ERROR
                                 \<and> syscall_error_to_H (errsyscall es) (errlookup_fault es)
                                       = Some se"

(* cap rights *)
definition
  "cap_rights_to_H rs \<equiv> CapRights (to_bool (capAllowWrite_CL rs))
                                  (to_bool (capAllowRead_CL rs))
                                  (to_bool (capAllowGrant_CL rs))
                                  (to_bool (capAllowGrantReply_CL rs))"

definition
  "ccap_rights_relation cr cr' \<equiv> cr = cap_rights_to_H (seL4_CapRights_lift cr')"

lemma (in kernel) syscall_error_to_H_cases_rev:
  "\<And>n. syscall_error_to_H e lf = Some (InvalidArgument n) \<Longrightarrow>
        type_C e = scast seL4_InvalidArgument"
  "\<And>n. syscall_error_to_H e lf = Some (InvalidCapability n) \<Longrightarrow>
        type_C e = scast seL4_InvalidCapability"
  "syscall_error_to_H e lf = Some IllegalOperation \<Longrightarrow>
        type_C e = scast seL4_IllegalOperation"
  "\<And>w1 w2. syscall_error_to_H e lf = Some (RangeError w1 w2) \<Longrightarrow>
        type_C e = scast seL4_RangeError"
  "syscall_error_to_H e lf = Some AlignmentError \<Longrightarrow>
        type_C e = scast seL4_AlignmentError"
  "\<And>b lf'. syscall_error_to_H e lf = Some (FailedLookup b lf') \<Longrightarrow>
        type_C e = scast seL4_FailedLookup"
  "syscall_error_to_H e lf = Some TruncatedMessage \<Longrightarrow>
        type_C e = scast seL4_TruncatedMessage"
  "syscall_error_to_H e lf = Some DeleteFirst \<Longrightarrow>
        type_C e = scast seL4_DeleteFirst"
  "syscall_error_to_H e lf = Some RevokeFirst \<Longrightarrow>
        type_C e = scast seL4_RevokeFirst"
  by (clarsimp simp: syscall_error_to_H_def syscall_error_type_defs
              split: if_split_asm)+

definition
  syscall_from_H :: "syscall \<Rightarrow> word32"
where
  "syscall_from_H c \<equiv> case c of
    SysSend \<Rightarrow> scast Kernel_C.SysSend
  | SysNBSend \<Rightarrow> scast Kernel_C.SysNBSend
  | SysCall \<Rightarrow> scast Kernel_C.SysCall
  | SysRecv \<Rightarrow> scast Kernel_C.SysRecv
  | SysReply \<Rightarrow> scast Kernel_C.SysReply
  | SysReplyRecv \<Rightarrow> scast Kernel_C.SysReplyRecv
  | SysNBRecv \<Rightarrow> scast Kernel_C.SysNBRecv
  | SysYield \<Rightarrow> scast Kernel_C.SysYield"

lemma (in kernel) cmap_relation_cs_atD:
  "\<lbrakk> cmap_relation as cs addr_fun rel; cs (addr_fun x) = Some y; inj addr_fun \<rbrakk> \<Longrightarrow>
  \<exists>ko. as x = Some ko \<and> rel ko y"
  apply (clarsimp simp: cmap_relation_def)
  apply (subgoal_tac "x \<in> dom as")
   apply (drule (1) bspec)
   apply (clarsimp simp: dom_def)
  apply (subgoal_tac "addr_fun x \<in> addr_fun ` dom as")
   prefer 2
   apply fastforce
  apply (erule imageE)
  apply (drule (1) injD)
  apply simp
  done

end


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

(*
 * The layout of the capability space and other parts of the system-initialiser.
 *)
theory RootTask_SI
imports WellFormed_SI
begin

(******************************************************************
 * Definition of the CSpace of the root task.                     *
 * This requires a default cap to all of the objects created,     *
 * and a copy of caps to all of the CNodes (for installing caps). *
 ******************************************************************)

consts
  si_cnode_id      :: cdl_object_id
  si_asidpool_id   :: cdl_object_id
  si_asidpool_base :: nat

definition
  si_cnode_size :: cdl_size_bits
where
  "si_cnode_size = 12"

(* If we axioimise this size, we need it to be smaller than the word size.
 * We need this to prove that:
   - word_bits - si_cnode_size + si_cnode_size = word_bits.
   - offset (of_nat slot) si_cnode_size = slot
 *)
lemma si_cnode_size_less_than_word_size [simp]:
  "si_cnode_size < word_bits"
  by (clarsimp simp: si_cnode_size_def word_bits_def)

lemma si_cnode_size_less_than_eq_word_size [simp]:
  "si_cnode_size \<le> word_bits"
  by (rule less_imp_le_nat, simp)

lemma si_cnode_size_greater_than_1 [simp]:
  "1 < si_cnode_size"
  by (clarsimp simp: si_cnode_size_def)

lemma si_cnode_size_greater_than_2 [simp]:
  "2 < si_cnode_size"
  by (clarsimp simp: si_cnode_size_def)

lemma unat_less_2_si_cnode_size:
  "unat (cptr::32 word) < 2 ^ si_cnode_size
  \<Longrightarrow> cptr < 2 ^ si_cnode_size"
  by (metis si_cnode_size_less_than_word_size unat_power_lower32 word_less_nat_alt)

lemma unat_less_2_si_cnode_size':
  "(cptr::32 word) < 2 ^ si_cnode_size
  \<Longrightarrow> unat cptr < 2 ^ si_cnode_size"
  by (metis unat_less_helper word_unat_power)

(* This is stored in the root TCB. *)
definition
  si_cspace_cap :: cdl_cap
where
  "si_cspace_cap = CNodeCap si_cnode_id 0 (word_bits - si_cnode_size) si_cnode_size"

(* This is the cap the root TCB has to its own root cnode (stored in its root CNode). *)
definition
  si_cnode_cap :: cdl_cap
where
  "si_cnode_cap = CNodeCap si_cnode_id 0 (word_bits - si_cnode_size) si_cnode_size"

definition
  root_tcb :: cdl_object
where
  "root_tcb = update_slots [tcb_cspace_slot \<mapsto> si_cspace_cap,
                            tcb_vspace_slot \<mapsto> undefined,
                            tcb_replycap_slot \<mapsto> undefined,
                            tcb_caller_slot \<mapsto> undefined,
                            tcb_ipcbuffer_slot \<mapsto> undefined,
                            tcb_pending_op_slot \<mapsto> undefined] (Tcb (default_tcb minBound))"

definition
  empty_asid :: cdl_asid_pool
where
  "empty_asid = \<lparr>cdl_asid_pool_caps = empty_cap_map asid_low_bits\<rparr>"

definition
  si_asid :: "sep_state \<Rightarrow> bool"
where
  "si_asid \<equiv>
  (si_cnode_id, unat seL4_CapInitThreadASIDPool) \<mapsto>c AsidPoolCap si_asidpool_id si_asidpool_base \<and>*
    si_asidpool_id \<mapsto>f AsidPool empty_asid \<and>*
   (\<And>* offset\<in>{offset. offset < 2 ^ asid_low_bits}.
               (si_asidpool_id, offset) \<mapsto>c -)"

abbreviation "si_tcb_id \<equiv> root_tcb_id"

definition si_objects :: "sep_state \<Rightarrow> bool"
where
  "si_objects \<equiv>
   si_tcb_id \<mapsto>f root_tcb \<and>*
   si_cnode_id \<mapsto>f CNode (empty_cnode si_cnode_size) \<and>*
  (si_tcb_id, tcb_cspace_slot) \<mapsto>c si_cspace_cap \<and>*
  (si_tcb_id, tcb_pending_op_slot) \<mapsto>c RunningCap \<and>*
  (si_cnode_id, unat seL4_CapInitThreadCNode) \<mapsto>c si_cnode_cap \<and>*
  (si_cnode_id, unat seL4_CapIRQControl) \<mapsto>c IrqControlCap \<and>*
   si_asid"

definition
  si_objects_extra_caps' :: "cdl_object_id set \<Rightarrow> cdl_cptr list \<Rightarrow> cdl_cptr list \<Rightarrow> sep_state \<Rightarrow> bool"
where
  "si_objects_extra_caps' obj_ids free_cptrs untyped_cptrs \<equiv> \<lambda>s.
   \<exists>untyped_caps all_available_ids.
    ((\<And>* (cptr, cap) \<in> set (zip untyped_cptrs untyped_caps). (si_cnode_id, unat cptr) \<mapsto>c cap) \<and>*
     (\<And>* cptr \<in> set (drop (card obj_ids) free_cptrs). (si_cnode_id, unat cptr) \<mapsto>c NullCap) \<and>*
     (\<And>* obj_id\<in>all_available_ids. obj_id \<mapsto>o Untyped)) s"

definition
  si_objects_extra_caps :: "cdl_object_id set \<Rightarrow> cdl_cptr list \<Rightarrow> cdl_cptr list
                          \<Rightarrow> cdl_state \<Rightarrow> sep_state \<Rightarrow> bool"
where
  "si_objects_extra_caps obj_ids free_cptrs untyped_cptrs spec \<equiv> \<lambda>s.
   \<exists>untyped_caps all_available_ids.
    ((\<And>* (cptr, cap) \<in> set (zip untyped_cptrs untyped_caps). (si_cnode_id, unat cptr) \<mapsto>c cap) \<and>*
     (\<And>* cptr \<in> set (drop (card obj_ids + card {obj_id \<in> obj_ids. cnode_or_tcb_at obj_id spec}) free_cptrs).
         (si_cnode_id, unat cptr) \<mapsto>c NullCap) \<and>*
     (\<And>* obj_id\<in>all_available_ids. obj_id \<mapsto>o Untyped)) s"

lemma distinct_take_drop_append:
  "distinct xs \<Longrightarrow> set (take b (drop a xs)) \<inter> set (drop (a + b) xs) = {}"
  by (metis distinct_append distinct_drop take_drop_append)

lemma si_objects_extra_caps'_si_objects_extra_caps:
  "distinct free_slots \<Longrightarrow>
     si_objects_extra_caps' obj_ids free_slots untyped_cptrs =
    (si_objects_extra_caps obj_ids free_slots untyped_cptrs spec \<and>*
    (\<And>* cptr \<in> set (take (card {obj_id \<in> obj_ids. cnode_or_tcb_at obj_id spec})
                       (drop (card obj_ids) free_slots)).
           (si_cnode_id, unat cptr) \<mapsto>c NullCap))"
  apply (rule ext)
  apply (clarsimp simp: si_objects_extra_caps'_def si_objects_extra_caps_def sep_conj_exists)
  apply (rule ex_eqI)+
  apply (subst take_drop_append [where a="card obj_ids" and
               b="card {obj_id \<in> obj_ids. cnode_or_tcb_at obj_id spec}"])
  apply clarsimp
  apply (subst sep.prod.union_disjoint, (simp add: distinct_take_drop_append)+)+
  apply (clarsimp simp: sep_conj_ac)
  done

definition
  si_irq_nodes :: "cdl_state \<Rightarrow> sep_state \<Rightarrow> bool"
where
  "si_irq_nodes spec \<equiv>
     (\<lambda>s. \<exists>k_irq_table. (\<And>* irq\<in>used_irqs spec. irq \<mapsto>irq k_irq_table irq \<and>*
                                                 k_irq_table irq \<mapsto>o IRQNode empty_irq_node) s)"

(***************************************
 * Lemmas about the root task objects. *
 ***************************************)

lemma is_cnode_cap_si_cspace_cap [simp]:
  "is_cnode_cap si_cspace_cap"
  by (clarsimp simp: si_cspace_cap_def)

lemma is_cnode_cap_si_cnode_cap [simp]:
  "is_cnode_cap si_cnode_cap"
  by (clarsimp simp: si_cnode_cap_def)

lemma is_tcb_root_tcb [simp]:
  "is_tcb root_tcb"
  by (clarsimp simp: root_tcb_def)

lemma cap_guard_size_si_cnode_cap_plus_si_cnode_size [simp]:
  "cap_guard_size si_cnode_cap + si_cnode_size = word_bits"
  by (clarsimp simp: si_cnode_cap_def)

lemma cap_object_si_cspace_cap [simp]:
  "cap_object si_cspace_cap = si_cnode_id"
  by (clarsimp simp: cap_object_def cap_has_object_def si_cspace_cap_def)

lemma cap_object_si_cnode_cap [simp]:
  "cap_object si_cnode_cap = si_cnode_id"
  by (clarsimp simp: cap_object_def cap_has_object_def si_cnode_cap_def)

lemma offset_slot_si_cnode_size:
  "slot < 2^si_cnode_size \<Longrightarrow> offset (of_nat slot) si_cnode_size = slot"
  by (clarsimp simp: offset_slot)

lemma offset_slot_si_cnode_size':
  "slot < 2^si_cnode_size \<Longrightarrow> offset slot si_cnode_size = unat slot"
  by (clarsimp simp: offset_slot')

lemma guard_equal_si_cspace_cap:
  "src_index < 2 ^ si_cnode_size \<Longrightarrow> guard_equal si_cspace_cap src_index 32"
  apply (clarsimp simp: si_cspace_cap_def guard_equal_def Let_unfold)
  apply (subst and_mask_eq_iff_shiftr_0 [THEN iffD1])
   apply (clarsimp simp: word_bits_def)
   apply (erule less_mask_eq)
  apply (clarsimp simp: mask_def)
  done

lemma guard_equal_si_cspace_cap':
  "src_index < 2 ^ si_cnode_size \<Longrightarrow> guard_equal si_cspace_cap src_index word_bits"
  by (drule guard_equal_si_cspace_cap, simp add: word_bits_def)

lemma guard_equal_si_cnode_cap:
  "src_index < 2 ^ si_cnode_size \<Longrightarrow> guard_equal si_cnode_cap src_index 32"
  apply (clarsimp simp: si_cnode_cap_def guard_equal_def Let_unfold)
  apply (subst and_mask_eq_iff_shiftr_0 [THEN iffD1])
   apply (clarsimp simp: word_bits_def)
   apply (erule less_mask_eq)
  apply (clarsimp simp: mask_def)
  done

lemma seL4_CapInitThreadASIDPool_si_cnode_size [simp]:
  "seL4_CapInitThreadASIDPool < 2 ^ si_cnode_size"
  by (clarsimp simp: seL4_CapInitThreadASIDPool_def si_cnode_size_def)

lemma guard_equal_si_cspace_cap_seL4_CapInitThreadASIDPool [simp]:
  "guard_equal si_cspace_cap seL4_CapInitThreadASIDPool word_bits"
  by (rule guard_equal_si_cspace_cap', simp)

lemma si_cspace_cap_guard_equal:
  "guard_equal si_cnode_cap src_index 32 \<Longrightarrow> src_index < 2 ^ si_cnode_size"
  apply (clarsimp simp: si_cnode_cap_def guard_equal_def
                        Let_unfold si_cnode_size_def)
  apply (subst (asm) shiftr_mask_eq')
   apply (simp add: word_bits_size word_bits_def)
  apply (subst (asm) le_mask_iff [symmetric])
  apply (clarsimp simp: mask_def)
  apply (insert word32_less_sub_le [where x=src_index and n=12])
  apply (clarsimp simp: word_bits_def)
  done

lemma one_lvl_lookup_si_cspace_cap [simp]:
  "one_lvl_lookup si_cspace_cap word_bits si_cnode_size"
  by (clarsimp simp: one_lvl_lookup_def si_cspace_cap_def)

lemmas one_lvl_lookup_si_cspace_cap' [simp] =
       one_lvl_lookup_si_cspace_cap [simplified word_bits_def, simplified]

lemma one_lvl_lookup_si_cnode_cap [simp]:
  "one_lvl_lookup si_cnode_cap word_bits si_cnode_size"
  by (clarsimp simp: one_lvl_lookup_def si_cnode_cap_def)

lemmas one_lvl_lookup_si_cnode_cap' [simp] =
       one_lvl_lookup_si_cnode_cap [simplified word_bits_def, simplified]

lemma obj_tcb_root_tcb [simp]:
  "Tcb (obj_tcb root_tcb) = root_tcb"
  by (clarsimp simp: obj_tcb_def root_tcb_def update_slots_def)

(***************************
 * Lemmas about word size. *
 ***************************)
lemma seL4_CapInitThreadCNode_less_than_si_cnode_size [simp]:
  "seL4_CapInitThreadCNode < 2 ^ si_cnode_size"
  apply (insert si_cnode_size_greater_than_1)
  apply (insert power_strict_increasing [where n=1 and a="(2::nat)" and N=si_cnode_size, simplified])
  apply (clarsimp)
  apply (drule  of_nat_less_pow_32)
   apply (clarsimp simp: seL4_CapInitThreadCNode_def)+
  done

lemma offset_seL4_CapInitThreadCNode [simp]:
  "offset seL4_CapInitThreadCNode si_cnode_size = unat seL4_CapInitThreadCNode"
  by (rule offset_slot', simp)

lemma seL4_CapIRQControl_less_than_si_cnode_size [simp]:
  "seL4_CapIRQControl < 2 ^ si_cnode_size"
  apply (simp add: seL4_CapIRQControl_def)
  apply (insert si_cnode_size_greater_than_2)
  apply (insert power_strict_increasing [where n=2 and a="(2::nat)" and N=si_cnode_size, simplified])
  apply (drule  of_nat_less_pow_32, simp_all)
  done

lemma offset_seL4_CapIRQControl [simp]:
  "offset seL4_CapIRQControl si_cnode_size = unat seL4_CapIRQControl"
  by (rule offset_slot', simp)

(* There is a cap in the root cnode that points to the obj_id specified.
 * This cap should be the default cap to that object.
 *
 * This predicate can be used for spec objects, or the duplicated cnode caps.
 *)
definition si_cap_at :: "(cdl_object_id \<Rightarrow> cdl_object_id option) \<Rightarrow>
                           (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow> bool \<Rightarrow>
                            cdl_object_id \<Rightarrow> sep_pred"
where
  "si_cap_at t si_caps spec dev obj_id \<equiv> \<lambda>s.
    \<exists>cap_ptr slot obj kobj_id.
     ((si_cnode_id, slot) \<mapsto>c default_cap (object_type obj) {kobj_id} (object_size_bits obj) dev) s \<and>
     si_caps obj_id = Some cap_ptr \<and>
     unat cap_ptr = slot \<and>
     cap_ptr < 2 ^ si_cnode_size \<and>
     cdl_objects spec obj_id = Some obj \<and>
     t obj_id = Some kobj_id"

definition si_irq_cap_at :: "(cdl_irq \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow>
                                cdl_irq \<Rightarrow> sep_pred"
where
  "si_irq_cap_at si_irq_caps spec irq \<equiv> \<lambda>s.
    \<exists>cap_ptr slot.
     ((si_cnode_id, slot) \<mapsto>c IrqHandlerCap irq) s \<and>
     si_irq_caps irq = Some cap_ptr \<and>
     unat cap_ptr = slot \<and>
     cap_ptr < 2 ^ si_cnode_size"

definition si_caps_at :: "(cdl_object_id \<Rightarrow> cdl_object_id option) \<Rightarrow>
                           (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow> bool \<Rightarrow>
                            cdl_object_id set \<Rightarrow> sep_pred"
where
  "si_caps_at t si_caps spec dev obj_ids \<equiv>
  \<And>* obj_id \<in> obj_ids. (si_cap_at t si_caps spec) dev obj_id"

definition si_irq_caps_at :: "(cdl_irq \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow>
                                cdl_irq set \<Rightarrow> sep_pred"
where
  "si_irq_caps_at si_irq_caps spec irqs \<equiv>
  \<And>* irq \<in> irqs. si_irq_cap_at si_irq_caps spec irq"

definition
  si_obj_cap_at' :: " (cdl_object_id \<Rightarrow> cdl_object_id option) \<Rightarrow>
                        (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow> bool \<Rightarrow>
                         cdl_object_id \<Rightarrow> cdl_cnode_index \<Rightarrow> sep_pred"
where
  "si_obj_cap_at' t si_caps spec dev obj_id slot \<equiv> \<lambda>s. \<exists> spec_cap.
   si_cap_at t si_caps spec dev (cap_object spec_cap) s \<and>
   opt_cap (obj_id, slot) spec = Some spec_cap"

definition si_obj_cap_at where
  "si_obj_cap_at t si_caps spec dev obj_id slot \<equiv>
     if original_cap_at (obj_id, slot) spec \<and> cap_at cap_has_object (obj_id, slot) spec
     then si_obj_cap_at' t si_caps spec dev obj_id slot
     else \<box>"

definition
  si_obj_caps_at :: "(cdl_object_id \<Rightarrow> cdl_object_id option) \<Rightarrow>
                            (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow> bool \<Rightarrow>
                             cdl_object_id \<Rightarrow> sep_pred"
where
  "si_obj_caps_at t si_caps spec dev obj_id \<equiv>
   \<And>* slot \<in> dom (slots_of obj_id spec). si_obj_cap_at t si_caps spec dev obj_id slot"

definition
  si_objs_caps_at :: "(cdl_object_id \<Rightarrow> cdl_object_id option) \<Rightarrow>
                             (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow> bool \<Rightarrow>
                              cdl_object_id set \<Rightarrow> sep_pred"
where
  "si_objs_caps_at t si_caps spec dev obj_ids \<equiv>
   \<And>* obj_id \<in> obj_ids. (si_obj_caps_at t si_caps spec) dev obj_id"

definition
  si_spec_irq_cap_at' :: "(cdl_irq \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow>
                             cdl_object_id \<Rightarrow> cdl_cnode_index \<Rightarrow> sep_pred"
where
  "si_spec_irq_cap_at' si_irq_caps spec obj_id slot \<equiv> \<lambda>s. \<exists> spec_cap.
   si_irq_cap_at si_irq_caps spec (cap_irq spec_cap) s \<and>
   opt_cap (obj_id, slot) spec = Some spec_cap"

definition si_spec_irq_cap_at where
  "si_spec_irq_cap_at si_irq_caps spec obj_id slot \<equiv>
     if irqhandler_cap_at (obj_id, slot) spec
     then si_spec_irq_cap_at' si_irq_caps spec obj_id slot
     else \<box>"

definition
  si_spec_irq_caps_at :: "(cdl_irq \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow>
                             cdl_object_id \<Rightarrow> sep_pred"
where
  "si_spec_irq_caps_at si_irq_caps spec obj_id \<equiv>
   \<And>* slot \<in> dom (slots_of obj_id spec). si_spec_irq_cap_at si_irq_caps spec obj_id slot"

definition
  si_spec_irqs_caps_at :: "(cdl_irq \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow>
                              cdl_object_id set \<Rightarrow> sep_pred"
where
  "si_spec_irqs_caps_at si_irq_caps spec obj_ids \<equiv>
   \<And>* obj_id \<in> obj_ids. si_spec_irq_caps_at si_irq_caps spec obj_id"

definition
  "si_null_cap_at t si_irq_caps spec obj_id \<equiv>
    \<lambda>s. \<exists>cap_ptr slot obj kobj_id.
       ((si_cnode_id, slot) \<mapsto>c NullCap) s \<and>
       si_irq_caps obj_id = Some cap_ptr \<and>
       unat cap_ptr = slot \<and>
       cap_ptr < 2 ^ si_cnode_size \<and>
       cdl_objects spec obj_id = Some obj \<and> t obj_id = Some kobj_id"

definition
  "si_null_irq_cap_at si_irq_caps spec irq \<equiv>
    \<lambda>s. \<exists>cap_ptr slot.
       ((si_cnode_id, slot) \<mapsto>c NullCap) s \<and>
       si_irq_caps irq = Some cap_ptr \<and>
       unat cap_ptr = slot \<and>
       cap_ptr < 2 ^ si_cnode_size"

definition
  si_spec_obj_null_cap_at' :: " (cdl_object_id \<Rightarrow> cdl_object_id option) \<Rightarrow>
                                  (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow>
                                   cdl_object_id \<Rightarrow> cdl_cnode_index \<Rightarrow> sep_pred"
where
  "si_spec_obj_null_cap_at' t si_irq_caps spec obj_id slot \<equiv> \<lambda>s. \<exists> spec_cap.
   si_null_cap_at t si_irq_caps spec (cap_object spec_cap) s \<and>
   opt_cap (obj_id, slot) spec = Some spec_cap"

definition si_spec_obj_null_cap_at where
  "si_spec_obj_null_cap_at t si_irq_caps spec obj_id slot \<equiv>
     if original_cap_at (obj_id, slot) spec \<and> cap_at cap_has_object (obj_id, slot) spec
     then si_spec_obj_null_cap_at' t si_irq_caps spec obj_id slot
     else \<box>"

definition
  si_spec_obj_null_caps_at :: "(cdl_object_id \<Rightarrow> cdl_object_id option) \<Rightarrow>
                                 (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow>
                                  cdl_object_id \<Rightarrow> sep_pred"
where
  "si_spec_obj_null_caps_at t si_irq_caps spec obj_id \<equiv>
   \<And>* slot \<in> dom (slots_of obj_id spec). si_spec_obj_null_cap_at t si_irq_caps spec obj_id slot"

definition
  si_spec_objs_null_caps_at :: "(cdl_object_id \<Rightarrow> cdl_object_id option) \<Rightarrow>
                                  (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow>
                                   cdl_object_id set \<Rightarrow> sep_pred"
where
  "si_spec_objs_null_caps_at t si_irq_caps spec obj_ids \<equiv>
   \<And>* obj_id \<in> obj_ids. si_spec_obj_null_caps_at t si_irq_caps spec obj_id"

definition
  si_spec_irq_null_cap_at' :: "(cdl_irq \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow>
                                  cdl_object_id \<Rightarrow> cdl_cnode_index \<Rightarrow> sep_pred"
where
  "si_spec_irq_null_cap_at' si_irq_caps spec obj_id slot \<equiv> \<lambda>s. \<exists> spec_cap.
   si_null_irq_cap_at si_irq_caps spec (cap_irq spec_cap) s \<and>
   opt_cap (obj_id, slot) spec = Some spec_cap \<and> \<not>is_untyped_cap spec_cap"

definition si_spec_irq_null_cap_at where
  "si_spec_irq_null_cap_at si_irq_caps spec obj_id slot \<equiv>
     if irqhandler_cap_at (obj_id, slot) spec
     then si_spec_irq_null_cap_at' si_irq_caps spec obj_id slot
     else \<box>"

definition
  si_spec_irq_null_caps_at :: "(cdl_irq \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow>
                                  cdl_object_id \<Rightarrow> sep_pred"
where
  "si_spec_irq_null_caps_at si_irq_caps spec obj_id \<equiv>
   \<And>* slot \<in> dom (slots_of obj_id spec). si_spec_irq_null_cap_at si_irq_caps spec obj_id slot"

definition
  si_spec_irqs_null_caps_at :: "(cdl_irq \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow>
                                   cdl_object_id set \<Rightarrow> sep_pred"
where
  "si_spec_irqs_null_caps_at si_irq_caps spec obj_ids \<equiv>
   \<And>* obj_id \<in> obj_ids. si_spec_irq_null_caps_at si_irq_caps spec obj_id"

definition si_null_caps_at :: "(cdl_object_id \<Rightarrow> cdl_object_id option) \<Rightarrow>
                           (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow>
                            cdl_object_id set \<Rightarrow> sep_pred"
where
  "si_null_caps_at t si_caps spec obj_ids \<equiv>
  \<And>* obj_id \<in> obj_ids. si_null_cap_at t si_caps spec obj_id"

lemma si_cap_at_less_si_cnode_size:
  "\<lbrakk>\<guillemotleft>si_cap_at t opt_sel4_cap spec dev obj_id \<and>* R\<guillemotright> s;
    Some cap_ptr = opt_sel4_cap obj_id\<rbrakk>
  \<Longrightarrow> cap_ptr < 2 ^ si_cnode_size"
  by (clarsimp simp: si_cap_at_def sep_conj_exists)

lemma si_irq_cap_at_less_si_cnode_size:
  "\<lbrakk>\<guillemotleft>si_irq_cap_at opt_sel4_cap spec obj_id \<and>* R\<guillemotright> s;
    Some cap_ptr = opt_sel4_cap obj_id\<rbrakk>
  \<Longrightarrow> cap_ptr < 2 ^ si_cnode_size"
  by (clarsimp simp: si_irq_cap_at_def sep_conj_exists)

lemma si_cap_at_has_k_obj_id:
  "\<lbrakk>\<guillemotleft>si_cap_at t opt_sel4_cap spec dev obj_id \<and>* R\<guillemotright> s\<rbrakk>
  \<Longrightarrow> \<exists>cap_object_id. t obj_id = Some cap_object_id"
  by (clarsimp simp: si_cap_at_def sep_conj_exists)

(******************************************************
 * Using just si_cap_at when you have si_caps_at. *
 ******************************************************)

lemma valid_si_caps_at_si_cap_at:
  "\<lbrakk>finite obj_ids; obj_id \<in> obj_ids;
   (\<And>R. \<lbrace>\<guillemotleft>si_cap_at t orig_caps spec dev obj_id \<and>* P \<and>* R\<guillemotright>\<rbrace>
   f
   \<lbrace>\<lambda>_.\<guillemotleft>si_cap_at t orig_caps spec dev obj_id \<and>* Q \<and>* R\<guillemotright>\<rbrace>)\<rbrakk>
   \<Longrightarrow>
   \<lbrace>\<guillemotleft>si_caps_at t orig_caps spec dev obj_ids \<and>* P \<and>* R\<guillemotright>\<rbrace>
   f
   \<lbrace>\<lambda>_.\<guillemotleft>si_caps_at t orig_caps spec dev obj_ids \<and>* Q \<and>* R\<guillemotright>\<rbrace>"
  apply (clarsimp simp: si_caps_at_def)
  apply (drule sep_set_conj_map_singleton_wp [where f=f and
                   I="si_cap_at t orig_caps spec dev" and  P=P and Q=Q and R=R, rotated])
    apply (clarsimp simp: sep_conj_ac)+
  done

(**********************************************************
 * The pre and post conditions of the system initialiser. *
 **********************************************************)

(* That the boot info is valid, and that there are enough free slots to initialise a system. *)
definition
  valid_boot_info
where
  "valid_boot_info bootinfo spec \<equiv> \<lambda>s.
  \<exists>untyped_caps fstart fend ustart uend.
  ((\<And>*(cptr, cap) \<in> set (zip [ustart .e. uend - 1] untyped_caps). (si_cnode_id, unat cptr) \<mapsto>c cap)  \<and>*
   (\<And>* cptr \<in> set [fstart .e. fend - 1]. (si_cnode_id, unat cptr) \<mapsto>c NullCap) \<and>*
   (\<And>* obj_id\<in>(\<Union>cap\<in>set untyped_caps. cap_free_ids cap). obj_id \<mapsto>o Untyped) \<and>*
    si_objects \<and>* si_irq_nodes spec) s \<and>
   card (dom (cdl_objects spec)) +
   card {obj_id. cnode_or_tcb_at obj_id spec} \<le> unat fend - unat fstart \<and>
   length untyped_caps = unat uend - unat ustart \<and>
   distinct_sets (map cap_free_ids untyped_caps) \<and>
   list_all is_full_untyped_cap untyped_caps \<and>
   list_all well_formed_untyped_cap untyped_caps \<and>
   list_all (\<lambda>c. \<not> is_device_cap c) untyped_caps \<and>
   bi_untypes bootinfo = (ustart, uend) \<and>
   bi_free_slots bootinfo = (fstart, fend) \<and>
   ustart < 2 ^ si_cnode_size \<and>
  (uend - 1) < 2 ^ si_cnode_size \<and>
   fstart < 2 ^ si_cnode_size \<and>
  (fend - 1) < 2 ^ si_cnode_size \<and>
   uend \<noteq> 0 \<and> fend \<noteq> 0"

definition
  si_final_objects :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_object_id option) \<Rightarrow> sep_pred"
where
  "si_final_objects spec t \<equiv> \<lambda>s.
   \<exists>dup_caps (untyped_cptrs::32 word list) (free_cptrs::32 word list) untyped_caps all_available_ids.
    ((\<And>*  cptr \<in> set (take (card (dom (cdl_objects spec))) free_cptrs).
          (si_cnode_id, unat cptr) \<mapsto>c NullCap) \<and>*
     (\<And>*  cptr \<in> set (drop (card (dom (cdl_objects spec)) +
                             card ({obj_id. cnode_or_tcb_at obj_id spec})) free_cptrs).
          (si_cnode_id, unat cptr) \<mapsto>c NullCap) \<and>*
     (\<And>* (cptr, untyped_cap) \<in> set (zip untyped_cptrs untyped_caps).
          (si_cnode_id, unat cptr) \<mapsto>c untyped_cap) \<and>*
     (\<And>*  obj_id \<in> all_available_ids. obj_id \<mapsto>o Untyped) \<and>*
     (\<And>*  obj_id \<in> {obj_id. cnode_or_tcb_at obj_id spec}. (si_cap_at t dup_caps spec False obj_id)) \<and>*
      si_objects) s"

(********************************************************
 * Conversion of si_objs_caps_at to si_caps_at *
 ********************************************************)

lemma orig_cap_rewrite:
  "Set.filter (\<lambda>cap_ref. original_cap_at cap_ref spec \<and> cap_at cap_has_object cap_ref spec)
               (SIGMA obj_id:{obj_id. cnode_at obj_id spec}.
                      dom (slots_of obj_id spec)) =
   {cap_ref. original_cap_at cap_ref spec \<and> object_cap_ref cap_ref spec}"
  by (auto simp: object_cap_ref_def opt_cap_def object_at_def cap_at_def real_object_at_def
          split: option.splits)

lemma slots_tcb:
  "\<lbrakk>well_formed spec; opt_cap (obj_id, slot) spec = Some cap;
    cdl_objects spec obj_id = Some obj; obj = Tcb tcb\<rbrakk> \<Longrightarrow>
   slot = 0 \<or>
   slot = 1 \<or>
   slot = 2 \<or>
   slot = 3 \<or>
   slot = 4 \<or>
   slot = 5 \<or>
   slot = 6"
  apply (frule (1) well_formed_object_slots)
  apply (drule (1) well_formed_well_formed_tcb)
  apply (clarsimp simp: well_formed_tcb_def opt_cap_def slots_of_def opt_object_def)
  apply (drule (1) dom_eqD)
  apply (clarsimp simp: object_default_state_def2 dom_object_slots_default_tcb
                        tcb_pending_op_slot_def tcb_boundntfn_slot_def)
  done

lemma object_at_dom_cdl_objects:
  "object_at P obj_id s \<Longrightarrow> obj_id \<in> dom (cdl_objects s)"
  by (clarsimp simp: object_at_def)

lemma foo:
  "\<lbrakk>well_formed spec; irq_node_at obj_id spec\<rbrakk>
  \<Longrightarrow> obj_id \<in> irq_nodes spec"
  by (metis irq_nodes_def mem_Collect_eq)

lemma well_formed_irqhandler_cap_in_cnode:
  "\<lbrakk>well_formed spec; opt_cap (obj_id, slot) spec = Some cap;
    is_irqhandler_cap cap; cdl_objects spec obj_id = Some obj\<rbrakk>
    \<Longrightarrow> is_cnode obj"
  apply (case_tac obj)
          apply (fastforce simp: opt_cap_def slots_of_def object_slots_def opt_object_def
                                 is_cnode_def object_at_def is_asidpool_def)+
        apply (frule (3) slots_tcb)
        apply (drule (1) well_formed_well_formed_tcb)
        apply (clarsimp simp: well_formed_tcb_def opt_cap_def slots_of_def opt_object_def)
        apply (erule allE [where x=slot])
        apply (simp add: tcb_slot_defs cap_type_def split: cdl_cap.splits)
       apply (fastforce simp: opt_cap_def slots_of_def object_slots_def opt_object_def
                              is_cnode_def object_at_def is_asidpool_def)
      apply (frule_tac obj_id=obj_id in well_formed_asidpool_at, simp add: object_at_def)
     apply (frule (1) well_formed_pt, simp add: object_at_def, simp+)
    apply (frule (1) well_formed_pd, simp add: object_at_def, simp+)
    apply (clarsimp simp: is_fake_pt_cap_def split: cdl_cap.splits)
   apply (fastforce simp: opt_cap_def slots_of_def object_slots_def opt_object_def
                         is_cnode_def object_at_def is_asidpool_def)+
   apply (frule (1) well_formed_well_formed_irq_node)
   apply (fastforce simp: well_formed_irq_node_def opt_cap_def slots_of_def opt_object_def
                          object_at_def irq_nodes_def is_irq_node_def)
  done

lemma well_formed_irqhandler_cap_in_cnode_at:
  "\<lbrakk>well_formed spec; opt_cap (obj_id, slot) spec = Some cap; is_irqhandler_cap cap\<rbrakk>
  \<Longrightarrow> cnode_at obj_id spec"
  apply (frule opt_cap_cdl_objects, clarsimp)
  apply (drule (3) well_formed_irqhandler_cap_in_cnode)
  apply (clarsimp simp: object_at_def)
  done

lemma irqhandler_cap_rewrite:
   "well_formed spec \<Longrightarrow>
    Set.filter (\<lambda>irq. irqhandler_cap_at irq spec)
                (SIGMA obj_id:{obj_id. cnode_at obj_id spec}.
                       dom (slots_of obj_id spec)) =
    {cap_ref. irqhandler_cap_at cap_ref spec}"
   apply (clarsimp simp: object_cap_ref_def object_at_def cap_at_def
          split: option.splits)
   apply rule
    apply clarsimp
   apply clarsimp
   apply (frule opt_cap_dom_cdl_objects)
   apply (frule opt_cap_dom_slots_of, clarsimp)
   apply (frule (3) well_formed_irqhandler_cap_in_cnode)
   apply (frule (1) well_formed_well_formed_irq_node)
   apply (clarsimp simp: well_formed_irq_node_def object_at_def
                         opt_cap_def slots_of_def opt_object_def dom_def)
   done

lemma well_formed_object_cap_real:
  "well_formed spec
  \<Longrightarrow> object_cap_ref cap_ref spec =
     (cap_at_to_real_object cap_ref spec \<and>
      cnode_at (fst cap_ref) spec)"
  apply (clarsimp simp: cap_at_def cap_at_to_real_object_def object_cap_ref_def)
  apply (rule iffI)
   apply clarsimp
   apply (drule (1) well_formed_well_formed_cap_to_real_object', simp)
   apply (clarsimp simp: well_formed_cap_to_real_object_def real_object_at_def)
  apply (clarsimp simp: real_object_at_def opt_cap_dom_cdl_objects)
  done

(* This lemma converts between the two represenatations of the fact that the
 * root task has orig caps to each of the objects.
 *
 * This can be specified either:
 * - on the objects themselves.
 * - on the cap slots of CNodes that have a orig cap in them.
 *
 * This relies on the bijection between orig capabilities and objects in the spec.
 *)

lemma si_caps_at_conversion:
  "\<lbrakk>well_formed spec;
    real_ids = {obj_id. real_object_at obj_id spec};
    cnode_ids = {obj_id. cnode_at obj_id spec}\<rbrakk>
  \<Longrightarrow> si_objs_caps_at t si_caps spec dev cnode_ids =
      si_caps_at t si_caps spec dev real_ids"
  apply (clarsimp simp: si_objs_caps_at_def si_obj_caps_at_def [abs_def]
                        si_obj_cap_at_def [abs_def] si_caps_at_def)
  apply (subst sep.prod.Sigma, clarsimp+)
  apply (clarsimp simp: split_def)
  apply (subst sep_map_set_conj_restrict_predicate)
   apply (rule finite_SigmaI, clarsimp+)
  apply (subst orig_cap_rewrite)
  apply (frule well_formed_bij)
  apply (clarsimp simp: bij_betw_def)
  apply (rule sep_map_set_conj_reindex_cong [where f="\<lambda>cap_ref. cap_ref_object cap_ref spec", symmetric])
    apply (subst well_formed_object_cap_real, simp+)
   apply (simp add: real_objects_def real_object_at_def)
   apply (subst well_formed_object_cap_real, simp+)
  apply (clarsimp simp: cap_ref_object_def object_cap_ref_def si_obj_cap_at'_def)
  done

lemma si_null_caps_at_conversion:
  "\<lbrakk>well_formed spec;
    real_ids = {obj_id. real_object_at obj_id spec};
    cnode_ids = {obj_id. cnode_at obj_id spec}\<rbrakk>
  \<Longrightarrow> si_spec_objs_null_caps_at t si_caps spec cnode_ids =
      si_null_caps_at t si_caps spec real_ids"
  apply (clarsimp simp: si_spec_objs_null_caps_at_def si_spec_obj_null_caps_at_def [abs_def]
                        si_spec_obj_null_cap_at_def [abs_def] si_null_caps_at_def)
  apply (subst sep.prod.Sigma, clarsimp+)
  apply (clarsimp simp: split_def)
  apply (subst sep_map_set_conj_restrict_predicate)
   apply (rule finite_SigmaI, clarsimp+)
  apply (subst orig_cap_rewrite)
  apply (frule well_formed_bij)
  apply (clarsimp simp: bij_betw_def)
  apply (rule sep_map_set_conj_reindex_cong [where f="\<lambda>cap_ref. cap_ref_object cap_ref spec"
    and h="(si_null_cap_at t si_caps spec)"
    and B="{obj_id. real_object_at obj_id spec}", symmetric])
    apply (subst well_formed_object_cap_real, simp+)
   apply (simp add: real_objects_def real_object_at_def)
   apply (subst well_formed_object_cap_real, simp+)
  apply (clarsimp simp: cap_ref_object_def object_cap_ref_def si_spec_obj_null_cap_at'_def)
  done

lemma si_null_caps_at_reindex:
  "\<lbrakk>distinct (obj_ids::32 word list); distinct (free_cptrs);
     orig_caps = map_of (zip obj_ids free_cptrs);
     length obj_ids \<le> length free_cptrs\<rbrakk>
  \<Longrightarrow> (\<And>* obj_id\<in>set obj_ids.
       (\<lambda>s. \<exists>cap_ptr. ((si_cnode_id, unat cap_ptr) \<mapsto>c NullCap) s \<and>
                       orig_caps obj_id = Some cap_ptr))
   = (\<And>* cptr\<in>set (take (length obj_ids) free_cptrs).
                   (si_cnode_id, unat cptr) \<mapsto>c NullCap)"
  apply (rule sep_map_set_conj_reindex_cong [symmetric, where
      f="\<lambda>obj_id. the (orig_caps obj_id)"
      and h="\<lambda>cptr. (si_cnode_id, unat cptr) \<mapsto>c NullCap"
      and B="set (take (length obj_ids) free_cptrs)"])
    apply clarsimp
    apply (erule (2) map_of_zip_inj')
   apply clarsimp
   apply (subst zip_take_length[symmetric])
   apply (subst map_of_zip_range)
     apply (clarsimp simp: min_def)
    apply assumption
   apply simp
  apply clarsimp
  apply (rule ext)
  apply rule
   apply clarsimp
  apply (rule_tac x="the (map_of (zip obj_ids free_cptrs) a)" in exI)
  apply clarsimp
  apply (frule_tac x=a in map_of_zip_is_Some', clarsimp)
  done

lemma si_null_caps_at_simplified_helper:
  "\<lbrakk>(si_null_caps_at t orig_caps spec obj_ids) s\<rbrakk> \<Longrightarrow>
     (\<And>* obj_id \<in> obj_ids. (\<lambda>s. \<exists>cap_ptr. ((si_cnode_id, unat cap_ptr) \<mapsto>c NullCap) s \<and>
                                   orig_caps obj_id = Some cap_ptr)) s"
  apply (clarsimp simp: si_null_caps_at_def si_null_cap_at_def [abs_def])
  apply (erule sep_map_set_conj_impl)
   apply blast
  apply clarsimp
  done

lemma si_null_caps_at_simplified:
  "\<lbrakk>(si_spec_objs_null_caps_at t si_caps spec cnode_ids) s;
    well_formed spec;
    cnode_ids = {obj_id. cnode_at obj_id spec};
    real_ids = {obj_id. real_object_at obj_id spec};
    real_ids = set obj_ids;
    distinct obj_ids; distinct free_cptrs;
    si_caps = map_of (zip obj_ids free_cptrs);
    length obj_ids \<le> length free_cptrs\<rbrakk> \<Longrightarrow>
   (\<And>* cptr \<in> set (take (length obj_ids) free_cptrs). ((si_cnode_id, unat cptr) \<mapsto>c NullCap)) s"
  apply (subst (asm) si_null_caps_at_conversion, assumption+)
  apply (drule si_null_caps_at_simplified_helper)
  apply (subst si_null_caps_at_reindex [symmetric], simp+)
  done

lemma map_of_zip_range':
  "\<lbrakk>length xs = length ys; distinct xs; set xs = X\<rbrakk>
  \<Longrightarrow> (\<lambda>x. (the (map_of (zip xs ys) x))) ` X = set ys"
  by (metis map_of_zip_range)

lemma si_irq_caps_at_conversion:
  "\<lbrakk>well_formed spec;
    cnode_ids = {obj_id. cnode_at obj_id spec};
    irqs = used_irqs spec\<rbrakk>
  \<Longrightarrow> si_spec_irqs_caps_at irq_caps spec cnode_ids =
      si_irq_caps_at irq_caps spec irqs"
  apply (clarsimp simp: si_spec_irqs_caps_at_def si_irq_caps_at_def
                        si_spec_irq_caps_at_def [abs_def]
                        si_spec_irq_cap_at_def [abs_def])
  apply (subst sep.prod.Sigma, clarsimp+)
  apply (clarsimp simp: split_def)
  apply (subst sep_map_set_conj_restrict_predicate)
   apply (rule finite_SigmaI, clarsimp+)
  apply (subst irqhandler_cap_rewrite, assumption)
  apply (frule well_formed_irqhandler_bij)
  apply (clarsimp simp: bij_betw_def)
  apply (rule sep_map_set_conj_reindex_cong [where f="\<lambda>cap_ref. cap_ref_irq cap_ref spec", symmetric], simp+)
  apply (clarsimp simp: si_spec_irq_cap_at'_def cap_ref_irq_def cap_at_def)
  done

definition si_null_irq_caps_at :: "(cdl_irq \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_state \<Rightarrow>
                                      cdl_irq set \<Rightarrow> sep_pred"
where
  "si_null_irq_caps_at si_irq_caps spec irqs \<equiv>
  \<And>* irq \<in> irqs. si_null_irq_cap_at si_irq_caps spec irq"

lemma si_null_irq_caps_at_simplified_helper:
  "\<lbrakk>(si_null_irq_caps_at si_irq_caps spec irqs) s\<rbrakk> \<Longrightarrow>
     (\<And>* irq \<in> irqs. (\<lambda>s. \<exists>cap_ptr. ((si_cnode_id, unat cap_ptr) \<mapsto>c NullCap) s \<and>
                                   si_irq_caps irq = Some cap_ptr)) s"
  apply (clarsimp simp: si_null_irq_caps_at_def si_null_irq_cap_at_def)
  apply (erule sep_map_set_conj_impl)
   apply blast
  apply clarsimp
  done

lemma map_of_zip_inj2:
  "\<lbrakk>distinct xs; distinct ys; length xs \<le> length ys; set xs = X\<rbrakk>
  \<Longrightarrow> inj_on (\<lambda>x. the (map_of (zip xs ys) x)) X"
  by (metis map_of_zip_inj')

lemma opt_cap_has_slots:
  "\<lbrakk>opt_cap (obj_id, slot) spec = Some cap\<rbrakk>
  \<Longrightarrow> object_at has_slots obj_id spec"
  by (auto simp: object_at_def has_slots_def opt_cap_def slots_of_def opt_object_def object_slots_def
          split: option.splits cdl_object.splits)

lemma well_formed_non_ntfn_in_real_object:
  "\<lbrakk>well_formed spec; opt_cap (obj_id, slot) spec = Some cap; \<not>is_ntfn_cap cap; cap \<noteq> NullCap\<rbrakk>
  \<Longrightarrow> real_object_at obj_id spec"
  apply (frule opt_cap_cdl_objects, clarsimp)
  apply (frule (1) well_formed_well_formed_irq_node)
  apply (clarsimp simp: well_formed_irq_node_def real_object_at_def
                         opt_cap_def slots_of_def opt_object_def opt_cap_dom_cdl_objects)
  done

lemma irqhandler_cap_at_simp:
  "well_formed spec \<Longrightarrow>
   {(obj_id, slot). cnode_at obj_id spec \<and> irqhandler_cap_at (obj_id, slot) spec} =
   {(obj_id, slot). irqhandler_cap_at (obj_id, slot) spec}"
  apply (safe)
  apply (clarsimp simp: cap_at_def)
  apply (frule (2) well_formed_irqhandler_cap_in_cnode_at)
  apply (frule (1) well_formed_non_ntfn_in_real_object, simp+)
  done

lemma orig_cap_rewrite_v2:
  "(SIGMA obj_id:{obj_id. cnode_at obj_id spec}. dom (slots_of obj_id spec)) =
   {(obj_id, slot). cnode_at obj_id spec \<and> slots_of obj_id spec slot \<noteq> None}"
  by auto

lemma rewrite_irqhandler_cap_at:
  "well_formed spec \<Longrightarrow>
  Set.filter (\<lambda>cap_ref. irqhandler_cap_at cap_ref spec)
             (SIGMA obj_id:{obj_id. cnode_at obj_id spec}. dom (slots_of obj_id spec)) =
  {(obj_id, slot). irqhandler_cap_at (obj_id, slot) spec}"
  apply (subst irqhandler_cap_at_simp [symmetric])
  by (auto simp: opt_cap_def cap_at_def)

lemma well_formed_used_irqs_rewrite:
  "well_formed spec \<Longrightarrow>
   (\<lambda>cap_ref. cap_ref_irq cap_ref spec) ` {(obj_id, slot). irqhandler_cap_at (obj_id, slot) spec} =
   used_irqs spec"
  apply (drule well_formed_irqhandler_bij)
  apply (auto simp: bij_betw_def)
  done

lemma si_irq_null_caps_at_simplified:
  "\<lbrakk>(si_spec_irqs_null_caps_at irq_caps spec {obj_id. cnode_at obj_id spec}) s;
    well_formed spec;
    distinct irqs; distinct free_cptrs;
    set irqs = used_irqs spec;
    irq_caps = map_of (zip irqs free_cptrs);
    length irqs \<le> length free_cptrs\<rbrakk> \<Longrightarrow>
   (\<And>* cptr \<in> set (take (length irqs) free_cptrs). ((si_cnode_id, unat cptr) \<mapsto>c NullCap)) s"
  apply (clarsimp simp: si_spec_irqs_null_caps_at_def si_spec_irq_null_caps_at_def
                        si_spec_irq_null_cap_at_def si_spec_irqs_caps_at_def)
  apply (subst (asm) sep.prod.Sigma, clarsimp+)
  apply (clarsimp simp: split_def)
  apply (subst (asm) sep_map_set_conj_restrict_predicate, rule finite_SigmaI, clarsimp+)
  apply (subst (asm) rewrite_irqhandler_cap_at, simp)
  apply (subst (asm) sep_map_set_conj_reindex_cong [where
                    f = "\<lambda>cap_ref. cap_ref_irq cap_ref spec"
                and h = "si_null_irq_cap_at (map_of (zip irqs free_cptrs)) spec", symmetric])
     apply (drule well_formed_irqhandler_bij)
     apply (clarsimp simp: bij_betw_def cond_case_prod_eta)
    apply simp
   apply (clarsimp simp: si_spec_irq_null_cap_at'_def cap_at_def cap_ref_irq_def)
  apply clarsimp
  apply (drule si_null_irq_caps_at_simplified_helper [simplified si_null_irq_caps_at_def])
  apply (subst (asm) sep_map_set_conj_reindex_cong [symmetric, where
                    f = "\<lambda>irq. the ( map_of (zip irqs free_cptrs) irq)"
                and h = "\<lambda>cptr. (si_cnode_id, unat cptr) \<mapsto>c NullCap"
                and B = "set (take (length irqs) free_cptrs)"])
     apply (subst well_formed_used_irqs_rewrite, assumption)
     apply (metis map_of_zip_inj')
    apply (subst well_formed_used_irqs_rewrite, assumption)
    apply (subst zip_take_length[symmetric], subst map_of_zip_range', simp+)
   apply (rule ext)
   apply rule
    apply clarsimp
   apply (rule_tac x="the (map_of (zip irqs free_cptrs) a)" in exI)
   apply clarsimp
   apply (frule_tac x1="(cap_irq (the (opt_cap (aa, b) spec)))" in map_of_zip_is_Some'[THEN iffD1], clarsimp)
    apply (fastforce simp: cap_at_def used_irqs_def all_caps_def)
   apply (clarsimp simp: cap_ref_irq_def)
  apply simp
  done

end