213 lines
7.4 KiB
Plaintext
213 lines
7.4 KiB
Plaintext
(*
|
|
* Copyright 2014, General Dynamics C4 Systems
|
|
*
|
|
* This software may be distributed and modified according to the terms of
|
|
* the GNU General Public License version 2. Note that NO WARRANTY is provided.
|
|
* See "LICENSE_GPLv2.txt" for details.
|
|
*
|
|
* @TAG(GD_GPL)
|
|
*)
|
|
|
|
(*
|
|
Top level architecture related proofs.
|
|
*)
|
|
|
|
theory Arch_AI
|
|
imports "./$L4V_ARCH/ArchUntyped_AI" "./$L4V_ARCH/ArchFinalise_AI"
|
|
begin
|
|
|
|
declare detype_arch_state[simp]
|
|
|
|
lemma invs_strgs:
|
|
"invs s \<longrightarrow> valid_pspace s"
|
|
"invs s \<longrightarrow> valid_mdb s"
|
|
"invs s \<longrightarrow> valid_objs s"
|
|
"invs s \<longrightarrow> pspace_aligned s"
|
|
by auto
|
|
|
|
|
|
lemma assocs_dom_comp:
|
|
"set (map fst (filter (\<lambda>(x,y). P x \<and> y = None) (assocs f))) = (- dom f \<inter> Collect P)"
|
|
apply (clarsimp simp: in_assocs_is_fun)
|
|
apply (rule set_eqI)
|
|
apply clarsimp
|
|
apply (rule iffI, clarsimp)
|
|
apply (erule conjE)
|
|
apply (drule not_in_domD)
|
|
apply (rule_tac x="(x,None)" in image_eqI)
|
|
apply simp
|
|
apply simp
|
|
done
|
|
|
|
|
|
lemma assocs_empty_dom_comp:
|
|
"(- dom f \<inter> Collect P = {}) = null (filter (\<lambda>(x, y). P x \<and> y = None) (assocs f))"
|
|
apply (subst assocs_dom_comp [symmetric])
|
|
apply (subst empty_set_is_null)
|
|
apply (simp add: null_def)
|
|
done
|
|
|
|
|
|
lemma dom_hd_assocsD:
|
|
fixes P
|
|
defines "filter_assocs f \<equiv> filter (\<lambda>(x,y). P x \<and> y = None) (assocs f)"
|
|
assumes d: "- dom f \<inter> Collect P \<noteq> {}"
|
|
shows "fst (hd (filter_assocs f)) \<notin> dom f \<and> P (fst (hd (filter_assocs f)))"
|
|
proof -
|
|
from d have "\<not>null (filter_assocs f)"
|
|
unfolding filter_assocs_def
|
|
by (simp add: assocs_empty_dom_comp)
|
|
hence "hd (filter_assocs f) \<in> set (filter_assocs f)"
|
|
by (clarsimp simp: null_def neq_Nil_conv)
|
|
thus ?thesis
|
|
unfolding filter_assocs_def
|
|
by (clarsimp simp: in_assocs_is_fun)
|
|
qed
|
|
|
|
|
|
lemma ucast_assocs:
|
|
"len_of TYPE('a) < len_of TYPE('b) \<Longrightarrow>
|
|
assocs (fn o (ucast :: ('a :: len) word \<Rightarrow> ('b :: len) word))
|
|
= map (\<lambda>(x, y). (ucast x, y)) (filter (\<lambda>(x, y). x < 2 ^ len_of TYPE('a)) (assocs fn))"
|
|
apply (simp add: assocs_def enum_word_def
|
|
split_def filter_map)
|
|
apply (rule map_cong)
|
|
apply (simp add: o_def)
|
|
apply (rule trans [OF _ filter_cong [OF refl]],
|
|
rule sym, rule filter_to_shorter_upto)
|
|
apply simp
|
|
apply (rule iffI)
|
|
apply (subst word_unat_power, rule of_nat_mono_maybe)
|
|
apply simp
|
|
apply assumption
|
|
apply (simp add: word_less_nat_alt word_unat.Abs_inverse unats_def)
|
|
apply clarsimp
|
|
apply (simp add: word_less_nat_alt word_unat.Abs_inverse unats_def)
|
|
apply (simp add: ucast_of_nat_small)
|
|
done
|
|
|
|
|
|
lemma ucast_le_migrate:
|
|
fixes x :: "('a :: len) word"
|
|
fixes y :: "('b :: len) word"
|
|
shows
|
|
"\<lbrakk> y < 2 ^ (size x); size x < size y \<rbrakk> \<Longrightarrow>
|
|
(ucast x \<le> y) = (x \<le> ucast y)"
|
|
apply (simp add: word_le_def ucast_def)
|
|
apply (subst word_uint.Abs_inverse)
|
|
apply (simp add: uints_num word_size)
|
|
apply (rule order_less_le_trans, rule uint_lt2p)
|
|
apply simp
|
|
apply (subst word_uint.Abs_inverse)
|
|
apply (simp add: uints_num word_size word_less_alt
|
|
uint_2p_alt)
|
|
apply simp
|
|
done
|
|
|
|
|
|
lemma obj_at_delete_objects:
|
|
"\<lbrace>\<lambda>s. Q (obj_at (P (interrupt_irq_node s) (arch_state s)) r s) \<and>
|
|
r \<notin> {ptr..ptr + 2 ^ bits - 1}\<rbrace>
|
|
delete_objects ptr bits
|
|
\<lbrace>\<lambda>_ s. Q (obj_at (P (interrupt_irq_node s) (arch_state s)) r s)\<rbrace>"
|
|
apply (simp add: delete_objects_def do_machine_op_def split_def)
|
|
apply wp
|
|
apply (simp add: detype_machine_state_update_comm)
|
|
done
|
|
|
|
|
|
(* FIXME: move *)
|
|
crunch arch [wp]: retype_region "\<lambda>s. P (arch_state s)"
|
|
(simp: crunch_simps)
|
|
|
|
lemma set_free_index_final_cap:
|
|
"\<lbrace>\<lambda>s. P (is_final_cap' cap s) \<and> cte_wp_at (op = src_cap) src s\<rbrace>
|
|
set_cap (free_index_update f src_cap) src
|
|
\<lbrace>\<lambda>rv s. P (is_final_cap' cap s) \<rbrace>"
|
|
apply (simp add:is_final_cap'_def2)
|
|
apply (clarsimp simp:valid_def)
|
|
apply (drule set_cap_caps_of_state_monad)
|
|
apply (erule subst[rotated])
|
|
apply (rule_tac f = P in arg_cong)
|
|
apply (subgoal_tac "\<And>slot. (cte_wp_at (\<lambda>c. obj_irq_refs cap \<inter> obj_irq_refs c \<noteq> {}) slot s
|
|
= cte_wp_at (\<lambda>c. obj_irq_refs cap \<inter> obj_irq_refs c \<noteq> {}) slot b)")
|
|
apply simp
|
|
apply (clarsimp split:cap.splits
|
|
simp:cte_wp_at_caps_of_state free_index_update_def
|
|
obj_irq_refs_def)
|
|
done
|
|
|
|
lemma set_cap_orth:
|
|
"\<lbrace>\<lambda>s. P s \<and> Q cap' s\<rbrace> set_cap cap src \<lbrace>\<lambda>rv s. Q cap' s\<rbrace> \<Longrightarrow>
|
|
\<lbrace>\<lambda>s. P s \<and> src\<noteq> dest \<and> (cte_wp_at (op = cap') dest s \<longrightarrow> Q cap' s)\<rbrace>
|
|
set_cap cap src
|
|
\<lbrace>\<lambda>rv s. cte_wp_at (op = cap') dest s \<longrightarrow> Q cap' s\<rbrace>"
|
|
apply (clarsimp simp:valid_def cte_wp_at_caps_of_state)
|
|
apply (drule_tac x = s in spec)
|
|
apply (frule set_cap_caps_of_state_monad)
|
|
apply clarsimp
|
|
apply (drule(1) bspec)
|
|
apply clarsimp
|
|
done
|
|
|
|
|
|
lemma set_cap_empty_tables[wp]:
|
|
"\<lbrace>\<lambda>s. P (obj_at (empty_table (set (arm_global_pts (arch_state s)))) p s)\<rbrace>
|
|
set_cap cap cref
|
|
\<lbrace>\<lambda>rv s. P (obj_at (empty_table (set (arm_global_pts (arch_state s)))) p s)\<rbrace>"
|
|
apply (rule hoare_pre)
|
|
apply (rule hoare_use_eq [where f=arch_state, OF set_cap_arch])
|
|
apply (wp set_cap_obj_at_impossible)
|
|
apply (clarsimp simp: empty_table_caps_of)
|
|
done
|
|
|
|
lemma cte_wp_at_eq_to_op_eq:
|
|
"cte_wp_at (\<lambda>c. c = cap) = cte_wp_at (op = cap)"
|
|
by (simp add: cte_wp_at_caps_of_state fun_eq_iff)
|
|
|
|
|
|
lemma max_index_upd_caps_overlap_reserved:
|
|
"\<lbrace>\<lambda>s. invs s \<and> S \<subseteq> untyped_range cap \<and>
|
|
descendants_range_in S slot s \<and> cte_wp_at (op = cap) slot s \<and> is_untyped_cap cap\<rbrace>
|
|
set_cap (max_free_index_update cap) slot
|
|
\<lbrace>\<lambda>rv. caps_overlap_reserved S\<rbrace>"
|
|
apply (rule hoare_name_pre_state)
|
|
apply (clarsimp simp:is_cap_simps)
|
|
apply (wp set_untyped_cap_caps_overlap_reserved)
|
|
apply (auto simp:cte_wp_at_caps_of_state max_free_index_def)
|
|
done
|
|
|
|
|
|
lemma max_index_upd_invs_simple:
|
|
"\<lbrace>\<lambda>s. descendants_range_in (untyped_range cap) cref s \<and>
|
|
pspace_no_overlap_range_cover (obj_ref_of cap) (cap_bits cap) s \<and>
|
|
invs s \<and> cte_wp_at (op = cap) cref s \<and> is_untyped_cap cap\<rbrace>
|
|
set_cap (max_free_index_update cap) cref \<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
apply (rule hoare_name_pre_state)
|
|
apply (clarsimp simp:is_cap_simps)
|
|
apply (wp set_untyped_cap_invs_simple)
|
|
apply (auto simp:cte_wp_at_caps_of_state max_free_index_def)
|
|
done
|
|
|
|
|
|
lemma sts_pspace_no_overlap [wp]:
|
|
"\<lbrace>pspace_no_overlap S\<rbrace> set_thread_state t st \<lbrace>\<lambda>rv. pspace_no_overlap S\<rbrace>"
|
|
by (wp pspace_no_overlap_typ_at_lift)
|
|
|
|
lemma diminished_cte_wp_at_valid_cap:
|
|
"cte_wp_at (diminished c) p s \<Longrightarrow> valid_objs s \<Longrightarrow> s \<turnstile> c"
|
|
apply (drule(1) cte_wp_at_valid_objs_valid_cap)
|
|
apply (clarsimp simp: diminished_def)
|
|
done
|
|
|
|
lemma delete_objects_st_tcb_at:
|
|
"\<lbrace>pred_tcb_at proj P t and invs and K (t \<notin> {ptr .. ptr + 2 ^ bits - 1})\<rbrace>
|
|
delete_objects ptr bits
|
|
\<lbrace>\<lambda>y. pred_tcb_at proj P t\<rbrace>"
|
|
by (wp|simp add: delete_objects_def do_machine_op_def split_def)+
|
|
|
|
|
|
|
|
|
|
end
|