1220 lines
52 KiB
Plaintext
1220 lines
52 KiB
Plaintext
(*
|
|
* Copyright 2014, General Dynamics C4 Systems
|
|
*
|
|
* SPDX-License-Identifier: GPL-2.0-only
|
|
*)
|
|
|
|
theory IpcCancel_AI
|
|
imports ArchSchedule_AI
|
|
begin
|
|
|
|
context begin interpretation Arch .
|
|
|
|
requalify_facts
|
|
arch_post_cap_deletion_pred_tcb_at
|
|
|
|
end
|
|
|
|
declare arch_post_cap_deletion_pred_tcb_at[wp]
|
|
|
|
lemma blocked_cancel_ipc_simple:
|
|
"\<lbrace>tcb_at t\<rbrace> blocked_cancel_ipc ts t \<lbrace>\<lambda>rv. st_tcb_at simple t\<rbrace>"
|
|
by (simp add: blocked_cancel_ipc_def | wp sts_st_tcb_at')+
|
|
|
|
lemma cancel_signal_simple:
|
|
"\<lbrace>\<top>\<rbrace> cancel_signal t ntfn \<lbrace>\<lambda>rv. st_tcb_at simple t\<rbrace>"
|
|
by (simp add: cancel_signal_def | wp sts_st_tcb_at')+
|
|
|
|
crunch typ_at: cancel_all_ipc "\<lambda>s. P (typ_at T p s)" (wp: crunch_wps mapM_x_wp)
|
|
|
|
lemma cancel_all_helper:
|
|
" \<lbrace>valid_objs and
|
|
(\<lambda>s. \<forall>t \<in> set queue. st_tcb_at (\<lambda>st. \<not> halted st) t s) \<rbrace>
|
|
mapM_x (\<lambda>t. do y \<leftarrow> set_thread_state t Structures_A.Restart;
|
|
do_extended_op (tcb_sched_enqueue_ext t) od) queue
|
|
\<lbrace>\<lambda>rv. valid_objs\<rbrace>"
|
|
apply (rule hoare_strengthen_post)
|
|
apply (rule mapM_x_wp [where S="set queue", simplified])
|
|
apply (wp, simp, wp hoare_vcg_const_Ball_lift sts_st_tcb_at_cases, simp)
|
|
apply (clarsimp elim: pred_tcb_weakenE)
|
|
apply (erule(1) my_BallE)
|
|
apply (clarsimp simp: st_tcb_def2)
|
|
apply (frule(1) valid_tcb_objs)
|
|
apply (clarsimp simp: valid_tcb_def valid_tcb_state_def
|
|
cte_wp_at_cases tcb_cap_cases_def
|
|
dest!: get_tcb_SomeD)
|
|
apply simp+
|
|
done
|
|
|
|
|
|
lemma cancel_all_ipc_valid_objs:
|
|
"\<lbrace>valid_objs and (\<lambda>s. sym_refs (state_refs_of s))\<rbrace>
|
|
cancel_all_ipc ptr \<lbrace>\<lambda>_. valid_objs\<rbrace>"
|
|
apply (simp add: cancel_all_ipc_def)
|
|
apply (rule hoare_seq_ext [OF _ get_simple_ko_sp])
|
|
apply (case_tac ep, simp_all add: get_ep_queue_def)
|
|
apply (wp, simp)
|
|
apply (wp cancel_all_helper hoare_vcg_const_Ball_lift
|
|
| clarsimp simp: ep_queued_st_tcb_at obj_at_def valid_ep_def)+
|
|
done
|
|
|
|
|
|
crunch typ_at: cancel_all_signals "\<lambda>s. P (typ_at T p s)" (wp: crunch_wps mapM_x_wp)
|
|
|
|
|
|
lemma unbind_notification_valid_objs_helper:
|
|
"valid_ntfn ntfn s \<longrightarrow> valid_ntfn (ntfn_set_bound_tcb ntfn None) s "
|
|
by (clarsimp simp: valid_bound_tcb_def valid_ntfn_def
|
|
split: option.splits ntfn.splits)
|
|
|
|
lemma unbind_notification_valid_objs:
|
|
"\<lbrace>valid_objs\<rbrace>
|
|
unbind_notification ptr \<lbrace>\<lambda>rv. valid_objs\<rbrace>"
|
|
unfolding unbind_notification_def
|
|
apply (wp thread_set_valid_objs_triv set_simple_ko_valid_objs hoare_drop_imp | wpc
|
|
| simp add: tcb_cap_cases_def
|
|
| strengthen unbind_notification_valid_objs_helper)+
|
|
apply (wp thread_get_wp' | simp add:get_bound_notification_def)+
|
|
apply (clarsimp)
|
|
apply (erule (1) obj_at_valid_objsE)
|
|
apply (clarsimp simp:valid_obj_def valid_tcb_def)+
|
|
done
|
|
|
|
|
|
lemma cancel_all_signals_valid_objs:
|
|
"\<lbrace>valid_objs and (\<lambda>s. sym_refs (state_refs_of s))\<rbrace>
|
|
cancel_all_signals ptr \<lbrace>\<lambda>rv. valid_objs\<rbrace>"
|
|
apply (simp add: cancel_all_signals_def unbind_maybe_notification_def)
|
|
apply (rule hoare_seq_ext [OF _ get_simple_ko_sp])
|
|
apply (rule hoare_pre)
|
|
apply (wp unbind_notification_valid_objs | wpc | simp_all add:unbind_maybe_notification_def)+
|
|
apply (wp cancel_all_helper hoare_vcg_const_Ball_lift
|
|
set_simple_ko_valid_objs unbind_notification_valid_objs
|
|
| clarsimp simp: ntfn_queued_st_tcb_at obj_at_def
|
|
valid_ntfn_def valid_bound_tcb_def
|
|
| wpc)+
|
|
apply (clarsimp split: option.splits)
|
|
apply (erule (1) valid_objsE)
|
|
apply (simp add: valid_obj_def valid_ntfn_def)
|
|
done
|
|
|
|
|
|
lemma get_ep_queue_inv[wp]:
|
|
"\<lbrace>P\<rbrace> get_ep_queue ep \<lbrace>\<lambda>_. P\<rbrace>"
|
|
by (cases ep, simp_all add: get_ep_queue_def)
|
|
|
|
|
|
lemma cancel_all_ipc_st_tcb_at:
|
|
assumes x[simp]: "P Structures_A.Restart" shows
|
|
"\<lbrace>st_tcb_at P t\<rbrace> cancel_all_ipc epptr \<lbrace>\<lambda>rv. st_tcb_at P t\<rbrace>"
|
|
unfolding cancel_all_ipc_def
|
|
by (wp ep_cases_weak_wp mapM_x_wp' sts_st_tcb_at_cases | simp)+
|
|
|
|
|
|
lemmas cancel_all_ipc_makes_simple[wp] =
|
|
cancel_all_ipc_st_tcb_at[where P=simple, simplified]
|
|
|
|
|
|
lemma unbind_notification_st_tcb_at[wp]:
|
|
"\<lbrace>st_tcb_at P t\<rbrace> unbind_notification t' \<lbrace>\<lambda>rv. st_tcb_at P t\<rbrace>"
|
|
unfolding unbind_notification_def
|
|
by (wp thread_set_no_change_tcb_state hoare_drop_imps | wpc | simp)+
|
|
|
|
|
|
lemma unbind_maybe_notification_st_tcb_at[wp]:
|
|
"\<lbrace>st_tcb_at P t\<rbrace> unbind_maybe_notification r \<lbrace>\<lambda>rv. st_tcb_at P t \<rbrace>"
|
|
unfolding unbind_maybe_notification_def
|
|
apply (rule hoare_pre)
|
|
apply (wp thread_set_no_change_tcb_state hoare_drop_imps| wpc | simp)+
|
|
done
|
|
|
|
lemma cancel_all_signals_st_tcb_at:
|
|
assumes x[simp]: "P Structures_A.Restart" shows
|
|
"\<lbrace>st_tcb_at P t\<rbrace> cancel_all_signals ntfnptr \<lbrace>\<lambda>rv. st_tcb_at P t\<rbrace>"
|
|
unfolding cancel_all_signals_def unbind_maybe_notification_def
|
|
by (wp ntfn_cases_weak_wp mapM_x_wp' sts_st_tcb_at_cases
|
|
hoare_drop_imps unbind_notification_st_tcb_at
|
|
| simp | wpc)+
|
|
|
|
|
|
lemmas cancel_all_signals_makes_simple[wp] =
|
|
cancel_all_signals_st_tcb_at[where P=simple, simplified]
|
|
|
|
|
|
|
|
|
|
lemma get_blocking_object_inv[wp]:
|
|
"\<lbrace>P\<rbrace> get_blocking_object st \<lbrace>\<lambda>_. P\<rbrace>"
|
|
by (cases st, simp_all add: get_blocking_object_def)
|
|
|
|
|
|
lemma blocked_ipc_st_tcb_at_general:
|
|
"\<lbrace>st_tcb_at P t' and K (t = t' \<longrightarrow> P Structures_A.Inactive)\<rbrace>
|
|
blocked_cancel_ipc st t
|
|
\<lbrace>\<lambda>rv. st_tcb_at P t'\<rbrace>"
|
|
apply (simp add: blocked_cancel_ipc_def)
|
|
apply (wp sts_st_tcb_at_cases static_imp_wp, simp+)
|
|
done
|
|
|
|
|
|
lemma cancel_signal_st_tcb_at_general:
|
|
"\<lbrace>st_tcb_at P t' and K (t = t' \<longrightarrow> (P Structures_A.Running \<and> P Structures_A.Inactive))\<rbrace>
|
|
cancel_signal t ntfn
|
|
\<lbrace>\<lambda>rv. st_tcb_at P t'\<rbrace>"
|
|
apply (simp add: cancel_signal_def)
|
|
apply (wp sts_st_tcb_at_cases ntfn_cases_weak_wp static_imp_wp)
|
|
apply simp
|
|
done
|
|
|
|
|
|
lemma fast_finalise_misc[wp]:
|
|
"\<lbrace>st_tcb_at simple t \<rbrace> fast_finalise a b \<lbrace>\<lambda>_. st_tcb_at simple t\<rbrace>"
|
|
apply (case_tac a,simp_all)
|
|
apply (wp|clarsimp)+
|
|
done
|
|
|
|
locale IpcCancel_AI =
|
|
fixes state_ext :: "('a::state_ext) itself"
|
|
assumes arch_post_cap_deletion_typ_at[wp]:
|
|
"\<And>P T p acap. \<lbrace>\<lambda>(s :: 'a state). P (typ_at T p s)\<rbrace> arch_post_cap_deletion acap \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
|
|
assumes arch_post_cap_deletion_idle_thread[wp]:
|
|
"\<And>P acap. \<lbrace>\<lambda>(s :: 'a state). P (idle_thread s)\<rbrace> arch_post_cap_deletion acap \<lbrace>\<lambda>rv s. P (idle_thread s)\<rbrace>"
|
|
|
|
crunches update_restart_pc
|
|
for typ_at[wp]: "\<lambda>s. P (typ_at ty ptr s)"
|
|
(* NB: Q needed for following has_reply_cap proof *)
|
|
and cte_wp_at[wp]: "\<lambda>s. Q (cte_wp_at P cte s)"
|
|
and idle_thread[wp]: "\<lambda>s. P (idle_thread s)"
|
|
and pred_tcb_at[wp]: "\<lambda>s. pred_tcb_at P proj tcb s"
|
|
and invs[wp]: "\<lambda>s. invs s"
|
|
|
|
lemma update_restart_pc_has_reply_cap[wp]:
|
|
"\<lbrace>\<lambda>s. \<not> has_reply_cap t s\<rbrace> update_restart_pc t \<lbrace>\<lambda>_ s. \<not> has_reply_cap t s\<rbrace>"
|
|
apply (simp add: has_reply_cap_def)
|
|
apply (wp hoare_vcg_all_lift)
|
|
done
|
|
|
|
crunch st_tcb_at_simple[wp]: reply_cancel_ipc "st_tcb_at simple t"
|
|
(wp: crunch_wps select_wp sts_st_tcb_at_cases thread_set_no_change_tcb_state
|
|
simp: crunch_simps unless_def fast_finalise.simps)
|
|
|
|
lemma cancel_ipc_simple [wp]:
|
|
"\<lbrace>\<top>\<rbrace> cancel_ipc t \<lbrace>\<lambda>rv. st_tcb_at simple t\<rbrace>"
|
|
apply (simp add: cancel_ipc_def)
|
|
apply (rule hoare_seq_ext [OF _ gts_sp])
|
|
apply (case_tac state, simp_all)
|
|
apply (wp hoare_strengthen_post [OF blocked_cancel_ipc_simple]
|
|
hoare_strengthen_post [OF cancel_signal_simple]
|
|
hoare_strengthen_post
|
|
[OF reply_cancel_ipc_st_tcb_at_simple [where t=t]]
|
|
sts_st_tcb_at_cases
|
|
hoare_drop_imps
|
|
| clarsimp elim!: pred_tcb_weakenE pred_tcb_at_tcb_at)+
|
|
done
|
|
|
|
lemma blocked_cancel_ipc_typ_at[wp]:
|
|
"\<lbrace>\<lambda>s. P (typ_at T p s)\<rbrace> blocked_cancel_ipc st t \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
|
|
apply (simp add: blocked_cancel_ipc_def get_blocking_object_def get_ep_queue_def
|
|
get_simple_ko_def)
|
|
apply (wp get_object_wp|wpc)+
|
|
apply simp
|
|
done
|
|
|
|
|
|
lemma blocked_cancel_ipc_tcb_at [wp]:
|
|
"\<lbrace>tcb_at t\<rbrace> blocked_cancel_ipc st t' \<lbrace>\<lambda>rv. tcb_at t\<rbrace>"
|
|
by (simp add: tcb_at_typ) wp
|
|
|
|
context IpcCancel_AI begin
|
|
|
|
crunch typ_at[wp]: cancel_ipc, reply_cancel_ipc, unbind_maybe_notification
|
|
"\<lambda>(s :: 'a state). P (typ_at T p s)"
|
|
(wp: crunch_wps hoare_vcg_if_splitE select_wp
|
|
simp: crunch_simps unless_def)
|
|
|
|
lemma cancel_ipc_tcb [wp]:
|
|
"\<lbrace>tcb_at t\<rbrace> cancel_ipc t' \<lbrace>\<lambda>rv. (tcb_at t) :: 'a state \<Rightarrow> bool\<rbrace>"
|
|
by (simp add: tcb_at_typ) wp
|
|
|
|
end
|
|
|
|
lemma gbep_ret:
|
|
"\<lbrakk> st = Structures_A.BlockedOnReceive epPtr pl' \<or>
|
|
st = Structures_A.BlockedOnSend epPtr pl \<rbrakk> \<Longrightarrow>
|
|
get_blocking_object st = return epPtr"
|
|
by (auto simp add: get_blocking_object_def)
|
|
|
|
|
|
lemma st_tcb_at_valid_st2:
|
|
"\<lbrakk> st_tcb_at ((=) st) t s; valid_objs s \<rbrakk> \<Longrightarrow> valid_tcb_state st s"
|
|
apply (clarsimp simp add: valid_objs_def get_tcb_def pred_tcb_at_def
|
|
obj_at_def)
|
|
apply (drule_tac x=t in bspec)
|
|
apply (erule domI)
|
|
apply (simp add: valid_obj_def valid_tcb_def)
|
|
done
|
|
|
|
|
|
definition
|
|
"emptyable \<equiv> \<lambda>p s. (tcb_at (fst p) s \<and> snd p = tcb_cnode_index 2) \<longrightarrow>
|
|
st_tcb_at halted (fst p) s"
|
|
|
|
locale delete_one_abs = IpcCancel_AI state_ext
|
|
for state_ext :: "('a :: state_ext) itself" +
|
|
assumes delete_one_invs:
|
|
"\<And>p. \<lbrace>invs and emptyable p\<rbrace> (cap_delete_one p :: (unit,'a) s_monad) \<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
|
|
assumes delete_one_deletes:
|
|
"\<lbrace>\<top>\<rbrace> (cap_delete_one sl :: (unit,'a) s_monad) \<lbrace>\<lambda>rv. cte_wp_at (\<lambda>c. c = cap.NullCap) sl\<rbrace>"
|
|
|
|
assumes delete_one_caps_of_state:
|
|
"\<And>P p. \<lbrace>\<lambda>s. cte_wp_at can_fast_finalise p s
|
|
\<longrightarrow> P ((caps_of_state s) (p \<mapsto> cap.NullCap))\<rbrace>
|
|
(cap_delete_one p :: (unit,'a) s_monad)
|
|
\<lbrace>\<lambda>rv s. P (caps_of_state s)\<rbrace>"
|
|
|
|
|
|
lemma reply_master_no_descendants_no_reply:
|
|
"\<lbrakk> valid_mdb s; valid_reply_masters s; tcb_at t s \<rbrakk> \<Longrightarrow>
|
|
descendants_of (t, tcb_cnode_index 2) (cdt s) = {} \<longrightarrow> \<not> has_reply_cap t s"
|
|
by (fastforce simp: invs_def valid_state_def valid_mdb_def has_reply_cap_def
|
|
cte_wp_at_caps_of_state reply_mdb_def is_reply_cap_to_def
|
|
reply_caps_mdb_def descendants_of_def cdt_parent_defs
|
|
dest: reply_master_caps_of_stateD tranclD)
|
|
|
|
|
|
lemma reply_cap_unique_descendant:
|
|
"\<lbrakk> invs s; tcb_at t s \<rbrakk> \<Longrightarrow>
|
|
\<forall>sl\<in>descendants_of (t, tcb_cnode_index 2) (cdt s). \<forall>sl'. sl' \<noteq> sl \<longrightarrow>
|
|
sl' \<notin> descendants_of (t, tcb_cnode_index 2) (cdt s)"
|
|
apply (subgoal_tac "cte_wp_at (\<lambda>c. (is_master_reply_cap c \<and> obj_ref_of c = t)
|
|
\<or> c = cap.NullCap)
|
|
(t, tcb_cnode_index 2) s")
|
|
apply (clarsimp simp: invs_def valid_state_def valid_mdb_def2 is_cap_simps
|
|
valid_reply_caps_def cte_wp_at_caps_of_state)
|
|
apply (erule disjE)
|
|
apply (fastforce simp: reply_mdb_def is_cap_simps dest: unique_reply_capsD)
|
|
apply (fastforce dest: mdb_cte_at_Null_descendants)
|
|
apply (clarsimp simp: tcb_cap_wp_at invs_valid_objs
|
|
tcb_cap_cases_def is_cap_simps)
|
|
done
|
|
|
|
|
|
lemma reply_master_one_descendant:
|
|
"\<lbrakk> invs s; tcb_at t s; descendants_of (t, tcb_cnode_index 2) (cdt s) \<noteq> {} \<rbrakk>
|
|
\<Longrightarrow> \<exists>sl. descendants_of (t, tcb_cnode_index 2) (cdt s) = {sl}"
|
|
by (fastforce elim: construct_singleton dest: reply_cap_unique_descendant)
|
|
|
|
|
|
lemma ep_redux_simps2:
|
|
"ep \<noteq> Structures_A.IdleEP \<Longrightarrow>
|
|
valid_ep (case xs of [] \<Rightarrow> Structures_A.endpoint.IdleEP
|
|
| a # list \<Rightarrow> update_ep_queue ep xs)
|
|
= (\<lambda>s. distinct xs \<and> (\<forall>t\<in>set xs. tcb_at t s))"
|
|
"ep \<noteq> Structures_A.IdleEP \<Longrightarrow>
|
|
ep_q_refs_of (case xs of [] \<Rightarrow> Structures_A.endpoint.IdleEP
|
|
| a # list \<Rightarrow> update_ep_queue ep xs)
|
|
= (set xs \<times> {case ep of Structures_A.SendEP xs \<Rightarrow> EPSend | Structures_A.RecvEP xs \<Rightarrow> EPRecv})"
|
|
by (cases ep, simp_all cong: list.case_cong add: ep_redux_simps)+
|
|
|
|
|
|
lemma gbi_ep_sp:
|
|
"\<lbrace>P\<rbrace>
|
|
get_blocking_object st
|
|
\<lbrace>\<lambda>ep. P and K ((\<exists>d. st = Structures_A.BlockedOnReceive ep d)
|
|
\<or> (\<exists>d. st = Structures_A.BlockedOnSend ep d))\<rbrace>"
|
|
apply (cases st, simp_all add: get_blocking_object_def)
|
|
apply (wp | simp)+
|
|
done
|
|
|
|
|
|
lemma get_epq_sp:
|
|
"\<lbrace>P\<rbrace>
|
|
get_ep_queue ep
|
|
\<lbrace>\<lambda>q. P and K (ep \<in> {Structures_A.SendEP q, Structures_A.RecvEP q})\<rbrace>"
|
|
apply (simp add: get_ep_queue_def)
|
|
apply (cases ep)
|
|
apply (wp|simp)+
|
|
done
|
|
|
|
lemma refs_in_tcb_bound_refs:
|
|
"(x, ref) \<in> tcb_bound_refs ntfn \<Longrightarrow> ref = TCBBound"
|
|
by (auto simp: tcb_bound_refs_def split: option.splits)
|
|
|
|
lemma refs_in_ntfn_bound_refs:
|
|
"(x, ref) \<in> ntfn_bound_refs tcb \<Longrightarrow> ref = NTFNBound"
|
|
by (auto simp: ntfn_bound_refs_def split: option.splits)
|
|
|
|
lemma blocked_cancel_ipc_invs:
|
|
"\<lbrace>invs and st_tcb_at ((=) st) t\<rbrace> blocked_cancel_ipc st t \<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
apply (simp add: blocked_cancel_ipc_def)
|
|
apply (rule hoare_seq_ext [OF _ gbi_ep_sp])
|
|
apply (rule hoare_seq_ext [OF _ get_simple_ko_sp])
|
|
apply (rule hoare_seq_ext [OF _ get_epq_sp])
|
|
apply (simp add: invs_def valid_state_def valid_pspace_def)
|
|
apply (rule hoare_pre, wp valid_irq_node_typ sts_only_idle)
|
|
apply (simp add: valid_tcb_state_def)
|
|
apply (strengthen reply_cap_doesnt_exist_strg)
|
|
apply simp
|
|
apply (wp valid_irq_node_typ valid_ioports_lift)
|
|
apply (subgoal_tac "ep \<noteq> Structures_A.IdleEP")
|
|
apply (clarsimp simp: ep_redux_simps2 cong: if_cong)
|
|
apply (frule(1) if_live_then_nonz_capD, (clarsimp simp: live_def)+)
|
|
apply (frule ko_at_state_refs_ofD)
|
|
apply (erule(1) obj_at_valid_objsE, clarsimp simp: valid_obj_def)
|
|
apply (frule st_tcb_at_state_refs_ofD)
|
|
apply (subgoal_tac "epptr \<notin> set (remove1 t queue)")
|
|
apply (case_tac ep, simp_all add: valid_ep_def)[1]
|
|
apply (auto elim!: delta_sym_refs pred_tcb_weaken_strongerE
|
|
simp: obj_at_def is_ep_def2 idle_not_queued refs_in_tcb_bound_refs
|
|
dest: idle_no_refs
|
|
split: if_split_asm)[2]
|
|
apply (case_tac ep, simp_all add: valid_ep_def)[1]
|
|
apply (clarsimp, drule(1) bspec, clarsimp simp: obj_at_def is_tcb_def)+
|
|
apply fastforce
|
|
done
|
|
|
|
lemma symreftype_inverse':
|
|
"symreftype ref = ref' \<Longrightarrow> ref = symreftype ref'"
|
|
by (cases ref) simp_all
|
|
|
|
lemma cancel_signal_invs:
|
|
"\<lbrace>invs and st_tcb_at ((=) (Structures_A.BlockedOnNotification ntfn)) t\<rbrace>
|
|
cancel_signal t ntfn
|
|
\<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
apply (simp add: cancel_signal_def
|
|
invs_def valid_state_def valid_pspace_def)
|
|
apply (rule hoare_seq_ext [OF _ get_simple_ko_sp])
|
|
apply (case_tac "ntfn_obj ntfna", simp_all)[1]
|
|
apply (rule hoare_pre)
|
|
apply (wp set_simple_ko_valid_objs valid_irq_node_typ sts_only_idle valid_ioports_lift
|
|
| simp add: valid_tcb_state_def
|
|
| strengthen reply_cap_doesnt_exist_strg
|
|
| wpc)+
|
|
apply (clarsimp simp: ep_redux_simps cong: list.case_cong if_cong)
|
|
apply (frule(1) if_live_then_nonz_capD, (clarsimp simp: live_def)+)
|
|
apply (frule ko_at_state_refs_ofD)
|
|
apply (frule st_tcb_at_state_refs_ofD)
|
|
apply (erule(1) obj_at_valid_objsE, clarsimp simp: valid_obj_def valid_ntfn_def)
|
|
apply (case_tac ntfna)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: pred_tcb_at_def obj_at_def)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply (clarsimp split:option.split)
|
|
apply (rule conjI, erule delta_sym_refs)
|
|
apply (clarsimp split: if_split_asm)+
|
|
apply (fastforce dest: refs_in_tcb_bound_refs refs_in_ntfn_bound_refs symreftype_inverse')
|
|
apply (fastforce simp: obj_at_def is_ntfn idle_not_queued
|
|
dest: idle_no_refs elim: pred_tcb_weakenE)
|
|
done
|
|
|
|
lemma reply_mdb_cte_at_master_None:
|
|
"\<lbrakk> reply_mdb m cs; mdb_cte_at (\<lambda>p. \<exists>c. cs p = Some c \<and> cap.NullCap \<noteq> c) m;
|
|
cs ptr = Some cap; is_master_reply_cap cap \<rbrakk> \<Longrightarrow>
|
|
m ptr = None"
|
|
unfolding reply_mdb_def reply_masters_mdb_def
|
|
by (fastforce simp: is_cap_simps)
|
|
|
|
|
|
lemma reply_slot_not_descendant:
|
|
"\<And>ptr. \<lbrakk> invs s; tcb_at t s \<rbrakk> \<Longrightarrow>
|
|
(t, tcb_cnode_index 2) \<notin> descendants_of ptr (cdt s)"
|
|
apply (subgoal_tac "cte_wp_at (\<lambda>c. is_master_reply_cap c \<or> c = cap.NullCap)
|
|
(t, tcb_cnode_index 2) s")
|
|
apply (fastforce simp: invs_def valid_state_def valid_mdb_def2
|
|
cte_wp_at_caps_of_state
|
|
dest: reply_mdb_cte_at_master_None mdb_cte_at_Null_None
|
|
descendants_of_NoneD)
|
|
apply (clarsimp simp: tcb_cap_wp_at invs_valid_objs
|
|
tcb_cap_cases_def)
|
|
done
|
|
|
|
lemma reply_cancel_ipc_invs:
|
|
assumes delete: "\<And>p. \<lbrace>invs and emptyable p\<rbrace>
|
|
(cap_delete_one p :: (unit,'z::state_ext) s_monad) \<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
shows "\<lbrace>invs\<rbrace> (reply_cancel_ipc t :: (unit,'z::state_ext) s_monad) \<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
apply (simp add: reply_cancel_ipc_def)
|
|
apply (wp delete select_wp)
|
|
apply (rule_tac Q="\<lambda>rv. invs" in hoare_post_imp)
|
|
apply (fastforce simp: emptyable_def dest: reply_slot_not_descendant)
|
|
apply (wp thread_set_invs_trivial)
|
|
apply (auto simp: tcb_cap_cases_def)+
|
|
done
|
|
|
|
|
|
lemma (in delete_one_abs) cancel_ipc_invs[wp]:
|
|
"\<lbrace>invs\<rbrace> (cancel_ipc t :: (unit,'a) s_monad) \<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
apply (simp add: cancel_ipc_def)
|
|
apply (rule hoare_seq_ext [OF _ gts_sp])
|
|
apply (case_tac state, simp_all)
|
|
apply (auto intro!: hoare_weaken_pre [OF return_wp]
|
|
hoare_weaken_pre [OF blocked_cancel_ipc_invs]
|
|
hoare_weaken_pre [OF cancel_signal_invs]
|
|
hoare_weaken_pre [OF reply_cancel_ipc_invs]
|
|
delete_one_invs
|
|
elim!: pred_tcb_weakenE)
|
|
done
|
|
|
|
context IpcCancel_AI begin
|
|
|
|
lemma cancel_ipc_valid_cap:
|
|
"\<lbrace>valid_cap c\<rbrace> cancel_ipc p \<lbrace>\<lambda>_. (valid_cap c) :: 'a state \<Rightarrow> bool\<rbrace>"
|
|
by (wp valid_cap_typ)
|
|
|
|
|
|
lemma cancel_ipc_cte_at[wp]:
|
|
"\<lbrace>cte_at p\<rbrace> cancel_ipc t \<lbrace>\<lambda>_. (cte_at p) :: 'a state \<Rightarrow> bool\<rbrace>"
|
|
by (wp valid_cte_at_typ)
|
|
|
|
end
|
|
|
|
lemma valid_ep_queue_subset:
|
|
"\<lbrace>\<lambda>s. valid_ep ep s\<rbrace>
|
|
get_ep_queue ep
|
|
\<lbrace>\<lambda>queue s. valid_ep (case (remove1 t queue) of [] \<Rightarrow> Structures_A.endpoint.IdleEP
|
|
| a # list \<Rightarrow> update_ep_queue ep (remove1 t queue)) s\<rbrace>"
|
|
apply (simp add: get_ep_queue_def)
|
|
apply (case_tac ep, simp_all)
|
|
apply wp
|
|
apply (clarsimp simp: ep_redux_simps2 valid_ep_def)
|
|
apply wp
|
|
apply (clarsimp simp: ep_redux_simps2 valid_ep_def)
|
|
done
|
|
|
|
lemma blocked_cancel_ipc_valid_objs[wp]:
|
|
"\<lbrace>valid_objs\<rbrace> blocked_cancel_ipc st t \<lbrace>\<lambda>_. valid_objs\<rbrace>"
|
|
apply (simp add: blocked_cancel_ipc_def)
|
|
apply (wp get_simple_ko_valid[where f=Endpoint, simplified valid_ep_def2[symmetric]]
|
|
valid_ep_queue_subset
|
|
| simp only: valid_inactive simp_thms
|
|
cong: imp_cong
|
|
| rule hoare_drop_imps
|
|
| clarsimp)+
|
|
done
|
|
|
|
|
|
lemma cancel_signal_valid_objs[wp]:
|
|
"\<lbrace>valid_objs\<rbrace> cancel_signal t ntfnptr \<lbrace>\<lambda>_. valid_objs\<rbrace>"
|
|
apply (simp add: cancel_signal_def)
|
|
apply (rule hoare_seq_ext [OF _ get_simple_ko_sp])
|
|
apply (rule hoare_pre)
|
|
apply (wp set_simple_ko_valid_objs
|
|
| simp only: valid_inactive
|
|
| simp
|
|
| wpc)+
|
|
apply (clarsimp simp: ep_redux_simps cong: list.case_cong)
|
|
apply (erule(1) obj_at_valid_objsE)
|
|
apply (clarsimp simp: valid_obj_def valid_ntfn_def)
|
|
apply (auto split: option.splits list.splits)
|
|
done
|
|
|
|
|
|
lemma tcb_in_valid_state:
|
|
"\<lbrakk> st_tcb_at P t s; valid_objs s \<rbrakk> \<Longrightarrow> \<exists>st. P st \<and> valid_tcb_state st s"
|
|
apply (clarsimp simp add: valid_objs_def pred_tcb_at_def obj_at_def)
|
|
apply (erule my_BallE, erule domI)
|
|
apply (simp add: valid_obj_def valid_tcb_def)
|
|
apply blast
|
|
done
|
|
|
|
|
|
lemma no_refs_simple_strg:
|
|
"st_tcb_at simple t s \<and> P {} \<longrightarrow> st_tcb_at (\<lambda>st. P (tcb_st_refs_of st)) t s"
|
|
by (fastforce elim!: pred_tcb_weakenE)+
|
|
|
|
|
|
crunch it[wp]: cancel_all_ipc "\<lambda>s. P (idle_thread s)"
|
|
(wp: crunch_wps select_wp simp: unless_def crunch_simps)
|
|
|
|
crunch it[wp]: cancel_all_signals, fast_finalise, unbind_notification "\<lambda>s. P (idle_thread s)"
|
|
(wp: crunch_wps select_wp simp: unless_def crunch_simps)
|
|
|
|
context IpcCancel_AI begin
|
|
|
|
crunch it[wp]: reply_cancel_ipc "\<lambda>(s::'a state). P (idle_thread s)"
|
|
(wp: crunch_wps select_wp simp: unless_def crunch_simps)
|
|
|
|
crunch it[wp]: cancel_ipc "\<lambda>(s :: 'a state). P (idle_thread s)"
|
|
|
|
end
|
|
|
|
lemma reply_cap_descends_from_master:
|
|
"\<lbrakk> invs s; tcb_at t s \<rbrakk> \<Longrightarrow>
|
|
\<forall>sl\<in>descendants_of (t, tcb_cnode_index 2) (cdt s). \<forall>sl' R. sl' \<noteq> sl \<longrightarrow>
|
|
caps_of_state s sl' \<noteq> Some (cap.ReplyCap t False R)"
|
|
apply (subgoal_tac "cte_wp_at (\<lambda>c. (is_master_reply_cap c \<and> obj_ref_of c = t)
|
|
\<or> c = cap.NullCap)
|
|
(t, tcb_cnode_index 2) s")
|
|
apply (clarsimp simp: invs_def valid_state_def valid_mdb_def2 is_cap_simps
|
|
valid_reply_caps_def cte_wp_at_caps_of_state)
|
|
apply (erule disjE)
|
|
apply (unfold reply_mdb_def reply_masters_mdb_def)[1]
|
|
apply (elim conjE)
|
|
apply (erule_tac x="(t, tcb_cnode_index 2)" in allE)
|
|
apply (erule_tac x=t in allE)+
|
|
apply (fastforce simp: unique_reply_caps_def is_cap_simps)
|
|
apply (fastforce dest: mdb_cte_at_Null_descendants)
|
|
apply (clarsimp simp: tcb_cap_wp_at invs_valid_objs
|
|
tcb_cap_cases_def is_cap_simps)
|
|
done
|
|
|
|
|
|
lemma (in delete_one_abs) reply_cancel_ipc_no_reply_cap[wp]:
|
|
notes hoare_pre
|
|
shows "\<lbrace>invs and tcb_at t\<rbrace> (reply_cancel_ipc t :: (unit,'a) s_monad) \<lbrace>\<lambda>rv s. \<not> has_reply_cap t s\<rbrace>"
|
|
apply (simp add: reply_cancel_ipc_def)
|
|
apply wp
|
|
apply (rule_tac Q="\<lambda>rvp s. cte_wp_at (\<lambda>c. c = cap.NullCap) x s \<and>
|
|
(\<forall>sl R. sl \<noteq> x \<longrightarrow>
|
|
caps_of_state s sl \<noteq> Some (cap.ReplyCap t False R))"
|
|
in hoare_strengthen_post)
|
|
apply (wp hoare_vcg_conj_lift hoare_vcg_all_lift
|
|
delete_one_deletes delete_one_caps_of_state)
|
|
apply (clarsimp simp: has_reply_cap_def cte_wp_at_caps_of_state is_reply_cap_to_def)
|
|
apply (case_tac "(aa, ba) = (a, b)",simp_all)[1]
|
|
apply (wp hoare_vcg_all_lift select_wp | simp del: split_paired_All)+
|
|
apply (rule_tac Q="\<lambda>_ s. invs s \<and> tcb_at t s" in hoare_post_imp)
|
|
apply (erule conjE)
|
|
apply (frule(1) reply_cap_descends_from_master)
|
|
apply (auto dest: reply_master_no_descendants_no_reply[rotated -1])[1]
|
|
apply (wp thread_set_invs_trivial | clarsimp simp: tcb_cap_cases_def)+
|
|
done
|
|
|
|
|
|
lemma (in delete_one_abs) cancel_ipc_no_reply_cap[wp]:
|
|
shows "\<lbrace>invs and tcb_at t\<rbrace> (cancel_ipc t :: (unit,'a) s_monad) \<lbrace>\<lambda>rv s. \<not> has_reply_cap t s\<rbrace>"
|
|
apply (simp add: cancel_ipc_def)
|
|
apply (wpsimp wp: hoare_post_imp [OF invs_valid_reply_caps]
|
|
reply_cancel_ipc_no_reply_cap
|
|
cancel_signal_invs cancel_signal_st_tcb_at_general
|
|
blocked_cancel_ipc_invs blocked_ipc_st_tcb_at_general
|
|
| strengthen reply_cap_doesnt_exist_strg)+
|
|
apply (rule_tac Q="\<lambda>rv. st_tcb_at ((=) rv) t and invs" in hoare_strengthen_post)
|
|
apply (wpsimp wp: gts_st_tcb)
|
|
apply (fastforce simp: invs_def valid_state_def st_tcb_at_tcb_at
|
|
elim!: pred_tcb_weakenE)+
|
|
done
|
|
|
|
lemma (in delete_one_abs) suspend_invs[wp]:
|
|
"\<lbrace>invs and tcb_at t and (\<lambda>s. t \<noteq> idle_thread s)\<rbrace>
|
|
(suspend t :: (unit,'a) s_monad) \<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
by (wp sts_invs_minor user_getreg_inv as_user_invs sts_invs_minor cancel_ipc_invs
|
|
cancel_ipc_no_reply_cap
|
|
| strengthen no_refs_simple_strg
|
|
| simp add: suspend_def)+
|
|
|
|
context IpcCancel_AI begin
|
|
|
|
lemma suspend_typ_at [wp]:
|
|
"\<lbrace>\<lambda>(s::'a state). P (typ_at T p s)\<rbrace> suspend t \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
|
|
by (wpsimp simp: suspend_def)
|
|
|
|
lemma suspend_valid_cap:
|
|
"\<lbrace>valid_cap c\<rbrace> suspend tcb \<lbrace>\<lambda>_. (valid_cap c) :: 'a state \<Rightarrow> bool\<rbrace>"
|
|
by (wp valid_cap_typ)
|
|
|
|
lemma suspend_tcb[wp]:
|
|
"\<lbrace>tcb_at t'\<rbrace> suspend t \<lbrace>\<lambda>rv. (tcb_at t') :: 'a state \<Rightarrow> bool\<rbrace>"
|
|
by (simp add: tcb_at_typ) wp
|
|
|
|
end
|
|
|
|
declare if_cong [cong del]
|
|
|
|
|
|
crunch cte_wp_at[wp]: blocked_cancel_ipc "cte_wp_at P p"
|
|
(wp: crunch_wps)
|
|
|
|
crunch cte_wp_at[wp]: cancel_signal "cte_wp_at P p"
|
|
(wp: crunch_wps)
|
|
|
|
locale delete_one_pre =
|
|
fixes state_ext_type :: "('a :: state_ext) itself"
|
|
assumes delete_one_cte_wp_at_preserved:
|
|
"(\<And>cap. P cap \<Longrightarrow> \<not> can_fast_finalise cap) \<Longrightarrow>
|
|
\<lbrace>cte_wp_at P sl\<rbrace> (cap_delete_one sl' :: (unit,'a) s_monad) \<lbrace>\<lambda>rv. cte_wp_at P sl\<rbrace>"
|
|
|
|
lemma (in delete_one_pre) reply_cancel_ipc_cte_wp_at_preserved:
|
|
"(\<And>cap. P cap \<Longrightarrow> \<not> can_fast_finalise cap) \<Longrightarrow>
|
|
\<lbrace>cte_wp_at P p\<rbrace> (reply_cancel_ipc t :: (unit,'a) s_monad) \<lbrace>\<lambda>rv. cte_wp_at P p\<rbrace>"
|
|
unfolding reply_cancel_ipc_def
|
|
apply (wpsimp wp: select_wp delete_one_cte_wp_at_preserved)
|
|
apply (rule_tac Q="\<lambda>_. cte_wp_at P p" in hoare_post_imp, clarsimp)
|
|
apply (wpsimp wp: thread_set_cte_wp_at_trivial simp: ran_tcb_cap_cases)
|
|
apply assumption
|
|
done
|
|
|
|
|
|
lemma (in delete_one_pre) cancel_ipc_cte_wp_at_preserved:
|
|
"(\<And>cap. P cap \<Longrightarrow> \<not> can_fast_finalise cap) \<Longrightarrow>
|
|
\<lbrace>cte_wp_at P p\<rbrace> (cancel_ipc t :: (unit,'a) s_monad) \<lbrace>\<lambda>rv. cte_wp_at P p\<rbrace>"
|
|
apply (simp add: cancel_ipc_def)
|
|
apply (rule hoare_pre)
|
|
apply (wp reply_cancel_ipc_cte_wp_at_preserved | wpcw | simp)+
|
|
done
|
|
|
|
lemma (in delete_one_pre) suspend_cte_wp_at_preserved:
|
|
"(\<And>cap. P cap \<Longrightarrow> \<not> can_fast_finalise cap) \<Longrightarrow>
|
|
\<lbrace>cte_wp_at P p\<rbrace> (suspend tcb :: (unit,'a) s_monad) \<lbrace>\<lambda>_. cte_wp_at P p\<rbrace>"
|
|
by (simp add: suspend_def) (wpsimp wp: cancel_ipc_cte_wp_at_preserved)+
|
|
|
|
|
|
(* FIXME - eliminate *)
|
|
lemma obj_at_exst_update:
|
|
"obj_at P p (trans_state f s) = obj_at P p s"
|
|
by (rule more_update.obj_at_update)
|
|
|
|
|
|
lemma set_thread_state_bound_tcb_at[wp]:
|
|
"\<lbrace>bound_tcb_at P t\<rbrace> set_thread_state p ts \<lbrace>\<lambda>_. bound_tcb_at P t\<rbrace>"
|
|
unfolding set_thread_state_def set_object_def get_object_def
|
|
by (wpsimp simp: pred_tcb_at_def obj_at_def get_tcb_def)
|
|
|
|
crunch bound_tcb_at[wp]: cancel_all_ipc, empty_slot, is_final_cap, get_cap "bound_tcb_at P t"
|
|
(wp: mapM_x_wp_inv)
|
|
|
|
|
|
lemma fast_finalise_bound_tcb_at:
|
|
"\<lbrace>\<lambda>s. bound_tcb_at P t s \<and> (\<exists>tt b R. cap = ReplyCap tt b R) \<rbrace> fast_finalise cap final \<lbrace>\<lambda>_. bound_tcb_at P t\<rbrace>"
|
|
by (case_tac cap, simp_all)
|
|
|
|
|
|
lemma get_cap_reply_cap_helper:
|
|
"\<lbrace>\<lambda>s. \<exists>t b R. Some (ReplyCap t b R) = caps_of_state s slot \<rbrace> get_cap slot \<lbrace>\<lambda>rv s. \<exists>t b R. rv = ReplyCap t b R\<rbrace>"
|
|
by (auto simp: valid_def get_cap_caps_of_state[symmetric])
|
|
|
|
|
|
lemma cap_delete_one_bound_tcb_at:
|
|
"\<lbrace>\<lambda>s. bound_tcb_at P t s \<and> (\<exists>t b R. caps_of_state s c = Some (ReplyCap t b R)) \<rbrace>
|
|
cap_delete_one c
|
|
\<lbrace>\<lambda>_. bound_tcb_at P t\<rbrace>"
|
|
apply (clarsimp simp: unless_def cap_delete_one_def)
|
|
apply (wp fast_finalise_bound_tcb_at)
|
|
apply (wp hoare_vcg_if_lift2, simp)
|
|
apply (wp hoare_conjI)
|
|
apply (wp only:hoare_drop_imp)
|
|
apply (wp hoare_vcg_conj_lift)
|
|
apply (wp get_cap_reply_cap_helper hoare_drop_imp | clarsimp)+
|
|
done
|
|
|
|
|
|
lemma valid_mdb_impl_reply_masters:
|
|
"valid_mdb s \<Longrightarrow> reply_masters_mdb (cdt s) (caps_of_state s)"
|
|
by (auto simp: valid_mdb_def reply_mdb_def)
|
|
|
|
|
|
lemma caps_of_state_tcb_index_trans:
|
|
"\<lbrakk>get_tcb p s = Some tcb \<rbrakk> \<Longrightarrow> caps_of_state s (p, tcb_cnode_index n) = (tcb_cnode_map tcb) (tcb_cnode_index n)"
|
|
apply (drule get_tcb_SomeD)
|
|
apply (clarsimp simp: caps_of_state_def)
|
|
apply (safe)
|
|
apply (clarsimp simp: get_object_def get_cap_def)
|
|
apply (simp add:set_eq_iff)
|
|
apply (drule_tac x=cap in spec)
|
|
apply (drule_tac x=s in spec)
|
|
apply (clarsimp simp: in_monad)
|
|
apply (clarsimp simp: get_cap_def get_object_def)
|
|
apply (rule ccontr)
|
|
apply (drule not_sym)
|
|
apply (auto simp: set_eq_iff in_monad)
|
|
done
|
|
|
|
|
|
lemma descendants_of_nullcap:
|
|
"\<lbrakk>descendants_of (a, b) (cdt s) \<noteq> {}; valid_mdb s \<rbrakk> \<Longrightarrow> caps_of_state s (a, b) \<noteq> Some NullCap"
|
|
apply clarsimp
|
|
apply (drule_tac cs="caps_of_state s" and p="(a,b)" and m="(cdt s)" in mdb_cte_at_Null_descendants)
|
|
apply (clarsimp simp: valid_mdb_def2)+
|
|
done
|
|
|
|
lemma reply_cancel_ipc_bound_tcb_at[wp]:
|
|
"\<lbrace>bound_tcb_at P t and valid_mdb and valid_objs and tcb_at p \<rbrace>
|
|
reply_cancel_ipc p
|
|
\<lbrace>\<lambda>_. bound_tcb_at P t\<rbrace>"
|
|
unfolding reply_cancel_ipc_def
|
|
apply (wpsimp wp: cap_delete_one_bound_tcb_at select_inv select_wp)
|
|
apply (rule_tac Q="\<lambda>_. bound_tcb_at P t and valid_mdb and valid_objs and tcb_at p" in hoare_strengthen_post)
|
|
apply (wpsimp wp: thread_set_no_change_tcb_pred thread_set_mdb)
|
|
apply (fastforce simp:tcb_cap_cases_def)
|
|
apply (wpsimp wp: thread_set_valid_objs_triv simp: ran_tcb_cap_cases)
|
|
apply clarsimp
|
|
apply (frule valid_mdb_impl_reply_masters)
|
|
apply (clarsimp simp: reply_masters_mdb_def)
|
|
apply (spec p)
|
|
apply (spec "tcb_cnode_index 2")
|
|
apply (spec p)
|
|
apply (clarsimp simp:tcb_at_def)
|
|
apply (frule(1) valid_tcb_objs)
|
|
apply (clarsimp simp: valid_tcb_def)
|
|
apply (erule impE)
|
|
apply (simp add: caps_of_state_tcb_index_trans tcb_cnode_map_def)
|
|
apply (clarsimp simp: tcb_cap_cases_def is_master_reply_cap_def split:cap.splits )
|
|
apply (subgoal_tac "descendants_of (p, tcb_cnode_index 2) (cdt s) \<noteq> {}")
|
|
prefer 2
|
|
apply simp
|
|
apply (drule descendants_of_nullcap, simp)
|
|
apply (simp add: caps_of_state_tcb_index_trans tcb_cnode_map_def)
|
|
apply fastforce
|
|
apply simp
|
|
done
|
|
|
|
crunch bound_tcb_at[wp]: cancel_ipc "bound_tcb_at P t"
|
|
(ignore: set_object thread_set wp: mapM_x_wp_inv)
|
|
|
|
context IpcCancel_AI begin
|
|
lemma suspend_unlive:
|
|
"\<lbrace>\<lambda>(s::'a state).
|
|
(bound_tcb_at ((=) None) t and valid_mdb and valid_objs) s \<rbrace>
|
|
suspend t
|
|
\<lbrace>\<lambda>rv. obj_at (Not \<circ> live0) t\<rbrace>"
|
|
apply (simp add: suspend_def set_thread_state_def set_object_def get_object_def)
|
|
(* avoid creating two copies of obj_at *)
|
|
supply hoare_vcg_if_split[wp_split del] if_splits[split del]
|
|
apply (wp | simp only: obj_at_exst_update)+
|
|
apply (simp add: obj_at_def)
|
|
apply (rule_tac Q="\<lambda>_. bound_tcb_at ((=) None) t" in hoare_strengthen_post)
|
|
supply hoare_vcg_if_split[wp_split]
|
|
apply wp
|
|
apply (auto simp: pred_tcb_def2)[1]
|
|
apply (simp flip: if_split)
|
|
apply wpsimp+
|
|
apply (simp add: pred_tcb_at_tcb_at)
|
|
done
|
|
end
|
|
|
|
definition bound_refs_of_tcb :: "'a state \<Rightarrow> machine_word \<Rightarrow> (machine_word \<times> reftype) set"
|
|
where
|
|
"bound_refs_of_tcb s t \<equiv> case kheap s t of
|
|
Some (TCB tcb) \<Rightarrow> tcb_bound_refs (tcb_bound_notification tcb)
|
|
| _ \<Rightarrow> {}"
|
|
|
|
lemma bound_refs_of_tcb_trans:
|
|
"bound_refs_of_tcb (trans_state f s) x = bound_refs_of_tcb s x"
|
|
by (clarsimp simp:bound_refs_of_tcb_def trans_state_def)
|
|
|
|
lemma cancel_all_invs_helper:
|
|
"\<lbrace>all_invs_but_sym_refs
|
|
and (\<lambda>s. (\<forall>x\<in>set q. ex_nonz_cap_to x s)
|
|
\<and> sym_refs (\<lambda>x. if x \<in> set q then {r \<in> state_refs_of s x. snd r = TCBBound}
|
|
else state_refs_of s x)
|
|
\<and> sym_refs (\<lambda>x. state_hyp_refs_of s x)
|
|
\<and> (\<forall>x\<in>set q. st_tcb_at (Not \<circ> (halted or awaiting_reply)) x s))\<rbrace>
|
|
mapM_x (\<lambda>t. do y \<leftarrow> set_thread_state t Structures_A.thread_state.Restart;
|
|
do_extended_op (tcb_sched_enqueue_ext t) od) q
|
|
\<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
apply (simp add: invs_def valid_state_def valid_pspace_def)
|
|
apply (rule mapM_x_inv_wp2)
|
|
apply (clarsimp simp: )
|
|
apply wp
|
|
apply (simp add:bound_refs_of_tcb_trans)
|
|
apply wp[1]
|
|
apply (rule hoare_pre, wp hoare_vcg_const_Ball_lift
|
|
valid_irq_node_typ sts_only_idle)
|
|
apply (rule sts_st_tcb_at_cases, simp)
|
|
apply (strengthen reply_cap_doesnt_exist_strg)
|
|
apply (auto simp: valid_tcb_state_def idle_no_ex_cap o_def if_split_asm
|
|
elim!: rsubst[where P=sym_refs] st_tcb_weakenE
|
|
intro!: ext)
|
|
done
|
|
|
|
|
|
lemma ep_no_bound_refs:
|
|
"ep_at p s \<Longrightarrow> {r \<in> state_refs_of s p. snd r = TCBBound} = {}"
|
|
by (clarsimp simp: obj_at_def state_refs_of_def refs_of_def is_ep ep_q_refs_of_def split: endpoint.splits)
|
|
|
|
lemma obj_at_conj_distrib:
|
|
"obj_at (\<lambda>ko. P ko \<and> Q ko) p s \<Longrightarrow> obj_at (\<lambda>ko. P ko) p s \<and> obj_at (\<lambda>ko. Q ko) p s"
|
|
by (auto simp:obj_at_def)
|
|
|
|
lemma ep_q_refs_of_no_ntfn_bound:
|
|
"(x, tp) \<in> ep_q_refs_of ep \<Longrightarrow> tp \<noteq> NTFNBound"
|
|
by (auto simp: ep_q_refs_of_def split:endpoint.splits)
|
|
|
|
lemma ep_q_refs_no_NTFNBound:
|
|
"(x, NTFNBound) \<notin> ep_q_refs_of ep"
|
|
by (clarsimp simp: ep_q_refs_of_def split:endpoint.splits)
|
|
|
|
lemma ep_list_tcb_at:
|
|
"\<lbrakk>ep_at p s; valid_objs s; state_refs_of s p = set q \<times> {k}; x \<in> set q \<rbrakk> \<Longrightarrow> tcb_at x s"
|
|
apply (erule (1) obj_at_valid_objsE)
|
|
apply (fastforce simp:is_ep valid_obj_def valid_ep_def state_refs_of_def split:endpoint.splits)
|
|
done
|
|
|
|
lemma tcb_at_no_ntfn_bound:
|
|
"\<lbrakk> valid_objs s; tcb_at x s \<rbrakk> \<Longrightarrow> (t, NTFNBound) \<notin> state_refs_of s x"
|
|
by (auto elim!: obj_at_valid_objsE
|
|
simp: state_refs_of_def is_tcb valid_obj_def tcb_bound_refs_def tcb_st_refs_of_def
|
|
split:thread_state.splits option.splits)
|
|
|
|
lemma ep_no_ntfn_bound:
|
|
"\<lbrakk>is_ep ko; refs_of ko = set q \<times> {NTFNBound}; y \<in> set q \<rbrakk> \<Longrightarrow> False"
|
|
apply (subst (asm) set_eq_iff)
|
|
apply (drule_tac x="(y, NTFNBound)" in spec)
|
|
apply (clarsimp simp: refs_of_rev is_ep)
|
|
done
|
|
|
|
lemma cancel_all_ipc_invs_helper:
|
|
assumes x: "\<And>x ko. (x, symreftype k) \<in> refs_of ko
|
|
\<Longrightarrow> (refs_of ko = {(x, symreftype k)} \<or>
|
|
(\<exists>y. refs_of ko = {(x, symreftype k), (y, TCBBound)}))"
|
|
shows
|
|
"\<lbrace>invs and obj_at (\<lambda>ko. is_ep ko \<and> refs_of ko = set q \<times> {k}) p\<rbrace>
|
|
do y \<leftarrow> set_endpoint p Structures_A.endpoint.IdleEP;
|
|
y \<leftarrow> mapM_x (\<lambda>t. do y \<leftarrow> set_thread_state t Structures_A.thread_state.Restart;
|
|
do_extended_op (tcb_sched_action (tcb_sched_enqueue) t) od) q;
|
|
do_extended_op reschedule_required
|
|
od \<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
apply (subst bind_assoc[symmetric])
|
|
apply (rule hoare_seq_ext)
|
|
apply wp
|
|
apply simp
|
|
apply (rule hoare_pre)
|
|
apply (wp cancel_all_invs_helper hoare_vcg_const_Ball_lift valid_irq_node_typ valid_ioports_lift)
|
|
apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_ep_def live_def)
|
|
apply (rule conjI)
|
|
apply (fastforce simp: live_def is_ep_def elim!: obj_at_weakenE split: kernel_object.splits)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (drule(1) sym_refs_obj_atD, clarsimp)
|
|
apply (drule(1) bspec, erule(1) if_live_then_nonz_capD)
|
|
apply (rule refs_of_live, clarsimp)
|
|
apply (rule conjI[rotated])
|
|
apply (subgoal_tac "\<exists>ep. ko_at (Endpoint ep) p s", clarsimp)
|
|
apply (subgoal_tac "\<exists>rt. (x, rt) \<in> ep_q_refs_of ep", clarsimp)
|
|
apply (fastforce elim!: ep_queued_st_tcb_at)
|
|
apply (clarsimp simp: obj_at_def is_ep_def)+
|
|
apply (case_tac ko, simp_all)
|
|
apply (frule(1) sym_refs_obj_atD)
|
|
apply (frule obj_at_state_refs_ofD)
|
|
apply (clarsimp dest!:obj_at_conj_distrib)
|
|
apply (thin_tac "obj_at (\<lambda>ko. refs_of ko = set q \<times> {k}) p s")
|
|
apply (erule delta_sym_refs)
|
|
apply (clarsimp simp: if_split_asm)+
|
|
apply (safe)
|
|
apply (fastforce dest!:symreftype_inverse' ep_no_ntfn_bound)
|
|
apply (clarsimp dest!: symreftype_inverse')
|
|
apply (frule (3) ep_list_tcb_at)
|
|
apply (frule_tac t=y in tcb_at_no_ntfn_bound, simp+)
|
|
apply (clarsimp dest!: symreftype_inverse')
|
|
apply (frule (3) ep_list_tcb_at)
|
|
apply (clarsimp simp: obj_at_def is_tcb is_ep)
|
|
apply (fastforce dest!: obj_at_state_refs_ofD x)
|
|
apply (fastforce dest!: obj_at_state_refs_ofD x)
|
|
apply (fastforce dest!: symreftype_inverse' ep_no_ntfn_bound)
|
|
apply (clarsimp)
|
|
apply (fastforce dest!: symreftype_inverse' ep_no_ntfn_bound)
|
|
done
|
|
|
|
lemma cancel_all_ipc_invs:
|
|
"\<lbrace>invs\<rbrace> cancel_all_ipc epptr \<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
apply (simp add: cancel_all_ipc_def)
|
|
apply (rule hoare_seq_ext [OF _ get_simple_ko_sp])
|
|
apply (case_tac ep, simp_all add: get_ep_queue_def)
|
|
apply (wp, fastforce)
|
|
apply (rule hoare_pre, rule cancel_all_ipc_invs_helper[where k=EPSend])
|
|
apply (fastforce simp: refs_of_rev tcb_bound_refs_def split: option.splits)
|
|
apply (clarsimp elim!: obj_at_weakenE simp: is_ep)
|
|
apply (rule hoare_pre, rule cancel_all_ipc_invs_helper[where k=EPRecv])
|
|
apply (fastforce simp: refs_of_rev tcb_bound_refs_def split: option.splits)
|
|
apply (clarsimp elim!: obj_at_weakenE simp: is_ep)
|
|
done
|
|
|
|
lemma ntfn_q_refs_no_NTFNBound:
|
|
"(x, NTFNBound) \<notin> ntfn_q_refs_of ntfn"
|
|
by (auto simp: ntfn_q_refs_of_def split:ntfn.splits)
|
|
|
|
lemma ntfn_q_refs_no_TCBBound:
|
|
"(x, TCBBound) \<notin> ntfn_q_refs_of ntfn"
|
|
by (auto simp: ntfn_q_refs_of_def split:ntfn.splits)
|
|
|
|
lemma ntfn_bound_tcb_get_set[simp]:
|
|
"ntfn_bound_tcb (ntfn_set_bound_tcb ntfn ntfn') = ntfn'"
|
|
by auto
|
|
|
|
lemma ntfn_obj_tcb_get_set[simp]:
|
|
"ntfn_obj (ntfn_set_bound_tcb ntfn ntfn') = ntfn_obj ntfn"
|
|
by auto
|
|
|
|
lemma valid_ntfn_set_bound_None:
|
|
"valid_ntfn ntfn s \<Longrightarrow> valid_ntfn (ntfn_set_bound_tcb ntfn None) s"
|
|
by (auto simp: valid_ntfn_def split:ntfn.splits)
|
|
|
|
lemma ntfn_bound_tcb_at:
|
|
"\<lbrakk>sym_refs (state_refs_of s); valid_objs s; kheap s ntfnptr = Some (Notification ntfn);
|
|
ntfn_bound_tcb ntfn = Some tcbptr; P (Some ntfnptr)\<rbrakk>
|
|
\<Longrightarrow> bound_tcb_at P tcbptr s"
|
|
apply (drule_tac x=ntfnptr in sym_refsD[rotated])
|
|
apply (fastforce simp: state_refs_of_def)
|
|
apply (auto simp: pred_tcb_at_def obj_at_def valid_obj_def valid_ntfn_def is_tcb
|
|
state_refs_of_def refs_of_rev
|
|
simp del: refs_of_simps
|
|
elim!: valid_objsE)
|
|
done
|
|
|
|
lemma bound_tcb_bound_notification_at:
|
|
"\<lbrakk>sym_refs (state_refs_of s); valid_objs s; kheap s ntfnptr = Some (Notification ntfn);
|
|
bound_tcb_at (\<lambda>ptr. ptr = (Some ntfnptr)) tcbptr s \<rbrakk>
|
|
\<Longrightarrow> ntfn_bound_tcb ntfn = Some tcbptr"
|
|
apply (drule_tac x=tcbptr in sym_refsD[rotated])
|
|
apply (fastforce simp: state_refs_of_def pred_tcb_at_def obj_at_def)
|
|
apply (auto simp: pred_tcb_at_def obj_at_def valid_obj_def valid_ntfn_def is_tcb
|
|
state_refs_of_def refs_of_rev
|
|
simp del: refs_of_simps
|
|
elim!: valid_objsE)
|
|
done
|
|
|
|
lemma unbind_notification_invs:
|
|
shows "\<lbrace>invs\<rbrace> unbind_notification t \<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
apply (simp add: unbind_notification_def invs_def valid_state_def valid_pspace_def)
|
|
apply (rule hoare_seq_ext [OF _ gbn_sp])
|
|
apply (case_tac ntfnptr, clarsimp, wp, simp)
|
|
apply clarsimp
|
|
apply (rule hoare_seq_ext [OF _ get_simple_ko_sp])
|
|
apply (wp valid_irq_node_typ set_simple_ko_valid_objs valid_ioports_lift
|
|
| clarsimp split del: if_split)+
|
|
apply (intro conjI impI;
|
|
(match conclusion in "sym_refs r" for r \<Rightarrow> \<open>-\<close>
|
|
| auto elim!: obj_at_weakenE obj_at_valid_objsE if_live_then_nonz_capD2
|
|
simp: live_def valid_ntfn_set_bound_None is_ntfn valid_obj_def
|
|
)?)
|
|
apply (clarsimp simp: if_split)
|
|
apply (rule delta_sym_refs, assumption)
|
|
apply (fastforce simp: obj_at_def is_tcb
|
|
dest!: pred_tcb_at_tcb_at ko_at_state_refs_ofD
|
|
split: if_split_asm)
|
|
apply (clarsimp split: if_split_asm)
|
|
apply (frule pred_tcb_at_tcb_at)
|
|
apply (frule_tac p=t in obj_at_ko_at, clarsimp)
|
|
apply (subst (asm) ko_at_state_refs_ofD, assumption)
|
|
apply (fastforce simp: obj_at_def is_tcb ntfn_q_refs_no_NTFNBound tcb_at_no_ntfn_bound refs_of_rev
|
|
tcb_ntfn_is_bound_def
|
|
dest!: pred_tcb_at_tcb_at bound_tcb_at_state_refs_ofD)
|
|
apply (subst (asm) ko_at_state_refs_ofD, assumption)
|
|
apply (fastforce simp: ntfn_bound_refs_def obj_at_def ntfn_q_refs_no_TCBBound
|
|
elim!: pred_tcb_weakenE
|
|
dest!: bound_tcb_bound_notification_at refs_in_ntfn_bound_refs symreftype_inverse'
|
|
split: option.splits)
|
|
done
|
|
|
|
crunch bound_tcb_at[wp]: cancel_all_signals "bound_tcb_at P t"
|
|
(wp: mapM_x_wp_inv)
|
|
|
|
|
|
lemma waiting_ntfn_list_tcb_at:
|
|
"\<lbrakk>valid_objs s; ko_at (Notification ntfn) ntfnptr s; ntfn_obj ntfn = WaitingNtfn x\<rbrakk> \<Longrightarrow> \<forall>t \<in> set x. tcb_at t s"
|
|
by (fastforce elim!: obj_at_valid_objsE simp:valid_obj_def valid_ntfn_def)
|
|
|
|
lemma tcb_at_ko_at:
|
|
"tcb_at p s \<Longrightarrow> \<exists>tcb. ko_at (TCB tcb) p s"
|
|
by (fastforce simp: obj_at_def is_tcb)
|
|
|
|
lemma tcb_state_refs_no_tcb:
|
|
"\<lbrakk>valid_objs s; tcb_at y s; (x, ref) \<in> state_refs_of s y\<rbrakk> \<Longrightarrow> ~ tcb_at x s"
|
|
apply (clarsimp simp: ko_at_state_refs_ofD dest!: tcb_at_ko_at)
|
|
apply (erule (1) obj_at_valid_objsE)
|
|
apply (clarsimp simp: is_tcb valid_obj_def)
|
|
apply (erule disjE)
|
|
apply (clarsimp simp: tcb_st_refs_of_def valid_tcb_def valid_tcb_state_def obj_at_def is_ep is_ntfn
|
|
split:thread_state.splits)
|
|
apply (clarsimp simp: tcb_bound_refs_def valid_tcb_def obj_at_def is_ntfn
|
|
split:option.splits)
|
|
done
|
|
|
|
lemma cancel_all_signals_invs:
|
|
"\<lbrace>invs\<rbrace> cancel_all_signals ntfnptr \<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
apply (simp add: cancel_all_signals_def)
|
|
apply (rule hoare_seq_ext [OF _ get_simple_ko_sp])
|
|
apply (rule hoare_pre)
|
|
apply (wp cancel_all_invs_helper set_simple_ko_valid_objs valid_irq_node_typ
|
|
hoare_vcg_const_Ball_lift valid_ioports_lift
|
|
| wpc
|
|
| simp add: live_def)+
|
|
apply (clarsimp simp: invs_def valid_state_def valid_pspace_def)
|
|
apply (rule conjI)
|
|
apply (fastforce simp: valid_obj_def valid_ntfn_def elim!: obj_at_valid_objsE)
|
|
apply (rule conjI)
|
|
apply (fastforce simp: live_def elim!: if_live_then_nonz_capD)
|
|
apply (rule conjI)
|
|
apply (fastforce simp: is_ntfn elim!: ko_at_weakenE)
|
|
apply (rule conjI)
|
|
apply (fastforce simp: st_tcb_at_refs_of_rev
|
|
dest: bspec sym_refs_ko_atD
|
|
elim: st_tcb_ex_cap)
|
|
apply (rule conjI[rotated])
|
|
apply (fastforce elim!: ntfn_queued_st_tcb_at)
|
|
|
|
apply (rule delta_sym_refs, assumption)
|
|
apply (fastforce dest!: refs_in_ntfn_bound_refs ko_at_state_refs_ofD
|
|
split: if_split_asm)
|
|
apply (clarsimp split:if_split_asm)
|
|
apply (fastforce dest: waiting_ntfn_list_tcb_at refs_in_ntfn_bound_refs
|
|
simp: obj_at_def is_tcb_def)
|
|
apply (rule conjI)
|
|
apply (fastforce dest: refs_in_ntfn_bound_refs symreftype_inverse')
|
|
apply (frule (2) waiting_ntfn_list_tcb_at)
|
|
apply (fastforce simp: st_tcb_at_refs_of_rev refs_in_tcb_bound_refs
|
|
dest: bspec sym_refs_ko_atD st_tcb_at_state_refs_ofD)
|
|
apply (fastforce simp: ntfn_bound_refs_def valid_obj_def valid_ntfn_def refs_of_rev
|
|
dest!: symreftype_inverse' ko_at_state_refs_ofD
|
|
split: option.splits
|
|
elim!: obj_at_valid_objsE)
|
|
done
|
|
|
|
lemma cancel_all_unlive_helper:
|
|
"\<lbrace>obj_at (\<lambda>obj. \<not> live obj \<and> (\<forall>tcb. obj \<noteq> TCB tcb)) ptr\<rbrace>
|
|
mapM_x (\<lambda>t. do y \<leftarrow> set_thread_state t Structures_A.Restart;
|
|
do_extended_op (tcb_sched_enqueue_ext t) od) q
|
|
\<lbrace>\<lambda>rv. obj_at (Not \<circ> live) ptr\<rbrace>"
|
|
apply (rule hoare_strengthen_post [OF mapM_x_wp'])
|
|
apply (simp add: set_thread_state_def set_object_def get_object_def)
|
|
apply (wp | simp only: obj_at_exst_update)+
|
|
apply (clarsimp dest!: get_tcb_SomeD)
|
|
apply (clarsimp simp: obj_at_def)
|
|
apply (clarsimp elim!: obj_at_weakenE)
|
|
done
|
|
|
|
|
|
lemma cancel_all_ipc_unlive[wp]:
|
|
"\<lbrace>\<top>\<rbrace> cancel_all_ipc ptr \<lbrace>\<lambda> rv. obj_at (Not \<circ> live) ptr\<rbrace>"
|
|
apply (simp add: cancel_all_ipc_def)
|
|
apply (rule hoare_seq_ext [OF _ get_simple_ko_sp])
|
|
apply (case_tac ep, simp_all add: set_simple_ko_def get_ep_queue_def)
|
|
apply wp
|
|
apply (clarsimp simp: live_def elim!: obj_at_weakenE)
|
|
apply (wp cancel_all_unlive_helper set_object_at_obj3 | simp only: obj_at_exst_update)+
|
|
apply (clarsimp simp: live_def)
|
|
apply (wp cancel_all_unlive_helper set_object_at_obj3 | simp only: obj_at_exst_update)+
|
|
apply (clarsimp simp: live_def)
|
|
done
|
|
|
|
|
|
(* This lemma should be sufficient provided that each notification object is unbound BEFORE the 'cancel_all_signals' function is invoked. TODO: Check the abstract specification and the C and Haskell implementations that this is indeed the case. *)
|
|
lemma cancel_all_signals_unlive[wp]:
|
|
"\<lbrace>\<lambda>s. obj_at (\<lambda>ko. \<exists>ntfn. ko = Notification ntfn \<and> ntfn_bound_tcb ntfn = None) ntfnptr s\<rbrace>
|
|
cancel_all_signals ntfnptr
|
|
\<lbrace>\<lambda> rv. obj_at (Not \<circ> live) ntfnptr\<rbrace>"
|
|
apply (simp add: cancel_all_signals_def)
|
|
apply (rule hoare_seq_ext [OF _ get_simple_ko_sp])
|
|
apply (rule hoare_pre)
|
|
apply (wp
|
|
| wpc
|
|
| simp add: unbind_maybe_notification_def)+
|
|
apply (rule_tac Q="\<lambda>_. obj_at (is_ntfn and Not \<circ> live) ntfnptr" in hoare_post_imp)
|
|
apply (fastforce elim: obj_at_weakenE)
|
|
apply (wp mapM_x_wp' sts_obj_at_impossible
|
|
| simp add: is_ntfn)+
|
|
apply (simp add: set_simple_ko_def)
|
|
apply (wp get_object_wp obj_set_prop_at)
|
|
apply (auto simp: live_def pred_tcb_at_def obj_at_def)
|
|
done
|
|
|
|
|
|
crunch cte_wp_at[wp]: cancel_all_ipc "cte_wp_at P p"
|
|
(wp: crunch_wps mapM_x_wp)
|
|
|
|
crunch cte_wp_at[wp]: cancel_all_signals "cte_wp_at P p"
|
|
(wp: crunch_wps mapM_x_wp thread_set_cte_wp_at_trivial
|
|
simp: tcb_cap_cases_def)
|
|
|
|
lemma cancel_badged_sends_filterM_helper':
|
|
"\<forall>ys.
|
|
\<lbrace>\<lambda>s. all_invs_but_sym_refs s \<and> sym_refs (state_hyp_refs_of s) \<and> distinct (xs @ ys) \<and> ep_at epptr s
|
|
\<and> ex_nonz_cap_to epptr s
|
|
\<and> sym_refs ((state_refs_of s) (epptr := ((set (xs @ ys)) \<times> {EPSend})))
|
|
\<and> (\<forall>x \<in> set (xs @ ys). {r \<in> state_refs_of s x. snd r \<noteq> TCBBound} = {(epptr, TCBBlockedSend)})\<rbrace>
|
|
filterM (\<lambda>t. do st \<leftarrow> get_thread_state t;
|
|
if blocking_ipc_badge st = badge
|
|
then do y \<leftarrow> set_thread_state t Structures_A.thread_state.Restart;
|
|
y \<leftarrow> do_extended_op (tcb_sched_action action t);
|
|
return False
|
|
od
|
|
else return True
|
|
od) xs
|
|
\<lbrace>\<lambda>rv s. all_invs_but_sym_refs s \<and> sym_refs (state_hyp_refs_of s)
|
|
\<and> ep_at epptr s \<and> (\<forall>x \<in> set (xs @ ys). tcb_at x s)
|
|
\<and> ex_nonz_cap_to epptr s
|
|
\<and> (\<forall>y \<in> set ys. {r \<in> state_refs_of s y. snd r \<noteq> TCBBound} = {(epptr, TCBBlockedSend)})
|
|
\<and> distinct rv \<and> distinct (xs @ ys) \<and> (set rv \<subseteq> set xs)
|
|
\<and> sym_refs ((state_refs_of s) (epptr := ((set rv \<union> set ys) \<times> {EPSend})))\<rbrace>"
|
|
apply (rule rev_induct[where xs=xs])
|
|
apply (rule allI, simp)
|
|
apply wp
|
|
apply clarsimp
|
|
apply (drule(1) bspec, drule singleton_eqD, clarsimp, drule state_refs_of_elemD)
|
|
apply (clarsimp simp: st_tcb_at_refs_of_rev pred_tcb_at_def is_tcb
|
|
elim!: obj_at_weakenE)
|
|
apply (clarsimp simp: filterM_append bind_assoc simp del: set_append distinct_append)
|
|
apply (drule spec, erule hoare_seq_ext[rotated])
|
|
apply (rule hoare_seq_ext [OF _ gts_sp])
|
|
apply (rule hoare_pre,
|
|
wpsimp wp: valid_irq_node_typ sts_only_idle hoare_vcg_const_Ball_lift)
|
|
apply (clarsimp simp: valid_tcb_state_def)
|
|
apply (rule conjI[rotated])
|
|
apply blast
|
|
apply clarsimp
|
|
apply (thin_tac "obj_at f epptr s" for f s)
|
|
apply (thin_tac "tcb_at x s" for x s)
|
|
apply (thin_tac "sym_refs (state_hyp_refs_of s)" for s)
|
|
apply (frule singleton_eqD, clarify, drule state_refs_of_elemD)
|
|
apply (frule(1) if_live_then_nonz_capD)
|
|
apply (rule refs_of_live, clarsimp)
|
|
apply (clarsimp simp: st_tcb_at_refs_of_rev)
|
|
apply (clarsimp simp: pred_tcb_def2 valid_idle_def)
|
|
apply (rule conjI, clarsimp)
|
|
apply (rule conjI, clarsimp)
|
|
apply (drule(1) valid_reply_capsD, clarsimp simp: st_tcb_def2)
|
|
apply (rule conjI, blast)
|
|
apply (rule conjI, blast)
|
|
apply (erule delta_sym_refs)
|
|
apply (auto dest!: get_tcb_ko_atD ko_at_state_refs_ofD symreftype_inverse'
|
|
refs_in_tcb_bound_refs
|
|
split: if_split_asm)[2]
|
|
done
|
|
|
|
lemmas cancel_badged_sends_filterM_helper
|
|
= spec [where x=Nil, OF cancel_badged_sends_filterM_helper', simplified]
|
|
|
|
lemma cancel_badged_sends_invs_helper:
|
|
"{r. snd r \<noteq> TCBBound \<and>
|
|
(r \<in> tcb_st_refs_of ts \<or> r \<in> tcb_bound_refs ntfnptr)} =
|
|
tcb_st_refs_of ts"
|
|
by (auto simp add: tcb_st_refs_of_def tcb_bound_refs_def split: thread_state.splits option.splits)
|
|
|
|
lemma cancel_badged_sends_invs[wp]:
|
|
"\<lbrace>invs\<rbrace> cancel_badged_sends epptr badge \<lbrace>\<lambda>rv. invs\<rbrace>"
|
|
apply (simp add: cancel_badged_sends_def)
|
|
apply (rule hoare_seq_ext [OF _ get_simple_ko_sp])
|
|
apply (case_tac ep; simp)
|
|
apply wpsimp
|
|
apply (simp add: invs_def valid_state_def valid_pspace_def)
|
|
apply (wpsimp wp: valid_irq_node_typ valid_ioports_lift)
|
|
apply (simp add: fun_upd_def[symmetric] ep_redux_simps ep_at_def2[symmetric, simplified]
|
|
cong: list.case_cong)
|
|
apply (rule hoare_strengthen_post,
|
|
rule cancel_badged_sends_filterM_helper[where epptr=epptr])
|
|
apply (auto intro:obj_at_weakenE)[1]
|
|
apply (wpsimp wp: valid_irq_node_typ set_endpoint_ep_at valid_ioports_lift)
|
|
apply (clarsimp simp: valid_ep_def conj_comms)
|
|
apply (subst obj_at_weakenE, simp, fastforce)
|
|
apply (clarsimp simp: is_ep_def)
|
|
apply (frule(1) sym_refs_ko_atD, clarsimp)
|
|
apply (frule(1) if_live_then_nonz_capD, (clarsimp simp: live_def)+)
|
|
apply (erule(1) obj_at_valid_objsE)
|
|
apply (clarsimp simp: valid_obj_def valid_ep_def st_tcb_at_refs_of_rev)
|
|
apply (simp add: fun_upd_idem obj_at_def is_ep_def | subst fun_upd_def[symmetric])+
|
|
apply (clarsimp, drule(1) bspec)
|
|
apply (drule st_tcb_at_state_refs_ofD)
|
|
apply (clarsimp simp only: cancel_badged_sends_invs_helper Un_iff, clarsimp)
|
|
apply (simp add: set_eq_subset)
|
|
apply wpsimp
|
|
done
|
|
|
|
(* FIXME rule_format? *)
|
|
lemma real_cte_emptyable_strg:
|
|
"real_cte_at p s \<longrightarrow> emptyable p s"
|
|
by (clarsimp simp: emptyable_def obj_at_def is_tcb is_cap_table)
|
|
|
|
end
|