826 lines
31 KiB
Plaintext
826 lines
31 KiB
Plaintext
(*
|
|
* 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 Syscall_S
|
|
imports Separation
|
|
begin
|
|
|
|
context begin interpretation Arch . (*FIXME: arch_split*)
|
|
|
|
lemma syscall_bisim:
|
|
assumes bs:
|
|
"bisim (fr \<oplus> r_flt_rel) P P' m_flt m_flt'"
|
|
"\<And>flt flt'. fr flt flt' \<Longrightarrow>
|
|
bisim r (P_flt flt) (P'_flt flt') (h_flt flt) (h_flt' flt')"
|
|
"\<And>rv rv'. r_flt_rel rv rv' \<Longrightarrow>
|
|
bisim (ser \<oplus> r_err_rel rv rv')
|
|
(P_no_flt rv) (P'_no_flt rv')
|
|
(m_err rv) (m_err' rv')"
|
|
"\<And>rv rv' err err'. \<lbrakk>r_flt_rel rv rv'; ser err err'\<rbrakk>
|
|
\<Longrightarrow> bisim r (P_err rv err)
|
|
(P'_err rv' err') (h_err err) (h_err' err')"
|
|
"\<And>rvf rvf' rve rve'. \<lbrakk>r_flt_rel rvf rvf'; r_err_rel rvf rvf' rve rve'\<rbrakk>
|
|
\<Longrightarrow> bisim (f \<oplus> r)
|
|
(P_no_err rvf rve) (P'_no_err rvf' rve')
|
|
(m_fin rve) (m_fin' rve')"
|
|
assumes wp: "\<And>rv. \<lbrace>Q_no_flt rv\<rbrace> m_err rv \<lbrace>P_no_err rv\<rbrace>, \<lbrace>P_err rv\<rbrace>"
|
|
"\<And>rv'. \<lbrace>Q'_no_flt rv'\<rbrace> m_err' rv' \<lbrace>P'_no_err rv'\<rbrace>,\<lbrace>P'_err rv'\<rbrace>"
|
|
"\<lbrace>Q\<rbrace> m_flt \<lbrace>\<lambda>rv. P_no_flt rv and Q_no_flt rv\<rbrace>, \<lbrace>P_flt\<rbrace>"
|
|
"\<lbrace>Q'\<rbrace> m_flt' \<lbrace>\<lambda>rv. P'_no_flt rv and Q'_no_flt rv\<rbrace>, \<lbrace>P'_flt\<rbrace>"
|
|
|
|
shows "bisim (f \<oplus> r) (P and Q) (P' and Q')
|
|
(syscall m_flt h_flt m_err h_err m_fin)
|
|
(syscall m_flt' h_flt' m_err' h_err' m_fin')"
|
|
apply (simp add: syscall_def liftE_bindE)
|
|
apply (rule bisim_split_bind_case_sum)
|
|
apply (rule bs)
|
|
apply simp
|
|
apply (rule bs)
|
|
apply simp
|
|
apply (simp add: liftE_bindE)
|
|
apply (rule bisim_split_bind_case_sum)
|
|
apply (erule bs)
|
|
apply simp
|
|
apply (erule bs)
|
|
apply simp
|
|
apply (erule(1) bs)
|
|
apply (rule wp)+
|
|
done
|
|
|
|
lemma dc_refl: "dc r r" by simp
|
|
|
|
|
|
lemma bisim_catch_faults_r:
|
|
assumes bs: "\<And>x. bisim_underlying sr r P (P' x) a (m x)"
|
|
and flt: "\<lbrace>S\<rbrace> b \<lbrace>\<lambda>_ _. False\<rbrace>, \<lbrace>P'\<rbrace>"
|
|
and pure: "\<And>s. \<lbrace>S' and op = s\<rbrace> b \<lbrace>\<lambda>_. op = s\<rbrace>"
|
|
and db: "not_empty Pd b"
|
|
shows "bisim_underlying sr r P (S and S' and Pd) a (b <catch> m)"
|
|
unfolding catch_def
|
|
apply (rule bisim_symb_exec_r [OF _ flt [unfolded validE_def] pure db] )
|
|
apply (case_tac x)
|
|
apply simp
|
|
apply (rule bs)
|
|
apply simp
|
|
apply (rule bisim_underlyingI, simp_all)[1]
|
|
done
|
|
|
|
lemma bisim_validE_R:
|
|
assumes ac: "bisim_underlying (op =) (dc \<oplus> op =) P P' a a'"
|
|
and rl: "\<lbrace>Q\<rbrace> a \<lbrace>S\<rbrace>, -"
|
|
shows "\<lbrace>P and P' and Q\<rbrace> a' \<lbrace>S\<rbrace>, -"
|
|
using ac rl
|
|
unfolding bisim_underlying_def valid_def validE_def validE_R_def
|
|
by (fastforce simp: split_def split: sum.splits)
|
|
|
|
lemma bisim_validE_R2:
|
|
assumes ac: "bisim_underlying (op =) (op =) P P' a a'"
|
|
and rl: "\<lbrace>Q\<rbrace> a' \<lbrace>S\<rbrace>, -"
|
|
shows "\<lbrace>P and P' and Q\<rbrace> a \<lbrace>S\<rbrace>, -"
|
|
using ac rl
|
|
unfolding bisim_underlying_def valid_def validE_def validE_R_def
|
|
by (fastforce simp: split_def split: sum.splits)
|
|
|
|
|
|
lemma bisim_rab:
|
|
"bisim (dc \<oplus> op =) \<top> (\<lambda>s. separate_cnode_cap (caps_of_state s) cap \<and> valid_cap cap s)
|
|
(doE
|
|
_ \<leftarrow> whenE (length cref < word_bits) (throwError undefined);
|
|
case cap of
|
|
CNodeCap p bits guard \<Rightarrow> if guard \<le> cref then
|
|
returnOk ((p, take bits (drop (length guard) cref)), drop (bits + length guard) cref)
|
|
else
|
|
(throwError undefined)
|
|
| _ \<Rightarrow> throwError undefined
|
|
odE)
|
|
(resolve_address_bits (cap, cref))"
|
|
unfolding resolve_address_bits_def
|
|
apply (cases "length cref < word_bits")
|
|
apply (auto intro!: bisim_underlyingI
|
|
elim!: separate_cnode_capE
|
|
simp: whenE_def in_monad Bex_def in_bindE word_bits_def in_get_cap_cte_wp_at cte_wp_at_caps_of_state
|
|
simp del: add_is_0 split: split_if_asm)[1]
|
|
apply simp
|
|
apply (rule bisim_underlyingI)
|
|
apply (clarsimp )
|
|
apply (erule separate_cnode_capE)
|
|
apply (fastforce simp: word_bits_def in_monad )
|
|
apply (case_tac "\<not> guard \<le> cref")
|
|
apply (clarsimp simp: in_monad Bex_def)
|
|
apply (drule (2) valid_sep_cap_not_cnode [where cref = cref])
|
|
apply simp
|
|
apply (fastforce simp: in_monad Bex_def in_bindE word_bits_def in_get_cap_cte_wp_at cte_wp_at_caps_of_state whenE_def
|
|
simp del: add_is_0 split: split_if_asm)
|
|
apply clarsimp
|
|
apply (erule separate_cnode_capE)
|
|
apply (fastforce simp: word_bits_def in_monad)
|
|
apply (drule (2) valid_sep_cap_not_cnode [where cref = cref])
|
|
apply simp
|
|
apply (fastforce simp: in_monad Bex_def in_bindE word_bits_def in_get_cap_cte_wp_at cte_wp_at_caps_of_state whenE_def
|
|
simp del: add_is_0 split: split_if_asm)
|
|
done
|
|
|
|
|
|
lemma lsft_sep:
|
|
"\<lbrace>separate_state and valid_objs\<rbrace> lookup_slot_for_thread tcb cptr \<lbrace>\<lambda>rv s. \<forall>cap. caps_of_state s (fst rv) = Some cap \<longrightarrow> separate_cap cap\<rbrace>, -"
|
|
unfolding lookup_slot_for_thread_def
|
|
apply wp
|
|
apply (rule bisim_validE_R)
|
|
apply (rule bisim_rab)
|
|
apply (wpc | wp whenE_throwError_wp)+
|
|
apply (fastforce elim: separate_cnode_capE dest: separate_state_get_tcbD objs_valid_tcb_ctable)
|
|
done
|
|
|
|
lemma get_cap_wp':
|
|
"\<lbrace>\<lambda>s. \<forall>cap. caps_of_state s p = Some cap \<longrightarrow> Q cap s\<rbrace> get_cap p \<lbrace>Q\<rbrace>"
|
|
apply (wp get_cap_wp)
|
|
apply (simp add: cte_wp_at_caps_of_state)
|
|
done
|
|
|
|
lemma lc_sep [wp]:
|
|
"\<lbrace>separate_state and valid_objs \<rbrace> lookup_cap tcb cptr \<lbrace>\<lambda>cap _. separate_cap cap\<rbrace>, -"
|
|
unfolding lookup_cap_def
|
|
apply (simp add: split_def)
|
|
apply (rule hoare_pre)
|
|
apply (wp get_cap_wp' lsft_sep)
|
|
apply simp
|
|
done
|
|
|
|
|
|
lemma not_empty_thread_get [wp]:
|
|
"not_empty (tcb_at p) (thread_get f p)"
|
|
unfolding thread_get_def
|
|
apply (rule not_empty_guard_imp)
|
|
apply (simp add: gets_the_def bind_assoc)
|
|
apply (wp )
|
|
apply (simp add: tcb_at_def)
|
|
done
|
|
|
|
lemma not_empty_throwError [wp]:
|
|
"not_empty \<top> (throwError e)"
|
|
unfolding not_empty_def throwError_def by (fastforce simp: return_def)
|
|
|
|
lemma not_empty_cap_fault_on_failure [wp]:
|
|
assumes d: "not_empty P m"
|
|
shows "not_empty P (cap_fault_on_failure a b m)"
|
|
unfolding cap_fault_on_failure_def
|
|
apply (simp add: handleE_def handleE'_def)
|
|
apply (rule not_empty_guard_imp)
|
|
apply (wp d | wpc | simp)+
|
|
done
|
|
|
|
lemma not_empty_splitE [wp_split]:
|
|
assumes da: "not_empty Pa a"
|
|
and db: "\<And>x. not_empty (Pb x) (b x)"
|
|
and v: "\<lbrace>Pb'\<rbrace> a \<lbrace>Pb\<rbrace>, -"
|
|
shows "not_empty (Pa and Pb') (a >>=E b)"
|
|
using v
|
|
apply (clarsimp simp: bindE_def validE_R_def validE_def)
|
|
apply (rule not_empty_split [OF da])
|
|
apply (rule not_empty_lift [OF db])
|
|
apply (erule hoare_post_imp [rotated])
|
|
apply (clarsimp split: sum.splits)
|
|
done
|
|
|
|
lemma not_empty_whenE_throwError [wp]:
|
|
"not_empty \<top> (whenE P (throwError e))"
|
|
by (simp add: whenE_def throwError_def return_def not_empty_def returnOk_def)
|
|
|
|
lemma not_empty_returnOk [wp]:
|
|
"not_empty \<top> (returnOk v)"
|
|
by (simp add: return_def not_empty_def returnOk_def)
|
|
|
|
lemma not_empty_if [wp_split]:
|
|
"\<lbrakk> not_empty Pt m; not_empty Pf m' \<rbrakk> \<Longrightarrow> not_empty (\<lambda>s. (b \<longrightarrow> Pt s) \<and> ( \<not> b \<longrightarrow> Pf s)) (if b then m else m')"
|
|
by (clarsimp split: split_if)
|
|
|
|
lemma not_empty_lsft:
|
|
shows "not_empty (tcb_at t and valid_objs and separate_state) (lookup_slot_for_thread t cptr)"
|
|
unfolding lookup_slot_for_thread_def
|
|
apply (simp add: gets_the_def bind_assoc)
|
|
apply (rule not_empty_guard_imp)
|
|
apply (wp bisim_not_empty [OF bisim_rab] | wpc)+
|
|
apply (fastforce simp: tcb_at_def elim: separate_cnode_capE dest: separate_state_get_tcbD objs_valid_tcb_ctable)
|
|
done
|
|
|
|
lemma not_empty_get_cap [wp]:
|
|
"not_empty (cte_at p) (get_cap p)"
|
|
unfolding not_empty_def
|
|
by (clarsimp simp: cte_at_def)
|
|
|
|
lemma not_empty_lc:
|
|
shows "not_empty (tcb_at t and valid_objs and separate_state) (lookup_cap t cptr)"
|
|
unfolding lookup_cap_def
|
|
apply (simp add: split_def)
|
|
apply (rule not_empty_guard_imp)
|
|
apply (wp not_empty_lsft)
|
|
apply simp
|
|
done
|
|
|
|
lemma not_empty_get [wp]:
|
|
"not_empty \<top> get"
|
|
unfolding not_empty_def get_def by simp
|
|
|
|
lemma not_empty_put [wp]:
|
|
"not_empty \<top> (put s)"
|
|
unfolding not_empty_def put_def by simp
|
|
|
|
lemma not_empty_set_object [wp]:
|
|
"not_empty \<top> (set_object p v)"
|
|
unfolding set_object_def
|
|
apply simp
|
|
apply (rule not_empty_guard_imp)
|
|
apply wp
|
|
apply simp
|
|
done
|
|
|
|
lemma not_empty_assert_opt [wp]:
|
|
"not_empty (\<lambda>_. v \<noteq> None) (assert_opt v)"
|
|
unfolding not_empty_def assert_opt_def
|
|
by (clarsimp simp: return_def)
|
|
|
|
lemma not_empty_thread_set [wp]:
|
|
"not_empty (tcb_at p) (thread_set f p)"
|
|
unfolding thread_set_def
|
|
apply (simp add: gets_the_def bind_assoc)
|
|
apply (rule not_empty_guard_imp)
|
|
apply wp
|
|
apply (simp add: tcb_at_def)
|
|
done
|
|
|
|
lemma not_empty_False:
|
|
"not_empty (\<lambda>_. False) m"
|
|
unfolding not_empty_def by simp
|
|
|
|
lemma not_empty_gen_asm:
|
|
assumes ne: "P \<Longrightarrow> not_empty R m"
|
|
shows "not_empty (R and (\<lambda>_. P)) m"
|
|
using ne unfolding not_empty_def by auto
|
|
|
|
lemmas bisim_refl' = bisim_refl [where P = \<top> and P' = \<top> and R = "op =", OF refl]
|
|
|
|
lemma send_fault_ipc_bisim:
|
|
"bisim op = \<top> (tcb_at tcb and valid_objs and separate_state)
|
|
(set_thread_state tcb Inactive) (send_fault_ipc tcb flt' <catch> handle_double_fault tcb flt')"
|
|
unfolding send_fault_ipc_def
|
|
apply (rule bisim_guard_imp)
|
|
apply (rule bisim_catch_faults_r [where S = "separate_state and valid_objs"])
|
|
apply (clarsimp simp: handle_double_fault_def)
|
|
apply (rule bisim_refl')
|
|
apply (simp add: Let_def)
|
|
apply (rule hoare_vcg_seqE)
|
|
apply (rule hoare_vcg_seqE)
|
|
apply wpc
|
|
apply wp
|
|
apply simp
|
|
apply (rule hoare_post_imp_R [OF lc_sep])
|
|
apply (clarsimp simp: separate_cap_def)
|
|
apply (wp | simp add: Let_def)+
|
|
apply (rule_tac P = "separate_cap handler_cap" in hoare_gen_asmE')
|
|
apply (erule separate_capE, simp_all)[1]
|
|
apply (wp | simp)+
|
|
apply clarsimp
|
|
apply assumption
|
|
-- "det_ont"
|
|
apply (simp add: Let_def cong: cap.case_cong)
|
|
apply (wp not_empty_lc)
|
|
apply (rule_tac P = "separate_cap xa" in not_empty_gen_asm)
|
|
apply (erule separate_capE, simp_all)[1]
|
|
apply wp
|
|
apply simp
|
|
done
|
|
|
|
lemma handle_fault_bisim:
|
|
"bisim op = \<top> (separate_state and tcb_at tcb and valid_objs) (handle_fault tcb flt) (Ipc_A.handle_fault tcb flt')"
|
|
unfolding handle_fault_def Ipc_A.handle_fault_def
|
|
apply (rule bisim_guard_imp)
|
|
apply (rule bisim_symb_exec_r [where Pe = \<top>])
|
|
apply simp
|
|
apply (rule send_fault_ipc_bisim)
|
|
apply wp
|
|
apply simp
|
|
apply (simp add: gets_the_def)
|
|
apply wp
|
|
apply (simp add: tcb_at_def)
|
|
done
|
|
|
|
lemmas bisim_throwError_dc = bisim_throwError [where f = dc, OF dc_refl]
|
|
|
|
lemma bisim_returnOk:
|
|
"R a b \<Longrightarrow> bisim (f \<oplus> R) \<top> \<top> (returnOk a) (returnOk b)"
|
|
apply (simp add: returnOk_def)
|
|
apply (rule bisim_return)
|
|
apply simp
|
|
done
|
|
|
|
lemma bisim_liftME_same:
|
|
assumes bs: "bisim (f \<oplus> op =) P P' m m'"
|
|
shows "bisim (f \<oplus> op =) P P' (liftME g m) (liftME g m')"
|
|
unfolding liftME_def
|
|
apply (rule bisim_guard_imp)
|
|
apply (rule bisim_splitE [OF bs])
|
|
apply simp
|
|
apply (rule bisim_returnOk)
|
|
apply simp
|
|
apply wp
|
|
apply simp+
|
|
done
|
|
|
|
lemma bisim_split_if:
|
|
"\<lbrakk> P \<Longrightarrow> bisim R Pt Pt' a a'; \<not> P \<Longrightarrow> bisim R Pf Pf' b b' \<rbrakk> \<Longrightarrow>
|
|
bisim R (\<lambda>s. (P \<longrightarrow> Pt s) \<and> (\<not> P \<longrightarrow> Pf s)) (\<lambda>s. (P \<longrightarrow> Pt' s) \<and> (\<not> P \<longrightarrow> Pf' s))
|
|
(if P then a else b) (if P then a' else b')"
|
|
by simp
|
|
|
|
lemma bisim_reflE:
|
|
"bisim (op = \<oplus> op =) \<top> \<top> a a"
|
|
apply (rule bisim_underlyingI)
|
|
apply (case_tac r, fastforce+)[1]
|
|
apply (case_tac r', fastforce+)[1]
|
|
done
|
|
|
|
lemma bisim_reflE_dc:
|
|
"bisim (dc \<oplus> op =) \<top> \<top> a a"
|
|
apply (rule bisim_underlyingI)
|
|
apply (case_tac r, fastforce+)[1]
|
|
apply (case_tac r', fastforce+)[1]
|
|
done
|
|
|
|
lemma decode_invocation_bisim:
|
|
"bisim (op = \<oplus> op =) \<top> (K (separate_cap cap))
|
|
(decode_invocation a b c d cap f) (Decode_A.decode_invocation a b c d cap f)"
|
|
unfolding decode_invocation_def Decode_A.decode_invocation_def
|
|
apply (rule bisim_guard_imp)
|
|
apply (rule bisim_separate_cap_cases [where cap = cap])
|
|
apply (simp split del: split_if)
|
|
apply (rule bisim_throwError, simp)
|
|
apply (simp split del: split_if)
|
|
apply (rule bisim_reflE)
|
|
apply (fastforce intro!: bisim_throwError bisim_returnOk simp: AllowRecv_def AllowSend_def)
|
|
apply simp
|
|
done
|
|
|
|
abbreviation
|
|
"separate_inv c \<equiv> \<exists>ptr badge. c = InvokeNotification ptr badge"
|
|
|
|
lemma perform_invocation_bisim:
|
|
"bisim (dc \<oplus> op =) \<top> (\<top> and K (separate_inv c))
|
|
(perform_invocation a b c) (Syscall_A.perform_invocation a b c)"
|
|
apply (rule bisim_gen_asm_r)
|
|
apply clarsimp
|
|
apply (rule bisim_reflE_dc)
|
|
done
|
|
|
|
lemmas bisim_split_reflE_eq = bisim_split_reflE [where R = "op =" and f = "op =", OF _ _ _ refl refl]
|
|
lemmas bisim_split_reflE_dc = bisim_split_reflE [where R = "op =" and f = "dc", OF _ _ _ dc_refl refl]
|
|
|
|
lemma decode_separate_inv:
|
|
"\<lbrace>\<top> and K ((\<forall>c \<in> set f. separate_cap (fst c)) \<and> (separate_cap cap))\<rbrace> Decode_A.decode_invocation a b c d cap f \<lbrace>\<lambda>rv s. separate_inv rv\<rbrace>, -"
|
|
unfolding Decode_A.decode_invocation_def
|
|
apply (rule hoare_gen_asmE)
|
|
apply clarify
|
|
apply (erule separate_capE, simp_all split del: split_if)
|
|
apply (rule hoare_pre, (wp | simp add: comp_def)+)[1]
|
|
apply (rule hoare_pre)
|
|
apply (wp | simp)+
|
|
done
|
|
|
|
lemma lcas_sep [wp]:
|
|
"\<lbrace>separate_state and valid_objs\<rbrace> lookup_cap_and_slot t v \<lbrace>\<lambda>rv s. separate_cap (fst rv)\<rbrace>, -"
|
|
apply (simp add: lookup_cap_and_slot_def split_def bind_assoc)
|
|
apply (rule hoare_pre)
|
|
apply (wp lsft_sep get_cap_wp'|simp)+
|
|
done
|
|
|
|
lemma lec_separate_caps:
|
|
"\<lbrace>separate_state and valid_objs\<rbrace> lookup_extra_caps t buffer ra \<lbrace>\<lambda>rv s. (\<forall>c\<in>set rv. separate_cap (fst c))\<rbrace>, -"
|
|
unfolding lookup_extra_caps_def
|
|
apply (wp mapME_set | simp)+
|
|
done
|
|
|
|
lemma handle_invocation_bisim:
|
|
"bisim (dc \<oplus> op =) \<top> (separate_state and valid_objs and cur_tcb) (handle_invocation c b) (Syscall_A.handle_invocation c b)"
|
|
unfolding handle_invocation_def Syscall_A.handle_invocation_def
|
|
apply (simp add: split_def)
|
|
apply (rule bisim_guard_imp)
|
|
apply (rule bisim_split_reflE_dc)+
|
|
apply (rule syscall_bisim)
|
|
apply (rule bisim_split_reflE_dc [where Q = "\<lambda>_. \<top>" and Q' = "\<lambda>_. \<top>"])+
|
|
apply (rule bisim_reflE_dc)
|
|
apply wp
|
|
apply (rule bisim_when [OF _ refl])
|
|
apply (rule handle_fault_bisim)
|
|
apply simp
|
|
apply (rule bisim_split_reflE_eq)
|
|
apply simp
|
|
apply (rule decode_invocation_bisim)
|
|
apply wp
|
|
apply (simp, rule bisim_refl')
|
|
apply simp
|
|
apply (rule bisim_split_reflE_dc)
|
|
apply (rule bisim_splitE_req)
|
|
apply (rule perform_invocation_bisim)
|
|
apply simp
|
|
apply (rule bisim_refl')
|
|
apply (wp | simp)+
|
|
apply (rule decode_separate_inv)
|
|
apply (wp lec_separate_caps | simp add: cur_tcb_def)+
|
|
done
|
|
|
|
lemma bisim_split_catch:
|
|
assumes bm: "bisim (f' \<oplus> r) Pn Pn' m m'"
|
|
and bc: "\<And>x x'. f' x x' \<Longrightarrow> bisim r (Pf x) (Pf' x') (c x) (c' x')"
|
|
and v1: "\<lbrace>P\<rbrace> m \<lbrace>\<lambda>_ _. True\<rbrace>, \<lbrace>Pf\<rbrace>"
|
|
and v2: "\<lbrace>P'\<rbrace> m' \<lbrace>\<lambda>_ _. True\<rbrace>, \<lbrace>Pf'\<rbrace>"
|
|
shows "bisim r (Pn and P) (Pn' and P') (m <catch> c) (m' <catch> c')"
|
|
unfolding catch_def
|
|
apply (rule bisim_split [where Q = "\<lambda>r s. case_sum (\<lambda>l. Pf l s) (\<lambda>_. True) r" and Q' = "\<lambda>r s. case_sum (\<lambda>l. Pf' l s) (\<lambda>_. True) r", OF bm, folded validE_def])
|
|
apply (case_tac ra)
|
|
apply clarsimp
|
|
apply (erule bc)
|
|
apply clarsimp
|
|
apply (rule bisim_return')
|
|
apply simp
|
|
apply (rule v1)
|
|
apply (rule v2)
|
|
done
|
|
|
|
lemma rel_sum_comb_eq:
|
|
"(op = \<oplus> op =) = (op =)"
|
|
apply (rule ext, rule ext)
|
|
apply (case_tac x)
|
|
apply auto
|
|
done
|
|
|
|
lemma bisim_split_catch_req:
|
|
assumes bm: "bisim (op = \<oplus> op =) Pn Pn' m m'"
|
|
and bc: "\<And>x. bisim op = (Pf x) (Pf' x) (c x) (c' x)"
|
|
and v1: "\<lbrace>P\<rbrace> m \<lbrace>\<lambda>_ _. True\<rbrace>, \<lbrace>\<lambda>r. Pf r and Pf' r\<rbrace>"
|
|
shows "bisim op = (Pn and P) Pn' (m <catch> c) (m' <catch> c')"
|
|
unfolding catch_def
|
|
apply (rule bisim_split_req [where Q = "\<lambda>r s. case_sum (\<lambda>l. Pf l s) (\<lambda>_. True) r" and Q' = "\<lambda>r s. case_sum (\<lambda>l. Pf' l s) (\<lambda>_. True) r"])
|
|
apply (rule bm [simplified rel_sum_comb_eq])
|
|
apply (case_tac r)
|
|
apply clarsimp
|
|
apply (rule bc)
|
|
apply clarsimp
|
|
apply (rule bisim_return')
|
|
apply simp
|
|
apply (rule hoare_post_imp [OF _ v1 [unfolded validE_def]])
|
|
apply (clarsimp split: sum.split_asm)
|
|
done
|
|
|
|
lemma bisim_injection:
|
|
assumes x: "t = injection_handler fn"
|
|
assumes y: "t' = injection_handler fn'"
|
|
assumes z: "\<And>ft ft'. f' ft ft' \<Longrightarrow> f (fn ft) (fn' ft')"
|
|
shows "bisim (f' \<oplus> r) P P' m m'
|
|
\<Longrightarrow> bisim (f \<oplus> r) P P' (t m) (t' m')"
|
|
apply (simp add: injection_handler_def handleE'_def x y)
|
|
apply (rule bisim_guard_imp)
|
|
apply (erule bisim_split)
|
|
apply (case_tac ra, clarsimp+)[1]
|
|
apply (rule bisim_throwError)
|
|
apply (simp add: z)
|
|
apply clarsimp
|
|
apply (rule bisim_return)
|
|
apply simp
|
|
apply wp
|
|
apply simp+
|
|
done
|
|
|
|
lemma cap_fault_injection:
|
|
"cap_fault_on_failure addr b = injection_handler (ExceptionTypes_A.CapFault addr b)"
|
|
apply (rule ext)
|
|
apply (simp add: cap_fault_on_failure_def injection_handler_def o_def)
|
|
done
|
|
|
|
lemma separate_state_cdt [simp]:
|
|
"separate_state (s\<lparr>cdt := x\<rparr>) = separate_state s"
|
|
unfolding separate_state_def
|
|
by (simp add: get_tcb_def)
|
|
|
|
lemma separate_state_original [simp]:
|
|
"separate_state (s\<lparr>is_original_cap := x\<rparr>) = separate_state s"
|
|
unfolding separate_state_def
|
|
by (simp add: get_tcb_def)
|
|
|
|
lemma separate_cap_NullCap [simp]: "separate_cap NullCap" by (simp add: separate_cap_def)
|
|
|
|
lemma set_cap_NullCap_separate_state [wp]:
|
|
"\<lbrace>separate_state\<rbrace> set_cap NullCap cptr \<lbrace>\<lambda>_. separate_state\<rbrace>"
|
|
unfolding separate_state_def[abs_def] separate_tcb_def separate_cnode_cap_def
|
|
apply (simp add: separate_state_def[abs_def] tcb_at_typ)
|
|
apply (rule hoare_pre)
|
|
apply wps
|
|
apply (wp set_cap_typ_at hoare_vcg_all_lift)
|
|
apply (subst separate_cnode_cap_def)
|
|
apply (clarsimp simp: separate_cap_def)
|
|
apply (drule spec, drule (1) mp)
|
|
apply (clarsimp cong: option.case_cong cap.case_cong split: option.split_asm)
|
|
apply (erule separate_cnode_capE)
|
|
apply (simp add: separate_cnode_cap_def)
|
|
apply (clarsimp simp add: separate_cnode_cap_def split: option.splits)
|
|
done
|
|
|
|
lemma separate_state_pres:
|
|
assumes rl: "(\<And>P t p. \<lbrace>\<lambda>s. P (typ_at t p s) (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (typ_at t p s) (caps_of_state s)\<rbrace>)"
|
|
shows "\<lbrace>separate_state\<rbrace> f \<lbrace>\<lambda>_. separate_state\<rbrace>"
|
|
unfolding separate_state_def[abs_def]
|
|
apply (simp add: tcb_at_typ)
|
|
apply (wp hoare_vcg_all_lift rl)
|
|
done
|
|
|
|
lemma separate_state_pres':
|
|
assumes rl: "(\<And>P t p. \<lbrace>\<lambda>s. P (typ_at t p s)\<rbrace> f \<lbrace>\<lambda>_ s. P (typ_at t p s)\<rbrace>)"
|
|
"(\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>)"
|
|
shows "\<lbrace>separate_state\<rbrace> f \<lbrace>\<lambda>_. separate_state\<rbrace>"
|
|
apply (rule separate_state_pres)
|
|
apply (rule hoare_pre)
|
|
apply (wps rl)
|
|
apply wp
|
|
apply simp
|
|
done
|
|
|
|
lemma separate_state_more_update[simp]:
|
|
"separate_state (trans_state f s) =
|
|
separate_state s"
|
|
by (simp add: separate_state_def)
|
|
|
|
lemma cap_delete_one_sep [wp]:
|
|
"\<lbrace>separate_state\<rbrace> cap_delete_one cptr \<lbrace>\<lambda>_. separate_state\<rbrace>"
|
|
unfolding cap_delete_one_def
|
|
apply (simp add: unless_when)
|
|
apply (wp get_cap_wp')
|
|
apply (simp add: empty_slot_def)
|
|
apply (wp | simp)+
|
|
(* ugh *)
|
|
apply (rule separate_state_pres)
|
|
apply (rule hoare_pre)
|
|
apply (wps set_cdt_typ_at)
|
|
apply (wp)
|
|
apply assumption
|
|
apply (wp get_cap_inv hoare_drop_imps)
|
|
apply (simp add: conj_comms)
|
|
apply (rule separate_state_pres)
|
|
apply (rule hoare_pre)
|
|
apply (wps )
|
|
apply wp
|
|
apply simp
|
|
apply (wp get_cap_wp')
|
|
apply simp
|
|
done
|
|
|
|
lemma bisim_caller_cap:
|
|
assumes bs: "bisim R P P' a (f NullCap)"
|
|
shows "bisim R P (P' and tcb_at p and separate_state) a (get_cap (p, tcb_cnode_index 3) >>= f)"
|
|
apply (rule bisim_guard_imp)
|
|
apply (rule bisim_symb_exec_r [where Pe = \<top>])
|
|
apply (rule_tac F = "rv = NullCap" in bisim_gen_asm_r)
|
|
apply simp
|
|
apply (rule bs)
|
|
apply (wp get_cap_wp')
|
|
apply fastforce
|
|
apply wp
|
|
apply simp
|
|
apply (clarsimp simp: cte_wp_at_caps_of_state tcb_at_def
|
|
caps_of_state_tcb_cap_cases dom_tcb_cap_cases
|
|
cong: conj_cong)
|
|
apply (drule (1) separate_state_get_tcbD)
|
|
apply simp
|
|
done
|
|
|
|
lemma delete_caller_cap_bisim:
|
|
"bisim op = \<top> (tcb_at r and separate_state) (return ()) (delete_caller_cap r)"
|
|
unfolding delete_caller_cap_def
|
|
apply (rule bisim_guard_imp)
|
|
apply (simp add: cap_delete_one_def unless_when)
|
|
apply (rule bisim_caller_cap)
|
|
apply (simp add: when_def)
|
|
apply (rule bisim_refl')
|
|
apply simp_all
|
|
done
|
|
|
|
lemma bisim_guard_imp_both:
|
|
"\<lbrakk> bisim r P P' m m'; \<And>s. R s \<Longrightarrow> P s \<and> P' s \<rbrakk> \<Longrightarrow> bisim r \<top> R m m'"
|
|
unfolding bisim_underlying_def by auto
|
|
|
|
lemma handle_recv_bisim:
|
|
"bisim op = \<top> (separate_state and cur_tcb and valid_objs) (handle_recv is_blocking) (Syscall_A.handle_recv is_blocking)"
|
|
unfolding handle_recv_def Syscall_A.handle_recv_def
|
|
apply (simp add: Let_def)
|
|
apply (rule bisim_guard_imp_both)
|
|
apply (rule bisim_split_refl)
|
|
apply (rule bisim_split_refl)
|
|
apply (rule bisim_split_catch_req)
|
|
apply (simp add: cap_fault_injection)
|
|
apply (rule bisim_injection [OF refl refl, where f' = "op ="])
|
|
apply simp
|
|
apply (rule bisim_split_reflE)
|
|
apply (rule_tac cap = rb in bisim_separate_cap_cases)
|
|
apply (simp, rule bisim_throwError, rule refl)+
|
|
apply (simp split del: split_if)
|
|
apply (rule bisim_refl [where P = \<top> and P' = \<top>])
|
|
apply (case_tac rc, simp_all)[1]
|
|
apply (wp get_cap_wp' lsft_sep | simp add: lookup_cap_def split_def del: hoare_True_E_R)+
|
|
apply (rule handle_fault_bisim)
|
|
apply (wp get_ntfn_wp | wpc | simp)+
|
|
apply (rule_tac Q' = "\<lambda>_. separate_state and valid_objs and tcb_at r" in hoare_post_imp_R)
|
|
prefer 2
|
|
apply simp
|
|
apply (wp | simp add: cur_tcb_def)+
|
|
done
|
|
|
|
lemma handle_reply_bisim:
|
|
"bisim op = \<top> (separate_state and cur_tcb) (return ()) Syscall_A.handle_reply"
|
|
unfolding Syscall_A.handle_reply_def
|
|
apply (rule bisim_guard_imp_both)
|
|
apply (rule bisim_symb_exec_r [where Pe = \<top>])
|
|
apply (rule bisim_caller_cap)
|
|
apply simp
|
|
apply (rule bisim_return)
|
|
apply simp
|
|
apply (wp | simp add: cur_tcb_def)+
|
|
done
|
|
|
|
lemma handle_event_bisim:
|
|
"bisim (dc \<oplus> op =) \<top> (separate_state and cur_tcb and valid_objs) (handle_event ev) (Syscall_A.handle_event ev)"
|
|
apply (cases ev; simp add: handle_send_def Syscall_A.handle_send_def
|
|
handle_call_def Syscall_A.handle_call_def
|
|
handle_reply_def
|
|
cong: syscall.case_cong)
|
|
|
|
apply (rename_tac syscall)
|
|
apply (case_tac syscall, simp_all)[1]
|
|
|
|
apply (rule bisim_guard_imp_both, rule handle_invocation_bisim, simp)
|
|
apply (rule bisim_guard_imp_both)
|
|
apply (rule bisim_symb_exec_r_bs)
|
|
apply (rule handle_reply_bisim)
|
|
apply (rule handle_recv_bisim)
|
|
apply simp
|
|
|
|
apply (rule bisim_guard_imp_both, rule handle_invocation_bisim, simp)
|
|
apply (rule bisim_guard_imp_both, rule handle_invocation_bisim, simp)
|
|
apply (rule bisim_guard_imp_both, rule handle_recv_bisim, simp)
|
|
apply (rule bisim_guard_imp_both, rule handle_reply_bisim, simp)
|
|
|
|
|
|
|
|
apply (simp add: handle_yield_def Syscall_A.handle_yield_def)
|
|
apply (rule bisim_guard_imp_both, rule bisim_refl', simp)
|
|
|
|
apply (rule bisim_guard_imp_both, rule handle_recv_bisim, simp)
|
|
|
|
apply (rule bisim_split_refl)
|
|
apply (rule handle_fault_bisim)
|
|
apply wp
|
|
apply (simp add: cur_tcb_def)
|
|
|
|
apply (rule bisim_split_refl)
|
|
apply (rule handle_fault_bisim)
|
|
apply wp
|
|
apply (simp add: cur_tcb_def)
|
|
|
|
apply (rule bisim_refl)
|
|
apply simp
|
|
|
|
apply (rename_tac vmfault_type)
|
|
apply (rule bisim_guard_imp_both)
|
|
apply (rule bisim_split_refl)
|
|
apply (rule bisim_split_catch_req)
|
|
apply (rule bisim_reflE)
|
|
apply (rule handle_fault_bisim)
|
|
apply wp
|
|
apply (case_tac vmfault_type, simp_all)[1]
|
|
apply (wp separate_state_pres)
|
|
apply (rule hoare_pre, wps, wp, simp)
|
|
apply wp
|
|
apply (rule hoare_pre, wps, wp, simp)
|
|
apply simp
|
|
|
|
apply (wp separate_state_pres)
|
|
apply (rule hoare_pre, wps, wp, simp)
|
|
apply wp
|
|
apply (rule hoare_pre, wps, wp, simp)
|
|
apply simp
|
|
|
|
apply wp
|
|
apply (simp_all add: cur_tcb_def)
|
|
done
|
|
|
|
lemma call_kernel_bisim:
|
|
"bisim (op =) \<top> (separate_state and cur_tcb and valid_objs) (call_kernel ev) (Syscall_A.call_kernel ev)"
|
|
unfolding call_kernel_def Syscall_A.call_kernel_def
|
|
apply (rule bisim_guard_imp_both)
|
|
apply simp
|
|
apply (rule bisim_split)
|
|
apply (rule bisim_split_handle)
|
|
apply (rule handle_event_bisim)
|
|
apply simp
|
|
apply (rule bisim_refl')
|
|
apply wp
|
|
apply (rule bisim_refl')
|
|
apply wp
|
|
apply simp
|
|
done
|
|
|
|
|
|
lemma as_user_separate_state [wp]:
|
|
"\<lbrace>separate_state\<rbrace> as_user t f \<lbrace>\<lambda>_. separate_state\<rbrace>"
|
|
by (wp separate_state_pres')
|
|
|
|
lemma activate_thread_separate_state [wp]:
|
|
"\<lbrace>separate_state\<rbrace> activate_thread \<lbrace>\<lambda>_. separate_state\<rbrace>"
|
|
unfolding activate_thread_def
|
|
by (wp separate_state_pres' | wpc | simp add: arch_activate_idle_thread_def | strengthen imp_consequent)+
|
|
|
|
lemma schedule_separate_state [wp]:
|
|
"\<lbrace>separate_state\<rbrace> schedule :: (unit,unit) s_monad \<lbrace>\<lambda>_. separate_state\<rbrace>"
|
|
apply (simp add: schedule_def switch_to_thread_def arch_switch_to_thread_def switch_to_idle_thread_def arch_switch_to_idle_thread_def allActiveTCBs_def)
|
|
apply (wp select_inv separate_state_pres' alternative_valid | wpc | simp add: arch_activate_idle_thread_def | strengthen imp_consequent)+
|
|
done
|
|
|
|
lemma set_message_info_sep_pres [wp]:
|
|
"\<lbrace>\<lambda>s. P (typ_at t p s) (caps_of_state s)\<rbrace>
|
|
set_message_info a b
|
|
\<lbrace>\<lambda>_ s. P (typ_at t p s) (caps_of_state s)\<rbrace>"
|
|
apply (rule hoare_pre)
|
|
apply (wp | wpc | wps | simp )+
|
|
done
|
|
|
|
lemma set_mrs_separate_state [wp]:
|
|
"\<lbrace>separate_state\<rbrace> set_mrs a b c \<lbrace>\<lambda>_. separate_state\<rbrace>"
|
|
apply (rule separate_state_pres)
|
|
apply (rule hoare_pre)
|
|
apply (wp | wpc | wps | simp )+
|
|
done
|
|
|
|
lemma send_signal_separate_state [wp]:
|
|
"\<lbrace>separate_state\<rbrace> send_signal a b \<lbrace>\<lambda>_. separate_state\<rbrace>"
|
|
unfolding send_signal_def cancel_ipc_def
|
|
apply (rule separate_state_pres)
|
|
apply (rule hoare_pre)
|
|
apply (wp gts_wp get_ntfn_wp hoare_pre_cont[where a = "reply_cancel_ipc x" for x]
|
|
| wpc | wps
|
|
| simp add: update_waiting_ntfn_def)+
|
|
apply (clarsimp)
|
|
apply (simp add: receive_blocked_def)
|
|
apply (case_tac st; clarsimp)
|
|
apply (clarsimp simp add: pred_tcb_at_def obj_at_def)
|
|
done
|
|
|
|
lemma dmo_separate_state [wp]:
|
|
"\<lbrace>separate_state\<rbrace> do_machine_op f \<lbrace>\<lambda>_. separate_state\<rbrace>"
|
|
by (rule separate_state_pres, rule hoare_pre, wps, wp, simp)
|
|
|
|
lemma handle_interrupt_separate_state [wp]:
|
|
"\<lbrace>separate_state\<rbrace> handle_interrupt irq \<lbrace>\<lambda>_. separate_state\<rbrace>"
|
|
unfolding handle_interrupt_def
|
|
apply (rule hoare_pre)
|
|
apply (wp | wpc | wps | simp | strengthen imp_consequent)+
|
|
done
|
|
|
|
lemma decode_invocation_separate_state [wp]:
|
|
"\<lbrace> separate_state \<rbrace>
|
|
Decode_SA.decode_invocation param_a param_b param_c param_d param_e param_f
|
|
\<lbrace> \<lambda>_. separate_state \<rbrace>"
|
|
unfolding decode_invocation_def
|
|
apply (rule hoare_pre, wpc, wp)
|
|
apply simp
|
|
done
|
|
|
|
lemma separate_state_machine_state:
|
|
"separate_state (s\<lparr>machine_state := ms\<rparr>) = separate_state s"
|
|
unfolding separate_state_def by simp
|
|
|
|
crunch separate_state [wp]: set_thread_state "separate_state"
|
|
(wp: separate_state_pres' crunch_wps simp: crunch_simps)
|
|
|
|
crunch separate_state [wp]: set_notification "separate_state"
|
|
(wp: separate_state_pres' crunch_wps simp: crunch_simps)
|
|
|
|
crunch separate_state [wp]: "Syscall_SA.handle_event" "separate_state"
|
|
(wp: crunch_wps without_preemption_wp syscall_valid simp: crunch_simps separate_state_machine_state ignore: set_thread_state do_machine_op)
|
|
|
|
|
|
lemma call_kernel_separate_state:
|
|
"\<lbrace>separate_state and cur_tcb and valid_objs\<rbrace> Syscall_A.call_kernel ev :: (unit,unit) s_monad \<lbrace>\<lambda>_. separate_state\<rbrace>"
|
|
apply (rule hoare_pre)
|
|
apply (rule bisim_valid)
|
|
apply (rule call_kernel_bisim)
|
|
apply (simp add: call_kernel_def)
|
|
apply (wp | wpc | wps | simp | strengthen imp_consequent)+
|
|
done
|
|
|
|
end
|
|
|
|
end
|