adbrucker
/
lh-l4v
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
lh-l4v/proof/drefine/Untyped_DR.thy

1953 lines
89 KiB
Plaintext
Raw Blame History

(*
* Copyright 2014, NICTA
*
* This software may be distributed and modified according to the terms of
* the GNU General Public License version 2. Note that NO WARRANTY is provided.
* See "LICENSE_GPLv2.txt" for details.
*
* @TAG(NICTA_GPL)
*)
theory Untyped_DR
imports CNode_DR
begin
lemma detype_dcorres:
"S = {ptr..ptr + 2 ^ sz - 1}
\<Longrightarrow> dcorres dc \<top> (\<lambda>s. invs s \<and> (\<exists>cref. cte_wp_at (op = (cap.UntypedCap ptr sz idx)) cref s) \<and> valid_etcbs s)
(modify (Untyped_D.detype S))
(modify (Retype_A.detype S))"
apply (rule corres_modify)
apply (clarsimp simp: transform_def Untyped_D.detype_def
transform_cdt_def
split del: split_if
simp del: untyped_range.simps)
apply (simp add: Untyped_D.detype_def transform_def
transform_current_thread_def Retype_A.detype_def transform_asid_table_def detype_ext_def)
apply (rule ext)
apply (clarsimp simp: map_option_case restrict_map_def transform_objects_def
map_add_def cte_wp_at_caps_of_state
split: option.split)
apply (drule valid_global_refsD2)
apply clarsimp
apply (clarsimp simp: global_refs_def transform_object_def detype_ext_def)
done
(* FIXME: move *)
lemma evalMonad_loadWords:
"evalMonad (mapM loadWord xs) ms =
(if (\<forall>x\<in>set xs. is_aligned x 2) then
Some (map (\<lambda>x. word_rcat [underlying_memory ms (x + 3),
underlying_memory ms (x + 2),
underlying_memory ms (x + 1),
underlying_memory ms x]) xs)
else None)"
proof (induct xs)
case Nil thus ?case
by (simp add: evalMonad_def mapM_simps return_def)
next
note mapM_simps[simp]
(* FIXME: could be generalized. *)
have evalMonad_bind_return:
"\<And>f g s. \<forall>x\<in>fst (f s). snd x = s \<Longrightarrow> \<exists>r. \<forall>x\<in>fst (f s). fst x = r \<Longrightarrow>
\<exists>r. \<forall>x\<in>fst (g s). fst x = r \<Longrightarrow>
evalMonad (do r \<leftarrow> f; rs \<leftarrow> g; return (r#rs) od) s =
(case evalMonad f s of None \<Rightarrow> None
| Some r \<Rightarrow> (case evalMonad g s of None \<Rightarrow> None
| Some rs \<Rightarrow> Some (r#rs)))"
apply (simp add: evalMonad_def bind_def split_def return_def)
apply safe
apply auto[2]
apply (rule sym)
apply (rule someI2_ex, fastforce)
apply (clarsimp split: split_if_asm)
apply (rule conjI)
apply (rule someI2_ex, fastforce+)+
done
have loadWord_const:
"\<And>a s. \<forall>x\<in>fst (loadWord a s). snd x = s"
apply (case_tac "is_aligned a 2")
apply (simp add: loadWord_def is_aligned_mask exec_gets)
apply (simp add: return_def)
apply (simp add: loadWord_def exec_gets fail_def is_aligned_mask)
done
have loadWord_atMostOneResult:
"\<And>a s. \<exists>r. \<forall>x\<in>fst (loadWord a s). fst x = r"
apply (case_tac "is_aligned a 2")
apply (simp add: loadWord_def is_aligned_mask exec_gets)
apply (simp add: return_def)
apply (simp add: loadWord_def exec_gets fail_def is_aligned_mask)
done
have mapM_loadWord_atMostOneResult[rule_format]:
"\<And>as s. \<exists>rs. \<forall>x\<in>fst (mapM loadWord as s). fst x = rs"
apply (induct_tac as)
apply (simp add: return_def)
using loadWord_const loadWord_atMostOneResult
by (fastforce simp: bind_def split_def return_def)
case Cons thus ?case
by (simp add: evalMonad_bind_return[OF loadWord_const
loadWord_atMostOneResult mapM_loadWord_atMostOneResult]
evalMonad_loadWord is_aligned_mask
split: option.splits)
qed
(* FIXME: change definition! *)
lemma get_ipc_buffer_words_def2:
"get_ipc_buffer_words ms tcb ns \<equiv>
(case tcb_ipcframe tcb of
cap.ArchObjectCap (arch_cap.PageCap buf rights sz mapdata) \<Rightarrow>
if AllowRead \<in> rights then
(if ns = Nil \<or> is_aligned (buf + tcb_ipc_buffer tcb) 2 then
map ((\<lambda>x. word_rcat [underlying_memory ms (x + 3),
underlying_memory ms (x + 2),
underlying_memory ms (x + 1),
underlying_memory ms x]) \<circ>
(\<lambda>n. buf + (tcb_ipc_buffer tcb && mask (pageBitsForSize sz)) +
of_nat n * of_nat word_size))
ns
else the None)
else []
| _ \<Rightarrow> [])"
proof -
(* FIXME: extract *)
have mask_eq:
"\<And>p q m n. m\<ge>n \<Longrightarrow> p + (q && mask m) && mask n = p + q && mask n"
by (subst mask_eqs(2)[of p "q && mask m" for p q m, symmetric])
(simp add: mask_twice min_def mask_eqs)
have eq: "\<And>x p b sz. is_aligned (p + (b && mask (pageBitsForSize sz)) +
of_nat x * of_nat word_size) 2
\<longleftrightarrow> is_aligned (p + b) 2"
apply (rule iffI)
apply (drule is_aligned_addD2)
apply (simp add: word_size_def is_aligned_mult_triv2[where n=2,
simplified word_bits_def, simplified])
apply (simp add: is_aligned_mask mask_eq)
apply (rule is_aligned_add)
apply (simp add: is_aligned_mask mask_eq)
apply (simp add: word_size_def is_aligned_mult_triv2[where n=2,
simplified word_bits_def, simplified])
done
show "PROP ?thesis"
apply (rule eq_reflection)
apply (auto simp: get_ipc_buffer_words_def evalMonad_loadWords eq
split: cap.splits arch_cap.splits)
done
qed
lemma is_arch_page_cap_def2:
"is_arch_page_cap cap \<longleftrightarrow>
(\<exists>buf rights sz mapdata.
cap = cap.ArchObjectCap (arch_cap.PageCap buf rights sz mapdata))"
by (simp add: is_arch_page_cap_def split: cap.splits arch_cap.splits)
lemma transform_full_intent_machine_state_eq:
assumes 3: "tcb_ipcframe tcb =
cap.ArchObjectCap (arch_cap.PageCap buf rights sz opt)"
assumes 4: "is_aligned buf (pageBitsForSize sz)"
assumes 1: "is_aligned (tcb_ipc_buffer tcb) msg_align_bits"
assumes 5: "(\<forall>p. buf = (p && ~~ mask (pageBitsForSize sz)) \<longrightarrow>
underlying_memory ms' p = underlying_memory ms p)"
shows "transform_full_intent ms tref tcb = transform_full_intent ms' tref tcb"
proof -
have 2: "valid_message_info (get_tcb_message_info tcb)"
by (simp add: get_tcb_message_info_def data_to_message_info_valid)
let ?p = "%x. buf + (tcb_ipc_buffer tcb && mask (pageBitsForSize sz)) +
of_nat x * of_nat word_size"
have word_rcat_eq:
"\<And>x. x<128 \<Longrightarrow>
word_rcat [underlying_memory ms (?p x + 3),
underlying_memory ms (?p x + 2),
underlying_memory ms (?p x + 1),
underlying_memory ms (?p x)] =
word_rcat [underlying_memory ms'(?p x + 3),
underlying_memory ms'(?p x + 2),
underlying_memory ms'(?p x + 1),
underlying_memory ms'(?p x)]"
proof -
fix x :: nat
assume x: "x<128"
have y: "!!y. y<4 \<Longrightarrow> ?p x + y && ~~ mask (pageBitsForSize sz) = buf"
apply (simp add: add.assoc)
apply (rule is_aligned_add_helper[OF 4, THEN conjunct2])
apply (rule_tac n=msg_align_bits in is_aligned_add_less_t2n)
apply (rule is_aligned_andI1[OF 1])
apply (rule_tac n=2 in is_aligned_add_less_t2n)
apply (simp add: word_size_def)
apply (rule is_aligned_mult_triv2[where n=2, simplified])
apply simp
apply (simp add: msg_align_bits_def)
apply (simp add: word_size_def)
apply (rule word_less_power_trans_ofnat[where k=2, simplified],
simp_all add: x msg_align_bits word_bits_def)[1]
apply (case_tac sz, simp_all add: msg_align_bits)[1]
apply (rule and_mask_less_size)
apply (case_tac sz, simp_all add: word_size)[1]
done
note 6 = 5[rule_format, OF y[symmetric]]
show "?thesis x"
apply (rule arg_cong[where f=word_rcat])
using 6[of 3] 6[of 2] 6[of 1] 6[of 0]
by simp
qed
show ?thesis
apply (clarsimp simp: transform_full_intent_def Let_def get_tcb_mrs_def
get_ipc_buffer_words_def2 3
Suc_leI[OF msg_registers_lt_msg_max_length]
simp del: upt_Suc
split del: split_if)
apply (case_tac "AllowRead \<in> rights",
simp_all del: upt_Suc split del: split_if)
apply (cut_tac y=2 in is_aligned_weaken[OF 1])
apply (simp add: msg_align_bits_def)
apply (cut_tac y=2 in is_aligned_weaken[OF 4])
apply (case_tac sz, simp_all)[1]
apply (frule (1) is_aligned_add[of buf 2 "tcb_ipc_buffer tcb"])
apply (simp add: o_def del: upt_Suc)
apply (intro conjI)
apply (rule arg_cong2[where f=transform_intent, OF refl])
apply (rule arg_cong2[where f="op@", OF refl])
apply (rule arg_cong2[where f=take, OF refl])
apply (rule map_cong[OF refl])
apply (rule word_rcat_eq)
apply (clarsimp simp: atLeastAtMost_upt[symmetric] msg_max_length_def
simp del: upt_Suc)
apply clarsimp
apply (rule word_rcat_eq)
using 2
apply (clarsimp simp: buffer_cptr_index_def msg_max_length_def
valid_message_info_def msg_max_extra_caps_def word_le_nat_alt)
apply (rule arg_cong2[where f="case_list None", OF refl])
apply (rule map_cong[OF refl])
apply (rule word_rcat_eq)
apply (clarsimp simp: atLeastAtMost_upt[symmetric] simp del: upt_Suc)
apply (simp add: msg_max_length_def msg_max_extra_caps_def)
done
qed
lemma valid_page_cap_imp_valid_buf:
"s \<turnstile> cap.ArchObjectCap (arch_cap.PageCap buf rights sz mapdata) \<Longrightarrow>
is_aligned buf (pageBitsForSize sz) \<and> typ_at (AArch (AIntData sz)) buf s"
by (clarsimp simp add: valid_cap_simps cap_aligned_def)
lemma freeMemory_dcorres:
"is_aligned ptr bits \<Longrightarrow> 2 \<le> bits \<Longrightarrow> bits < word_bits \<Longrightarrow>
dcorres dc (\<lambda>_. True)
(pspace_no_overlap ptr bits and valid_objs and valid_etcbs)
(return rv) (do_machine_op (freeMemory ptr bits))"
apply (clarsimp simp add: corres_underlying_def split_def return_def)
apply (rename_tac s t)
apply (drule_tac P="op= s" and
Q="%_ u. (\<exists>ms. u=s\<lparr>machine_state := ms\<rparr>) \<and>
(\<forall>p\<in>UNIV-{ptr..ptr + 2 ^ bits - 1}.
underlying_memory (machine_state s) p =
underlying_memory (machine_state u) p)"
in use_valid)
apply (simp add: do_machine_op_def split_def)
apply wp
apply (clarsimp simp: freeMemory_def word_size_def
mapM_x_storeWord_step intvl_range_conv')
apply (rule conjI, fastforce)
apply clarsimp
apply (erule use_valid[where P=P and Q="%_. P" for P])
apply wp
apply (clarsimp simp: is_aligned_no_wrap' of_nat_less_pow word_bits_def
x_power_minus_1 word_plus_mono_right)
apply (rule refl)
apply (rule refl)
apply (clarsimp simp: transform_def transform_current_thread_def)
apply (rule ext)
apply (clarsimp simp: transform_objects_def map_add_def)
apply (clarsimp simp: option_map_def split: option.splits)
apply (clarsimp simp: transform_object_def transform_tcb_def
split: Structures_A.kernel_object.split option.splits)
apply (rename_tac s ms tref etcb tcb)
apply (clarsimp simp: restrict_map_def split: split_if_asm)
apply (frule(1) valid_etcbs_tcb_etcb)
apply (case_tac "\<not> is_arch_page_cap (tcb_ipcframe tcb)")
apply (erule transform_full_intent_no_ipc_buffer)
apply (clarsimp simp: is_arch_page_cap_def2)
apply (simp add: valid_objs_def)
apply (drule_tac x=tref in bspec, clarsimp+)
apply (clarsimp simp: valid_obj_def valid_tcb_def)
(* FIXME: extract a sensible lemma for that *)
apply (drule_tac x="(tcb_ipcframe, tcb_ipcframe_update,
\<lambda>_ _. is_arch_cap or op = cap.NullCap)" in bspec)
apply (simp add: ran_tcb_cap_cases)
apply clarsimp
apply (thin_tac "case_option x y z" for x y z)
apply (simp add: valid_ipc_buffer_cap_def)
apply (drule valid_page_cap_imp_valid_buf)
apply (frule_tac transform_full_intent_machine_state_eq, simp_all)
apply clarsimp
apply (erule_tac x=p in bspec)
apply (frule is_aligned_no_overflow')
apply (clarsimp simp: pspace_no_overlap_def typ_at_pg obj_at_def
mask_2pm1[symmetric])
apply (erule_tac x="(p && ~~ mask (pageBitsForSize sz))" in allE)
apply clarsimp
apply (thin_tac "length xs = y" for xs y)
apply (clarsimp simp:is_aligned_neg_mask_eq)
apply (erule impE)
apply (simp add:mask_def[unfolded shiftl_t2n,simplified,symmetric] p_assoc_help)
apply (erule order_trans[OF word_and_le2])
apply (erule impE)
apply (rule_tac y = p in order_trans)
apply simp
apply (cut_tac ptr = p and n = "pageBitsForSize sz" in word_neg_and_le)
apply (simp add:mask_def[unfolded shiftl_t2n,simplified,symmetric] p_assoc_help)
apply (thin_tac "x\<noteq>y" for x y)
apply (erule notE)
apply (rule is_aligned_no_wrap'[OF is_aligned_neg_mask])
apply (rule le_refl)
apply (simp add:mask_def not_le pbfs_less_wb'[unfolded word_bits_def, simplified])
done
(* Strictly speaking, we would not need ct_active, here. Proving that,
however, requires a stronger version of lemma detype_invariants. *)
lemma delete_objects_dcorres:
notes order_class.Icc_eq_Icc [simp del]
assumes S: "S = {ptr..ptr + 2 ^ bits - 1}"
shows "dcorres dc \<top>
(\<lambda>s. invs s \<and> ct_active s \<and> (\<exists>cref.
cte_wp_at (op= (cap.UntypedCap ptr bits idx)) cref s
\<and> descendants_range (cap.UntypedCap ptr bits idx) cref s) \<and> valid_etcbs s)
(modify (Untyped_D.detype S))
(delete_objects ptr bits)"
apply (clarsimp simp: S)
apply (unfold delete_objects_def2 K_bind_def)
apply (rule corres_bind_return)
apply (rule_tac F="is_aligned ptr bits \<and> 2 \<le> bits \<and> bits < word_bits"
in corres_req)
apply clarsimp
apply (drule cte_wp_valid_cap, clarsimp)
apply (simp add: valid_cap_def cap_aligned_def)
apply (rule corres_guard_imp)
apply (rule corres_split[OF _ detype_dcorres])
apply (rule freeMemory_dcorres, simp+)
apply wp
apply clarsimp
apply assumption
apply clarsimp
apply (rule conjI)
apply fastforce
apply (frule cte_wp_valid_cap, clarsimp)
apply (intro conjI)
apply (erule pspace_no_overlap_detype)
apply clarsimp+
apply (frule invs_untyped_children)
apply (drule_tac detype_invariants, simp_all)
apply (clarsimp simp:empty_descendants_range_in descendants_range_def2) +
apply (simp add: invs_def valid_state_def valid_pspace_def
detype_clear_um_independent valid_etcbs_def)
apply (simp add: invs_def valid_state_def valid_pspace_def detype_clear_um_independent valid_etcbs_def
is_etcb_at_def detype_def detype_ext_def st_tcb_at_kh_def obj_at_kh_def obj_at_def)
done
lemma unat_ptr_range_end:
"\<lbrakk> is_aligned (ptr :: 'a :: len word) sz; sz < len_of TYPE('a)\<rbrakk>
\<Longrightarrow> unat (ptr + 2 ^ sz - 1) = unat ptr + 2 ^ sz - 1"
apply (simp only: add_diff_eq[symmetric])
apply (subst unat_plus_simple[THEN iffD1])
apply (simp add: add_diff_eq)
apply (subst unat_minus_one)
apply simp_all
done
definition
translate_object_type :: "Structures_A.apiobject_type \<Rightarrow> cdl_object_type"
where
"translate_object_type type \<equiv> case type of
Structures_A.Untyped \<Rightarrow> UntypedType
| Structures_A.TCBObject \<Rightarrow> TcbType
| Structures_A.EndpointObject \<Rightarrow> EndpointType
| Structures_A.NotificationObject \<Rightarrow> NotificationType
| Structures_A.CapTableObject \<Rightarrow> CNodeType
| ArchObject SmallPageObj \<Rightarrow> FrameType 12
| ArchObject LargePageObj \<Rightarrow> FrameType 16
| ArchObject SectionObj \<Rightarrow> FrameType 20
| ArchObject SuperSectionObj \<Rightarrow> FrameType 24
| ArchObject PageTableObj \<Rightarrow> PageTableType
| ArchObject PageDirectoryObj \<Rightarrow> PageDirectoryType
| ArchObject ASIDPoolObj \<Rightarrow> AsidPoolType"
definition
translate_untyped_invocation :: "Invocations_A.untyped_invocation \<Rightarrow> cdl_untyped_invocation"
where
"translate_untyped_invocation x \<equiv>
case x of Invocations_A.Retype cref ptr_base ptr tp us slots
\<Rightarrow> cdl_untyped_invocation.Retype
(transform_cslot_ptr cref )
(translate_object_type tp)
us
(map transform_cslot_ptr slots)
(ptr_base \<noteq> ptr) (length slots) "
definition
"retype_transform_obj_ref type sz ptr
\<equiv> if type = Structures_A.Untyped then {ptr .. ptr + 2^sz - 1}
else {ptr}"
lemma transform_empty_cnode:
"transform_cnode_contents o_bits (empty_cnode o_bits) = empty_cap_map o_bits"
apply (simp add: transform_cnode_contents_def dom_empty_cnode)
apply (rule ext, simp add: option_map_join_def empty_cap_map_def
nat_to_bl_def len_bin_to_bl_aux)
done
lemma transform_default_tcb:
"transform_tcb ms x default_tcb (default_etcb\<lparr>tcb_domain := domain\<rparr>)
= Tcb (Types_D.default_tcb domain)"
apply (simp add: transform_tcb_def default_tcb_def Types_D.default_tcb_def)
apply (simp add: transform_full_intent_def Let_def new_context_def
cap_register_def ARMMachineTypes.capRegister_def
get_tcb_mrs_def
Suc_le_eq get_tcb_message_info_def msg_info_register_def
ARMMachineTypes.msgInfoRegister_def data_to_message_info_def
get_ipc_buffer_words_def)
apply (simp add: transform_intent_def invocation_type_def fromEnum_def
enum_invocation_label toEnum_def)
apply (simp add: fun_eq_iff tcb_slot_defs tcb_pending_op_slot_def tcb_boundntfn_slot_def)
apply (simp add: infer_tcb_pending_op_def infer_tcb_bound_notification_def guess_error_def default_etcb_def default_domain_def)
done
lemma transform_unat_map_empty:
"unat_map (\<lambda>_ :: ('a :: len) word. Some cdl_cap.NullCap)
= empty_cap_map (len_of TYPE('a))"
by (rule ext, simp add: unat_map_def empty_cap_map_def)
lemma transform_default_object:
"\<lbrakk>type \<noteq> Structures_A.Untyped; type = Structures_A.CapTableObject \<longrightarrow> 0 < o_bits\<rbrakk> \<Longrightarrow>
transform_object ms word (default_ext type domain) (Retype_A.default_object type o_bits)
= the (Types_D.default_object (translate_object_type type) o_bits domain)"
by (cases type, simp_all add: translate_object_type_def default_object_def
Types_D.default_object_def transform_default_tcb default_ext_def
transform_unat_map_empty transform_empty_cnode
Types_D.empty_cnode_def dom_empty_cnode
transform_object_def default_arch_object_def
transform_page_table_contents_def o_def transform_pte_def
transform_page_directory_contents_def transform_pde_def kernel_pde_mask_def
transform_asid_pool_contents_def transform_asid_pool_entry_def asid_low_bits_def
split: aobject_type.split nat.splits)
lemma obj_bits_bound32:
"\<lbrakk>type = Invariants_AI.Untyped \<longrightarrow> us < 32;
type = Invariants_AI.CapTableObject \<longrightarrow> us < 28\<rbrakk>
\<Longrightarrow>obj_bits_api type us < WordSetup.word_bits"
apply (case_tac type)
apply (simp_all add:obj_bits_api_def word_bits_def slot_bits_def)
apply (rename_tac aobject_type)
apply (case_tac aobject_type)
apply (simp_all add:arch_kobj_size_def default_arch_object_def pageBits_def)
done
lemma obj_bits_bound4:
"\<lbrakk>type = Invariants_AI.Untyped \<longrightarrow> 4 \<le> us\<rbrakk> \<Longrightarrow>
4 \<le> obj_bits_api type us"
apply (case_tac type)
apply (simp_all add:obj_bits_api_def word_bits_def slot_bits_def)
apply (rename_tac aobject_type)
apply (case_tac aobject_type)
apply (simp_all add:arch_kobj_size_def default_arch_object_def pageBits_def)
done
lemma distinct_retype_addrs:
"\<lbrakk>type = Invariants_AI.Untyped \<longrightarrow> 4 \<le> us;
range_cover ptr sz (obj_bits_api type us) n\<rbrakk>
\<Longrightarrow> distinct (retype_addrs ptr type n us)"
apply (clarsimp simp:retype_addrs_def distinct_map ptr_add_def inj_on_def)
apply (simp only: shiftl_t2n[symmetric,unfolded field_simps,simplified])
apply (drule shiftl_inj_if)
apply (rule shiftl_shiftr_id)
apply (simp add:range_cover_def)
apply (rule word_of_nat_less)
apply (subst unat_power_lower)
apply (rule diff_less)
apply (cut_tac obj_bits_bound4[where us = us and type = type])
apply simp
apply simp
apply (simp add:word_bits_def)
apply (erule Retype_AI.range_cover.range_cover_le_n_less(2))
apply simp
apply (rule shiftl_shiftr_id)
apply (simp add:range_cover_def)
apply (rule word_of_nat_less)
apply (subst unat_power_lower)
apply (rule diff_less)
apply (cut_tac obj_bits_bound4[where us = us and type = type])
apply simp
apply simp
apply (simp add:word_bits_def)
apply (erule Retype_AI.range_cover.range_cover_le_n_less(2))
apply simp
apply (rule of_nat_inj32[THEN iffD1])
apply (simp add:range_cover.range_cover_le_n_less[where 'a=32, folded word_bits_def])+
done
lemma length_retype_addrs[simp]:
"length (retype_addrs ptr type n us) = n"
by (simp add:retype_addrs_def)
lemma retype_transform_obj_ref_ut:
"(p \<in> (retype_transform_obj_ref Structures_A.Untyped sz ptr))
= (p \<in> {ptr .. ptr + 2^sz - 1})"
by (clarsimp simp:retype_transform_obj_ref_def)
lemma transform_none_to_untyped:
"\<lbrakk>valid_idle s'; kheap s' obj_id = None\<rbrakk>
\<Longrightarrow> cdl_objects (transform s') obj_id = Some Types_D.Untyped"
apply (clarsimp simp: transform_def restrict_map_def map_add_def transform_objects_def)
apply (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def)
done
lemma retype_transform_obj_ref_available:
"\<lbrakk>pspace_no_overlap ptr sz s'; s = transform s'; valid_pspace s'; valid_idle s';
range_cover ptr sz (obj_bits_api ty us) n;
y \<in> set (retype_addrs ptr ty n us)\<rbrakk>
\<Longrightarrow> retype_transform_obj_ref ty us y \<subseteq>
(cdl_objects s) -` {Some Types_D.Untyped}"
apply (clarsimp simp:retype_transform_obj_ref_def | rule conjI)+
apply (rule transform_none_to_untyped, simp)
apply (rule ccontr, clarsimp)
apply (drule(1) retype_addrs_range_subset[where p = y])
apply (drule_tac S = "{x}" in pspace_no_overlap_obj_range)
apply assumption
apply (erule subset_trans[rotated])
apply (clarsimp simp:obj_bits_api_def)
apply (drule p_in_obj_range)
apply clarsimp+
apply (drule(2) pspace_no_overlap_into_Int_none)
apply (clarsimp simp: transform_def restrict_map_def map_add_def transform_objects_def
split: if_splits option.splits)
apply (fastforce simp: valid_idle_def pred_tcb_at_def obj_at_def)
done
lemma retype_transform_obj_ref_pick_id:
"type \<noteq> Structures_A.Untyped
\<Longrightarrow> map (\<lambda>x. {pick x}) (map (retype_transform_obj_ref type us) xs)
= map (retype_transform_obj_ref type us) xs"
by (simp add:retype_transform_obj_ref_def)
lemma translate_object_type_not_untyped:
"type \<noteq> Invariants_AI.Untyped
\<Longrightarrow> Some (the (Types_D.default_object (translate_object_type type) us current_domain))
= Types_D.default_object (translate_object_type type) us current_domain"
by (clarsimp simp:translate_object_type_def Types_D.default_object_def
split:Structures_A.apiobject_type.splits aobject_type.splits)
lemma retype_transform_obj_ref_not_untyped:
"\<lbrakk>type \<noteq> Invariants_AI.Untyped\<rbrakk>
\<Longrightarrow>
{x} \<in> retype_transform_obj_ref type us ` set xs = (x \<in> set xs)"
apply (rule iffI)
apply (clarsimp simp:retype_transform_obj_ref_def)+
done
lemma retype_transform_obj_ref_in_untyped_range:
notes [simp del] = atLeastAtMost_iff atLeastatMost_subset_iff
shows "\<lbrakk>y \<in> set (retype_addrs ptr type n us);
range_cover ptr sz (obj_bits_api type us) n\<rbrakk>
\<Longrightarrow> retype_transform_obj_ref type us y \<subseteq>
{ptr &&~~ mask sz ..(ptr && ~~ mask sz) + (2 ^ sz - 1)}"
apply (frule retype_addrs_subset_ptr_bits)
apply (clarsimp simp:retype_transform_obj_ref_def)
apply (rule conjI)
apply (drule(1) set_mp)
apply clarsimp
apply (erule set_mp[rotated])
apply (frule(1) retype_addrs_range_subset)
apply (simp add:obj_bits_api_def)
apply (erule subset_trans)
apply (clarsimp simp: atLeastatMost_subset_iff field_simps)
apply (rule word_and_le2)
apply clarsimp
apply (erule set_mp[rotated])
apply (erule subset_trans)
apply (clarsimp simp: atLeastatMost_subset_iff field_simps)
apply (rule word_and_le2)
done
lemma retype_region_dcorres:
"dcorres (\<lambda>rv rv'. rv = map (retype_transform_obj_ref type us) rv'
\<and> rv' = retype_addrs ptr type n us)
\<top>
(\<lambda>s. pspace_no_overlap ptr sz s \<and> invs s
\<and> range_cover ptr sz (obj_bits_api type us) n
\<and> (type = Invariants_AI.Untyped \<longrightarrow> 4 \<le> us)
\<and> (type = Structures_A.CapTableObject \<longrightarrow> us \<noteq> 0))
(Untyped_D.retype_region
us (translate_object_type type) (map (retype_transform_obj_ref type us) (retype_addrs ptr type n us)))
(Retype_A.retype_region ptr n us type)"
apply (simp add: retype_region_def Untyped_D.retype_region_def
split del: split_if)
apply (clarsimp simp:when_def generate_object_ids_def bind_assoc
split del:split_if)
apply (simp add:retype_addrs_fold split del:split_if)
apply (case_tac "type = Invariants_AI.Untyped")
apply (rule corres_guard_imp)
apply (simp add:translate_object_type_def)
apply (intro conjI impI ballI | simp)+
apply (simp add:gets_fold_into_modify retype_addrs_fold retype_region_ext_def modify_modify
create_objects_def)
apply (rule dcorres_expand_pfx)
apply clarsimp
apply (rule corres_guard_imp)
apply (rule corres_split)
apply (rule corres_trivial)
apply simp
apply (rule_tac r = dc and Q = \<top> and Q' = "op = s'" in corres_guard_imp)
apply (clarsimp simp: transform_def bind_def simpler_modify_def corres_underlying_def
transform_current_thread_def transform_cdt_def transform_asid_table_def)
apply (rule ext)
apply (clarsimp simp:foldr_upd_app_if foldr_fun_upd_value restrict_map_def map_add_def
transform_objects_def retype_transform_obj_ref_def image_def)
apply (subgoal_tac "idle_thread s' \<notin> set (retype_addrs ptr type n us)")
apply (subgoal_tac "type = Structures_A.CapTableObject \<longrightarrow> us \<noteq> 0")
apply (clarsimp simp:transform_default_object translate_object_type_not_untyped)
defer
apply clarsimp
apply (frule invs_valid_idle,clarsimp simp:valid_idle_def pred_tcb_at_def obj_at_def)
apply (erule(3) pspace_no_overlapC)
apply clarsimp
apply simp
apply assumption
apply wp
apply fastforce
apply simp
apply (case_tac type, simp_all add:translate_object_type_def)
apply (rename_tac aobject_type)
apply (case_tac aobject_type,simp_all)
done
lemma page_objects_default_object:
"ty \<in> ArchObject ` {SmallPageObj, LargePageObj, SectionObj, SuperSectionObj}
\<Longrightarrow> \<exists>vmsz. (default_object ty us = ArchObj (DataPage vmsz) \<and> pageBitsForSize vmsz = obj_bits_api ty us)"
by (auto simp: default_object_def default_arch_object_def obj_bits_api_def pageBitsForSize_def)
lemma clearMemory_unused_corres_noop:
"\<lbrakk> ty \<in> ArchObject ` {SmallPageObj, LargePageObj, SectionObj, SuperSectionObj};
range_cover ptr sz (obj_bits_api ty us) n;
p \<in> set (retype_addrs ptr ty n us)\<rbrakk>
\<Longrightarrow> dcorres dc \<top>
(\<lambda>s. (\<forall>x \<in> set (retype_addrs ptr ty n us).
obj_at (\<lambda>ko. ko = Retype_A.default_object ty us) x s
\<and> (\<forall>cap\<in>ran (caps_of_state s). x \<notin> (obj_refs cap)))
\<and> valid_objs s \<and> pspace_aligned s \<and> pspace_distinct s \<and> valid_idle s \<and> valid_etcbs s)
(return ())
(do_machine_op (clearMemory p (2 ^ (obj_bits_api ty us))))"
(is "\<lbrakk> ?def; ?szv; ?in \<rbrakk> \<Longrightarrow> dcorres dc \<top> ?P ?f ?g")
apply (drule page_objects_default_object[where us=us], clarsimp)
apply (rename_tac pgsz)
apply (simp add: clearMemory_def do_machine_op_bind
cleanCacheRange_PoU_def ef_storeWord
mapM_x_mapM dom_mapM)
apply (subst do_machine_op_bind)
apply (clarsimp simp: ef_storeWord
mapM_x_mapM dom_mapM cleanCacheRange_PoU_def cleanByVA_PoU_def)+
apply (rule corres_guard_imp, rule corres_split_noop_rhs)
apply (rule dcorres_machine_op_noop, wp)
apply (rule corres_mapM_to_mapM_x)
apply (rule_tac P=\<top> and P'="?P"
and S="Id \<inter> ({p .. p + 2 ^ (obj_bits_api ty us) - 1} \<times> UNIV)"
in corres_mapM_x[where f="\<lambda>_. return ()", OF _ _ _ refl,
simplified mapM_x_return])
apply clarsimp
apply (rule stronger_corres_guard_imp,
rule_tac sz=pgsz in dcorres_store_word_safe)
apply (simp add: within_page_def)
apply simp
apply (clarsimp simp: obj_at_def)
apply (subgoal_tac "y && ~~ mask (obj_bits_api ty us) = p")
apply (clarsimp simp: ipc_frame_wp_at_def obj_at_def ran_null_filter
split: cap.split_asm arch_cap.split_asm)
apply (cut_tac t="(t, tcb_cnode_index 4)" and P="op = cap" for t cap
in cte_wp_at_tcbI, simp, fastforce, simp)
apply (clarsimp simp: cte_wp_at_caps_of_state)
apply (drule(1) bspec)
apply clarsimp
apply (drule(1) bspec[OF _ ranI])
apply simp
apply (drule(2) retype_addrs_aligned
[OF _ range_cover.aligned range_cover_sz'
[where 'a=32, folded word_bits_def] le_refl])
apply (simp add:mask_in_range)
apply wp
apply (simp | wp hoare_vcg_ball_lift)+
apply (simp add:zip_same)
apply (rule conjI)
apply clarsimp
apply (clarsimp simp: word_size_def)
apply (drule subsetD[OF upto_enum_step_subset])
apply simp
apply (wp | simp)+
done
lemma dcorres_create_word_objects:
"\<lbrakk> 0 < n; ty \<in> ArchObject ` {SmallPageObj, LargePageObj, SectionObj, SuperSectionObj};
xsz = obj_bits_api ty us \<rbrakk>
\<Longrightarrow> dcorres dc (\<lambda>_. True)
(\<lambda>s. (\<forall>x\<in>set (retype_addrs ptr ty n us).
obj_at (\<lambda>ko. ko = Retype_A.default_object ty us) x s \<and>
(\<forall>cap\<in> ran (caps_of_state s). x\<notin> (obj_refs cap))) \<and>
range_cover ptr sz (obj_bits_api ty us) n \<and>
valid_objs s \<and> pspace_aligned s \<and> pspace_distinct s \<and> valid_idle s \<and> valid_etcbs s)
(return ()) (create_word_objects ptr n xsz)"
apply (clarsimp simp:create_word_objects_def reserve_region_def mapM_x_mapM)
apply (subst do_machine_op_bind)
apply ((wp empty_fail_mapM empty_fail_bind
| simp add:clearMemory_def mapM_x_mapM ef_storeWord)+)[2]
apply (subst dom_mapM)
apply ((wp empty_fail_mapM empty_fail_bind
| simp add:clearMemory_def mapM_x_mapM ef_storeWord)+)[1]
apply (rule corres_dummy_return_pl)
apply (rule dcorres_expand_pfx)
apply (rule corres_guard_imp)
apply (rule corres_split[OF corres_trivial])
apply simp
apply (rule corres_mapM_to_mapM_x)
apply (rule_tac P=\<top> and P'="P" and S = "{(x,y). y \<in> set M}" for P M
in corres_mapM_x[where f="\<lambda>_. return ()", OF _ _ _ refl,
simplified mapM_x_return])
apply clarsimp
apply (rule clearMemory_unused_corres_noop)
apply simp
apply simp
apply simp
apply wp
apply (wp hoare_vcg_ball_lift | simp)+
apply (clarsimp simp:zip_same retype_addrs_def ptr_add_def image_def shiftl_t2n)
apply (rule_tac x = "unat x" in bexI)
apply simp
apply clarsimp
apply (rule unat_less_helper)
apply (subst le_m1_iff_lt[THEN iffD1,symmetric])
apply (drule range_cover_not_zero[rotated])
apply simp
apply (simp add:word_neq_0_conv)
apply simp
apply wp
apply simp
apply clarsimp
done
lemma init_arch_objects_corres_noop:
notes [simp del] = atLeastAtMost_iff atLeastatMost_subset_iff
shows
"\<lbrakk> \<forall>x \<in> set refs. is_aligned x (obj_bits_api ty obj_sz);
range_cover ptr sz (obj_bits_api ty obj_sz) n; 0 < n \<rbrakk>
\<Longrightarrow> dcorres dc \<top>
(\<lambda>s. (ty \<noteq> Structures_A.Untyped \<longrightarrow>
(\<forall>x\<in>set (retype_addrs ptr ty n obj_sz).
obj_at (\<lambda>ko. ko = Retype_A.default_object ty obj_sz) x s))
\<and> (\<forall>cap \<in> ran (null_filter (caps_of_state s)).
obj_refs cap \<inter> {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} = {})
\<and> valid_objs s \<and> pspace_aligned s \<and> pspace_distinct s \<and> valid_idle s \<and> valid_etcbs s)
(return ())
(init_arch_objects ty ptr n obj_sz refs)"
apply (simp add: init_arch_objects_def
split: Structures_A.apiobject_type.split aobject_type.split)
apply (simp add: dcorres_machine_op_noop[THEN corres_guard_imp]
cleanCacheRange_PoU_def machine_op_lift)
apply safe
apply (rule corres_guard_imp)
apply (erule corres_guard_imp[OF dcorres_create_word_objects
[where sz = sz and us = obj_sz and ty = "ArchObject SmallPageObj"]])
apply simp
apply (clarsimp simp:obj_bits_api_def arch_kobj_size_def default_arch_object_def)
apply simp
apply assumption
apply simp
apply (clarsimp simp:null_filter_def)
apply (drule(1) bspec)
apply (drule_tac x = cap in bspec)
apply (erule ranE)
apply (rule_tac a = xa in ranI)
apply clarsimp
apply (erule(1) in_empty_interE)
apply (clarsimp dest!:retype_addrs_subset_ptr_bits simp:field_simps,blast)
apply (rule corres_guard_imp)
apply (erule corres_guard_imp[OF dcorres_create_word_objects
[where sz = sz and us = obj_sz and ty = "ArchObject LargePageObj"]])
apply (clarsimp simp:obj_bits_api_def arch_kobj_size_def default_arch_object_def)+
apply assumption+
apply (clarsimp simp:null_filter_def)
apply (drule(1) bspec,drule_tac x = cap in bspec)
apply (erule ranE,rule_tac a = xa in ranI)
apply clarsimp
apply (erule(1) in_empty_interE)
apply (clarsimp dest!:retype_addrs_subset_ptr_bits simp:field_simps,blast)
apply (rule corres_guard_imp)
apply (erule corres_guard_imp[OF dcorres_create_word_objects
[where sz = sz and us = obj_sz and ty = "ArchObject SectionObj"]])
apply (clarsimp simp:obj_bits_api_def arch_kobj_size_def default_arch_object_def)+
apply assumption+
apply (clarsimp simp:null_filter_def)
apply (drule(1) bspec,drule_tac x = cap in bspec)
apply (erule ranE,rule_tac a = xa in ranI)
apply clarsimp
apply (erule(1) in_empty_interE)
apply (clarsimp dest!:retype_addrs_subset_ptr_bits simp:field_simps,blast)
apply (rule corres_guard_imp)
apply (erule corres_guard_imp[OF dcorres_create_word_objects
[where sz = sz and us = obj_sz and ty = "ArchObject SuperSectionObj"]])
apply (clarsimp simp:obj_bits_api_def arch_kobj_size_def default_arch_object_def)+
apply assumption+
apply (clarsimp simp:null_filter_def)
apply (drule(1) bspec,drule_tac x = cap in bspec)
apply (erule ranE,rule_tac a = xa in ranI)
apply clarsimp
apply (erule(1) in_empty_interE)
apply (clarsimp dest!:retype_addrs_subset_ptr_bits simp:field_simps,blast)
apply (rule corres_guard_imp[OF dcorres_machine_op_noop])
apply (wp mapM_x_wp' | simp)+
apply (simp add:mapM_x_mapM)
apply (rule corres_guard_imp)
apply (rule corres_split_noop_rhs)
apply (rule corres_noop[where P=\<top> and P'=valid_idle])
apply (simp add: clearMemory_def do_machine_op_bind
cleanCacheRange_PoU_def ef_storeWord
mapM_x_mapM dom_mapM)
apply (wp mapM_wp' dmo_dwp | simp)+
apply (rule corres_noop[where P=\<top> and P'=valid_idle])
apply simp
apply (rule hoare_strengthen_post, rule mapM_wp')
apply (subst eq_commute, wp copy_global_mappings_dwp)
apply (simp add: obj_bits_api_def arch_kobj_size_def
default_arch_object_def pd_bits_def pageBits_def)
apply (wp mapM_wp' dmo_dwp | simp)+
done
lemma monad_commute_set_cap_cdt:
"monad_commute \<top> (KHeap_D.set_cap ptr cap) (modify (\<lambda>s. s\<lparr>cdl_cdt := cdl_cdt s(ptr2 \<mapsto> ptr3)\<rparr>))"
apply (clarsimp simp:monad_commute_def)
apply (rule sym)
apply (subst bind_assoc[symmetric])
apply (subst oblivious_modify_swap)
apply (simp add: KHeap_D.set_cap_def split_def gets_the_def
KHeap_D.set_object_def)
apply (intro oblivious_bind oblivious_assert impI conjI allI
oblivious_select |
simp add: opt_object_def split: cdl_object.split)+
apply (clarsimp simp:bind_assoc)
done
lemma monad_commute_set_cap_assert:
"monad_commute \<top> (KHeap_D.set_cap ptr cap) (assert F)"
apply (simp add: monad_commute_def
assert_def fail_def bind_def return_def)
apply (subgoal_tac "empty_fail (KHeap_D.set_cap ptr cap)")
apply (clarsimp simp:empty_fail_def)
apply fastforce
apply (simp add:KHeap_D.set_cap_def split_def)
apply (wp|wpc|clarsimp split:cdl_object.splits)+
apply (simp add:KHeap_D.set_object_def)
done
crunch cdl_cdt_inv: "KHeap_D.set_cap" "\<lambda>s. P (cdl_cdt s)"
lemma monad_commute_set_cap_gets_cdt:
"monad_commute \<top> (KHeap_D.set_cap ptr cap) (gets cdl_cdt)"
apply (simp add: monad_commute_def gets_def get_def
assert_def fail_def bind_def return_def)
apply auto[1]
apply (rule bexI[rotated])
apply simp
apply simp
apply (drule use_valid)
apply (rule KHeap_D_set_cap_cdl_cdt_inv)
prefer 2
apply (fastforce +)[2]
apply (rule bexI[rotated])
apply simp
apply simp
apply (drule use_valid)
apply (rule KHeap_D_set_cap_cdl_cdt_inv)
prefer 2
apply (fastforce +)[2]
done
lemma set_cap_set_parent_swap:
"do _ \<leftarrow> KHeap_D.set_cap ptr cap; set_parent ptr2 ptr3 od
= do _ \<leftarrow> set_parent ptr2 ptr3; KHeap_D.set_cap ptr cap od"
apply (rule bind_return_eq)
apply (subst bind_assoc)+
apply (rule ext)
apply (subst monad_commute_simple)
apply (simp add:set_parent_def)
apply (rule monad_commute_split)+
apply (rule monad_commute_set_cap_cdt)
apply (rule monad_commute_set_cap_assert)
apply wp
apply (rule monad_commute_set_cap_gets_cdt)
apply clarsimp
apply fastforce
apply fastforce
done
lemma transform_default_cap:
"transform_cap (default_cap type ptr sz)
= Types_D.default_cap (translate_object_type type)
(retype_transform_obj_ref type sz ptr) sz"
by (cases type,
simp_all add: translate_object_type_def Types_D.default_cap_def
free_range_of_untyped_def
transform_cap_def arch_default_cap_def transform_mapping_def
retype_transform_obj_ref_def vm_read_write_def Nitpick.The_psimp
transform_asid_def asid_high_bits_of_def asid_low_bits_def
split: aobject_type.split)
crunch valid_etcbs[wp]: create_cap_ext valid_etcbs
lemma create_cap_dcorres:
"dcorres dc \<top> (cte_at parent and cte_wp_at (op = cap.NullCap) slot
and not_idle_thread (fst slot) and valid_idle and valid_etcbs
and (\<lambda>s. mdb_cte_at (swp (cte_wp_at (op \<noteq> cap.NullCap)) s) (cdt s)))
(Untyped_D.create_cap (translate_object_type type) sz (transform_cslot_ptr parent)
(transform_cslot_ptr slot, retype_transform_obj_ref type sz ptr))
(Retype_A.create_cap type sz parent (slot, ptr))"
apply (simp add: Untyped_D.create_cap_def Retype_A.create_cap_def)
apply (rule stronger_corres_guard_imp)
apply (rule corres_gets_the_bind)
apply (rule corres_underlying_gets_pre_lhs)
apply (rule corres_assert_lhs)
apply (simp add: set_cap_set_parent_swap bind_assoc[symmetric])
apply (rule corres_split_nor)
apply (fold dc_def)
apply (rule set_cap_corres, simp_all add: transform_default_cap)[1]
apply (simp add: bind_assoc set_original_def create_cap_ext_def
set_cdt_modify gets_fold_into_modify update_cdt_list_def
modify_modify set_cdt_list_modify)
apply (rule dcorres_set_parent_helper)
apply (rule_tac P'="\<lambda>s. mdb_cte_at (swp cte_at s) (cdt s)
\<and> cte_at parent s \<and> cte_at slot s"
in corres_modify[where P=\<top>])
apply (clarsimp simp: transform_def transform_current_thread_def
transform_asid_table_def transform_objects_def)
apply (simp add: transform_cdt_def fun_upd_def[symmetric])
apply (subst map_lift_over_upd)
apply (rule_tac P=\<top> and s=s' in transform_cdt_slot_inj_on_cte_at)
apply (auto dest: mdb_cte_atD[rotated] elim!: ranE)[1]
apply simp
apply (wp|simp)+
apply (clarsimp simp: cte_wp_at_caps_of_state caps_of_state_transform_opt_cap
not_idle_thread_def)
apply (clarsimp simp: swp_def not_idle_thread_def cte_wp_at_caps_of_state)
apply (drule mdb_cte_at_cdt_null)
apply (clarsimp simp:cte_wp_at_caps_of_state swp_def)
apply (fastforce simp:mdb_cte_at_def)
done
lemma set_cap_default_not_none:
"\<lbrace>\<lambda>s. cte_wp_at (\<lambda>x. slot \<noteq> ptr \<longrightarrow> x \<noteq> cap.NullCap) slot s\<rbrace> CSpaceAcc_A.set_cap (Retype_A.default_cap type a b) ptr
\<lbrace>\<lambda>rv s. cte_wp_at (op \<noteq> cap.NullCap) slot s\<rbrace>"
apply (clarsimp simp:cte_wp_at_caps_of_state valid_def)
apply (drule set_cap_caps_of_state_monad)
apply clarsimp
done
crunch cte_wp_at[wp]: create_cap_ext "cte_wp_at P ps"
lemma create_cap_mdb_cte_at:
"\<lbrace>\<lambda>s. mdb_cte_at (swp (cte_wp_at (op\<noteq>cap.NullCap)) s) (cdt s)
\<and> cte_wp_at (op\<noteq>cap.NullCap) parent s \<and> cte_at (fst tup) s\<rbrace>
create_cap type sz parent tup \<lbrace>\<lambda>rv s. mdb_cte_at (swp (cte_wp_at (op\<noteq>cap.NullCap)) s) (cdt s)\<rbrace>"
apply (simp add: create_cap_def split_def mdb_cte_at_def)
apply (rule hoare_pre)
apply (wp hoare_vcg_all_lift set_cap_default_not_none
set_cdt_cte_wp_at static_imp_wp dxo_wp_weak
| simp | wps)+
apply (clarsimp simp:cte_wp_at_caps_of_state)
apply (intro conjI impI)
apply clarsimp
apply (drule spec)+
apply (erule impE)
apply simp
apply clarsimp
apply fastforce
done
lemma neg_mask_add_2p_helper:
"\<lbrakk>is_aligned (b::word32) us;us < 32\<rbrakk> \<Longrightarrow> b + 2 ^ us - 1 && ~~ mask us = b"
apply (simp add:p_assoc_help)
apply (rule is_aligned_add_helper[THEN conjunct2])
apply (simp add:less_1_helper)
apply (simp add:word_power_less_1)
done
lemma retype_transform_ref_subseteq_strong:
"\<lbrakk>p \<in> set (retype_addrs ptr ty n us);range_cover ptr sz (obj_bits_api ty us) n \<rbrakk>
\<Longrightarrow> retype_transform_obj_ref ty us p \<subseteq> {ptr..ptr + of_nat n * (2::word32) ^ obj_bits_api ty us - 1}"
apply (subgoal_tac "{p .. p + 2 ^ obj_bits_api ty us - 1}
\<subseteq> {ptr..ptr + of_nat n * 2 ^ obj_bits_api ty us - 1}")
apply (erule subset_trans[rotated])
apply (clarsimp simp:retype_transform_obj_ref_def)
apply (rule conjI)
apply (clarsimp simp:obj_bits_api_def)
apply clarsimp
apply (rule is_aligned_no_overflow)
apply (erule retype_addrs_aligned)
apply (erule range_cover.aligned)
apply (drule range_cover.sz,simp add:word_bits_def)
apply (erule range_cover.sz)
apply (case_tac "n = 0")
apply (clarsimp simp:retype_addrs_def)
apply (frule(1) retype_addrs_range_subset)
apply clarsimp
proof -
assume cover:"range_cover ptr sz (obj_bits_api ty us) n"
and mem_p:"p \<in> set (retype_addrs ptr ty n us)"
and not_0:"0 < n"
note n_less = range_cover.range_cover_n_less[OF cover]
have unat_of_nat_m1: "unat (of_nat n - (1::word32)) < n"
using not_0 n_less
by (simp add:unat_of_nat_minus_1)
have decomp:"of_nat n * 2 ^ obj_bits_api ty us = of_nat (n - 1) * 2 ^ obj_bits_api ty us
+ (2 :: word32) ^ obj_bits_api ty us"
apply (simp add:distrib_right[where b = "1::'a::len word",simplified,symmetric])
using not_0 n_less
apply (simp add:unat_of_nat_minus_1 obj_bits_api_def3)
done
show "p + 2 ^ obj_bits_api ty us - 1 \<le> ptr + of_nat n * 2 ^ obj_bits_api ty us - 1"
apply (subst decomp)
apply (simp add:add.assoc[symmetric])
apply (simp add:p_assoc_help)
apply (rule order_trans[OF word_plus_mono_left word_plus_mono_right])
using mem_p not_0
apply (clarsimp simp:retype_addrs_def ptr_add_def shiftl_t2n)
apply (rule word_plus_mono_right)
apply (rule word_mult_le_mono1[OF word_of_nat_le])
using n_less not_0
apply (subst unat_of_nat_minus_1)
apply simp
apply simp
apply (simp add:Set_Interval.ord_class.atLeastLessThan_def)
apply (rule p2_gt_0[THEN iffD2])
using cover
apply (simp add:word_bits_def range_cover_def)
apply (simp only: word_bits_def[symmetric])
using not_0 n_less
apply (clarsimp simp: unat_of_nat_minus_1)
apply (subst unat_power_lower)
using cover
apply (simp add:range_cover_def)
apply (rule nat_less_power_trans2[OF range_cover.range_cover_le_n_less(2),OF cover, folded word_bits_def])
apply (simp add:unat_of_nat_m1 less_imp_le)
using cover
apply (simp add:range_cover_def word_bits_def)
apply (rule word32_plus_mono_right_split[where sz = sz])
using range_cover.range_cover_compare[OF cover,where p = "unat (of_nat n - (1::word32))"]
apply (clarsimp simp:unat_of_nat_m1)
using cover
apply (simp add:range_cover_def word_bits_def)
apply (rule olen_add_eqv[THEN iffD2])
apply (subst add.commute[where a = "2^(obj_bits_api ty us) - 1"])
apply (subst p_assoc_help[symmetric])
apply (rule is_aligned_no_overflow)
apply (insert cover)
apply (clarsimp simp:range_cover_def)
apply (erule aligned_add_aligned[OF _ is_aligned_mult_triv2])
apply (simp add:range_cover_def)+
done
qed
lemma generate_object_ids_exec:
notes [simp del] = order_class.Icc_eq_Icc
shows
"dcorres r P P' (f (map (retype_transform_obj_ref ty us) (retype_addrs ptr ty n us))) g
\<Longrightarrow> dcorres r P
(K ((ty = Invariants_AI.Untyped \<longrightarrow> (4 \<le> us))
\<and> range_cover ptr sz (obj_bits_api ty us) n
\<and> is_aligned ptr (obj_bits_api ty us)
\<and> {ptr..ptr + of_nat n * 2 ^ obj_bits_api ty us - 1} \<subseteq> free_range )
and (pspace_no_overlap ptr sz) and valid_pspace and valid_idle and P')
(do
t \<leftarrow> generate_object_ids n (translate_object_type ty) free_range;
f t
od) g"
apply (clarsimp simp:generate_object_ids_def bind_assoc)
apply (rule dcorres_absorb_get_l)
apply (rule corres_guard_imp)
apply (rule_tac x = "(map (retype_transform_obj_ref ty us) (retype_addrs ptr ty n us))"
in select_pick_corres_asm[rotated])
apply (rule corres_symb_exec_l)
apply (rule_tac F = "rv = map (retype_transform_obj_ref ty us) (retype_addrs ptr ty n us)"
in corres_gen_asm)
apply clarify
apply assumption
apply (clarsimp simp:return_def exs_valid_def)
apply (rule hoare_vcg_split_if)
apply (wp|simp)+
apply (intro conjI impI)
apply (clarsimp simp:distinct_map distinct_retype_addrs)
apply (clarsimp simp:inj_on_def)
apply (clarsimp simp:retype_transform_obj_ref_def
split:if_splits)
apply (frule range_cover.sz(1))
apply (drule(1) retype_addrs_aligned[where sz = sz])
apply (clarsimp simp:word_bits_def)
apply (erule range_cover.sz)
apply (drule(1) retype_addrs_aligned[where sz = sz])
apply (clarsimp simp:word_bits_def)
apply (erule range_cover.sz)
apply (subst (asm) range_eq)
apply (clarsimp simp:is_aligned_no_overflow obj_bits_api_def)
apply simp
apply (clarsimp simp:retype_transform_obj_ref_def split:if_splits)
apply (frule range_cover.sz(1))
apply (drule(1) retype_addrs_aligned[where sz = sz])
apply (clarsimp simp:word_bits_def)
apply (erule range_cover.sz)
apply (drule(1) retype_addrs_aligned[where sz = sz])
apply (clarsimp simp:word_bits_def)
apply (erule range_cover.sz)
apply (clarsimp simp:obj_bits_api_def order_class.Icc_eq_Icc)
apply (drule_tac x = b in neg_mask_mono_le[where n = us])
apply (drule_tac x = a in neg_mask_mono_le[where n = us])
apply (clarsimp simp:is_aligned_neg_mask_eq neg_mask_add_2p_helper
dest!:range_cover_sz')
apply (clarsimp)
apply (intro conjI)
apply (clarsimp simp:retype_transform_obj_ref_def)
apply (rule is_aligned_no_overflow)
apply (drule(1) retype_addrs_aligned[where sz = sz])
apply (clarsimp simp:word_bits_def dest!:range_cover.sz(1))
apply (erule range_cover.sz)
apply (simp add:obj_bits_api_def)
apply (erule(2) subset_trans[OF retype_transform_ref_subseteq_strong])
apply (rule retype_transform_obj_ref_available)
apply simp+
apply (clarsimp simp:retype_transform_obj_ref_def translate_object_type_def)
apply simp
done
lemma create_caps_loop_dcorres:
"dcorres dc \<top>
(\<lambda>s. cte_wp_at (op \<noteq> cap.NullCap) parent s \<and> valid_idle s \<and> mdb_cte_at (swp (cte_wp_at (op \<noteq> cap.NullCap)) s) (cdt s)
\<and> idle_thread s \<notin> fst ` fst ` set targets
\<and> distinct (parent # map fst targets)
\<and> (\<forall>tup \<in> set targets. cte_wp_at (op = cap.NullCap) (fst tup) s) \<and> valid_etcbs s)
(mapM_x
(\<lambda>x. Untyped_D.create_cap (translate_object_type type) sz
(transform_cslot_ptr parent)
(transform_cslot_ptr (fst x), retype_transform_obj_ref type sz (snd x)))
targets)
(mapM_x (Retype_A.create_cap type sz parent) targets)"
apply (induct targets)
apply (simp add: mapM_x_Nil)
apply (clarsimp simp: mapM_x_Cons)
apply (rule corres_guard_imp)
apply (erule corres_split_nor)
apply (rule create_cap_dcorres)
apply (wp create_cap_invs hoare_vcg_const_Ball_lift
create_cap_mdb_cte_at[unfolded swp_def])
apply simp
apply (clarsimp simp: not_idle_thread_def swp_def)
apply (auto simp: cte_wp_at_caps_of_state image_def)
done
crunch valid_idle[wp]: init_arch_objects "valid_idle"
(wp: crunch_wps ignore: clearMemory)
crunch idle_thread[wp]: init_arch_objects, retype_region "\<lambda>s. P (idle_thread s)"
(wp: crunch_wps ignore: clearMemory)
lemma delete_objects_idle_thread[wp]:
"\<lbrace>\<lambda>s. P (idle_thread s)\<rbrace> delete_objects a b \<lbrace>\<lambda>_ s. P (idle_thread s)\<rbrace>"
by (simp add: delete_objects_def do_machine_op_def split_def detype_def | wp)+
lemma update_available_range_dcorres:
"dcorres dc \<top> ( K(\<exists>idx. untyped_cap = transform_cap (cap.UntypedCap ptr sz idx)
\<and> free_range_of_untyped idx' sz ptr \<subseteq> new_range - set oids)
and valid_idle and (\<lambda>s. cref \<noteq> idle_thread s) and valid_etcbs)
(update_available_range new_range oids
(transform_cslot_ptr (cref, oref)) untyped_cap)
(CSpaceAcc_A.set_cap
(cap.UntypedCap ptr
sz idx')
(cref, oref))"
apply (rule dcorres_expand_pfx)
apply (clarsimp simp:update_available_range_def)
apply (rule corres_guard_imp)
apply (rule select_pick_corres)
apply (rule set_cap_corres)
apply clarsimp
apply simp+
done
lemma subseteq_set_minus:
"\<lbrakk>A \<subseteq> B; A\<inter> C = {}\<rbrakk> \<Longrightarrow> A \<subseteq> B - C"
by auto
lemma free_range_of_untyped_subseteq:
"range_cover (ptr::word32) sz us n \<Longrightarrow>
free_range_of_untyped (unat ((ptr && mask sz) + (of_nat n * 2^us))) sz (ptr &&~~ mask sz)
\<subseteq> {ptr.. (ptr &&~~ mask sz) + 2 ^ sz - 1}"
unfolding free_range_of_untyped_def
apply clarsimp
apply (subst AND_NOT_mask_plus_AND_mask_eq[symmetric,where n = sz])
apply (rule word_plus_mono_right)
apply (drule range_cover.range_cover_base_le)
apply (clarsimp simp:shiftl_t2n field_simps)
apply (rule is_aligned_no_wrap'[OF is_aligned_neg_mask])
apply (rule le_refl)
apply (rule word32_less_sub_le[THEN iffD1])
apply (simp add:range_cover_def word_bits_def)
apply (simp add:word_le_nat_alt unat_power_lower32
range_cover_def unat_2p_sub_1)
done
lemma retype_addrs_range_subset_strong:
notes [simp del] = atLeastAtMost_iff atLeastatMost_subset_iff
shows "\<lbrakk>p \<in> set (retype_addrs ptr ty n us); range_cover ptr sz (obj_bits_api ty us) n\<rbrakk>
\<Longrightarrow> {p..p + 2 ^ obj_bits_api ty us - 1} \<subseteq> {ptr..ptr + of_nat n * 2 ^ obj_bits_api ty us - 1}"
apply (clarsimp simp: retype_addrs_def ptr_add_def)
apply (drule_tac p = pa in range_cover_subset)
apply clarsimp+
apply blast
done
lemma le_p2_minus_1:
"a \<le> (2^z - (Suc 0::nat)) \<Longrightarrow> a < 2^z"
apply (subgoal_tac "(0 :: nat)< 2^z")
apply arith
apply simp
done
lemma free_range_of_untyped_subseteq':
"\<lbrakk>a \<le> a';is_aligned ptr sz; sz < 32\<rbrakk> \<Longrightarrow> free_range_of_untyped a' sz (ptr::word32) \<subseteq>free_range_of_untyped a sz (ptr::word32)"
apply (clarsimp simp:free_range_of_untyped_def)
apply (rule word_plus_mono_right)
apply (drule le_p2_minus_1)
apply (rule of_nat_mono_maybe_le[THEN iffD1,rotated -1])
apply simp
apply (erule less_le_trans)
apply (rule power_increasing,simp+)[1]
apply (drule(1) le_less_trans)
apply (erule less_le_trans)
apply (rule power_increasing,simp+)
apply (erule is_aligned_no_wrap')
apply (rule word_of_nat_less)
apply (drule le_p2_minus_1)
apply (simp add:unat_power_lower32[unfolded word_bits_def]
word_bits_def)
done
lemma retype_transform_obj_ref_not_empty:
"\<lbrakk>range_cover ptr sz (obj_bits_api tp us) n;
is_aligned ptr (obj_bits_api tp us);
y \<in> set (retype_addrs ptr tp n us)\<rbrakk>
\<Longrightarrow> (retype_transform_obj_ref tp us y) \<noteq> {}"
apply (frule(1) retype_addrs_aligned)
apply (drule range_cover.sz,simp add:word_bits_def)
apply (erule range_cover.sz)
apply (clarsimp simp:retype_addrs_def retype_transform_obj_ref_def ptr_add_def)
apply (rule is_aligned_no_overflow)
apply (simp add:obj_bits_api_def)
done
lemma in_empty_setE:
"\<lbrakk>x\<in> A;x\<in> B; A\<inter> B = {}\<rbrakk> \<Longrightarrow> Q"
by blast
lemma free_range_of_untyped_pick_retype_addrs:
notes [simp del] = atLeastAtMost_iff
shows "\<lbrakk>range_cover ptr sz (obj_bits_api tp us) (length slots) ; slots \<noteq> []\<rbrakk> \<Longrightarrow>
free_range_of_untyped (unat ((ptr && mask sz) + (of_nat (length slots) << obj_bits_api tp us))) sz (ptr && ~~ mask sz) \<inter>
(\<lambda>a. pick (retype_transform_obj_ref tp us a)) ` set (retype_addrs ptr tp (length slots) us) =
{}"
apply (clarsimp simp:image_def free_range_of_untyped_def)
apply (rule disjointI)
apply (drule CollectD)
apply clarsimp
apply (frule retype_transform_obj_ref_not_empty)
apply (erule range_cover.aligned)
apply simp
apply (drule(1) retype_transform_ref_subseteq_strong)
apply (drule nonempty_pick_in)
apply (drule(1) set_mp[rotated])
apply (clarsimp simp:shiftl_t2n field_simps)
apply (erule(1) in_empty_setE)
apply clarsimp
apply (drule leD[where y = "(ptr && mask sz) + ((ptr && ~~ mask sz)
+ of_nat (length slots) * 2 ^ obj_bits_api tp us)"])
apply (subgoal_tac " ptr + of_nat (length slots) * 2 ^ obj_bits_api tp us - 1 <
(ptr && mask sz) + ((ptr && ~~ mask sz) + of_nat (length slots) * 2 ^ obj_bits_api tp us)")
apply simp
apply (subst group_add_class.add_diff_eq[symmetric])
apply (frule range_cover_not_zero_shift[rotated,OF _ le_refl])
apply simp
apply (thin_tac "\<not>P" for P)
apply (subst add.assoc[symmetric])
apply (subst AND_NOT_mask_plus_AND_mask_eq[symmetric,where n = sz])
apply (subst add.commute[where a = "(ptr && mask sz)"])
apply (rule word_plus_strict_mono_right)
apply (rule minus_one_helper)
apply simp
apply (simp add:shiftl_t2n field_simps)
apply (subst add.assoc)
apply (rule word_plus_mono_right)
apply (simp add:word_le_nat_alt)
apply (simp add: range_cover_unat)
apply (rule is_aligned_no_wrap'[OF is_aligned_neg_mask])
apply (rule le_refl)
apply (drule le_p2_minus_1)
apply (simp add:word_less_nat_alt)
apply (subst unat_power_lower32[unfolded word_bits_def])
apply (erule range_cover.sz)
apply simp
done
lemma invoke_untyped_corres:
"dcorres dc (\<lambda>_. True)
(invs and ct_active and valid_untyped_inv untyped_invocation and valid_etcbs)
(Untyped_D.invoke_untyped (translate_untyped_invocation untyped_invocation))
(Retype_A.invoke_untyped untyped_invocation)"
apply (rule dcorres_expand_pfx)
apply (cases untyped_invocation)
apply (clarsimp simp del:invoke_untyped.simps)
apply (rename_tac s cref oref ptr tp us slots sz idx)
proof -
fix cref oref ptr tp us slots s sz idx
assume cte_wp_at : "cte_wp_at (\<lambda>c. c = cap.UntypedCap (ptr && ~~ mask sz) sz idx) (cref,oref) (s :: det_ext state)"
have cte_at: "cte_wp_at (op = (cap.UntypedCap (ptr && ~~ mask sz) sz idx)) (cref,oref) s" (is "?cte_cond s")
using cte_wp_at by (simp add:cte_wp_at_caps_of_state)
assume desc_range: "ptr = ptr && ~~ mask sz \<longrightarrow> descendants_range_in {ptr..ptr + 2 ^ sz - 1} (cref,oref) s"
assume misc : "distinct slots" "tp = Invariants_AI.CapTableObject \<longrightarrow> 0 < (us::nat)"
" tp = Invariants_AI.Untyped \<longrightarrow> 4 \<le> (us::nat)"
" idx \<le> unat (ptr && mask sz) \<or> ptr = ptr && ~~ mask sz"
" invs s" "valid_etcbs s" "tp \<noteq> ArchObject ASIDPoolObj"
" \<forall>slot\<in>set slots. cte_wp_at (op = cap.NullCap) slot s \<and> ex_cte_cap_wp_to is_cnode_cap slot s \<and> real_cte_at slot s"
" ct_active s"
assume cover : "range_cover ptr sz (obj_bits_api tp us) (length slots)"
assume vslot : "slots\<noteq> []"
note [simp del] = usable_untyped_range.simps atLeastAtMost_iff
atLeastatMost_subset_iff split_paired_Ex
have [simp]:"(cref, oref) \<notin> set slots"
using cte_wp_at misc by(clarsimp simp:cte_wp_at_caps_of_state)
have not_idle:"not_idle_thread cref s"
using cte_wp_at misc
apply -
apply (rule ccontr)
apply (clarsimp simp:not_idle_thread_def cte_wp_at_caps_of_state)
apply (drule valid_idle_has_null_cap[rotated -1])
apply clarsimp+
done
have pf: "invoke_untyped_proofs s (cref,oref) ptr tp us slots sz idx"
using cte_wp_at desc_range misc cover vslot
apply (clarsimp simp:invoke_untyped_proofs_def cte_wp_at_caps_of_state)
apply (drule(1) bspec)
apply (clarsimp elim!:ex_cte_cap_wp_to_weakenE)
done
note cte_wp_at_machine_state[simp del]
note set_cap_free_index_invs_spec = set_free_index_invs[where cap = "cap.UntypedCap (ptr && ~~ mask sz) sz idx"
,unfolded free_index_update_def free_index_of_def,simplified]
note subset_stuff[simp] = invoke_untyped_proofs.subset_stuff[OF pf]
note descendants_range[simp] = invoke_untyped_proofs.descendants_range[OF pf]
note ps_no_overlap[simp] = invoke_untyped_proofs.ps_no_overlap[OF pf]
note caps_no_overlap[simp] = invoke_untyped_proofs.caps_no_overlap[OF pf]
note slots_invD = invoke_untyped_proofs.slots_invD[OF pf]
note kernel_window_inv = invoke_untyped_proofs.kernel_window_inv[OF pf]
note ptr_0[simp] = invoke_untyped_proofs.not_0_ptr
have nidx[simp]: "\<And>m. ptr + m - (ptr && ~~ mask sz)
= (ptr && mask sz) + m"
apply (subst word_plus_and_or_coroll2[symmetric,where w = "mask sz" and t = ptr])
apply simp
done
have non_detype_idx_le[simp]: "ptr \<noteq> ptr && ~~ mask sz \<Longrightarrow> idx < 2^sz"
using misc cover
apply clarsimp
apply (frule le_mask_le_2p)
apply (simp add:range_cover_def[where 'a=32, folded word_bits_def])+
done
have in_free_range:
"ptr \<noteq> ptr && ~~ mask sz \<Longrightarrow> {ptr..(ptr && ~~ mask sz) + 2 ^ sz - 1}
\<subseteq> free_range_of_untyped idx sz (ptr && ~~ mask sz)"
using misc
apply (clarsimp simp:free_range_of_untyped_def nat_le_Suc_less_imp atLeastatMost_subset_iff)
apply (subgoal_tac "(ptr && ~~ mask sz) + of_nat idx \<le> (ptr && ~~ mask sz) + (ptr && mask sz)")
apply (simp add:mask_out_sub_mask)
apply (rule word_plus_mono_right)
apply (simp add:word_of_nat_le)
apply (rule is_aligned_no_wrap'[OF is_aligned_neg_mask])
apply (rule le_refl)
apply (rule and_mask_less')
apply (rule range_cover.sz[OF cover])
done
have idx_compare:
"ptr \<noteq> ptr && ~~ mask sz \<Longrightarrow>
idx \<le> unat ((ptr && mask sz) + of_nat (length slots) * 2 ^ obj_bits_api tp us)"
using misc
apply (cut_tac range_cover_unat[OF cover])
apply simp
done
note neg_mask_add_mask = word_plus_and_or_coroll2[symmetric,where w = "mask sz" and t = ptr,symmetric]
have [simp]: "ptr &&~~ mask sz = ptr \<Longrightarrow> {ptr + of_nat k |k. k < 2 ^ sz} = {ptr .. ptr + 2 ^ sz - 1}"
using cover
apply -
apply (rule intvl_range_conv)
apply (simp add:is_aligned_neg_mask_eq')
apply (simp add:range_cover_def)
done
have detype_valid_etcbs: "\<lbrakk> valid_etcbs s; ptr && ~~ mask sz = ptr \<rbrakk> \<Longrightarrow> valid_etcbs (detype {ptr..(ptr && ~~ mask sz) + 2 ^ sz - 1} (clear_um {ptr..(ptr && ~~ mask sz) + 2 ^ sz - 1} s))"
apply (clarsimp simp: valid_etcbs_def st_tcb_at_def is_etcb_at_def detype_def detype_ext_def
st_tcb_at_kh_def obj_at_kh_def obj_at_def clear_um_def)
done
note msimp[simp add] = misc getObjectSize_def_eq neg_mask_add_mask
show "dcorres dc (op = (transform s)) (op = s)
(Untyped_D.invoke_untyped
(translate_untyped_invocation
(Invocations_A.untyped_invocation.Retype (cref, oref) (ptr && ~~ mask sz) ptr tp us slots)))
(Retype_A.invoke_untyped
(Invocations_A.untyped_invocation.Retype (cref, oref) (ptr && ~~ mask sz) ptr tp us slots))"
using not_idle
apply (clarsimp simp: Untyped_D.invoke_untyped_def mapM_x_def
translate_untyped_invocation_def)
apply (clarsimp simp:unless_def)
apply (case_tac "ptr && ~~ mask sz = ptr")
apply (rule corres_guard_imp)
apply (rule corres_split[OF _ get_cap_corres] )
apply (rule corres_split[OF _ corres_when])
apply (rule generate_object_ids_exec[where ptr = ptr and us = us and sz = sz])
apply (simp add:generate_object_ids_def)
apply (rule corres_split[OF _ update_available_range_dcorres])
apply simp
apply (rule corres_split[OF _ retype_region_dcorres[where sz = sz]])
apply (rule corres_split_noop_rhs[OF _ init_arch_objects_corres_noop[where sz =sz]])
apply (simp add: liftM_def[symmetric] mapM_x_def[symmetric]
zip_map zip_map2 o_def split_beta dc_def[symmetric])
apply (rule create_caps_loop_dcorres)
apply clarsimp
apply (erule retype_addrs_aligned[OF _ range_cover.aligned _ le_refl])
apply (rule cover)
apply (rule range_cover_sz'[where 'a=32, folded word_bits_def, OF cover])
apply (rule cover)
apply (simp add:misc vslot)
apply ((wp | simp add: mdb_cte_at_def | rule hoare_vcg_conj_lift, wps)+)[2]
apply (wp retype_region_aligned_for_init[where sz = sz]
retype_region_obj_at[THEN hoare_vcg_const_imp_lift]
retype_region_caps_of[where sza = "\<lambda>_. sz"]
| simp add:misc)+
apply (rule_tac Q="\<lambda>rv s. cte_wp_at (op \<noteq> cap.NullCap) (cref, oref) s \<and> post_retype_invs tp rv s
\<and> idle_thread s \<notin> fst ` set slots
\<and> (\<forall>slot\<in>set slots.
cte_wp_at (op = cap.NullCap) slot s) \<and> valid_etcbs s"
in hoare_post_imp)
apply (simp add:post_retype_invs_def split:split_if_asm)
apply ((clarsimp dest!:set_zip_leftD
simp:image_def invs_def valid_state_def valid_mdb_def
elim!:cte_wp_at_weakenE | intro conjI | drule (1) bspec | drule(1) mdb_cte_atD[rotated])+)[2]
apply (wp retype_region_cte_at_other'[where sz= sz] retype_region_post_retype_invs[where sz = sz]
hoare_vcg_const_Ball_lift retype_region_aligned_for_init)
apply (clarsimp simp:conj_comms misc cover)
apply (rule_tac Q="\<lambda>r s.
cte_wp_at (op = (cap.UntypedCap ptr sz (unat (of_nat (length slots) << obj_bits_api tp us)))) (cref, oref) s \<and>
invs s \<and> pspace_no_overlap ptr sz s \<and> caps_no_overlap ptr sz s \<and>
region_in_kernel_window {ptr..ptr + 2 ^ sz - 1} s \<and>
caps_overlap_reserved {ptr..ptr + of_nat (length slots) * 2 ^ obj_bits_api tp us - 1} s \<and>
idle_thread s \<notin> fst ` set slots \<and> cap_objects (transform_cap cap) = {ptr..ptr + (2 ^ sz - 1)}
\<and> (\<forall>x\<in>set slots. cte_wp_at (op= cap.NullCap) x s) \<and> valid_etcbs s"
in hoare_strengthen_post[rotated])
apply (clarsimp simp:invs_mdb invs_valid_pspace cte_wp_at_caps_of_state)
apply (intro conjI exI ballI,simp+)
apply (erule ranE)
apply (clarsimp simp:null_filter_def split:if_splits)
apply (frule_tac cap = capa in caps_of_state_ko[OF caps_of_state_valid])
apply assumption
apply (elim disjE)
apply (clarsimp simp:cap_range_def is_cap_simps)+
apply (rule disjointI)
apply clarsimp
apply (drule bspec,fastforce,clarsimp)
apply (drule_tac S = "{y}" in pspace_no_overlap_obj_range)
apply assumption
apply simp
apply (drule p_in_obj_range)
apply clarsimp+
apply (rule_tac P = "cap = cap.UntypedCap (ptr && ~~ mask sz) sz idx" in hoare_gen_asm)
apply (simp add:bits_of_def region_in_kernel_window_def)
apply (wp set_cap_no_overlap hoare_vcg_ball_lift set_untyped_cap_invs_simple
set_cap_cte_wp_at set_cap_descendants_range_in set_cap_caps_no_overlap
set_untyped_cap_caps_overlap_reserved set_cap_cte_cap_wp_to)
apply simp
apply simp
apply (rule_tac F = "cap = cap.UntypedCap (ptr && ~~ mask sz) sz idx" in corres_gen_asm2)
apply (rule delete_objects_dcorres)
apply (rule set_eqI)
apply (clarsimp simp: bits_of_def image_def)
apply wp
apply (clarsimp simp:conj_comms)
apply (rule_tac P = "cap = cap.UntypedCap ptr sz idx \<and> sz \<le> word_bits
\<and> 2 \<le> sz" in hoare_gen_asm)
apply (clarsimp simp:delete_objects_rewrite bits_of_def)
apply (wp get_cap_wp | clarsimp | simp)+
using cte_at invoke_untyped_proofs.detype_descendants_range_in[OF pf] descendants_range
misc invoke_untyped_proofs.cref_inv[OF pf] invoke_untyped_proofs.detype_invs[OF pf]
cover invoke_untyped_proofs.vc[OF pf] subset_stuff invoke_untyped_proofs.usable_range_disjoint[OF pf]
range_cover.sz[OF cover] range_cover.aligned[OF cover] detype_valid_etcbs
apply (clarsimp simp:detype_clear_um_independent conj_comms not_idle_thread_def
misc invs_valid_idle invs_valid_objs word_bits_def)
apply (clarsimp simp:cte_wp_at_caps_of_state range_cover.aligned
untyped_range.simps bits_of_def field_simps)
apply (intro conjI)
apply (simp add:valid_cap_simps)
apply fastforce
apply (clarsimp dest!:invs_valid_idle)
apply (clarsimp dest!:invs_valid_pspace)
apply (erule pspace_no_overlap_detype)
apply (clarsimp simp:invs_psp_aligned)
apply (clarsimp simp:invs_valid_objs)
apply (rule caps_no_overlap_detype,simp)
apply (rule invoke_untyped_proofs.idx_compare'[OF pf])
apply (simp add:descendants_range_def2 untyped_range.simps)
apply fastforce
apply (simp add:is_aligned_neg_mask_eq'[symmetric] is_aligned_mask)
apply (simp add:clear_um_def detype_def)
apply (simp add:clear_um_def detype_def)
apply (clarsimp simp:clear_um_def kernel_window_inv)
apply (clarsimp simp:clear_um_def detype_def dest!:slots_invD)
apply (drule ex_cte_cap_to_not_idle)
apply (clarsimp simp:invs_valid_global_refs)
apply (simp add:invs_valid_idle)
apply (clarsimp simp:invs_irq_node)
apply simp
apply (drule(1) descendants_range_in_subseteq)
apply simp
apply (simp add:shiftl_t2n field_simps)
apply (clarsimp dest!:slots_invD)
apply (rule subseteq_set_minus)
apply (drule free_range_of_untyped_subseteq)
apply (simp add:shiftl_t2n field_simps
mask_out_sub_mask)
apply (drule free_range_of_untyped_pick_retype_addrs)
apply (simp add:vslot)
apply simp
apply (simp add: valid_etcbs_def is_etcb_at_def st_tcb_at_def detype_def detype_ext_def clear_um_def st_tcb_at_kh_def obj_at_kh_def obj_at_def)
apply (rule corres_guard_imp)
apply (rule corres_split[OF _ get_cap_corres] )
apply simp
apply (rule generate_object_ids_exec[where ptr = ptr and us = us and sz = sz and ty = tp])
apply (rule corres_split[OF _ update_available_range_dcorres])
apply simp
apply (rule corres_split[OF _ retype_region_dcorres[where sz = sz]])
apply (rule corres_split_noop_rhs[OF _ init_arch_objects_corres_noop[where sz =sz]])
apply (simp add: liftM_def[symmetric] mapM_x_def[symmetric]
zip_map zip_map2 o_def split_beta dc_def[symmetric])
apply (rule create_caps_loop_dcorres)
apply clarsimp
apply (erule retype_addrs_aligned[OF _ range_cover.aligned _ le_refl])
apply (rule cover)
apply (rule range_cover_sz'[where 'a=32, folded word_bits_def, OF cover])
apply (rule cover)
apply (simp add:misc vslot)
apply ((wp | simp add: mdb_cte_at_def | rule hoare_vcg_conj_lift, wps)+)[2]
apply (wp retype_region_aligned_for_init[where sz = sz]
retype_region_obj_at[THEN hoare_vcg_const_imp_lift]
retype_region_caps_of[where sza = "\<lambda>_. sz"]
| simp add:misc)+
apply (rule_tac Q="\<lambda>rv s. cte_wp_at (op \<noteq> cap.NullCap) (cref, oref) s \<and> post_retype_invs tp rv s
\<and> idle_thread s \<notin> fst ` set slots
\<and> (\<forall>slot\<in>set slots.
cte_wp_at (op = cap.NullCap) slot s) \<and> valid_etcbs s"
in hoare_post_imp)
apply (simp add:post_retype_invs_def split:split_if_asm)
apply ((clarsimp dest!:set_zip_leftD
simp:image_def invs_def valid_state_def valid_mdb_def
elim!:cte_wp_at_weakenE | intro conjI | drule (1) bspec | drule(1) mdb_cte_atD[rotated])+)[2]
apply (wp retype_region_cte_at_other'[where sz= sz] retype_region_post_retype_invs[where sz = sz]
hoare_vcg_const_Ball_lift retype_region_aligned_for_init)
apply (clarsimp simp:conj_comms misc cover)
apply (rule_tac Q="\<lambda>r s.
cte_wp_at (op = (cap.UntypedCap (ptr && ~~ mask sz)
sz (unat ((ptr && mask sz) + (of_nat (length slots) << obj_bits_api tp us))))) (cref, oref) s \<and>
invs s \<and> valid_etcbs s \<and> pspace_no_overlap ptr sz s \<and> caps_no_overlap ptr sz s \<and>
region_in_kernel_window {ptr..(ptr && ~~ mask sz) + 2 ^ sz - 1} s \<and>
caps_overlap_reserved {ptr..ptr + of_nat (length slots) * 2 ^ obj_bits_api tp us - 1} s \<and>
idle_thread s \<notin> fst ` set slots
\<and> cap_objects (transform_cap cap) = {ptr && ~~ mask sz..(ptr && ~~ mask sz) + (2 ^ sz - 1)}
\<and> (\<forall>x\<in>set slots. cte_wp_at (op= cap.NullCap) x s)"
in hoare_strengthen_post[rotated])
apply (clarsimp simp:invs_mdb invs_valid_pspace cte_wp_at_caps_of_state)
apply (erule ranE)
apply (clarsimp simp:null_filter_def split:if_splits)
apply (frule_tac cap = capa in caps_of_state_ko[OF caps_of_state_valid])
apply assumption
apply (elim disjE)
apply (clarsimp simp:cap_range_def is_cap_simps)+
apply (rule disjointI)
apply clarsimp
apply (drule bspec,fastforce,clarsimp)
apply (drule_tac S = "{y}" in pspace_no_overlap_obj_range)
apply assumption
apply simp
apply (drule p_in_obj_range)
apply clarsimp+
apply (rule_tac P = "cap = cap.UntypedCap (ptr && ~~ mask sz) sz idx" in hoare_gen_asm)
apply (simp add:bits_of_def region_in_kernel_window_def)
apply (rule hoare_vcg_conj_lift)
apply (rule hoare_strengthen_post[OF set_cap_sets])
apply (clarsimp simp:cte_wp_at_caps_of_state shiftl_t2n field_simps)
apply (wp set_cap_no_overlap hoare_vcg_ball_lift
set_cap_free_index_invs_spec set_cap_caps_no_overlap
set_cap_cte_wp_at set_cap_descendants_range_in
set_untyped_cap_caps_overlap_reserved)
apply simp
apply simp
apply (wp get_cap_wp)
apply simp
using cte_at descendants_range misc invoke_untyped_proofs.cref_inv[OF pf] kernel_window_inv
invoke_untyped_proofs.idx_compare'[OF pf] invoke_untyped_proofs.usable_range_disjoint[OF pf]
cover invoke_untyped_proofs.vc[OF pf] subset_stuff
apply (clarsimp simp:invs_valid_idle invs_valid_pspace
cte_wp_at_caps_of_state bits_of_def shiftl_t2n
untyped_range.simps field_simps)
apply (intro conjI)
apply (simp add:range_cover.aligned)
apply (rule subset_trans[OF subset_stuff])
apply (rule in_free_range)
apply simp
apply fastforce
apply (rule subseteq_set_minus)
apply (rule free_range_of_untyped_subseteq')
apply (rule idx_compare)
apply simp
apply (simp add:is_aligned_neg_mask)
apply (cut_tac range_cover.sz[OF cover],simp)
apply (drule free_range_of_untyped_pick_retype_addrs[OF _ vslot])
apply (simp add:shiftl_t2n field_simps image_def)
apply (simp add:shiftl_t2n not_idle_thread_def field_simps range_cover_unat[OF cover])
apply (rule idx_compare)
apply simp
apply (rule subset_trans[OF subset_stuff])
apply (clarsimp simp: atLeastatMost_subset_iff word_and_le2)
apply (clarsimp dest!:slots_invD)
apply (drule ex_cte_cap_wp_to_not_idle)
apply (clarsimp simp:invs_valid_global_refs invs_valid_objs
invs_valid_idle invs_irq_node)+
apply (simp add:not_idle_thread_def)
apply (clarsimp dest!:slots_invD)
done
qed
lemma transform_translate_type:
"transform_type n = Some tp
\<Longrightarrow> \<exists>v. data_to_obj_type n = returnOk v \<and> tp = translate_object_type v"
apply (simp add: transform_type_def
split: split_if_asm)
apply (simp_all add: data_to_obj_type_def arch_data_to_obj_type_def)
apply (auto simp add: translate_object_type_def)
done
lemma corres_whenE_throwError_split_rhs:
"corres_underlying sr f r P Q a (whenE G (throwError e) >>=E (\<lambda>_. b))
= ((G \<longrightarrow> corres_underlying sr f r P Q a (throwError e))
\<and> (\<not> G \<longrightarrow> corres_underlying sr f r P Q a b))"
by (simp add: whenE_bindE_throwError_to_if)
lemma nat_bl_to_bin_nat_to_cref:
assumes asms: "x < 2 ^ bits" "bits < word_bits"
shows "nat (bl_to_bin (nat_to_cref bits x)) = x"
proof -
note of_bl = of_bl_nat_to_cref[OF asms[unfolded word_bits_conv]]
have lt_bl: "bl_to_bin (nat_to_cref bits x) < 2 ^ 32"
apply (rule order_less_le_trans, rule bl_to_bin_lt2p)
apply (rule power_increasing)
apply (simp add: nat_to_cref_def)
apply simp
done
have lt_x: "x < 2 ^ 32"
apply (rule order_less_le_trans, rule asms)
apply (rule power_increasing, simp_all)
apply (insert asms word_bits_conv, simp)
done
show ?thesis using of_bl lt_bl lt_x
apply (simp add: of_bl_def word_of_nat)
apply (drule word_uint.Abs_eqD)
apply (simp add: uints_num bl_to_bin_ge0)
apply (simp add: uints_num)
apply simp
done
qed
crunch inv[wp]: "CSpace_D.ensure_empty" "P"
lemma mapME_x_inv_wp2:
"(\<And>x. \<lbrace>P and E\<rbrace> f x \<lbrace>\<lambda>rv. P and E\<rbrace>,\<lbrace>\<lambda>rv. E\<rbrace>)
\<Longrightarrow> \<lbrace>P and E\<rbrace> mapME_x f xs \<lbrace>\<lambda>rv. P\<rbrace>,\<lbrace>\<lambda>rv. E\<rbrace>"
apply (rule hoare_post_impErr)
apply (rule mapME_x_inv_wp[where E="\<lambda>_. E"])
apply (rule hoare_post_impErr, assumption)
apply simp_all
done
lemma gets_get:
"get = gets id "
by (simp add:gets_def)
lemma transform_cdt_dom_standard:
"transform_cdt s' slot' = Some (transform_cslot_ptr b)
\<Longrightarrow> \<exists>slot. slot' = transform_cslot_ptr slot"
apply (case_tac b)
apply (fastforce simp:transform_cdt_def map_lift_over_def split:split_if_asm)
done
lemma descendants_of_empty_lift :
"\<lbrakk>cte_at slot' s; valid_mdb s\<rbrakk> \<Longrightarrow>
(CSpaceAcc_A.descendants_of slot' (cdt s) = {})
= (\<not> (\<exists>slot. transform_cdt s slot = Some (transform_cslot_ptr slot')))"
apply (rule iffI)
apply clarsimp
apply (frule transform_cdt_dom_standard)
apply (clarsimp simp:descendants_of_def)
apply (thin_tac "(a,b) = P" for P)
apply (drule(1) transform_cdt_some_rev)
apply (clarsimp simp:valid_mdb_def)
apply clarsimp
apply (drule_tac x = a in spec,drule_tac x = b in spec)
apply (subgoal_tac "cdt s \<Turnstile> slot' \<rightarrow> (a, b)")
apply simp
apply (rule r_into_trancl')
apply (simp add:cdt_parent_rel_def is_cdt_parent_def)
apply (rule ccontr)
apply (clarsimp simp:descendants_of_def)
apply (drule tranclD)
apply clarsimp
apply (drule_tac x = aa in spec,drule_tac x = "nat (bl_to_bin ba)" in spec)
apply (frule descendants_of_cte_at[rotated])
apply (simp add:descendants_of_def)
apply (rule r_into_trancl')
apply simp
apply (drule_tac slot = "(aa,ba)" in mdb_cte_transform_cdt_lift)
apply (simp add:valid_mdb_def)
apply (clarsimp simp:cdt_parent_rel_def is_cdt_parent_def transform_cslot_ptr_def)
done
lemma alignUp_gt_0:
"\<lbrakk>is_aligned (x :: 'a :: len word) n; n < len_of TYPE('a); x \<noteq> 0 ; a \<le> x\<rbrakk> \<Longrightarrow> (0 < WordSetup.alignUp a n) = (a \<noteq> 0)"
apply (rule iffI)
apply (rule ccontr)
apply (clarsimp simp:not_less alignUp_def2 mask_def)
apply (frule(1) alignUp_is_aligned_nz[where a = a])
apply (simp add:unat_1_0)
apply simp
apply (simp add:word_neq_0_conv)
done
lemma of_nat_0:
"free_index < 2^word_bits - 1
\<Longrightarrow> ((of_nat free_index::word32) = 0) = (free_index = 0)"
apply (subst word_unat.inverse_norm)
apply (subst word_bits_def[symmetric])
apply simp
done
lemma range_cover_sz_less':
"range_cover (ptr :: word32) sz us n \<Longrightarrow> (2::nat) ^ sz < 2 ^ word_bits - 1"
apply (simp add:range_cover_def)
apply (rule le_less_trans[where y = "2^31"])
apply (rule power_increasing)
apply (clarsimp simp:word_bits_def)
apply simp
apply (simp add:word_bits_def)
done
lemma decode_untyped_corres:
"\<lbrakk> Some (UntypedIntent ui) = transform_intent (invocation_type label') args';
cap = transform_cap cap';
cap' = cap.UntypedCap ptr sz idx;
slot = transform_cslot_ptr slot';
excaps = transform_cap_list excaps' \<rbrakk> \<Longrightarrow>
dcorres (dc \<oplus> (\<lambda>x y. x = translate_untyped_invocation y))
\<top> (cte_wp_at (op = cap') slot' and invs
and (\<lambda>s. \<forall>x \<in> set (map fst excaps'). s \<turnstile> x)
and (\<lambda>s. \<forall>x \<in> set excaps'. cte_wp_at (diminished (fst x)) (snd x) s) and valid_etcbs)
(Untyped_D.decode_untyped_invocation cap slot excaps ui)
(Decode_A.decode_untyped_invocation label' args' slot' cap' (map fst excaps'))"
apply (simp add: transform_intent_def option_map_Some_eq2
transform_intent_untyped_retype_def
split: invocation_label.split_asm list.split_asm
option.split_asm)
apply (cases ui)
apply (drule transform_translate_type[where 'a=det_ext])
apply (clarsimp simp: Untyped_D.decode_untyped_invocation_def
Decode_A.decode_untyped_invocation_def
unlessE_whenE
split del: split_if
split: invocation_label.split_asm)
apply (rename_tac a list w1 w2 w3 w4 w5 apiobject_type)
apply (cases excaps')
apply (simp add: get_index_def transform_cap_list_def
alternative_refl)
apply (simp add: get_index_def transform_cap_list_def throw_on_none_def
split_beta
split del: split_if)
apply (clarsimp simp: corres_whenE_throwError_split_rhs
corres_alternate2
split del: split_if)
apply (simp add: bindE_assoc[symmetric] split del: split_if)
apply (rule_tac r'="\<lambda>rv rv'. rv = transform_cap rv'"
in corres_alternative_throw_splitE)
apply (rule corres_guard_imp, rule corres_alternate1)
apply (rule corres_if)
apply (simp add: unat_eq_0)
apply (rule corres_trivial, simp add: returnOk_def)
apply (rule corres_splitEE[OF _ lookup_slot_for_cnode_op_corres])
apply clarsimp
apply (rule get_cap_corres)
apply simp+
apply (wp lsfco_not_idle | simp)+
apply (clarsimp simp: cte_wp_at_caps_of_state)
apply auto[1]
apply (rename_tac cnode_cap cnode_cap')
apply (simp add: bindE_assoc split del: split_if)
apply (simp add: if_to_top_of_bindE is_cnode_cap_transform_cap[symmetric]
split del: split_if)
apply (rule corres_if_rhs[rotated])
apply (rule corres_trivial, simp add: alternative_refl)
apply (simp add: corres_whenE_throwError_split_rhs
corres_alternate2)
apply (intro impI)
apply (rule_tac r'=dc in corres_alternative_throw_splitE[rotated])
apply (simp add:liftE_bindE)
apply (rule corres_symb_exec_r)
apply (clarsimp simp:corres_whenE_throwError_split_rhs corres_alternate2)
apply (rule corres_alternate1)
apply (simp add:gets_get)
apply (rule corres_underlying_gets_pre_lhs)
apply (rule_tac P' = "\<lambda>s. valid_mdb s \<and> cte_at slot' s \<and> is_cnode_cap cnode_cap' \<and>
cap_aligned cnode_cap' \<and> invs s \<and> not_idle_thread (obj_ref_of cnode_cap') s \<and>
free_index \<le> 2^sz \<and> is_aligned ptr sz \<and> sz < WordSetup.word_bits \<and>
(free_index = 0) = (descendants_of slot' (cdt s) ={} ) \<and> valid_etcbs s"
and P = "\<lambda>s. s = x" in corres_returnOk)
apply (simp add: translate_untyped_invocation_def transform_def get_free_ref_def)
apply (clarsimp simp: not_less)
apply (drule(4) range_cover_stuff)
apply (subst alignUp_plus)
apply (erule is_aligned_weaken)
apply (simp add:range_cover_def)
apply (simp add:has_children_def KHeap_D.is_cdt_parent_def
descendants_of_empty_lift word_neq_0_conv)
apply (subst alignUp_gt_0[where x = "2 ^ sz"])
apply (rule is_aligned_weaken[where x = sz])
apply (simp add:is_aligned_def)
apply (simp add:range_cover_def)
apply (simp add:range_cover_def)
apply (simp add: power_not_zero[where 'a=32, folded word_bits_def] range_cover_def)
apply (rule word_of_nat_le)
apply simp
apply (intro conjI)
apply (clarsimp simp:is_cap_simps cap_object_simps
transform_cslot_ptr_def bits_of_def
cap_aligned_def nat_bl_to_bin_nat_to_cref)
apply (subst of_nat_0)
apply (erule le_less_trans)
apply (clarsimp dest!:range_cover_sz_less')
apply simp
apply (wp check_free_index_wp)
apply simp
apply (simp add:const_on_failure_def)
apply clarsimp
apply wp
apply (clarsimp simp:conj_comms)
apply (wp mapME_x_inv_wp[OF hoare_pre(2)] | simp)+
apply (wp hoare_whenE_wp)
apply (simp add:validE_def split del:if_splits)
apply (rule_tac Q = "\<lambda>r. op = s" in hoare_strengthen_post)
apply wp
apply fastforce
apply (case_tac r,clarsimp+)
apply (rule corres_alternate1)
apply (rule corres_guard_imp)
apply (rule_tac F="cap_aligned cnode_cap' \<and> is_cnode_cap cnode_cap'" in corres_gen_asm2)
apply (subgoal_tac "map (Pair (cap_object (transform_cap cnode_cap')))
[unat w4 ..< unat w4 + unat w5]
= map (\<lambda>x. transform_cslot_ptr (obj_ref_of (cnode_cap'),
(nat_to_cref (bits_of cnode_cap') x)))
[unat w4 ..< unat w4 + unat w5]")
apply (simp del: map_eq_conv)
apply (simp add: mapME_x_map_simp)
apply (rule mapME_x_corres_inv)
apply (simp add: dc_def[symmetric])
apply (rule dcorres_ensure_empty)
apply (wp mapME_x_inv_wp[OF hoare_pre(2)] | simp)+
apply (clarsimp simp:is_cap_simps cap_object_simps
transform_cslot_ptr_def bits_of_def
cap_aligned_def nat_bl_to_bin_nat_to_cref)
apply simp
apply (clarsimp,intro conjI impI allI)
apply ((fastforce simp:invs_valid_idle)+)[5] (* sseefried; Brittle proof. Change number? *)
apply (rule hoare_pre)
apply (wp hoare_drop_imp | simp)+
apply fastforce
apply (clarsimp simp: conj_comms is_cnode_cap_transform_cap split del: split_if)
apply (rule validE_R_validE)
apply (rule_tac Q' = "\<lambda>a s. invs s \<and> valid_etcbs s \<and> valid_cap a s \<and> cte_wp_at (op = (cap.UntypedCap ptr sz idx)) slot' s
\<and> (Structures_A.is_cnode_cap a \<longrightarrow> not_idle_thread (obj_ref_of a) s)"
in hoare_post_imp_R)
apply (rule hoare_pre)
apply (wp get_cap_wp)
apply (rule_tac Q' = "\<lambda>a s. invs s \<and> valid_etcbs s \<and> cte_wp_at (op = (cap.UntypedCap ptr sz idx)) slot' s"
in hoare_post_imp_R)
apply wp
apply (clarsimp simp: cte_wp_at_caps_of_state)
apply (frule_tac p = "(x,y)" for x y in caps_of_state_valid[rotated])
apply simp
apply (clarsimp simp:valid_cap_def obj_at_def valid_idle_def pred_tcb_at_def
is_cap_simps not_idle_thread_def is_cap_table_def dest!:invs_valid_idle)
apply (clarsimp simp:valid_cap_def obj_at_def valid_idle_def pred_tcb_at_def
is_cap_simps not_idle_thread_def is_cap_table_def dest!:invs_valid_idle)
apply (clarsimp simp:invs_mdb cte_wp_at_caps_of_state valid_cap_aligned)
apply (frule(1) caps_of_state_valid)
apply (rule ccontr)
apply (clarsimp simp:valid_cap_simps cap_aligned_def)
apply (frule cte_wp_at_caps_descendants_range_inI[where ptr = ptr and cref = slot' and sz = sz])
apply (clarsimp simp:cte_wp_at_caps_of_state is_aligned_neg_mask_eq)
apply simp+
apply (simp add:is_aligned_neg_mask_eq)
apply (drule descendants_range_imply_no_descendants[rotated 3])
apply clarsimp+
apply (clarsimp simp:descendants_range_def2)
apply (clarsimp dest!:invs_mdb simp:valid_mdb_def)
apply simp
apply simp
apply (rule hoare_pre,wp,simp)
apply (wp hoare_drop_imp mapME_x_inv_wp2 | simp add:whenE_def split del:split_if)+
apply (rule hoare_pre,wp,simp)
done
lemma decode_untyped_label_not_match:
"\<lbrakk>Some intent = transform_intent (invocation_type label) args; \<forall>ui. intent \<noteq> UntypedIntent ui\<rbrakk>
\<Longrightarrow> \<lbrace>op = s\<rbrace> Decode_A.decode_untyped_invocation label args ref (cap.UntypedCap a b idx) e
\<lbrace>\<lambda>r. \<bottom>\<rbrace>, \<lbrace>\<lambda>e. op = s\<rbrace>"
apply (case_tac "invocation_type label = UntypedRetype")
apply (clarsimp simp:Decode_A.decode_untyped_invocation_def transform_intent_def)+
apply (clarsimp simp:transform_intent_untyped_retype_def split:option.splits list.splits)
apply (simp add:Decode_A.decode_untyped_invocation_def unlessE_def)
apply wp
done
end
Reference in New Issue View Git Blame Copy Permalink