575 lines
25 KiB
Plaintext
575 lines
25 KiB
Plaintext
(*
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
|
*
|
|
* SPDX-License-Identifier: GPL-2.0-only
|
|
*)
|
|
|
|
theory Retype_IF
|
|
imports ArchCNode_IF
|
|
begin
|
|
|
|
lemma create_cap_reads_respects:
|
|
"reads_respects aag l (K (is_subject aag (fst (fst slot))))
|
|
(create_cap type bits untyped dev slot)"
|
|
apply (rule gen_asm_ev)
|
|
apply (simp add: create_cap_def split_def bind_assoc[symmetric])
|
|
apply (fold update_cdt_def)
|
|
apply (simp add: bind_assoc create_cap_ext_def)
|
|
apply (wp set_cap_reads_respects set_original_reads_respects
|
|
update_cdt_list_reads_respects update_cdt_reads_respects
|
|
| simp | fastforce simp: equiv_for_def split: option.splits)+
|
|
apply (intro impI conjI allI)
|
|
by (fastforce simp: reads_equiv_def2 equiv_for_def
|
|
elim: states_equiv_forE_is_original_cap states_equiv_forE_cdt
|
|
dest: aag_can_read_self
|
|
split: option.splits)+
|
|
|
|
lemma gets_any_evrv:
|
|
"equiv_valid_rv_inv I A \<top>\<top> \<top> (gets f)"
|
|
by (clarsimp simp: equiv_valid_2_def in_monad)
|
|
|
|
lemma select_f_any_evrv:
|
|
"equiv_valid_rv_inv I A \<top>\<top> \<top> (select_f f)"
|
|
by (clarsimp simp: equiv_valid_2_def select_f_def)
|
|
|
|
lemma select_f_any_ev2:
|
|
"equiv_valid_2 I A A \<top>\<top> \<top> \<top> (select_f f) (select_f f')"
|
|
by (clarsimp simp: equiv_valid_2_def select_f_def)
|
|
|
|
lemma machine_op_lift_ev':
|
|
"equiv_valid_inv I A
|
|
(K (\<forall>s t x y. (I s t \<longrightarrow> I (s\<lparr>machine_state_rest := x\<rparr>) (t\<lparr>machine_state_rest := y\<rparr>)) \<and>
|
|
(A s t \<longrightarrow> A (s\<lparr>machine_state_rest := x\<rparr>) (t\<lparr>machine_state_rest := y\<rparr>))))
|
|
(machine_op_lift mop)"
|
|
unfolding machine_op_lift_def comp_def machine_rest_lift_def
|
|
apply (rule gen_asm_ev)
|
|
apply (simp add: equiv_valid_def2)
|
|
apply (rule equiv_valid_rv_bind)
|
|
apply (rule gets_any_evrv)
|
|
apply (rule_tac R'="\<top>\<top>" and Q="\<top>\<top>" and Q'="\<top>\<top>" in equiv_valid_2_bind_pre)
|
|
apply (simp add: split_def)
|
|
apply (rule modify_ev2)
|
|
apply fastforce
|
|
apply (rule select_f_any_ev2)
|
|
apply wpsimp+
|
|
done
|
|
|
|
lemma equiv_machine_state_machine_state_rest_update:
|
|
"equiv_machine_state P s t
|
|
\<Longrightarrow> equiv_machine_state P (s\<lparr>machine_state_rest := x\<rparr>) (t\<lparr>machine_state_rest := y\<rparr>)"
|
|
by (fastforce intro: equiv_forI elim: equiv_forE)
|
|
|
|
lemma machine_op_lift_ev:
|
|
"equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) \<top> (machine_op_lift mop)"
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (rule machine_op_lift_ev')
|
|
apply clarsimp
|
|
apply (intro conjI impI)
|
|
apply (drule equiv_machine_state_machine_state_rest_update, fastforce)+
|
|
done
|
|
|
|
lemma machine_op_lift_irq_state[wp]:
|
|
"machine_op_lift mop \<lbrace>\<lambda>ms. P (irq_state ms)\<rbrace>"
|
|
by (simp add: machine_op_lift_def machine_rest_lift_def | wp | wpc)+
|
|
|
|
lemma dmo_mol_reads_respects:
|
|
"reads_respects aag l \<top> (do_machine_op (machine_op_lift mop))"
|
|
apply (rule use_spec_ev)
|
|
apply (rule do_machine_op_spec_reads_respects)
|
|
apply (rule equiv_valid_guard_imp[OF machine_op_lift_ev])
|
|
apply simp
|
|
apply wp
|
|
done
|
|
|
|
lemma dmo_bind_ev:
|
|
"equiv_valid_inv I A P (do_machine_op (a >>= b)) =
|
|
equiv_valid_inv I A P (do_machine_op a >>= (\<lambda>rv. do_machine_op (b rv)))"
|
|
by (fastforce simp: do_machine_op_def gets_def get_def select_f_def modify_def
|
|
put_def return_def bind_def equiv_valid_def2 equiv_valid_2_def)
|
|
|
|
lemma dmo_bind_ev':
|
|
"equiv_valid_inv I A P (a >>= (\<lambda>rv. do_machine_op (b rv >>= c rv))) =
|
|
equiv_valid_inv I A P (a >>= (\<lambda>rv. do_machine_op (b rv) >>= (\<lambda>rv'. do_machine_op (c rv rv'))))"
|
|
by (fastforce simp: do_machine_op_def gets_def get_def select_f_def modify_def
|
|
put_def return_def bind_def equiv_valid_def2 equiv_valid_2_def)
|
|
|
|
lemma dmo_mapM_ev_pre:
|
|
assumes reads_res: "\<And>x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (do_machine_op (m x))"
|
|
assumes invariant: "\<And>x. x \<in> set lst \<Longrightarrow> do_machine_op (m x) \<lbrace>I\<rbrace>"
|
|
assumes inv_established: "\<And>s. P s \<Longrightarrow> I s"
|
|
shows "equiv_valid_inv D A P (do_machine_op (mapM m lst))"
|
|
using assms
|
|
apply atomize
|
|
apply (rule_tac Q=I in equiv_valid_guard_imp)
|
|
apply (induct lst)
|
|
apply (simp add: mapM_Nil return_ev_pre)
|
|
apply (subst mapM_Cons)
|
|
apply (simp add: dmo_bind_ev dmo_bind_ev')
|
|
apply (rule bind_ev_pre[where P''="I"])
|
|
apply (rule bind_ev[OF return_ev])
|
|
apply fastforce
|
|
apply (rule wp_post_taut)
|
|
apply fastforce+
|
|
done
|
|
|
|
lemma dmo_mapM_x_ev_pre:
|
|
assumes reads_res: "\<And>x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (do_machine_op (m x))"
|
|
assumes invariant: "\<And>x. x \<in> set lst \<Longrightarrow> do_machine_op (m x) \<lbrace>I\<rbrace>"
|
|
assumes inv_established: "\<And>s. P s \<Longrightarrow> I s"
|
|
shows "equiv_valid_inv D A P (do_machine_op (mapM_x m lst))"
|
|
apply (subst mapM_x_mapM)
|
|
apply (simp add: dmo_bind_ev)
|
|
apply (rule bind_ev_pre[OF return_ev dmo_mapM_ev_pre])
|
|
by (blast intro: reads_res invariant inv_established wp_post_taut)+
|
|
|
|
lemma dmo_mapM_ev:
|
|
assumes reads_res: "\<And>x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (do_machine_op (m x))"
|
|
assumes invariant: "\<And>x. x \<in> set lst \<Longrightarrow> \<lbrace>I\<rbrace> do_machine_op (m x) \<lbrace>\<lambda>_. I\<rbrace>"
|
|
shows "equiv_valid_inv D A I (do_machine_op (mapM m lst))"
|
|
using assms by (auto intro: dmo_mapM_ev_pre)
|
|
|
|
lemma dmo_mapM_x_ev:
|
|
assumes reads_res: "\<And>x. x \<in> set lst \<Longrightarrow> equiv_valid_inv D A I (do_machine_op (m x))"
|
|
assumes invariant: "\<And>x. x \<in> set lst \<Longrightarrow> \<lbrace>I\<rbrace> do_machine_op (m x) \<lbrace>\<lambda>_. I\<rbrace>"
|
|
shows "equiv_valid_inv D A I (do_machine_op (mapM_x m lst))"
|
|
using assms by (auto intro: dmo_mapM_x_ev_pre)
|
|
|
|
|
|
locale Retype_IF_1 =
|
|
assumes clearMemory_ev:
|
|
"equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) \<top> (clearMemory ptr bits)"
|
|
and freeMemory_ev:
|
|
"equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) \<top> (freeMemory ptr bits)"
|
|
and no_irq_freeMemory:
|
|
"no_irq (freeMemory ptr sz)"
|
|
and equiv_asid_detype:
|
|
"equiv_asid asid s s' \<Longrightarrow> equiv_asid asid (detype N s) (detype N s')"
|
|
and clearMemory_irq_state[wp]:
|
|
"\<And>P. clearMemory ptr bits \<lbrace>\<lambda>s. P (irq_state s)\<rbrace>"
|
|
and freeMemory_irq_state[wp]:
|
|
"\<And>P. freeMemory ptr bits \<lbrace>\<lambda>s. P (irq_state s)\<rbrace>"
|
|
and dmo_clearMemory_globals_equiv:
|
|
"do_machine_op (clearMemory ptr (2 ^ bits)) \<lbrace>globals_equiv s\<rbrace>"
|
|
and dmo_freeMemory_globals_equiv:
|
|
"do_machine_op (freeMemory ptr bits) \<lbrace>globals_equiv s\<rbrace>"
|
|
and retype_region_globals_equiv:
|
|
"\<lbrace>globals_equiv s and invs
|
|
and (\<lambda>s. \<exists>i. cte_wp_at (\<lambda>c. c = UntypedCap dev (p && ~~ mask sz) sz i) slot s \<and>
|
|
(i \<le> unat (p && mask sz) \<or> pspace_no_overlap_range_cover p sz s))
|
|
and K (range_cover p sz (obj_bits_api type o_bits) num \<and> 0 < num)\<rbrace>
|
|
retype_region p num o_bits type dev
|
|
\<lbrace>\<lambda>_. globals_equiv s\<rbrace>"
|
|
begin
|
|
|
|
lemma dmo_clearMemory_reads_respects:
|
|
"reads_respects aag l \<top> (do_machine_op (clearMemory ptr bits))"
|
|
apply (rule use_spec_ev)
|
|
apply (rule do_machine_op_spec_reads_respects)
|
|
apply (rule equiv_valid_guard_imp[OF clearMemory_ev], rule TrueI)
|
|
apply wp
|
|
done
|
|
|
|
lemma dmo_freeMemory_reads_respects:
|
|
"reads_respects aag l \<top> (do_machine_op (freeMemory ptr bits))"
|
|
apply (rule use_spec_ev)
|
|
apply (rule do_machine_op_spec_reads_respects)
|
|
apply (rule equiv_valid_guard_imp[OF freeMemory_ev], rule TrueI)
|
|
apply wp
|
|
done
|
|
|
|
lemma dmo_clearMemory_reads_respects_g:
|
|
"reads_respects_g aag l \<top> (do_machine_op (clearMemory ptr (2 ^bits)))"
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (rule reads_respects_g)
|
|
apply (rule dmo_clearMemory_reads_respects)
|
|
apply (rule doesnt_touch_globalsI[where P = \<top>, simplified, OF dmo_clearMemory_globals_equiv])
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma dmo_freeMemory_reads_respects_g:
|
|
"reads_respects_g aag l (\<lambda> s. is_aligned ptr bits \<and> 2 \<le> bits \<and> bits < word_bits)
|
|
(do_machine_op (freeMemory ptr bits))"
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (rule reads_respects_g)
|
|
apply (rule dmo_freeMemory_reads_respects)
|
|
apply (rule doesnt_touch_globalsI[where P = \<top>, simplified, OF dmo_freeMemory_globals_equiv])
|
|
apply clarsimp
|
|
done
|
|
|
|
end
|
|
|
|
|
|
lemma globals_equiv_cdt_update[simp]:
|
|
"globals_equiv s (s'\<lparr>cdt := x\<rparr>) = globals_equiv s s'"
|
|
by (fastforce simp: globals_equiv_def idle_equiv_def)
|
|
|
|
lemma globals_equiv_is_original_cap_update[simp]:
|
|
"globals_equiv s (s'\<lparr>is_original_cap := x\<rparr>) = globals_equiv s s'"
|
|
by (fastforce simp: globals_equiv_def idle_equiv_def)
|
|
|
|
lemma create_cap_globals_equiv:
|
|
"\<lbrace>globals_equiv s and valid_global_objs and valid_arch_state\<rbrace>
|
|
create_cap type bits untyped dev slot
|
|
\<lbrace>\<lambda>_. globals_equiv s\<rbrace>"
|
|
apply (simp only: create_cap_def split_def)
|
|
apply (wp set_cap_globals_equiv set_original_globals_equiv set_cdt_globals_equiv
|
|
set_cdt_valid_global_objs dxo_wp_weak set_original_wp | simp)+
|
|
done
|
|
|
|
abbreviation reads_equiv_valid_g_inv where
|
|
"reads_equiv_valid_g_inv A aag P f \<equiv> equiv_valid_inv (reads_equiv_g aag) A P f"
|
|
|
|
lemma gets_apply_ev':
|
|
"\<forall>s t. I s t \<and> A s t \<and> P s \<and> P t \<longrightarrow> (f s) x = (f t) x
|
|
\<Longrightarrow> equiv_valid I A A P (gets_apply f x)"
|
|
by (clarsimp simp: gets_apply_def get_def bind_def return_def equiv_valid_def2 equiv_valid_2_def)
|
|
|
|
lemma do_machine_op_globals_equiv:
|
|
"(\<And>s sa. \<lbrakk> P sa; globals_equiv s sa \<rbrakk>
|
|
\<Longrightarrow> \<forall>x\<in>fst (f (machine_state sa)). globals_equiv s (sa\<lparr>machine_state := snd x\<rparr>))
|
|
\<Longrightarrow> \<lbrace>globals_equiv s and P\<rbrace>
|
|
do_machine_op f
|
|
\<lbrace>\<lambda>_. globals_equiv s\<rbrace>"
|
|
unfolding do_machine_op_def
|
|
apply (wp | simp add: split_def)+
|
|
done
|
|
|
|
lemma ptr_range_memE:
|
|
"\<lbrakk> x \<in> ptr_range ptr bits; \<lbrakk> ptr \<le> x; x \<le> ptr + 2 ^ bits - 1 \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
|
|
by (clarsimp simp: ptr_range_def)
|
|
|
|
lemma is_aligned_word_size_bits_upto_enum_step_mem:
|
|
fixes ptr :: obj_ref
|
|
shows "\<lbrakk> is_aligned ptr bits; word_size_bits \<le> bits; bits < word_bits;
|
|
x \<in> set [ptr, ptr + word_size .e. ptr + 2 ^ bits - 1] \<rbrakk>
|
|
\<Longrightarrow> is_aligned x word_size_bits"
|
|
apply (clarsimp simp: word_size_size_bits_word[symmetric])
|
|
apply (subst (asm) upto_enum_step_shift_red; (fastforce simp: word_bits_def)?)
|
|
apply clarsimp
|
|
apply (erule aligned_add_aligned)
|
|
apply (rule is_alignedI)
|
|
apply (simp add: mult.commute)
|
|
apply (simp add: word_bits_conv)
|
|
done
|
|
|
|
(* TODO: cleanup this beautiful proof *)
|
|
lemma ptr_range_subset:
|
|
fixes ptr :: obj_ref
|
|
shows "\<lbrakk> is_aligned ptr bits; word_size_bits \<le> bits; bits < word_bits;
|
|
x \<in> set [ptr , ptr + word_size .e. ptr + 2 ^ bits - 1] \<rbrakk>
|
|
\<Longrightarrow> ptr_range x word_size_bits \<subseteq> ptr_range ptr bits"
|
|
apply (frule is_aligned_word_size_bits_upto_enum_step_mem, assumption+)
|
|
apply (rule subsetI)
|
|
apply (clarsimp simp: word_size_size_bits_word[symmetric])
|
|
apply (subst (asm) upto_enum_step_shift_red; (fastforce simp: word_bits_def)?)
|
|
apply (subst ptr_range_def)
|
|
apply (clarsimp)
|
|
apply (erule ptr_range_memE)
|
|
apply (rule conjI)
|
|
apply (erule order_trans[rotated])
|
|
apply (erule is_aligned_no_wrap')
|
|
apply (rule word_less_power_trans2[where k=word_size_bits, simplified];
|
|
fastforce elim: of_nat_power simp: word_bits_conv word_bits_def)
|
|
apply (erule order_trans)
|
|
apply (clarsimp simp: word_size_size_bits_word)
|
|
apply (subgoal_tac "ptr + of_nat xaa * word_size + word_size - 1 =
|
|
ptr + ((2 ^ word_size_bits - 1) + of_nat xaa * word_size)")
|
|
apply (subgoal_tac "ptr + 2 ^ bits - 1 = ptr + (2 ^ bits - 1)")
|
|
apply (erule ssubst)+
|
|
apply (rule word_plus_mono_right)
|
|
apply (drule is_aligned_addD1)
|
|
apply (erule (1) is_aligned_weaken)
|
|
prefer 2
|
|
apply (erule is_aligned_no_wrap')
|
|
apply simp
|
|
apply (simp_all add: word_size_size_bits_word)
|
|
apply (drule (1) word_less_power_trans_ofnat[where 'a=machine_word_len], simp add: word_bits_def)
|
|
apply (subst add.commute)
|
|
apply (erule is_aligned_add_less_t2n)
|
|
apply (simp_all add: word_size_size_bits_word)
|
|
using zero_less_word_size gt0_iff_gem1 by blast
|
|
|
|
lemma do_machine_op_mapM_x:
|
|
assumes ef: "\<And>a. empty_fail (f a)"
|
|
shows "do_machine_op (mapM_x f xs) = mapM_x (\<lambda> x. do_machine_op (f x)) xs"
|
|
apply (induct xs)
|
|
apply (simp add: mapM_x_Nil)
|
|
apply (clarsimp simp: mapM_x_Cons do_machine_op_bind[OF ef empty_fail_mapM_x[OF ef]])
|
|
done
|
|
|
|
lemma create_cap_reads_respects_g:
|
|
"reads_respects_g aag l
|
|
(K (is_subject aag (fst (fst slot))) and valid_global_objs and valid_arch_state)
|
|
(create_cap type bits untyped dev slot)"
|
|
apply (rule equiv_valid_guard_imp[OF reads_respects_g])
|
|
apply (rule create_cap_reads_respects)
|
|
apply (wp doesnt_touch_globalsI create_cap_globals_equiv | simp)+
|
|
done
|
|
|
|
lemma retype_region_ext_def2:
|
|
"retype_region_ext a b =
|
|
modify (\<lambda>s. ekheap_update (\<lambda>ekh x. if x \<in> set a then default_ext b (cur_domain s) else ekh x) s)"
|
|
by (simp add: retype_region_ext_def foldr_upd_app_if' gets_def bind_def
|
|
return_def modify_def get_def put_def fun_eq_iff)
|
|
|
|
lemma retype_region_reads_respects:
|
|
"reads_respects aag l \<top> (retype_region ptr num_objects o_bits type dev)"
|
|
apply (simp only: retype_region_def retype_addrs_def foldr_upd_app_if fun_app_def
|
|
K_bind_def when_def retype_region_ext_extended.dxo_eq)
|
|
apply (simp only: retype_region_ext_def2)
|
|
apply (simp split del: if_split add: equiv_valid_def2)
|
|
apply (rule_tac W="\<top>\<top>" and Q="\<top>\<top>" in equiv_valid_rv_bind)
|
|
apply (rule equiv_valid_rv_guard_imp[OF if_evrv])
|
|
apply (rule equiv_valid_rv_bind[OF gets_kheap_revrv])
|
|
apply simp
|
|
apply (rule_tac Q="\<lambda>_ s. rv = kheap s" and Q'="\<lambda>_ s. rv' = kheap s" and R'="(=)"
|
|
in equiv_valid_2_bind_pre)
|
|
apply (rule modify_ev2)
|
|
apply (fastforce elim: reads_equiv_identical_kheap_updates
|
|
affects_equiv_identical_kheap_updates
|
|
simp: identical_kheap_updates_def)
|
|
apply (rule_tac P=\<top> and P'=\<top> in modify_ev2)
|
|
apply (fastforce intro: reads_equiv_identical_ekheap_updates
|
|
affects_equiv_identical_ekheap_updates
|
|
simp: identical_updates_def default_ext_def reads_equiv_def)
|
|
apply (wp | simp)+
|
|
apply (rule return_ev2 | simp | rule impI, rule TrueI)+
|
|
apply (intro impI, wp)
|
|
done
|
|
|
|
lemma subset_thing:
|
|
"\<lbrakk> a \<le> b; a \<le> a \<rbrakk> \<Longrightarrow> {a} \<subseteq> {a..b}"
|
|
by auto
|
|
|
|
lemma updates_not_idle:
|
|
"\<lbrakk> idle_equiv st s; \<forall>a \<in> S. a \<noteq> idle_thread s \<rbrakk>
|
|
\<Longrightarrow> idle_equiv st (s\<lparr>kheap := \<lambda>a. if a \<in> S then y else kheap s a\<rparr>)"
|
|
by (fastforce simp: idle_equiv_def tcb_at_def2)
|
|
|
|
lemma post_retype_invs_valid_arch_stateI:
|
|
"post_retype_invs ty rv s \<Longrightarrow> valid_arch_state s"
|
|
by (clarsimp simp: post_retype_invs_def invs_def valid_state_def split: if_split_asm)
|
|
|
|
lemma post_retype_invs_pspace_alignedI:
|
|
"post_retype_invs ty rv s \<Longrightarrow> pspace_aligned s"
|
|
by (clarsimp simp: post_retype_invs_def invs_def valid_state_def split: if_split_asm)
|
|
|
|
lemma detype_def2:
|
|
"detype S (s :: det_state) = s\<lparr>kheap := \<lambda>x. if x \<in> S then None else kheap s x,
|
|
ekheap := \<lambda>x. if x \<in> S then None else ekheap s x\<rparr>"
|
|
by (simp add: detype_def detype_ext_def)
|
|
|
|
lemma cur_thread_detype:
|
|
"cur_thread (detype S s) = cur_thread s"
|
|
by (auto simp: detype_def)
|
|
|
|
lemma cur_domain_detype:
|
|
"cur_domain (detype S s) = cur_domain s"
|
|
by (auto simp: detype_def detype_ext_def)
|
|
|
|
lemma sched_act_detype:
|
|
"scheduler_action (detype S s) = scheduler_action s"
|
|
by (auto simp: detype_def detype_ext_def)
|
|
|
|
lemma wuc_detype:
|
|
"work_units_completed (detype S s) = work_units_completed s"
|
|
by (auto simp: detype_def detype_ext_def)
|
|
|
|
lemma machine_state_detype:
|
|
"machine_state (detype S s) = machine_state s"
|
|
by (auto simp: detype_def detype_ext_def)
|
|
|
|
|
|
context Retype_IF_1 begin
|
|
|
|
lemma retype_region_reads_respects_g:
|
|
"reads_respects_g aag l
|
|
((\<lambda>s. \<exists>idx. cte_wp_at (\<lambda>c. c = UntypedCap dev (ptr && ~~ mask sz) sz idx) slot s \<and>
|
|
(idx \<le> unat (ptr && mask sz) \<or> pspace_no_overlap_range_cover ptr sz s)) and
|
|
invs and K (range_cover ptr sz (obj_bits_api type o_bits) num_objects \<and> 0 < num_objects))
|
|
(retype_region ptr num_objects o_bits type dev)"
|
|
apply (rule equiv_valid_guard_imp[OF reads_respects_g[OF retype_region_reads_respects]])
|
|
apply (rule doesnt_touch_globalsI)
|
|
apply (rule hoare_weaken_pre[OF retype_region_globals_equiv])
|
|
apply simp
|
|
apply auto
|
|
done
|
|
|
|
lemma states_equiv_for_detype:
|
|
"states_equiv_for P Q R S s s' \<Longrightarrow> states_equiv_for P Q R S (detype N s) (detype N s')"
|
|
apply (simp add: states_equiv_for_def equiv_for_def equiv_asids_def obj_at_def equiv_asid_detype)
|
|
apply (simp add: detype_def detype_ext_def)
|
|
done
|
|
|
|
lemma detype_reads_respects:
|
|
"reads_respects aag l \<top> (modify (detype S))"
|
|
apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def in_monad reads_equiv_def2 affects_equiv_def2)
|
|
apply (simp add: cur_domain_detype cur_thread_detype sched_act_detype wuc_detype machine_state_detype)
|
|
apply (fastforce intro: states_equiv_for_detype)
|
|
done
|
|
|
|
crunch irq_masks[wp]: delete_objects "\<lambda>s. P (irq_masks (machine_state s))"
|
|
(ignore: do_machine_op wp: dmo_wp no_irq_freeMemory no_irq simp: detype_def)
|
|
|
|
end
|
|
|
|
|
|
lemma untyped_caps_do_not_overlap_global_refs:
|
|
"\<lbrakk> cte_wp_at ((=) (UntypedCap dev word sz idx)) slot s; valid_global_refs s \<rbrakk>
|
|
\<Longrightarrow> ptr_range word sz \<inter> global_refs s = {}"
|
|
apply (simp add: cte_wp_at_caps_of_state)
|
|
apply (drule (1) valid_global_refsD2)
|
|
apply (fastforce simp: cap_range_def ptr_range_def)
|
|
done
|
|
|
|
lemma singleton_set_size:
|
|
"{ptr..(ptr::'a::len word) + 2 ^ 0 - 1} = {ptr}"
|
|
by (simp add: field_simps)
|
|
|
|
lemma cap_range_of_valid_capD:
|
|
"valid_cap cap s \<Longrightarrow> (cap_range cap = {}) \<or> (\<exists>ptr sz. (cap_range cap = ptr_range ptr sz))"
|
|
apply (rule disj_subst)
|
|
apply (cases cap)
|
|
by (clarsimp simp: valid_cap_def valid_untyped_def cap_aligned_def cap_range_def ptr_range_def
|
|
| intro exI | rule singleton_set_size[symmetric] | fastforce)+
|
|
|
|
lemma set_cap_reads_respects_g:
|
|
"reads_respects_g aag l (valid_global_objs and valid_arch_state
|
|
and K (is_subject aag (fst slot))) (set_cap cap slot)"
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (rule reads_respects_g[OF set_cap_reads_respects])
|
|
apply (wp doesnt_touch_globalsI set_cap_globals_equiv | simp)+
|
|
done
|
|
|
|
(*FIXME move*)
|
|
lemma when_ev:
|
|
"(C \<Longrightarrow> equiv_valid I A A P handle) \<Longrightarrow> equiv_valid I A A (\<lambda>s. C \<longrightarrow> P s) (when C handle)"
|
|
by (wp | auto simp: when_def)+
|
|
|
|
lemma delete_objects_caps_no_overlap:
|
|
"\<lbrace>invs and ct_active and (\<lambda>s. \<exists>slot idx. cte_wp_at ((=) (UntypedCap dev ptr sz idx)) slot s \<and>
|
|
descendants_range_in {ptr..ptr + 2 ^ sz - 1} slot s)\<rbrace>
|
|
delete_objects ptr sz
|
|
\<lbrace>\<lambda>_ s :: det_ext state. caps_no_overlap ptr sz s\<rbrace>"
|
|
apply (clarsimp simp: valid_def)
|
|
apply (rule descendants_range_caps_no_overlapI)
|
|
apply (erule use_valid | wp | simp add: descendants_range_def2 | blast)+
|
|
apply (frule untyped_cap_aligned,
|
|
(simp add: invs_valid_objs)+)
|
|
apply (rule conjI, assumption)
|
|
apply (drule (2) untyped_slots_not_in_untyped_range, simp+, rule subset_refl)
|
|
apply simp
|
|
apply (erule use_valid | wp delete_objects_descendants_range_in | simp | blast)+
|
|
done
|
|
|
|
lemma get_cap_reads_respects_g:
|
|
"reads_respects_g aag l (K (is_subject aag (fst slot))) (get_cap slot)"
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (rule reads_respects_g[OF get_cap_rev])
|
|
apply (rule doesnt_touch_globalsI)
|
|
apply wp
|
|
apply clarsimp
|
|
apply simp
|
|
done
|
|
|
|
lemma irq_state_independent_globals_equiv[simp,intro!]:
|
|
"irq_state_independent_A (globals_equiv st)"
|
|
by (clarsimp simp: irq_state_independent_A_def globals_equiv_def idle_equiv_def)
|
|
|
|
lemma irq_state_independent_A_only_timer_irq_inv[simp]:
|
|
"irq_state_independent_A (only_timer_irq_inv irq st)"
|
|
apply (simp add: only_timer_irq_inv_def)
|
|
apply (rule irq_state_independent_A_conjI)
|
|
apply (simp add: domain_sep_inv_def)
|
|
apply (simp add: irq_state_independent_A_def only_timer_irq_def
|
|
irq_is_recurring_def is_irq_at_def)
|
|
done
|
|
|
|
lemma only_timer_irq_inv_work_units_completed[simp]:
|
|
"only_timer_irq_inv irq st (work_units_completed_update f s)
|
|
= only_timer_irq_inv irq st s"
|
|
apply (simp add: only_timer_irq_inv_def)
|
|
apply (simp add: domain_sep_inv_def)
|
|
apply (simp add: irq_state_independent_A_def only_timer_irq_def
|
|
irq_is_recurring_def is_irq_at_def)
|
|
done
|
|
|
|
lemma delete_objects_pspace_no_overlap_again:
|
|
"\<lbrace>pspace_aligned and valid_objs and (\<lambda>s. \<exists>slot. cte_wp_at (\<lambda>cp. is_untyped_cap cp \<and>
|
|
obj_ref_of cp = ptr \<and>
|
|
bits_of cp = sz) slot s)
|
|
and K (S \<subseteq> {ptr .. ptr + 2 ^ sz - 1})\<rbrace>
|
|
delete_objects ptr sz
|
|
\<lbrace>\<lambda>_. pspace_no_overlap S\<rbrace>"
|
|
unfolding delete_objects_def do_machine_op_def
|
|
apply (wp | simp add: split_def detype_machine_state_update_comm)+
|
|
apply (clarsimp simp: cte_wp_at_caps_of_state is_cap_simps bits_of_def)
|
|
apply (drule caps_of_state_cteD)
|
|
apply (frule cte_wp_at_valid_objs_valid_cap, clarsimp+)
|
|
apply (erule pspace_no_overlap_subset[rotated])
|
|
apply (rule pspace_no_overlap_subset, rule pspace_no_overlap_detype, simp+)
|
|
apply (simp add: valid_cap_simps cap_aligned_def field_simps)
|
|
done
|
|
|
|
lemma ex_tupleI:
|
|
"P (fst t) (snd t) \<Longrightarrow> \<exists>a b. P a b"
|
|
by blast
|
|
|
|
lemma equiv_valid_obtain:
|
|
assumes fn_eq: "\<And>s t. I s t \<Longrightarrow> A s t \<Longrightarrow> P s \<Longrightarrow> P t \<Longrightarrow> fn s = fn t"
|
|
assumes pr: "\<And>x. equiv_valid I A B (P and (\<lambda>s. fn s = x)) f"
|
|
shows "equiv_valid I A B P f"
|
|
apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def)
|
|
apply (frule(1) fn_eq, simp+)
|
|
apply (cut_tac x="fn s" in pr)
|
|
apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def)
|
|
apply fastforce
|
|
done
|
|
|
|
lemma reads_equiv_cte_wp_at:
|
|
"\<lbrakk> reads_equiv aag s s'; is_subject aag (fst slot) \<rbrakk>
|
|
\<Longrightarrow> cte_wp_at P slot s = cte_wp_at P slot s'"
|
|
apply (frule(1) is_subject_kheap_eq)
|
|
apply (simp add: cte_wp_at_cases)
|
|
done
|
|
|
|
lemma reads_equiv_caps_of_state:
|
|
"\<lbrakk> reads_equiv aag s s'; is_subject aag (fst slot) \<rbrakk>
|
|
\<Longrightarrow> caps_of_state s slot = caps_of_state s' slot"
|
|
apply (frule(1) reads_equiv_cte_wp_at[where P="(=) (the (caps_of_state s slot))"])
|
|
apply (frule(1) reads_equiv_cte_wp_at[where P="\<top>"])
|
|
apply (auto simp: cte_wp_at_caps_of_state)
|
|
done
|
|
|
|
|
|
locale Retype_IF_2 = Retype_IF_1 +
|
|
fixes aag :: "'a subject_label PAS"
|
|
assumes invoke_untyped_reads_respects_g_wcap:
|
|
"reads_respects_g aag l (invs and valid_untyped_inv_wcap ui (Some (UntypedCap dev ptr sz idx))
|
|
and only_timer_irq_inv irq st
|
|
and ct_active and pas_refined aag
|
|
and K (authorised_untyped_inv aag ui)) (invoke_untyped ui)"
|
|
begin
|
|
|
|
lemma invoke_untyped_reads_respects_g:
|
|
"reads_respects_g aag l (invs and valid_untyped_inv ui and only_timer_irq_inv irq st
|
|
and ct_active and pas_refined aag
|
|
and K (authorised_untyped_inv aag ui)) (invoke_untyped ui)"
|
|
apply (rule_tac fn="\<lambda>s. caps_of_state s (slot_of_untyped_inv ui)" in equiv_valid_obtain)
|
|
apply (cases ui, clarsimp simp: valid_untyped_inv_wcap reads_equiv_g_def)
|
|
apply (simp add: authorised_untyped_inv_def
|
|
reads_equiv_caps_of_state)
|
|
apply (case_tac "x \<noteq> None \<and> is_untyped_cap (the x)")
|
|
apply (clarsimp simp: is_cap_simps)
|
|
apply (rule equiv_valid_guard_imp, rule invoke_untyped_reads_respects_g_wcap)
|
|
apply (cases ui, clarsimp simp: cte_wp_at_caps_of_state valid_untyped_inv_wcap)
|
|
apply auto[1]
|
|
apply (rule equiv_valid_guard_imp, rule gen_asm_ev'[where Q=False])
|
|
apply simp
|
|
apply (cases ui, clarsimp simp: valid_untyped_inv_wcap cte_wp_at_caps_of_state)
|
|
done
|
|
|
|
end
|
|
|
|
end
|