1163 lines
48 KiB
Plaintext
1163 lines
48 KiB
Plaintext
(*
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
|
*
|
|
* SPDX-License-Identifier: GPL-2.0-only
|
|
*)
|
|
|
|
(*
|
|
* State translation.
|
|
*
|
|
* Takes a state of the system as defined in the abstract seL4
|
|
* specification, and returns an equivalent state of the system
|
|
* defined in terms of the CapDL specification.
|
|
*)
|
|
|
|
theory StateTranslation_D
|
|
imports Lemmas_D
|
|
begin
|
|
|
|
context begin interpretation Arch . (*FIXME: arch_split*)
|
|
|
|
type_synonym kernel_object = Structures_A.kernel_object
|
|
type_synonym tcb = Structures_A.tcb
|
|
type_synonym pte = ARM_A.pte
|
|
|
|
(* Transform an abstract-spec cap ptr to a capDL one. This is currently
|
|
* a no-(;) however, it is conceivable that the capDL cptr representation could
|
|
* be changed. Allowing for this potential change is the purpose of this
|
|
* definition.
|
|
*)
|
|
definition
|
|
transform_cptr :: "word32 \<Rightarrow> cdl_cptr" where
|
|
"transform_cptr w \<equiv> w"
|
|
|
|
(* transform an abstract-spec recv_slot description to a capDL one *)
|
|
definition
|
|
transform_recv_slot :: "(word32 \<times> word32 \<times> word8) \<Rightarrow>
|
|
(cdl_cptr \<times> word32 \<times> word8)"
|
|
where
|
|
"transform_recv_slot x \<equiv> let (cap,w32,w8) = x in (transform_cptr cap,w32,w8)"
|
|
|
|
(*
|
|
* Convert a user value to a CDL type.
|
|
*
|
|
* We repeat "FrameType" multiple times because CapDL doesn't
|
|
* treat the different frame sizes as different types.
|
|
*)
|
|
definition
|
|
transform_type :: "word32 \<Rightarrow> cdl_object_type option"
|
|
where
|
|
"transform_type x \<equiv>
|
|
if x = 0 then Some UntypedType
|
|
else if x = 1 then Some TcbType
|
|
else if x = 2 then Some EndpointType
|
|
else if x = 3 then Some NotificationType
|
|
else if x = 4 then Some CNodeType
|
|
else if x = 5 then Some PageDirectoryType
|
|
else if x = 6 then Some (FrameType 12)
|
|
else if x = 7 then Some (FrameType 16)
|
|
else if x = 8 then Some (FrameType 20)
|
|
else if x = 9 then Some (FrameType 24)
|
|
else if x = 10 then Some PageTableType
|
|
else None"
|
|
|
|
definition
|
|
transform_intent_untyped_retype :: "word32 list \<Rightarrow> cdl_untyped_intent option"
|
|
where
|
|
"transform_intent_untyped_retype args =
|
|
(case args of
|
|
type#size_bits#index#depth#offset#window#_ \<Rightarrow>
|
|
(case transform_type type of
|
|
Some x \<Rightarrow>
|
|
Some (UntypedRetypeIntent x size_bits index depth offset window)
|
|
| _ \<Rightarrow>
|
|
None)
|
|
| _ \<Rightarrow> None)"
|
|
|
|
(* Arch flags always set to 0 here as they have no meaning on ARM. *)
|
|
definition
|
|
transform_intent_tcb_read_registers :: "word32 list \<Rightarrow> cdl_tcb_intent option"
|
|
where
|
|
"transform_intent_tcb_read_registers args =
|
|
(case args of flags#n#_ \<Rightarrow>
|
|
Some (TcbReadRegistersIntent (flags !! 0) 0 n)
|
|
| _ \<Rightarrow> None)"
|
|
|
|
(* Arch flags always set to 0 here as they have no meaning on ARM. *)
|
|
definition
|
|
transform_intent_tcb_write_registers :: "word32 list \<Rightarrow> cdl_tcb_intent option"
|
|
where
|
|
"transform_intent_tcb_write_registers args =
|
|
(case args of flags#n#values \<Rightarrow>
|
|
Some (TcbWriteRegistersIntent (flags !! 0) 0 n values)
|
|
| _ \<Rightarrow> None)"
|
|
|
|
(* Arch flags always set to 0 here as they have no meaning on ARM. *)
|
|
definition
|
|
transform_intent_tcb_copy_registers :: "word32 list \<Rightarrow> cdl_tcb_intent option"
|
|
where
|
|
"transform_intent_tcb_copy_registers args =
|
|
(case args of flags#_ \<Rightarrow>
|
|
Some (TcbCopyRegistersIntent (flags !! 0) (flags !! 1) (flags !! 2) (flags !! 3) 0)
|
|
| _ \<Rightarrow> None)"
|
|
|
|
(* Priority always set to 0 here. This should change if priorities
|
|
* are ever added to the capDL spec.
|
|
*)
|
|
definition
|
|
prio_from_arg :: "word32 \<Rightarrow> word8"
|
|
where
|
|
"prio_from_arg _ = 0"
|
|
|
|
definition
|
|
transform_intent_tcb_configure :: "word32 list \<Rightarrow> cdl_tcb_intent option"
|
|
where
|
|
"transform_intent_tcb_configure args =
|
|
(case args of fault_ep#croot_data#vroot_data#buffer#_ \<Rightarrow>
|
|
Some (TcbConfigureIntent fault_ep
|
|
croot_data vroot_data buffer)
|
|
| _ \<Rightarrow> None)"
|
|
|
|
definition
|
|
transform_intent_tcb_set_priority :: "word32 list \<Rightarrow> cdl_tcb_intent option"
|
|
where
|
|
"transform_intent_tcb_set_priority args =
|
|
(case args of prio#_ \<Rightarrow>
|
|
Some (TcbSetPriorityIntent (prio_from_arg prio))
|
|
| _ \<Rightarrow> None)"
|
|
|
|
definition
|
|
transform_intent_tcb_set_mcpriority :: "word32 list \<Rightarrow> cdl_tcb_intent option"
|
|
where
|
|
"transform_intent_tcb_set_mcpriority args =
|
|
(case args of mcp#_ \<Rightarrow>
|
|
Some (TcbSetMCPriorityIntent (prio_from_arg mcp))
|
|
| _ \<Rightarrow> None)"
|
|
|
|
definition
|
|
transform_intent_tcb_set_sched_params :: "word32 list \<Rightarrow> cdl_tcb_intent option"
|
|
where
|
|
"transform_intent_tcb_set_sched_params args =
|
|
(case args of mcp#priority#_ \<Rightarrow>
|
|
Some (TcbSetSchedParamsIntent (prio_from_arg mcp) (prio_from_arg priority))
|
|
| _ \<Rightarrow> None)"
|
|
|
|
definition
|
|
transform_intent_tcb_set_ipc_buffer :: "word32 list \<Rightarrow> cdl_tcb_intent option"
|
|
where
|
|
"transform_intent_tcb_set_ipc_buffer args =
|
|
(case args of buffer#_ \<Rightarrow>
|
|
Some (TcbSetIPCBufferIntent buffer)
|
|
| _ \<Rightarrow> None)"
|
|
|
|
|
|
definition
|
|
transform_intent_tcb_set_space :: "word32 list \<Rightarrow> cdl_tcb_intent option"
|
|
where
|
|
"transform_intent_tcb_set_space args =
|
|
(case args of fault_ep#croot_data#vroot_data#_ \<Rightarrow>
|
|
Some (TcbSetSpaceIntent fault_ep croot_data vroot_data)
|
|
| _ \<Rightarrow> None)"
|
|
|
|
definition
|
|
transform_cnode_index_and_depth :: "(word32 \<Rightarrow> word32 \<Rightarrow> 'a) \<Rightarrow> word32 list \<Rightarrow> 'a option"
|
|
where
|
|
"transform_cnode_index_and_depth func args \<equiv>
|
|
case args of index#depth#_ \<Rightarrow>
|
|
Some (func index depth)
|
|
| _ \<Rightarrow> None"
|
|
|
|
|
|
definition
|
|
transform_intent_cnode_copy :: "word32 list \<Rightarrow> cdl_cnode_intent option"
|
|
where
|
|
"transform_intent_cnode_copy args \<equiv>
|
|
case args of destindex#destdepth#srcindex#srcdepth#rightsWord#_ \<Rightarrow>
|
|
Some (CNodeCopyIntent destindex destdepth
|
|
srcindex srcdepth (data_to_rights rightsWord))
|
|
| _ \<Rightarrow> Nothing"
|
|
|
|
definition
|
|
transform_intent_cnode_mint :: "word32 list \<Rightarrow> cdl_cnode_intent option"
|
|
where
|
|
"transform_intent_cnode_mint args \<equiv>
|
|
case args of destindex#destdepth#srcindex#srcdepth#rightsWord#capData#_ \<Rightarrow>
|
|
Some (CNodeMintIntent destindex destdepth
|
|
srcindex srcdepth (data_to_rights rightsWord) capData)
|
|
| _ \<Rightarrow> Nothing"
|
|
|
|
definition
|
|
transform_intent_cnode_move :: "word32 list \<Rightarrow> cdl_cnode_intent option"
|
|
where
|
|
"transform_intent_cnode_move args \<equiv>
|
|
case args of destindex#destdepth#srcindex#srcdepth#rest \<Rightarrow>
|
|
Some (CNodeMoveIntent destindex destdepth
|
|
srcindex srcdepth)
|
|
| _ \<Rightarrow> Nothing"
|
|
|
|
definition
|
|
transform_intent_cnode_mutate :: "word32 list \<Rightarrow> cdl_cnode_intent option"
|
|
where
|
|
"transform_intent_cnode_mutate args \<equiv>
|
|
case args of destindex#destdepth#srcindex#srcdepth#capData#_ \<Rightarrow>
|
|
Some (CNodeMutateIntent destindex destdepth
|
|
srcindex srcdepth capData)
|
|
| _ \<Rightarrow> Nothing"
|
|
|
|
definition
|
|
transform_intent_cnode_rotate :: "word32 list \<Rightarrow> cdl_cnode_intent option"
|
|
where
|
|
"transform_intent_cnode_rotate args \<equiv>
|
|
case args of destindex#destdepth#pivotbadge#pivotindex#
|
|
pivotdepth#srcbadge#srcindex#srcdepth#_ \<Rightarrow>
|
|
Some (CNodeRotateIntent destindex destdepth
|
|
pivotindex pivotdepth pivotbadge
|
|
srcindex srcdepth srcbadge)
|
|
| _ \<Rightarrow> Nothing"
|
|
|
|
|
|
definition
|
|
transform_intent_issue_irq_handler :: "word32 list \<Rightarrow> cdl_irq_control_intent option"
|
|
where
|
|
"transform_intent_issue_irq_handler args \<equiv>
|
|
case args of
|
|
irqW#index#depth#_ \<Rightarrow>
|
|
Some (IrqControlIssueIrqHandlerIntent ((ucast irqW)::10 word) index depth)
|
|
| _ \<Rightarrow> Nothing"
|
|
|
|
definition
|
|
arch_transform_intent_issue_irq_handler :: "word32 list \<Rightarrow> cdl_irq_control_intent option"
|
|
where
|
|
"arch_transform_intent_issue_irq_handler args \<equiv>
|
|
case args of
|
|
irqW#trigger#index#depth#_ \<Rightarrow>
|
|
Some (IrqControlIssueIrqHandlerIntent ((ucast irqW)::10 word) index depth)
|
|
| _ \<Rightarrow> Nothing"
|
|
|
|
definition
|
|
transform_intent_page_table_map :: "word32 list \<Rightarrow> cdl_page_table_intent option"
|
|
where
|
|
"transform_intent_page_table_map args =
|
|
(case args of
|
|
vaddr#attr#_ \<Rightarrow>
|
|
Some (PageTableMapIntent vaddr attr)
|
|
| _ \<Rightarrow> Nothing)"
|
|
|
|
definition
|
|
transform_intent_page_map :: "word32 list \<Rightarrow> cdl_page_intent option"
|
|
where
|
|
"transform_intent_page_map args =
|
|
(case args of
|
|
vaddr#rightsW#attr#_ \<Rightarrow>
|
|
Some (PageMapIntent vaddr (data_to_rights rightsW) attr)
|
|
| _ \<Rightarrow> Nothing)"
|
|
|
|
definition
|
|
transform_intent_domain :: "word32 list \<Rightarrow> cdl_domain_intent option"
|
|
where
|
|
"transform_intent_domain args =
|
|
(case args of
|
|
d#_ \<Rightarrow> Some (DomainSetIntent (ucast d :: word8))
|
|
| _ \<Rightarrow> Nothing)"
|
|
|
|
(* Added for IOAPIC patch *)
|
|
definition
|
|
to_bool :: "word32 \<Rightarrow> bool"
|
|
where
|
|
"to_bool w \<equiv> w \<noteq> 0"
|
|
|
|
(* A dispatch function that converts the user's message label
|
|
* and IPC buffer into an intent by dispatching on the message label.
|
|
* For malformed messages etc., we return None.
|
|
*)
|
|
|
|
definition
|
|
transform_intent :: "invocation_label \<Rightarrow> word32 list \<Rightarrow> cdl_intent option" where
|
|
"transform_intent label args \<equiv>
|
|
case label of
|
|
GenInvocationLabel InvalidInvocation \<Rightarrow> None
|
|
| GenInvocationLabel UntypedRetype \<Rightarrow>
|
|
map_option UntypedIntent (transform_intent_untyped_retype args)
|
|
| GenInvocationLabel TCBReadRegisters \<Rightarrow>
|
|
map_option TcbIntent
|
|
(transform_intent_tcb_read_registers args)
|
|
| GenInvocationLabel TCBWriteRegisters \<Rightarrow>
|
|
map_option TcbIntent
|
|
(transform_intent_tcb_write_registers args)
|
|
| GenInvocationLabel TCBCopyRegisters \<Rightarrow>
|
|
map_option TcbIntent
|
|
(transform_intent_tcb_copy_registers args)
|
|
| GenInvocationLabel TCBConfigure \<Rightarrow>
|
|
map_option TcbIntent
|
|
(transform_intent_tcb_configure args)
|
|
| GenInvocationLabel TCBSetPriority \<Rightarrow>
|
|
map_option TcbIntent
|
|
(transform_intent_tcb_set_priority args)
|
|
| GenInvocationLabel TCBSetMCPriority \<Rightarrow>
|
|
map_option TcbIntent
|
|
(transform_intent_tcb_set_mcpriority args)
|
|
| GenInvocationLabel TCBSetSchedParams \<Rightarrow>
|
|
map_option TcbIntent
|
|
(transform_intent_tcb_set_sched_params args)
|
|
| GenInvocationLabel TCBSetIPCBuffer \<Rightarrow>
|
|
map_option TcbIntent
|
|
(transform_intent_tcb_set_ipc_buffer args)
|
|
| GenInvocationLabel TCBSetSpace \<Rightarrow>
|
|
map_option TcbIntent
|
|
(transform_intent_tcb_set_space args)
|
|
| GenInvocationLabel TCBSuspend \<Rightarrow> Some (TcbIntent TcbSuspendIntent)
|
|
| GenInvocationLabel TCBResume \<Rightarrow> Some (TcbIntent TcbResumeIntent)
|
|
| GenInvocationLabel TCBBindNotification \<Rightarrow> Some (TcbIntent TcbBindNTFNIntent)
|
|
| GenInvocationLabel TCBUnbindNotification \<Rightarrow> Some (TcbIntent TcbUnbindNTFNIntent)
|
|
| GenInvocationLabel TCBSetTLSBase \<Rightarrow> Some (TcbIntent TcbSetTLSBaseIntent)
|
|
| GenInvocationLabel CNodeRevoke \<Rightarrow>
|
|
map_option CNodeIntent
|
|
(transform_cnode_index_and_depth CNodeRevokeIntent args)
|
|
| GenInvocationLabel CNodeDelete \<Rightarrow>
|
|
map_option CNodeIntent
|
|
(transform_cnode_index_and_depth CNodeDeleteIntent args)
|
|
| GenInvocationLabel CNodeCancelBadgedSends \<Rightarrow>
|
|
map_option CNodeIntent
|
|
(transform_cnode_index_and_depth CNodeCancelBadgedSendsIntent args)
|
|
| GenInvocationLabel CNodeCopy \<Rightarrow>
|
|
map_option CNodeIntent
|
|
(transform_intent_cnode_copy args)
|
|
| GenInvocationLabel CNodeMint \<Rightarrow>
|
|
map_option CNodeIntent
|
|
(transform_intent_cnode_mint args)
|
|
| GenInvocationLabel CNodeMove \<Rightarrow>
|
|
map_option CNodeIntent
|
|
(transform_intent_cnode_move args)
|
|
| GenInvocationLabel CNodeMutate \<Rightarrow>
|
|
map_option CNodeIntent
|
|
(transform_intent_cnode_mutate args)
|
|
| GenInvocationLabel CNodeRotate \<Rightarrow>
|
|
map_option CNodeIntent
|
|
(transform_intent_cnode_rotate args)
|
|
| GenInvocationLabel CNodeSaveCaller \<Rightarrow>
|
|
map_option CNodeIntent
|
|
(transform_cnode_index_and_depth CNodeSaveCallerIntent args)
|
|
| GenInvocationLabel IRQIssueIRQHandler \<Rightarrow>
|
|
map_option IrqControlIntent
|
|
(transform_intent_issue_irq_handler args)
|
|
| GenInvocationLabel IRQAckIRQ \<Rightarrow> Some (IrqHandlerIntent IrqHandlerAckIntent)
|
|
| GenInvocationLabel IRQSetIRQHandler \<Rightarrow> Some (IrqHandlerIntent IrqHandlerSetEndpointIntent)
|
|
| GenInvocationLabel IRQClearIRQHandler \<Rightarrow> Some (IrqHandlerIntent IrqHandlerClearIntent)
|
|
| ArchInvocationLabel ARMPageTableMap \<Rightarrow>
|
|
map_option PageTableIntent
|
|
(transform_intent_page_table_map args)
|
|
| ArchInvocationLabel ARMPageTableUnmap \<Rightarrow> Some (PageTableIntent PageTableUnmapIntent)
|
|
| ArchInvocationLabel ARMPageMap \<Rightarrow>
|
|
map_option PageIntent
|
|
(transform_intent_page_map args)
|
|
| ArchInvocationLabel ARMPageUnmap \<Rightarrow> Some (PageIntent PageUnmapIntent)
|
|
| ArchInvocationLabel ARMPageClean_Data \<Rightarrow> Some (PageIntent PageFlushCachesIntent )
|
|
| ArchInvocationLabel ARMPageInvalidate_Data \<Rightarrow> Some (PageIntent PageFlushCachesIntent )
|
|
| ArchInvocationLabel ARMPageCleanInvalidate_Data \<Rightarrow> Some (PageIntent PageFlushCachesIntent )
|
|
| ArchInvocationLabel ARMPageUnify_Instruction \<Rightarrow> Some (PageIntent PageFlushCachesIntent )
|
|
| ArchInvocationLabel ARMPageGetAddress \<Rightarrow> Some (PageIntent PageGetAddressIntent )
|
|
| ArchInvocationLabel ARMPDClean_Data \<Rightarrow> Some (PageDirectoryIntent PageDirectoryFlushIntent )
|
|
| ArchInvocationLabel ARMPDInvalidate_Data \<Rightarrow> Some (PageDirectoryIntent PageDirectoryFlushIntent )
|
|
| ArchInvocationLabel ARMPDCleanInvalidate_Data \<Rightarrow> Some (PageDirectoryIntent PageDirectoryFlushIntent)
|
|
| ArchInvocationLabel ARMPDUnify_Instruction \<Rightarrow> Some (PageDirectoryIntent PageDirectoryFlushIntent )
|
|
| ArchInvocationLabel ARMASIDControlMakePool \<Rightarrow>
|
|
map_option AsidControlIntent
|
|
(transform_cnode_index_and_depth AsidControlMakePoolIntent args)
|
|
| ArchInvocationLabel ARMASIDPoolAssign \<Rightarrow> Some (AsidPoolIntent AsidPoolAssignIntent )
|
|
| ArchInvocationLabel ARMIRQIssueIRQHandler \<Rightarrow>
|
|
map_option IrqControlIntent
|
|
(arch_transform_intent_issue_irq_handler args)
|
|
| GenInvocationLabel DomainSetSet \<Rightarrow> map_option DomainIntent (transform_intent_domain args)"
|
|
|
|
lemmas transform_intent_tcb_defs =
|
|
transform_intent_tcb_read_registers_def
|
|
transform_intent_tcb_write_registers_def
|
|
transform_intent_tcb_copy_registers_def
|
|
transform_intent_tcb_configure_def
|
|
transform_intent_tcb_set_priority_def
|
|
transform_intent_tcb_set_mcpriority_def
|
|
transform_intent_tcb_set_sched_params_def
|
|
transform_intent_tcb_set_ipc_buffer_def
|
|
transform_intent_tcb_set_space_def
|
|
|
|
lemma transform_tcb_intent_invocation:
|
|
"transform_intent label args = Some (TcbIntent ti)
|
|
\<Longrightarrow>
|
|
(
|
|
((label = GenInvocationLabel TCBReadRegisters) = (ti = (TcbReadRegistersIntent ((args ! 0)!!0) 0 (args ! 1)) \<and> length args \<ge> 2)) \<and>
|
|
((label = GenInvocationLabel TCBWriteRegisters) = (ti = (TcbWriteRegistersIntent ((args ! 0)!!0) 0 (args ! 1) (drop 2 args)) \<and> length args \<ge> 2)) \<and>
|
|
((label = GenInvocationLabel TCBCopyRegisters) = (ti = (TcbCopyRegistersIntent ((args ! 0)!!0) ((args ! 0)!!1) ((args ! 0)!!2) ((args ! 0)!!3) 0) \<and> length args \<ge> 1)) \<and>
|
|
((label = GenInvocationLabel TCBConfigure) = (ti = (TcbConfigureIntent (args ! 0) (args ! 1) (args ! 2) (args ! 3)) \<and> length args \<ge> 4)) \<and>
|
|
((label = GenInvocationLabel TCBSetPriority) = (ti = (TcbSetPriorityIntent (prio_from_arg (args ! 0))) \<and> length args \<ge> 1)) \<and>
|
|
((label = GenInvocationLabel TCBSetMCPriority) = (ti = (TcbSetMCPriorityIntent (prio_from_arg (args ! 0))) \<and> length args \<ge> 1)) \<and>
|
|
((label = GenInvocationLabel TCBSetSchedParams) = (ti = (TcbSetSchedParamsIntent (prio_from_arg (args ! 0)) (prio_from_arg (args ! 1))) \<and> length args \<ge> 2)) \<and>
|
|
((label = GenInvocationLabel TCBSetSpace) = (ti = (TcbSetSpaceIntent (args ! 0) (args ! 1) (args ! 2)) \<and> length args \<ge> 3)) \<and>
|
|
((label = GenInvocationLabel TCBSuspend) = (ti = TcbSuspendIntent)) \<and>
|
|
((label = GenInvocationLabel TCBResume) = (ti = TcbResumeIntent)) \<and>
|
|
((label = GenInvocationLabel TCBBindNotification) = (ti = TcbBindNTFNIntent)) \<and>
|
|
((label = GenInvocationLabel TCBUnbindNotification) = (ti = TcbUnbindNTFNIntent)) \<and>
|
|
((label = GenInvocationLabel TCBSetTLSBase) = (ti = TcbSetTLSBaseIntent))
|
|
) \<and>
|
|
(
|
|
label \<noteq> GenInvocationLabel InvalidInvocation \<and>
|
|
label \<noteq> GenInvocationLabel UntypedRetype \<and>
|
|
label \<noteq> GenInvocationLabel CNodeRevoke \<and>
|
|
label \<noteq> GenInvocationLabel CNodeDelete \<and>
|
|
label \<noteq> GenInvocationLabel CNodeCancelBadgedSends \<and>
|
|
label \<noteq> GenInvocationLabel CNodeCopy \<and>
|
|
label \<noteq> GenInvocationLabel CNodeMint \<and>
|
|
label \<noteq> GenInvocationLabel CNodeMove \<and>
|
|
label \<noteq> GenInvocationLabel CNodeMutate \<and>
|
|
label \<noteq> GenInvocationLabel CNodeRotate \<and>
|
|
label \<noteq> GenInvocationLabel CNodeSaveCaller \<and>
|
|
label \<noteq> GenInvocationLabel IRQIssueIRQHandler \<and>
|
|
label \<noteq> GenInvocationLabel IRQAckIRQ \<and>
|
|
label \<noteq> GenInvocationLabel IRQSetIRQHandler \<and>
|
|
label \<noteq> GenInvocationLabel IRQClearIRQHandler \<and>
|
|
label \<noteq> ArchInvocationLabel ARMPageTableMap \<and>
|
|
label \<noteq> ArchInvocationLabel ARMPageTableUnmap \<and>
|
|
label \<noteq> ArchInvocationLabel ARMPageMap \<and>
|
|
label \<noteq> ArchInvocationLabel ARMPageUnmap \<and>
|
|
label \<noteq> ArchInvocationLabel ARMPageClean_Data \<and>
|
|
label \<noteq> ArchInvocationLabel ARMPageInvalidate_Data \<and>
|
|
label \<noteq> ArchInvocationLabel ARMPageCleanInvalidate_Data \<and>
|
|
label \<noteq> ArchInvocationLabel ARMPageUnify_Instruction \<and>
|
|
label \<noteq> ArchInvocationLabel ARMPageGetAddress \<and>
|
|
label \<noteq> ArchInvocationLabel ARMPDClean_Data \<and>
|
|
label \<noteq> ArchInvocationLabel ARMPDInvalidate_Data \<and>
|
|
label \<noteq> ArchInvocationLabel ARMPDCleanInvalidate_Data \<and>
|
|
label \<noteq> ArchInvocationLabel ARMPDUnify_Instruction \<and>
|
|
label \<noteq> ArchInvocationLabel ARMASIDControlMakePool \<and>
|
|
label \<noteq> GenInvocationLabel DomainSetSet)"
|
|
apply(intro conjI)
|
|
apply(rule iffI,
|
|
simp add: transform_intent_def transform_intent_tcb_defs split: list.split_asm,
|
|
simp add: transform_intent_def transform_intent_tcb_defs
|
|
split: gen_invocation_labels.split_asm invocation_label.split_asm
|
|
arch_invocation_label.split_asm list.split_asm)+
|
|
(* 30 subgoals *)
|
|
apply(simp add: transform_intent_def transform_intent_tcb_defs
|
|
split: gen_invocation_labels.split_asm invocation_label.split_asm
|
|
arch_invocation_label.split_asm)+
|
|
done
|
|
|
|
lemma transform_intent_isnot_UntypedIntent:
|
|
"(\<not> (\<exists> ui. Some (UntypedIntent ui) = transform_intent label args))
|
|
= ((label \<noteq> GenInvocationLabel UntypedRetype) \<or>
|
|
(label = GenInvocationLabel UntypedRetype \<and> length args < 6) \<or>
|
|
(label = GenInvocationLabel UntypedRetype \<and> length args \<ge> 6 \<and> args ! 0 > 10))"
|
|
apply(rule iffI)
|
|
apply(erule contrapos_np)
|
|
apply(clarsimp)
|
|
apply(simp add: transform_intent_def)
|
|
apply(unfold transform_intent_untyped_retype_def)
|
|
apply (clarsimp split: list.split, safe, simp_all)[1]
|
|
apply (clarsimp simp: transform_type_def)
|
|
apply (simp add: unat_arith_simps)
|
|
apply (simp add: eval_nat_numeral linorder_not_less le_Suc_eq)
|
|
apply(erule disjE)
|
|
apply(auto simp: transform_intent_def option_map_def
|
|
split: gen_invocation_labels.split invocation_label.split arch_invocation_label.split
|
|
option.split_asm)[1]
|
|
apply (erule disjE)
|
|
apply (auto simp: transform_intent_def transform_intent_untyped_retype_def
|
|
option_map_def split: invocation_label.split option.split_asm list.split)[1]
|
|
apply clarsimp
|
|
apply (clarsimp simp: transform_intent_def transform_type_def transform_intent_untyped_retype_def)
|
|
apply (clarsimp simp: option_map_def
|
|
split: invocation_label.splits arch_invocation_label.splits option.splits list.splits)
|
|
apply (clarsimp simp: transform_type_def split: if_split_asm)
|
|
done
|
|
|
|
lemma transform_cnode_index_and_depth_success:
|
|
"(\<exists>ci. Some (C ci) =
|
|
map_option C
|
|
(transform_cnode_index_and_depth C2 args)) =
|
|
(\<not> length args < 2)"
|
|
apply(rule iffI)
|
|
apply(unfold option_map_def transform_cnode_index_and_depth_def)
|
|
apply(case_tac args)
|
|
apply(auto split: list.split)
|
|
done
|
|
|
|
lemmas transform_intent_cnode_defs =
|
|
transform_cnode_index_and_depth_def
|
|
transform_intent_cnode_copy_def
|
|
transform_intent_cnode_mint_def
|
|
transform_intent_cnode_move_def
|
|
transform_intent_cnode_mutate_def
|
|
transform_intent_cnode_rotate_def
|
|
|
|
method case_labels for label :: invocation_label =
|
|
(cases label,
|
|
find_goal \<open>match premises in "label = GenInvocationLabel x" for x \<Rightarrow> \<open>cases x\<close>\<close>,
|
|
find_goal \<open>match premises in "label = ArchInvocationLabel x" for x \<Rightarrow> \<open>cases x\<close>\<close>)
|
|
|
|
lemma transform_intent_isnot_CNodeIntent:
|
|
"(\<not> (\<exists> ui. Some (CNodeIntent ui) = transform_intent label args))
|
|
= ((label = GenInvocationLabel CNodeRevoke \<longrightarrow> length args < 2) \<and>
|
|
(label = GenInvocationLabel CNodeDelete \<longrightarrow> length args < 2) \<and>
|
|
(label = GenInvocationLabel CNodeCancelBadgedSends \<longrightarrow> length args < 2) \<and>
|
|
(label = GenInvocationLabel CNodeCopy \<longrightarrow> length args < 5) \<and>
|
|
(label = GenInvocationLabel CNodeMint \<longrightarrow> length args < 6) \<and>
|
|
(label = GenInvocationLabel CNodeMove \<longrightarrow> length args < 4) \<and>
|
|
(label = GenInvocationLabel CNodeMutate \<longrightarrow> length args < 5) \<and>
|
|
(label = GenInvocationLabel CNodeRotate \<longrightarrow> length args < 8) \<and>
|
|
(label = GenInvocationLabel CNodeSaveCaller \<longrightarrow> length args < 2))"
|
|
apply(rule iffI)
|
|
apply(erule contrapos_np)
|
|
apply(clarsimp simp: transform_intent_def)
|
|
apply(cases label; simp)
|
|
apply(rename_tac gen_label, case_tac gen_label;
|
|
simp add: transform_intent_cnode_defs option_map_def
|
|
split: list.split)
|
|
prefer 10
|
|
apply(clarify)
|
|
apply(case_labels label;
|
|
clarsimp simp: transform_intent_def option_map_def transform_intent_cnode_defs
|
|
split: list.split_asm option.split_asm)
|
|
apply(auto)
|
|
done
|
|
|
|
lemma transform_intent_isnot_TcbIntent:
|
|
"(\<not> (\<exists> ti. Some (TcbIntent ti) = transform_intent label args))
|
|
= ((label = GenInvocationLabel TCBReadRegisters \<longrightarrow> length args < 2) \<and>
|
|
(label = GenInvocationLabel TCBWriteRegisters \<longrightarrow> length args < 2) \<and>
|
|
(label = GenInvocationLabel TCBCopyRegisters \<longrightarrow> length args < 1) \<and>
|
|
(label = GenInvocationLabel TCBConfigure \<longrightarrow> length args < 4) \<and>
|
|
(label = GenInvocationLabel TCBSetPriority \<longrightarrow> length args < 1) \<and>
|
|
(label = GenInvocationLabel TCBSetMCPriority \<longrightarrow> length args < 1) \<and>
|
|
(label = GenInvocationLabel TCBSetSchedParams \<longrightarrow> length args < 2) \<and>
|
|
(label = GenInvocationLabel TCBSetIPCBuffer \<longrightarrow> length args < 1) \<and>
|
|
(label = GenInvocationLabel TCBSetSpace \<longrightarrow> length args < 3) \<and>
|
|
(label \<noteq> GenInvocationLabel TCBSuspend) \<and>
|
|
(label \<noteq> GenInvocationLabel TCBResume) \<and>
|
|
(label \<noteq> GenInvocationLabel TCBBindNotification) \<and>
|
|
(label \<noteq> GenInvocationLabel TCBUnbindNotification) \<and>
|
|
(label \<noteq> GenInvocationLabel TCBSetTLSBase))"
|
|
apply(rule iffI)
|
|
subgoal
|
|
apply(erule contrapos_np)
|
|
apply(clarsimp simp: transform_intent_def)
|
|
apply(case_labels label; simp)
|
|
apply(fastforce simp: transform_intent_tcb_defs option_map_def
|
|
split: list.split)+
|
|
done
|
|
apply(unfold transform_intent_def)
|
|
apply(case_labels label; simp add: option_map_def split: option.split)
|
|
apply(auto simp: transform_intent_tcb_defs
|
|
split: list.splits arch_invocation_label.splits)
|
|
done
|
|
|
|
(*
|
|
* Convert a partial function of type "word \<Rightarrow> 'b" into
|
|
* a partial function of type "nat \<Rightarrow> 'b".
|
|
*
|
|
* It would be nice if we could just use the original
|
|
* partial function as "p (unat x)". Unfortunately, this
|
|
* would mean that "p ((unat x) + 2^32)" would return
|
|
* some non-None value, which isn't what we want.
|
|
*
|
|
* Instead, return a new function that performs a range
|
|
* check prior to calling the original function.
|
|
*)
|
|
definition
|
|
unat_map :: "(('a :: len) word \<rightharpoonup> 'b) \<Rightarrow> (nat \<rightharpoonup> 'b)"
|
|
where
|
|
"unat_map x z \<equiv>
|
|
if z < 2^len_of(TYPE('a)) then
|
|
x (of_nat z)
|
|
else
|
|
None"
|
|
|
|
lemma unat_map_unat [simp]: "(unat_map p) (unat x) = p x"
|
|
by (clarsimp simp: unat_map_def)
|
|
|
|
(*
|
|
* Convert a cslot_ptr into a cdl_cap_ref.
|
|
*)
|
|
definition
|
|
transform_cslot_ptr :: "cslot_ptr \<Rightarrow> cdl_cap_ref"
|
|
where
|
|
"transform_cslot_ptr \<equiv>
|
|
\<lambda> (a, b). (a, nat (bl_to_bin b))"
|
|
|
|
(*
|
|
* Convert an asid into a cdl_asid with asid_low_bits
|
|
* hardcoded.
|
|
*)
|
|
definition
|
|
transform_asid :: "asid \<Rightarrow> cdl_asid"
|
|
where
|
|
"transform_asid asid = (unat (asid_high_bits_of asid), unat (ucast asid :: 10 word))"
|
|
|
|
definition
|
|
transform_mapping :: "(asid \<times> vspace_ref) option \<Rightarrow> cdl_mapped_addr option"
|
|
where
|
|
" transform_mapping mp = option_map (\<lambda>x. (transform_asid (fst x),snd x)) mp"
|
|
|
|
(*
|
|
* Transform a cap in the abstract spec to an equivalent
|
|
* CapDL cap.
|
|
*)
|
|
|
|
definition "free_range_of_untyped \<equiv> (\<lambda>idx size_bits ptr.
|
|
(if (idx \<le> 2^size_bits - 1) then {ptr + of_nat idx .. ptr + 2^size_bits - 1} else {}))"
|
|
definition
|
|
transform_cap :: "cap \<Rightarrow> cdl_cap"
|
|
where
|
|
"transform_cap c \<equiv> case c of
|
|
Structures_A.NullCap \<Rightarrow>
|
|
Types_D.NullCap
|
|
| Structures_A.UntypedCap dev ptr size_bits idx \<Rightarrow>
|
|
Types_D.UntypedCap dev {ptr .. ptr + 2^ size_bits - 1}
|
|
(free_range_of_untyped idx size_bits ptr)
|
|
| Structures_A.EndpointCap ptr badge cap_rights_ \<Rightarrow>
|
|
Types_D.EndpointCap ptr badge cap_rights_
|
|
| Structures_A.NotificationCap ptr badge cap_rights_ \<Rightarrow>
|
|
Types_D.NotificationCap ptr badge cap_rights_
|
|
| Structures_A.ReplyCap ptr is_master cap_rights_ \<Rightarrow>
|
|
if is_master then Types_D.MasterReplyCap ptr else Types_D.ReplyCap ptr cap_rights_
|
|
| Structures_A.CNodeCap ptr size_bits guard \<Rightarrow>
|
|
Types_D.CNodeCap ptr (of_bl guard) (length guard) size_bits
|
|
| Structures_A.ThreadCap ptr \<Rightarrow>
|
|
Types_D.TcbCap ptr
|
|
| Structures_A.DomainCap \<Rightarrow>
|
|
Types_D.DomainCap
|
|
| Structures_A.IRQControlCap \<Rightarrow>
|
|
Types_D.IrqControlCap
|
|
| Structures_A.IRQHandlerCap irq \<Rightarrow>
|
|
Types_D.IrqHandlerCap irq
|
|
| Structures_A.Zombie ptr _ _ \<Rightarrow>
|
|
Types_D.ZombieCap ptr
|
|
| Structures_A.ArchObjectCap arch_cap \<Rightarrow> (case arch_cap of
|
|
ARM_A.ASIDControlCap \<Rightarrow>
|
|
Types_D.AsidControlCap
|
|
| ARM_A.ASIDPoolCap ptr asid \<Rightarrow>
|
|
Types_D.AsidPoolCap ptr (fst $ (transform_asid asid))
|
|
| ARM_A.PageCap dev ptr cap_rights_ sz mp \<Rightarrow>
|
|
Types_D.FrameCap dev ptr cap_rights_ (pageBitsForSize sz) Real (transform_mapping mp)
|
|
| ARM_A.PageTableCap ptr mp \<Rightarrow>
|
|
Types_D.PageTableCap ptr Real (transform_mapping mp)
|
|
| ARM_A.PageDirectoryCap ptr mp \<Rightarrow>
|
|
Types_D.PageDirectoryCap ptr Real (option_map transform_asid mp)
|
|
)
|
|
"
|
|
|
|
(* Transform a list of (caps, refs) into CDL equivalents. *)
|
|
definition
|
|
transform_cap_list :: "(cap \<times> cslot_ptr) list
|
|
\<Rightarrow> (cdl_cap \<times> cdl_cap_ref) list"
|
|
where
|
|
"transform_cap_list \<equiv>
|
|
map (\<lambda>(cap, slot). (transform_cap cap, transform_cslot_ptr slot))"
|
|
|
|
|
|
\<comment> \<open>Convert a nat into a bool list of the given size.\<close>
|
|
definition
|
|
nat_to_bl :: "nat \<Rightarrow> nat \<Rightarrow> bool list option"
|
|
where
|
|
"nat_to_bl bits n \<equiv>
|
|
if n \<ge> 2^bits then
|
|
None
|
|
else
|
|
Some $ bin_to_bl bits (of_nat n)"
|
|
|
|
lemma nat_to_bl_id [simp]: "nat_to_bl (size (x :: (('a::len) word))) (unat x) = Some (to_bl x)"
|
|
by (clarsimp simp: nat_to_bl_def to_bl_def le_def word_size)
|
|
|
|
(* FIXME: MOVE *)
|
|
definition
|
|
option_join :: "'a option option \<Rightarrow> 'a option"
|
|
where
|
|
"option_join x \<equiv> case x of
|
|
Some (Some y) \<Rightarrow> Some y
|
|
| _ \<Rightarrow> None"
|
|
|
|
definition
|
|
option_map_join :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a option \<Rightarrow> 'b option"
|
|
where
|
|
"option_map_join f x \<equiv> case x of
|
|
Some y \<Rightarrow> f y
|
|
| _ \<Rightarrow> None"
|
|
|
|
lemmas option_map_join_simps = option_map_join_def [split_simps option.split]
|
|
|
|
(* Transform a CNode. *)
|
|
|
|
definition
|
|
transform_cnode_contents :: "nat \<Rightarrow> cnode_contents \<Rightarrow> cdl_cap_map"
|
|
where
|
|
"transform_cnode_contents sz c \<equiv> \<lambda>n. option_map transform_cap (option_map_join c (nat_to_bl sz n))"
|
|
|
|
|
|
(* Create a "TCB pending operation" cap based on the given thread's
|
|
* current state. *)
|
|
|
|
definition
|
|
infer_tcb_pending_op :: "obj_ref \<Rightarrow> Structures_A.thread_state \<Rightarrow> cdl_cap"
|
|
where
|
|
"infer_tcb_pending_op ptr t \<equiv>
|
|
case t of
|
|
Structures_A.BlockedOnReceive ptr payload \<Rightarrow>
|
|
PendingSyncRecvCap ptr False (receiver_can_grant payload)
|
|
|
|
| Structures_A.BlockedOnReply \<Rightarrow>
|
|
PendingSyncRecvCap ptr True False
|
|
|
|
| Structures_A.BlockedOnSend ptr payload \<Rightarrow>
|
|
PendingSyncSendCap ptr
|
|
(sender_badge payload) (sender_is_call payload)
|
|
(sender_can_grant payload) (sender_can_grant_reply payload)
|
|
False
|
|
|
|
| Structures_A.BlockedOnNotification ptr \<Rightarrow>
|
|
PendingNtfnRecvCap ptr
|
|
|
|
| Structures_A.Restart \<Rightarrow> RestartCap
|
|
|
|
| Structures_A.Running \<Rightarrow> RunningCap
|
|
|
|
| _ \<Rightarrow> Types_D.NullCap
|
|
"
|
|
|
|
(* Create a "Bound NTFN" cap based on the given thread's
|
|
* current state. *)
|
|
|
|
definition
|
|
infer_tcb_bound_notification :: "obj_ref option \<Rightarrow> cdl_cap"
|
|
where
|
|
"infer_tcb_bound_notification a \<equiv> case a of
|
|
Some ntfn \<Rightarrow> BoundNotificationCap ntfn
|
|
| _ \<Rightarrow> Types_D.NullCap"
|
|
|
|
definition
|
|
evalMonad :: "('s, 'a) nondet_monad \<Rightarrow> 's \<Rightarrow> 'a option"
|
|
where
|
|
"evalMonad m s = (if fst (m s) = {} then None else Some (SOME x. x \<in> fst ` (fst (m s))))"
|
|
|
|
(* The monad here avoids repeating the def of loadWord *)
|
|
definition
|
|
get_ipc_buffer_words :: "machine_state \<Rightarrow> tcb \<Rightarrow> nat list \<Rightarrow> word32 list"
|
|
where
|
|
"get_ipc_buffer_words ms tcb ns \<equiv>
|
|
let
|
|
p = tcb_ipc_buffer tcb;
|
|
cap = tcb_ipcframe tcb;
|
|
wordsM = case cap of
|
|
cap.ArchObjectCap (arch_cap.PageCap dev buf rights sz mapdata) \<Rightarrow> if AllowRead \<in> rights then
|
|
mapM loadWord (map (\<lambda>n. buf + (p && mask(pageBitsForSize sz)) + (of_nat (n * word_size))) ns)
|
|
else return []
|
|
| _ \<Rightarrow> return []
|
|
in
|
|
the (evalMonad wordsM ms)"
|
|
|
|
definition
|
|
get_tcb_message_info :: "tcb \<Rightarrow> Structures_A.message_info"
|
|
where
|
|
"get_tcb_message_info t \<equiv> data_to_message_info ((arch_tcb_context_get (tcb_arch t)) msg_info_register)"
|
|
|
|
definition
|
|
get_tcb_mrs :: "machine_state \<Rightarrow> tcb \<Rightarrow> word32 list"
|
|
where
|
|
"get_tcb_mrs ms tcb \<equiv>
|
|
let
|
|
info = get_tcb_message_info tcb;
|
|
cpu_mrs = map (arch_tcb_context_get (tcb_arch tcb)) msg_registers;
|
|
mem_mrs = get_ipc_buffer_words ms tcb [length msg_registers + 1 ..< Suc msg_max_length]
|
|
in
|
|
(take (unat (mi_length info)) (cpu_mrs @ mem_mrs))"
|
|
|
|
(* Convert contents of the user's IPC buffer into an intent. *)
|
|
definition "guess_error \<equiv> \<lambda>x. x \<noteq> (0::word32)"
|
|
|
|
definition
|
|
transform_full_intent :: "machine_state \<Rightarrow> obj_ref \<Rightarrow> tcb \<Rightarrow> cdl_full_intent"
|
|
where
|
|
"transform_full_intent ms r tcb \<equiv>
|
|
let mi = get_tcb_message_info tcb;
|
|
offset = msg_max_length + msg_max_extra_caps + 2
|
|
in
|
|
\<lparr> cdl_intent_op = (transform_intent
|
|
(invocation_type (mi_label mi))
|
|
(get_tcb_mrs ms tcb)),
|
|
cdl_intent_error = guess_error (mi_label mi),
|
|
cdl_intent_cap = arch_tcb_context_get (tcb_arch tcb) cap_register,
|
|
cdl_intent_extras = get_ipc_buffer_words ms tcb [buffer_cptr_index ..< buffer_cptr_index + (unat (mi_extra_caps mi))],
|
|
cdl_intent_recv_slot = case (get_ipc_buffer_words ms tcb [offset ..< offset + 3]) of
|
|
[croot, index, depth] \<Rightarrow> Some (croot, index, unat depth)
|
|
| _ \<Rightarrow> None
|
|
\<rparr>"
|
|
|
|
lemma invocation_type0:
|
|
"invocation_type 0 = GenInvocationLabel InvalidInvocation"
|
|
by (clarsimp simp: invocation_type_def toEnum_def enum_invocation_label enum_gen_invocation_labels)
|
|
|
|
(* Transform a TCB object. *)
|
|
abbreviation
|
|
"tcb_has_fault \<equiv> \<lambda>tcb. tcb_fault tcb \<noteq> None"
|
|
|
|
definition
|
|
transform_tcb :: "machine_state \<Rightarrow> obj_ref \<Rightarrow> tcb \<Rightarrow> etcb \<Rightarrow> cdl_object"
|
|
where
|
|
"transform_tcb ms ptr tcb etcb \<equiv>
|
|
Types_D.Tcb \<lparr> cdl_tcb_caps = [
|
|
tcb_cspace_slot \<mapsto> (transform_cap $ tcb_ctable tcb),
|
|
tcb_vspace_slot \<mapsto> (transform_cap $ tcb_vtable tcb),
|
|
tcb_replycap_slot \<mapsto> (transform_cap $ tcb_reply tcb),
|
|
tcb_caller_slot \<mapsto> (transform_cap $ tcb_caller tcb),
|
|
tcb_ipcbuffer_slot \<mapsto> (transform_cap $ tcb_ipcframe tcb),
|
|
tcb_pending_op_slot \<mapsto> (infer_tcb_pending_op ptr (tcb_state tcb)),
|
|
tcb_boundntfn_slot \<mapsto> (infer_tcb_bound_notification (tcb_bound_notification tcb))
|
|
],
|
|
|
|
cdl_tcb_fault_endpoint = (of_bl (tcb_fault_handler tcb)),
|
|
|
|
\<comment> \<open>Decode the thread's intent.\<close>
|
|
cdl_tcb_intent = transform_full_intent ms ptr tcb,
|
|
cdl_tcb_has_fault = (tcb_has_fault tcb),
|
|
cdl_tcb_domain = tcb_domain etcb
|
|
\<rparr>"
|
|
|
|
definition
|
|
transform_asid_pool_entry :: "obj_ref option \<Rightarrow> cdl_cap"
|
|
where
|
|
"transform_asid_pool_entry p \<equiv> case p of
|
|
None \<Rightarrow> Types_D.NullCap
|
|
| Some p \<Rightarrow> Types_D.PageDirectoryCap p Fake None"
|
|
|
|
(*
|
|
* Transform an AsidPool.
|
|
*
|
|
* This converts the object references into PageDirectory caps.
|
|
*)
|
|
definition
|
|
transform_asid_pool_contents :: "(10 word \<Rightarrow> obj_ref option) \<Rightarrow> cdl_cap_map"
|
|
where
|
|
"transform_asid_pool_contents M \<equiv> unat_map (Some \<circ> transform_asid_pool_entry \<circ> M)"
|
|
|
|
definition
|
|
transform_paddr :: "paddr \<Rightarrow> cdl_object_id"
|
|
where
|
|
"transform_paddr = ptrFromPAddr"
|
|
|
|
declare transform_paddr_def[simp]
|
|
|
|
(*
|
|
* Transform a PageTable, one entry(PTE) at a time.
|
|
*
|
|
* This transforms the references to frames into frame caps.
|
|
*)
|
|
definition
|
|
transform_pte :: "ARM_A.pte \<Rightarrow> cdl_cap"
|
|
where
|
|
"transform_pte pte \<equiv> case pte of
|
|
ARM_A.InvalidPTE \<Rightarrow> cdl_cap.NullCap
|
|
| ARM_A.LargePagePTE ref _ rights_ \<Rightarrow>
|
|
Types_D.FrameCap False (transform_paddr ref) rights_
|
|
(pageBitsForSize ARMLargePage) Fake None
|
|
| ARM_A.SmallPagePTE ref _ rights_ \<Rightarrow>
|
|
Types_D.FrameCap False (transform_paddr ref) rights_
|
|
(pageBitsForSize ARMSmallPage) Fake None"
|
|
|
|
definition
|
|
transform_page_table_contents :: "(word8 \<Rightarrow> ARM_A.pte) \<Rightarrow> (nat \<Rightarrow> cdl_cap option)"
|
|
where
|
|
"transform_page_table_contents M \<equiv> unat_map (Some o transform_pte o M)"
|
|
|
|
(*
|
|
* Transform a PageDirectory, one entry(PDE) at a time.
|
|
*
|
|
* This transforms the references to frames into PageTable or Frame caps.
|
|
*)
|
|
definition
|
|
transform_pde :: "ARM_A.pde \<Rightarrow> cdl_cap"
|
|
where
|
|
"transform_pde pde \<equiv> case pde of
|
|
ARM_A.InvalidPDE \<Rightarrow> cdl_cap.NullCap
|
|
| ARM_A.PageTablePDE ref _ _ \<Rightarrow>
|
|
Types_D.PageTableCap (transform_paddr ref) Fake None
|
|
| ARM_A.SectionPDE ref _ _ rights_ \<Rightarrow>
|
|
Types_D.FrameCap False (transform_paddr ref) rights_
|
|
(pageBitsForSize ARMSection) Fake None
|
|
| ARM_A.SuperSectionPDE ref _ rights_ \<Rightarrow>
|
|
Types_D.FrameCap False (transform_paddr ref) rights_
|
|
(pageBitsForSize ARMSuperSection) Fake None"
|
|
|
|
definition
|
|
kernel_pde_mask :: "(12 word \<Rightarrow> ARM_A.pde) \<Rightarrow> (12 word \<Rightarrow> ARM_A.pde)"
|
|
where
|
|
"kernel_pde_mask M \<equiv> \<lambda>x.
|
|
if (ucast (kernel_base >> 20)) \<le> x then ARM_A.InvalidPDE else M x"
|
|
|
|
definition
|
|
transform_page_directory_contents :: "(12 word \<Rightarrow> ARM_A.pde) \<Rightarrow> (nat \<Rightarrow> cdl_cap option)"
|
|
where
|
|
"transform_page_directory_contents M \<equiv> unat_map (Some o transform_pde o kernel_pde_mask M)"
|
|
|
|
(* sseefried: The 'undefined' case below will never occur as long as this function is invoked in an environment
|
|
where the invariant 'valid_etcbs s' holds *)
|
|
(* Transform a kernel object. *)
|
|
definition
|
|
transform_object :: "machine_state \<Rightarrow> obj_ref \<Rightarrow> etcb option \<Rightarrow> kernel_object \<Rightarrow> cdl_object"
|
|
where
|
|
"transform_object ms ref opt_etcb ko \<equiv> case ko of
|
|
Structures_A.CNode 0 c \<Rightarrow>
|
|
Types_D.IRQNode \<lparr>cdl_irq_node_caps = transform_cnode_contents 0 c\<rparr>
|
|
| Structures_A.CNode sz c \<Rightarrow>
|
|
Types_D.CNode \<lparr>
|
|
cdl_cnode_caps = transform_cnode_contents sz c,
|
|
cdl_cnode_size_bits = sz
|
|
\<rparr>
|
|
| Structures_A.TCB tcb \<Rightarrow> (case opt_etcb of Some etcb \<Rightarrow> transform_tcb ms ref tcb etcb | None \<Rightarrow> undefined)
|
|
| Structures_A.Endpoint _ \<Rightarrow> Types_D.Endpoint
|
|
| Structures_A.Notification _ \<Rightarrow> Types_D.Notification
|
|
| Structures_A.ArchObj (ARM_A.ASIDPool ap) \<Rightarrow>
|
|
Types_D.AsidPool \<lparr>cdl_asid_pool_caps = (transform_asid_pool_contents ap)\<rparr>
|
|
| Structures_A.ArchObj (ARM_A.PageTable ptx) \<Rightarrow>
|
|
Types_D.PageTable \<lparr>cdl_page_table_caps = (transform_page_table_contents ptx)\<rparr>
|
|
| Structures_A.ArchObj (ARM_A.PageDirectory pd) \<Rightarrow>
|
|
Types_D.PageDirectory \<lparr>cdl_page_directory_caps = (transform_page_directory_contents pd)\<rparr>
|
|
| Structures_A.ArchObj (ARM_A.DataPage dev sz) \<Rightarrow>
|
|
Types_D.Frame \<lparr>cdl_frame_size_bits = pageBitsForSize sz\<rparr>"
|
|
|
|
lemmas transform_object_simps [simp] =
|
|
transform_object_def [split_simps Structures_A.kernel_object.split ARM_A.arch_kernel_obj.split]
|
|
|
|
(* Lifts a map over a function, returning the empty map if that
|
|
function would be insufficiently injective *)
|
|
definition
|
|
map_lift_over :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<rightharpoonup> 'a) \<Rightarrow> ('b \<rightharpoonup> 'b)"
|
|
where
|
|
"map_lift_over f m = (if inj_on f (dom m \<union> ran m)
|
|
then (\<lambda>x. if \<exists>y. f y = x \<and> y \<in> dom m
|
|
then map_option f (m (inv_into (dom m) f x)) else None)
|
|
else Map.empty)"
|
|
|
|
(* Transform the CDT. *)
|
|
definition
|
|
transform_cdt :: "'z::state_ext state \<Rightarrow> cdl_cdt"
|
|
where
|
|
"transform_cdt s =
|
|
map_lift_over transform_cslot_ptr (cdt s)"
|
|
|
|
definition
|
|
get_obj :: "'z::state_ext state \<Rightarrow> obj_ref \<Rightarrow> kernel_object option"
|
|
where
|
|
"get_obj s r \<equiv> (kheap s) r"
|
|
|
|
definition
|
|
cap_installed_at_irq :: "irq \<Rightarrow> 'z::state_ext state \<Rightarrow> cap option"
|
|
where
|
|
"cap_installed_at_irq irq s \<equiv> caps_of_state s (interrupt_irq_node s irq, [])"
|
|
|
|
abbreviation
|
|
option_map2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a option \<Rightarrow> 'b option \<Rightarrow> 'c option"
|
|
where
|
|
"option_map2 f opt_a opt_b \<equiv> case opt_a of
|
|
None \<Rightarrow> None
|
|
| Some a \<Rightarrow> (case opt_b of
|
|
None \<Rightarrow> None
|
|
| Some b \<Rightarrow> Some (f a b))"
|
|
|
|
|
|
|
|
|
|
|
|
(* Transform objects in the abstract spec to CapDL.
|
|
Empty memory is transformed into Untyped objects. *)
|
|
definition
|
|
transform_objects :: "det_ext state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_object option)"
|
|
where
|
|
"transform_objects s = (\<lambda>ptr. Some Types_D.Untyped) |` (- {idle_thread s}) ++
|
|
(\<lambda>ptr. map_option (transform_object (machine_state s) ptr ((ekheap s |` (- {idle_thread s})) ptr))
|
|
((kheap s |` (- {idle_thread s})) ptr))"
|
|
|
|
lemma evalMonad_return [simp]:
|
|
"evalMonad (return x) s = Some x"
|
|
by (simp add: evalMonad_def return_def)
|
|
|
|
definition
|
|
"det_or_fail f \<equiv> \<forall>s. fst (f s) = {} \<or> (\<exists>r. fst (f s) = {r})"
|
|
|
|
lemma evalMonad_bind:
|
|
assumes f: "\<And>P. \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. P\<rbrace>"
|
|
assumes det: "det_or_fail f"
|
|
shows "evalMonad (f >>= g) s = (if evalMonad f s = None then None else evalMonad (g (the (evalMonad f s))) s)"
|
|
apply (case_tac "evalMonad f s")
|
|
apply (simp add: evalMonad_def split: if_split_asm)
|
|
apply (simp add: bind_def)
|
|
apply simp
|
|
apply (simp add: evalMonad_def)
|
|
apply (clarsimp simp: bind_def)
|
|
apply (insert det)
|
|
apply (clarsimp simp: det_or_fail_def split: if_split_asm)
|
|
apply (erule_tac x=s in allE)
|
|
apply clarsimp
|
|
apply (subgoal_tac "b = s")
|
|
apply simp
|
|
apply (subgoal_tac "(a,b) \<in> fst (f s)")
|
|
apply (drule use_valid, rule f [where P="(=) s"])
|
|
apply (rule refl)
|
|
apply simp
|
|
apply simp
|
|
done
|
|
|
|
lemma bind_dfI:
|
|
"\<lbrakk> det_or_fail f; \<And>x. det_or_fail (g x) \<rbrakk> \<Longrightarrow> det_or_fail (f >>= g)"
|
|
apply (auto simp: det_or_fail_def bind_def split_def)
|
|
apply force
|
|
done
|
|
|
|
lemma return_df:
|
|
"det_or_fail (return x)"
|
|
by (simp add: det_or_fail_def return_def)
|
|
|
|
lemma assert_df:
|
|
"det_or_fail (assert P)"
|
|
by (simp add: assert_def fail_def det_or_fail_def return_def)
|
|
|
|
lemma mapM_df:
|
|
"(\<And>x. det_or_fail (f x)) \<Longrightarrow> det_or_fail (mapM f xs)"
|
|
apply (induct xs)
|
|
apply (simp add: mapM_Nil return_df)
|
|
apply (simp add: mapM_Cons)
|
|
apply (rule bind_dfI, assumption)
|
|
apply (rule bind_dfI, assumption)
|
|
apply (rule return_df)
|
|
done
|
|
|
|
lemma df_loadWord: "det_or_fail (loadWord x)"
|
|
apply (unfold loadWord_def)
|
|
apply (rule bind_dfI)
|
|
apply (simp add: simpler_gets_def det_or_fail_def)
|
|
apply clarsimp
|
|
apply (rule bind_dfI)
|
|
apply (rule assert_df)
|
|
apply (rule return_df)
|
|
done
|
|
|
|
lemma evalMonad_loadWord_cong:
|
|
"underlying_memory ms = underlying_memory ms' \<Longrightarrow>
|
|
evalMonad (loadWord x) ms = evalMonad (loadWord x) ms'"
|
|
by (simp add: loadWord_def bind_def simpler_gets_def assert_def
|
|
return_def fail_def evalMonad_def)
|
|
|
|
lemma evalMonad_mapM_cong:
|
|
assumes f: "\<And>x. evalMonad (f x) ms = evalMonad (f x) ms'"
|
|
assumes P: "\<And>P x. \<lbrace>P\<rbrace> f x \<lbrace>\<lambda>_. P\<rbrace>"
|
|
assumes det: "\<And>x. det_or_fail (f x)"
|
|
shows "evalMonad (mapM f xs) ms = evalMonad (mapM f xs) ms'"
|
|
apply (induct xs)
|
|
apply (simp add: mapM_Nil)
|
|
apply (simp add: mapM_Cons)
|
|
apply (subst evalMonad_bind [OF P det])
|
|
apply (subst evalMonad_bind [OF P det])
|
|
apply (clarsimp simp: f)
|
|
apply (subst evalMonad_bind)
|
|
apply (wp mapM_wp' P)
|
|
apply (rule mapM_df, rule det)
|
|
apply (subst evalMonad_bind)
|
|
apply (wp mapM_wp' P)
|
|
apply (rule mapM_df, rule det)
|
|
apply simp
|
|
done
|
|
|
|
lemma evalMonad_mapM_loadWord_cong:
|
|
"underlying_memory ms = underlying_memory ms' \<Longrightarrow>
|
|
evalMonad (mapM loadWord xs) ms = evalMonad (mapM loadWord xs) ms'"
|
|
apply (rule evalMonad_mapM_cong)
|
|
apply (simp cong: evalMonad_loadWord_cong)
|
|
apply (wp loadWord_inv)
|
|
apply (rule df_loadWord)
|
|
done
|
|
|
|
lemma get_ipc_buffer_words_cong:
|
|
"underlying_memory ms = underlying_memory ms' \<Longrightarrow>
|
|
get_ipc_buffer_words ms = get_ipc_buffer_words ms'"
|
|
apply (rule ext)+
|
|
apply (simp add: get_ipc_buffer_words_def Let_def cong: evalMonad_mapM_loadWord_cong
|
|
split: cap.splits arch_cap.splits)
|
|
done
|
|
|
|
lemma get_tcb_mrs_cong:
|
|
"underlying_memory ms = underlying_memory ms' \<Longrightarrow> get_tcb_mrs ms = get_tcb_mrs ms'"
|
|
apply (rule ext)
|
|
apply (simp add: get_tcb_mrs_def Let_def cong: get_ipc_buffer_words_cong)
|
|
done
|
|
|
|
lemma transform_objects_ms_underlying_mem:
|
|
"transform_objects s =
|
|
transform_objects (s \<lparr> machine_state :=
|
|
undefined \<lparr> underlying_memory := underlying_memory (machine_state s) \<rparr> \<rparr>)"
|
|
supply option.case_cong[cong]
|
|
apply (rule ext)
|
|
apply (simp add: transform_objects_def map_add_def option_map_def
|
|
split: option.split)
|
|
apply (simp add: transform_object_def transform_tcb_def
|
|
transform_full_intent_def Let_def
|
|
split: Structures_A.kernel_object.split)
|
|
apply (clarsimp simp: transform_intent_def cong: get_tcb_mrs_cong get_ipc_buffer_words_cong)
|
|
done
|
|
|
|
lemmas transform_objects_def2
|
|
= trans [OF transform_objects_ms_underlying_mem
|
|
transform_objects_def,
|
|
simplified]
|
|
|
|
(*
|
|
* Transform the current thread in the abstract spec to CapDL.
|
|
*
|
|
* We just return the thread's memory address, unless it happens
|
|
* to be the idle thread, which CapDL maps as "None".
|
|
*)
|
|
definition
|
|
transform_current_thread :: "'z::state_ext state \<Rightarrow> cdl_object_id option"
|
|
where
|
|
"transform_current_thread s \<equiv>
|
|
if (cur_thread s \<noteq> idle_thread s) then
|
|
Some (cur_thread s)
|
|
else
|
|
None"
|
|
|
|
definition
|
|
transform_asid_table_entry :: "obj_ref option \<Rightarrow> cdl_cap"
|
|
where
|
|
"transform_asid_table_entry p \<equiv> case p of
|
|
None \<Rightarrow> Types_D.NullCap
|
|
| Some p \<Rightarrow> Types_D.AsidPoolCap p 0"
|
|
|
|
definition
|
|
transform_asid_table :: "'z::state_ext state \<Rightarrow> cdl_cap_map"
|
|
where
|
|
"transform_asid_table s \<equiv>
|
|
let asid_table = arm_asid_table $ arch_state s
|
|
in unat_map (Some \<circ> transform_asid_table_entry \<circ> asid_table)"
|
|
|
|
definition
|
|
transform_current_domain :: "det_ext state \<Rightarrow> word8"
|
|
where
|
|
"transform_current_domain s = cur_domain s"
|
|
|
|
(*
|
|
* Transform an abstract spec state into the corresponding
|
|
* CDL state.
|
|
*)
|
|
definition
|
|
transform :: "det_ext state \<Rightarrow> cdl_state"
|
|
where
|
|
"transform s \<equiv> \<lparr>
|
|
cdl_arch = ARM11,
|
|
cdl_objects = transform_objects s,
|
|
cdl_cdt = transform_cdt s,
|
|
cdl_current_thread = transform_current_thread s,
|
|
cdl_irq_node = interrupt_irq_node s,
|
|
cdl_asid_table = transform_asid_table s,
|
|
cdl_current_domain = transform_current_domain s
|
|
\<rparr>"
|
|
|
|
end
|
|
|
|
end
|
|
|