522 lines
25 KiB
Plaintext
522 lines
25 KiB
Plaintext
(*
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
|
*
|
|
* SPDX-License-Identifier: GPL-2.0-only
|
|
*)
|
|
|
|
theory SysInit_SI
|
|
imports
|
|
"DSpecProofs.Kernel_DP"
|
|
"Lib.NonDetMonadLemmaBucket"
|
|
begin
|
|
|
|
definition
|
|
parse_bootinfo :: "cdl_bootinfo \<Rightarrow> (cdl_cptr list \<times> cdl_cptr list) u_monad"
|
|
where
|
|
"parse_bootinfo bootinfo \<equiv> do
|
|
(untyped_start, untyped_end) \<leftarrow> return $ bi_untypes bootinfo;
|
|
untyped_list \<leftarrow> return [untyped_start .e. (untyped_end - 1)];
|
|
|
|
(free_slot_start, free_slot_end) \<leftarrow> return $ bi_free_slots bootinfo;
|
|
free_slots \<leftarrow> return [free_slot_start .e. (free_slot_end - 1)];
|
|
|
|
return (untyped_list, free_slots)
|
|
od"
|
|
|
|
(* Create a new object in the next free cnode slot using a given untyped.
|
|
Return whether or not the operation fails. *)
|
|
definition
|
|
retype_untyped :: "cdl_cptr \<Rightarrow> cdl_cptr \<Rightarrow> cdl_object_type \<Rightarrow> nat \<Rightarrow> bool u_monad"
|
|
where
|
|
"retype_untyped free_slot free_untyped type size_bits \<equiv>
|
|
seL4_Untyped_Retype free_untyped type (of_nat size_bits)
|
|
seL4_CapInitThreadCNode 0 0 free_slot 1"
|
|
|
|
definition
|
|
inc_when :: "bool \<Rightarrow> nat \<Rightarrow> ('s,nat) nondet_monad"
|
|
where
|
|
"inc_when P x \<equiv> return (if P then Suc x else x)"
|
|
|
|
lemma inc_when_wp [wp]:
|
|
"\<lbrace>Q (if B then Suc x else x)\<rbrace> inc_when B x \<lbrace>Q\<rbrace>"
|
|
by (unfold inc_when_def, wp)
|
|
|
|
definition
|
|
update_when :: "bool \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> 'a \<Rightarrow> 'b
|
|
\<Rightarrow> ('s,('a \<Rightarrow> 'b option)) nondet_monad"
|
|
where
|
|
"update_when P t a b \<equiv> return (if P then t(a \<mapsto> b) else t)"
|
|
|
|
lemma update_when_wp [wp]:
|
|
"\<lbrace>Q (if B then t(a \<mapsto> b) else t)\<rbrace> update_when B t a b \<lbrace>Q\<rbrace>"
|
|
by (unfold update_when_def, wp)
|
|
|
|
(* Create the objects in the capDL spec.
|
|
Caps to new objects are stored in the free slots. *)
|
|
|
|
definition create_objects :: "cdl_state \<Rightarrow> cdl_object_id list
|
|
\<Rightarrow> cdl_cptr list \<Rightarrow> cdl_cptr list
|
|
\<Rightarrow> ((cdl_object_id \<Rightarrow> cdl_cptr option) \<times> cdl_cptr list) u_monad"
|
|
where
|
|
"create_objects spec obj_ids untyped_cptrs free_cptrs \<equiv> do
|
|
(obj_id_index, untyped_index, si_caps) \<leftarrow> whileLoop (\<lambda>(obj_id_index, untyped_index, si_caps) _.
|
|
obj_id_index < length [obj\<leftarrow>obj_ids. real_object_at obj spec] \<and>
|
|
obj_id_index < length free_cptrs \<and>
|
|
untyped_index < length untyped_cptrs)
|
|
(\<lambda>(obj_id_index, untyped_index, si_caps).
|
|
do
|
|
obj_id \<leftarrow> return $ [obj\<leftarrow>obj_ids. real_object_at obj spec] ! obj_id_index;
|
|
free_cptr \<leftarrow> return $ free_cptrs ! obj_id_index;
|
|
untyped_cptr \<leftarrow> return $ untyped_cptrs ! untyped_index;
|
|
|
|
object \<leftarrow> get_spec_object spec obj_id;
|
|
object_type \<leftarrow> return $ object_type object;
|
|
object_size \<leftarrow> return $ object_size_bits object;
|
|
|
|
fail \<leftarrow> retype_untyped free_cptr untyped_cptr object_type object_size;
|
|
|
|
obj_id_index \<leftarrow> inc_when (\<not> fail) obj_id_index;
|
|
untyped_index \<leftarrow> inc_when fail untyped_index;
|
|
si_caps \<leftarrow> update_when (\<not> fail) si_caps obj_id free_cptr;
|
|
return (obj_id_index, untyped_index, si_caps)
|
|
od) (0, 0, Map.empty);
|
|
assert (untyped_index \<noteq> length untyped_cptrs);
|
|
return (si_caps, drop (length [obj\<leftarrow>obj_ids. real_object_at obj spec]) free_cptrs)
|
|
od"
|
|
|
|
|
|
(* This makes the IRQ handler caps.
|
|
* These caps are then used to set up the IRQs.
|
|
* We need some predicate to say that they are there.
|
|
* irq \<mapsto>c IrqHandlerCap cnode_id?
|
|
*)
|
|
definition create_irq_cap :: "cdl_state \<Rightarrow> (cdl_irq \<times> cdl_cptr) \<Rightarrow> unit u_monad"
|
|
where
|
|
"create_irq_cap spec \<equiv> \<lambda>(irq, free_cptr). do
|
|
control_cap \<leftarrow> return seL4_CapIRQControl;
|
|
root \<leftarrow> return seL4_CapInitThreadCNode;
|
|
index \<leftarrow> return $ free_cptr;
|
|
depth \<leftarrow> return (32::word32);
|
|
|
|
fail \<leftarrow> seL4_IRQControl_Get control_cap irq root index depth;
|
|
assert (\<not>fail)
|
|
od"
|
|
|
|
definition
|
|
used_irq_list_compute :: "cdl_state \<Rightarrow> cdl_irq list"
|
|
where
|
|
"used_irq_list_compute \<equiv>
|
|
\<lambda>s. filter
|
|
(HOL.Not o Option.is_none o cdl_objects s o cdl_irq_node s)
|
|
[0 .e. maxBound]"
|
|
|
|
definition create_irq_caps :: "cdl_state \<Rightarrow> cdl_cptr list \<Rightarrow>
|
|
((cdl_irq \<Rightarrow> cdl_cptr option) \<times> cdl_cptr list) u_monad"
|
|
where
|
|
"create_irq_caps spec free_cptrs \<equiv> do
|
|
irqs \<leftarrow> return $ used_irq_list_compute spec;
|
|
mapM_x (create_irq_cap spec) (zip irqs free_cptrs);
|
|
si_irq_caps \<leftarrow> return $ map_of (zip irqs free_cptrs);
|
|
return (si_irq_caps, drop (length irqs) free_cptrs)
|
|
od"
|
|
|
|
(* This one installs the caps in the CNodes.
|
|
* It uses seL4 _IRQHandler_SetEndpoint.
|
|
* It turns irq_empty to irq_initialised?
|
|
*)
|
|
definition
|
|
init_irq :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow>
|
|
(cdl_irq \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_irq \<Rightarrow> unit u_monad"
|
|
where
|
|
"init_irq spec orig_caps irq_caps irq \<equiv> do
|
|
irq_handler_cap \<leftarrow> assert_opt $ irq_caps irq;
|
|
irq_slot \<leftarrow> return $ get_irq_slot irq spec;
|
|
endpoint_cap \<leftarrow> assert_opt $ opt_cap irq_slot spec;
|
|
endpoint_cptr \<leftarrow> assert_opt $ orig_caps (cap_object endpoint_cap);
|
|
|
|
fail \<leftarrow> seL4_IRQHandler_SetEndpoint irq_handler_cap endpoint_cptr;
|
|
assert (\<not>fail)
|
|
od"
|
|
|
|
definition
|
|
init_irqs :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow>
|
|
(cdl_irq \<Rightarrow> cdl_cptr option) \<Rightarrow> unit u_monad"
|
|
where
|
|
"init_irqs spec orig_caps irq_caps \<equiv> do
|
|
irqs \<leftarrow> return $ bound_irq_list spec;
|
|
mapM_x (init_irq spec orig_caps irq_caps) irqs
|
|
od"
|
|
|
|
|
|
(* Make a duplicate of a cap in a new free slot. *)
|
|
definition duplicate_cap :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option)
|
|
\<Rightarrow> (cdl_object_id \<times> cdl_cptr) \<Rightarrow> unit u_monad"
|
|
where
|
|
"duplicate_cap spec orig_caps \<equiv> \<lambda>(obj_id, free_slot). do
|
|
rights \<leftarrow> return $ all_cdl_rights;
|
|
|
|
dest_root \<leftarrow> return seL4_CapInitThreadCNode;
|
|
dest_index \<leftarrow> return $ free_slot;
|
|
dest_depth \<leftarrow> return (32::word32);
|
|
|
|
src_root \<leftarrow> return seL4_CapInitThreadCNode;
|
|
src_index \<leftarrow> assert_opt $ orig_caps obj_id;
|
|
src_depth \<leftarrow> return (32::word32);
|
|
|
|
fail \<leftarrow> seL4_CNode_Copy dest_root dest_index dest_depth
|
|
src_root src_index src_depth rights;
|
|
assert (\<not>fail)
|
|
od"
|
|
|
|
(* As CNode caps can be moved, referencing the CNodes can be tricky.
|
|
* Moving capabilities in a particular order would work for all be difficult circular cases,
|
|
* but just keeping a copy of the caps to all of the CNodes and using the copy is much easier.
|
|
*
|
|
* Thread caps are duplicated as the system initialiser needs to have them to start the threads
|
|
* at the end of initialisation.
|
|
*)
|
|
definition duplicate_caps :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option)
|
|
\<Rightarrow> cdl_object_id list \<Rightarrow> cdl_cptr list
|
|
\<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option) u_monad"
|
|
where
|
|
"duplicate_caps spec orig_caps obj_ids free_slots \<equiv> do
|
|
obj_ids' \<leftarrow> return [obj_id \<leftarrow> obj_ids. cnode_or_tcb_at obj_id spec];
|
|
assert (length obj_ids' \<le> length free_slots);
|
|
mapM_x (duplicate_cap spec orig_caps) (zip obj_ids' free_slots);
|
|
return $ map_of $ zip obj_ids' free_slots
|
|
od"
|
|
|
|
(* Initialise a single tcb (cspace, vspace and fault_ep). *)
|
|
definition init_tcb :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_object_id \<Rightarrow> unit u_monad"
|
|
where
|
|
"init_tcb spec orig_caps tcb_id \<equiv> do
|
|
cdl_tcb \<leftarrow> assert_opt $ opt_thread tcb_id spec;
|
|
cdl_cspace_root \<leftarrow> assert_opt $ opt_cap (tcb_id, tcb_cspace_slot) spec;
|
|
cdl_vspace_root \<leftarrow> assert_opt $ opt_cap (tcb_id, tcb_vspace_slot) spec;
|
|
cdl_ipcbuffer \<leftarrow> assert_opt $ opt_cap (tcb_id, tcb_ipcbuffer_slot) spec;
|
|
ipcbuf_addr \<leftarrow> return $ tcb_ipc_buffer_address cdl_tcb;
|
|
priority \<leftarrow> return $ tcb_priority cdl_tcb;
|
|
|
|
sel4_tcb \<leftarrow> assert_opt $ orig_caps tcb_id;
|
|
sel4_cspace_root \<leftarrow> assert_opt $ orig_caps (cap_object cdl_cspace_root);
|
|
sel4_vspace_root \<leftarrow> assert_opt $ orig_caps (cap_object cdl_vspace_root);
|
|
sel4_ipcbuffer \<leftarrow> assert_opt $ orig_caps (cap_object cdl_ipcbuffer);
|
|
sel4_fault_ep \<leftarrow> return $ cdl_tcb_fault_endpoint cdl_tcb;
|
|
|
|
sel4_cspace_root_data \<leftarrow> return $ guard_as_rawdata cdl_cspace_root;
|
|
sel4_vspace_root_data \<leftarrow> return 0;
|
|
|
|
fail \<leftarrow> seL4_TCB_Configure sel4_tcb sel4_fault_ep
|
|
sel4_cspace_root sel4_cspace_root_data
|
|
sel4_vspace_root sel4_vspace_root_data
|
|
ipcbuf_addr sel4_ipcbuffer;
|
|
assert (\<not>fail)
|
|
od"
|
|
|
|
(* Set the registers of a single tcb (cspace, vspace and fault_ep). *)
|
|
definition configure_tcb :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_object_id \<Rightarrow> unit u_monad"
|
|
where
|
|
"configure_tcb spec orig_caps tcb_id \<equiv> do
|
|
cdl_tcb \<leftarrow> assert_opt $ opt_thread tcb_id spec;
|
|
sel4_tcb \<leftarrow> assert_opt $ orig_caps tcb_id;
|
|
ip \<leftarrow> return $ tcb_ip cdl_tcb;
|
|
sp \<leftarrow> return $ tcb_sp cdl_tcb;
|
|
regs \<leftarrow> return [ip, sp];
|
|
fail \<leftarrow> seL4_TCB_WriteRegisters sel4_tcb False 0 2 regs;
|
|
assert fail
|
|
od"
|
|
|
|
(* Initialise all the tcbs (cspace, vspace and fault_ep). *)
|
|
definition init_tcbs :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_object_id list \<Rightarrow> unit u_monad"
|
|
where
|
|
"init_tcbs spec orig_caps objects \<equiv> do
|
|
tcb_ids \<leftarrow> return [obj \<leftarrow> objects. tcb_at obj spec];
|
|
mapM_x (init_tcb spec orig_caps) tcb_ids;
|
|
mapM_x (configure_tcb spec orig_caps) tcb_ids
|
|
od"
|
|
|
|
|
|
|
|
(**************************
|
|
* VSpace Initialisation. *
|
|
**************************)
|
|
|
|
(* Sets the asid for a page directory from the initialiser's asid pool. *)
|
|
definition set_asid :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_object_id
|
|
\<Rightarrow> unit u_monad"
|
|
where
|
|
"set_asid spec orig_caps page_id \<equiv> do
|
|
\<comment> \<open>Set asid pool for the page directory.\<close>
|
|
sel4_asid_pool \<leftarrow> return seL4_CapInitThreadASIDPool;
|
|
sel4_page \<leftarrow> assert_opt $ orig_caps page_id;
|
|
fail \<leftarrow> seL4_ASIDPool_Assign sel4_asid_pool sel4_page;
|
|
assert (\<not>fail)
|
|
od"
|
|
|
|
(* Set the ASIDs for the page directories. *)
|
|
definition init_pd_asids :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_object_id list \<Rightarrow> unit u_monad"
|
|
where
|
|
"init_pd_asids spec orig_caps obj_ids \<equiv> do
|
|
pd_ids \<leftarrow> return [obj_id \<leftarrow> obj_ids. pd_at obj_id spec];
|
|
mapM_x (set_asid spec orig_caps) pd_ids
|
|
od"
|
|
|
|
(* Map a page into a page table or page directory *)
|
|
definition map_page ::
|
|
"cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_object_id
|
|
\<Rightarrow> cdl_object_id \<Rightarrow> cdl_right set \<Rightarrow> word32 \<Rightarrow> cdl_cptr \<Rightarrow> unit u_monad"
|
|
where
|
|
"map_page spec orig_caps page_id pd_id rights vaddr free_cptr \<equiv> do
|
|
cdl_page \<leftarrow> assert_opt $ cdl_objects spec page_id;
|
|
sel4_page \<leftarrow> assert_opt $ orig_caps page_id;
|
|
sel4_pd \<leftarrow> assert_opt $ orig_caps pd_id;
|
|
vmattribs \<leftarrow> assert_opt $ opt_vmattribs cdl_page;
|
|
assert (frame_at page_id spec);
|
|
\<comment> \<open>Copy the frame cap into a new slot for mapping, this enables shared frames\<close>
|
|
duplicate_cap spec orig_caps (page_id, free_cptr);
|
|
seL4_Page_Map free_cptr sel4_pd vaddr rights vmattribs;
|
|
return ()
|
|
od"
|
|
|
|
(* Map a page table into a page directory *)
|
|
definition map_page_table ::
|
|
"cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_object_id
|
|
\<Rightarrow> cdl_object_id \<Rightarrow> cdl_right set \<Rightarrow> word32 \<Rightarrow> unit u_monad"
|
|
where
|
|
"map_page_table spec orig_caps page_id pd_id rights vaddr \<equiv> do
|
|
cdl_page \<leftarrow> assert_opt $ cdl_objects spec page_id;
|
|
sel4_page \<leftarrow> assert_opt $ orig_caps page_id;
|
|
sel4_pd \<leftarrow> assert_opt $ orig_caps pd_id;
|
|
vmattribs \<leftarrow> assert_opt $ opt_vmattribs cdl_page;
|
|
assert (pt_at page_id spec);
|
|
seL4_PageTable_Map sel4_page sel4_pd vaddr vmattribs;
|
|
return ()
|
|
od"
|
|
|
|
(* Map a page table slot *)
|
|
definition map_page_table_slot ::
|
|
"cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_object_id
|
|
\<Rightarrow> cdl_object_id \<Rightarrow> word32 \<Rightarrow> (cdl_cap_ref \<Rightarrow> cdl_cptr) \<Rightarrow> cdl_cnode_index \<Rightarrow> unit u_monad"
|
|
where
|
|
"map_page_table_slot spec orig_caps pd_id pt_id pt_vaddr free_cptr pt_slot \<equiv> do
|
|
frame_cap \<leftarrow> assert_opt $ opt_cap (pt_id, pt_slot) spec;
|
|
page \<leftarrow> return $ cap_object frame_cap;
|
|
|
|
\<comment> \<open>The page's virtual address is the page table's virtual address,
|
|
plus the relative address of the page in the page table.
|
|
Each page stores 12 bits of memory.\<close>
|
|
page_vaddr \<leftarrow> return $ pt_vaddr + (of_nat pt_slot << small_frame_size);
|
|
page_rights \<leftarrow> return (cap_rights frame_cap);
|
|
if frame_cap \<noteq> NullCap then
|
|
do cptr \<leftarrow> return $ free_cptr (pt_id, pt_slot);
|
|
map_page spec orig_caps page pd_id page_rights page_vaddr cptr
|
|
od
|
|
else
|
|
return ()
|
|
od"
|
|
|
|
(* Map a page directory slot (and all its contents if it points to a page table) *)
|
|
definition map_page_directory_slot ::
|
|
"cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option)
|
|
\<Rightarrow> cdl_object_id \<Rightarrow> (cdl_cap_ref \<Rightarrow> cdl_cptr) \<Rightarrow> cdl_cnode_index \<Rightarrow> unit u_monad"
|
|
where
|
|
"map_page_directory_slot spec orig_caps pd_id free_cptrs pd_slot \<equiv> do
|
|
page_cap \<leftarrow> assert_opt $ opt_cap (pd_id, pd_slot) spec;
|
|
page_id \<leftarrow> return $ cap_object page_cap;
|
|
|
|
\<comment> \<open>The page table's virtual address is given by the number of slots and how much memory each maps.
|
|
Each page directory slot maps 10+12 bits of memory (by the page table and page respectively).\<close>
|
|
page_vaddr \<leftarrow> return $ of_nat pd_slot << (pt_size + small_frame_size);
|
|
page_rights \<leftarrow> return (cap_rights page_cap);
|
|
|
|
if pt_at page_id spec then
|
|
do
|
|
map_page_table spec orig_caps page_id pd_id page_rights page_vaddr;
|
|
page_slots \<leftarrow> return $ slots_of_list spec page_id;
|
|
mapM_x (map_page_table_slot spec orig_caps pd_id page_id page_vaddr free_cptrs)
|
|
[slot <- page_slots. cap_at ((\<noteq>) NullCap) (page_id, slot) spec]
|
|
od
|
|
else if frame_at page_id spec then
|
|
do
|
|
cptr \<leftarrow> return $ free_cptrs (pd_id, pd_slot);
|
|
map_page spec orig_caps page_id pd_id page_rights page_vaddr cptr
|
|
od
|
|
else
|
|
return ()
|
|
od"
|
|
|
|
(* Map a page directory and all its contents *)
|
|
definition map_page_directory ::
|
|
"cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option)
|
|
\<Rightarrow> (cdl_cap_ref \<Rightarrow> cdl_cptr) \<Rightarrow> cdl_object_id \<Rightarrow> unit u_monad"
|
|
where
|
|
"map_page_directory spec orig_caps free_cptrs pd_id \<equiv> do
|
|
pd_slots \<leftarrow> return $ slots_of_list spec pd_id;
|
|
mapM_x (map_page_directory_slot spec orig_caps pd_id free_cptrs)
|
|
[pd_slot <- pd_slots. cap_at (\<lambda>cap. cap \<noteq> NullCap
|
|
\<and> frame_at (cap_object cap) spec) (pd_id, pd_slot) spec];
|
|
mapM_x (map_page_directory_slot spec orig_caps pd_id free_cptrs)
|
|
[pd_slot <- pd_slots. cap_at (\<lambda>cap. cap \<noteq> NullCap
|
|
\<and> pt_at (cap_object cap) spec) (pd_id, pd_slot) spec]
|
|
od"
|
|
|
|
(* Get a list of all the (object_id, slot) pairs contained within a page directory
|
|
and its child page tables which contain frame caps *)
|
|
definition get_frame_caps :: "cdl_state \<Rightarrow> cdl_object_id \<Rightarrow> (cdl_object_id \<times> nat) list" where
|
|
"get_frame_caps spec pd_id \<equiv> do {
|
|
pd_slot <- slots_of_list spec pd_id;
|
|
obj_cap <- case_option [] (\<lambda>x. [x]) $ opt_cap (pd_id, pd_slot) spec;
|
|
let obj_id = cap_object obj_cap;
|
|
if frame_at obj_id spec then
|
|
[(pd_id, pd_slot)]
|
|
else
|
|
\<comment> \<open>If the slot contains a page table cap, collect all its slots that contain frames\<close>
|
|
map (Pair obj_id) o filter (\<lambda>slot. cap_at ((\<noteq>) NullCap) (obj_id, slot) spec) $
|
|
slots_of_list spec obj_id
|
|
}"
|
|
|
|
(* Construct a function to assign each frame cap a free cptr, mapping all other slots to 0 *)
|
|
definition make_frame_cap_map ::
|
|
"cdl_object_id list \<Rightarrow> word32 list \<Rightarrow> cdl_state \<Rightarrow> cdl_object_id \<times> nat \<Rightarrow> word32"
|
|
where
|
|
"make_frame_cap_map obj_ids free_cptrs spec ref \<equiv>
|
|
case_option 0 id
|
|
(map_of (zip ([obj_id \<leftarrow> obj_ids. pd_at obj_id spec] \<bind> get_frame_caps spec) free_cptrs) ref)"
|
|
|
|
(* Maps page directories and all their contents. *)
|
|
definition init_vspace ::
|
|
"cdl_state \<Rightarrow>
|
|
(cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow>
|
|
cdl_object_id list \<Rightarrow>
|
|
cdl_cptr list \<Rightarrow>
|
|
unit u_monad"
|
|
where
|
|
"init_vspace spec orig_caps obj_ids free_cptrs \<equiv> do
|
|
pd_ids \<leftarrow> return [obj_id \<leftarrow> obj_ids. pd_at obj_id spec];
|
|
cptr_map \<leftarrow> return $ make_frame_cap_map obj_ids free_cptrs spec;
|
|
mapM_x (map_page_directory spec orig_caps cptr_map) pd_ids
|
|
od"
|
|
|
|
(**************************
|
|
* CSpace Initialisation. *
|
|
**************************)
|
|
|
|
datatype init_cnode_mode = Move | Copy
|
|
|
|
(* initialises a CNode slot with the desired cap, either moving them or copying it. *)
|
|
definition init_cnode_slot :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option)
|
|
\<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option)
|
|
\<Rightarrow> (cdl_irq \<Rightarrow> cdl_cptr option)
|
|
\<Rightarrow> init_cnode_mode \<Rightarrow> cdl_object_id
|
|
\<Rightarrow> cdl_cnode_index \<Rightarrow> bool u_monad"
|
|
where
|
|
"init_cnode_slot spec orig_caps dup_caps irq_caps mode cnode_id cnode_slot \<equiv> do
|
|
target_cap \<leftarrow> assert_opt (opt_cap (cnode_id, cnode_slot) spec);
|
|
target_cap_obj \<leftarrow> return (cap_object target_cap);
|
|
target_cap_irq \<leftarrow> return (cap_irq target_cap);
|
|
|
|
target_cap_rights \<leftarrow> return (cap_rights target_cap);
|
|
|
|
\<comment> \<open>for endpoint this is the badge, for cnodes, this is the (encoded) guard\<close>
|
|
target_cap_data \<leftarrow> return (cap_data target_cap);
|
|
|
|
is_ep_cap \<leftarrow> return (ep_related_cap target_cap);
|
|
is_irqhandler_cap \<leftarrow> return (is_irqhandler_cap target_cap);
|
|
|
|
\<comment> \<open>ny original caps (which includes IRQ Hander caps) are moved, not copied.\<close>
|
|
move_cap \<leftarrow> return (original_cap_at (cnode_id, cnode_slot) spec);
|
|
|
|
dest_obj \<leftarrow> get_spec_object spec cnode_id;
|
|
dest_size \<leftarrow> return (object_size_bits dest_obj);
|
|
|
|
\<comment> \<open>Use a copy of the cap to reference the destination,
|
|
in case the original has already been moved.\<close>
|
|
dest_root \<leftarrow> assert_opt (dup_caps cnode_id);
|
|
dest_index \<leftarrow> return (of_nat cnode_slot);
|
|
dest_depth \<leftarrow> return (of_nat dest_size);
|
|
|
|
\<comment> \<open>Use an original cap to reference the object to copy.\<close>
|
|
src_root \<leftarrow> return seL4_CapInitThreadCNode;
|
|
src_index \<leftarrow> assert_opt (if is_irqhandler_cap
|
|
then irq_caps target_cap_irq
|
|
else orig_caps target_cap_obj);
|
|
src_depth \<leftarrow> return (32::word32);
|
|
|
|
\<comment> \<open>If it's a NullCap, then there's no need to do anything.
|
|
d If it's a cap that wants to be moved, and we want to move the cap, move (mutate) it.
|
|
If it's a cap that wants to be copied, and we want to copy it, then copy (mint) it.
|
|
\<close>
|
|
if (target_cap = NullCap) then
|
|
return True
|
|
else if (mode = Move \<and> move_cap) then (
|
|
if (is_ep_cap \<or> is_irqhandler_cap) then
|
|
(seL4_CNode_Move dest_root dest_index dest_depth src_root src_index src_depth)
|
|
else
|
|
(seL4_CNode_Mutate dest_root dest_index dest_depth src_root src_index src_depth target_cap_data)
|
|
)
|
|
else if (mode = Copy \<and> \<not> move_cap) then
|
|
seL4_CNode_Mint dest_root dest_index dest_depth src_root src_index src_depth target_cap_rights target_cap_data
|
|
else
|
|
return True
|
|
od"
|
|
|
|
(* Initialises a CNode with it's desired caps, either moving them or copying them. *)
|
|
definition init_cnode :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option)
|
|
\<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option)
|
|
\<Rightarrow> (cdl_irq \<Rightarrow> cdl_cptr option)
|
|
\<Rightarrow> init_cnode_mode \<Rightarrow> cdl_object_id \<Rightarrow> unit u_monad"
|
|
where
|
|
"init_cnode spec orig_caps dup_caps irq_caps mode cnode_id \<equiv> do
|
|
cnode_slots \<leftarrow> return $ slots_of_list spec cnode_id;
|
|
mapM_x (init_cnode_slot spec orig_caps dup_caps irq_caps mode cnode_id) cnode_slots
|
|
od"
|
|
|
|
(* Initialises CNodes with their desired caps in two passes.
|
|
First pass copies caps, the second moves them. *)
|
|
definition init_cspace :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option)
|
|
\<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option)
|
|
\<Rightarrow> (cdl_irq \<Rightarrow> cdl_cptr option)
|
|
\<Rightarrow> cdl_object_id list \<Rightarrow> unit u_monad"
|
|
where
|
|
"init_cspace spec orig_caps dup_caps irq_caps obj_ids \<equiv> do
|
|
cnode_ids \<leftarrow> return [obj_id \<leftarrow> obj_ids. cnode_at obj_id spec];
|
|
mapM_x (init_cnode spec orig_caps dup_caps irq_caps Copy) cnode_ids;
|
|
mapM_x (init_cnode spec orig_caps dup_caps irq_caps Move) cnode_ids
|
|
od"
|
|
|
|
(* Initialise a single tcb (cspace, vspace and fault_ep). *)
|
|
definition start_thread :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_object_id \<Rightarrow> unit u_monad"
|
|
where
|
|
"start_thread spec dup_caps tcb_id \<equiv> do
|
|
sel4_tcb \<leftarrow> assert_opt $ dup_caps tcb_id;
|
|
fail \<leftarrow> seL4_TCB_Resume sel4_tcb;
|
|
assert fail
|
|
od"
|
|
|
|
definition start_threads :: "cdl_state \<Rightarrow> (cdl_object_id \<Rightarrow> cdl_cptr option) \<Rightarrow> cdl_object_id list
|
|
\<Rightarrow> unit u_monad"
|
|
where
|
|
"start_threads spec orig_caps obj_ids \<equiv> do
|
|
tcbs \<leftarrow> return [obj_id \<leftarrow> obj_ids. is_waiting_thread_at obj_id spec];
|
|
mapM_x (start_thread spec orig_caps) tcbs
|
|
od"
|
|
|
|
definition init_system :: "cdl_state \<Rightarrow> cdl_bootinfo \<Rightarrow> cdl_object_id list \<Rightarrow> unit u_monad"
|
|
where
|
|
"init_system spec bootinfo obj_ids \<equiv> do
|
|
(untyped_cptrs, free_cptrs) \<leftarrow> parse_bootinfo bootinfo;
|
|
|
|
(orig_caps, free_cptrs) \<leftarrow> create_objects spec obj_ids untyped_cptrs free_cptrs;
|
|
(irq_caps, free_cptrs) \<leftarrow> create_irq_caps spec free_cptrs;
|
|
dup_caps \<leftarrow> duplicate_caps spec orig_caps obj_ids free_cptrs;
|
|
|
|
init_irqs spec orig_caps irq_caps;
|
|
init_pd_asids spec orig_caps obj_ids;
|
|
init_vspace spec orig_caps obj_ids free_cptrs;
|
|
init_tcbs spec orig_caps obj_ids;
|
|
init_cspace spec orig_caps dup_caps irq_caps obj_ids;
|
|
start_threads spec dup_caps obj_ids
|
|
od"
|
|
|
|
end
|