1927 lines
79 KiB
Plaintext
1927 lines
79 KiB
Plaintext
(*
|
|
* Copyright 2014, General Dynamics C4 Systems
|
|
*
|
|
* This software may be distributed and modified according to the terms of
|
|
* the GNU General Public License version 2. Note that NO WARRANTY is provided.
|
|
* See "LICENSE_GPLv2.txt" for details.
|
|
*
|
|
* @TAG(GD_GPL)
|
|
*)
|
|
|
|
chapter \<open>Abstract datatype for the executable specification\<close>
|
|
|
|
theory ADT_H
|
|
imports
|
|
"AInvs.ADT_AI"
|
|
Syscall_R
|
|
begin
|
|
|
|
text \<open>
|
|
The general refinement calculus (see theory Simulation) requires
|
|
the definition of a so-called ``abstract datatype'' for each refinement layer.
|
|
This theory defines this datatype for the executable specification.
|
|
It is based on the abstract specification because we chose
|
|
to base the refinement's observable state on the abstract state.
|
|
\<close>
|
|
|
|
consts
|
|
initEntry :: word32
|
|
initFrames :: "word32 list"
|
|
initOffset :: word32
|
|
initKernelFrames :: "word32 list"
|
|
initBootFrames :: "word32 list"
|
|
initDataStart :: word32
|
|
|
|
context begin interpretation Arch . (*FIXME: arch_split*)
|
|
|
|
text \<open>
|
|
The construction of the abstract data type
|
|
for the executable specification largely follows
|
|
the one for the abstract specification.
|
|
\<close>
|
|
definition
|
|
Init_H :: "kernel_state global_state set"
|
|
where
|
|
"Init_H \<equiv>
|
|
({empty_context} \<times> snd `
|
|
fst (initKernel (VPtr initEntry) (PPtr initOffset) (map PPtr initFrames)
|
|
(map PPtr initKernelFrames) initBootFrames
|
|
(newKernelState initDataStart))) \<times>
|
|
{UserMode} \<times> {None}"
|
|
|
|
definition
|
|
"user_mem' s \<equiv> \<lambda>p.
|
|
if (pointerInUserData p s)
|
|
then Some (underlying_memory (ksMachineState s) p)
|
|
else None"
|
|
|
|
definition
|
|
"device_mem' s \<equiv> \<lambda>p.
|
|
if (pointerInDeviceData p s)
|
|
then Some p
|
|
else None"
|
|
|
|
|
|
definition
|
|
vm_rights_of :: "vmrights \<Rightarrow> rights set"
|
|
where
|
|
"vm_rights_of x \<equiv> case x of VMKernelOnly \<Rightarrow> vm_kernel_only
|
|
| VMReadOnly \<Rightarrow> vm_read_only
|
|
| VMReadWrite \<Rightarrow> vm_read_write"
|
|
|
|
lemma vm_rights_of_vmrights_map_id[simp]:
|
|
"rs \<in> valid_vm_rights \<Longrightarrow> vm_rights_of (vmrights_map rs)= rs"
|
|
by (auto simp: vm_rights_of_def vmrights_map_def valid_vm_rights_def
|
|
vm_read_write_def vm_read_only_def vm_kernel_only_def)
|
|
|
|
definition
|
|
absPageTable :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> obj_ref \<Rightarrow>
|
|
word8 \<Rightarrow> ARM_A.pte"
|
|
where
|
|
"absPageTable h a \<equiv> %offs.
|
|
case (h (a + (ucast offs << 2))) of
|
|
Some (KOArch (KOPTE (ARM_H.InvalidPTE))) \<Rightarrow> ARM_A.InvalidPTE
|
|
| Some (KOArch (KOPTE (ARM_H.LargePagePTE p c g xn rights))) \<Rightarrow>
|
|
if is_aligned offs 4 then
|
|
ARM_A.LargePagePTE p
|
|
{x. c & x=PageCacheable | g & x=Global | xn & x=XNever}
|
|
(vm_rights_of rights)
|
|
else ARM_A.InvalidPTE
|
|
| Some (KOArch (KOPTE (ARM_H.SmallPagePTE p c g xn rights))) \<Rightarrow>
|
|
ARM_A.SmallPagePTE p {x. c & x=PageCacheable |
|
|
g & x=Global |
|
|
xn & x=XNever} (vm_rights_of rights)"
|
|
|
|
definition
|
|
absPageDirectory :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> obj_ref \<Rightarrow>
|
|
12 word \<Rightarrow> ARM_A.pde"
|
|
where
|
|
"absPageDirectory h a \<equiv> %offs.
|
|
case (h (a + (ucast offs << 2))) of
|
|
Some (KOArch (KOPDE (ARM_H.InvalidPDE))) \<Rightarrow> ARM_A.InvalidPDE
|
|
| Some (KOArch (KOPDE (ARM_H.PageTablePDE p e mw))) \<Rightarrow>
|
|
ARM_A.PageTablePDE p {x. e & x=ParityEnabled} mw
|
|
| Some (KOArch (KOPDE (ARM_H.SectionPDE p e mw c g xn rights))) \<Rightarrow>
|
|
ARM_A.SectionPDE p {x. e & x=ParityEnabled |
|
|
c & x=PageCacheable |
|
|
g & x=Global |
|
|
xn & x=XNever} mw (vm_rights_of rights)
|
|
| Some (KOArch (KOPDE (ARM_H.SuperSectionPDE p e c g xn rights))) \<Rightarrow>
|
|
if is_aligned offs 4 then
|
|
ARM_A.SuperSectionPDE p
|
|
{x. e & x=ParityEnabled | c & x=PageCacheable
|
|
| g & x=Global | xn & x=XNever}
|
|
(vm_rights_of rights)
|
|
else ARM_A.InvalidPDE"
|
|
|
|
(* Can't pull the whole heap off at once, start with arch specific stuff.*)
|
|
definition
|
|
absHeapArch :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> word32
|
|
\<Rightarrow> arch_kernel_object \<rightharpoonup> arch_kernel_obj"
|
|
where
|
|
"absHeapArch h a \<equiv> %ako.
|
|
(case ako of
|
|
KOASIDPool (ARM_H.ASIDPool ap) \<Rightarrow>
|
|
Some (ARM_A.ASIDPool (\<lambda>w. ap (ucast w)))
|
|
| KOPTE _ \<Rightarrow>
|
|
if is_aligned a pt_bits then Some (PageTable (absPageTable h a))
|
|
else None
|
|
| KOPDE _ \<Rightarrow>
|
|
if is_aligned a pd_bits then Some (PageDirectory (absPageDirectory h a))
|
|
else None)"
|
|
|
|
lemma
|
|
assumes ptes:
|
|
"\<forall>x. (\<exists>pte. ksPSpace \<sigma> x = Some (KOArch (KOPTE pte))) \<longrightarrow>
|
|
is_aligned x pt_bits \<longrightarrow>
|
|
(\<forall>y::word8. \<exists>pte'. ksPSpace \<sigma> (x + (ucast y << 2)) =
|
|
Some (KOArch (KOPTE pte')))"
|
|
and pte_rights:
|
|
"\<forall>x. case ksPSpace \<sigma> x of
|
|
Some (KOArch (KOPTE (ARM_H.LargePagePTE _ _ _ _ r))) \<Rightarrow>
|
|
r \<noteq> VMNoAccess"
|
|
"\<forall>x. case ksPSpace \<sigma> x of
|
|
Some (KOArch (KOPTE (ARM_H.SmallPagePTE _ _ _ _ r))) \<Rightarrow>
|
|
r \<noteq> VMNoAccess"
|
|
|
|
assumes pdes:
|
|
"\<forall>x. (\<exists>pde. ksPSpace \<sigma> x = Some (KOArch (KOPDE pde))) \<longrightarrow>
|
|
is_aligned x pd_bits \<longrightarrow>
|
|
(\<forall>y::12 word. \<exists>pde'. ksPSpace \<sigma> (x + (ucast y << 2)) =
|
|
Some (KOArch (KOPDE pde')))"
|
|
and pde_rights:
|
|
"\<forall>x. case ksPSpace \<sigma> x of
|
|
Some (KOArch (KOPDE (ARM_H.SectionPDE _ _ _ _ _ _ r))) \<Rightarrow>
|
|
r \<noteq> VMNoAccess"
|
|
"\<forall>x. case ksPSpace \<sigma> x of
|
|
Some (KOArch (KOPDE (ARM_H.SuperSectionPDE _ _ _ _ _ r))) \<Rightarrow>
|
|
r \<noteq> VMNoAccess"
|
|
|
|
assumes fst_pte:
|
|
"\<forall>x. (\<exists>pte. ksPSpace \<sigma> x = Some (KOArch (KOPTE pte))) \<longrightarrow>
|
|
(\<exists>pte'. ksPSpace \<sigma> (x && ~~ mask pt_bits) =
|
|
Some (KOArch (KOPTE pte')))"
|
|
assumes fst_pde:
|
|
"\<forall>x. (\<exists>pde. ksPSpace \<sigma> x = Some (KOArch (KOPDE pde))) \<longrightarrow>
|
|
(\<exists>pde'. ksPSpace \<sigma> (x && ~~ mask pd_bits) =
|
|
Some (KOArch (KOPDE pde')))"
|
|
assumes pspace_aligned': "pspace_aligned' \<sigma>"
|
|
|
|
shows
|
|
"pspace_relation
|
|
(%x. case ksPSpace \<sigma> x of
|
|
Some (KOArch ako) \<Rightarrow>
|
|
map_option ArchObj (absHeapArch (ksPSpace \<sigma>) x ako)
|
|
| _ \<Rightarrow> None)
|
|
(%x. case ksPSpace \<sigma> x of Some (KOArch _) \<Rightarrow> ksPSpace \<sigma> x | _ \<Rightarrow> None)"
|
|
supply image_cong_simp [cong del]
|
|
apply (clarsimp simp add: pspace_relation_def dom_def)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp add: pspace_dom_def dom_def UNION_eq)
|
|
apply (rule Collect_cong)
|
|
apply (rule iffI)
|
|
apply (erule exE)
|
|
apply (case_tac "ksPSpace \<sigma> x", simp+)
|
|
apply (clarsimp split: option.splits Structures_H.kernel_object.splits)
|
|
apply (rename_tac arch_kernel_object aa b z)
|
|
apply (simp add: absHeapArch_def)
|
|
apply (case_tac arch_kernel_object)
|
|
apply (clarsimp split: asidpool.splits)
|
|
apply (clarsimp split: if_split_asm)
|
|
using ptes
|
|
apply (erule_tac x=x in allE)
|
|
apply simp
|
|
apply (erule_tac x=y in allE)
|
|
apply clarsimp
|
|
apply (clarsimp split: if_split_asm)
|
|
using pdes
|
|
apply (erule_tac x=x in allE)
|
|
apply simp
|
|
apply (erule_tac x=y in allE)
|
|
apply clarsimp
|
|
apply (clarsimp split: option.splits Structures_H.kernel_object.splits)
|
|
apply (clarsimp simp add: absHeapArch_def)
|
|
apply (rename_tac arch_kernel_object)
|
|
apply (case_tac arch_kernel_object)
|
|
apply (rule_tac x=y in exI)
|
|
apply (clarsimp split: asidpool.splits)
|
|
using fst_pte
|
|
apply (erule_tac x=y in allE)
|
|
apply (clarsimp split: if_split_asm)
|
|
apply (rule_tac x="(y && ~~ mask pt_bits)" in exI, simp)
|
|
apply (simp add: range_composition[symmetric])
|
|
apply (rule_tac x="ucast (y >> 2)" in range_eqI)
|
|
apply (simp add: pt_bits_def pageBits_def)
|
|
apply (simp add: word_size ucast_ucast_mask and_mask_shiftl_comm)
|
|
using pspace_aligned'
|
|
apply (simp add: pspace_aligned'_def dom_def)
|
|
apply (erule_tac x=y in allE)
|
|
apply (simp add: objBitsKO_def archObjSize_def is_aligned_neg_mask_eq pteBits_def
|
|
and_not_mask[symmetric] AND_NOT_mask_plus_AND_mask_eq)
|
|
using fst_pde
|
|
apply (erule_tac x=y in allE)
|
|
apply clarsimp
|
|
apply (rule_tac x="(y && ~~ mask pd_bits)" in exI, simp)
|
|
apply (simp add: range_composition[symmetric])
|
|
apply (rule_tac x="ucast (y >> 2)" in range_eqI)
|
|
apply (simp add: pd_bits_def pageBits_def)
|
|
apply (simp add: word_size ucast_ucast_mask and_mask_shiftl_comm)
|
|
using pspace_aligned'
|
|
apply (simp add: pspace_aligned'_def dom_def)
|
|
apply (erule_tac x=y in allE)
|
|
apply (simp add: objBitsKO_def archObjSize_def is_aligned_neg_mask_eq pdeBits_def
|
|
and_not_mask[symmetric] AND_NOT_mask_plus_AND_mask_eq)
|
|
apply (simp split: option.splits Structures_H.kernel_object.splits)
|
|
apply (intro allI)
|
|
apply (intro impI)
|
|
apply (elim exE)
|
|
apply (clarsimp split: option.splits Structures_H.kernel_object.splits)
|
|
apply (simp add: absHeapArch_def)
|
|
apply (rename_tac arch_kernel_object z a b)
|
|
apply (case_tac arch_kernel_object)
|
|
apply (clarsimp split: asidpool.splits)
|
|
apply (simp add: other_obj_relation_def asid_pool_relation_def o_def inv_def)
|
|
apply simp
|
|
apply (clarsimp simp: pte_relation_def pte_relation_aligned_def
|
|
split: if_split_asm)
|
|
using ptes
|
|
apply (erule_tac x=x in allE)
|
|
apply simp
|
|
apply (erule_tac x=y in allE)
|
|
apply clarsimp
|
|
apply (rule_tac x=pte' in exI)
|
|
apply (simp add: absPageTable_def split: option.splits ARM_H.pte.splits)
|
|
apply (clarsimp simp add: vmrights_map_def vm_rights_of_def
|
|
vm_kernel_only_def vm_read_only_def vm_read_write_def
|
|
split: vmrights.splits)
|
|
using pte_rights
|
|
apply -[1]
|
|
apply (erule_tac x="x + (ucast y << 2)" in allE)+
|
|
subgoal by fastforce
|
|
apply (clarsimp split: if_split_asm)
|
|
using pdes
|
|
apply (erule_tac x=x in allE)
|
|
apply simp
|
|
apply (erule_tac x=y in allE)
|
|
apply clarsimp
|
|
apply (simp add: pde_relation_def pde_relation_aligned_def)
|
|
apply (simp add: absPageDirectory_def
|
|
split: option.splits ARM_H.pde.splits)
|
|
apply (clarsimp simp add: vmrights_map_def vm_rights_of_def
|
|
vm_kernel_only_def vm_read_only_def vm_read_write_def
|
|
split: vmrights.splits)
|
|
using pde_rights
|
|
apply -[1]
|
|
apply (erule_tac x="x + (ucast y << 2)" in allE)+
|
|
apply fastforce
|
|
done
|
|
|
|
definition
|
|
"EndpointMap ep \<equiv> case ep of
|
|
Structures_H.IdleEP \<Rightarrow> Structures_A.IdleEP
|
|
| Structures_H.SendEP q \<Rightarrow> Structures_A.SendEP q
|
|
| Structures_H.RecvEP q \<Rightarrow> Structures_A.RecvEP q"
|
|
|
|
definition
|
|
"AEndpointMap ntfn \<equiv>
|
|
\<lparr> ntfn_obj = case ntfnObj ntfn of
|
|
Structures_H.IdleNtfn \<Rightarrow> Structures_A.IdleNtfn
|
|
| Structures_H.WaitingNtfn q \<Rightarrow> Structures_A.WaitingNtfn q
|
|
| Structures_H.ActiveNtfn b \<Rightarrow> Structures_A.ActiveNtfn b
|
|
, ntfn_bound_tcb = ntfnBoundTCB ntfn \<rparr>"
|
|
|
|
fun
|
|
CapabilityMap :: "capability \<Rightarrow> cap"
|
|
where
|
|
"CapabilityMap capability.NullCap = cap.NullCap"
|
|
| "CapabilityMap (capability.UntypedCap d ref n idx) = cap.UntypedCap d ref n idx"
|
|
| "CapabilityMap (capability.EndpointCap ref b sr rr gr grr) =
|
|
cap.EndpointCap ref b {x. sr \<and> x = AllowSend \<or> rr \<and> x = AllowRecv \<or>
|
|
gr \<and> x = AllowGrant \<or> grr \<and> x = AllowGrantReply}"
|
|
| "CapabilityMap (capability.NotificationCap ref b sr rr) =
|
|
cap.NotificationCap ref b {x. sr \<and> x = AllowSend \<or> rr \<and> x = AllowRecv}"
|
|
| "CapabilityMap (capability.CNodeCap ref n L l) =
|
|
cap.CNodeCap ref n (bin_to_bl l (uint L))"
|
|
| "CapabilityMap (capability.ThreadCap ref) = cap.ThreadCap ref"
|
|
| "CapabilityMap capability.DomainCap = cap.DomainCap"
|
|
| "CapabilityMap (capability.ReplyCap ref master gr) =
|
|
cap.ReplyCap ref master {x. gr \<and> x = AllowGrant \<or> x = AllowWrite}"
|
|
| "CapabilityMap capability.IRQControlCap = cap.IRQControlCap"
|
|
| "CapabilityMap (capability.IRQHandlerCap irq) = cap.IRQHandlerCap irq"
|
|
| "CapabilityMap (capability.Zombie p b n) =
|
|
cap.Zombie p (case b of ZombieTCB \<Rightarrow> None | ZombieCNode n \<Rightarrow> Some n) n"
|
|
| "CapabilityMap (capability.ArchObjectCap (arch_capability.ASIDPoolCap x y)) =
|
|
cap.ArchObjectCap (arch_cap.ASIDPoolCap x y)"
|
|
| "CapabilityMap (capability.ArchObjectCap (arch_capability.ASIDControlCap)) =
|
|
cap.ArchObjectCap (arch_cap.ASIDControlCap)"
|
|
| "CapabilityMap (capability.ArchObjectCap
|
|
(arch_capability.PageCap d word rghts sz data)) =
|
|
cap.ArchObjectCap (arch_cap.PageCap d word (vm_rights_of rghts) sz data)"
|
|
| "CapabilityMap (capability.ArchObjectCap
|
|
(arch_capability.PageTableCap word data)) =
|
|
cap.ArchObjectCap (arch_cap.PageTableCap word data)"
|
|
| "CapabilityMap (capability.ArchObjectCap
|
|
(arch_capability.PageDirectoryCap word data)) =
|
|
cap.ArchObjectCap (arch_cap.PageDirectoryCap word data)"
|
|
|
|
(* FIXME: wellformed_cap_simps has lots of duplicates. *)
|
|
lemma cap_relation_imp_CapabilityMap:
|
|
"\<lbrakk>wellformed_cap c; cap_relation c c'\<rbrakk> \<Longrightarrow> CapabilityMap c' = c"
|
|
apply (case_tac c; simp add: wellformed_cap_simps)
|
|
apply (rule set_eqI, clarsimp)
|
|
apply (case_tac "x", simp_all)
|
|
apply (rule set_eqI, clarsimp)
|
|
apply (case_tac "x", simp_all add: word_bits_def)
|
|
apply clarsimp
|
|
apply (simp add: set_eq_iff, rule allI)
|
|
apply (case_tac x; clarsimp)
|
|
apply (simp add: uint_of_bl_is_bl_to_bin bl_bin_bl[simplified])
|
|
apply (simp add: zbits_map_def split: option.splits)
|
|
apply (rename_tac arch_cap)
|
|
apply clarsimp
|
|
apply (case_tac arch_cap, simp_all add: wellformed_cap_simps)
|
|
done
|
|
|
|
primrec
|
|
ThStateMap :: "Structures_H.thread_state \<Rightarrow> Structures_A.thread_state"
|
|
where
|
|
"ThStateMap Structures_H.thread_state.Running =
|
|
Structures_A.thread_state.Running"
|
|
| "ThStateMap Structures_H.thread_state.Restart =
|
|
Structures_A.thread_state.Restart"
|
|
| "ThStateMap Structures_H.thread_state.Inactive =
|
|
Structures_A.thread_state.Inactive"
|
|
| "ThStateMap Structures_H.thread_state.IdleThreadState =
|
|
Structures_A.thread_state.IdleThreadState"
|
|
| "ThStateMap Structures_H.thread_state.BlockedOnReply =
|
|
Structures_A.thread_state.BlockedOnReply"
|
|
| "ThStateMap (Structures_H.thread_state.BlockedOnReceive oref grant) =
|
|
Structures_A.thread_state.BlockedOnReceive oref \<lparr> receiver_can_grant = grant \<rparr>"
|
|
| "ThStateMap (Structures_H.thread_state.BlockedOnSend oref badge grant grant_reply call) =
|
|
Structures_A.thread_state.BlockedOnSend oref
|
|
\<lparr> sender_badge = badge,
|
|
sender_can_grant = grant,
|
|
sender_can_grant_reply = grant_reply,
|
|
sender_is_call = call \<rparr>"
|
|
| "ThStateMap (Structures_H.thread_state.BlockedOnNotification oref) =
|
|
Structures_A.thread_state.BlockedOnNotification oref"
|
|
|
|
lemma thread_state_relation_imp_ThStateMap:
|
|
"thread_state_relation ts ts' \<Longrightarrow> ThStateMap ts' = ts"
|
|
by (cases ts) simp_all
|
|
|
|
definition
|
|
"LookupFailureMap \<equiv> \<lambda>lf. case lf of
|
|
Fault_H.lookup_failure.InvalidRoot \<Rightarrow>
|
|
ExceptionTypes_A.lookup_failure.InvalidRoot
|
|
| Fault_H.lookup_failure.MissingCapability n \<Rightarrow>
|
|
ExceptionTypes_A.lookup_failure.MissingCapability n
|
|
| Fault_H.lookup_failure.DepthMismatch n m \<Rightarrow>
|
|
ExceptionTypes_A.lookup_failure.DepthMismatch n m
|
|
| Fault_H.lookup_failure.GuardMismatch n g l \<Rightarrow>
|
|
ExceptionTypes_A.lookup_failure.GuardMismatch n (bin_to_bl l (uint g))"
|
|
|
|
lemma LookupFailureMap_lookup_failure_map:
|
|
"(\<forall>n g. lf = ExceptionTypes_A.GuardMismatch n g \<longrightarrow> length g \<le> 32)
|
|
\<Longrightarrow> LookupFailureMap (lookup_failure_map lf) = lf"
|
|
by (clarsimp simp add: LookupFailureMap_def lookup_failure_map_def
|
|
uint_of_bl_is_bl_to_bin
|
|
simp del: bin_to_bl_def
|
|
split: ExceptionTypes_A.lookup_failure.splits)
|
|
|
|
primrec
|
|
ArchFaultMap :: "Fault_H.arch_fault \<Rightarrow> ExceptionTypes_A.arch_fault"
|
|
where
|
|
"ArchFaultMap (ArchFault_H.ARM_H.arch_fault.VMFault p m) = Machine_A.ARM_A.arch_fault.VMFault p m"
|
|
|
|
|
|
primrec
|
|
FaultMap :: "Fault_H.fault \<Rightarrow> ExceptionTypes_A.fault"
|
|
where
|
|
"FaultMap (Fault_H.fault.CapFault ref b failure) =
|
|
ExceptionTypes_A.fault.CapFault ref b (LookupFailureMap failure)"
|
|
| "FaultMap (Fault_H.fault.ArchFault fault) =
|
|
ExceptionTypes_A.fault.ArchFault (ArchFaultMap fault)"
|
|
| "FaultMap (Fault_H.fault.UnknownSyscallException n) =
|
|
ExceptionTypes_A.fault.UnknownSyscallException n"
|
|
| "FaultMap (Fault_H.fault.UserException x y) =
|
|
ExceptionTypes_A.fault.UserException x y"
|
|
|
|
lemma ArchFaultMap_arch_fault_map: "ArchFaultMap (arch_fault_map f) = f"
|
|
by (cases f, simp add: ArchFaultMap_def arch_fault_map_def)
|
|
|
|
lemma FaultMap_fault_map[simp]:
|
|
"valid_fault ft \<Longrightarrow> FaultMap (fault_map ft) = ft"
|
|
apply (case_tac ft, simp_all)
|
|
apply (simp add: valid_fault_def LookupFailureMap_lookup_failure_map word_bits_def)
|
|
apply (rule ArchFaultMap_arch_fault_map)
|
|
done
|
|
|
|
definition
|
|
"ArchTcbMap atcb \<equiv>
|
|
\<lparr> tcb_context = atcbContext atcb \<rparr>"
|
|
|
|
lemma arch_tcb_relation_imp_ArchTcnMap:
|
|
"\<lbrakk> arch_tcb_relation atcb atcb'\<rbrakk> \<Longrightarrow> ArchTcbMap atcb' = atcb"
|
|
by (clarsimp simp: arch_tcb_relation_def ArchTcbMap_def)
|
|
|
|
definition
|
|
"TcbMap tcb \<equiv>
|
|
\<lparr>tcb_ctable = CapabilityMap (cteCap (tcbCTable tcb)),
|
|
tcb_vtable = CapabilityMap (cteCap (tcbVTable tcb)),
|
|
tcb_reply = CapabilityMap (cteCap (tcbReply tcb)),
|
|
tcb_caller = CapabilityMap (cteCap (tcbCaller tcb)),
|
|
tcb_ipcframe = CapabilityMap (cteCap (tcbIPCBufferFrame tcb)),
|
|
tcb_state = ThStateMap (tcbState tcb),
|
|
tcb_fault_handler = to_bl (tcbFaultHandler tcb),
|
|
tcb_ipc_buffer = tcbIPCBuffer tcb,
|
|
tcb_fault = map_option FaultMap (tcbFault tcb),
|
|
tcb_bound_notification = tcbBoundNotification tcb,
|
|
tcb_mcpriority = tcbMCP tcb,
|
|
tcb_arch = ArchTcbMap (tcbArch tcb)\<rparr>"
|
|
|
|
definition
|
|
"absCNode sz h a \<equiv> CNode sz (%bl.
|
|
if length bl = sz
|
|
then Some (CapabilityMap (case (h (a + of_bl bl * 2^cteSizeBits)) of
|
|
Some (KOCTE cte) \<Rightarrow> cteCap cte))
|
|
else None)"
|
|
|
|
definition
|
|
absHeap :: "(word32 \<rightharpoonup> vmpage_size) \<Rightarrow> (word32 \<rightharpoonup> nat) \<Rightarrow>
|
|
(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> Structures_A.kheap"
|
|
where
|
|
"absHeap ups cns h \<equiv> \<lambda>x.
|
|
case h x of
|
|
Some (KOEndpoint ep) \<Rightarrow> Some (Endpoint (EndpointMap ep))
|
|
| Some (KONotification ntfn) \<Rightarrow> Some (Notification (AEndpointMap ntfn))
|
|
| Some KOKernelData \<Rightarrow> undefined \<comment> \<open>forbidden by pspace_relation\<close>
|
|
| Some KOUserData \<Rightarrow> map_option (ArchObj \<circ> DataPage False) (ups x)
|
|
| Some KOUserDataDevice \<Rightarrow> map_option (ArchObj \<circ> DataPage True) (ups x)
|
|
| Some (KOTCB tcb) \<Rightarrow> Some (TCB (TcbMap tcb))
|
|
| Some (KOCTE cte) \<Rightarrow> map_option (%sz. absCNode sz h x) (cns x)
|
|
| Some (KOArch ako) \<Rightarrow> map_option ArchObj (absHeapArch h x ako)
|
|
| None \<Rightarrow> None"
|
|
|
|
lemma unaligned_page_offsets_helper:
|
|
"\<lbrakk>is_aligned y (pageBitsForSize vmpage_size); n\<noteq>0;
|
|
n < 2 ^ (pageBitsForSize vmpage_size - pageBits)\<rbrakk>
|
|
\<Longrightarrow> \<not> is_aligned (y + n * 2 ^ pageBits :: word32) (pageBitsForSize vmpage_size)"
|
|
apply (simp (no_asm_simp) add: is_aligned_mask)
|
|
apply (simp add: mask_add_aligned)
|
|
apply (cut_tac mask_eq_iff_w2p [of "pageBitsForSize vmpage_size" "n * 2 ^ pageBits"])
|
|
prefer 2
|
|
apply (case_tac vmpage_size, simp_all add: pageBits_def word_size)
|
|
apply (cut_tac word_power_nonzero_32[of n pageBits];
|
|
simp add: word_bits_conv pageBits_def)
|
|
prefer 2
|
|
apply (case_tac vmpage_size, simp_all add: pageBits_def word_size)
|
|
apply (frule less_trans[of n _ "0x100000"], simp+)+
|
|
apply clarsimp
|
|
apply (case_tac vmpage_size, simp_all add: pageBits_def)
|
|
apply (frule_tac i=n and k="0x1000" in word_mult_less_mono1, simp+)+
|
|
done
|
|
|
|
(* FIXME: move *)
|
|
lemma unaligned_helper:
|
|
"\<lbrakk>is_aligned x n; y\<noteq>0; y < 2 ^ n\<rbrakk> \<Longrightarrow> \<not> is_aligned (x + y) n"
|
|
apply (simp (no_asm_simp) add: is_aligned_mask)
|
|
apply (simp add: mask_add_aligned)
|
|
apply (cut_tac mask_eq_iff_w2p[of n y], simp_all add: word_size)
|
|
apply (rule ccontr)
|
|
apply (simp add: not_less power_overflow word_bits_conv)
|
|
done
|
|
|
|
lemma pspace_aligned_distinct_None:
|
|
(* NOTE: life would be easier if pspace_aligned and pspace_distinct were defined on PSpace instead of the whole kernel state. *)
|
|
assumes pspace_aligned:
|
|
"\<forall>x\<in>dom ha. is_aligned (x :: word32) (obj_bits (the (ha x)))"
|
|
assumes pspace_distinct:
|
|
"\<forall>x y ko ko'.
|
|
ha x = Some ko \<and> ha y = Some ko' \<and> x \<noteq> y \<longrightarrow>
|
|
{x..x + (2 ^ obj_bits ko - 1)} \<inter> {y..y + (2 ^ obj_bits ko' - 1)} = {}"
|
|
shows
|
|
"\<lbrakk>ha x = Some ko; y \<in> {0<..<2^(obj_bits ko)}\<rbrakk> \<Longrightarrow> ha (x+y) = None"
|
|
using pspace_aligned[simplified dom_def, simplified]
|
|
apply (erule_tac x=x in allE)
|
|
apply (rule ccontr)
|
|
apply clarsimp
|
|
apply (rename_tac ko')
|
|
using pspace_distinct pspace_aligned[simplified dom_def, simplified]
|
|
apply (erule_tac x=x in allE)
|
|
apply (erule_tac x="x+y" in allE)+
|
|
apply (clarsimp simp add: word_gt_0)
|
|
apply (clarsimp simp add: ucast_of_nat_small is_aligned_mask mask_2pm1[symmetric])
|
|
apply (frule (1) is_aligned_AND_less_0)
|
|
apply (clarsimp simp add: word_plus_and_or_coroll le_word_or2)
|
|
apply (simp add: word_bool_alg.disj_assoc le_word_or2)
|
|
apply (simp add: word_plus_and_or_coroll[symmetric])
|
|
apply (subgoal_tac "x + y \<le> x + mask (obj_bits ko)", simp)
|
|
apply (rule word_add_le_mono2)
|
|
apply (simp add: mask_def plus_one_helper)
|
|
apply (thin_tac "~ P" for P)+
|
|
apply (thin_tac "(x::'a::len word) < y" for x y)+
|
|
apply (thin_tac "x = Some y" for x y)+
|
|
apply (thin_tac "x && mask (obj_bits ko') = 0" for x)
|
|
apply (thin_tac "x && y = 0")
|
|
apply (clarsimp simp add: dvd_def word_bits_len_of word_bits_conv
|
|
and_mask_dvd_nat[symmetric])
|
|
apply (cut_tac x=x in unat_lt2p)
|
|
apply (cut_tac x="mask (obj_bits ko)::word32" in unat_lt2p)
|
|
apply (simp add: mult.commute
|
|
add.commute[of "unat (mask (obj_bits ko))"])
|
|
apply (case_tac "k=0", simp+)
|
|
apply (subgoal_tac "obj_bits ko\<le>32")
|
|
prefer 2
|
|
apply (rule ccontr)
|
|
apply (simp add: not_le)
|
|
apply (frule_tac a="2::nat" and n=32 in power_strict_increasing, simp+)
|
|
apply (case_tac "k=1", simp)
|
|
apply (cut_tac m=k and n="2 ^ obj_bits ko" in n_less_n_mult_m,
|
|
(simp(no_asm_simp))+)
|
|
apply (simp only: mult.commute)
|
|
apply (thin_tac "x = y" for x y)+
|
|
apply (clarsimp simp add: le_less)
|
|
apply (erule disjE)
|
|
prefer 2
|
|
apply (simp add: mask_def)
|
|
apply (subgoal_tac "obj_bits ko <= (31::nat)", simp_all)
|
|
apply (simp add: mask_def unat_minus_one word_bits_conv)
|
|
apply (cut_tac w=k and c="2 ^ obj_bits ko" and b="2^(32-obj_bits ko)"
|
|
in less_le_mult_nat)
|
|
apply (simp_all add: power_add[symmetric])
|
|
apply (rule ccontr)
|
|
apply (simp add: not_less)
|
|
apply (simp add: le_less[of "2 ^ (32 - obj_bits ko)"])
|
|
apply (erule disjE)
|
|
prefer 2
|
|
apply (clarsimp simp add: power_add[symmetric])
|
|
apply clarsimp
|
|
apply (drule mult_less_mono1[of "2 ^ (32 - obj_bits ko)" _ "2 ^ obj_bits ko"])
|
|
apply (simp add: power_add[symmetric])+
|
|
done
|
|
|
|
lemma pspace_aligned_distinct_None':
|
|
assumes pspace_aligned: "pspace_aligned s"
|
|
assumes pspace_distinct: "pspace_distinct s"
|
|
shows
|
|
"\<lbrakk>kheap s x = Some ko; y \<in> {0<..<2^(obj_bits ko)}\<rbrakk> \<Longrightarrow> kheap s (x+y) = None"
|
|
apply (rule pspace_aligned_distinct_None)
|
|
apply (rule pspace_aligned[simplified pspace_aligned_def])
|
|
apply (rule pspace_distinct[simplified pspace_distinct_def])
|
|
apply assumption+
|
|
done
|
|
|
|
lemma absHeap_correct:
|
|
assumes pspace_aligned: "pspace_aligned s"
|
|
assumes pspace_distinct: "pspace_distinct s"
|
|
assumes valid_objs: "valid_objs s"
|
|
assumes pspace_relation: "pspace_relation (kheap s) (ksPSpace s')"
|
|
assumes ghost_relation: "ghost_relation (kheap s) (gsUserPages s') (gsCNodes s')"
|
|
shows
|
|
"absHeap (gsUserPages s') (gsCNodes s') (ksPSpace s') = kheap s"
|
|
proof -
|
|
from ghost_relation
|
|
have gsUserPages:
|
|
"\<And>a sz. (\<exists>dev. kheap s a = Some (ArchObj (DataPage dev sz))) \<longleftrightarrow>
|
|
gsUserPages s' a = Some sz"
|
|
and gsCNodes:
|
|
"\<And>a n. (\<exists>cs. kheap s a = Some (CNode n cs) \<and> well_formed_cnode_n n cs) \<longleftrightarrow>
|
|
gsCNodes s' a = Some n"
|
|
by (fastforce simp add: ghost_relation_def)+
|
|
|
|
show "?thesis"
|
|
supply image_cong_simp [cong del]
|
|
apply (rule ext)
|
|
apply (simp add: absHeap_def split: option.splits)
|
|
apply (rule conjI)
|
|
using pspace_relation
|
|
apply (clarsimp simp add: pspace_relation_def pspace_dom_def UNION_eq
|
|
dom_def Collect_eq)
|
|
apply (erule_tac x=x in allE)
|
|
apply clarsimp
|
|
apply (case_tac "kheap s x", simp)
|
|
apply (erule_tac x=x in allE, clarsimp)
|
|
apply (erule_tac x=x in allE, simp add: Ball_def)
|
|
apply (erule_tac x=x in allE, clarsimp)
|
|
|
|
apply (case_tac a)
|
|
apply (simp_all add: other_obj_relation_def
|
|
split: if_split_asm Structures_H.kernel_object.splits)
|
|
apply (rename_tac sz cs)
|
|
apply (clarsimp simp add: image_def cte_map_def
|
|
well_formed_cnode_n_def Collect_eq dom_def)
|
|
apply (erule_tac x="replicate sz False" in allE)+
|
|
apply simp
|
|
apply (rename_tac arch_kernel_obj)
|
|
apply (case_tac arch_kernel_obj, simp_all add: image_def)
|
|
apply (erule_tac x=0 in allE, simp)
|
|
apply (erule_tac x=0 in allE, simp)
|
|
apply clarsimp
|
|
apply (erule_tac x=0 in allE, simp add: pageBits_def)
|
|
apply (rename_tac vmpage_size)
|
|
apply (case_tac vmpage_size, simp_all)
|
|
|
|
apply clarsimp
|
|
apply (intro conjI impI allI)
|
|
apply (erule pspace_dom_relatedE[OF _ pspace_relation])
|
|
apply clarsimp
|
|
apply (case_tac ko, simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: cte_relation_def split: if_split_asm)
|
|
apply (clarsimp simp add: ep_relation_def EndpointMap_def
|
|
split: Structures_A.endpoint.splits)
|
|
apply (clarsimp simp add: EndpointMap_def
|
|
split: Structures_A.endpoint.splits)
|
|
apply (rename_tac arch_kernel_obj)
|
|
apply (case_tac arch_kernel_obj,
|
|
simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: pte_relation_def)
|
|
apply (clarsimp simp add: pde_relation_def)
|
|
apply (clarsimp split: if_split_asm)+
|
|
|
|
apply (erule pspace_dom_relatedE[OF _ pspace_relation])
|
|
apply (case_tac ko, simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: cte_relation_def split: if_split_asm)
|
|
apply (clarsimp simp add: ntfn_relation_def AEndpointMap_def
|
|
split: Structures_A.ntfn.splits)
|
|
apply (clarsimp simp add: AEndpointMap_def
|
|
split: Structures_A.ntfn.splits)
|
|
apply (rename_tac arch_kernel_obj)
|
|
apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: pte_relation_def)
|
|
apply (clarsimp simp add: pde_relation_def)
|
|
apply (clarsimp split: if_split_asm)+
|
|
|
|
apply (erule pspace_dom_relatedE[OF _ pspace_relation])
|
|
apply (case_tac ko, simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: cte_relation_def split: if_split_asm)
|
|
apply (rename_tac arch_kernel_obj)
|
|
apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: pte_relation_def)
|
|
apply (clarsimp simp add: pde_relation_def)
|
|
apply (clarsimp split: if_split_asm)+
|
|
|
|
apply (erule pspace_dom_relatedE[OF _ pspace_relation])
|
|
apply (case_tac ko, simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: cte_relation_def split: if_split_asm)
|
|
apply (rename_tac arch_kernel_obj)
|
|
apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: pte_relation_def)
|
|
apply (clarsimp simp add: pde_relation_def)
|
|
apply (rename_tac vmpage_size)
|
|
apply (cut_tac a=y and sz=vmpage_size in gsUserPages, clarsimp split: if_split_asm)
|
|
apply (case_tac "n=0", simp)
|
|
apply (case_tac "kheap s (y + n * 2 ^ pageBits)")
|
|
apply (rule ccontr)
|
|
apply (clarsimp dest!: gsUserPages[symmetric, THEN iffD1] )
|
|
using pspace_aligned
|
|
apply (simp add: pspace_aligned_def dom_def)
|
|
apply (erule_tac x=y in allE)
|
|
apply (case_tac "n=0",(simp split: if_split_asm)+)
|
|
apply (frule (2) unaligned_page_offsets_helper)
|
|
apply (frule_tac y="n*2^pageBits" in pspace_aligned_distinct_None'
|
|
[OF pspace_aligned pspace_distinct])
|
|
apply simp
|
|
apply (rule conjI, clarsimp simp add: word_gt_0)
|
|
apply (simp add: is_aligned_mask)
|
|
apply (clarsimp simp add: pageBits_def mask_def)
|
|
apply (case_tac vmpage_size; simp)
|
|
apply ((frule_tac i=n and k="0x1000" in word_mult_less_mono1, simp+)+)[4]
|
|
apply (erule pspace_dom_relatedE[OF _ pspace_relation])
|
|
apply (case_tac ko, simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: cte_relation_def split: if_split_asm)
|
|
apply (rename_tac arch_kernel_obj)
|
|
apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: pte_relation_def)
|
|
apply (clarsimp simp add: pde_relation_def)
|
|
apply (rename_tac vmpage_size)
|
|
apply (cut_tac a=y and sz=vmpage_size in gsUserPages, clarsimp split: if_split_asm)
|
|
apply (case_tac "n=0", simp)
|
|
apply (case_tac "kheap s (y + n * 2 ^ pageBits)")
|
|
apply (rule ccontr)
|
|
apply (clarsimp dest!: gsUserPages[symmetric, THEN iffD1])
|
|
using pspace_aligned
|
|
apply (simp add: pspace_aligned_def dom_def)
|
|
apply (erule_tac x=y in allE)
|
|
apply (case_tac "n=0",simp+)
|
|
apply (frule (2) unaligned_page_offsets_helper)
|
|
apply (frule_tac y="n*2^pageBits" in pspace_aligned_distinct_None'
|
|
[OF pspace_aligned pspace_distinct])
|
|
apply simp
|
|
apply (rule conjI, clarsimp simp add: word_gt_0)
|
|
apply (simp add: is_aligned_mask)
|
|
apply (clarsimp simp add: pageBits_def mask_def)
|
|
apply (case_tac vmpage_size; simp)
|
|
apply ((frule_tac i=n and k="0x1000" in word_mult_less_mono1, simp+)+)[4]
|
|
apply (erule pspace_dom_relatedE[OF _ pspace_relation])
|
|
apply (case_tac ko, simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: cte_relation_def split: if_split_asm)
|
|
prefer 2
|
|
apply (rename_tac arch_kernel_obj)
|
|
apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: pte_relation_def)
|
|
apply (clarsimp simp add: pde_relation_def)
|
|
apply (clarsimp split: if_split_asm)
|
|
apply (clarsimp simp add: TcbMap_def tcb_relation_def valid_obj_def)
|
|
apply (rename_tac tcb y tcb')
|
|
apply (case_tac tcb)
|
|
apply (case_tac tcb')
|
|
apply (simp add: thread_state_relation_imp_ThStateMap)
|
|
apply (subgoal_tac "map_option FaultMap (tcbFault tcb) = tcb_fault")
|
|
prefer 2
|
|
apply (simp add: fault_rel_optionation_def)
|
|
using valid_objs[simplified valid_objs_def dom_def fun_app_def,
|
|
simplified]
|
|
apply (erule_tac x=y in allE)
|
|
apply (clarsimp simp: valid_obj_def valid_tcb_def
|
|
split: option.splits)
|
|
using valid_objs[simplified valid_objs_def Ball_def dom_def fun_app_def]
|
|
apply (erule_tac x=y in allE)
|
|
apply (clarsimp simp add: cap_relation_imp_CapabilityMap valid_obj_def
|
|
valid_tcb_def ran_tcb_cap_cases valid_cap_def2
|
|
arch_tcb_relation_imp_ArchTcnMap)
|
|
apply (simp add: absCNode_def cte_map_def)
|
|
apply (erule pspace_dom_relatedE[OF _ pspace_relation])
|
|
apply (case_tac ko, simp_all add: other_obj_relation_def
|
|
split: if_split_asm)
|
|
prefer 2
|
|
apply (rename_tac arch_kernel_obj)
|
|
apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: pte_relation_def)
|
|
apply (clarsimp simp add: pde_relation_def)
|
|
apply (clarsimp split: if_split_asm)
|
|
apply (simp add: cte_map_def)
|
|
apply (clarsimp simp add: cte_relation_def)
|
|
apply (cut_tac a=y and n=sz in gsCNodes, clarsimp)
|
|
using pspace_aligned[simplified pspace_aligned_def]
|
|
apply (drule_tac x=y in bspec, clarsimp)
|
|
apply clarsimp
|
|
apply (case_tac "(of_bl ya::word32) * 2^cte_level_bits = 0", simp)
|
|
apply (rule ext)
|
|
apply simp
|
|
apply (rule conjI)
|
|
prefer 2
|
|
using valid_objs[simplified valid_objs_def Ball_def dom_def
|
|
fun_app_def]
|
|
apply (erule_tac x=y in allE)
|
|
apply (clarsimp simp add: valid_obj_def valid_cs_def valid_cs_size_def
|
|
well_formed_cnode_n_def dom_def Collect_eq)
|
|
apply (frule_tac x=ya in spec, simp)
|
|
apply (erule_tac x=bl in allE)
|
|
apply clarsimp+
|
|
apply (frule pspace_relation_absD[OF _ pspace_relation])
|
|
apply (simp add: cte_map_def)
|
|
apply (drule_tac x="y + of_bl bl * 2^cte_level_bits" in spec)
|
|
apply clarsimp
|
|
apply (erule_tac x="cte_relation bl" in allE)
|
|
apply (erule impE)
|
|
apply (fastforce simp add: well_formed_cnode_n_def)
|
|
apply clarsimp
|
|
apply (clarsimp simp add: cte_relation_def)
|
|
apply (rule cap_relation_imp_CapabilityMap)
|
|
using valid_objs[simplified valid_objs_def Ball_def dom_def
|
|
fun_app_def]
|
|
apply (erule_tac x=y in allE)
|
|
apply (clarsimp simp: valid_obj_def valid_cs_def valid_cap_def2 ran_def)
|
|
apply (fastforce simp: cte_level_bits_def cteSizeBits_def)+
|
|
apply (subgoal_tac "kheap s (y + of_bl ya * 2^cte_level_bits) = None")
|
|
prefer 2
|
|
using valid_objs[simplified valid_objs_def Ball_def dom_def fun_app_def]
|
|
apply (erule_tac x=y in allE)
|
|
apply (clarsimp simp add: valid_obj_def valid_cs_def valid_cs_size_def)
|
|
apply (rule pspace_aligned_distinct_None'[OF
|
|
pspace_aligned pspace_distinct], assumption)
|
|
apply (clarsimp simp: word_neq_0_conv power_add cte_index_repair)
|
|
apply (simp add: well_formed_cnode_n_def dom_def Collect_eq)
|
|
apply (erule_tac x=ya in allE)+
|
|
apply (rule word_mult_less_mono1)
|
|
apply (subgoal_tac "sz = length ya")
|
|
apply simp
|
|
apply (rule of_bl_length, (simp add: word_bits_def)+)[1]
|
|
apply fastforce
|
|
apply (simp add: cte_level_bits_def)
|
|
apply (simp add: word_bits_conv cte_level_bits_def)
|
|
apply (drule_tac a="2::nat" in power_strict_increasing, simp+)
|
|
apply (rule ccontr, clarsimp)
|
|
apply (cut_tac a="y + of_bl ya * 2^cte_level_bits" and n=yc in gsCNodes)
|
|
apply clarsimp
|
|
|
|
(* mapping architecture-specific objects *)
|
|
apply clarsimp
|
|
apply (erule pspace_dom_relatedE[OF _ pspace_relation])
|
|
apply (case_tac ko, simp_all add: other_obj_relation_def)
|
|
apply (clarsimp simp add: cte_relation_def split: if_split_asm)
|
|
apply (rename_tac arch_kernel_object y ko P arch_kernel_obj)
|
|
apply (case_tac arch_kernel_object, simp_all add: absHeapArch_def
|
|
split: asidpool.splits)
|
|
|
|
apply clarsimp
|
|
apply (case_tac arch_kernel_obj)
|
|
apply (simp add: other_obj_relation_def asid_pool_relation_def
|
|
inv_def o_def)
|
|
apply (clarsimp simp add: pte_relation_def)
|
|
apply (clarsimp simp add: pde_relation_def)
|
|
apply (clarsimp split: if_split_asm)+
|
|
|
|
apply (case_tac arch_kernel_obj)
|
|
apply (simp add: other_obj_relation_def asid_pool_relation_def inv_def
|
|
o_def)
|
|
using pspace_aligned[simplified pspace_aligned_def Ball_def dom_def]
|
|
apply (erule_tac x=y in allE)
|
|
apply (clarsimp simp add: pte_relation_def absPageTable_def
|
|
pt_bits_def pageBits_def)
|
|
apply (rule conjI)
|
|
prefer 2
|
|
apply clarsimp
|
|
apply (rule sym)
|
|
apply (rule pspace_aligned_distinct_None'
|
|
[OF pspace_aligned pspace_distinct], simp+)
|
|
apply (cut_tac x=ya and n="2^10" in
|
|
ucast_less_shiftl_helper[where 'a=32,simplified word_bits_conv], simp+)
|
|
apply (clarsimp simp add: word_gt_0)
|
|
apply clarsimp
|
|
apply (subgoal_tac "ucast ya << 2 = 0")
|
|
prefer 2
|
|
apply (rule ccontr)
|
|
apply (frule_tac x=y in unaligned_helper, assumption)
|
|
apply (rule ucast_less_shiftl_helper, simp_all)
|
|
apply (rule ext)
|
|
apply (frule pspace_relation_absD[OF _ pspace_relation])
|
|
apply simp
|
|
apply (erule_tac x=offs in allE)
|
|
apply (clarsimp simp add: pte_relation_def)
|
|
using valid_objs[simplified valid_objs_def fun_app_def dom_def,
|
|
simplified]
|
|
apply (erule_tac x=y in allE)
|
|
apply (clarsimp simp add: valid_obj_def wellformed_pte_def)
|
|
apply (erule_tac x=offs in allE)
|
|
apply (rename_tac pte')
|
|
apply (case_tac pte', simp_all add: pte_relation_aligned_def)[1]
|
|
apply (clarsimp split: ARM_A.pte.splits)
|
|
apply (rule set_eqI, clarsimp)
|
|
apply (case_tac x, simp_all)[1]
|
|
apply (clarsimp split: ARM_A.pte.splits)
|
|
apply (rule set_eqI, clarsimp)
|
|
apply (case_tac x, simp_all)[1]
|
|
apply (clarsimp simp add: pde_relation_def)
|
|
apply (clarsimp split: if_split_asm)+
|
|
|
|
apply (case_tac arch_kernel_obj)
|
|
apply (simp add: other_obj_relation_def asid_pool_relation_def inv_def
|
|
o_def)
|
|
apply (clarsimp simp add: pte_relation_def)
|
|
using pspace_aligned
|
|
apply (simp add: pspace_aligned_def dom_def)
|
|
apply (erule_tac x=y in allE)
|
|
apply (clarsimp simp add: pde_relation_def absPageDirectory_def
|
|
pd_bits_def pageBits_def)
|
|
apply (rule conjI)
|
|
prefer 2
|
|
apply clarsimp
|
|
apply (rule sym)
|
|
apply (rule pspace_aligned_distinct_None'
|
|
[OF pspace_aligned pspace_distinct], simp+)
|
|
apply (cut_tac x=ya and n="2^14" in
|
|
ucast_less_shiftl_helper[where 'a=32, simplified word_bits_conv], simp+)
|
|
apply (clarsimp simp add: word_gt_0)
|
|
apply clarsimp
|
|
apply (subgoal_tac "ucast ya << 2 = 0")
|
|
prefer 2
|
|
apply (rule ccontr)
|
|
apply (frule_tac x=y in unaligned_helper, assumption)
|
|
apply (rule ucast_less_shiftl_helper, simp_all)
|
|
apply (rule ext)
|
|
apply (frule pspace_relation_absD[OF _ pspace_relation])
|
|
apply simp
|
|
apply (erule_tac x=offs in allE)
|
|
apply (clarsimp simp add: pde_relation_def)
|
|
|
|
using valid_objs[simplified valid_objs_def fun_app_def dom_def,simplified]
|
|
apply (erule_tac x=y in allE)
|
|
apply (clarsimp simp add: valid_obj_def wellformed_pde_def)
|
|
apply (erule_tac x=offs in allE)
|
|
apply (rename_tac pde')
|
|
apply (case_tac pde', simp_all add: pde_relation_aligned_def)[1]
|
|
apply (clarsimp split: ARM_A.pde.splits)+
|
|
apply (fastforce simp add: subset_eq)
|
|
apply (clarsimp split: ARM_A.pde.splits)
|
|
apply (rule set_eqI, clarsimp)
|
|
apply (case_tac x, simp_all)[1]
|
|
apply (clarsimp split: ARM_A.pde.splits)
|
|
apply (rule set_eqI, clarsimp)
|
|
apply (case_tac x, simp_all)[1]
|
|
apply (clarsimp simp add: pde_relation_def split: if_split_asm)
|
|
done
|
|
qed
|
|
|
|
definition
|
|
"EtcbMap tcb \<equiv>
|
|
\<lparr>tcb_priority = tcbPriority tcb,
|
|
time_slice = tcbTimeSlice tcb,
|
|
tcb_domain = tcbDomain tcb\<rparr>"
|
|
|
|
definition
|
|
absEkheap :: "(word32 \<rightharpoonup> Structures_H.kernel_object) \<Rightarrow> obj_ref \<Rightarrow> etcb option"
|
|
where
|
|
"absEkheap h \<equiv> \<lambda>x.
|
|
case h x of
|
|
Some (KOTCB tcb) \<Rightarrow> Some (EtcbMap tcb)
|
|
| _ \<Rightarrow> None"
|
|
|
|
lemma absEkheap_correct:
|
|
assumes pspace_relation: "pspace_relation (kheap s) (ksPSpace s')"
|
|
assumes ekheap_relation: "ekheap_relation (ekheap s) (ksPSpace s')"
|
|
assumes vetcbs: "valid_etcbs s"
|
|
shows
|
|
"absEkheap (ksPSpace s') = ekheap s"
|
|
apply (rule ext)
|
|
apply (clarsimp simp: absEkheap_def split: option.splits Structures_H.kernel_object.splits)
|
|
apply (subgoal_tac "\<forall>x. (\<exists>tcb. kheap s x = Some (TCB tcb)) =
|
|
(\<exists>tcb'. ksPSpace s' x = Some (KOTCB tcb'))")
|
|
using vetcbs ekheap_relation
|
|
apply (clarsimp simp: valid_etcbs_def is_etcb_at_def dom_def ekheap_relation_def st_tcb_at_def obj_at_def)
|
|
apply (erule_tac x=x in allE)+
|
|
apply (rule conjI, force)
|
|
apply clarsimp
|
|
apply (rule conjI, clarsimp simp: EtcbMap_def etcb_relation_def)+
|
|
apply clarsimp
|
|
using pspace_relation
|
|
apply (clarsimp simp add: pspace_relation_def pspace_dom_def UNION_eq
|
|
dom_def Collect_eq)
|
|
apply (rule iffI)
|
|
apply (erule_tac x=x in allE)+
|
|
apply (case_tac "ksPSpace s' x", clarsimp)
|
|
apply (erule_tac x=x in allE, clarsimp)
|
|
apply clarsimp
|
|
apply (case_tac a, simp_all add: other_obj_relation_def)
|
|
apply (insert pspace_relation)
|
|
apply (clarsimp simp: obj_at'_def projectKOs)
|
|
apply (erule(1) pspace_dom_relatedE)
|
|
apply (erule(1) obj_relation_cutsE)
|
|
apply (clarsimp simp: other_obj_relation_def
|
|
split: Structures_A.kernel_object.split_asm if_split_asm
|
|
ARM_A.arch_kernel_obj.split_asm)+
|
|
done
|
|
|
|
text \<open>The following function can be used to reverse cte_map.\<close>
|
|
definition
|
|
"cteMap cns \<equiv> \<lambda>p.
|
|
let P = (%(a,bl). cte_map (a,bl) = p \<and> cns a = Some (length bl))
|
|
in if \<exists>x. P x then (SOME x. P x)
|
|
else (p && ~~ mask tcbBlockSizeBits, bin_to_bl 3 (uint (p >> cte_level_bits)))"
|
|
|
|
lemma tcb_cap_cases_length:
|
|
"tcb_cap_cases b = Some x \<Longrightarrow> length b = 3"
|
|
by (simp add: tcb_cap_cases_def tcb_cnode_index_def split: if_split_asm)
|
|
|
|
lemma of_bl_mult_and_not_mask_eq:
|
|
"\<lbrakk>is_aligned (a :: word32) n; length b + m \<le> n\<rbrakk>
|
|
\<Longrightarrow> a + of_bl b * (2^m) && ~~ mask n = a"
|
|
apply (simp add: shiftl_t2n[simplified mult.commute, symmetric])
|
|
apply (simp add: mask_out_add_aligned[where q="of_bl b << m", symmetric])
|
|
apply (case_tac "n<32")
|
|
prefer 2
|
|
apply (simp add: not_less power_overflow mask_def)
|
|
apply (simp add: mask_eq_x_eq_0[symmetric])
|
|
apply (rule less_mask_eq)
|
|
apply (rule shiftl_less_t2n, simp_all)
|
|
apply (cut_tac 'a=32 and xs=b in of_bl_length, simp)
|
|
apply (drule nat_move_sub_le)
|
|
apply (drule two_power_increasing[where 'a=32], simp)
|
|
apply (drule (2) less_le_trans)
|
|
done
|
|
|
|
lemma bin_to_bl_of_bl_eq:
|
|
"\<lbrakk>is_aligned (a::'a::len word) n; length b + c \<le> n; length b + c < LENGTH('a)\<rbrakk>
|
|
\<Longrightarrow> bin_to_bl (length b) (uint ((a + of_bl b * 2^c) >> c)) = b"
|
|
apply (subst word_plus_and_or_coroll)
|
|
apply (erule is_aligned_get_word_bits)
|
|
apply (rule is_aligned_AND_less_0)
|
|
apply (simp add: is_aligned_mask)
|
|
apply (rule order_less_le_trans)
|
|
apply (rule of_bl_length2)
|
|
apply (simp add: word_bits_conv cte_level_bits_def)
|
|
apply (simp add: two_power_increasing)
|
|
apply simp
|
|
apply (rule nth_equalityI)
|
|
apply (simp only: len_bin_to_bl)
|
|
apply (clarsimp simp only: len_bin_to_bl nth_bin_to_bl
|
|
word_test_bit_def[symmetric])
|
|
apply (simp add: nth_shiftr nth_shiftl
|
|
shiftl_t2n[where n=c, simplified mult.commute,
|
|
simplified, symmetric])
|
|
apply (simp add: is_aligned_nth[THEN iffD1, rule_format]
|
|
test_bit_of_bl nth_rev)
|
|
apply (case_tac "b ! i", simp_all)
|
|
apply arith
|
|
done
|
|
|
|
lemma TCB_implies_KOTCB:
|
|
"\<lbrakk>pspace_relation (kheap s) (ksPSpace s'); kheap s a = Some (TCB tcb)\<rbrakk>
|
|
\<Longrightarrow> \<exists>tcb'. ksPSpace s' a = Some (KOTCB tcb') \<and> tcb_relation tcb tcb'"
|
|
apply (clarsimp simp add: pspace_relation_def pspace_dom_def
|
|
dom_def UNION_eq Collect_eq)
|
|
apply (erule_tac x=a in allE)+
|
|
apply (clarsimp simp add: other_obj_relation_def
|
|
split: Structures_H.kernel_object.splits)
|
|
apply (drule iffD1)
|
|
apply (fastforce simp add: dom_def image_def)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma cte_at_CNodeI:
|
|
"\<lbrakk>kheap s a = Some (CNode (length b) cs); well_formed_cnode_n (length b) cs\<rbrakk>
|
|
\<Longrightarrow> cte_at (a,b) s"
|
|
apply (subgoal_tac "\<exists>y. cs b = Some y")
|
|
apply clarsimp
|
|
apply (rule_tac cte=y in cte_wp_at_cteI[of s _ "length b" cs],
|
|
simp_all)
|
|
apply (simp add: well_formed_cnode_n_def dom_def Collect_eq)
|
|
done
|
|
|
|
lemma cteMap_correct:
|
|
assumes rel: "(s,s') \<in> state_relation"
|
|
assumes valid_objs: "valid_objs s"
|
|
assumes pspace_aligned: "pspace_aligned s"
|
|
assumes pspace_distinct: "pspace_distinct s"
|
|
assumes pspace_aligned': "pspace_aligned' s'"
|
|
assumes pspace_distinct': "pspace_distinct' s'"
|
|
shows "p \<in> dom (caps_of_state s) \<longrightarrow> cteMap (gsCNodes s') (cte_map p) = p"
|
|
proof -
|
|
from rel have gsCNodes:
|
|
"\<forall>a n. (\<exists>cs. kheap s a = Some (CNode n cs) \<and> well_formed_cnode_n n cs) \<longleftrightarrow>
|
|
gsCNodes s' a = Some n"
|
|
by (simp add: state_relation_def ghost_relation_def)
|
|
show ?thesis
|
|
apply (simp add: dom_def cteMap_def split: if_split_asm)
|
|
apply (clarsimp simp: caps_of_state_cte_wp_at split: if_split_asm)
|
|
apply (drule cte_wp_cte_at)
|
|
apply (intro conjI impI)
|
|
apply (rule some_equality)
|
|
apply (clarsimp simp add: split_def)
|
|
apply (frule gsCNodes[rule_format,THEN iffD2])
|
|
apply clarsimp
|
|
apply (frule (1) cte_at_CNodeI)
|
|
apply (frule (2) cte_map_inj_eq[OF _ _ _ valid_objs pspace_aligned pspace_distinct])
|
|
apply clarsimp
|
|
apply (clarsimp simp add: split_def)
|
|
apply (frule gsCNodes[rule_format,THEN iffD2])
|
|
apply clarsimp
|
|
apply (frule (1) cte_at_CNodeI)
|
|
apply (frule (2) cte_map_inj_eq[OF _ _ _ valid_objs pspace_aligned pspace_distinct])
|
|
apply clarsimp
|
|
apply (case_tac p)
|
|
apply (clarsimp simp add: cte_wp_at_cases)
|
|
apply (erule disjE)
|
|
apply clarsimp
|
|
apply (drule_tac x=a in spec, drule_tac x=b in spec, simp)
|
|
apply (cut_tac a=a and n=sz in gsCNodes[rule_format])
|
|
apply clarsimp
|
|
apply (simp add: well_formed_cnode_n_def dom_def Collect_eq)
|
|
apply (erule_tac x=b in allE)
|
|
apply simp
|
|
apply (thin_tac "ALL x. P x" for P)
|
|
apply clarsimp
|
|
apply (frule TCB_implies_KOTCB[OF state_relation_pspace_relation[OF rel]])
|
|
apply clarsimp
|
|
using pspace_aligned'[simplified pspace_aligned'_def]
|
|
apply (drule_tac x=a in bspec, simp add: dom_def)
|
|
apply (simp add: objBitsKO_def cte_map_def)
|
|
apply (rule conjI[rotated])
|
|
apply (drule tcb_cap_cases_length)
|
|
apply (frule_tac b=b and c=cte_level_bits in bin_to_bl_of_bl_eq)
|
|
apply (fastforce simp: cte_level_bits_def objBits_defs)+
|
|
apply (case_tac "b = [False, False, False]")
|
|
apply (simp add: is_aligned_neg_mask_eq)
|
|
apply (frule_tac b=b and c=cte_level_bits in bin_to_bl_of_bl_eq)
|
|
apply (fastforce simp: tcb_cap_cases_length cte_level_bits_def objBits_defs)+
|
|
apply (subgoal_tac "ksPSpace s' (cte_map (a, b)) = None")
|
|
prefer 2
|
|
apply (rule ccontr)
|
|
apply clarsimp
|
|
using pspace_distinct'[simplified pspace_distinct'_def]
|
|
apply (drule_tac x=a in bspec, simp add: dom_def)
|
|
apply (simp add: ps_clear_def dom_def mask_2pm1[symmetric] x_power_minus_1)
|
|
apply (simp add: objBitsKO_def)
|
|
apply (drule_tac a="cte_map (a, b)" in equals0D)
|
|
apply (clarsimp simp add: cte_map_def)
|
|
apply (drule tcb_cap_cases_length)
|
|
apply (erule impE)
|
|
apply (rule word_plus_mono_right)
|
|
apply (cut_tac 'a=machine_word_len and xs=b in of_bl_length, fastforce simp: word_bits_conv)
|
|
apply (drule_tac k="2^cte_level_bits" in word_mult_less_mono1)
|
|
apply (fastforce simp: cte_level_bits_def objBits_defs)+
|
|
apply (simp add: mask_def)
|
|
apply (rule ccontr)
|
|
apply (simp add: not_le)
|
|
apply (drule (1) less_trans, fastforce simp: cte_level_bits_def objBits_defs)
|
|
apply (drule is_aligned_no_overflow'[simplified mask_2pm1[symmetric]])
|
|
apply (simp add: word_bits_conv)
|
|
apply simp
|
|
apply (erule impE)
|
|
apply (drule is_aligned_no_overflow'[simplified mask_2pm1[symmetric]])
|
|
apply (cut_tac 'a=machine_word_len and xs=b in of_bl_length, simp add: word_bits_conv)
|
|
apply (drule_tac k="2^cte_level_bits" in word_mult_less_mono1)
|
|
apply (fastforce simp: cte_level_bits_def objBits_defs)+
|
|
apply (erule word_random)
|
|
apply (rule order.strict_implies_order)
|
|
apply (erule less_trans)
|
|
apply (fastforce simp: cte_level_bits_def objBits_defs mask_def)
|
|
apply (simp add: mult.commute[of _ "2^cte_level_bits"]
|
|
shiftl_t2n[of _ cte_level_bits, simplified, symmetric])
|
|
apply word_bitwise
|
|
apply simp
|
|
apply (case_tac b, simp)
|
|
apply (rename_tac b, case_tac b, simp)
|
|
apply (rename_tac b, case_tac b, simp)
|
|
apply (clarsimp simp add: test_bit_of_bl eval_nat_numeral cte_level_bits_def)
|
|
apply (simp add: cte_map_def split: option.splits)
|
|
apply (drule tcb_cap_cases_length)
|
|
apply (rule of_bl_mult_and_not_mask_eq[where m=cte_level_bits, simplified])
|
|
apply (fastforce simp: cte_level_bits_def objBits_defs)+
|
|
done
|
|
qed
|
|
|
|
definition (* NOTE: cnp maps addresses to CNode, offset pairs *)
|
|
"absIsOriginalCap cnp h \<equiv>
|
|
%(oref,cref).
|
|
cnp (cte_map (oref, cref)) = (oref, cref) \<and>
|
|
cte_map (oref,cref) : dom (map_to_ctes h) \<and>
|
|
(\<exists>cte. map_to_ctes h (cte_map (oref,cref)) = Some cte \<and>
|
|
(cteCap cte \<noteq> capability.NullCap) \<and> mdbRevocable (cteMDBNode cte))"
|
|
|
|
lemma absIsOriginalCap_correct:
|
|
assumes valid_ioc: "valid_ioc s"
|
|
assumes valid_objs: "valid_objs s"
|
|
assumes rel: "(s,s') \<in> state_relation"
|
|
assumes pspace_aligned: "pspace_aligned s"
|
|
assumes pspace_distinct: "pspace_distinct s"
|
|
assumes pspace_aligned': "pspace_aligned' s'"
|
|
assumes pspace_distinct': "pspace_distinct' s'"
|
|
shows
|
|
"absIsOriginalCap (cteMap (gsCNodes s')) (ksPSpace s') = is_original_cap s"
|
|
proof -
|
|
from valid_ioc
|
|
have no_cap_not_orig:
|
|
"\<forall>p. caps_of_state s p = None \<longrightarrow> is_original_cap s p = False"
|
|
and null_cap_not_orig:
|
|
"\<forall>p. caps_of_state s p = Some cap.NullCap \<longrightarrow> is_original_cap s p = False"
|
|
by (fastforce simp: valid_ioc_def2 null_filter_def)+
|
|
|
|
have cnp:
|
|
"\<forall>a b. caps_of_state s (a, b) \<noteq> None \<longrightarrow>
|
|
(cteMap (gsCNodes s')) (cte_map (a, b)) = (a, b)"
|
|
using cteMap_correct[OF rel valid_objs pspace_aligned pspace_distinct
|
|
pspace_aligned' pspace_distinct']
|
|
by (clarsimp simp: dom_def)
|
|
|
|
show ?thesis
|
|
apply (subgoal_tac "revokable_relation (is_original_cap s)
|
|
(null_filter (caps_of_state s)) (ctes_of s') \<and>
|
|
pspace_relation (kheap s) (ksPSpace s')")
|
|
prefer 2
|
|
using rel
|
|
apply (clarsimp simp add: state_relation_def)
|
|
apply (rule ext)
|
|
apply (clarsimp simp add: revokable_relation_def
|
|
null_filter_def absIsOriginalCap_def
|
|
split: if_split_asm)
|
|
apply (erule_tac x=a in allE)
|
|
apply (erule_tac x=b in allE)
|
|
apply (case_tac "caps_of_state s (a, b)")
|
|
apply (clarsimp simp: no_cap_not_orig)
|
|
apply (frule (1) pspace_relation_cte_wp_atI[OF _ _ valid_objs])
|
|
apply (clarsimp simp: cte_wp_at_caps_of_state)
|
|
apply (subgoal_tac "(a,b) = (aa,ba)", simp)
|
|
apply (cut_tac a=aa and b=ba in cnp[rule_format], simp)
|
|
apply (simp add: cte_map_def)
|
|
apply simp
|
|
apply (case_tac "aa = cap.NullCap")
|
|
apply (clarsimp simp add: null_cap_not_orig)
|
|
apply (frule (1) pspace_relation_ctes_ofI
|
|
[OF _ caps_of_state_cteD pspace_aligned' pspace_distinct'])
|
|
apply clarsimp
|
|
apply (frule (1) pspace_relation_ctes_ofI
|
|
[OF _ caps_of_state_cteD pspace_aligned' pspace_distinct'])
|
|
apply (clarsimp simp add: dom_def)
|
|
apply (cut_tac a=a and b=b in cnp[rule_format], simp+)
|
|
apply (case_tac cte, clarsimp)
|
|
apply (case_tac aa, simp_all)
|
|
apply (rename_tac arch_cap)
|
|
apply (case_tac arch_cap, simp_all)
|
|
done
|
|
qed
|
|
|
|
text \<open>
|
|
In the executable specification,
|
|
a linked list connects all children of a certain node.
|
|
More specifically, the predicate @{term "subtree h c c'"} holds iff
|
|
the map @{term h} from addresses to CTEs contains capabilities
|
|
at the addresses @{term c} and @{term c'} and
|
|
the latter is a child of the former.
|
|
|
|
In the abstract specification, the capability-derivation tree @{term "cdt s"}
|
|
maps the address of each capability to the address of its immediate parent.
|
|
|
|
The definition below takes a binary predicate @{term ds} as parameter,
|
|
which represents a childhood relation like @{term "subtree h"},
|
|
and converts this into an optional function to the immediate parent
|
|
in the same format as @{term "cdt s"}.
|
|
\<close>
|
|
definition
|
|
"parent_of' ds \<equiv> %x.
|
|
if \<forall>p. \<not> ds p x then None
|
|
else Some (THE p. ds p x \<and> (\<forall>q. ds p q \<and> ds q x \<longrightarrow> p = q))"
|
|
|
|
definition
|
|
"absCDT cnp h \<equiv>
|
|
\<lambda>(oref,cref).
|
|
if cnp (cte_map (oref, cref)) = (oref, cref)
|
|
then map_option cnp (parent_of' (subtree h) (cte_map (oref, cref)))
|
|
else None"
|
|
|
|
lemma valid_mdb_mdb_cte_at:
|
|
"valid_mdb s
|
|
\<Longrightarrow> mdb_cte_at (\<lambda>p. \<exists>c. caps_of_state s p = Some c \<and> cap.NullCap \<noteq> c)
|
|
(cdt s)"
|
|
by (simp add: valid_mdb_def2)
|
|
|
|
lemma ctes_of_cte_wp_atD:
|
|
"ctes_of s p = Some cte \<Longrightarrow> cte_wp_at' ((=) cte) p s"
|
|
by (simp add: KHeap_R.cte_wp_at_ctes_of)
|
|
|
|
|
|
lemma absCDT_correct':
|
|
assumes pspace_aligned: "pspace_aligned s"
|
|
assumes pspace_distinct: "pspace_distinct s"
|
|
assumes pspace_aligned': "pspace_aligned' s'"
|
|
assumes pspace_distinct': "pspace_distinct' s'"
|
|
assumes valid_objs: "valid_objs s"
|
|
assumes valid_mdb: "valid_mdb s"
|
|
assumes rel: "(s,s') \<in> state_relation"
|
|
shows
|
|
"absCDT (cteMap (gsCNodes s')) (ctes_of s') = cdt s" (is ?P)
|
|
"(case (cdt s x) of None \<Rightarrow> caps_of_state s x \<noteq> None \<longrightarrow> (\<forall>q. \<not>(ctes_of s' \<turnstile> q \<rightarrow> cte_map x)) |
|
|
Some p \<Rightarrow>
|
|
ctes_of s' \<turnstile> cte_map p \<rightarrow> cte_map x \<and>
|
|
(\<forall>q. ctes_of s' \<turnstile> cte_map p \<rightarrow> q \<and>
|
|
ctes_of s' \<turnstile> q \<rightarrow> cte_map x \<longrightarrow>
|
|
cte_map p = q))" (is ?Q)
|
|
proof -
|
|
|
|
have cnp:
|
|
"\<forall>a b. caps_of_state s (a, b) \<noteq> None \<longrightarrow>
|
|
(cteMap (gsCNodes s')) (cte_map (a, b)) = (a, b)"
|
|
using cteMap_correct[OF rel valid_objs pspace_aligned pspace_distinct
|
|
pspace_aligned' pspace_distinct']
|
|
by (clarsimp simp: dom_def)
|
|
|
|
from rel
|
|
have descs_eq:
|
|
"\<forall>a b. cte_wp_at (\<lambda>_. True) (a, b) s \<longrightarrow>
|
|
{y. \<exists>x\<in>descendants_of (a, b) (cdt s). y = cte_map x} =
|
|
descendants_of' (cte_map (a, b)) (ctes_of s')"
|
|
apply (clarsimp simp add: state_relation_def)
|
|
apply (clarsimp simp add: swp_def cdt_relation_def image_def)
|
|
done
|
|
|
|
from rel
|
|
have pspace_relation: "pspace_relation (kheap s) (ksPSpace s')"
|
|
by (clarsimp simp add: state_relation_def)
|
|
|
|
note cdt_has_caps = mdb_cte_atD[OF _ valid_mdb_mdb_cte_at[OF valid_mdb]]
|
|
note descendants_of_simps =
|
|
descendants_of_def cdt_parent_rel_def is_cdt_parent_def
|
|
|
|
have descendants_implies:
|
|
"\<And>p p'. p' \<in> descendants_of p (cdt s) \<Longrightarrow>
|
|
\<exists>cap cap'. caps_of_state s p = Some cap \<and>
|
|
caps_of_state s p' = Some cap'"
|
|
apply (clarsimp simp: descendants_of_simps)
|
|
apply (frule tranclD2, drule tranclD)
|
|
apply (auto dest: cdt_has_caps)
|
|
done
|
|
|
|
let ?cnp = "cteMap (gsCNodes s')"
|
|
have subtree_implies:
|
|
"\<And>p p'. subtree (ctes_of s') p p' \<Longrightarrow>
|
|
\<exists>cap cap'. ?cnp p' \<in> descendants_of (?cnp p) (cdt s) \<and>
|
|
caps_of_state s (?cnp p) = Some cap \<and>
|
|
caps_of_state s (?cnp p') = Some cap' \<and>
|
|
(\<exists>cte cte'. ctes_of s' p = Some cte \<and> ctes_of s' p' = Some cte')"
|
|
apply (subgoal_tac "(ctes_of s') \<turnstile> p parentOf p'")
|
|
prefer 2
|
|
apply (erule subtree.cases, simp+)
|
|
apply (clarsimp simp add: parentOf_def)
|
|
apply (frule_tac x=p in
|
|
pspace_relation_cte_wp_atI[OF pspace_relation _ valid_objs])
|
|
apply clarsimp
|
|
apply (frule descs_eq[rule_format, OF cte_wp_at_weakenE], simp)
|
|
apply (simp add: descendants_of'_def Collect_eq)
|
|
apply (drule spec, drule(1) iffD2)
|
|
apply (clarsimp simp: cnp cte_wp_at_caps_of_state)
|
|
apply (frule descendants_implies)
|
|
apply (clarsimp simp: cnp)
|
|
done
|
|
have is_parent:
|
|
"\<And>a b p cap cap' a' b' c.
|
|
\<lbrakk>cdt s (a, b) = Some (a', b')\<rbrakk>
|
|
\<Longrightarrow> ctes_of s' \<turnstile> cte_map (a', b') \<rightarrow> cte_map (a, b) \<and>
|
|
(\<forall>q. ctes_of s' \<turnstile> cte_map (a', b') \<rightarrow> q \<and>
|
|
ctes_of s' \<turnstile> q \<rightarrow> cte_map (a, b) \<longrightarrow>
|
|
cte_map (a', b') = q)"
|
|
apply (frule cdt_has_caps)
|
|
using descs_eq pspace_relation
|
|
apply (frule_tac x=a' in spec, erule_tac x=b' in allE)
|
|
apply (simp add: cte_wp_at_caps_of_state Collect_eq descendants_of_simps
|
|
descendants_of'_def)
|
|
apply (rule conjI)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (drule subtree_implies)+
|
|
apply (clarsimp simp: cnp)
|
|
using valid_mdb
|
|
apply (clarsimp simp: cnp descendants_of_simps valid_mdb_def no_mloop_def)
|
|
apply (drule_tac x="?cnp q" and y="(a, b)" in tranclD2)
|
|
apply clarsimp
|
|
apply (fastforce intro: trancl_rtrancl_trancl)
|
|
done
|
|
|
|
|
|
show ?P
|
|
apply (rule ext)
|
|
using descs_eq pspace_relation
|
|
apply (simp add: absCDT_def)
|
|
apply (rule conjI[rotated])
|
|
apply clarsimp
|
|
apply (rule sym, rule ccontr, clarsimp)
|
|
apply (frule cdt_has_caps)
|
|
using cnp
|
|
apply fastforce
|
|
apply clarsimp
|
|
|
|
apply (clarsimp simp: parent_of'_def)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (rule sym, rule ccontr, clarsimp)
|
|
apply (simp add: descendants_of_simps descendants_of'_def)
|
|
apply (rename_tac a' b')
|
|
apply (erule_tac x=a' in allE, erule_tac x=b' in allE)
|
|
apply (erule_tac x="cte_map (a', b')" in allE, erule notE)
|
|
apply (frule cdt_has_caps)
|
|
apply (clarsimp simp: cte_wp_at_caps_of_state Collect_eq)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (drule subtree_implies)
|
|
apply clarsimp
|
|
apply (case_tac "cdt s (a, b)")
|
|
apply (simp add: descendants_of_simps descendants_of'_def)
|
|
apply (drule tranclD2)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (rename_tac a' b')
|
|
apply (frule cdt_has_caps)
|
|
apply clarsimp
|
|
apply (rule trans[rotated])
|
|
apply (rule cnp[rule_format], simp)
|
|
apply (rule arg_cong[where f="?cnp"])
|
|
apply (rule the_equality)
|
|
apply (rule is_parent,assumption)
|
|
apply clarsimp
|
|
apply (rule ccontr)
|
|
apply (drule_tac x="cte_map (a', b')" in spec, drule mp)
|
|
apply simp_all
|
|
apply (drule subtree_implies)
|
|
apply clarsimp
|
|
apply (drule_tac p=pa in ctes_of_cte_wp_atD)
|
|
apply (drule pspace_relation_cte_wp_atI'[OF pspace_relation _ valid_objs])
|
|
apply (clarsimp simp add: cte_wp_at_caps_of_state cnp)
|
|
apply (thin_tac "(a, b) \<in> descendants_of (?cnp p) (cdt s)",
|
|
thin_tac "caps_of_state s (?cnp p) = Some cap")
|
|
apply (unfold descendants_of'_def)
|
|
apply (erule_tac x=a' in allE)
|
|
apply (erule_tac x=b' in allE)
|
|
apply (simp add: Collect_eq)
|
|
apply (erule_tac x="cte_map (a, b)" in allE)
|
|
apply (drule iffD1)
|
|
apply (rule_tac x="(a, b)" in bexI, simp)
|
|
apply (clarsimp simp: cnp descendants_of_simps)
|
|
apply (rule trancl.intros(1))
|
|
apply simp_all
|
|
apply (rule descs_eq[simplified descendants_of'_def Collect_eq,
|
|
rule_format, THEN iffD1])
|
|
apply (clarsimp simp add: cte_wp_at_caps_of_state)
|
|
apply (rule_tac x="(a', b')" in bexI, simp)
|
|
apply (clarsimp simp: descendants_of_simps)
|
|
apply (drule_tac x="(aa,ba)" and y="(a, b)" in tranclD2)
|
|
apply clarsimp
|
|
apply (drule rtranclD, erule disjE, simp_all)[1]
|
|
done
|
|
thus ?Q
|
|
apply (case_tac x)
|
|
apply (case_tac "cdt s (a, b)")
|
|
apply (drule sym)
|
|
apply (simp add: mdb_cte_at_def)
|
|
apply (simp add: absCDT_def split_def)
|
|
apply (simp add: parent_of'_def split: if_split_asm)
|
|
apply (intro impI)
|
|
apply (frule_tac a=a and b=b in cnp[simplified,rule_format])
|
|
apply simp
|
|
apply simp
|
|
apply (clarsimp simp: is_parent)
|
|
done
|
|
qed
|
|
|
|
lemmas absCDT_correct = absCDT_correct'(1)
|
|
lemmas cdt_simple_rel = absCDT_correct'(2)
|
|
|
|
|
|
(* Produce a cdt_list from a cdt by sorting the children
|
|
sets by reachability via mdbNext. We then demonstrate
|
|
that a list satisfying the state relation must
|
|
already be sorted in the same way and therefore is
|
|
equivalent. *)
|
|
|
|
definition sort_cdt_list where
|
|
"sort_cdt_list cd m = (\<lambda>p. (THE xs. set xs = {c. cd c = Some p} \<and> partial_sort.psorted (\<lambda>x y. m \<turnstile> cte_map x \<leadsto>\<^sup>* cte_map y) xs \<and> distinct xs))"
|
|
|
|
end
|
|
|
|
locale partial_sort_cdt = partial_sort "\<lambda> x y. m' \<turnstile> cte_map x \<leadsto>\<^sup>* cte_map y"
|
|
"\<lambda> x y. cte_at x (s::det_state) \<and> cte_at y s \<and> (\<exists>p. m' \<turnstile> p \<rightarrow> cte_map x \<and> m' \<turnstile> p \<rightarrow> cte_map y)" for m' s +
|
|
fixes s'::"kernel_state"
|
|
fixes m t
|
|
defines "m \<equiv> (cdt s)"
|
|
defines "t \<equiv> (cdt_list s)"
|
|
assumes m'_def : "m' = (ctes_of s')"
|
|
assumes rel:"(s,s') \<in> state_relation"
|
|
assumes valid_mdb: "valid_mdb s"
|
|
assumes assms' : "pspace_aligned s" "pspace_distinct s" "pspace_aligned' s'"
|
|
"pspace_distinct' s'" "valid_objs s" "valid_mdb s" "valid_list s"
|
|
|
|
begin
|
|
|
|
interpretation Arch . (*FIXME: arch_split*)
|
|
|
|
lemma valid_list_2 : "valid_list_2 t m"
|
|
apply (insert assms')
|
|
apply (simp add: t_def m_def)
|
|
done
|
|
|
|
lemma has_next_not_child_is_descendant:
|
|
notes split_paired_All[simp del] split_paired_Ex[simp del]
|
|
shows
|
|
"next_not_child slot t m = Some slot2 \<Longrightarrow> (\<exists>p. slot \<in> descendants_of p m)"
|
|
apply (drule next_not_childD)
|
|
apply (simp add: m_def finite_depth assms')+
|
|
using assms'
|
|
apply (simp add: valid_mdb_def)
|
|
apply (elim disjE)
|
|
apply (drule next_sib_same_parent[OF valid_list_2])
|
|
apply (elim exE)
|
|
apply (rule_tac x=p in exI)
|
|
apply (rule child_descendant)
|
|
apply simp
|
|
apply (elim conjE exE)
|
|
apply force
|
|
done
|
|
|
|
|
|
lemma has_next_slot_is_descendant :
|
|
notes split_paired_All[simp del] split_paired_Ex[simp del]
|
|
shows
|
|
"next_slot slot t m = Some slot2 \<Longrightarrow> m slot2 = Some slot \<or> (\<exists>p. slot \<in> descendants_of p m)"
|
|
apply (insert valid_list_2)
|
|
apply (simp add: next_slot_def next_child_def split: if_split_asm)
|
|
apply (case_tac "t slot",simp+)
|
|
apply (simp add: valid_list_2_def)
|
|
apply (rule disjI1)
|
|
apply force
|
|
apply (rule disjI2)
|
|
apply (erule has_next_not_child_is_descendant)
|
|
done
|
|
|
|
lemma descendant_has_parent:
|
|
notes split_paired_All[simp del] split_paired_Ex[simp del]
|
|
shows
|
|
"slot \<in> descendants_of p m \<Longrightarrow> \<exists>q. m slot = Some q"
|
|
apply (simp add: descendants_of_def)
|
|
apply (drule tranclD2)
|
|
apply (simp add: cdt_parent_of_def)
|
|
apply force
|
|
done
|
|
|
|
|
|
|
|
lemma next_slot_cte_at:
|
|
notes split_paired_All[simp del] split_paired_Ex[simp del]
|
|
shows
|
|
"next_slot slot t m = Some slot2 \<Longrightarrow> cte_at slot s"
|
|
apply (cut_tac valid_mdb_mdb_cte_at)
|
|
prefer 2
|
|
apply (cut_tac assms')
|
|
apply simp
|
|
apply (fold m_def)
|
|
apply (simp add: mdb_cte_at_def)
|
|
apply (simp add: cte_wp_at_caps_of_state)
|
|
apply (drule has_next_slot_is_descendant)
|
|
apply (elim disjE)
|
|
apply force
|
|
apply (elim exE)
|
|
apply (drule descendant_has_parent)
|
|
apply force
|
|
done
|
|
|
|
lemma cte_at_has_cap: "cte_at slot s \<Longrightarrow> \<exists>c. cte_wp_at ((=) c) slot s"
|
|
apply (drule cte_at_get_cap_wp)
|
|
apply force
|
|
done
|
|
|
|
|
|
lemma next_slot_mdb_next:
|
|
notes split_paired_All[simp del]
|
|
shows
|
|
"next_slot slot t m = Some slot2 \<Longrightarrow> m' \<turnstile> (cte_map slot) \<leadsto> (cte_map slot2)"
|
|
apply (frule cte_at_has_cap[OF next_slot_cte_at])
|
|
apply (elim exE)
|
|
apply (cut_tac s=s and s'=s' in pspace_relation_ctes_ofI)
|
|
apply (fold m'_def)
|
|
using rel
|
|
apply (simp add: state_relation_def)
|
|
apply simp
|
|
using assms'
|
|
apply simp
|
|
using assms'
|
|
apply simp
|
|
apply (subgoal_tac "cdt_list_relation t m m'")
|
|
apply (simp add: cdt_list_relation_def)
|
|
apply (elim exE)
|
|
apply (case_tac cte)
|
|
apply (simp add: mdb_next_rel_def mdb_next_def)
|
|
apply force
|
|
using rel
|
|
apply (simp add: state_relation_def m_def t_def m'_def)
|
|
done
|
|
|
|
|
|
lemma next_sib_2_reachable: "next_sib_2 slot p s = Some slot2 \<Longrightarrow> m' \<turnstile> (cte_map slot) \<leadsto>\<^sup>* (cte_map slot2)"
|
|
apply (induct slot rule: next_sib_2_pinduct[where s=s and p=p])
|
|
apply (cut_tac slot=slot and s=s and p=p in next_sib_2.psimps[OF next_sib_2_termination], (simp add: assms')+)
|
|
apply (fold m_def t_def)
|
|
apply (simp split: if_split_asm)
|
|
apply (case_tac "next_slot slot t m")
|
|
apply simp
|
|
apply (simp split: if_split_asm)
|
|
apply (rule r_into_rtrancl)
|
|
apply (erule next_slot_mdb_next)
|
|
apply (drule_tac x="a" in meta_spec)
|
|
apply simp
|
|
apply (rule trans)
|
|
apply (rule r_into_rtrancl)
|
|
apply (rule next_slot_mdb_next)
|
|
apply (simp add: assms' valid_list_2)+
|
|
done
|
|
|
|
|
|
lemma next_sib_reachable: "next_sib slot t m = Some slot2 \<Longrightarrow> m slot = Some p \<Longrightarrow>
|
|
m' \<turnstile> (cte_map slot) \<leadsto>\<^sup>* (cte_map slot2)"
|
|
apply (rule next_sib_2_reachable)
|
|
apply (insert assms')
|
|
apply (simp add: t_def m_def)
|
|
apply (subst next_sib_def2,simp+)
|
|
done
|
|
|
|
lemma after_in_list_next_reachable:
|
|
notes split_paired_All[simp del] split_paired_Ex[simp del]
|
|
shows
|
|
"after_in_list (t p) slot = Some slot2 \<Longrightarrow> m' \<turnstile> (cte_map slot) \<leadsto>\<^sup>* (cte_map slot2)"
|
|
apply (subgoal_tac "m slot = Some p")
|
|
apply (rule next_sib_reachable)
|
|
apply (simp add: next_sib_def)+
|
|
apply (drule after_in_list_in_list')
|
|
apply (insert valid_list_2)
|
|
apply (simp add: valid_list_2_def)
|
|
done
|
|
|
|
lemma sorted_lists:
|
|
"psorted (t p)"
|
|
apply (rule after_order_sorted)
|
|
apply (rule after_in_list_next_reachable)
|
|
apply simp
|
|
apply (insert assms')
|
|
apply (simp add: valid_list_def t_def del: split_paired_All)
|
|
done
|
|
|
|
lemma finite_children:
|
|
notes split_paired_All[simp del]
|
|
shows
|
|
"finite {c. m c = Some p}"
|
|
apply (insert assms')
|
|
apply(subgoal_tac "{x. x \<in> descendants_of p (cdt s)} \<subseteq> {x. cte_wp_at (\<lambda>_. True) x s}")
|
|
prefer 2
|
|
apply(fastforce simp: descendants_of_cte_at)
|
|
apply(drule finite_subset)
|
|
apply(simp add: cte_wp_at_set_finite)
|
|
apply(subgoal_tac "{c. m c = Some p} \<subseteq> {c. c \<in> descendants_of p (cdt s)}")
|
|
apply (drule finite_subset)
|
|
apply simp
|
|
apply simp
|
|
apply clarsimp
|
|
apply (simp add: m_def child_descendant)
|
|
done
|
|
|
|
|
|
lemma ex1_sorted_cdt: "\<exists>!xs. set xs = {c. m c = Some p} \<and>
|
|
psorted xs \<and>
|
|
distinct xs"
|
|
apply (rule psorted_set[OF finite_children])
|
|
apply (simp add: R_set_def)
|
|
apply (intro impI conjI allI)
|
|
apply (simp add: has_parent_cte_at[OF valid_mdb] m_def)
|
|
apply (simp add: has_parent_cte_at[OF valid_mdb] m_def)
|
|
|
|
apply (cut_tac s=s and s'=s' and x="(a,b)" in cdt_simple_rel, simp_all add: assms' rel)
|
|
apply (simp add: m_def)
|
|
apply (cut_tac s=s and s'=s' and x="(aa,ba)" in cdt_simple_rel, simp_all add: assms' rel)
|
|
apply (rule_tac x="cte_map p" in exI)
|
|
apply (simp add: m'_def)
|
|
done
|
|
|
|
lemma sort_cdt_list_correct:
|
|
"sort_cdt_list m m' = t"
|
|
apply (rule ext)
|
|
apply (simp add: sort_cdt_list_def)
|
|
apply (rule the1_equality)
|
|
apply (rule ex1_sorted_cdt)
|
|
apply (simp add: sorted_lists)
|
|
apply (insert assms')
|
|
apply (simp add: valid_list_def t_def m_def del: split_paired_All)
|
|
done
|
|
|
|
end
|
|
|
|
context begin interpretation Arch . (*FIXME: arch_split*)
|
|
|
|
definition absCDTList where
|
|
"absCDTList cnp h \<equiv> sort_cdt_list (absCDT cnp h) h"
|
|
|
|
lemma no_loops_sym_eq: "no_loops m \<Longrightarrow> m \<turnstile> a \<leadsto>\<^sup>* b \<Longrightarrow> m \<turnstile> b \<leadsto>\<^sup>* a \<Longrightarrow> a = b"
|
|
apply (rule ccontr)
|
|
apply (subgoal_tac "m \<turnstile> a \<leadsto>\<^sup>+ a")
|
|
apply (simp add: no_loops_def)
|
|
apply (simp add: rtrancl_eq_or_trancl)
|
|
done
|
|
|
|
lemma mdb_next_single_valued: "single_valued (mdb_next_rel m)"
|
|
apply (simp add: single_valued_def mdb_next_rel_def)
|
|
done
|
|
|
|
lemma substring_next: "m \<turnstile> a \<leadsto>\<^sup>* b \<Longrightarrow> m \<turnstile> a \<leadsto>\<^sup>* c \<Longrightarrow> m \<turnstile> b \<leadsto>\<^sup>* c \<or> m \<turnstile> c \<leadsto>\<^sup>* b"
|
|
apply (rule single_valued_confluent)
|
|
apply (rule mdb_next_single_valued)
|
|
apply simp+
|
|
done
|
|
|
|
lemma ancestor_comparable: "\<lbrakk>m \<turnstile> a \<rightarrow> x; m \<turnstile> a \<rightarrow> y\<rbrakk> \<Longrightarrow> m \<turnstile> x \<leadsto>\<^sup>* y \<or> m \<turnstile> y \<leadsto>\<^sup>* x"
|
|
apply (rule substring_next)
|
|
apply (erule subtree_mdb_next[THEN trancl_into_rtrancl])+
|
|
done
|
|
|
|
lemma valid_mdb'_no_loops: "valid_mdb' s \<Longrightarrow> no_loops (ctes_of s)"
|
|
apply (rule mdb_chain_0_no_loops)
|
|
apply (simp add: valid_mdb'_def valid_mdb_ctes_def)+
|
|
done
|
|
|
|
|
|
lemma absCDTList_correct:
|
|
notes split_paired_All[simp del] split_paired_Ex[simp del]
|
|
assumes valid_mdb: "valid_mdb s"
|
|
assumes valid_mdb': "valid_mdb' s'"
|
|
assumes valid_list: "valid_list s"
|
|
assumes valid_objs: "valid_objs s"
|
|
assumes pspace_aligned: "pspace_aligned s"
|
|
assumes pspace_aligned': "pspace_aligned' s'"
|
|
assumes pspace_distinct: "pspace_distinct s"
|
|
assumes pspace_distinct': "pspace_distinct' s'"
|
|
assumes rel: "(s,s') \<in> state_relation"
|
|
shows
|
|
"absCDTList (cteMap (gsCNodes s')) (ctes_of s') = cdt_list s"
|
|
apply (simp add: absCDTList_def)
|
|
apply (subst absCDT_correct[where s=s])
|
|
apply (simp add: assms)+
|
|
apply (rule partial_sort_cdt.sort_cdt_list_correct[where s'=s'])
|
|
apply (simp add: partial_sort_cdt_def)
|
|
apply (rule context_conjI')
|
|
apply unfold_locales
|
|
apply (simp add: assms)+
|
|
apply (simp add: partial_sort_cdt_axioms_def)
|
|
apply (elim conjE exE)
|
|
apply (rule ancestor_comparable,assumption+)
|
|
apply (elim conjE)
|
|
apply (rule cte_map_inj_eq)
|
|
apply (rule no_loops_sym_eq[where m="ctes_of s'"])
|
|
apply (rule valid_mdb'_no_loops[OF valid_mdb'])
|
|
apply (simp add: assms)+
|
|
done
|
|
|
|
definition
|
|
"absInterruptIRQNode is' \<equiv> \<lambda>irq.
|
|
case is' of InterruptState node irqs' \<Rightarrow>
|
|
node + (ucast irq << cte_level_bits)"
|
|
|
|
definition
|
|
"irq_state_map s \<equiv> case s of
|
|
irq_state.IRQInactive \<Rightarrow> irqstate.IRQInactive
|
|
| irq_state.IRQSignal \<Rightarrow> irqstate.IRQSignal
|
|
| irq_state.IRQTimer \<Rightarrow> irqstate.IRQTimer
|
|
| irq_state.IRQReserved \<Rightarrow> irqstate.IRQReserved"
|
|
|
|
definition
|
|
"IRQStateMap s \<equiv> case s of
|
|
irqstate.IRQInactive \<Rightarrow> irq_state.IRQInactive
|
|
| irqstate.IRQSignal \<Rightarrow> irq_state.IRQSignal
|
|
| irqstate.IRQTimer \<Rightarrow> irq_state.IRQTimer
|
|
| irqstate.IRQReserved \<Rightarrow> irq_state.IRQReserved"
|
|
|
|
definition
|
|
"absInterruptStates is' \<equiv>
|
|
case is' of InterruptState node m \<Rightarrow>
|
|
IRQStateMap \<circ> m"
|
|
|
|
lemma absInterruptIRQNode_correct:
|
|
"interrupt_state_relation (interrupt_irq_node s) (interrupt_states s)
|
|
(ksInterruptState s') \<Longrightarrow>
|
|
absInterruptIRQNode (ksInterruptState s') = interrupt_irq_node s"
|
|
by (rule ext) (clarsimp simp add: absInterruptIRQNode_def
|
|
interrupt_state_relation_def)
|
|
|
|
lemma absInterruptStates_correct:
|
|
"interrupt_state_relation (interrupt_irq_node s) (interrupt_states s)
|
|
(ksInterruptState s') \<Longrightarrow>
|
|
absInterruptStates (ksInterruptState s') = interrupt_states s"
|
|
apply (rule ext)
|
|
apply (clarsimp simp add: absInterruptStates_def IRQStateMap_def
|
|
interrupt_state_relation_def irq_state_relation_def)
|
|
apply (erule_tac x=x in allE)+
|
|
apply (clarsimp split: irq_state.splits irqstate.splits)
|
|
done
|
|
|
|
definition
|
|
"absArchState s' \<equiv>
|
|
case s' of ARMKernelState asid_tbl hwat anext am gpd gpts kvspace \<Rightarrow>
|
|
\<lparr>arm_asid_table = asid_tbl \<circ> ucast,
|
|
arm_hwasid_table = hwat, arm_next_asid = anext,
|
|
arm_asid_map = am, arm_global_pd = gpd, arm_global_pts = gpts,
|
|
arm_kernel_vspace = kvspace\<rparr>"
|
|
|
|
lemma absArchState_correct:
|
|
assumes rel:
|
|
"(s,s') \<in> state_relation"
|
|
shows
|
|
"absArchState (ksArchState s') = arch_state s"
|
|
apply (subgoal_tac "(arch_state s, ksArchState s') \<in> arch_state_relation")
|
|
prefer 2
|
|
using rel
|
|
apply (simp add: state_relation_def)
|
|
apply (clarsimp simp add: arch_state_relation_def)
|
|
by (clarsimp simp add: absArchState_def
|
|
split: ARM_H.kernel_state.splits)
|
|
|
|
definition absSchedulerAction where
|
|
"absSchedulerAction action \<equiv>
|
|
case action of ResumeCurrentThread \<Rightarrow> resume_cur_thread
|
|
| SwitchToThread t \<Rightarrow> switch_thread t
|
|
| ChooseNewThread \<Rightarrow> choose_new_thread"
|
|
|
|
lemma absSchedulerAction_correct:
|
|
assumes act_rel: "sched_act_relation action action'"
|
|
shows " absSchedulerAction action' = action"
|
|
using act_rel
|
|
by (cases action, simp_all add: absSchedulerAction_def)
|
|
|
|
definition
|
|
"absExst s \<equiv>
|
|
\<lparr>work_units_completed_internal = ksWorkUnitsCompleted s,
|
|
scheduler_action_internal = absSchedulerAction (ksSchedulerAction s),
|
|
ekheap_internal = absEkheap (ksPSpace s),
|
|
domain_list_internal = ksDomSchedule s,
|
|
domain_index_internal = ksDomScheduleIdx s,
|
|
cur_domain_internal = ksCurDomain s,
|
|
domain_time_internal = ksDomainTime s,
|
|
ready_queues_internal = curry (ksReadyQueues s),
|
|
cdt_list_internal = absCDTList (cteMap (gsCNodes s)) (ctes_of s)\<rparr>"
|
|
|
|
lemma absExst_correct:
|
|
assumes invs: "einvs s" and invs': "invs' s'"
|
|
assumes rel: "(s, s') \<in> state_relation"
|
|
shows "absExst s' = exst s"
|
|
apply (rule det_ext.equality)
|
|
using rel invs invs'
|
|
apply (simp_all add: absExst_def absSchedulerAction_correct absEkheap_correct
|
|
absCDTList_correct[THEN fun_cong] state_relation_def invs_def valid_state_def
|
|
ready_queues_relation_def invs'_def valid_state'_def
|
|
valid_pspace_def valid_sched_def valid_pspace'_def curry_def fun_eq_iff)
|
|
apply (fastforce simp: absEkheap_correct)
|
|
done
|
|
|
|
|
|
definition
|
|
"absKState s \<equiv>
|
|
\<lparr>kheap = absHeap (gsUserPages s) (gsCNodes s) (ksPSpace s),
|
|
cdt = absCDT (cteMap (gsCNodes s)) (ctes_of s),
|
|
is_original_cap = absIsOriginalCap (cteMap (gsCNodes s)) (ksPSpace s),
|
|
cur_thread = ksCurThread s, idle_thread = ksIdleThread s,
|
|
machine_state = observable_memory (ksMachineState s) (user_mem' s),
|
|
interrupt_irq_node = absInterruptIRQNode (ksInterruptState s),
|
|
interrupt_states = absInterruptStates (ksInterruptState s),
|
|
arch_state = absArchState (ksArchState s),
|
|
exst = absExst s\<rparr>"
|
|
|
|
(* TODO: move *)
|
|
lemma invs_valid_ioc[elim!]: "invs s \<Longrightarrow> valid_ioc s"
|
|
by (clarsimp simp add: invs_def valid_state_def)
|
|
|
|
|
|
|
|
definition
|
|
checkActiveIRQ :: "(kernel_state, bool) nondet_monad"
|
|
where
|
|
"checkActiveIRQ \<equiv>
|
|
do irq \<leftarrow> doMachineOp (getActiveIRQ False);
|
|
return (irq \<noteq> None)
|
|
od"
|
|
|
|
definition
|
|
check_active_irq_H :: "((user_context \<times> kernel_state) \<times> bool \<times> (user_context \<times> kernel_state)) set"
|
|
where
|
|
"check_active_irq_H \<equiv> {((tc, s), irq, (tc, s')). (irq, s') \<in> fst (checkActiveIRQ s)}"
|
|
|
|
definition
|
|
doUserOp :: "user_transition \<Rightarrow> user_context \<Rightarrow>
|
|
(kernel_state, event option \<times> user_context) nondet_monad"
|
|
where
|
|
"doUserOp uop tc \<equiv>
|
|
do t \<leftarrow> getCurThread;
|
|
trans \<leftarrow> gets (ptable_lift t \<circ> absKState);
|
|
perms \<leftarrow> gets (ptable_rights t \<circ> absKState);
|
|
|
|
um \<leftarrow> gets (\<lambda>s. user_mem' s \<circ> ptrFromPAddr);
|
|
dm \<leftarrow> gets (\<lambda>s. device_mem' s \<circ> ptrFromPAddr);
|
|
|
|
ds \<leftarrow> gets (device_state \<circ> ksMachineState);
|
|
assert (dom (um \<circ> addrFromPPtr) \<subseteq> - dom ds);
|
|
assert (dom (dm \<circ> addrFromPPtr) \<subseteq> dom ds);
|
|
|
|
(e, tc',um',ds') \<leftarrow> select (fst (uop t (restrict_map trans {pa. perms pa \<noteq> {}}) perms
|
|
(tc, restrict_map um
|
|
{pa. \<exists>va. trans va = Some pa \<and> AllowRead \<in> perms va}
|
|
,(ds \<circ> ptrFromPAddr) |` {pa. \<exists>va. trans va = Some pa \<and> AllowRead \<in> perms va} )
|
|
));
|
|
doMachineOp (user_memory_update
|
|
((um' |` {pa. \<exists>va. trans va = Some pa \<and> AllowWrite \<in> perms va}
|
|
\<circ> addrFromPPtr) |` (- dom ds)));
|
|
doMachineOp (device_memory_update
|
|
((ds' |` {pa. \<exists>va. trans va = Some pa \<and> AllowWrite \<in> perms va}
|
|
\<circ> addrFromPPtr )|` (dom ds)));
|
|
return (e, tc')
|
|
od"
|
|
|
|
definition
|
|
do_user_op_H
|
|
:: "user_transition \<Rightarrow>
|
|
((user_context \<times> kernel_state) \<times> (event option \<times> user_context \<times> kernel_state)) set"
|
|
where
|
|
"do_user_op_H uop \<equiv> monad_to_transition (doUserOp uop)"
|
|
|
|
definition
|
|
"kernelEntry e tc \<equiv> do
|
|
t \<leftarrow> getCurThread;
|
|
threadSet (\<lambda>tcb. tcb \<lparr> tcbArch := atcbContextSet tc (tcbArch tcb) \<rparr>) t;
|
|
callKernel e;
|
|
t' \<leftarrow> getCurThread;
|
|
threadGet (atcbContextGet o tcbArch) t'
|
|
od"
|
|
|
|
definition
|
|
kernel_call_H
|
|
:: "event \<Rightarrow> ((user_context \<times> kernel_state) \<times> mode \<times>
|
|
(user_context \<times> kernel_state)) set"
|
|
where
|
|
"kernel_call_H e \<equiv>
|
|
{(s, m, s'). s' \<in> fst (split (kernelEntry e) s) \<and>
|
|
m = (if ct_running' (snd s') then UserMode else IdleMode)}"
|
|
|
|
definition
|
|
ADT_H :: "user_transition \<Rightarrow>
|
|
(kernel_state global_state, det_ext observable, unit) data_type"
|
|
|
|
where
|
|
"ADT_H uop \<equiv>
|
|
\<lparr>Init = \<lambda>s. Init_H,
|
|
Fin = \<lambda>((tc,s),m,e). ((tc, absKState s),m,e),
|
|
Step = (\<lambda>u. global_automaton check_active_irq_H (do_user_op_H uop) kernel_call_H)\<rparr>"
|
|
|
|
end
|
|
|
|
end
|