2014-07-14 19:32:44 +00:00
(*
* Copyright 2014, General Dynamics C4 Systems
*
* This software may be distributed and modified according to the terms of
* the GNU General Public License version 2. Note that NO WARRANTY is provided.
* See "LICENSE_GPLv2.txt" for details.
*
* @TAG(GD_GPL)
*)
theory Ipc_C
2016-11-10 04:44:36 +00:00
imports
Finalise_C
CSpace_All
SyscallArgs_C
IsolatedThreadAction
2014-07-14 19:32:44 +00:00
begin
2016-05-04 05:07:51 +00:00
context begin interpretation Arch . (*FIXME: arch_split*)
2014-07-14 19:32:44 +00:00
definition
"replyFromKernel_success_empty thread \<equiv> do
VSpace_H.lookupIPCBuffer True thread;
2016-05-01 03:35:49 +00:00
asUser thread $ setRegister ARM_H.badgeRegister 0;
2014-07-14 19:32:44 +00:00
setMessageInfo thread $ (Types_H.MI 0 0 0 0)
od"
lemma replyFromKernel_success_empty:
"replyFromKernel thread (0, []) = replyFromKernel_success_empty thread"
unfolding replyFromKernel_def replyFromKernel_success_empty_def
by (simp add: setMRs_Nil submonad_asUser.fn_stateAssert)
crunch valid_queues[wp]: handleFaultReply valid_queues
crunch valid_queues'[wp]: handleFaultReply valid_queues'
crunch sch_act_wf: handleFaultReply "\<lambda>s. sch_act_wf (ksSchedulerAction s) s"
2017-05-02 01:12:26 +00:00
2014-07-14 19:32:44 +00:00
crunch valid_ipc_buffer_ptr' [wp]: copyMRs "valid_ipc_buffer_ptr' p"
2016-08-23 12:31:49 +00:00
(rule: hoare_valid_ipc_buffer_ptr_typ_at' wp: crunch_wps)
2014-07-14 19:32:44 +00:00
lemma threadSet_obj_at'_nontcb:
"koType TYPE('a::pspace_storable) \<noteq> koType TYPE(Structures_H.tcb) \<Longrightarrow>
\<lbrace>obj_at' (P :: 'a \<Rightarrow> bool) t'\<rbrace> threadSet f t \<lbrace>\<lambda>rv. obj_at' P t'\<rbrace>"
apply (simp add: threadSet_def)
apply (wp obj_at_setObject2 hoare_drop_imps
| clarsimp simp: updateObject_tcb updateObject_default_def in_monad)+
done
2015-11-02 00:00:32 +00:00
lemma setMRs_ntfn_at[wp]:
"\<lbrace>ko_at' (ntfn :: Structures_H.notification) p\<rbrace>
2015-09-02 05:43:39 +00:00
setMRs badge val thread
2015-11-02 00:00:32 +00:00
\<lbrace>\<lambda>_. ko_at' ntfn p\<rbrace>"
2015-09-02 05:43:39 +00:00
apply (simp add: setMRs_def
2014-07-14 19:32:44 +00:00
zipWithM_x_mapM_x split_def storeWordUser_def
setThreadState_def asUser_def)
apply (wp threadSet_obj_at'_nontcb mapM_x_wp hoare_drop_imps
| simp | rule subset_refl)+
done
2015-11-02 00:00:32 +00:00
lemma asUser_ntfn_at[wp]:
"\<lbrace>ko_at' (ntfn :: Structures_H.notification) p\<rbrace>
asUser tptr f \<lbrace>\<lambda>_. ko_at' ntfn p\<rbrace>"
2015-09-02 05:43:39 +00:00
apply (simp add: asUser_def split_def)
apply (wp threadSet_obj_at'_nontcb hoare_drop_imps | simp | rule subset_refl)+
2014-07-14 19:32:44 +00:00
done
definition
"lookup_fault_get_lufType luf \<equiv> case luf of
InvalidRoot \<Rightarrow> 0
| MissingCapability _ \<Rightarrow> 1
| DepthMismatch _ _ \<Rightarrow> 2
| GuardMismatch _ _ _ \<Rightarrow> 3"
definition
"setMR thread buffer \<equiv> \<lambda>idx value.
if idx < length msgRegisters
then do
asUser thread (setRegister (msgRegisters ! idx) value);
return (idx + 1)
od
else case buffer of None \<Rightarrow> return (length msgRegisters)
| Some buf \<Rightarrow> do
storeWordUser (buf + (of_nat (idx + 1) * word_size)) value;
return (idx + 1)
od"
lemmas msgMaxLength_unfold
= msgMaxLength_def[where 'a=nat, unfolded msgLengthBits_def, simplified,
unfolded shiftL_nat, simplified]
lemma registers_less_maxlength:
"length msgRegisters < msgMaxLength"
by (simp add: msgRegisters_unfold msgMaxLength_unfold)
lemma setMRs_to_setMR':
2015-09-30 18:05:05 +00:00
notes
wordSize_def' [simp]
shows
2014-07-14 19:32:44 +00:00
"setMRs thread buffer xs
= (do
stateAssert (tcb_at' thread) [];
ys \<leftarrow> zipWithM (setMR thread buffer) [0 ..< msgMaxLength] xs;
return (of_nat (min (length xs) (length msgRegisters +
(case buffer of None \<Rightarrow> 0 | _ \<Rightarrow> Suc (unat (msgMaxLength :: word32))
- unat ((1 :: word32) + of_nat (length msgRegisters))))))
od)"
2017-05-02 01:12:26 +00:00
apply (simp add: setMRs_def setMR_def split_def
2014-07-14 19:32:44 +00:00
zipWithM_x_mapM_x asUser_mapM_x bind_assoc
zipWithM_If_cut)
apply (simp add: zipWithM_mapM)
apply (simp add: split_def mapM_liftM_const[unfolded liftM_def]
mapM_return mapM_Nil mapM_x_Nil asUser_mapM_x
zip_is_empty last_append map_replicate_const
2016-10-25 06:01:30 +00:00
split: option.split split del: if_split)
apply (simp add: mapM_discarded mapM_x_def split del: if_split)
2014-07-14 19:32:44 +00:00
apply (intro allI conjI impI bind_cong bind_apply_cong refl
arg_cong2[where f=sequence_x]
map_length_cong,
2017-05-02 01:12:26 +00:00
insert registers_less_maxlength, simp_all)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: set_zip)
apply (clarsimp simp: set_zip)
apply (simp add: msgRegisters_unfold msgMaxLength_def
msgLengthBits_def shiftL_nat)
apply (clarsimp simp only: set_zip min_less_iff_conj length_zip
length_map nth_zip fst_conv nth_map
snd_conv upto_enum_word length_drop
length_take nth_drop nth_upt)
apply (subst nth_take)
apply (simp add: less_diff_conv)
apply (simp add: word_size word_size_def field_simps)
done
lemma setMRs_to_setMR:
"setMRs thread buffer xs
= (do
stateAssert (tcb_at' thread) [];
ys \<leftarrow> zipWithM (setMR thread buffer) [0 ..< msgMaxLength] xs;
return (of_nat (last (0 # ys)))
od)"
apply (simp add: setMRs_to_setMR' zipWithM_mapM split_def mapM_discarded
del: last.simps)
apply (subst mapM_last_Cons)
prefer 3
apply simp
apply (simp add: zip_is_empty msgMaxLength_unfold)
apply (simp add: fst_last_zip_upt)
apply (subgoal_tac "msgMaxLength - Suc 0 \<ge> length msgRegisters
\<and> of_nat (length xs - Suc 0) = of_nat (length xs) - (1 :: word32)
\<and> unat ((1 :: word32) + of_nat (length msgRegisters)) = Suc (length msgRegisters)")
apply (simp add: setMR_def split: option.split)
apply (intro impI conjI allI)
apply clarsimp
apply clarsimp
apply (clarsimp simp add: msgRegisters_unfold)
apply (clarsimp simp: linorder_not_less linorder_not_le)
apply (clarsimp simp: msgRegisters_unfold msgMaxLength_def
msgLengthBits_def shiftL_nat)
apply (clarsimp simp: msgRegisters_unfold msgMaxLength_def
msgLengthBits_def shiftL_nat)
apply (simp add: msgRegisters_unfold msgMaxLength_unfold)
apply (case_tac xs, simp_all)
done
lemma asUser_comm:
assumes neq: "a \<noteq> b"
assumes efa: "empty_fail fa" and efb: "empty_fail fb"
shows
"\<And>ra rb. do
ra \<leftarrow> asUser a fa;
rb \<leftarrow> asUser b fb;
c ra rb
od = do
rb \<leftarrow> asUser b fb;
ra \<leftarrow> asUser a fa;
c ra rb
od"
apply (rule submonad_comm' [OF submonad_asUser submonad_asUser])
apply (clarsimp simp: neq asUser_replace_def Let_def fun_upd_twist [OF neq])
apply (clarsimp simp: neq asUser_replace_def Let_def obj_at'_real_def
ko_wp_at'_def ps_clear_upd_None ps_clear_upd
split: option.split kernel_object.split)
apply (clarsimp simp: neq[symmetric] asUser_replace_def Let_def
obj_at'_real_def ko_wp_at'_def ps_clear_upd_None
ps_clear_upd
split: option.split kernel_object.split)
apply (rule efa efb)+
done
(* FIXME move the thread_submonad stuff to SubMonad_R and use it for asUser *)
definition
"thread_fetch \<equiv> \<lambda>ext t s. case (ksPSpace s t) of
Some (KOTCB tcb) \<Rightarrow> ext tcb
| None \<Rightarrow> undefined"
definition
2016-11-10 04:44:36 +00:00
"thread_fetch_option \<equiv> \<lambda>ext t s. case (ksPSpace s t) of
Some (KOTCB tcb) \<Rightarrow> ext tcb
| None \<Rightarrow> None"
definition
"thread_replace \<equiv> \<lambda>upd t nv s.
2014-07-14 19:32:44 +00:00
let obj = case (ksPSpace s t) of
Some (KOTCB tcb) \<Rightarrow> Some (KOTCB (upd (\<lambda>_. nv) tcb))
| obj \<Rightarrow> obj
in s \<lparr> ksPSpace := (ksPSpace s) (t := obj) \<rparr>"
lemma thread_submonad_args:
"\<lbrakk> \<And>f v. ext (upd f v) = f (ext v);
\<And>f1 f2 v. upd f1 (upd f2 v) = upd (f1 \<circ> f2) v;
\<And>f v. upd (\<lambda>_. ext v) v = v \<rbrakk> \<Longrightarrow>
submonad_args (thread_fetch ext t) (thread_replace upd t) (tcb_at' t)"
apply unfold_locales
apply (clarsimp simp: thread_fetch_def thread_replace_def
Let_def obj_at'_def projectKOs
split: kernel_object.split option.split)
apply (clarsimp simp: thread_replace_def Let_def
split: kernel_object.split option.split)
apply (clarsimp simp: thread_fetch_def thread_replace_def Let_def
fun_upd_idem
split: kernel_object.splits option.splits)
apply (clarsimp simp: obj_at'_def thread_replace_def Let_def projectKOs
split: kernel_object.splits option.splits)
2015-05-20 10:39:47 +00:00
apply (rename_tac tcb)
2014-07-14 19:32:44 +00:00
apply (case_tac tcb, simp add: objBitsKO_def ps_clear_def)
done
lemma tcbFault_submonad_args:
"submonad_args (thread_fetch tcbFault t) (thread_replace tcbFault_update t)
(tcb_at' t)"
apply (rule thread_submonad_args)
apply (case_tac v, simp)+
done
lemma threadGet_stateAssert_gets:
"threadGet ext t = do stateAssert (tcb_at' t) []; gets (thread_fetch ext t) od"
2017-01-13 12:58:40 +00:00
including no_pre
2014-07-14 19:32:44 +00:00
apply (rule is_stateAssert_gets [OF _ _ empty_fail_threadGet no_fail_threadGet])
2017-01-13 12:58:40 +00:00
apply (clarsimp simp: threadGet_def liftM_def, wp+)[1]
apply (simp add: threadGet_def liftM_def, (wp getObject_tcb_at')+)
apply (simp add: threadGet_def liftM_def, wp+)
apply (rule hoare_strengthen_post, (wp getObject_obj_at')+)
2014-07-14 19:32:44 +00:00
apply (simp add: objBits_def objBitsKO_def)+
apply (clarsimp simp: obj_at'_def thread_fetch_def projectKOs)
done
lemma threadGet_tcbFault_submonad_fn:
"threadGet tcbFault t =
submonad_fn (thread_fetch tcbFault t) (thread_replace tcbFault_update t)
(tcb_at' t) get"
apply (rule ext)
apply (clarsimp simp: submonad_fn_def bind_assoc split_def)
apply (subst threadGet_stateAssert_gets, simp)
apply (rule bind_apply_cong [OF refl])
apply (clarsimp simp: in_monad bind_def gets_def get_def return_def
submonad_args.args(3) [OF tcbFault_submonad_args]
select_f_def modify_def put_def)
done
lemma asUser_threadGet_tcbFault_comm:
"empty_fail im \<Longrightarrow>
do y \<leftarrow> asUser t im;
x \<leftarrow> threadGet tcbFault t';
n x y
od =
do x \<leftarrow> threadGet tcbFault t';
asUser t im >>= n x
od"
apply (rule submonad_comm2 [OF tcbFault_submonad_args
2017-05-02 01:12:26 +00:00
threadGet_tcbFault_submonad_fn
2014-07-14 19:32:44 +00:00
submonad_asUser, symmetric])
apply (clarsimp simp: thread_replace_def asUser_replace_def Let_def
split: option.split)
apply (clarsimp simp: fun_upd_idem fun_upd_twist
split: kernel_object.split)
2015-05-20 10:39:47 +00:00
apply (rename_tac tcb)
2014-07-14 19:32:44 +00:00
apply (case_tac tcb, simp)
apply (clarsimp simp: asUser_replace_def Let_def obj_at'_real_def
ko_wp_at'_def ps_clear_upd_None ps_clear_upd
objBitsKO_def projectKOs
split: option.split kernel_object.split)
apply (clarsimp simp: thread_replace_def Let_def obj_at'_real_def
ko_wp_at'_def ps_clear_upd_None
ps_clear_upd objBitsKO_def projectKOs
split: option.split kernel_object.split)
apply (simp add: get_def empty_fail_def)
apply assumption
done
2017-02-06 07:33:39 +00:00
lemma asUser_getRegister_threadGet_comm:
"do
ra \<leftarrow> asUser a (getRegister r);
rb \<leftarrow> threadGet fb b;
c ra rb
od = do
rb \<leftarrow> threadGet fb b;
ra \<leftarrow> asUser a (getRegister r);
c ra rb
od"
by (rule bind_inv_inv_comm, auto; wp)
2017-05-02 01:12:26 +00:00
crunch inv[wp]: getSanitiseRegisterInfo P
(ignore: getObject)
lemma empty_fail_getSanitiseRegisterInfo[wp, simp]:
"empty_fail (getSanitiseRegisterInfo t)"
by (wpsimp simp: getSanitiseRegisterInfo_def)
lemma asUser_getRegister_getSanitiseRegisterInfo_comm:
"do
ra \<leftarrow> asUser a (getRegister r);
rb \<leftarrow> getSanitiseRegisterInfo b;
c ra rb
od = do
rb \<leftarrow> getSanitiseRegisterInfo b;
ra \<leftarrow> asUser a (getRegister r);
c ra rb
od"
by (rule bind_inv_inv_comm; wpsimp)
2017-02-06 07:33:39 +00:00
lemma asUser_mapMloadWordUser_threadGet_comm:
"do
ra \<leftarrow> mapM loadWordUser xs;
rb \<leftarrow> threadGet fb b;
c ra rb
od = do
rb \<leftarrow> threadGet fb b;
ra \<leftarrow> mapM loadWordUser xs;
c ra rb
od"
by (rule bind_inv_inv_comm, auto; wp mapM_wp')
2017-05-02 01:12:26 +00:00
lemma asUser_mapMloadWordUser_getSanitiseRegisterInfo_comm:
"do
ra \<leftarrow> mapM loadWordUser xs;
rb \<leftarrow> getSanitiseRegisterInfo b;
c ra rb
od = do
rb \<leftarrow> getSanitiseRegisterInfo b;
ra \<leftarrow> mapM loadWordUser xs;
c ra rb
od"
by (rule bind_inv_inv_comm, auto; wp mapM_wp')
2014-07-14 19:32:44 +00:00
lemma threadGet_tcbFault_doMachineOp_comm:
"\<lbrakk> empty_fail m' \<rbrakk> \<Longrightarrow>
do x \<leftarrow> threadGet tcbFault t; y \<leftarrow> doMachineOp m'; n x y od =
do y \<leftarrow> doMachineOp m'; x \<leftarrow> threadGet tcbFault t; n x y od"
apply (rule submonad_comm2 [OF tcbFault_submonad_args
threadGet_tcbFault_submonad_fn
submonad_doMachineOp])
apply (simp add: thread_replace_def Let_def)
apply simp
apply (rule refl)
apply (simp add: get_def empty_fail_def)
apply assumption
done
lemma getObject_tcb_det:
"(r::tcb,s') \<in> fst (getObject p s) \<Longrightarrow> fst (getObject p s) = {(r,s)} \<and> s' = s"
apply (clarsimp simp add: getObject_def bind_def get_def gets_def
return_def loadObject_default_def split_def)
2016-10-25 06:01:30 +00:00
apply (clarsimp split: kernel_object.split_asm if_split_asm option.split_asm
2014-07-14 19:32:44 +00:00
simp: in_monad typeError_def alignError_def magnitudeCheck_def
objBits_def objBitsKO_def projectKOs
lookupAround2_def Let_def o_def)
apply (simp_all add: bind_def return_def assert_opt_def split_def projectKOs
alignCheck_def is_aligned_mask[symmetric]
unless_def when_def magnitudeCheck_def)
done
lemma threadGet_again:
"\<And>rv s s' n. (rv, s') \<in> fst (threadGet ext t s) \<Longrightarrow>
(threadGet ext t >>= n) s' = n rv s'"
apply (clarsimp simp add: threadGet_def liftM_def in_monad)
apply (frule use_valid [OF _ getObject_obj_at'])
apply (simp add: objBits_def objBitsKO_def)+
apply (frule getObject_tcb_det)
apply (clarsimp simp: bind_def split_def)
apply (insert no_fail_getObject_tcb)
apply (clarsimp simp: no_fail_def obj_at'_def is_tcb)
done
lemma asUser_getRegister_discarded:
"(asUser t (getRegister r)) >>= (\<lambda>_. n) =
stateAssert (tcb_at' t) [] >>= (\<lambda>_. n)"
apply (rule ext)
apply (clarsimp simp: submonad_asUser.fn_is_sm submonad_fn_def
submonad_asUser.args assert_def select_f_def
gets_def get_def modify_def put_def
getRegister_def bind_def split_def
return_def fail_def stateAssert_def)
done
lemma loadWordUser_submonad_fn:
"loadWordUser p = submonad_fn ksMachineState (ksMachineState_update \<circ> K)
(pointerInUserData p) (loadWord p)"
by (simp add: loadWordUser_def submonad_doMachineOp.fn_is_sm submonad_fn_def)
lemma storeWordUser_submonad_fn:
"storeWordUser p v = submonad_fn ksMachineState (ksMachineState_update \<circ> K)
(pointerInUserData p) (storeWord p v)"
by (simp add: storeWordUser_def submonad_doMachineOp.fn_is_sm submonad_fn_def)
lemma threadGet_tcbFault_loadWordUser_comm:
"do x \<leftarrow> threadGet tcbFault t; y \<leftarrow> loadWordUser p; n x y od =
do y \<leftarrow> loadWordUser p; x \<leftarrow> threadGet tcbFault t; n x y od"
apply (rule submonad_comm [OF tcbFault_submonad_args _
threadGet_tcbFault_submonad_fn
loadWordUser_submonad_fn])
apply (simp add: submonad_args_def pointerInUserData_def)
apply (simp add: thread_replace_def Let_def)
apply simp
apply (clarsimp simp: thread_replace_def Let_def typ_at'_def ko_wp_at'_def
ps_clear_upd ps_clear_upd_None pointerInUserData_def
split: option.split kernel_object.split)
apply (simp add: get_def empty_fail_def)
apply (simp add: ef_loadWord)
done
lemma threadGet_tcbFault_storeWordUser_comm:
"do x \<leftarrow> threadGet tcbFault t; y \<leftarrow> storeWordUser p v; n x y od =
do y \<leftarrow> storeWordUser p v; x \<leftarrow> threadGet tcbFault t; n x y od"
apply (rule submonad_comm [OF tcbFault_submonad_args _
threadGet_tcbFault_submonad_fn
storeWordUser_submonad_fn])
apply (simp add: submonad_args_def pointerInUserData_def)
apply (simp add: thread_replace_def Let_def)
apply simp
apply (clarsimp simp: thread_replace_def Let_def typ_at'_def ko_wp_at'_def
ps_clear_upd ps_clear_upd_None pointerInUserData_def
split: option.split kernel_object.split)
apply (simp add: get_def empty_fail_def)
apply (simp add: ef_storeWord)
done
lemma asUser_loadWordUser_comm:
"empty_fail m \<Longrightarrow>
do x \<leftarrow> asUser t m; y \<leftarrow> loadWordUser p; n x y od =
do y \<leftarrow> loadWordUser p; x \<leftarrow> asUser t m; n x y od"
apply (rule submonad_comm2 [OF _ loadWordUser_submonad_fn
submonad_asUser, symmetric])
apply (simp add: submonad_args_def pointerInUserData_def)
apply (simp add: asUser_replace_def Let_def)
apply (clarsimp simp: asUser_replace_def Let_def typ_at'_def ko_wp_at'_def
ps_clear_upd ps_clear_upd_None pointerInUserData_def
split: option.split kernel_object.split)
apply simp
apply (simp add: ef_loadWord)
apply assumption
done
lemma asUser_storeWordUser_comm:
"empty_fail m \<Longrightarrow>
do x \<leftarrow> asUser t m; y \<leftarrow> storeWordUser p v; n x y od =
do y \<leftarrow> storeWordUser p v; x \<leftarrow> asUser t m; n x y od"
apply (rule submonad_comm2 [OF _ storeWordUser_submonad_fn
submonad_asUser, symmetric])
apply (simp add: submonad_args_def pointerInUserData_def)
apply (simp add: asUser_replace_def Let_def)
apply (clarsimp simp: asUser_replace_def Let_def typ_at'_def ko_wp_at'_def
ps_clear_upd ps_clear_upd_None pointerInUserData_def
split: option.split kernel_object.split)
apply simp
apply (simp add: ef_storeWord)
apply assumption
done
lemma length_syscallMessage:
2016-05-01 03:35:49 +00:00
"length ARM_H.syscallMessage = unat n_syscallMessage"
2016-05-05 22:59:33 +00:00
apply (simp add: syscallMessage_def ARM.syscallMessage_def
2014-07-14 19:32:44 +00:00
msgRegisters_unfold n_syscallMessage_def)
apply (simp add: upto_enum_def)
apply (simp add: fromEnum_def enum_register)
done
2016-05-04 05:07:51 +00:00
end
context kernel_m begin
(*FIXME: arch_split: C kernel names hidden by Haskell names *)
2016-11-10 04:44:36 +00:00
(*FIXME: fupdate simplification issues for 2D arrays *)
abbreviation "syscallMessageC \<equiv> kernel_all_global_addresses.fault_messages.[unat MessageID_Syscall]"
lemmas syscallMessageC_def = kernel_all_substitute.fault_messages_def
abbreviation "exceptionMessageC \<equiv> kernel_all_substitute.fault_messages.[unat MessageID_Exception]"
lemmas exceptionMessageC_def = kernel_all_substitute.fault_messages_def
2016-05-04 05:07:51 +00:00
lemma syscallMessage_ccorres:
2014-07-14 19:32:44 +00:00
"n < unat n_syscallMessage
2016-05-01 03:35:49 +00:00
\<Longrightarrow> register_from_H (ARM_H.syscallMessage ! n)
2016-05-04 05:07:51 +00:00
= index syscallMessageC n"
apply (simp add: ARM_H.syscallMessage_def syscallMessageC_def
2016-05-05 22:59:33 +00:00
ARM.syscallMessage_def
2016-11-10 04:44:36 +00:00
MessageID_Exception_def MessageID_Syscall_def
2014-07-14 19:32:44 +00:00
n_syscallMessage_def msgRegisters_unfold)
apply (simp add: upto_enum_def fromEnum_def enum_register)
apply (simp add: toEnum_def enum_register)
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: fupdate_def Kernel_C.CPSR_def
2014-07-14 19:32:44 +00:00
| drule nat_less_cases' | erule disjE)+
done
2016-05-04 05:07:51 +00:00
end
context begin interpretation Arch . (*FIXME: arch_split*)
2014-07-14 19:32:44 +00:00
definition
2016-11-10 04:44:36 +00:00
"handleArchFaultReply' f sender receiver tag \<equiv> do
2014-07-14 19:32:44 +00:00
label \<leftarrow> return $ msgLabel tag;
mlen \<leftarrow> return $ msgLength tag;
case f of
2016-11-10 04:44:36 +00:00
VMFault _ _ \<Rightarrow> do
2014-07-14 19:32:44 +00:00
sendBuf \<leftarrow> lookupIPCBuffer False sender;
stateAssert (tcb_at' sender) [];
case sendBuf of
None \<Rightarrow> return ()
| Some bufferPtr \<Rightarrow> do
mapM loadWordUser
(map (\<lambda>i. bufferPtr + PPtr (i * 4))
[(scast n_msgRegisters :: word32) + 1.e. msgMaxLength]);
return ()
od;
return True
od
2016-11-10 04:44:36 +00:00
od"
definition
"handleFaultReply' f sender receiver \<equiv> do
tag \<leftarrow> getMessageInfo sender;
label \<leftarrow> return $ msgLabel tag;
mlen \<leftarrow> return $ msgLength tag;
case f of
CapFault _ _ _ \<Rightarrow> return True
| ArchFault af \<Rightarrow> handleArchFaultReply' af sender receiver tag
2014-07-14 19:32:44 +00:00
| UnknownSyscallException _ \<Rightarrow> do
2017-05-02 01:12:26 +00:00
t \<leftarrow> getSanitiseRegisterInfo receiver;
2014-07-14 19:32:44 +00:00
regs \<leftarrow> return $ take (unat mlen) syscallMessage;
zipWithM_x (\<lambda>rs rd. do
v \<leftarrow> asUser sender $ getRegister rs;
2017-02-06 07:33:39 +00:00
asUser receiver $ setRegister rd $ sanitiseRegister t rd v
2014-07-14 19:32:44 +00:00
od) msgRegisters regs;
2016-11-10 04:44:36 +00:00
sendBuf \<leftarrow> lookupIPCBuffer False sender;
2014-07-14 19:32:44 +00:00
case sendBuf of
None \<Rightarrow> return ()
2017-05-02 01:12:26 +00:00
| Some bufferPtr \<Rightarrow>
2014-07-14 19:32:44 +00:00
zipWithM_x (\<lambda>i rd. do
v \<leftarrow> loadWordUser (bufferPtr + PPtr (i * 4));
2017-02-06 07:33:39 +00:00
asUser receiver $ setRegister rd $ sanitiseRegister t rd v
2017-05-02 01:12:26 +00:00
od) [(scast n_msgRegisters :: word32) + 1.e. scast n_syscallMessage] (drop (unat (scast n_msgRegisters :: word32)) regs);
2014-07-14 19:32:44 +00:00
return (label = 0)
od
| UserException _ _ \<Rightarrow> do
2017-05-02 01:12:26 +00:00
t \<leftarrow> getSanitiseRegisterInfo receiver;
2014-07-14 19:32:44 +00:00
regs \<leftarrow> return $ take (unat mlen) exceptionMessage;
zipWithM_x (\<lambda>rs rd. do
v \<leftarrow> asUser sender $ getRegister rs;
2017-02-06 07:33:39 +00:00
asUser receiver $ setRegister rd $ sanitiseRegister t rd v
2014-07-14 19:32:44 +00:00
od) msgRegisters regs;
return (label = 0)
od
od"
lemma loadWordUser_discarded:
"loadWordUser p >>= (\<lambda>_. n) =
stateAssert (pointerInUserData p and K (p && mask 2 = 0)) [] >>= (\<lambda>_. n)"
apply (rule ext)
apply (clarsimp simp: loadWordUser_def loadWord_def bind_def assert_def
stateAssert_def split_def return_def fail_def
doMachineOp_def gets_def get_def select_f_def
modify_def put_def)
done
lemma stateAssert_mapM_loadWordUser_comm:
"do x \<leftarrow> stateAssert P []; y \<leftarrow> mapM loadWordUser ptrs; n od =
do y \<leftarrow> mapM loadWordUser ptrs; x \<leftarrow> stateAssert P []; n od"
apply (rule bind_inv_inv_comm)
apply (wp stateAssert_inv)
2017-01-13 12:58:40 +00:00
apply (wp mapM_wp_inv)+
2014-07-14 19:32:44 +00:00
apply simp
done
lemmas syscallMessage_unfold
2016-05-01 03:35:49 +00:00
= ARM_H.syscallMessage_def
2016-05-05 22:59:33 +00:00
ARM.syscallMessage_def
2014-07-14 19:32:44 +00:00
[unfolded upto_enum_def, simplified,
unfolded fromEnum_def enum_register, simplified,
unfolded toEnum_def enum_register, simplified]
2016-11-10 04:44:36 +00:00
lemma handleArchFaultReply':
2015-09-30 18:05:05 +00:00
notes option.case_cong_weak [cong] wordSize_def'[simp]
2016-11-10 04:44:36 +00:00
shows "(do
2014-07-14 19:32:44 +00:00
sb \<leftarrow> lookupIPCBuffer False s;
msg \<leftarrow> getMRs s sb tag;
2016-11-10 04:44:36 +00:00
handleArchFaultReply f r (msgLabel tag) msg
od) x' = handleArchFaultReply' f s r tag x'"
apply (unfold handleArchFaultReply'_def getMRs_def msgMaxLength_def
2014-07-14 19:32:44 +00:00
bit_def msgLengthBits_def msgRegisters_unfold
fromIntegral_simp1 fromIntegral_simp2
shiftL_word)
apply (simp add: bind_assoc)
apply (clarsimp simp: mapM_def sequence_def bind_assoc asUser_bind_distrib
asUser_return submonad_asUser.fn_stateAssert)
apply (case_tac f)
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: handleArchFaultReply_def asUser_getRegister_discarded
2014-07-14 19:32:44 +00:00
bind_subst_lift [OF stateAssert_stateAssert]
pred_conj_def)
apply (rule bind_apply_cong [OF refl], rename_tac sb s'')
2016-11-10 04:44:36 +00:00
apply (rule bind_apply_cong [OF refl], rename_tac rv r'')
apply (case_tac sb, simp_all add: word_size n_msgRegisters_def)[1]
done
lemmas lookup_uset_getreg_swap = bind_inv_inv_comm[OF lookupIPCBuffer_inv'
user_getreg_inv'
empty_fail_lookupIPCBuffer
empty_fail_asUser[OF getRegister_empty_fail]]
end
lemma mapM_x_zip_take_Cons_append:
"n = 0 \<longrightarrow> zs = []
\<Longrightarrow> mapM_x f (zip (x # xs) (take n (y # ys) @ zs))
= do
when (n > 0) (f (x, y));
mapM_x f (zip xs (take (n - 1) ys @ zs))
od"
by (cases n, simp_all add: mapM_x_Cons)
2017-02-06 07:33:39 +00:00
lemma threadGet_lookupIPCBuffer_comm:
"do
a \<leftarrow> lookupIPCBuffer x y;
t \<leftarrow> threadGet id r;
c a t
od = do
t \<leftarrow> threadGet id r;
a \<leftarrow> lookupIPCBuffer x y;
c a t
od"
by (rule bind_inv_inv_comm; wp?; auto)
2017-05-02 01:12:26 +00:00
lemma getSanitiseRegisterInfo_lookupIPCBuffer_comm:
"do
a \<leftarrow> lookupIPCBuffer x y;
t \<leftarrow> getSanitiseRegisterInfo r;
c a t
od = do
t \<leftarrow> getSanitiseRegisterInfo r;
a \<leftarrow> lookupIPCBuffer x y;
c a t
od"
by (rule bind_inv_inv_comm; wp?; auto)
2017-02-06 07:33:39 +00:00
lemma threadGet_moreMapM_comm:
"do
a \<leftarrow>
case sb of None \<Rightarrow> return []
| Some bufferPtr \<Rightarrow> return (xs bufferPtr) >>= mapM loadWordUser;
t \<leftarrow> threadGet id r;
c a t
od = do
t \<leftarrow> threadGet id r;
a \<leftarrow>
case sb of None \<Rightarrow> return []
| Some bufferPtr \<Rightarrow> return (xs bufferPtr) >>= mapM loadWordUser;
c a t
od"
apply (rule bind_inv_inv_comm)
apply (rule hoare_pre, wpc; (wp mapM_wp')?)
apply simp
apply wp
apply (auto split: option.splits)
done
2017-05-02 01:12:26 +00:00
lemma getSanitiseRegisterInfo_moreMapM_comm:
"do
a \<leftarrow>
case sb of None \<Rightarrow> return []
| Some bufferPtr \<Rightarrow> return (xs bufferPtr) >>= mapM loadWordUser;
t \<leftarrow> getSanitiseRegisterInfo r;
c a t
od = do
t \<leftarrow> getSanitiseRegisterInfo r;
a \<leftarrow>
case sb of None \<Rightarrow> return []
| Some bufferPtr \<Rightarrow> return (xs bufferPtr) >>= mapM loadWordUser;
c a t
od"
apply (rule bind_inv_inv_comm)
apply (rule hoare_pre, wpc; (wp mapM_wp')?)
apply simp
apply wp
apply (auto split: option.splits)
done
2017-02-06 07:33:39 +00:00
lemma monadic_rewrite_symb_exec_r':
"\<lbrakk> \<And>s. \<lbrace>op = s\<rbrace> m \<lbrace>\<lambda>r. op = s\<rbrace>; no_fail P m;
\<And>rv. monadic_rewrite F False (Q rv) x (y rv);
\<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace> \<rbrakk>
\<Longrightarrow> monadic_rewrite F False P x (m >>= y)"
apply (rule monadic_rewrite_imp)
apply (rule monadic_rewrite_symb_exec_r; assumption)
apply simp
done
lemma monadic_rewrite_threadGet_return:
"monadic_rewrite True False (tcb_at' r) (return x) (do t \<leftarrow> threadGet f r; return x od)"
apply (rule monadic_rewrite_symb_exec_r')
apply wp+
apply (rule monadic_rewrite_refl)
apply wp
done
2017-05-02 01:12:26 +00:00
context begin interpretation Arch .
lemma no_fail_getSanitiseRegisterInfo[wp, simp]:
"no_fail (tcb_at' r) (getSanitiseRegisterInfo r)"
apply (simp add: getSanitiseRegisterInfo_def)
by wpsimp
end
lemma monadic_rewrite_getSanitiseRegisterInfo_return:
"monadic_rewrite True False (tcb_at' r) (return x) (do t \<leftarrow> getSanitiseRegisterInfo r; return x od)"
apply (rule monadic_rewrite_symb_exec_r')
apply wp+
apply (rule monadic_rewrite_refl)
apply wp
done
lemma monadic_rewrite_getSanitiseRegisterInfo_drop:
"monadic_rewrite True False (tcb_at' r) (d) (do t \<leftarrow> getSanitiseRegisterInfo r; d od)"
apply (rule monadic_rewrite_symb_exec_r')
apply wp+
apply (rule monadic_rewrite_refl)
apply wp
done
2016-11-10 04:44:36 +00:00
lemma monadic_rewrite_inst: "monadic_rewrite F E P f g \<Longrightarrow> monadic_rewrite F E P f g"
by simp
context kernel_m begin interpretation Arch .
2017-02-06 07:33:39 +00:00
lemma threadGet_discarded:
"(threadGet f t >>= (\<lambda>_. n)) = stateAssert (tcb_at' t) [] >>= (\<lambda>_. n)"
apply (simp add: threadGet_def getObject_get_assert liftM_def bind_assoc stateAssert_def)
apply (rule ext)
apply (simp add: bind_def simpler_gets_def get_def)
2016-11-10 04:44:36 +00:00
done
2017-05-02 01:12:26 +00:00
lemma monadic_rewrite_do_flip:
"monadic_rewrite E F P (do c \<leftarrow> j; a \<leftarrow> f; b \<leftarrow> g c; return (a, c) od)
(do c \<leftarrow> j; b \<leftarrow> g c; a \<leftarrow> f; return (a, c) od)
\<Longrightarrow> monadic_rewrite E F P (do c \<leftarrow> j; a \<leftarrow> f; b \<leftarrow> g c; h a c od)
(do c \<leftarrow> j; b \<leftarrow> g c; a \<leftarrow> f; h a c od)"
apply (drule_tac h="\<lambda>(a, b). h a b" in monadic_rewrite_bind_head)
apply (simp add: bind_assoc)
done
2016-11-10 04:44:36 +00:00
lemma handleFaultReply':
notes option.case_cong_weak [cong] wordSize_def'[simp] take_append[simp del]
assumes neq: "s \<noteq> r"
shows "monadic_rewrite True False (tcb_at' s and tcb_at' r) (do
tag \<leftarrow> getMessageInfo s;
sb \<leftarrow> lookupIPCBuffer False s;
msg \<leftarrow> getMRs s sb tag;
handleFaultReply f r (msgLabel tag) msg
od) (handleFaultReply' f s r)"
apply (unfold handleFaultReply'_def getMRs_def msgMaxLength_def
bit_def msgLengthBits_def msgRegisters_unfold
fromIntegral_simp1 fromIntegral_simp2
shiftL_word)
2017-02-06 07:33:39 +00:00
apply (simp add: bind_assoc)
2016-11-10 04:44:36 +00:00
apply (rule monadic_rewrite_bind_tail)
apply (clarsimp simp: mapM_def sequence_def bind_assoc asUser_bind_distrib
2017-02-06 07:33:39 +00:00
asUser_return submonad_asUser.fn_stateAssert)
apply (case_tac f, simp_all add: handleFaultReply_def zipWithM_x_mapM_x zip_take)
2016-11-10 04:44:36 +00:00
(* UserException *)
apply (clarsimp simp: handleFaultReply_def zipWithM_x_mapM_x
zip_Cons ARM_H.exceptionMessage_def
ARM.exceptionMessage_def
mapM_x_Cons mapM_x_Nil)
2017-01-13 12:58:40 +00:00
apply (rule monadic_rewrite_symb_exec_l, wp+)
2016-11-10 04:44:36 +00:00
apply (rule_tac P="tcb_at' s and tcb_at' r" in monadic_rewrite_inst)
apply (case_tac rv; (case_tac "msgLength tag < scast n_msgRegisters",
(erule disjE[OF word_less_cases],
( clarsimp simp: n_msgRegisters_def asUser_bind_distrib
mapM_x_Cons mapM_x_Nil bind_assoc
2017-02-06 07:33:39 +00:00
asUser_getRegister_discarded asUser_mapMloadWordUser_threadGet_comm
2017-05-02 01:12:26 +00:00
asUser_getRegister_getSanitiseRegisterInfo_comm
asUser_mapMloadWordUser_getSanitiseRegisterInfo_comm
2017-02-06 07:33:39 +00:00
asUser_comm[OF neq] asUser_getRegister_threadGet_comm
2016-11-10 04:44:36 +00:00
bind_comm_mapM_comm [OF asUser_loadWordUser_comm, symmetric]
word_le_nat_alt[of 4, simplified linorder_not_less[symmetric, of 4]]
asUser_return submonad_asUser.fn_stateAssert
| rule monadic_rewrite_bind_tail monadic_rewrite_refl
monadic_rewrite_symb_exec_l[OF stateAssert_inv]
monadic_rewrite_symb_exec_l[OF mapM_x_mapM_valid[OF mapM_x_wp']]
2017-02-06 07:33:39 +00:00
| wp asUser_tcb_at' lookupIPCBuffer_inv' )+)+))
2016-11-10 04:44:36 +00:00
apply wp
(* capFault *)
2017-01-13 12:58:40 +00:00
apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_asUser)+)+
2016-11-10 04:44:36 +00:00
apply(case_tac rv)
apply (clarsimp
| rule monadic_rewrite_bind_tail monadic_rewrite_refl
monadic_rewrite_symb_exec_l[OF mapM_x_mapM_valid[OF mapM_x_wp']]
| wp mapM_x_mapM_valid[OF mapM_x_wp'[OF loadWordUser_inv]]
empty_fail_loadWordUser)+
(* UnknownSyscallExceptio *)
2017-02-06 07:33:39 +00:00
apply (simp add: zip_append2 mapM_x_append asUser_bind_distrib split_def bind_assoc)
2016-11-10 04:44:36 +00:00
apply (rule monadic_rewrite_imp)
apply (rule monadic_rewrite_trans[rotated])
apply (rule monadic_rewrite_do_flip)
2017-02-06 07:33:39 +00:00
apply (rule monadic_rewrite_bind_tail)
apply (rule_tac P="inj (case_bool s r)" in monadic_rewrite_gen_asm)
apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse])
apply (rule monadic_rewrite_weaken[where F=False and E=True], simp)
apply (rule isolate_thread_actions_rewrite_bind
bool.simps setRegister_simple
zipWithM_setRegister_simple
thread_actions_isolatable_bind lookupIPCBuffer_isolatable
lookupIPCBuffer_isolatable[THEN thread_actions_isolatableD]
copy_registers_isolate_general thread_actions_isolatable_return
thread_actions_isolatable_return[THEN thread_actions_isolatableD]
| assumption
| wp assert_inv)+
apply (rule monadic_rewrite_isolate_final[where P="\<top>"])
apply simp+
apply wp
2016-11-10 04:44:36 +00:00
(* swap ends *)
apply (clarsimp simp: handleFaultReply_def zipWithM_x_mapM_x
zip_Cons syscallMessage_unfold
n_syscallMessage_def
upto_enum_word mapM_x_Cons mapM_x_Nil)
2017-05-02 01:12:26 +00:00
apply (simp add: getSanitiseRegisterInfo_moreMapM_comm asUser_getRegister_getSanitiseRegisterInfo_comm getSanitiseRegisterInfo_lookupIPCBuffer_comm)
2016-11-10 04:44:36 +00:00
apply (rule monadic_rewrite_bind_tail)
2017-02-06 07:33:39 +00:00
apply (rule monadic_rewrite_bind_tail [where Q="\<lambda>_. tcb_at' r"])
2016-11-10 04:44:36 +00:00
apply (case_tac sb)
apply (case_tac "msgLength tag < scast n_msgRegisters")
apply (erule disjE[OF word_less_cases],
( clarsimp simp: n_msgRegisters_def asUser_bind_distrib
mapM_x_Cons mapM_x_Nil bind_assoc
asUser_getRegister_discarded
asUser_comm[OF neq] take_zip
word_le_nat_alt[of 4, simplified linorder_not_less[symmetric, of 4]]
asUser_return submonad_asUser.fn_stateAssert
| rule monadic_rewrite_bind_tail monadic_rewrite_refl
monadic_rewrite_symb_exec_l[OF stateAssert_inv]
| wp asUser_tcb_at')+)+
apply (case_tac "msgLength tag < scast n_msgRegisters")
apply (erule disjE[OF word_less_cases],
( clarsimp simp: n_msgRegisters_def asUser_bind_distrib
mapM_x_Cons mapM_x_Nil bind_assoc
zipWithM_x_Nil
asUser_getRegister_discarded
asUser_comm[OF neq] take_zip
bind_comm_mapM_comm [OF asUser_loadWordUser_comm, symmetric]
asUser_return submonad_asUser.fn_stateAssert
| rule monadic_rewrite_bind_tail monadic_rewrite_refl
monadic_rewrite_symb_exec_l[OF mapM_x_mapM_valid[OF mapM_x_wp']]
monadic_rewrite_symb_exec_l[OF stateAssert_inv]
2017-02-06 07:33:39 +00:00
monadic_rewrite_threadGet_return
2017-05-02 01:12:26 +00:00
monadic_rewrite_getSanitiseRegisterInfo_return
2017-02-06 07:33:39 +00:00
| wp asUser_tcb_at' mapM_wp')+)+
2016-11-10 04:44:36 +00:00
apply (simp add: n_msgRegisters_def word_le_nat_alt n_syscallMessage_def
linorder_not_less syscallMessage_unfold)
apply (clarsimp | frule neq0_conv[THEN iffD2, THEN not0_implies_Suc,
OF order_less_le_trans, rotated])+
apply (subgoal_tac "\<forall>n :: word32. n \<le> scast n_syscallMessage \<longrightarrow> [n .e. msgMaxLength]
= [n .e. scast n_syscallMessage]
@ [scast n_syscallMessage + 1 .e. msgMaxLength]")
apply (simp only: upto_enum_word[where y="scast n_syscallMessage :: word32"]
upto_enum_word[where y="scast n_syscallMessage + 1 :: word32"])
2017-02-06 07:33:39 +00:00
apply (clarsimp simp: bind_assoc asUser_bind_distrib asUser_getRegister_threadGet_comm
mapM_x_Cons mapM_x_Nil threadGet_discarded
2016-11-10 04:44:36 +00:00
asUser_comm [OF neq] asUser_getRegister_discarded
submonad_asUser.fn_stateAssert take_zip
bind_subst_lift [OF submonad_asUser.stateAssert_fn]
word_less_nat_alt ARM_H.sanitiseRegister_def
split_def n_msgRegisters_def msgMaxLength_def
bind_comm_mapM_comm [OF asUser_loadWordUser_comm, symmetric]
word_size msgLengthBits_def n_syscallMessage_def
2016-10-25 06:01:30 +00:00
split del: if_split
cong: if_weak_cong)
2016-11-10 04:44:36 +00:00
apply (rule monadic_rewrite_bind_tail)+
apply (subst (2) upto_enum_word)
apply (case_tac "ma < unat n_syscallMessage - 4")
apply (erule disjE[OF nat_less_cases'],
( clarsimp simp: n_syscallMessage_def bind_assoc asUser_bind_distrib
mapM_x_Cons mapM_x_Nil zipWithM_x_mapM_x mapM_Cons
bind_comm_mapM_comm [OF asUser_loadWordUser_comm, symmetric]
asUser_loadWordUser_comm loadWordUser_discarded asUser_return
zip_take_triv2 msgMaxLength_def
cong: if_weak_cong
2017-05-02 01:12:26 +00:00
| simp
2016-11-10 04:44:36 +00:00
| rule monadic_rewrite_bind_tail
monadic_rewrite_refl
monadic_rewrite_symb_exec_l[OF stateAssert_inv]
monadic_rewrite_symb_exec_l[OF mapM_x_mapM_valid[OF mapM_x_wp']]
2017-05-02 01:12:26 +00:00
monadic_rewrite_threadGet_return
monadic_rewrite_getSanitiseRegisterInfo_return
monadic_rewrite_getSanitiseRegisterInfo_drop
2016-11-10 04:44:36 +00:00
| wp empty_fail_loadWordUser)+)+
apply (clarsimp simp: upto_enum_word word_le_nat_alt simp del: upt.simps cong: if_weak_cong)
apply (cut_tac i="unat n" and j="Suc (unat (scast n_syscallMessage :: word32))"
and k="Suc msgMaxLength" in upt_add_eq_append')
apply (simp add: n_syscallMessage_def)
apply (simp add: n_syscallMessage_def msgMaxLength_unfold)
apply (simp add: n_syscallMessage_def msgMaxLength_def
msgLengthBits_def shiftL_nat
del: upt.simps upt_rec_numeral)
apply (simp add: upto_enum_word cong: if_weak_cong)
2017-02-06 07:33:39 +00:00
apply wp+
2016-11-10 04:44:36 +00:00
(* ArchFault *)
apply (simp add: neq inj_case_bool split: bool.split)
apply (rule monadic_rewrite_imp)
apply (rule monadic_rewrite_is_refl)
apply (rule ext)
apply (unfold handleArchFaultReply'[symmetric] getMRs_def msgMaxLength_def
bit_def msgLengthBits_def msgRegisters_unfold
fromIntegral_simp1 fromIntegral_simp2 shiftL_word)
apply (clarsimp simp: mapM_def sequence_def bind_assoc asUser_bind_distrib
2017-05-02 01:12:26 +00:00
asUser_return submonad_asUser.fn_stateAssert)
2017-03-13 16:37:32 +00:00
apply wpsimp+
2014-07-14 19:32:44 +00:00
done
2016-05-04 05:07:51 +00:00
end
2014-07-14 19:32:44 +00:00
context kernel_m
begin
(* FIXME: move *)
lemma ccorres_merge_return:
2017-05-02 01:12:26 +00:00
"ccorres (\<lambda>a c. r (f a) c) xf P P' hs H C \<Longrightarrow>
ccorres r xf P P' hs (do x \<leftarrow> H; return (f x) od) C"
2015-05-20 10:39:47 +00:00
by (rule ccorres_return_into_rel)
2014-07-14 19:32:44 +00:00
(* FIXME: move *)
lemma ccorres_break:
assumes r: "\<And>s s'. \<lbrakk> (s,s') \<in> rf_sr; P s; s' \<in> P' \<rbrakk> \<Longrightarrow> r (Inl e) (xf s')"
assumes xf: "\<And>s. xf (global_exn_var_'_update (\<lambda>_. Break) s) = xf s"
shows "ccorres r xf P P' (catchbrk_C#hs) (throwError e) break_C"
apply (simp add: throwError_def cbreak_def)
apply (clarsimp simp: ccorres_underlying_def return_def split: xstate.splits)
apply (frule (2) r)
apply (rule conjI)
apply clarsimp
apply (erule exec_handlers.cases, simp_all)[1]
apply clarsimp
apply (erule exec_elim_cases, simp_all)[1]
apply (erule exec_elim_cases, simp_all)[1]
apply clarsimp
apply (erule exec_elim_cases, simp_all)[1]
apply clarsimp
apply (erule exec_handlers.cases, simp_all)[1]
apply (clarsimp simp: catchbrk_C_def)
apply (erule exec_elim_cases, simp_all)[1]
apply (erule exec_elim_cases, simp_all)[1]
apply clarsimp
apply (clarsimp simp: catchbrk_C_def)
apply (erule exec_elim_cases, simp_all)[1]
apply clarsimp
apply (erule exec_elim_cases, simp_all)[1]
apply (clarsimp simp: unif_rrel_def xf)
apply clarsimp
apply clarsimp
apply (erule exec_elim_cases, simp_all)[1]
apply (erule exec_elim_cases, simp_all)[1]
apply (erule exec_elim_cases, simp_all)[1]
apply (rule conjI, clarsimp)
apply (erule exec_handlers.cases, simp_all)[1]
apply clarsimp
apply ((erule exec_elim_cases, simp_all)[1])+
apply (clarsimp simp: catchbrk_C_def)
apply (erule exec_handlers.cases, simp_all)[1]
apply (auto elim: exec_elim_cases)[3]
apply (rule conjI, clarsimp)
apply (erule exec_handlers.cases, simp_all)[1]
apply clarsimp
apply ((erule exec_elim_cases, simp_all)[1])+
apply (clarsimp simp: catchbrk_C_def)
apply (erule exec_handlers.cases, simp_all)[1]
apply (auto elim: exec_elim_cases)[3]
apply clarsimp
apply (erule exec_handlers.cases, simp_all)[1]
apply clarsimp
apply ((erule exec_elim_cases, simp_all)[1])+
apply (clarsimp simp: catchbrk_C_def)
apply (erule exec_handlers.cases, simp_all)[1]
apply (auto elim!: exec_elim_cases)
done
(* FIXME: move *)
lemma ccorres_break_return:
assumes r: "\<And>s s'. \<lbrakk> (s,s') \<in> rf_sr; P s; s' \<in> P' \<rbrakk> \<Longrightarrow> r n (xf s')"
assumes xf: "\<And>s. xf (global_exn_var_'_update (\<lambda>_. Break) s) = xf s"
shows "ccorres r xf P P' (catchbrk_C#hs) (return n) break_C"
apply (simp add: throwError_def cbreak_def)
apply (clarsimp simp: ccorres_underlying_def return_def split: xstate.splits)
apply (frule (2) r)
apply (rule conjI)
apply clarsimp
apply (erule exec_handlers.cases, simp_all)[1]
apply clarsimp
apply (erule exec_elim_cases, simp_all)[1]
apply (erule exec_elim_cases, simp_all)[1]
apply clarsimp
apply (erule exec_elim_cases, simp_all)[1]
apply clarsimp
apply (erule exec_handlers.cases, simp_all)[1]
apply (clarsimp simp: catchbrk_C_def)
apply (erule exec_elim_cases, simp_all)[1]
apply (erule exec_elim_cases, simp_all)[1]
apply clarsimp
apply (clarsimp simp: catchbrk_C_def)
apply (erule exec_elim_cases, simp_all)[1]
apply clarsimp
apply (erule exec_elim_cases, simp_all)[1]
apply (clarsimp simp: unif_rrel_def xf)
apply clarsimp
apply clarsimp
apply (erule exec_elim_cases, simp_all)[1]
apply (erule exec_elim_cases, simp_all)[1]
apply (erule exec_elim_cases, simp_all)[1]
apply (rule conjI, clarsimp)
apply (erule exec_handlers.cases, simp_all)[1]
apply clarsimp
apply ((erule exec_elim_cases, simp_all)[1])+
apply (clarsimp simp: catchbrk_C_def)
apply (erule exec_handlers.cases, simp_all)[1]
apply (auto elim: exec_elim_cases)[3]
apply (rule conjI, clarsimp)
apply (erule exec_handlers.cases, simp_all)[1]
apply clarsimp
apply ((erule exec_elim_cases, simp_all)[1])+
apply (clarsimp simp: catchbrk_C_def)
apply (erule exec_handlers.cases, simp_all)[1]
apply (auto elim: exec_elim_cases)[3]
apply clarsimp
apply (erule exec_handlers.cases, simp_all)[1]
apply clarsimp
apply ((erule exec_elim_cases, simp_all)[1])+
apply (clarsimp simp: catchbrk_C_def)
apply (erule exec_handlers.cases, simp_all)[1]
apply (auto elim!: exec_elim_cases)
done
lemma messageInfoFromWord_spec:
2017-05-02 01:12:26 +00:00
"\<forall>s. \<Gamma> \<turnstile> {s} Call messageInfoFromWord_'proc {t. seL4_MessageInfo_lift (ret__struct_seL4_MessageInfo_C_' t) =
2016-01-08 07:43:33 +00:00
\<lparr>label_CL = (w_' s >> 12) && 0xFFFFF, capsUnwrapped_CL = (w_' s >> 9) && 7,
extraCaps_CL = (w_' s >> 7) && 3, length_CL = let v = w_' s && 0x7F in if v > msgMaxLength then msgMaxLength else v\<rparr>}"
2014-07-14 19:32:44 +00:00
apply vcg
2016-01-08 07:43:33 +00:00
apply (simp add: seL4_MessageInfo_lift_def Let_def msgMaxLength_def mask_def word_sle_def
2015-01-09 21:34:52 +00:00
word_sless_def seL4_MsgMaxLength_def
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
done
lemma messageInfoFromWord_ccorres [corres]:
2016-01-08 07:43:33 +00:00
"ccorres (\<lambda>r r'. r = message_info_to_H r') ret__struct_seL4_MessageInfo_C_' \<top> {s. w_' s = w} []
2014-07-14 19:32:44 +00:00
(return (messageInfoFromWord w)) (Call messageInfoFromWord_'proc)"
apply (rule ccorres_from_spec_modifies [where P = \<top>, simplified])
apply (rule messageInfoFromWord_spec)
apply (rule messageInfoFromWord_modifies)
apply simp
apply simp
2017-05-02 01:12:26 +00:00
apply (simp add: return_def messageInfoFromWord_def Let_def message_info_to_H_def
2014-07-14 19:32:44 +00:00
Types_H.msgLengthBits_def Types_H.msgExtraCapBits_def msgMaxExtraCaps_def
shiftL_nat msgMaxLength_def)
apply (rule shiftr_mask_eq' [symmetric, where m = 20, simplified mask_def, simplified])
apply (simp add: word_size)
done
2015-11-16 03:12:37 +00:00
2017-05-02 01:12:26 +00:00
lemma getMessageInfo_ccorres:
"ccorres (\<lambda>r r'. r = message_info_to_H r') ret__struct_seL4_MessageInfo_C_'
2014-07-14 19:32:44 +00:00
(tcb_at' sender) UNIV hs (getMessageInfo sender)
(\<acute>ret__unsigned_long :== CALL getRegister(tcb_ptr_to_ctcb_ptr sender,scast Kernel_C.msgInfoRegister);;
2016-01-08 07:43:33 +00:00
\<acute>ret__struct_seL4_MessageInfo_C :== CALL messageInfoFromWord(\<acute>ret__unsigned_long))"
2014-07-14 19:32:44 +00:00
unfolding getMessageInfo_def
apply simp
apply (rule ccorres_guard_imp2)
apply ctac
apply ctac
apply wp
apply vcg
apply (frule (1) obj_at_cslift_tcb)
2016-05-05 22:59:33 +00:00
apply (clarsimp simp: typ_heap_simps ARM_H.msgInfoRegister_def ARM.msgInfoRegister_def
2014-07-14 19:32:44 +00:00
Kernel_C.msgInfoRegister_def Kernel_C.R1_def dest!: c_guard_clift)
done
2017-05-02 01:12:26 +00:00
lemma getMessageInfo_ccorres':
"ccorres (\<lambda>r r'. r = message_info_to_H r') tag_'
2014-07-14 19:32:44 +00:00
(tcb_at' sender) UNIV hs (getMessageInfo sender)
(\<acute>ret__unsigned_long :== CALL getRegister(tcb_ptr_to_ctcb_ptr sender,scast Kernel_C.msgInfoRegister);;
\<acute>tag :== CALL messageInfoFromWord(\<acute>ret__unsigned_long))"
unfolding getMessageInfo_def
apply simp
apply (rule ccorres_guard_imp2)
apply ctac
apply ctac
apply wp
apply vcg
apply (frule (1) obj_at_cslift_tcb)
2016-05-05 22:59:33 +00:00
apply (clarsimp simp: typ_heap_simps ARM_H.msgInfoRegister_def ARM.msgInfoRegister_def
2014-07-14 19:32:44 +00:00
Kernel_C.msgInfoRegister_def Kernel_C.R1_def dest!: c_guard_clift)
done
lemma replyFromKernel_success_empty_ccorres [corres]:
"ccorres dc xfdc \<top> (UNIV \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>) hs
(replyFromKernel thread (0, []))
(Call replyFromKernel_success_empty_'proc)"
apply (subst replyFromKernel_success_empty)
apply (cinit lift: thread_')
apply (rule ccorres_symb_exec_l [OF _ _ _ empty_fail_lookupIPCBuffer])
apply (ctac add: setRegister_ccorres)
apply (unfold setMessageInfo_def)
apply csymbr
apply ctac
apply (simp only: fun_app_def)
apply (ctac add: setRegister_ccorres)
apply wp
apply vcg
apply wp
apply vcg
2017-01-13 12:58:40 +00:00
apply wp+
2016-05-05 22:59:33 +00:00
apply (simp add: ARM_H.msgInfoRegister_def ARM.msgInfoRegister_def
2014-07-14 19:32:44 +00:00
Kernel_C.msgInfoRegister_def Kernel_C.R1_def
2016-05-05 22:59:33 +00:00
ARM_H.badgeRegister_def ARM.badgeRegister_def
2014-07-14 19:32:44 +00:00
Kernel_C.badgeRegister_def Kernel_C.R0_def
message_info_to_H_def)
done
lemma msgRegisters_offset_conv:
2017-05-02 01:12:26 +00:00
"\<And>offset i. \<lbrakk> offset + i < length ARM_H.msgRegisters \<rbrakk> \<Longrightarrow>
2016-05-04 05:07:51 +00:00
index msgRegistersC (unat ((of_nat offset :: word32) + of_nat i)) =
2016-05-01 03:35:49 +00:00
register_from_H (ARM_H.msgRegisters ! (offset + i))"
2016-05-04 05:07:51 +00:00
apply (simp add: msgRegistersC_def msgRegisters_unfold fupdate_def)
2014-07-14 19:32:44 +00:00
apply (subst of_nat_add [symmetric])
apply (case_tac "offset + i", simp_all del: of_nat_add)
apply (case_tac nat, simp, rename_tac nat, simp)+
done
lemmas ccorres_pre_stateAssert =
ccorres_symb_exec_l [OF _ stateAssert_inv stateAssert_wp
empty_fail_stateAssert]
declare setRegister_ccorres[corres]
lemma setMR_ccorres:
notes if_cong[cong]
shows
"ccorres (\<lambda>r r'. r = unat (r' && mask msgLengthBits)) ret__unsigned_'
2015-10-12 13:11:13 +00:00
(valid_pspace' and case_option \<top> valid_ipc_buffer_ptr' buf
and (\<lambda>s. offset < msgMaxLength))
2014-07-14 19:32:44 +00:00
(UNIV \<inter> {s. offset_' s = of_nat offset} \<inter> {s. reg_' s = v}
\<inter> {s. receiver_' s = tcb_ptr_to_ctcb_ptr thread}
\<inter> {s. receiveIPCBuffer_' s = option_to_ptr buf}) []
(setMR thread buf offset v) (Call setMR_'proc)"
apply (rule ccorres_gen_asm)
apply (cinit lift: offset_' reg_' receiver_' receiveIPCBuffer_')
apply (rule ccorres_cond2'[where R=\<top>])
apply (simp add: msgRegisters_unfold n_msgRegisters_def Collect_const_mem
linorder_not_less word_le_nat_alt unat_of_nat32
word_bits_def msgMaxLength_unfold)
apply arith
apply wpc
apply (simp add: option_to_ptr_def option_to_0_def Collect_False
ccorres_cond_iffs
del: Collect_const)
apply (rule ccorres_return_C, simp+)[1]
apply (simp add: option_to_ptr_def option_to_0_def Collect_True
ccorres_cond_iffs
2015-10-12 13:11:13 +00:00
del: Collect_const ptr_add_def')
2014-07-14 19:32:44 +00:00
apply (rule ccorres_cond_true)
2015-10-12 13:11:13 +00:00
apply (rule ccorres_split_nothrow_novcg)
2015-11-16 03:12:37 +00:00
apply (rule ccorres_move_array_assertion_ipc_buffer
| (rule ccorres_flip_Guard, rule ccorres_move_array_assertion_ipc_buffer))+
apply (rule storeWordUser_ccorres)
2015-10-12 13:11:13 +00:00
apply ceqv
2014-07-14 19:32:44 +00:00
apply (rule ccorres_return_C, simp+)[1]
apply wp
2015-10-12 13:11:13 +00:00
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
apply (simp add: msgLengthBits_def msgMaxLength_def
unat_arith_simps less_mask_eq unat_of_nat
del: Collect_const)
2014-07-14 19:32:44 +00:00
apply ctac
apply (rule ccorres_return_C, simp+)[1]
apply wp
apply (simp del: Collect_const)
apply (vcg exspec=setRegister_modifies)
2015-11-16 03:12:37 +00:00
apply (simp add: Collect_const_mem option_to_0_def
unat_gt_0 option_to_ptr_def)
2014-07-14 19:32:44 +00:00
apply (intro impI conjI allI, simp_all)
2015-11-16 03:12:37 +00:00
apply (clarsimp simp: valid_ipc_buffer_ptr'_def)
apply (erule aligned_add_aligned)
apply (simp only: word_size_def is_aligned_mult_triv2[where n=2, simplified])
apply (simp add: msg_align_bits_def)
apply (simp add: n_msgRegisters_def length_msgRegisters msgLengthBits_def mask_def)
2015-10-12 13:11:13 +00:00
apply (simp add: msg_align_bits word_size_def msgMaxLength_def
length_msgRegisters n_msgRegisters_def)
2015-11-16 03:12:37 +00:00
apply (simp add: unat_word_ariths msg_align_bits msgMaxLength_def
2015-10-12 13:11:13 +00:00
word_less_nat_alt unat_of_nat)
2015-11-16 03:12:37 +00:00
apply (simp add: unat_word_ariths msg_align_bits msgMaxLength_def
word_less_nat_alt unat_of_nat)
2015-10-12 13:11:13 +00:00
apply (clarsimp simp: valid_ipc_buffer_ptr'_def)
2014-07-14 19:32:44 +00:00
apply (simp add: unat_of_nat32 word_bits_def msgMaxLength_unfold
word_le_nat_alt msgRegisters_ccorres n_msgRegisters_def)
apply (simp add: unat_of_nat32 msgMaxLength_unfold word_bits_def
unat_add_lem[THEN iffD1] less_mask_eq msgLengthBits_def
word_less_nat_alt)
apply (simp add: linorder_not_le n_msgRegisters_def)
done
lemma setMR_ccorres_dc:
"ccorres dc xfdc
2015-10-12 13:11:13 +00:00
(valid_pspace' and case_option \<top> valid_ipc_buffer_ptr' buf
and (\<lambda>s. offset < msgMaxLength))
2014-07-14 19:32:44 +00:00
(UNIV \<inter> {s. offset_' s = of_nat offset} \<inter> {s. reg_' s = v}
\<inter> {s. receiver_' s = tcb_ptr_to_ctcb_ptr thread}
\<inter> {s. receiveIPCBuffer_' s = option_to_ptr buf}) []
(setMR thread buf offset v) (Call setMR_'proc)"
by (rule ccorres_rel_imp, rule setMR_ccorres, simp)
end
2015-11-16 03:12:37 +00:00
(* FIXME: move *)
2016-05-04 05:07:51 +00:00
context begin interpretation Arch . (*FIXME: arch_split*)
2014-07-14 19:32:44 +00:00
crunch valid_pspace'[wp]: setMR "valid_pspace'"
2015-11-16 03:12:37 +00:00
crunch valid_ipc_buffer_ptr'[wp]: setMR "valid_ipc_buffer_ptr' p"
2016-05-04 05:07:51 +00:00
end
2015-11-16 03:12:37 +00:00
2014-07-14 19:32:44 +00:00
context kernel_m begin
lemma setMRs_lookup_failure_ccorres:
2016-11-10 04:44:36 +00:00
shows
2014-07-14 19:32:44 +00:00
"ccorres (\<lambda>r r'. r \<noteq> [] \<and> last r = unat (r' && mask msgLengthBits))
ret__unsigned_'
(valid_pspace'
2015-11-16 03:12:37 +00:00
and (case buf of None \<Rightarrow> \<top> | Some x \<Rightarrow> valid_ipc_buffer_ptr' x)
2014-07-14 19:32:44 +00:00
and (\<lambda>_. n + length (msgFromLookupFailure lf) < msgMaxLength))
(UNIV \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr thread\<rbrace>
\<inter> \<lbrace>\<acute>receiveIPCBuffer = option_to_ptr buf\<rbrace>
2014-08-09 05:16:17 +00:00
\<inter> \<lbrace>map_option lookup_fault_to_H
2014-07-14 19:32:44 +00:00
(lookup_fault_lift \<acute>luf) = Some lf\<rbrace>
\<inter> \<lbrace>n = unat \<acute>offset\<rbrace>) hs
(mapM (\<lambda>(x, y). setMR thread buf x y)
(zip [n ..< msgMaxLength] (msgFromLookupFailure lf)))
(Call setMRs_lookup_failure_'proc)"
apply (rule ccorres_gen_asm)+
apply (cinit' lift: receiver_' receiveIPCBuffer_' luf_' offset_')
apply csymbr
2015-11-16 03:12:37 +00:00
apply (rule_tac P="valid_pspace'
and (case buf of None \<Rightarrow> \<top> | Some x \<Rightarrow> valid_ipc_buffer_ptr' x)" and P'=UNIV
2014-07-14 19:32:44 +00:00
in ccorres_inst)
apply (clarsimp simp: msgFromLookupFailure_def lookup_fault_lift_def
Let_def zip_upt_Cons msgMaxLength_unfold
mapM_Cons mapM_Nil bind_assoc
simp del: Collect_const
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_guard_imp2)
apply csymbr
apply (ctac add: setMR_ccorres)
2016-11-10 04:44:36 +00:00
apply (ccorres_rewrite)
2014-07-14 19:32:44 +00:00
apply (simp add: ccorres_cond_iffs)
apply (rule ccorres_return_C, simp+)[1]
apply wp
apply (simp del: Collect_const)
apply (vcg exspec=setMR_modifies)
apply (clarsimp simp: msgMaxLength_unfold Collect_const_mem)
apply (simp add: lookup_fault_tag_defs)
apply (rule ccorres_guard_imp2)
apply csymbr
apply (ctac add: setMR_ccorres)
apply (simp add: ccorres_cond_iffs)
2016-11-10 04:44:36 +00:00
apply (ccorres_rewrite)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_rhs_assoc)+
apply csymbr
apply (ctac add: setMR_ccorres)
apply (rule ccorres_return_C, simp+)[1]
apply wp
apply simp
apply (vcg exspec=setMR_modifies)
2015-11-16 03:12:37 +00:00
apply (wp hoare_case_option_wp)
2014-07-14 19:32:44 +00:00
apply (simp add: Collect_const_mem)
apply (vcg exspec=setMR_modifies)
apply (clarsimp simp: msgMaxLength_unfold Collect_const_mem)
apply (simp add: lookup_fault_missing_capability_lift_def
lookup_fault_lift_missing_capability)
apply (simp add: lookup_fault_tag_defs)
apply (rule ccorres_guard_imp2)
apply csymbr
apply (ctac add: setMR_ccorres)
apply (simp add: ccorres_cond_iffs)
2016-11-10 04:44:36 +00:00
apply (ccorres_rewrite)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_rhs_assoc)+
apply csymbr
apply (ctac add: setMR_ccorres_dc)
apply csymbr
apply (ctac add: setMR_ccorres)
apply (rule ccorres_return_C, simp+)[1]
apply wp
apply simp
apply (vcg exspec=setMR_modifies)
2015-11-16 03:12:37 +00:00
apply (wp hoare_case_option_wp)
2014-07-14 19:32:44 +00:00
apply (simp add: Collect_const_mem)
apply (vcg exspec=setMR_modifies)
2015-11-16 03:12:37 +00:00
apply (wp hoare_case_option_wp)
2014-07-14 19:32:44 +00:00
apply (simp add: Collect_const_mem)
apply (vcg exspec=setMR_modifies)
apply (clarsimp simp: msgMaxLength_unfold Collect_const_mem)
apply (simp add: lookup_fault_depth_mismatch_lift_def
lookup_fault_lift_depth_mismatch)
apply (simp add: lookup_fault_tag_defs)
apply (rule ccorres_guard_imp2)
apply csymbr
apply (ctac add: setMR_ccorres)
apply (simp add: ccorres_cond_iffs)
2016-11-10 04:44:36 +00:00
apply (ccorres_rewrite)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_rhs_assoc)+
apply csymbr
apply (ctac add: setMR_ccorres_dc)
apply csymbr
apply (ctac add: setMR_ccorres_dc)
apply csymbr
apply (ctac add: setMR_ccorres)
apply (rule ccorres_return_C, simp+)[1]
2015-11-16 03:12:37 +00:00
apply (wp hoare_case_option_wp
| (simp add: Collect_const_mem, vcg exspec=setMR_modifies))+
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: msgMaxLength_unfold Collect_const_mem)
apply (simp add: lookup_fault_guard_mismatch_lift_def
lookup_fault_lift_guard_mismatch)
apply (simp add: lookup_fault_tag_defs)
apply simp
done
lemma setMRs_syscall_error_ccorres:
2015-12-08 06:29:42 +00:00
"ccorres (\<lambda>r r'. r = r' && mask msgLengthBits) ret__unsigned_long_'
2014-07-14 19:32:44 +00:00
(valid_pspace'
2015-11-16 03:12:37 +00:00
and (case buf of None \<Rightarrow> \<top> | Some x \<Rightarrow> valid_ipc_buffer_ptr' x)
2014-07-14 19:32:44 +00:00
and (\<lambda>_. msg = snd (msgFromSyscallError err)))
(UNIV \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>
\<inter> \<lbrace>\<acute>receiveIPCBuffer = option_to_ptr buf\<rbrace>
\<inter> \<lbrace>syscall_error_to_H \<acute>current_syscall_error
(lookup_fault_lift \<acute>current_lookup_fault)
= Some err\<rbrace>) hs
(setMRs thread buf msg)
(Call setMRs_syscall_error_'proc)"
2015-12-08 06:29:42 +00:00
(is "ccorres ?r ret__unsigned_long_' ?P ?P' hs ?a ?c")
2014-07-14 19:32:44 +00:00
apply (rule ccorres_gen_asm)
apply (cinit')
apply (rule_tac xf' = "\<lambda>s. current_syscall_error_' (globals s)"
in ccorres_abstract)
apply (rule ceqv_rules, rule rewrite_xfI, simp, rule ceqv_refl)+
apply (rule ceqv_refl)
apply (rename_tac err')
apply (rule_tac xf' = "\<lambda>s. current_lookup_fault_' (globals s)"
in ccorres_abstract)
apply (rule ceqv_rules, rule rewrite_xfI, simp, rule ceqv_refl)+
apply (rule ceqv_refl)
2017-05-02 01:12:26 +00:00
apply (rename_tac luf')
2014-07-14 19:32:44 +00:00
apply (rule_tac P="Some err = syscall_error_to_H err' (lookup_fault_lift luf')"
in ccorres_gen_asm2)
apply (rule_tac A="?P" and A'="?P'" in ccorres_guard_imp2)
apply (simp add: setMRs_to_setMR del: Collect_const)
apply (rule ccorres_stateAssert)
apply (rule ccorres_Cond_rhs[rotated])+
apply (rule ccorres_inst[where P=\<top> and P'=UNIV])
apply simp
apply (rule ccorres_inst[where P=\<top> and P'=UNIV])
apply (simp add: syscall_error_to_H_def)
apply (simp_all add: syscall_error_to_H_def msgFromSyscallError_def
zipWithM_mapM mapM_Nil mapM_Cons
msgMaxLength_unfold zip_upt_Cons bind_assoc)
apply (ctac add:setMR_ccorres)
apply (rule ccorres_return_C,simp+)[1]
apply (wp | (simp add: Collect_const_mem,
vcg exspec=setMR_modifies exspec=setMRs_lookup_failure_modifies))+
apply (subgoal_tac "msg = []")
apply (simp add: zipWithM_mapM mapM_Nil)
apply (rule ccorres_return_C, simp+)[1]
2016-10-25 06:01:30 +00:00
apply (simp split: if_split_asm)
2014-07-14 19:32:44 +00:00
apply (subgoal_tac "err = FailedLookup (to_bool (failedLookupWasSource_C err'))
(lookup_fault_to_H (the (lookup_fault_lift luf')))")
apply (simp add: zip_upt_Cons mapM_Cons bind_assoc)
apply (rule ccorres_rhs_assoc)+
apply (ctac add: setMR_ccorres_dc)
apply (ctac add: setMRs_lookup_failure_ccorres[unfolded msgMaxLength_unfold])
apply (rule ccorres_return_C, simp+)[1]
2015-11-16 03:12:37 +00:00
apply (wp hoare_case_option_wp
| (simp add: Collect_const_mem,
2014-07-14 19:32:44 +00:00
vcg exspec=setMR_modifies exspec=setMRs_lookup_failure_modifies))+
2016-04-18 20:25:44 +00:00
apply (clarsimp simp: map_option_Some_eq2)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_return_C, simp+)[1]
apply (rule ccorres_rhs_assoc
| (rule ccorres_inst, ctac add: setMR_ccorres_dc)
| (rule ccorres_inst, ctac add: setMR_ccorres)
| (rule ccorres_return_C, simp+)[1]
2015-11-16 03:12:37 +00:00
| wp hoare_case_option_wp
2014-07-14 19:32:44 +00:00
| (simp del: Collect_const, vcg exspec=setMR_modifies)
)+
apply (simp add: msgMaxLength_unfold if_1_0_0 true_def false_def)
2016-10-25 06:01:30 +00:00
apply (clarsimp split:if_split_asm simp:syscall_error_to_H_def map_option_Some_eq2)
2014-07-14 19:32:44 +00:00
apply (simp add: msgFromLookupFailure_def
split: lookup_failure.split
2016-10-25 06:01:30 +00:00
| simp add: to_bool_def split: if_split)+
2014-07-14 19:32:44 +00:00
done
lemma lookupIPCBuffer_aligned_option_to_0:
"\<lbrace>valid_objs'\<rbrace> lookupIPCBuffer b s \<lbrace>\<lambda>rv s. is_aligned (option_to_0 rv) msg_align_bits\<rbrace>"
apply (rule hoare_strengthen_post, rule lookupIPCBuffer_valid_ipc_buffer)
apply (simp add: option_to_0_def valid_ipc_buffer_ptr'_def split: option.split_asm)
done
2016-07-04 07:35:42 +00:00
lemma Cond_if_mem:
"(Cond (if P then UNIV else {})) = (Cond {s. P})"
by simp
2014-07-14 19:32:44 +00:00
lemma copyMRs_register_loop_helper:
fixes n
2016-05-01 03:35:49 +00:00
defines regs: "regs \<equiv> take (unat n) ARM_H.msgRegisters"
2014-07-14 19:32:44 +00:00
shows
"\<forall>i. i<length regs \<longrightarrow>
ccorres dc xfdc \<top> \<lbrace>\<acute>i = of_nat i\<rbrace> hs
(do v \<leftarrow> asUser sender (getRegister (regs ! i));
asUser receiver (setRegister (regs ! i) v)
od)
(Guard ArrayBounds \<lbrace>\<acute>i < 4\<rbrace>
(\<acute>ret__unsigned_long :== CALL getRegister(tcb_ptr_to_ctcb_ptr sender,
2016-05-04 05:07:51 +00:00
ucast (index msgRegistersC (unat \<acute>i))));;
2014-07-14 19:32:44 +00:00
Guard ArrayBounds \<lbrace>\<acute>i < 4\<rbrace>
(CALL setRegister(tcb_ptr_to_ctcb_ptr receiver,
2016-05-04 05:07:51 +00:00
ucast (index msgRegistersC (unat \<acute>i)),
2014-07-14 19:32:44 +00:00
\<acute>ret__unsigned_long)))"
apply clarsimp
apply (rule ccorres_guard_imp)
apply ctac
apply ctac
apply wp
apply vcg
apply simp
2016-05-04 05:07:51 +00:00
apply (clarsimp simp: regs msgRegistersC_def msgRegisters_unfold)
2014-07-14 19:32:44 +00:00
apply (simp |
(case_tac i,
clarsimp simp: fupdate_def index_update index_update2 Kernel_C.R2_def
Kernel_C.R3_def Kernel_C.R4_def Kernel_C.R5_def
Kernel_C.R6_def Kernel_C.R7_def,
rename_tac i))+
done
lemma mab_gt_2 [simp]:
"2 \<le> msg_align_bits" by (simp add: msg_align_bits)
lemma wb_gt_2:
"2 < word_bits" by (simp add: word_bits_conv)
(* FIXME move *)
lemma mapM_only_length:
"do ys \<leftarrow> mapM f xs;
g (length ys)
od =
do _ \<leftarrow> mapM_x f xs;
g (length xs)
od"
by (subst bind_return_subst [OF mapM_length])
(rule mapM_discarded)
lemma length_upto_enum_cases:
fixes a :: word32
shows "length [a .e. b] = (if a \<le> b then Suc (unat b) - unat a else 0)"
apply (case_tac "a \<le> b")
apply (clarsimp simp: length_upto_enum)
apply (clarsimp simp: upto_enum_def)
apply unat_arith
done
(* FIXME move *)
lemma copyMRs_ccorres [corres]:
2015-09-30 18:05:05 +00:00
notes
wordSize_def'[simp]
shows
2015-12-08 06:29:42 +00:00
"ccorres (\<lambda>r r'. r = r' && mask msgLengthBits) ret__unsigned_long_'
2014-07-14 19:32:44 +00:00
(valid_pspace' and tcb_at' sender and tcb_at' receiver
2015-11-16 03:12:37 +00:00
and (case sendBuffer of None \<Rightarrow> \<top> | Some x \<Rightarrow> valid_ipc_buffer_ptr' x)
and (case recvBuffer of None \<Rightarrow> \<top> | Some x \<Rightarrow> valid_ipc_buffer_ptr' x)
2014-07-14 19:32:44 +00:00
and K (sendBuffer \<noteq> Some 0) and K (recvBuffer \<noteq> Some 0)
and K (unat n \<le> msgMaxLength))
(UNIV \<inter> \<lbrace>\<acute>n = \<acute>n && mask msgLengthBits \<and> \<acute>n = n\<rbrace>
\<inter> \<lbrace>\<acute>sendBuf = Ptr (option_to_0 sendBuffer)\<rbrace>
\<inter> \<lbrace>\<acute>recvBuf = Ptr (option_to_0 recvBuffer)\<rbrace>
\<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>) []
(copyMRs sender sendBuffer receiver recvBuffer n)
(Call copyMRs_'proc)"
apply (unfold K_def, intro ccorres_gen_asm)
apply (cinit lift: n_' sendBuf_' recvBuf_' sender_' receiver_'
simp: whileAnno_def)
apply (simp only: mapM_discarded)
apply (rule ccorres_rhs_assoc2)
2016-05-01 03:35:49 +00:00
apply (rule_tac P = "length (take (unat n) ARM_H.msgRegisters) <
2014-07-14 19:32:44 +00:00
2 ^ word_bits"
in ccorres_gen_asm)
apply (rule ccorres_split_nothrow_novcg)
apply (rule ccorres_mapM_x_while [OF copyMRs_register_loop_helper[unfolded ucast_id]])
apply (clarsimp simp: n_msgRegisters_def
2015-11-16 03:12:37 +00:00
length_msgRegisters min_def
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
apply unat_arith
apply vcg
apply simp
apply wp
apply assumption
apply ceqv
2015-11-16 03:12:37 +00:00
apply (wpc, simp add: option_to_0_def)
apply (rule ccorres_split_throws, rule ccorres_return_C, simp+)
apply vcg
apply (wpc, simp_all add: option_to_0_def)[1]
apply (rule ccorres_split_throws, rule ccorres_return_C, simp+)
apply vcg
apply (subst mapM_only_length)
2016-05-01 03:35:49 +00:00
apply (rule_tac P="unat n \<le> length ARM_H.msgRegisters" in ccorres_cases)
2015-11-16 03:12:37 +00:00
apply (simp add: upto_enum_def length_msgRegisters n_msgRegisters_def
mapM_x_Nil)
apply (rule ccorres_expand_while_iff_Seq[THEN iffD1])
apply (rule ccorres_cond_false)
apply (rule ccorres_return_C, simp+)
apply (rule ccorres_split_nothrow_novcg)
2016-05-01 03:35:49 +00:00
apply (rule_tac i="length ARM_H.msgRegisters"
2015-11-16 03:12:37 +00:00
and F="\<lambda>_. valid_ipc_buffer_ptr' (the sendBuffer)
and valid_ipc_buffer_ptr' (the recvBuffer)
and valid_pspace'"
in ccorres_mapM_x_while')
apply clarsimp
apply (rule ccorres_guard_imp)
apply (rule ccorres_pre_loadWordUser)
apply (unfold storeWordUser_def)
apply (rule ccorres_pre_stateAssert)
apply (unfold K_bind_def)
apply (rule ccorres_move_array_assertion_ipc_buffer
ccorres_Guard[where S="{s. h_t_valid (htd s) c_guard (ptr s)}" for ptr htd])+
apply (ctac add: storeWord_ccorres)
apply (clarsimp simp: word_size valid_ipc_buffer_ptr'_def
msg_align_bits
aligned_add_aligned[OF _ is_aligned_mult_triv2[where n=2, simplified]])
apply (clarsimp simp: msgRegisters_unfold upto_enum_word word_size
pointerInUserData_h_t_valid pointerInUserData_c_guard
typ_heap_simps'
2016-10-25 06:01:30 +00:00
split: if_split_asm simp del: upt.simps)
2015-11-16 03:12:37 +00:00
apply (simp only: unat_arith_simps unat_of_nat msg_align_bits
2016-10-25 06:01:30 +00:00
msgMaxLength_def, simp split: if_split)
2015-11-16 03:12:37 +00:00
apply arith
apply (simp add: n_msgRegisters_def length_msgRegisters)
apply (rule allI, rule conseqPre, vcg)
apply clarsimp
apply (rule hoare_pre, wp hoare_valid_ipc_buffer_ptr_typ_at')
apply clarsimp
apply (simp add: length_msgRegisters n_msgRegisters_def msgMaxLength_def
word_bits_def)
apply ceqv
apply simp
apply (rule ccorres_return_C, simp_all)[1]
apply wp
apply clarsimp
apply (clarsimp simp: guard_is_UNIV_def upto_enum_def
min_def word_le_nat_alt
length_msgRegisters n_msgRegisters_def
msgLengthBits_def mask_def
linorder_not_le)
apply simp
apply (wp mapM_x_wp' hoare_vcg_all_lift hoare_vcg_const_imp_lift | simp)+
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: guard_is_UNIV_def
2015-11-16 03:12:37 +00:00
length_msgRegisters n_msgRegisters_def mask_def
Types_H.msgLengthBits_def min_def word_le_nat_alt
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
apply unat_arith
2015-11-16 03:12:37 +00:00
apply (clarsimp simp: length_msgRegisters n_msgRegisters_def
2014-07-14 19:32:44 +00:00
msgLengthBits_def min_def word_bits_def)
2016-10-25 06:01:30 +00:00
apply (auto split: if_split)
2014-07-14 19:32:44 +00:00
done
declare zipWith_Nil2[simp]
declare zipWithM_x_Nil2[simp]
lemma getRestartPC_ccorres [corres]:
"ccorres (op =) ret__unsigned_long_' \<top>
(UNIV \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>) hs
(asUser thread (getRegister register.FaultInstruction))
(Call getRestartPC_'proc)"
apply (cinit' lift: thread_')
apply (rule ccorres_trim_return, simp, simp)
apply ctac
apply clarsimp
done
lemma asUser_tcbFault_obj_at:
"\<lbrace>obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace> asUser t' m
\<lbrace>\<lambda>rv. obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>"
apply (simp add: asUser_def split_def)
apply (wp threadGet_wp)
apply simp
done
2016-11-10 04:44:36 +00:00
lemma asUser_atcbContext_obj_at:
"t \<noteq> t' \<Longrightarrow>
\<lbrace>obj_at' (\<lambda>tcb. P ((atcbContextGet o tcbArch) tcb)) t\<rbrace>
asUser t' m
\<lbrace>\<lambda>rv. obj_at' (\<lambda>tcb. P ((atcbContextGet o tcbArch) tcb)) t\<rbrace>"
apply (simp add: asUser_def split_def atcbContextGet_def atcbContextSet_def)
apply (wp threadGet_wp)
apply simp
done
2014-07-14 19:32:44 +00:00
lemma asUser_tcbFault_inv:
"\<lbrace>\<lambda>s. \<exists>t. ko_at' t p' s \<and> tcbFault t = f\<rbrace> asUser p m
\<lbrace>\<lambda>rv s. \<exists>t. ko_at' t p' s \<and> tcbFault t = f\<rbrace>"
apply (rule_tac Q="\<lambda>rv. obj_at' (\<lambda>t. tcbFault t = f) p'"
in hoare_strengthen_post)
apply (wp asUser_tcbFault_obj_at)
apply (clarsimp simp: obj_at'_def)+
done
2016-11-10 04:44:36 +00:00
lemma setMR_atcbContext_obj_at:
"t \<noteq> t' \<Longrightarrow>
\<lbrace>obj_at' (\<lambda>tcb. P ((atcbContextGet o tcbArch) tcb)) t\<rbrace>
setMR t' b r v
\<lbrace>\<lambda>rv. obj_at' (\<lambda>tcb. P ((atcbContextGet o tcbArch) tcb)) t\<rbrace>"
2016-10-25 06:01:30 +00:00
apply (simp add: setMR_def split del: if_split)
2016-11-10 04:44:36 +00:00
apply (rule hoare_pre)
apply (wp asUser_atcbContext_obj_at[simplified] | simp | wpc)+
done
2014-07-14 19:32:44 +00:00
lemma setMR_tcbFault_obj_at:
"\<lbrace>obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace> setMR t' b r v
\<lbrace>\<lambda>rv. obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>"
2016-10-25 06:01:30 +00:00
apply (simp add: setMR_def split del: if_split)
2014-07-14 19:32:44 +00:00
apply (rule hoare_pre)
apply (wp asUser_tcbFault_obj_at | wpc)+
apply simp
done
(* FIXME move *)
lemma from_bool_to_bool_and_1 [simp]:
assumes r_size: "1 < size r"
shows "from_bool (to_bool (r && 1)) = r && 1"
proof -
from r_size have "r && 1 < 2"
by (simp add: and_mask_less_size [where n=1, unfolded mask_def, simplified])
thus ?thesis
by (fastforce simp add: from_bool_def to_bool_def dest: word_less_cases)
qed
(* FIXME move to Corres_C and remove from Tcb_C *)
lemma ccorres_abstract_known:
"\<lbrakk> \<And>rv' t t'. ceqv \<Gamma> xf' rv' t t' g (g' rv'); ccorres rvr xf P P' hs f (g' val) \<rbrakk>
\<Longrightarrow> ccorres rvr xf P (P' \<inter> {s. xf' s = val}) hs f g"
apply (rule ccorres_guard_imp2)
apply (rule_tac xf'=xf' in ccorres_abstract)
apply assumption
apply (rule_tac P="rv' = val" in ccorres_gen_asm2)
apply simp
apply simp
done
lemma ccorres_add_getRegister:
"ccorres rv xf P P' hs (asUser t (getRegister r) >>= (\<lambda>_. a)) c
\<Longrightarrow> ccorres rv xf (P and tcb_at' t) P' hs a c"
apply (simp add: asUser_getRegister_discarded)
apply (simp add: ccorres_underlying_def)
apply (elim ballEI | clarsimp del: allI)+
apply (drule mp)
apply (simp add: stateAssert_def bind_assoc exec_get)
apply (elim allEI)
apply (clarsimp simp: in_monad stateAssert_def split: xstate.split_asm)
apply fastforce
done
lemma user_getreg_rv:
2016-11-10 04:44:36 +00:00
"\<lbrace>obj_at' (\<lambda>tcb. P ((atcbContextGet o tcbArch) tcb r)) t\<rbrace> asUser t (getRegister r) \<lbrace>\<lambda>rv s. P rv\<rbrace>"
2014-07-14 19:32:44 +00:00
apply (simp add: asUser_def split_def)
apply (wp threadGet_wp)
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: obj_at'_def projectKOs getRegister_def in_monad atcbContextGet_def)
2014-07-14 19:32:44 +00:00
done
lemma exceptionMessage_ccorres:
"n < unat n_exceptionMessage
2016-05-01 03:35:49 +00:00
\<Longrightarrow> register_from_H (ARM_H.exceptionMessage ! n)
2016-05-04 05:07:51 +00:00
= index exceptionMessageC n"
apply (simp add: exceptionMessageC_def ARM_H.exceptionMessage_def
2016-11-10 04:44:36 +00:00
ARM.exceptionMessage_def MessageID_Exception_def)
2017-01-13 12:58:40 +00:00
by (simp add: Arrays.update_def n_exceptionMessage_def fcp_beta nth_Cons'
fupdate_def
split: if_split)
2014-07-14 19:32:44 +00:00
lemma asUser_obj_at_elsewhere:
"\<lbrace>obj_at' (P :: tcb \<Rightarrow> bool) t' and (\<lambda>_. t \<noteq> t')\<rbrace> asUser t m \<lbrace>\<lambda>rv. obj_at' P t'\<rbrace>"
apply (rule hoare_gen_asm')
apply (simp add: asUser_def split_def)
apply (wp threadGet_wp)
apply clarsimp
done
2016-11-10 04:44:36 +00:00
lemma exceptionMessage_length_aux :
"\<And>n. n < length ARM_H.exceptionMessage \<Longrightarrow> n < unat n_exceptionMessage"
by (simp add: ARM.exceptionMessage_def ARM_H.exceptionMessage_def n_exceptionMessage_def)
lemma copyMRsFault_ccorres_exception:
"ccorres dc xfdc
(valid_pspace'
and obj_at' (\<lambda>tcb. map (atcbContext (tcbArch tcb)) ARM_H.exceptionMessage = msg) sender
and K (length msg = 3)
and K (recvBuffer \<noteq> Some 0)
and K (sender \<noteq> receiver))
(UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
\<inter> \<lbrace>\<acute>receiveIPCBuffer = Ptr (option_to_0 recvBuffer)\<rbrace>
\<inter> \<lbrace> \<acute>length___unsigned_long = 3 \<rbrace>
\<inter> \<lbrace> \<acute>id___anonymous_enum = MessageID_Exception \<rbrace>)
hs
(mapM_x (\<lambda>(x, y). setMR receiver recvBuffer x y) (zip [0..<120] msg))
(Call copyMRsFault_'proc)"
apply (unfold K_def)
apply (intro ccorres_gen_asm)
apply (cinit' lift: sender_' receiver_' receiveIPCBuffer_'
length___unsigned_long_' id___anonymous_enum_'
simp: whileAnno_def)
apply (simp only: mapM_x_append[where xs="take (unat n_msgRegisters) (zip as bs)"
and ys="drop (unat n_msgRegisters) (zip as bs)"
for as bs, simplified] bind_assoc)
apply (rule ccorres_rhs_assoc2, rule ccorres_split_nothrow_novcg)
apply (rule_tac F="K $ obj_at' (\<lambda>tcb. map ((atcbContext o tcbArch) tcb) ARM_H.exceptionMessage = msg) sender"
in ccorres_mapM_x_while)
apply (clarsimp simp: n_msgRegisters_def)
apply (rule ccorres_guard_imp2)
apply (rule_tac t=sender and r="ARM_H.exceptionMessage ! n"
in ccorres_add_getRegister)
apply (ctac(no_vcg))
apply (rule_tac P="\<lambda>s. rv = msg ! n" in ccorres_cross_over_guard)
apply (simp add: setMR_def length_msgRegisters n_msgRegisters_def
liftM_def[symmetric])
apply ctac
apply (wp user_getreg_rv)
apply (clarsimp simp: msgRegisters_ccorres n_msgRegisters_def
syscallMessage_ccorres n_syscallMessage_def
obj_at'_def projectKOs
atcbContextGet_def unat_of_nat32[unfolded word_bits_def])
apply (clarsimp simp: exceptionMessage_ccorres[simplified,symmetric,OF exceptionMessage_length_aux])
apply (clarsimp simp: word_of_nat_less MessageID_Exception_def)
apply (clarsimp simp: n_msgRegisters_def foo)
apply (rule allI, rule conseqPre, vcg exspec=setRegister_modifies exspec=getRegister_modifies)
apply simp
2016-10-25 06:01:30 +00:00
apply (simp add: setMR_def split del: if_split)
2016-11-10 04:44:36 +00:00
apply (rule hoare_pre)
apply (wp asUser_obj_at_elsewhere | wpc)+
apply simp
apply (simp add: word_bits_def)
apply ceqv
apply (rule ccorres_Cond_rhs)
apply (simp del: Collect_const)
apply (simp add: n_msgRegisters_def mapM_x_Nil)
apply (subst ccorres_expand_while_iff[symmetric])
apply (rule ccorres_cond_false)
apply (rule ccorres_return_Skip')
apply (simp add: n_msgRegisters_def mapM_x_Nil)
apply (rule ccorres_return_Skip')
apply wp
apply (simp add: guard_is_UNIV_def)
apply (clarsimp)
done
lemma mapM_cong: "\<lbrakk> \<forall>x. elem x xs \<longrightarrow> f x = g x \<rbrakk> \<Longrightarrow> mapM_x f xs = mapM_x g xs"
by (induction xs, (simp add: mapM_x_Nil mapM_x_Cons)+)
lemma copyMRsFault_ccorres_syscall:
"ccorres dc xfdc
(valid_pspace'
and obj_at' (\<lambda>tcb. map (atcbContext (tcbArch tcb)) ARM_H.syscallMessage = msg) sender
and (case recvBuffer of Some x \<Rightarrow> valid_ipc_buffer_ptr' x | None \<Rightarrow> \<top>)
and K (length msg = 12)
and K (recvBuffer \<noteq> Some 0)
and K (sender \<noteq> receiver))
(UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
\<inter> \<lbrace>\<acute>receiveIPCBuffer = Ptr (option_to_0 recvBuffer)\<rbrace>
\<inter> \<lbrace>\<acute>length___unsigned_long = 12 \<rbrace>
\<inter> \<lbrace> \<acute>id___anonymous_enum = MessageID_Syscall \<rbrace>)
hs
(mapM_x (\<lambda>(x, y). setMR receiver recvBuffer x y) (zip [0..<120] msg))
(Call copyMRsFault_'proc)"
proof -
(* auxiliary lemmas *)
have option_to_0_imp : "\<lbrakk> option_to_0 recvBuffer= 0 ; recvBuffer \<noteq> Some 0 \<rbrakk> \<Longrightarrow> recvBuffer = None"
by (simp add: option_to_0_def; cases recvBuffer; simp+)
have drop_n: "\<And>n m. drop n [0..<m] = [n..<m]"
by simp
have less_than_4: "\<And>x y n m. elem (x, y) (zip [n..<120] m) \<Longrightarrow> \<not> x < n "
by (simp | erule in_set_zipE)+
have msg_aux: "\<forall>p. elem p (zip [4..<120] (drop 4 msg))
\<longrightarrow> (\<lambda>(x1,y1). setMR receiver None x1 y1) p = (\<lambda>_ . return (length msgRegisters)) p"
by (fastforce simp add: numeral_eqs setMR_def less_than_4 n_msgRegisters_def length_msgRegisters)
have mapM_x_return_gen: "\<And>v w xs. mapM_x (\<lambda>_. return v) xs = return w" (* FIXME mapM_x_return *)
by (induct_tac xs; simp add: mapM_x_Nil mapM_x_Cons)
show ?thesis
2017-01-13 12:58:40 +00:00
including no_pre
2016-11-10 04:44:36 +00:00
apply (unfold K_def)
apply (intro ccorres_gen_asm)
apply (cinit' lift: sender_' receiver_' receiveIPCBuffer_'
length___unsigned_long_' id___anonymous_enum_'
simp: whileAnno_def)
apply (simp only: mapM_x_append[where xs="take (unat n_msgRegisters) (zip as bs)"
and ys="drop (unat n_msgRegisters) (zip as bs)"
for as bs, simplified] bind_assoc)
apply (rule ccorres_rhs_assoc2, rule ccorres_split_nothrow_novcg)
apply (rule_tac F="K $ obj_at' (\<lambda>tcb. map ((atcbContext o tcbArch) tcb) ARM_H.syscallMessage = msg) sender"
in ccorres_mapM_x_while)
apply (clarsimp simp: n_msgRegisters_def)
apply (rule ccorres_guard_imp2)
apply (rule_tac t=sender and r="ARM_H.syscallMessage ! n"
in ccorres_add_getRegister)
apply (ctac(no_vcg))
apply (rule_tac P="\<lambda>s. rv = msg ! n" in ccorres_cross_over_guard)
apply (simp add: setMR_def length_msgRegisters n_msgRegisters_def
liftM_def[symmetric])
apply ctac
apply (wp user_getreg_rv)
apply (clarsimp simp: msgRegisters_ccorres n_msgRegisters_def
syscallMessage_ccorres n_syscallMessage_def
obj_at'_def projectKOs
atcbContextGet_def unat_of_nat32[unfolded word_bits_def])
apply (clarsimp simp: word_of_nat_less MessageID_Syscall_def)
apply (simp add: n_msgRegisters_def)
apply (rule allI, rule conseqPre, vcg exspec=setRegister_modifies exspec=getRegister_modifies)
apply simp
2016-10-25 06:01:30 +00:00
apply (simp add: setMR_def split del: if_split)
2016-11-10 04:44:36 +00:00
apply (rule hoare_pre)
apply (wp asUser_obj_at_elsewhere | wpc)+
apply simp
apply (simp add: word_bits_def)
apply ceqv
apply (rule ccorres_Cond_rhs)
apply (simp del: Collect_const)
apply (rule ccorres_rel_imp[where r = "\<lambda>rv rv'. True", simplified])
apply (rule_tac F="\<lambda>_. obj_at' (\<lambda>tcb. map ((atcbContext o tcbArch) tcb) ARM_H.syscallMessage = msg)
sender and valid_pspace'
and (case recvBuffer of Some x \<Rightarrow> valid_ipc_buffer_ptr' x | None \<Rightarrow> \<top>)"
in ccorres_mapM_x_while'[where i="unat n_msgRegisters"])
apply (clarsimp simp: setMR_def n_msgRegisters_def length_msgRegisters
option_to_0_def liftM_def[symmetric]
split: option.split_asm)
apply (rule ccorres_guard_imp2)
apply (rule_tac t=sender and r="ARM_H.syscallMessage ! (n + unat n_msgRegisters)"
in ccorres_add_getRegister)
apply (ctac(no_vcg))
apply (rule_tac P="\<lambda>s. rv = msg ! (n + unat n_msgRegisters)"
in ccorres_cross_over_guard)
apply (rule ccorres_move_array_assertion_ipc_buffer
| (rule ccorres_flip_Guard, rule ccorres_move_array_assertion_ipc_buffer))+
apply (simp add: storeWordUser_def)
apply (rule ccorres_pre_stateAssert)
apply (ctac add: storeWord_ccorres[unfolded fun_app_def])
apply (simp add: pred_conj_def)
apply (wp user_getreg_rv)
apply (clarsimp simp: n_syscallMessage_def n_msgRegisters_def
syscallMessage_ccorres msgRegisters_ccorres
unat_add_lem[THEN iffD1] unat_of_nat32
word_bits_def word_size_def)
apply (simp only:field_simps imp_ex imp_conjL)
apply (clarsimp simp: pointerInUserData_c_guard obj_at'_def
pointerInUserData_h_t_valid
atcbContextGet_def
projectKOs objBits_simps word_less_nat_alt
unat_add_lem[THEN iffD1] unat_of_nat)
apply (clarsimp simp: pointerInUserData_h_t_valid rf_sr_def
MessageID_Syscall_def
msg_align_bits valid_ipc_buffer_ptr'_def)
apply (erule aligned_add_aligned)
apply (rule aligned_add_aligned[where n=2])
apply (simp add: is_aligned_def)
apply (rule is_aligned_mult_triv2 [where n=2, simplified])
apply (simp add: wb_gt_2)+
apply (simp add: n_msgRegisters_def)
apply (vcg exspec=getRegister_modifies)
apply simp
apply (simp add: setMR_def n_msgRegisters_def length_msgRegisters)
apply (rule hoare_pre)
apply (wp hoare_case_option_wp | wpc)+
apply clarsimp
apply (simp add: n_msgRegisters_def word_bits_def)
apply (simp add: n_msgRegisters_def)
apply (frule (1) option_to_0_imp)
apply (subst drop_zip)
apply (subst drop_n)
apply (clarsimp simp: n_msgRegisters_def numeral_eqs
mapM_cong[OF msg_aux, simplified numeral_eqs]
mapM_x_return_gen)
apply (subst mapM_x_return_gen[where w2="()"])
apply (rule ccorres_return_Skip[simplified dc_def])
apply (clarsimp)
apply (rule hoare_impI)
apply (wp mapM_x_wp_inv setMR_atcbContext_obj_at[simplified atcbContextGet_def, simplified]
| clarsimp
| wpc)+
apply (cases recvBuffer; simp add: option_to_0_def )
apply wp
apply (clarsimp simp: guard_is_UNIV_def n_msgRegisters_def msgLengthBits_def
mask_def)+
done
qed
lemma Arch_setMRs_fault_ccorres:
"ccorres (\<lambda>r r'. r = r' && mask msgLengthBits) ret__unsigned_long_'
(valid_pspace' and obj_at' (\<lambda>tcb. tcbFault tcb = Some ft) sender
and K (ft = ArchFault aft)
and (case buffer of Some x \<Rightarrow> valid_ipc_buffer_ptr' x | None \<Rightarrow> \<top>)
and K (buffer \<noteq> Some 0)
and K (sender \<noteq> receiver))
(UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
\<inter> \<lbrace>\<acute>faultType = fault_to_fault_tag ft \<rbrace>
\<inter> \<lbrace>\<acute>receiveIPCBuffer = Ptr (option_to_0 buffer)\<rbrace>) hs
(makeArchFaultMessage aft sender >>= (\<lambda>ms. setMRs receiver buffer (snd ms)))
(Call Arch_setMRs_fault_'proc)"
proof -
let ?obj_at_ft = "obj_at' (\<lambda>tcb. tcbFault tcb = Some ft) sender"
note symb_exec_r_fault = ccorres_symb_exec_r_known_rv_UNIV
[where xf'=ret__unsigned_' and R="?obj_at_ft" and R'=UNIV]
show ?thesis
apply (unfold K_def)
using [[goals_limit = 1]]
apply (intro ccorres_gen_asm)
apply (cinit' lift: sender_' receiver_' faultType_' receiveIPCBuffer_')
apply (simp only: makeArchFaultMessage_def setMRs_to_setMR
2016-10-25 06:01:30 +00:00
del: Collect_const split del: if_split)
2016-11-10 04:44:36 +00:00
apply (rule_tac P="ft = ArchFault aft" in ccorres_gen_asm)
apply wpc
apply (rename_tac list)
apply (rule_tac P="zip [Suc (Suc 0) ..< msgMaxLength] list = [(2, hd list), (3, hd (tl list))]"
in ccorres_gen_asm)
apply (simp add: Collect_True Collect_False ccorres_cond_iffs
zip_upt_Cons msgMaxLength_unfold
zipWithM_mapM mapM_Cons bind_assoc
seL4_Fault_tag_defs
del: Collect_const)
apply (rule ccorres_rhs_assoc)+
apply (ctac (no_vcg))
apply (rule ccorres_stateAssert)
apply (ctac(no_vcg) add: setMR_ccorres_dc)
apply (rule ccorres_move_c_guard_tcb)
apply (rule_tac val="vmFaultAddress aft" in symb_exec_r_fault)
apply (rule conseqPre, vcg, clarsimp)
apply (drule(1) obj_at_cslift_tcb)
apply (clarsimp simp: ctcb_relation_def typ_heap_simps
cfault_rel_def seL4_Fault_lift_def
seL4_Fault_VMFault_lift_def Let_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2016-11-10 04:44:36 +00:00
apply ceqv
apply (ctac(no_vcg) add: setMR_ccorres_dc)
apply (rule_tac val="hd (vmFaultArchData aft)" in symb_exec_r_fault)
apply (rule conseqPre, vcg, clarsimp)
apply (drule(1) obj_at_cslift_tcb)
apply (clarsimp simp: typ_heap_simps')
apply (clarsimp simp: ctcb_relation_def
cfault_rel_def seL4_Fault_lift_def
seL4_Fault_VMFault_lift_def Let_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2016-11-10 04:44:36 +00:00
apply ceqv
apply (ctac(no_vcg) add: setMR_ccorres_dc)
apply (rule_tac val="vmFaultArchData aft ! 1" in symb_exec_r_fault)
apply (rule conseqPre, vcg, clarsimp)
apply (drule(1) obj_at_cslift_tcb)
apply (clarsimp simp: typ_heap_simps')
apply (clarsimp simp: ctcb_relation_def
cfault_rel_def seL4_Fault_lift_def
seL4_Fault_VMFault_lift_def Let_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2016-11-10 04:44:36 +00:00
apply ceqv
apply (ctac(no_vcg) add: setMR_ccorres)
apply (simp add: mapM_Nil)
apply (rule ccorres_return_C, simp+)[1]
apply wp
apply (clarsimp simp: option_to_ptr_def)
apply (subgoal_tac "case list of [a, b] \<Rightarrow> True | _ \<Rightarrow> True")
apply (simp add: zip_upt_Cons guard_is_UNIVI seL4_VMFault_FSR_def split: list.split_asm)
apply (simp split: list.split)
apply (wp setMR_tcbFault_obj_at asUser_inv[OF getRestartPC_inv]
hoare_case_option_wp
| simp add: option_to_ptr_def guard_is_UNIVI
seL4_VMFault_PrefetchFault_def
seL4_VMFault_Addr_def
seL4_VMFault_IP_def
msgMaxLength_def
2016-10-25 06:01:30 +00:00
del: Collect_const split del: if_split)+
2016-11-10 04:44:36 +00:00
apply clarsimp
apply (drule(1) obj_at_cslift_tcb[where thread=sender])
apply (clarsimp simp: obj_at'_def projectKOs objBits_simps)
apply (clarsimp simp: ctcb_relation_def cfault_rel_def seL4_Fault_lift_def
Let_def zip_upt_Cons
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2016-11-10 04:44:36 +00:00
done
qed
lemmas seL4_Faults = seL4_Fault_UserException_def
seL4_Fault_UnknownSyscall_def
seL4_Fault_CapFault_def
lemmas seL4_Arch_Faults = seL4_Fault_VMFault_def
2014-07-14 19:32:44 +00:00
lemma setMRs_fault_ccorres [corres]:
2015-12-08 06:29:42 +00:00
"ccorres (\<lambda>r r'. r = r' && mask msgLengthBits) ret__unsigned_long_'
2014-07-14 19:32:44 +00:00
(valid_pspace' and obj_at' (\<lambda>tcb. tcbFault tcb = Some ft) sender
and tcb_at' receiver
2015-11-16 03:12:37 +00:00
and (case buffer of Some x \<Rightarrow> valid_ipc_buffer_ptr' x | None \<Rightarrow> \<top>)
2014-07-14 19:32:44 +00:00
and K (buffer \<noteq> Some 0)
and K (sender \<noteq> receiver))
(UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
\<inter> \<lbrace>\<acute>receiveIPCBuffer = Ptr (option_to_0 buffer)\<rbrace>) hs
(makeFaultMessage ft sender >>= (\<lambda>ms. setMRs receiver buffer (snd ms)))
(Call setMRs_fault_'proc)"
proof -
let ?obj_at_ft = "obj_at' (\<lambda>tcb. tcbFault tcb = Some ft) sender"
note symb_exec_r_fault = ccorres_symb_exec_r_known_rv_UNIV
2015-12-08 06:29:42 +00:00
[where xf'=ret__unsigned_' and R="?obj_at_ft" and R'=UNIV]
2014-07-14 19:32:44 +00:00
show ?thesis
apply (unfold K_def)
apply (intro ccorres_gen_asm)
apply (cinit' lift: sender_' receiver_' receiveIPCBuffer_' simp: whileAnno_def)
apply (simp add: makeFaultMessage_def setMRs_to_setMR
2016-10-25 06:01:30 +00:00
del: Collect_const split del: if_split)
2014-07-14 19:32:44 +00:00
apply (rule_tac val="fault_to_fault_tag ft" in symb_exec_r_fault)
apply (vcg, clarsimp)
apply (drule(1) obj_at_cslift_tcb)
apply (clarsimp simp: ctcb_relation_def typ_heap_simps'
2016-11-10 04:44:36 +00:00
cfault_rel_def seL4_Fault_lift_def Let_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2014-07-14 19:32:44 +00:00
apply ceqv
2016-11-10 04:44:36 +00:00
(* UserException *)
2014-07-14 19:32:44 +00:00
apply wpc
2016-11-10 04:44:36 +00:00
apply (simp add: bind_assoc seL4_Fault_tag_defs ccorres_cond_iffs
2014-07-14 19:32:44 +00:00
Collect_True Collect_False
zipWithM_mapM zip_append2 mapM_append
2016-10-25 06:01:30 +00:00
del: Collect_const split del: if_split)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_symb_exec_l)
apply (rule ccorres_stateAssert)
apply (rule_tac P="length msg = unat n_exceptionMessage"
in ccorres_gen_asm)
apply (simp add: n_exceptionMessage_def msgMaxLength_unfold
zip_upt_Cons mapM_Nil mapM_Cons bind_assoc
mapM_discarded
del: Collect_const upt.simps upt_rec_numeral
2016-10-25 06:01:30 +00:00
split del: if_split)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_rhs_assoc)+
2016-11-10 04:44:36 +00:00
apply (ctac add: copyMRsFault_ccorres_exception)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_move_c_guard_tcb)
apply (rule_tac val="userExceptionNumber ft" in symb_exec_r_fault)
apply (vcg, clarsimp)
apply (drule(1) obj_at_cslift_tcb)
apply (clarsimp simp: ctcb_relation_def typ_heap_simps
2016-11-10 04:44:36 +00:00
cfault_rel_def seL4_Fault_lift_def
seL4_Fault_UserException_lift_def Let_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2014-07-14 19:32:44 +00:00
apply ceqv
apply (ctac add: setMR_ccorres_dc)
apply (rule ccorres_move_c_guard_tcb)
apply (rule_tac val="userExceptionErrorCode ft" in symb_exec_r_fault)
apply (vcg, clarsimp)
apply (drule(1) obj_at_cslift_tcb)
apply (clarsimp simp: ctcb_relation_def typ_heap_simps
2016-11-10 04:44:36 +00:00
cfault_rel_def seL4_Fault_lift_def
seL4_Fault_UserException_lift_def Let_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2014-07-14 19:32:44 +00:00
apply ceqv
apply (ctac add: setMR_ccorres)
apply (rule ccorres_return_C, simp+)[1]
apply wp
apply (simp del: Collect_const)
apply (vcg exspec=setMR_modifies)
apply (clarsimp simp: option_to_ptr_def guard_is_UNIVI)
2015-11-16 03:12:37 +00:00
apply (wp setMR_tcbFault_obj_at
hoare_case_option_wp)
2014-07-14 19:32:44 +00:00
apply simp
apply (vcg exspec=setMR_modifies)
apply (clarsimp simp: option_to_ptr_def guard_is_UNIVI)
apply (simp add: split_def)
apply (wp mapM_x_wp' setMR_tcbFault_obj_at
2015-11-16 03:12:37 +00:00
hoare_case_option_wp
2014-07-14 19:32:44 +00:00
| simp)+
2016-11-10 04:44:36 +00:00
apply (vcg exspec=copyMRsFault_modifies exspect=setRegister_modifies)
2014-07-14 19:32:44 +00:00
apply (wp asUser_inv mapM_wp' getRegister_inv)
apply simp
2016-11-10 04:44:36 +00:00
apply (wp asUser_inv mapM_wp' getRegister_inv hoare_drop_imps asUser_const_rv
asUser_get_registers[simplified atcbContextGet_def comp_def])
2014-07-14 19:32:44 +00:00
apply simp
2016-11-10 04:44:36 +00:00
(* CapFault *)
apply (simp add: Collect_True Collect_False ccorres_cond_iffs
2014-07-14 19:32:44 +00:00
zip_upt_Cons msgMaxLength_unfold
2016-11-10 04:44:36 +00:00
zipWithM_mapM mapM_Cons bind_assoc
2014-07-14 19:32:44 +00:00
del: Collect_const)
apply (rule ccorres_rhs_assoc)+
apply (ctac(no_vcg))
apply (rule ccorres_stateAssert)
apply (ctac(no_vcg) add: setMR_ccorres_dc)
2016-11-10 04:44:36 +00:00
apply (rule_tac val="capFaultAddress ft" in symb_exec_r_fault)
2014-07-14 19:32:44 +00:00
apply (rule conseqPre, vcg, clarsimp)
apply (drule(1) obj_at_cslift_tcb)
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: typ_heap_simps' ctcb_relation_def
cfault_rel_def seL4_Fault_lift_def Let_def
seL4_Fault_CapFault_lift_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2014-07-14 19:32:44 +00:00
apply ceqv
apply (ctac(no_vcg) add: setMR_ccorres_dc)
2016-11-10 04:44:36 +00:00
apply (rule_tac val="from_bool (capFaultInReceivePhase ft)" in symb_exec_r_fault)
2014-07-14 19:32:44 +00:00
apply (rule conseqPre, vcg, clarsimp)
apply (drule(1) obj_at_cslift_tcb)
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: typ_heap_simps' ctcb_relation_def
cfault_rel_def seL4_Fault_lift_def Let_def
seL4_Fault_CapFault_lift_def
from_bool_to_bool_and_1 word_size
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2014-07-14 19:32:44 +00:00
apply ceqv
apply (ctac(no_vcg) add: setMR_ccorres_dc)
2016-11-10 04:44:36 +00:00
apply (rule ccorres_move_c_guard_tcb)
apply (rule_tac P="obj_at' (\<lambda>tcb. tcbFault tcb = Some ft) sender"
in ccorres_cross_over_guard)
apply (ctac(no_vcg) add: setMRs_lookup_failure_ccorres[unfolded msgMaxLength_unfold])
apply simp
apply (rule ccorres_return_C, simp+)[1]
2017-01-13 12:58:40 +00:00
apply (wp setMR_tcbFault_obj_at hoare_case_option_wp)+
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: option_to_ptr_def Collect_const_mem guard_is_UNIV_def)
apply (rule conjI)
apply (simp add: seL4_CapFault_InRecvPhase_def)
apply (rule conjI)
apply (simp add: from_bool_def split: bool.split)
apply clarsimp
2014-07-14 19:32:44 +00:00
apply (drule(1) obj_at_cslift_tcb)
apply (clarsimp simp: typ_heap_simps' ctcb_relation_def
2016-11-10 04:44:36 +00:00
cfault_rel_def seL4_Fault_lift_def Let_def
seL4_Fault_CapFault_lift_def is_cap_fault_def
seL4_CapFault_LookupFailureType_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2016-11-10 04:44:36 +00:00
apply (wp setMR_tcbFault_obj_at hoare_case_option_wp
asUser_inv[OF getRestartPC_inv]
| (rule guard_is_UNIVI, clarsimp simp: option_to_ptr_def
seL4_CapFault_Addr_def))+
(* UnknowSyscall *)
apply (rename_tac syscall_number)
apply (simp add: seL4_Fault_tag_defs Collect_True Collect_False
2014-07-14 19:32:44 +00:00
ccorres_cond_iffs zipWithM_mapM mapM_append
zip_append2 bind_assoc
del: Collect_const)
apply (rule ccorres_symb_exec_l)
apply (rule ccorres_stateAssert)
apply (rule_tac P="length msg = unat n_syscallMessage" in ccorres_gen_asm)
apply (simp add: msgMaxLength_unfold n_syscallMessage_def zip_upt_Cons
mapM_Cons mapM_Nil mapM_discarded
del: Collect_const upt_rec_numeral)
apply (rule ccorres_rhs_assoc)+
2016-11-10 04:44:36 +00:00
apply (ctac add: copyMRsFault_ccorres_syscall)
apply (rule ccorres_move_c_guard_tcb)
apply (rule_tac val="syscall_number" in symb_exec_r_fault)
apply (vcg, clarsimp)
apply (drule(1) obj_at_cslift_tcb)
apply (clarsimp simp: ctcb_relation_def typ_heap_simps'
cfault_rel_def seL4_Fault_lift_def Let_def
seL4_Fault_UnknownSyscall_def
seL4_Fault_UnknownSyscall_lift_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2016-11-10 04:44:36 +00:00
apply ceqv
apply (ctac add: setMR_ccorres)
apply (rule ccorres_return_C, simp+)[1]
apply wp
2014-07-14 19:32:44 +00:00
apply (simp del: Collect_const)
2016-11-10 04:44:36 +00:00
apply (vcg exspec=setMR_modifies)
apply (clarsimp simp: option_to_ptr_def guard_is_UNIVI)
apply (wp setMR_tcbFault_obj_at mapM_x_wp_inv hoare_case_option_wp
| clarsimp
| wpc)+
apply (vcg exspec=copyMRsFault_modifies)
apply (wp asUser_inv mapM_wp' getRegister_inv)
2014-07-14 19:32:44 +00:00
apply simp
2016-11-10 04:44:36 +00:00
apply (wp asUser_inv mapM_wp' getRegister_inv hoare_drop_imps asUser_const_rv
asUser_get_registers[simplified atcbContextGet_def comp_def])
apply simp
(* ArchFault *)
apply (rule ccorres_cond_false)
apply (rule ccorres_cond_false)
apply (rule ccorres_cond_false)
apply (simp add: Collect_True Collect_False ccorres_cond_iffs
zip_upt_Cons
mapM_Cons bind_assoc
seL4_Fault_tag_defs
del: Collect_const)
apply (rule ccorres_rhs_assoc)+
apply (rule ccorres_move_c_guard_tcb)
apply (rule_tac val="fault_to_fault_tag ft" in symb_exec_r_fault)
apply (vcg, clarsimp)
apply (drule(1) obj_at_cslift_tcb)
apply (clarsimp simp: ctcb_relation_def typ_heap_simps'
cfault_rel_def seL4_Fault_lift_def Let_def
seL4_Fault_UnknownSyscall_def
seL4_Fault_UnknownSyscall_lift_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2016-11-10 04:44:36 +00:00
apply ceqv
apply (rule ccorres_add_return2)
apply (ctac add: Arch_setMRs_fault_ccorres[simplified setMRs_to_setMR last.simps K_bind_def])
apply (ctac add: ccorres_return_C)
apply wp
apply (vcg exspec=Arch_setMRs_fault_modifies)
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
apply (rule fault_to_fault_tag.simps(2)[symmetric])
(* done *)
apply (rule guard_is_UNIVI, clarsimp simp: option_to_ptr_def seL4_CapFault_IP_def)
apply (case_tac x)
apply (simp add: seL4_Faults seL4_Arch_Faults)
apply (clarsimp simp: msgMaxLength_unfold length_syscallMessage
2016-05-01 03:35:49 +00:00
ARM_H.exceptionMessage_def
2016-05-05 22:59:33 +00:00
ARM.exceptionMessage_def
2016-11-10 04:44:36 +00:00
n_exceptionMessage_def
n_syscallMessage_def)
2014-07-14 19:32:44 +00:00
apply (drule(1) obj_at_cslift_tcb[where thread=sender])
apply (clarsimp simp: obj_at'_def projectKOs objBits_simps)
apply (clarsimp simp: msgFromLookupFailure_def split: lookup_failure.split)
2016-11-10 04:44:36 +00:00
done
2014-07-14 19:32:44 +00:00
qed
2016-11-10 04:44:36 +00:00
definition
makeArchFaultMessage2 :: "arch_fault \<Rightarrow> 32 word"
where
"makeArchFaultMessage2 \<equiv> \<lambda>aft. case aft of VMFault _ _ \<Rightarrow> 5"
2014-07-14 19:32:44 +00:00
lemma makeFaultMessage2:
"makeFaultMessage ft thread
= (do x \<leftarrow> makeFaultMessage ft thread;
return (case ft of CapFault _ _ _ \<Rightarrow> 1
2016-11-10 04:44:36 +00:00
| UnknownSyscallException _ \<Rightarrow> 2
| UserException _ _ \<Rightarrow> 3
| ArchFault aft \<Rightarrow> makeArchFaultMessage2 aft, snd x) od)"
by (simp add: makeFaultMessage_def makeArchFaultMessage2_def makeArchFaultMessage_def
split: fault.split arch_fault.split)
2014-07-14 19:32:44 +00:00
lemma doFaultTransfer_ccorres [corres]:
"ccorres dc xfdc (valid_pspace' and tcb_at' sender and tcb_at' receiver
2015-11-16 03:12:37 +00:00
and (case buffer of Some x \<Rightarrow> valid_ipc_buffer_ptr' x | None \<Rightarrow> \<top>)
and K (buffer \<noteq> Some 0) and K (receiver \<noteq> sender))
2014-07-14 19:32:44 +00:00
(UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
\<inter> \<lbrace>\<acute>receiverIPCBuffer = Ptr (option_to_0 buffer)\<rbrace>
\<inter> \<lbrace>\<acute>badge = badge\<rbrace>) []
(doFaultTransfer badge sender receiver buffer)
(Call doFaultTransfer_'proc)"
apply (unfold K_def)
apply (intro ccorres_gen_asm)
apply (simp add: doFaultTransfer_def)
apply (subst makeFaultMessage2)
2016-11-10 04:44:36 +00:00
apply (simp only: makeArchFaultMessage2_def)
2014-07-14 19:32:44 +00:00
apply (cinit' lift: sender_' receiver_' receiverIPCBuffer_' badge_')
apply (rule ccorres_pre_threadGet)
apply (rename_tac ft)
apply wpc
apply (simp del: Collect_const, rule ccorres_fail)
apply (simp add: split_def bind_assoc del: Collect_const)
2014-08-11 08:51:04 +00:00
apply (simp only: bind_assoc[symmetric, where m="makeFaultMessage ft t" for ft t])
2014-07-14 19:32:44 +00:00
apply (ctac(no_vcg) add: setMRs_fault_ccorres)
apply (rule_tac R="obj_at' (\<lambda>tcb. tcbFault tcb = ft) sender"
and val="case (the ft) of CapFault _ _ _ \<Rightarrow> 1
2016-11-10 04:44:36 +00:00
| ArchFault (VMFault _ _) \<Rightarrow> 5 | UnknownSyscallException _ \<Rightarrow> 2
| UserException _ _ \<Rightarrow> 3"
2014-07-14 19:32:44 +00:00
in ccorres_symb_exec_r_known_rv_UNIV
2015-12-08 06:29:42 +00:00
[where xf'=ret__unsigned_' and R'=UNIV])
2014-07-14 19:32:44 +00:00
apply (rule conseqPre, vcg, clarsimp)
apply (drule(1) obj_at_cslift_tcb)
apply (clarsimp simp: typ_heap_simps' ctcb_relation_def
2016-11-10 04:44:36 +00:00
cfault_rel_def seL4_Fault_lift_def Let_def
seL4_Fault_tag_defs
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2014-07-14 19:32:44 +00:00
apply ceqv
apply csymbr
apply (ctac (no_vcg, c_lines 2) add: setMessageInfo_ccorres)
apply (ctac add: setRegister_ccorres[unfolded dc_def])
apply wp
2016-05-05 22:59:33 +00:00
apply (simp add: badgeRegister_def ARM.badgeRegister_def
2014-07-14 19:32:44 +00:00
Kernel_C.badgeRegister_def "StrictC'_register_defs")
apply (clarsimp simp: message_info_to_H_def guard_is_UNIVI
mask_def msgLengthBits_def
2016-11-10 04:44:36 +00:00
split: fault.split arch_fault.split)
2014-07-14 19:32:44 +00:00
apply wp
apply (simp add: setMRs_to_setMR zipWithM_mapM split_def)
apply (wp mapM_wp' setMR_tcbFault_obj_at | simp)+
apply (clarsimp simp: obj_at'_def projectKOs)
done
lemma ccorres_emptyOnFailure:
assumes corr_ac: "ccorres (\<lambda>f c. case f of Inl _ \<Rightarrow> r [] c | Inr xs \<Rightarrow> r xs c)
xf
P P' hs a c"
shows "ccorres r xf P P' hs (emptyOnFailure a) c" using corr_ac
apply (simp add: emptyOnFailure_def catch_def const_def bind_def split_def)
apply (clarsimp simp: ccorres_underlying_def return_def split: xstate.splits sum.splits)
apply (drule (1) bspec)
apply (rule conjI, clarsimp)
apply (erule_tac x=n in allE)
2015-05-20 10:39:47 +00:00
apply (rename_tac s)
2014-07-14 19:32:44 +00:00
apply (erule_tac x="Normal s" in allE)
apply clarsimp
apply (rule bexI)
prefer 2
apply assumption
apply clarsimp
apply (rule conjI, clarsimp simp: unif_rrel_def)
apply (clarsimp simp: unif_rrel_def)
apply fastforce
done
lemma unifyFailure_ccorres:
assumes corr_ac: "ccorres (f \<currency> r) xf P P' hs a c"
2017-05-02 01:12:26 +00:00
shows "ccorres ((\<lambda>_. dc) \<currency> r) xf P P' hs (unifyFailure a) c"
2014-07-14 19:32:44 +00:00
using corr_ac
2017-05-02 01:12:26 +00:00
apply (simp add: unifyFailure_def rethrowFailure_def const_def o_def
2014-07-14 19:32:44 +00:00
handleE'_def throwError_def)
2017-05-02 01:12:26 +00:00
apply (clarsimp simp: ccorres_underlying_def bind_def split_def return_def
2014-07-14 19:32:44 +00:00
split: xstate.splits sum.splits)
apply (drule (1) bspec)
apply clarsimp
apply (rule conjI)
apply clarsimp
apply (erule_tac x=n in allE)
2015-05-20 10:39:47 +00:00
apply (rename_tac s)
2014-07-14 19:32:44 +00:00
apply (erule_tac x="Normal s" in allE)
apply clarsimp
apply (rule bexI)
prefer 2
apply assumption
apply (clarsimp simp: unif_rrel_def)
apply fastforce
2017-05-02 01:12:26 +00:00
apply fastforce
2014-07-14 19:32:44 +00:00
done
2017-05-02 01:12:26 +00:00
definition
2014-07-14 19:32:44 +00:00
cct_relation:: "cap_transfer \<Rightarrow> cap_transfer_C \<Rightarrow> bool"
where
2017-05-02 01:12:26 +00:00
"cct_relation atc ctc \<equiv>
2014-07-14 19:32:44 +00:00
case atc of
2016-11-03 22:15:38 +00:00
(CT croot idx dpt) \<Rightarrow> ctReceiveRoot_C ctc = croot \<and>
ctReceiveIndex_C ctc= idx \<and>
unat (ctReceiveDepth_C ctc) = dpt"
2014-07-14 19:32:44 +00:00
lemma capTransferFromWords_ccorres [corres]:
2017-05-02 01:12:26 +00:00
"ccorres cct_relation ret__struct_cap_transfer_C_'
2014-07-14 19:32:44 +00:00
(valid_pspace' and K (is_aligned ptr 2))
2015-11-16 03:12:37 +00:00
(UNIV \<inter> \<lbrace>array_assertion (Ptr ptr :: word32 ptr) 3 (hrs_htd \<acute>t_hrs)\<rbrace>
\<inter> \<lbrace>\<acute>wptr = Ptr ptr\<rbrace>) hs
2014-07-14 19:32:44 +00:00
(capTransferFromWords ptr)
(Call capTransferFromWords_'proc)"
apply (cinit lift: wptr_')
apply (rule ccorres_pre_loadWordUser)+
2017-05-02 01:12:26 +00:00
apply (rule_tac P=\<top>
2015-11-16 03:12:37 +00:00
and P'="{s. array_assertion (Ptr ptr :: word32 ptr)
3 (hrs_htd (t_hrs_' (globals s))) \<and>
2017-05-02 01:12:26 +00:00
cslift s (Ptr ptr) = Some rv \<and>
2014-07-14 19:32:44 +00:00
cslift s (Ptr (ptr + 4)) = Some rva \<and>
cslift s (Ptr (ptr + 8)) = Some rvb}"
in ccorres_from_vcg_throws)
apply (rule allI, rule conseqPre, vcg)
2015-11-16 03:12:37 +00:00
apply (clarsimp simp: typ_heap_simps' ptr_add_assertion_positive
array_assertion_shrink_right)
2014-07-14 19:32:44 +00:00
apply (simp add: return_def)
apply (simp add: cct_relation_def)
2015-09-30 18:05:05 +00:00
apply (clarsimp simp: word_size valid_ipc_buffer_ptr'_def wordSize_def')
2014-07-14 19:32:44 +00:00
apply safe
apply (erule aligned_add_aligned | simp add: is_aligned_def word_bits_conv)+
done
2015-11-16 03:12:37 +00:00
lemma array_assertion_shrink_left_add:
"array_assertion (Ptr ptr :: ('a :: wf_type) ptr) j htd
\<Longrightarrow> n = of_nat (k * size_of TYPE('a)) \<and> k + i \<le> j \<and> 0 < i
\<Longrightarrow> array_assertion (Ptr (ptr + n) :: 'a ptr) i htd"
apply (cases "k = 0")
apply (simp add: unat_eq_0)
apply (erule array_assertion_shrink_right, simp)
apply (drule_tac j=k in array_assertion_shrink_leftD)
apply simp
apply simp
apply (erule array_assertion_shrink_right)
apply arith
done
lemma array_assertion_shrink_left_add_div:
"array_assertion (Ptr ptr :: ('a :: wf_type) ptr) j htd
\<Longrightarrow> n = of_nat (unat n div size_of TYPE('a)) * of_nat (size_of TYPE('a))
\<and> i + (unat n div size_of TYPE('a)) \<le> j \<and> 0 < i
\<Longrightarrow> array_assertion (Ptr (ptr + n) :: 'a ptr) i htd"
apply (erule_tac k="unat n div size_of TYPE('a)"
in array_assertion_shrink_left_add)
apply simp
done
2014-07-14 19:32:44 +00:00
lemma loadCapTransfer_ccorres [corres]:
2017-05-02 01:12:26 +00:00
"ccorres cct_relation ret__struct_cap_transfer_C_'
2014-07-14 19:32:44 +00:00
(valid_pspace' and valid_ipc_buffer_ptr' buffer)
(UNIV \<inter> \<lbrace>\<acute>buffer = Ptr buffer\<rbrace>) hs
(loadCapTransfer buffer)
(Call loadCapTransfer_'proc)"
apply (cinit lift: buffer_')
apply (rule ccorres_Guard_Seq)+
apply csymbr
2017-05-02 01:12:26 +00:00
apply (simp add: seL4_MsgLengthBits_def
2015-11-16 03:12:37 +00:00
seL4_MsgExtraCapBits_def
seL4_MsgMaxLength_def
ptr_add_assertion_positive)
apply (rule ccorres_move_array_assertion_ipc_buffer
ccorres_rhs_assoc)+
2014-07-14 19:32:44 +00:00
apply (rule ccorres_add_return2)
2015-11-16 03:12:37 +00:00
apply (ctac(no_vcg))
apply (rule ccorres_move_array_assertion_ipc_buffer)
2017-05-02 01:12:26 +00:00
apply simp
2014-07-14 19:32:44 +00:00
apply (ctac (no_vcg) add: ccorres_return_C)
2015-11-16 03:12:37 +00:00
apply (wp capTransferFromWords_inv | simp)+
apply (clarsimp simp: word_size)
2017-05-02 01:12:26 +00:00
apply (simp add: seL4_MsgLengthBits_def
2014-07-14 19:32:44 +00:00
seL4_MsgExtraCapBits_def
2015-01-09 21:34:52 +00:00
seL4_MsgMaxLength_def
2014-07-14 19:32:44 +00:00
word_size word_sle_def
msgMaxLength_def msgMaxExtraCaps_def
2015-11-16 03:12:37 +00:00
msgLengthBits_def msgExtraCapBits_def
Collect_const_mem msg_align_bits)
apply (frule(1) valid_ipc_buffer_ptr_array[where p="Ptr p'" for p', simplified],
rule order_refl, simp_all add: msg_align_bits)
2015-12-01 05:29:29 +00:00
apply (clarsimp simp: valid_ipc_buffer_ptr'_def wordSize_def')
2015-11-16 03:12:37 +00:00
apply (subst array_assertion_shrink_left_add_div, assumption)
apply (simp add: msgMaxLength_def msgExtraCaps_def msgMaxExtraCaps_def msgExtraCapBits_def
shiftL_nat)
2015-12-01 05:29:29 +00:00
apply simp
2015-11-16 03:12:37 +00:00
apply (erule aligned_add_aligned, simp_all add: is_aligned_def)
done
2014-07-14 19:32:44 +00:00
lemma loadCapTransfer_ctReceiveDepth:
"\<lbrace>\<top>\<rbrace> loadCapTransfer buffer \<lbrace>\<lambda>rv s. ctReceiveDepth rv < 2 ^ word_bits\<rbrace>"
apply (simp add: loadCapTransfer_def capTransferFromWords_def)
apply wp
apply (rule_tac Q'="\<lambda>_ _. True" in hoare_post_eq)
apply simp
apply (simp only: word_bits_len_of[symmetric])
2017-05-02 01:12:26 +00:00
apply (subst unat_lt2p, simp)
2017-03-13 16:37:32 +00:00
apply wpsimp+
2017-01-13 12:58:40 +00:00
done
2014-07-14 19:32:44 +00:00
(* FIXME: move *)
lemma cte_at_0' [dest!]:
"\<lbrakk> cte_at' 0 s; no_0_obj' s \<rbrakk> \<Longrightarrow> False"
apply (clarsimp simp: cte_wp_at_obj_cases')
2017-01-13 12:58:40 +00:00
by (auto simp: tcb_cte_cases_def is_aligned_def dest!:tcb_aligned' split: if_split_asm)
2014-07-14 19:32:44 +00:00
lemma getReceiveSlots_ccorres:
2017-05-02 01:12:26 +00:00
"ccorres (\<lambda>a c. (a = [] \<or> (\<exists>slot. a = [slot])) \<and>
((a \<noteq> []) = (c \<noteq> NULL)) \<and> (a\<noteq>[] \<longrightarrow> c = cte_Ptr (hd a) \<and> c \<noteq> NULL))
2014-07-14 19:32:44 +00:00
ret__ptr_to_struct_cte_C_'
(valid_ipc_buffer_ptr' buffer and
valid_pspace' and
2017-05-02 01:12:26 +00:00
tcb_at' thread
2014-07-14 19:32:44 +00:00
and (\<lambda>s. buffer \<noteq> 0))
(UNIV \<inter> \<lbrace>\<acute>buffer = Ptr buffer\<rbrace> \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>) hs
(getReceiveSlots thread (Some buffer))
(Call getReceiveSlots_'proc)"
apply (rule ccorres_gen_asm)
apply (cinit lift: buffer_' thread_')
apply (simp add: split_def)
apply (ctac (no_vcg))
apply (rule ccorres_emptyOnFailure)
apply csymbr
apply (rule ccorres_split_nothrowE)
apply (rule unifyFailure_ccorres)
apply (ctac (no_vcg) add: lookupCap_ccorres')
apply ceqv
apply simp
apply csymbr
apply (fold lookupTargetSlot_def)
apply (rule ccorres_split_nothrow_novcgE)
apply (rule unifyFailure_ccorres)
apply (ctac (no_vcg) add: lookupTargetSlot_ccorres')
apply ceqv
apply (rename_tac slot slot_c)
apply (simp add: liftE_bindE)
apply csymbr
apply (rule_tac P="cte_at' slot and no_0_obj'"
in ccorres_from_vcg_throws[where P'=UNIV])
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp simp: in_monad cte_wp_at_ctes_of Bex_def in_getCTE2)
apply (rule cmap_relationE1[OF cmap_relation_cte], assumption+)
apply (clarsimp simp: typ_heap_simps' cap_get_tag_isCap in_monad
dest!: ccte_relation_ccap_relation)
apply (erule cte_at_0'[rotated], simp add: cte_wp_at_ctes_of)
apply clarsimp
apply (rule ccorres_split_throws)
apply (rule_tac P=\<top> and P'=UNIV in ccorres_from_vcg_throws)
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp simp: throwError_def return_def)
apply (rule conseqPre, vcg, clarsimp)
apply clarsimp
apply (wp lsfco_cte_at')
apply (clarsimp simp: guard_is_UNIV_def)
apply (clarsimp simp: guard_is_UNIV_def)
apply (rule UNIV_I)
apply simp
apply clarsimp
apply (rule ccorres_split_throws)
apply (rule_tac P=\<top> and P'=UNIV in ccorres_from_vcg_throws)
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp simp: throwError_def return_def)
apply (rule conseqPre, vcg, clarsimp)
apply clarsimp
apply wp
apply (vcg exspec=lookupCap_modifies)
apply clarsimp
apply (wp loadCapTransfer_ctReceiveDepth)
apply clarsimp
apply (intro conjI)
apply fastforce
apply fastforce
apply clarsimp
apply (simp add: cct_relation_def)
apply (case_tac rv, clarsimp)
apply (rule UNIV_I) -- "still a schematic here ..."
2017-01-13 12:58:40 +00:00
done
2014-07-14 19:32:44 +00:00
lemma setExtraBadge_ccorres:
2017-05-02 01:12:26 +00:00
"ccorres dc xfdc
2014-07-14 19:32:44 +00:00
(valid_pspace' and valid_ipc_buffer_ptr' buffer and (\<lambda>_. msg_max_length + 2 + n < unat max_ipc_words))
2017-05-02 01:12:26 +00:00
(UNIV \<inter> \<lbrace>\<acute>bufferPtr = Ptr buffer\<rbrace> \<inter> \<lbrace>\<acute>badge = badge\<rbrace> \<inter> \<lbrace>\<acute>i = of_nat n\<rbrace>)
2014-07-14 19:32:44 +00:00
hs
(setExtraBadge buffer badge n)
(Call setExtraBadge_'proc)"
apply (rule ccorres_gen_asm)
apply (cinit lift: bufferPtr_' badge_' i_')
apply (unfold storeWordUser_def)
apply (rule ccorres_pre_stateAssert)
2015-11-16 03:12:37 +00:00
apply (simp only: K_bind_def)
apply (rule ccorres_move_array_assertion_ipc_buffer
ccorres_Guard[where F=C_Guard]
ccorres_Guard[where F=SignedArithmetic]
)+
2014-07-14 19:32:44 +00:00
apply (ctac add: storeWord_ccorres)
2015-09-30 18:05:05 +00:00
apply (clarsimp simp: bufferCPtrOffset_def word_size msgMaxLength_def wordSize_def'
2015-01-09 21:34:52 +00:00
seL4_MsgLengthBits_def seL4_MsgMaxLength_def Types_H.msgLengthBits_def
2015-11-16 03:12:37 +00:00
field_simps Collect_const_mem)
2014-07-14 19:32:44 +00:00
apply (subgoal_tac " is_aligned (buffer + (of_nat n * 4 + 0x1E8)) 2")
apply clarsimp
prefer 2
apply (clarsimp simp: valid_ipc_buffer_ptr'_def)
apply (erule aligned_add_aligned, simp_all add: word_bits_def)
apply (rule_tac n=2 in aligned_add_aligned, simp_all add: word_bits_def)
apply (rule is_aligned_mult_triv2 [where n = 2, simplified])
apply (simp add: is_aligned_def)
2015-11-16 03:12:37 +00:00
apply (auto simp: pointerInUserData_c_guard pointerInUserData_h_t_valid
msg_align_bits max_ipc_words_def msg_max_length_def
capTransferDataSize_def msgMaxLength_def msgMaxExtraCaps_def
msgExtraCapBits_def unat_word_ariths unat_of_nat)
done
2014-07-14 19:32:44 +00:00
lemma option_to_0_Some:
"option_to_0 (Some x) = x"
by (simp add: option_to_0_def)
(* FIXME: move *)
lemma ccorres_constOnFailure:
assumes corr_ac: "ccorres (\<lambda>f c. case f of Inl x \<Rightarrow> r n c | Inr n \<Rightarrow> r n c)
xf
P P' hs a c"
shows "ccorres r xf P P' hs (constOnFailure n a) c" using corr_ac
apply (simp add: constOnFailure_def catch_def const_def bind_def split_def)
apply (clarsimp simp: ccorres_underlying_def return_def split: xstate.splits sum.splits)
apply (drule (1) bspec)
apply (rule conjI, clarsimp)
apply (erule_tac x=na in allE)
2015-05-20 10:39:47 +00:00
apply (rename_tac s)
2014-07-14 19:32:44 +00:00
apply (erule_tac x="Normal s" in allE)
apply clarsimp
apply (rule bexI)
prefer 2
apply assumption
apply clarsimp
apply (rule conjI, clarsimp simp: unif_rrel_def)
apply (clarsimp simp: unif_rrel_def)
apply fastforce
done
(* FIXME: move *)
2014-08-09 05:16:17 +00:00
lemma ccorres_case_sum_liftE:
"ccorres r xf P P' hs H C \<Longrightarrow> ccorres (\<lambda>a c. case_sum (\<lambda>x. r' x c) (\<lambda>y. r y c) a) xf P P' hs (liftE H) C"
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: ccorres_underlying_def split: xstate.splits)
apply (drule (1) bspec)
apply (clarsimp simp: split_def liftE_def bind_def return_def)
apply (fastforce simp: unif_rrel_def)
done
(* FIXME: move *)
2014-08-11 08:51:04 +00:00
lemma ccorres_case_bools_rhs:
2014-07-14 19:32:44 +00:00
assumes P: "ccorres r xf P P' hs a c"
assumes Q: "ccorres r xf Q Q' hs a c"
shows "ccorres r xf (P and Q)
({s. s \<in> B \<longrightarrow> s \<in> P'} \<inter> {s. s \<notin> B \<longrightarrow> s \<in> Q'})
hs a c" using P Q
apply (clarsimp simp: ccorres_underlying_def)
apply (drule (1) bspec)+
apply clarsimp
apply (case_tac "b \<in> B", auto)
done
(* FIXME: move *)
lemma ccorres_return_bind_add:
"ccorres r xf P P' hs (do z \<leftarrow> return (f x); H z od) C \<Longrightarrow> ccorres r xf P P' hs (H (f x)) C"
by simp
(* FIXME: move *)
lemma ccorres_if_cond_throws_break:
fixes e :: 'e
assumes abs: "\<forall>s s'. (s, s') \<in> sr \<and> Q s \<and> Q' s' \<longrightarrow> P = (s' \<in> P')"
and ac: "P \<Longrightarrow> ccorres_underlying sr \<Gamma> r xf arrel axf R R' (catchbrk_C # hs) a c"
and bd: "\<not> P \<Longrightarrow> ccorres_underlying sr \<Gamma> r xf arrel axf U U' (catchbrk_C # hs) b d"
and cthrows: "\<Gamma> \<turnstile>\<^bsub>/UNIV\<^esub> PT' c {}, UNIV" -- "c always throws"
shows "ccorres_underlying sr \<Gamma> r xf arrel axf
(Q and (\<lambda>s. P \<longrightarrow> R s) and (\<lambda>s. \<not> P \<longrightarrow> U s))
(Collect Q' \<inter> {s. (s \<in> P' \<longrightarrow> s \<in> R' \<inter> PT') \<and> (s \<notin> P' \<longrightarrow> s \<in> U')})
2017-05-02 01:12:26 +00:00
(catchbrk_C # hs)
(if P then a else b) (Cond P' c SKIP ;; d)"
2014-07-14 19:32:44 +00:00
(is "ccorres_underlying sr \<Gamma> r xf arrel axf ?G ?G' ?hs ?a ?c")
proof (cases P)
case True
2017-05-02 01:12:26 +00:00
2014-07-14 19:32:44 +00:00
thus ?thesis
apply simp
apply (rule ccorres_guard_imp2)
apply (rule ccorres_split_throws)
apply (rule ccorres_cond_true [OF ac [OF True]])
apply (rule HoarePartial.Cond [where P = "P' \<inter> PT'", OF _ cthrows])
apply clarsimp
apply (rule HoarePartial.Skip)
apply (rule subset_refl)
apply (clarsimp simp: abs [rule_format, OF conjI])
done
next
case False
2017-05-02 01:12:26 +00:00
2014-07-14 19:32:44 +00:00
thus ?thesis
apply simp
apply (rule ccorres_guard_imp2)
apply (rule ccorres_add_return)
2017-05-02 01:12:26 +00:00
apply (rule ccorres_split_nothrow)
apply (rule ccorres_cond_false)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_return_Skip)
apply (rule ceqv_refl)
apply (rule bd [OF False])
2017-05-02 01:12:26 +00:00
apply wp
2014-07-14 19:32:44 +00:00
apply simp
apply (rule Cond_false)
apply (rule HoarePartial.Skip [OF subset_refl])
apply (clarsimp simp: abs [rule_format, OF conjI])
done
qed
(* FIXME: move *)
lemma ccorres_if_cond_throws_break2:
fixes e :: 'e
assumes abs: "\<forall>s s'. (s, s') \<in> sr \<and> Q s \<and> Q' s' \<longrightarrow> (\<not> P) = (s' \<in> P')"
and ac: "\<not> P \<Longrightarrow> ccorres_underlying sr \<Gamma> r xf arrel axf R R' (catchbrk_C # hs) a c"
and bd: "P \<Longrightarrow> ccorres_underlying sr \<Gamma> r xf arrel axf U U' (catchbrk_C # hs) b d"
and cthrows: "\<Gamma> \<turnstile>\<^bsub>/UNIV\<^esub> PT' c {}, UNIV" -- "c always throws"
shows "ccorres_underlying sr \<Gamma> r xf arrel axf
(Q and (\<lambda>s. \<not> P \<longrightarrow> R s) and (\<lambda>s. P \<longrightarrow> U s))
(Collect Q' \<inter> {s. (s \<in> P' \<longrightarrow> s \<in> R' \<inter> PT') \<and> (s \<notin> P' \<longrightarrow> s \<in> U')})
(catchbrk_C # hs)
(if P then b else a) (Cond P' c SKIP ;; d)"
apply (subst if_swap)
apply (rule ccorres_guard_imp2)
apply (rule ccorres_if_cond_throws_break [OF abs ac bd cthrows])
apply assumption
apply simp
apply clarsimp
done
(* FIXME : move *)
lemma scast_bit_test [simp]:
"scast ((1 :: 'a::len signed word) << n) = (1 :: 'a word) << n"
by (clarsimp simp: word_eq_iff)
(* FIXME: move *)
lemma ccorres_split_when_throwError_cond_break:
fixes e :: 'e
assumes abs: "\<forall>s s'. (s, s') \<in> sr \<and> Q s \<and> Q' s' \<longrightarrow> P = (s' \<in> P')"
and cc: "P \<Longrightarrow> ccorres_underlying sr \<Gamma> r xf ar axf
R R' (catchbrk_C # hs) (throwError e) c"
and bd: "\<not> P \<Longrightarrow> ccorres_underlying sr \<Gamma> r xf ar axf
U U' (catchbrk_C # hs) b d"
and cthrows: "\<Gamma> \<turnstile>\<^bsub>/UNIV\<^esub> PT' c {}, UNIV" -- "c always throws"
shows "ccorres_underlying sr \<Gamma> r xf ar axf
(Q and (\<lambda>s. P \<longrightarrow> R s) and (\<lambda>s. \<not> P \<longrightarrow> U s))
(Collect Q' \<inter> {s. (s \<in> P' \<longrightarrow> s \<in> R' \<inter> PT') \<and> (s \<notin> P' \<longrightarrow> s \<in> U')})
2017-05-02 01:12:26 +00:00
(catchbrk_C # hs)
2014-07-14 19:32:44 +00:00
(whenE P (throwError e) >>=E (\<lambda>_. b)) (Cond P' c SKIP ;; d)"
apply (subst whenE_bindE_throwError_to_if)
apply (rule ccorres_if_cond_throws_break [OF abs cc bd cthrows])
apply assumption
apply assumption
done
lemma maskAsFull_isEndpoint[simp]:
"isEndpointCap a \<Longrightarrow> maskedAsFull a b = a"
by (clarsimp simp:isCap_simps maskedAsFull_def)
lemma maskAsFull_eq_ep:
"maskedAsFull cap cap =
EndpointCap a b c d e \<Longrightarrow> cap = EndpointCap a b c d e"
by (clarsimp simp:maskedAsFull_def isCap_simps split:if_splits)
lemma is_derived_capMasterCap:
"is_derived' m slot cap cap'
\<Longrightarrow> capMasterCap cap = capMasterCap cap'"
2017-05-02 01:12:26 +00:00
by (clarsimp simp:is_derived'_def badge_derived'_def)
2014-07-14 19:32:44 +00:00
lemma maskedAsFull_misc:
"badge_derived' a (maskedAsFull a b)"
"capASID (maskedAsFull a b) = capASID a"
"cap_asid_base' (maskedAsFull a b) = cap_asid_base' a"
"cap_vptr' (maskedAsFull a b) = cap_vptr' a"
"capMasterCap (maskedAsFull a b) = capMasterCap a"
2015-11-16 03:12:37 +00:00
by (auto simp:maskedAsFull_def isCap_simps badge_derived'_def
2016-10-25 06:01:30 +00:00
split:if_split)
2014-07-14 19:32:44 +00:00
lemma maskedAsFull_again:
"maskedAsFull (maskedAsFull aa aa) r = maskedAsFull aa aa"
apply (case_tac aa)
2016-10-25 06:01:30 +00:00
apply (simp_all add:maskedAsFull_def isCap_simps split: if_split)+
2014-07-14 19:32:44 +00:00
done
2016-08-23 12:31:49 +00:00
lemma ccap_relation_lift:
2014-07-14 19:32:44 +00:00
"ccap_relation cap cap'
\<Longrightarrow> (cap_to_H (the (cap_lift cap'))) = cap"
2014-09-10 07:26:44 +00:00
apply (case_tac "cap_lift cap'")
apply (auto simp:ccap_relation_def split:option.splits)
done
2014-07-14 19:32:44 +00:00
lemma ccap_relation_inject:
"\<lbrakk>ccap_relation acap cap; ccap_relation bcap cap\<rbrakk> \<Longrightarrow> acap = bcap"
2014-09-10 07:26:44 +00:00
apply (case_tac "cap_lift cap")
apply (auto simp:ccap_relation_def split:option.splits)
done
2014-07-14 19:32:44 +00:00
lemma t2n_mask_eq_if:
"(2 ^ n && mask m) = (if n < m then 2 ^ n else 0)"
2016-10-25 06:01:30 +00:00
by (rule word_eqI, auto simp add: word_size nth_w2p split: if_split)
2014-07-14 19:32:44 +00:00
lemma transferCapsLoop_ccorres:
assumes conds:
"rcv_buffer \<noteq> 0"
"ep \<noteq> Some 0"
defines "check1 \<equiv>
Guard ShiftError \<lbrace>0 <=s seL4_MsgExtraCapBits\<rbrace>
(Guard ShiftError \<lbrace>seL4_MsgExtraCapBits <s 0x20\<rbrace>
(\<acute>ret__int :==
(if \<acute>i < 2 ^ unat seL4_MsgExtraCapBits - 1 then 1
else 0)))"
and "check2 \<equiv> \<lambda>caps.
IF \<acute>ret__int \<noteq> 0 THEN
Guard ArrayBounds \<lbrace>\<acute>i < 3\<rbrace> (\<acute>ret__int :==
(if index (excaprefs_C caps) (unat \<acute>i) \<noteq> cte_Ptr 0 then 1
else 0))
FI"
2016-02-10 03:11:09 +00:00
defines "W \<equiv> \<lambda>ep caps.
2014-07-14 19:32:44 +00:00
check1;; check2 caps;;
(While \<lbrace>\<acute>ret__int \<noteq> 0\<rbrace>
(Guard ArrayBounds \<lbrace>\<acute>i < 3\<rbrace> (\<acute>slot :== index (excaprefs_C caps) (unat \<acute>i));;
Guard C_Guard \<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t \<acute>slot\<rbrace>
(\<acute>cap :== h_val (hrs_mem \<acute>t_hrs) (cap_Ptr &(\<acute>slot\<rightarrow>[''cap_C''])));;
2015-12-08 06:29:42 +00:00
\<acute>ret__unsigned :== CALL cap_get_capType(\<acute>cap);;
\<acute>ret__int :== (if \<acute>ret__unsigned = scast cap_endpoint_cap then 1 else 0);;
2014-07-14 19:32:44 +00:00
IF \<acute>ret__int \<noteq> 0 THEN
2015-12-08 06:29:42 +00:00
\<acute>ret__unsigned :== CALL cap_endpoint_cap_get_capEPPtr(\<acute>cap);;
\<acute>ret__int :== (if ep_Ptr \<acute>ret__unsigned = option_to_ptr ep then 1 else 0)
2014-07-14 19:32:44 +00:00
FI;;
IF \<acute>ret__int \<noteq> 0 THEN
2015-12-08 06:29:42 +00:00
\<acute>ret__unsigned :== CALL cap_endpoint_cap_get_capEPBadge(\<acute>cap);;
CALL setExtraBadge(Ptr rcv_buffer, ucast \<acute>ret__unsigned,\<acute>i);;
2016-01-08 07:43:33 +00:00
\<acute>ret__unsigned :== CALL seL4_MessageInfo_get_capsUnwrapped(\<acute>info);;
2014-07-14 19:32:44 +00:00
Guard ShiftError \<lbrace>unat \<acute>i < 31 \<and> 0 <=s (1 :: sword32)\<rbrace>
2016-01-08 07:43:33 +00:00
(\<acute>info :== CALL seL4_MessageInfo_set_capsUnwrapped(\<acute>info,
2015-12-08 06:29:42 +00:00
\<acute>ret__unsigned || scast ((1 :: sword32) << unat \<acute>i)))
2014-07-14 19:32:44 +00:00
ELSE
lvar_nondet_init dc_ret_' dc_ret_'_update;;
IF \<acute>destSlot = cte_Ptr 0 THEN
break_C
FI;;
2017-05-02 01:12:26 +00:00
\<acute>dc_ret :== CALL deriveCap(\<acute>slot,\<acute>cap);;
2014-07-14 19:32:44 +00:00
IF deriveCap_ret_C.status_C \<acute>dc_ret \<noteq> scast EXCEPTION_NONE THEN
break_C
FI;;
2015-12-08 06:29:42 +00:00
\<acute>ret__unsigned :== CALL cap_get_capType(deriveCap_ret_C.cap_C \<acute>dc_ret);;
IF \<acute>ret__unsigned = scast cap_null_cap THEN
2014-07-14 19:32:44 +00:00
break_C
FI;;
CALL cteInsert(deriveCap_ret_C.cap_C \<acute>dc_ret,\<acute>slot,\<acute>destSlot);;
\<acute>destSlot :== cte_Ptr 0
FI;;
\<acute>i :== \<acute>i + 1;; check1;; check2 caps))"
2017-05-02 01:12:26 +00:00
defines "precond n mi slots \<equiv> (UNIV \<inter> \<lbrace>\<acute>i = of_nat n\<rbrace>
\<inter> \<lbrace>mi = message_info_to_H (\<acute>info)\<rbrace>
2014-07-14 19:32:44 +00:00
\<inter> \<lbrace>\<acute>destSlot = (if slots = [] then NULL else cte_Ptr (hd slots))
\<and> length slots \<le> 1 \<and> slots \<noteq> [0]\<rbrace>)"
defines "is_the_ep \<equiv> \<lambda>cap. isEndpointCap cap \<and> ep \<noteq> None \<and> capEPPtr cap = the ep"
defines "stable \<equiv> \<lambda>scap excap. excap \<noteq> scap \<longrightarrow> excap = maskedAsFull scap scap"
defines "relative_at \<equiv> \<lambda>scap slot s. cte_wp_at'
(\<lambda>cte. badge_derived' scap (cteCap cte) \<and>
capASID scap = capASID (cteCap cte) \<and>
cap_asid_base' scap = cap_asid_base' (cteCap cte) \<and>
cap_vptr' scap = cap_vptr' (cteCap cte)) slot s"
shows "drop n (interpret_excaps caps') = excaps_map caps
\<and> n \<le> length (interpret_excaps caps')
\<Longrightarrow> ccorresG rf_sr \<Gamma>
(\<lambda>r (i, info). r = msgExtraCaps_update (\<lambda>_. i) (message_info_to_H info)
\<and> i \<le> 3) (\<lambda>s. (i_' s, info_' s))
(valid_pspace' and valid_ipc_buffer_ptr' rcv_buffer and
2017-05-02 01:12:26 +00:00
(\<lambda>s. (\<forall>x \<in> set caps. s \<turnstile>' fst x
2014-07-14 19:32:44 +00:00
\<and> cte_wp_at' (\<lambda>cte. slots \<noteq> [] \<or> is_the_ep (cteCap cte)
\<longrightarrow> (fst x) = (cteCap cte)) (snd x) s
\<and> cte_wp_at' (\<lambda>cte. fst x \<noteq> NullCap \<longrightarrow> stable (fst x) (cteCap cte)) (snd x) s)) and
(\<lambda>s. \<forall> sl \<in> (set slots). cte_wp_at' (isNullCap o cteCap) sl s) and
(\<lambda>_. n + length caps \<le> 3 \<and> distinct slots ))
(precond n mi slots)
[catchbrk_C]
2016-02-10 03:11:09 +00:00
(transferCapsToSlots ep rcv_buffer n caps slots mi)
(W ep caps')"
2014-07-14 19:32:44 +00:00
unfolding W_def check1_def check2_def split_def
proof (rule ccorres_gen_asm, induct caps arbitrary: n slots mi)
2016-10-25 06:01:30 +00:00
note if_split[split]
2014-07-14 19:32:44 +00:00
case Nil
thus ?case
apply (simp only: transferCapsToSlots.simps)
apply (rule ccorres_guard_imp2)
apply (rule ccorres_Guard_Seq ccorres_rhs_assoc)+
apply (rule ccorres_rhs_assoc2, rule ccorres_symb_exec_r)
apply (rule ccorres_expand_while_iff [THEN iffD1])
apply (rule ccorres_cond_false)
apply (rule_tac P="\<lambda>_. n \<le> 3" and P'="\<lbrace>\<acute>i=of_nat n \<and> mi=message_info_to_H \<acute>info\<rbrace>"
in ccorres_from_vcg)
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp simp: return_def msgExtraCapBits_def word_le_nat_alt unat_of_nat)
apply vcg
apply (rule conseqPre, vcg, clarsimp)
apply (simp add: seL4_MsgExtraCapBits_def)
apply (clarsimp simp: excaps_map_def seL4_MsgExtraCapBits_def word_sle_def
precond_def)
apply (subst (asm) interpret_excaps_test_null)
apply (simp add: unat_of_nat)
apply (simp add: unat_of_nat)
apply (erule le_neq_trans, clarsimp)
apply (simp add: unat_of_nat)
done
next
2016-10-25 06:01:30 +00:00
note if_split[split]
2014-07-14 19:32:44 +00:00
case (Cons x xs')
let ?S="\<lbrace>\<acute>i=of_nat n \<and> mi=message_info_to_H \<acute>info\<rbrace>"
have n3: "n \<le> 3" using Cons.prems by simp
hence of_nat_n3[intro!]: "of_nat n \<le> (3 :: word32)"
by (simp add: word_le_nat_alt unat_of_nat)
have drop_n_foo: "\<And>xs n y ys. drop n xs = y # ys
\<Longrightarrow> \<exists>xs'. length xs' = n \<and> xs = xs' @ (y # ys)"
apply (frule_tac f=length in arg_cong, simp(no_asm_use))
apply (cut_tac n=n and xs=xs in append_take_drop_id)
apply (rule_tac x="take n xs" in exI)
apply simp
done
have ep_cap_not_null: "\<And>cap. isEndpointCap cap \<Longrightarrow> cap \<noteq> NullCap"
by (clarsimp simp: isCap_simps)
have is_the_ep_maskedAsFull[simp]:"\<And>a b. is_the_ep (maskedAsFull a b) = is_the_ep a"
apply (case_tac a)
apply (simp add:maskedAsFull_def is_the_ep_def isCap_simps)+
done
have is_the_ep_fold:
"(isEndpointCap (fst x) \<and> (\<exists>y. ep = Some y) \<and> capEPPtr (fst x) = the ep)
= is_the_ep (fst x)"
by (simp add:is_the_ep_def)
have relative_fold:
"\<And>scap slot s. (cte_wp_at'
(\<lambda>cte. badge_derived' scap (cteCap cte) \<and>
capASID scap = capASID (cteCap cte) \<and>
cap_asid_base' scap = cap_asid_base' (cteCap cte) \<and>
cap_vptr' scap = cap_vptr' (cteCap cte)) slot s) = relative_at scap slot s"
by (simp add:relative_at_def)
have stableD:
"\<And>scap excap. stable scap excap
\<Longrightarrow> (badge_derived' scap excap \<and>
capASID scap = capASID excap \<and>
cap_asid_base' scap = cap_asid_base' excap \<and> cap_vptr' scap = cap_vptr' excap)"
apply (clarsimp simp:stable_def)
apply (case_tac "excap = scap",simp+)
apply (simp add:maskedAsFull_misc)
done
have stable_eq:
"\<And>scap excap. \<lbrakk>stable scap excap; isEndpointCap excap\<rbrakk> \<Longrightarrow> scap = excap"
by (simp add:isCap_simps stable_def maskedAsFull_def split:if_splits)
2017-05-02 01:12:26 +00:00
2014-07-14 19:32:44 +00:00
have is_the_ep_stable:
"\<And>a b. \<lbrakk>a \<noteq> NullCap \<longrightarrow> stable a b; \<not> is_the_ep b \<rbrakk> \<Longrightarrow> \<not> is_the_ep a"
apply (clarsimp simp:stable_def maskedAsFull_def is_the_ep_def isCap_simps split:if_splits)
apply auto
done
have is_the_ep_maskCapRights:
"\<And>rights cap. is_the_ep (maskCapRights rights cap) = is_the_ep cap"
apply (case_tac "isEndpointCap cap")
apply (simp_all add:is_the_ep_def maskCapRights_def)
apply (clarsimp simp:isCap_simps)
apply (case_tac cap)
apply (simp_all add:isCap_simps)
2015-05-20 10:39:47 +00:00
apply (rename_tac acap)
apply (case_tac acap)
2016-05-01 03:35:49 +00:00
apply (clarsimp simp:ARM_H.maskCapRights_def isPageCap_def)+
2014-07-14 19:32:44 +00:00
done
have is_the_ep_deriveCap:
"\<And>slot cap. \<lbrace>\<lambda>s. \<not> (is_the_ep cap)\<rbrace> deriveCap slot cap \<lbrace>\<lambda>rv s. \<not> (is_the_ep rv)\<rbrace>, -"
apply (case_tac cap)
apply (simp_all add:deriveCap_def Let_def isCap_simps is_the_ep_def)
apply (wp,clarsimp)+
defer
apply (wp,clarsimp)+
2015-05-20 10:39:47 +00:00
apply (rename_tac acap)
apply (case_tac acap)
2016-05-01 03:35:49 +00:00
apply (simp_all add:ARM_H.deriveCap_def Let_def isCap_simps is_the_ep_def)
2014-07-14 19:32:44 +00:00
apply (wp |clarsimp|rule conjI)+
done
have mask_right_eq_null:
"\<And>r cap. (maskCapRights r cap = NullCap) = (cap = NullCap)"
apply (case_tac cap)
apply (simp_all add:maskCapRights_def isCap_simps)
2015-05-20 10:39:47 +00:00
apply (rename_tac acap)
apply (case_tac acap)
2016-05-01 03:35:49 +00:00
apply (simp add:ARM_H.maskCapRights_def isPageCap_def)+
2014-07-14 19:32:44 +00:00
done
2016-10-25 06:01:30 +00:00
note if_split[split del]
2014-07-14 19:32:44 +00:00
note if_cong[cong]
2016-04-18 20:25:44 +00:00
note extra_sle_sless_unfolds [simp del]
2014-07-14 19:32:44 +00:00
from Cons.prems
show ?case
2016-04-18 20:25:44 +00:00
apply (clarsimp simp: Let_def word_sle_def[where b=5] split_def
cong: call_ignore_cong
2014-07-14 19:32:44 +00:00
simp del: Collect_const)
apply (rule ccorres_constOnFailure)
apply (rule ccorres_guard_imp2)
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_expand_while_iff [THEN iffD1])
apply (rule ccorres_cond_true)
apply (rule ccorres_rhs_assoc)+
apply (rule_tac xf'=i_' in ccorres_abstract, ceqv)
apply (rule ccorres_Guard_Seq)
apply csymbr
apply (rule ccorres_symb_exec_r)
apply (rule_tac xf'=cap_' in ccorres_abstract,ceqv)
apply (rename_tac n' cap')
apply (rule_tac P="\<exists>acap. ccap_relation acap cap'
\<and> (isEndpointCap acap \<longrightarrow> capEPPtr acap \<noteq> 0)" in ccorres_gen_asm2)
apply csymbr+
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_seq_cond_raise[THEN iffD2])
apply (rule_tac xf'=ret__int_' in ccorres_abstract_known, ceqv)
apply (rule ccorres_cond2[where R=\<top>])
apply (clarsimp simp: Collect_const_mem)
apply (rule sym, rule from_bool_neq_0)
-- "case where a badge is sent"
apply (rule ccorres_rhs_assoc)+
apply csymbr
apply (simp only: Let_def liftE_bindE withoutFailure_def fun_app_def)
apply (ctac add: setExtraBadge_ccorres)
apply (simp only: K_bind_def)
2014-08-09 05:16:17 +00:00
apply (rule ccorres_case_sum_liftE)
2014-07-14 19:32:44 +00:00
apply (csymbr, rule ccorres_abstract_cleanup)
apply (rule ccorres_Guard_Seq)
apply (csymbr, rule ccorres_abstract_cleanup)
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_rhs_assoc2)
apply (rule Cons.hyps)
apply (clarsimp simp: excaps_map_def dest!: drop_n_foo)
apply simp
apply vcg
apply (rule conseqPre, vcg, clarsimp)
apply (wp hoare_vcg_ball_lift)
2016-10-25 06:01:30 +00:00
apply (simp split del: if_split)
2014-07-14 19:32:44 +00:00
apply (vcg exspec=setExtraBadge_modifies)
-- "case where a cap is sent (or rather a send is attempted)"
apply (simp add: split_def del: Collect_const
2016-10-25 06:01:30 +00:00
cong: call_ignore_cong split del: if_split)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_rhs_assoc)+
apply csymbr
apply wpc
apply (rule ccorres_cond_true_seq)
2016-02-10 03:11:09 +00:00
apply (simp add: returnOk_liftE)
2014-08-09 05:16:17 +00:00
apply (rule ccorres_case_sum_liftE)
2017-05-02 01:12:26 +00:00
apply (rule ccorres_split_throws)
2014-07-14 19:32:44 +00:00
apply (rule_tac P=\<top> and P'="?S" in ccorres_break_return)
apply clarsimp
apply simp
apply vcg
apply (rule ccorres_cond_false_seq)
2016-02-10 03:11:09 +00:00
apply (simp)
2017-05-02 01:12:26 +00:00
2014-07-14 19:32:44 +00:00
-- "case not diminish"
apply (rule ccorres_split_nothrowE)
apply (rule unifyFailure_ccorres)
apply (ctac add: deriveCap_ccorres')
apply ceqv
apply (simp only: refl not_True_eq_False Collect_False ccorres_seq_simps)
apply csymbr
apply (rule_tac Q=\<top> and Q'=\<top> in ccorres_split_when_throwError_cond_break)
apply (clarsimp simp: cap_get_tag_isCap Collect_const_mem)
apply (rule_tac P=\<top> and P'="?S" in ccorres_break)
apply clarsimp
apply simp
2016-10-25 06:01:30 +00:00
apply (simp(no_asm) add: liftE_bindE split del: if_split)
2014-07-14 19:32:44 +00:00
apply (ctac add: cteInsert_ccorres)
2014-08-09 05:16:17 +00:00
apply (rule ccorres_case_sum_liftE)
2014-07-14 19:32:44 +00:00
apply csymbr
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_rhs_assoc2)
2015-05-20 10:39:47 +00:00
apply (rule_tac P="ccorresG rf_sr \<Gamma> r xf Pre Pre' hs a" for r xf Pre Pre' hs a in rsubst)
2014-07-14 19:32:44 +00:00
apply (rule Cons.hyps)
apply (clarsimp simp: excaps_map_def dest!: drop_n_foo)
apply simp
apply simp
apply vcg
apply (rule conseqPre, vcg)
apply clarsimp
apply (rule cteInsert_assume_Null)
apply simp
apply (wp cteInsert_valid_pspace hoare_valid_ipc_buffer_ptr_typ_at'
hoare_vcg_const_Ball_lift cteInsert_cte_wp_at)
apply (vcg exspec=cteInsert_modifies)
apply vcg
2015-05-20 10:39:47 +00:00
apply (simp)
2017-05-02 01:12:26 +00:00
apply (rule ccorres_split_throws)
2014-07-14 19:32:44 +00:00
apply (rule_tac P=\<top> and P'="?S" in ccorres_break)
apply clarsimp
apply simp
apply vcg
apply wp
apply (simp cong: conj_cong)
apply (rule_tac Q' ="\<lambda>rcap s. s \<turnstile>' rcap
\<and> (rcap\<noteq> NullCap \<longrightarrow> cte_wp_at' (is_derived' (ctes_of s) (snd x) rcap \<circ> cteCap) (snd x) s)
\<and> valid_pspace' s \<and> valid_ipc_buffer_ptr' rcv_buffer s \<and> length slots = 1
\<and> \<not> is_the_ep rcap
\<and> (\<forall>x\<in>set slots. cte_wp_at' (isNullCap \<circ> cteCap) x s)
2017-05-02 01:12:26 +00:00
\<and> (\<forall>x\<in>set xs'. s \<turnstile>' fst x
2014-07-14 19:32:44 +00:00
\<and> cte_wp_at' (\<lambda>c. is_the_ep (cteCap c) \<longrightarrow> fst x = cteCap c) (snd x) s
\<and> cte_wp_at' (\<lambda>c. fst x \<noteq> NullCap \<longrightarrow> stable (fst x) (cteCap c)) (snd x) s)"
in hoare_post_imp_R)
prefer 2
apply (clarsimp simp:cte_wp_at_ctes_of valid_pspace_mdb' valid_pspace'_splits
valid_pspace_valid_objs' is_derived_capMasterCap image_def)
apply (clarsimp split:if_splits)
apply (rule conjI)
apply clarsimp+
apply (rule conjI)
apply (drule(1) bspec)+
apply (rule conjI | clarsimp)+
apply (clarsimp simp:is_the_ep_def isCap_simps stable_def)
apply (drule(1) bspec)+
apply (rule conjI | clarsimp)+
apply (clarsimp simp:is_the_ep_def stable_def split:if_splits)+
2014-09-10 07:26:44 +00:00
apply (case_tac "a = cteCap cteb",clarsimp)
2014-07-14 19:32:44 +00:00
apply (simp add:maskedAsFull_def split:if_splits)
apply (simp add:maskedAsFull_again)
apply (wp deriveCap_derived is_the_ep_deriveCap)
apply (vcg exspec=deriveCap_modifies)
--"remaining non ccorres subgoals"
apply (clarsimp simp: Collect_const_mem if_1_0_0
2016-10-25 06:01:30 +00:00
split del: if_split)
2014-07-14 19:32:44 +00:00
apply (rule_tac Q'="\<lbrace>\<acute>ret__int = from_bool (cap_get_tag cap' = scast cap_endpoint_cap
\<and> ep_Ptr (capEPPtr_CL (cap_endpoint_cap_lift cap')) = option_to_ptr ep)
\<and> n' = of_nat n \<and> ((slots \<noteq> [] \<or> isEndpointCap (fst x) \<or> is_the_ep (cap_to_H (the (cap_lift cap'))))
\<longrightarrow> ccap_relation (fst x) cap' )
\<and> (isEndpointCap (fst x) \<longrightarrow> capEPPtr (fst x) \<noteq> 0)\<rbrace>
\<inter> precond n mi slots"
in conseqPost[OF _ _ order_refl])
apply vcg
apply (rule subsetI)
apply (clarsimp simp: word_of_nat_less from_bool_0 precond_def
cap_get_tag_isCap unat_of_nat)
apply (rule conjI)
apply (clarsimp simp: cap_get_tag_EndpointCap cap_get_tag_isCap[symmetric]
ep_cap_not_null)
2016-04-18 20:25:44 +00:00
apply (clarsimp simp: ccap_relation_def map_option_Some_eq2)
2014-07-14 19:32:44 +00:00
apply (simp add: message_info_to_H_def word_ao_dist)
apply (fold shiftl_1)[1]
apply (subst and_mask_eq_iff_shiftr_0[THEN iffD2],
subst shiftl_shiftr2, simp, simp)
2016-01-08 07:43:33 +00:00
apply (simp add: seL4_MessageInfo_lift_def word_bw_assocs
2014-07-14 19:32:44 +00:00
word_sle_def t2n_mask_eq_if)
apply (simp add: mask_def)
apply (rule conjI)
apply (clarsimp simp: ccap_rights_relation_def cap_rights_to_H_def
false_def true_def to_bool_def allRights_def
excaps_map_def split_def
dest!: drop_n_foo interpret_excaps_eq)
apply (clarsimp simp:from_bool_def split:bool.splits)
apply (case_tac "isEndpointCap (fst x)")
apply (clarsimp simp: cap_get_tag_EndpointCap ep_cap_not_null cap_get_tag_isCap[symmetric])
apply (clarsimp simp: option_to_ptr_def option_to_0_def split:option.splits)
apply (clarsimp simp: cap_get_tag_EndpointCap ep_cap_not_null cap_get_tag_isCap[symmetric])
apply (case_tac "ccap_relation (fst x) cap'")
apply (simp add:ccap_relation_lift)
apply (drule(1) ccap_relation_inject)
apply (drule sym[where t = "fst x"])
apply (clarsimp simp:isCap_simps)
apply (clarsimp simp: is_the_ep_def ccap_relation_lift isCap_simps)
apply (clarsimp simp: option_to_ptr_def option_to_0_def split:option.splits)
apply (clarsimp simp:option_to_ptr_def option_to_0_def)
apply (case_tac "isEndpointCap (fst x)")
apply (clarsimp simp: isCap_simps)
apply (drule_tac acap = acap in ccap_relation_inject)
apply assumption
apply clarsimp
2016-04-18 20:25:44 +00:00
apply (clarsimp simp: ccap_relation_def map_option_Some_eq2 split:option.splits)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: cap_endpoint_cap_lift_def option_to_ptr_def
option_to_0_def cap_to_H_def Let_def split:cap_CL.splits split:if_splits)
apply clarsimp
2017-05-02 01:12:26 +00:00
apply (simp only:badge_derived_mask capASID_mask cap_asid_base_mask'
2014-07-14 19:32:44 +00:00
cap_vptr_mask' maskCap_valid mask_right_eq_null)
apply (simp only:is_the_ep_fold relative_fold)
apply (clarsimp simp:Collect_const_mem if_1_0_0
2016-10-25 06:01:30 +00:00
split del:if_split)
2014-07-14 19:32:44 +00:00
apply (rule conseqPre, vcg, clarsimp simp: Collect_const_mem)
apply (clarsimp simp: if_1_0_0 Collect_const_mem
trans[OF eq_commute from_bool_eq_if]
from_bool_0
2016-10-25 06:01:30 +00:00
split del: if_split simp del: Collect_const)
2014-07-14 19:32:44 +00:00
apply vcg
apply (simp only:is_the_ep_fold)
apply (clarsimp simp:Collect_const_mem if_1_0_0
2016-10-25 06:01:30 +00:00
split del:if_split)
2014-07-14 19:32:44 +00:00
apply (rule conseqPre, vcg)
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split)
apply (clarsimp split del: if_split
2014-07-14 19:32:44 +00:00
simp add: Collect_const[symmetric] precond_def true_def false_def
simp del: Collect_const)
apply (rule HoarePartial.Seq[rotated] HoarePartial.Cond[OF order_refl]
HoarePartial.Basic[OF order_refl] HoarePartial.Skip[OF order_refl]
HoarePartial.Guard[OF order_refl])+
apply (simp only:is_the_ep_fold)
apply (clarsimp simp:Collect_const_mem if_1_0_0
2016-10-25 06:01:30 +00:00
split del:if_split)
2014-07-14 19:32:44 +00:00
apply (rule conseqPre, vcg, rule subsetI, clarsimp)
apply (simp only:is_the_ep_fold)
apply (clarsimp simp: Collect_const_mem seL4_MsgExtraCapBits_def
word_sle_def if_1_0_0 precond_def
msg_max_length_def max_ipc_words word_of_nat_less
excaps_map_def unat_of_nat valid_pspace'_def
cte_wp_at_ctes_of
dest!: drop_n_foo interpret_excaps_eq)
apply (frule(1) ctes_of_valid')
apply (rule cmap_relationE1[OF cmap_relation_cte], assumption+)
apply (clarsimp simp: typ_heap_simps' split_def is_the_ep_maskCapRights)
apply (frule ccte_relation_ccap_relation)
apply (intro conjI impI)
apply (intro allI impI)
apply clarsimp
apply fastforce
apply (subgoal_tac "fst x = cteCap cte",simp)
apply clarsimp
apply (elim disjE)
apply (clarsimp simp:ep_cap_not_null stable_def)
apply (clarsimp dest!:ccap_relation_lift stable_eq simp: cap_get_tag_isCap)
apply (clarsimp simp:valid_cap_simps' isCap_simps)
apply (subgoal_tac "slots \<noteq> []")
apply simp
apply clarsimp
apply (elim disjE)
apply (clarsimp simp:ep_cap_not_null stable_def)
apply (clarsimp dest!:ccap_relation_lift stable_eq simp: cap_get_tag_isCap)
apply (clarsimp dest!:ccap_relation_lift simp:cap_get_tag_isCap is_the_ep_def)
apply (clarsimp simp:valid_cap_simps' isCap_simps)
apply (intro exI conjI,assumption)
2016-04-18 20:25:44 +00:00
apply (clarsimp simp: ccap_relation_def map_option_Some_eq2
2014-07-14 19:32:44 +00:00
isCap_simps valid_cap_simps')+
done
qed
lemma cte_wp_at_imp_consequent':
"cte_wp_at' Q p s \<longrightarrow> cte_wp_at' (\<lambda>cte. P cte \<longrightarrow> Q cte) p s"
by (clarsimp simp: cte_wp_at_ctes_of)
lemma lookupExtraCaps_srcs2:
"\<lbrace>\<top>\<rbrace> lookupExtraCaps t buf mi \<lbrace>\<lambda>caps s. \<forall>x \<in> set caps. cte_wp_at'
(\<lambda>cte. cteCap cte = fst x) (snd x) s\<rbrace>,-"
apply (simp add: lookupExtraCaps_def lookupCapAndSlot_def
split_def lookupSlotForThread_def
getSlotCap_def)
apply (wp mapME_set[where R=\<top>] getCTE_wp'
2017-05-02 01:12:26 +00:00
| simp add: cte_wp_at_ctes_of
2014-07-14 19:32:44 +00:00
| wp_once hoare_drop_imps
| (rule hoare_strengthen_post [OF hoare_TrueI], rule allI, rule impI, rule TrueI))+
done
2017-05-02 01:12:26 +00:00
lemma transferCaps_ccorres [corres]:
2014-07-14 19:32:44 +00:00
notes if_cong[cong]
2016-04-18 20:25:44 +00:00
notes extra_sle_sless_unfolds[simp del]
2014-07-14 19:32:44 +00:00
shows
2016-01-08 07:43:33 +00:00
"ccorres (\<lambda>r r'. r = message_info_to_H r') ret__struct_seL4_MessageInfo_C_'
2014-07-14 19:32:44 +00:00
(valid_pspace' and tcb_at' receiver
2014-08-09 05:16:17 +00:00
and (case_option \<top> valid_ipc_buffer_ptr') receiveBuffer
2014-07-14 19:32:44 +00:00
and (excaps_in_mem caps \<circ> ctes_of)
and K (length caps \<le> 3)
and K (ep \<noteq> Some 0)
and K (receiveBuffer \<noteq> Some 0)
and K (unat (msgExtraCaps mi) \<le> 3))
(UNIV \<inter> \<lbrace>interpret_excaps (\<acute>caps) = excaps_map caps\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
\<inter> \<lbrace> mi = message_info_to_H \<acute>info\<rbrace>
\<inter> \<lbrace>\<acute>receiveBuffer = Ptr (option_to_0 receiveBuffer)\<rbrace>
2016-02-10 03:11:09 +00:00
\<inter> \<lbrace>\<acute>endpoint = option_to_ptr ep\<rbrace>) []
(transferCaps mi caps ep receiver receiveBuffer)
2014-07-14 19:32:44 +00:00
(Call transferCaps_'proc)" (is "ccorres _ _ ?P _ _ _ _")
apply (unfold K_def, intro ccorres_gen_asm)
2016-02-10 03:11:09 +00:00
apply (cinit lift: caps_' receiver_' info_' receiveBuffer_' endpoint_'
2015-11-16 03:12:37 +00:00
simp: getThreadCSpaceRoot_def locateSlot_conv whileAnno_def)
2014-07-14 19:32:44 +00:00
apply csymbr+
apply (rule_tac P="?P" and P'="{s. info_' s = info}" in ccorres_inst)
apply (cases "receiveBuffer = None")
apply (clarsimp simp: option_to_0_def getReceiveSlots_def
2016-04-18 20:25:44 +00:00
simp del: Collect_const)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_guard_imp2)
apply (rule ccorres_move_const_guards)+
2016-04-18 20:25:44 +00:00
apply (simp (no_asm))
2014-07-14 19:32:44 +00:00
apply (rule_tac R'=UNIV in ccorres_split_throws [OF ccorres_return_C], simp_all)[1]
apply vcg
apply simp
apply (simp add: message_info_to_H_def word_sless_def word_sle_def)
apply (cases "caps = []")
apply (clarsimp simp: interpret_excaps_test_null excaps_map_def
2016-04-18 20:25:44 +00:00
simp del: Collect_const not_None_eq)
2014-07-14 19:32:44 +00:00
apply (erule notE, rule ccorres_guard_imp2)
apply (rule ccorres_move_const_guards)+
2016-04-18 20:25:44 +00:00
apply (simp (no_asm))
2014-07-14 19:32:44 +00:00
apply (rule ccorres_symb_exec_l)
apply (rule_tac R'=UNIV in ccorres_split_throws [OF ccorres_return_C], simp_all)[1]
apply vcg
apply simp
2017-01-13 12:58:40 +00:00
apply ((wp empty_fail_getReceiveSlots)+)[3]
2014-07-14 19:32:44 +00:00
apply (simp add: message_info_to_H_def word_sless_def word_sle_def)
apply (simp add: option_to_0_def ccorres_cond_iffs
interpret_excaps_test_null excaps_map_def
del: Collect_const
2016-04-18 20:25:44 +00:00
cong: call_ignore_cong)
2014-07-14 19:32:44 +00:00
apply (elim exE)
apply (clarsimp simp: Collect_const[symmetric] Collect_False
signed_shift_guard_simpler_32
simp del: Collect_const
2016-04-18 20:25:44 +00:00
cong: call_ignore_cong)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_guard_imp2)
apply (rule ccorres_move_const_guards)+
apply (simp (no_asm) only: ccorres_seq_cond_empty ccorres_seq_skip)
apply (ctac add: getReceiveSlots_ccorres)
apply (elim conjE)
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_add_return2)
apply (rule ccorres_split_nothrow_novcg)
apply (rule ccorres_Catch)
apply (rule_tac caps=caps and caps'=capsa in transferCapsLoop_ccorres, simp+)
apply (simp add: excaps_map_def)
apply ceqv
apply csymbr
apply (rule ccorres_abstract_cleanup)
apply (rule ccorres_return_C, simp+)[1]
apply wp
apply (simp add: guard_is_UNIV_def)
2016-10-25 06:01:30 +00:00
apply (clarsimp simp: message_info_to_H_def split: if_split)
2014-07-14 19:32:44 +00:00
apply (erule notE, (rule sym)?, rule less_mask_eq)
apply (simp add: minus_one_helper5)
apply (subgoal_tac "rv \<noteq> [0]")
apply simp
apply vcg
apply clarsimp
apply (rule conseqPre, vcg, clarsimp)
apply (simp add: o_def pred_conj_def)
apply (strengthen cte_wp_at_imp_consequent')
apply wp
2016-10-25 06:01:30 +00:00
apply (simp only: mem_simps simp_thms split: if_split)
2014-07-14 19:32:44 +00:00
apply (vcg exspec=getReceiveSlots_modifies)
apply (clarsimp simp: message_info_to_H_def excaps_in_mem_def
slotcap_in_mem_def split_def cte_wp_at_ctes_of
word_sless_def word_sle_def)
2014-09-10 07:26:44 +00:00
apply fastforce
2014-07-14 19:32:44 +00:00
apply clarsimp
done
(* FIXME: move *)
lemma getMessageInfo_le3:
"\<lbrace>\<top>\<rbrace> getMessageInfo sender \<lbrace>\<lambda>rv s. unat (msgExtraCaps rv) \<le> 3\<rbrace>"
2017-01-13 12:58:40 +00:00
including no_pre
2014-07-14 19:32:44 +00:00
apply (simp add: getMessageInfo_def)
apply wp
apply (rule_tac Q="\<lambda>_. \<top>" in hoare_strengthen_post)
apply wp
apply (simp add: messageInfoFromWord_def Let_def msgExtraCapBits_def)
apply (cut_tac y="r >> Types_H.msgLengthBits" in word_and_le1 [where a=3])
apply (simp add: word_le_nat_alt)
2017-01-13 12:58:40 +00:00
done
2014-07-14 19:32:44 +00:00
lemma getMessageInfo_msgLength:
"\<lbrace>\<top>\<rbrace> getMessageInfo sender \<lbrace>\<lambda>rv. K (unat (msgLength rv) \<le> msgMaxLength)\<rbrace>"
2017-01-13 12:58:40 +00:00
including no_pre
2014-07-14 19:32:44 +00:00
apply (simp add: getMessageInfo_def)
apply wp
apply (rule_tac Q="\<lambda>_. \<top>" in hoare_strengthen_post)
apply wp
2015-11-16 03:12:37 +00:00
apply (simp add: messageInfoFromWord_def Let_def not_less msgMaxLength_def msgLengthBits_def
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
apply (cut_tac y="r" in word_and_le1 [where a="0x7F"])
apply (simp add: word_le_nat_alt)
2015-11-16 03:12:37 +00:00
done
2014-07-14 19:32:44 +00:00
definition
2016-01-08 07:43:33 +00:00
mi_from_H :: "Types_H.message_info \<Rightarrow> seL4_MessageInfo_CL"
2014-07-14 19:32:44 +00:00
where
"mi_from_H mi \<equiv>
2016-01-08 07:43:33 +00:00
\<lparr> label_CL = msgLabel mi,
capsUnwrapped_CL = msgCapsUnwrapped mi,
extraCaps_CL = msgExtraCaps mi,
length_CL = msgLength mi \<rparr>"
2014-07-14 19:32:44 +00:00
lemma ccorres_add_returnOk2:
"ccorres_underlying rf_sr G r xf arrel axf P P' hs (a >>=E returnOk) c
\<Longrightarrow> ccorres_underlying rf_sr G r xf arrel axf P P' hs a c"
2016-04-18 20:25:44 +00:00
by (rule ccorres_add_returnOk)
2014-07-14 19:32:44 +00:00
lemma capFaultOnFailure_ccorres:
"ccorres (f \<currency> r) xf P P' hs a c
\<Longrightarrow> ccorres ((\<lambda>x y z. \<exists>w. x = CapFault addr b w \<and> f w y z) \<currency> r)
xf P P' hs
(capFaultOnFailure addr b a) c"
apply (simp add: capFault_injection injection_handler_liftM)
apply (erule ccorres_rel_imp)
apply (auto split: sum.split)
done
definition
2017-05-02 01:12:26 +00:00
"cfault_rel2 \<equiv> \<lambda>ft exnvar err. exnvar = (scast EXCEPTION_FAULT :: word32) \<and>
2014-07-14 19:32:44 +00:00
cfault_rel (Some ft) (errfault err) (errlookup_fault err)"
lemma takeWhile_eq:
"\<lbrakk> \<And>m. \<lbrakk> m < length ys \<rbrakk> \<Longrightarrow> P (xs ! m);
length ys < length xs \<Longrightarrow> \<not> P (xs ! length ys);
length ys \<le> length xs;
\<And>m. m < length ys \<Longrightarrow> xs ! m = ys ! m \<rbrakk>
\<Longrightarrow> takeWhile P xs = ys"
proof (induct xs arbitrary: n ys)
case Nil
thus ?case by simp
next
case (Cons x xs' ys')
have P: "\<And>v m. \<lbrakk> (x # xs') ! m = v; m < length ys' \<rbrakk>
\<Longrightarrow> P v"
using Cons.prems by clarsimp
show ?case using Cons.prems(2-3)
apply simp
apply (cases ys')
apply simp
2015-05-20 10:39:47 +00:00
apply (subst P[where m1=0])
2014-07-14 19:32:44 +00:00
apply simp+
apply (rule conjI)
2015-05-20 10:39:47 +00:00
apply (cut_tac m1=0 in Cons.prems(4), simp+)
2014-07-14 19:32:44 +00:00
apply (rule Cons.hyps)
2015-05-20 10:39:47 +00:00
apply (rule_tac m1="Suc m" in P, simp+)
apply (cut_tac m1="Suc m" in Cons.prems(4), simp+)
2014-07-14 19:32:44 +00:00
done
qed
2015-12-08 06:29:42 +00:00
lemma ccorres_sequenceE_while':
fixes axf :: "globals myvars \<Rightarrow> 'e" shows
"\<lbrakk>\<And>ys. length ys < length xs \<Longrightarrow>
ccorres_underlying sr \<Gamma> (inr_rrel (\<lambda>rv rv'. r' (ys @ [rv]) rv')) xf'
(inl_rrel arrel) axf
(F (length ys)) (Q \<inter> {s. i_' s = of_nat (length ys) \<and> r' ys (xf' s)}) hs
(xs ! length ys) body;
\<And>n. P n = (n < of_nat (length xs));
\<And>s. s \<in> Q \<Longrightarrow> \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {s} body (Q \<inter> {t. i_' t = i_' s}),UNIV;
\<And>n. n < length xs \<Longrightarrow> \<lbrace>F n\<rbrace> xs ! n \<lbrace>\<lambda>_. F (Suc n)\<rbrace>, -;
length xs < 2 ^ word_bits;
\<forall>s f. xf' (i_'_update f s) = xf' s
\<and> ((i_'_update f s \<in> Q) = (s \<in> Q))
\<and> (\<forall>s'. ((s', i_'_update f s) \<in> sr) = ((s', s) \<in> sr)) \<rbrakk>
\<Longrightarrow> ccorres_underlying sr \<Gamma> (inr_rrel (\<lambda>rv (i', rv'). r' rv rv' \<and> i' = of_nat (length xs)))
(\<lambda>s. (i_' s, xf' s)) arrel axf
(F 0) (Q \<inter> {s. r' [] (xf' s)}) hs
(sequenceE xs)
(Basic (\<lambda>s. i_'_update (\<lambda>_. 0) s) ;;
While {s. P (i_' s)} (body;;
Basic (\<lambda>s. i_'_update (\<lambda>_. i_' s + 1) s)))"
apply (rule ccorres_guard_imp2)
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_sequenceE_while_gen'[where i=0, simplified, where xf_update=i_'_update],
(assumption | simp)+)
apply (simp add: word_bits_def)
apply simp+
apply vcg
apply (rule conseqPre, vcg)
apply clarsimp
apply simp
done
2014-07-14 19:32:44 +00:00
lemma lookupExtraCaps_ccorres:
2016-04-30 06:31:11 +00:00
notes if_cong[cong] nat_min_simps [simp del]
2014-07-14 19:32:44 +00:00
shows
"ccorres
((\<lambda>ft _ err.
cfault_rel (Some ft) (errfault err) (errlookup_fault err))
\<currency> (\<lambda>xs ys. interpret_excaps ys = excaps_map xs))
(liftxf errstate fst snd
(\<lambda>s. (ret__unsigned_long_' s, current_extra_caps_' (globals s))))
2015-11-16 03:12:37 +00:00
(valid_pspace' and tcb_at' thread
and (case buffer of Some x\<Rightarrow> valid_ipc_buffer_ptr' x | _ \<Rightarrow> \<top>)
2014-07-14 19:32:44 +00:00
and (\<lambda>s. unat (msgExtraCaps info) <= 3))
(UNIV \<inter> {s. thread_' s = tcb_ptr_to_ctcb_ptr thread}
\<inter> {s. bufferPtr_' s = option_to_ptr buffer}
2016-01-08 07:43:33 +00:00
\<inter> {s. seL4_MessageInfo_lift (info_' s) = mi_from_H info
2014-07-14 19:32:44 +00:00
}) []
(lookupExtraCaps thread buffer info) (Call lookupExtraCaps_'proc)"
proof -
let ?curr = "\<lambda>s. current_extra_caps_' (globals s)"
let ?EXCNONE = "{s. ret__unsigned_long_' s = scast EXCEPTION_NONE}"
let ?interpret = "\<lambda>v n. take n (array_to_list (excaprefs_C v))"
2016-10-25 06:01:30 +00:00
note if_split[split del]
2014-07-14 19:32:44 +00:00
show ?thesis
apply (rule ccorres_gen_asm)+
apply (cinit(no_subst_asm) lift: thread_' bufferPtr_' info_' simp: whileAnno_def)
apply (clarsimp simp add: getExtraCPtrs_def lookupCapAndSlot_def
capFault_bindE
simp del: Collect_const)
apply (simp add: liftE_bindE del: Collect_const)
apply wpc
2015-05-20 10:39:47 +00:00
apply (rename_tac word1 word2 word3 word4)
2014-07-14 19:32:44 +00:00
apply (simp del: Collect_const)
apply wpc
apply (simp add: option_to_ptr_def option_to_0_def)
apply (rule ccorres_rhs_assoc2, rule ccorres_split_throws)
apply (rule ccorres_from_vcg_throws[where P=\<top> and P'=UNIV])
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp simp: returnOk_def return_def)
apply (simp add: excaps_map_def)
apply (subst interpret_excaps_test_null[where n=0, simplified, symmetric])
apply (simp add: word_sle_def word_sless_def)
apply vcg
apply (simp add: id_def[symmetric] del: Collect_const)
apply (rule ccorres_symb_exec_r)
apply (simp add: option_to_ptr_def option_to_0_def Collect_False
ccorres_cond_iffs
del: Collect_const)
apply csymbr
apply (rename_tac "lngth")
apply (simp add: mi_from_H_def mapME_def del: Collect_const cong: bind_apply_cong)
apply (rule ccorres_symb_exec_l)
apply (rule_tac P="length rv = unat word2" in ccorres_gen_asm)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_add_returnOk2,
rule ccorres_splitE_novcg)
apply (rule_tac xf'="?curr"
and r'="\<lambda>xs v. excaps_map xs = ?interpret v (length xs)"
and Q="UNIV"
and F="\<lambda>n s. valid_pspace' s \<and> tcb_at' thread s \<and>
2015-11-16 03:12:37 +00:00
(case buffer of Some x \<Rightarrow> valid_ipc_buffer_ptr' x | _ \<Rightarrow> \<top>) s \<and>
2014-07-14 19:32:44 +00:00
(\<forall>m < length rv. user_word_at (rv ! m)
2014-09-10 07:26:44 +00:00
(x2 + (of_nat m + (msgMaxLength + 2)) * 4) s)"
2015-12-08 06:29:42 +00:00
in ccorres_sequenceE_while')
2014-07-14 19:32:44 +00:00
apply (simp add: split_def)
apply (rule ccorres_rhs_assoc)+
apply (rule ccorres_guard_imp2)
apply (rule ccorres_symb_exec_r)
apply (rule_tac xf'=cptr_' in ccorres_abstract, ceqv)
apply (ctac add: capFaultOnFailure_ccorres
[OF lookupSlotForThread_ccorres'])
apply (rule_tac P="is_aligned rva 4" in ccorres_gen_asm)
apply (simp add: ccorres_cond_iffs liftE_bindE)
apply (rule ccorres_symb_exec_l [OF _ _ _ empty_fail_getSlotCap])
apply (rule_tac P'="UNIV \<inter> {s. excaps_map ys
= ?interpret (?curr s) (length ys)}
\<inter> {s. i_' s = of_nat (length ys)}"
in ccorres_from_vcg[where P=\<top>])
apply (rule allI, rule conseqPre, vcg)
apply (simp add: returnOk_liftE)
apply (clarsimp simp: Bex_def in_monad)
apply (clarsimp simp: excaps_map_def array_to_list_def
lookupSlot_raw_rel_def)
apply (subgoal_tac "length ys < 3")
apply (simp add: take_Suc_conv_app_nth take_map
unat_of_nat32[unfolded word_bits_conv]
word_of_nat_less)
apply (simp add: word_less_nat_alt)
2017-01-13 12:58:40 +00:00
apply wp+
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: ccorres_cond_iffs)
apply (rule_tac P= \<top>
and P'="{x. errstate x= lu_ret___struct_lookupSlot_raw_ret_C \<and>
rv' = (rv ! length ys)}"
in ccorres_from_vcg_throws)
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp simp: throwError_def return_def)
apply (frule lookup_failure_rel_fault_lift, assumption)
apply (clarsimp simp: cfault_rel2_def)
apply (clarsimp simp: cfault_rel_def)
2016-11-10 04:44:36 +00:00
apply (simp add: seL4_Fault_CapFault_lift)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: is_cap_fault_def to_bool_def false_def)
apply wp
apply (rule hoare_post_imp_R, rule lsft_real_cte)
apply (clarsimp simp: obj_at'_def projectKOs objBits_simps)
apply (vcg exspec=lookupSlot_modifies)
apply vcg
apply (rule conseqPre, vcg)
apply clarsimp
apply (clarsimp simp: valid_pspace'_def)
apply (drule spec, drule(1) mp)
apply (drule(1) user_word_at_cross_over [OF _ _ refl])
apply (simp add: field_simps msgMaxLength_def
seL4_MsgLengthBits_def
2015-01-09 21:34:52 +00:00
seL4_MsgMaxLength_def
2014-07-14 19:32:44 +00:00
msgLengthBits_def)
2015-11-16 03:12:37 +00:00
apply (subst valid_ipc_buffer_ptr_array, simp+,
simp add: msg_align_bits unat_word_ariths unat_of_nat,
simp add: msg_align_bits unat_word_ariths unat_of_nat)+
apply clarsimp
2014-07-14 19:32:44 +00:00
apply simp
apply (rule conseqPre)
apply (vcg exspec=lookupSlot_modifies)
apply clarsimp
apply (simp add: split_def)
apply (rule hoare_pre, wp)
apply simp
apply (simp add: word_less_nat_alt word_bits_def)
apply simp
apply (rule ceqv_tuple2)
apply ceqv
apply ceqv
apply (simp del: Collect_const)
apply (rule_tac P'="{s. snd rv'=?curr s}"
and P="\<lambda>s. length rva = length rv
\<and> (\<forall>x \<in> set rva. snd x \<noteq> 0)"
in ccorres_from_vcg_throws)
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp simp: returnOk_def return_def
seL4_MsgExtraCapBits_def)
apply (simp add: word_sle_def interpret_excaps_def
excaps_map_def)
apply (rule conjI)
apply (clarsimp simp: array_to_list_def)
apply (rule takeWhile_eq, simp_all)[1]
apply (drule_tac f="\<lambda>xs. xs ! m" in arg_cong)
apply (clarsimp simp: split_def NULL_ptr_val[symmetric])
2014-09-10 07:26:44 +00:00
apply (simp add: word_less_nat_alt min.absorb2)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: array_to_list_def)
apply (rule takeWhile_eq, simp_all)[1]
apply (drule_tac f="\<lambda>xs. xs ! m" in arg_cong)
apply (clarsimp simp: split_def NULL_ptr_val[symmetric])
2014-09-10 07:26:44 +00:00
apply (simp add: min.absorb1 word_less_nat_alt)
2014-07-14 19:32:44 +00:00
apply simp
apply (simp add: mapME_def[symmetric] split_def
liftE_bindE[symmetric])
apply (wp mapME_length mapME_set | simp)+
apply (rule_tac Q'="\<lambda>rv. no_0_obj' and real_cte_at' rv"
in hoare_post_imp_R, wp lsft_real_cte)
apply (clarsimp simp: cte_wp_at_ctes_of)
2017-03-13 16:37:32 +00:00
apply (wpsimp)+
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: guard_is_UNIV_def
elim!: inl_inrE)
apply (rule hoare_pre, (wp mapM_wp' | simp)+)
apply (rule mapM_loadWordUser_user_words_at)
apply simp
apply vcg
apply (rule conseqPre, vcg, clarsimp)
apply clarsimp
apply (rule conjI)
apply (clarsimp simp add: valid_pspace'_def)
apply (simp add: upto_enum_step_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2015-09-30 18:05:05 +00:00
apply (simp add: word_size upto_enum_word field_simps wordSize_def'
2014-07-14 19:32:44 +00:00
del: upt.simps)
2015-11-16 03:12:37 +00:00
apply (clarsimp simp: excaps_map_def option_to_ptr_def option_to_0_def
valid_ipc_buffer_ptr'_def)
2014-07-14 19:32:44 +00:00
done
qed
lemma interpret_excaps_empty:
"(interpret_excaps caps = []) = (index (excaprefs_C caps) 0 = NULL)"
by (simp add: interpret_excaps_test_null)
lemma getSlotCap_slotcap_in_mem:
"\<lbrace>\<top>\<rbrace> getSlotCap slot \<lbrace>\<lambda>cap s. slotcap_in_mem cap slot (ctes_of s)\<rbrace>"
apply (simp add: getSlotCap_def)
apply (wp getCTE_wp')
apply (clarsimp simp: cte_wp_at_ctes_of slotcap_in_mem_def)
done
lemma lookupExtraCaps_excaps_in_mem[wp]:
"\<lbrace>\<top>\<rbrace> lookupExtraCaps thread buffer info \<lbrace>\<lambda>rv s. excaps_in_mem rv (ctes_of s)\<rbrace>,-"
apply (simp add: excaps_in_mem_def lookupExtraCaps_def lookupCapAndSlot_def
split_def)
apply (wp mapME_set)
2017-03-13 16:37:32 +00:00
apply (wpsimp wp: getSlotCap_slotcap_in_mem)+
2014-07-14 19:32:44 +00:00
done
lemma doNormalTransfer_ccorres [corres]:
"ccorres dc xfdc
(valid_pspace' and cur_tcb' and tcb_at' sender
and tcb_at' receiver
and K (endpoint \<noteq> Some 0)
2014-08-09 05:16:17 +00:00
and (case_option \<top> valid_ipc_buffer_ptr' sendBuffer)
and (case_option \<top> valid_ipc_buffer_ptr' receiveBuffer))
2014-07-14 19:32:44 +00:00
(UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
\<inter> \<lbrace>\<acute>sendBuffer = Ptr (option_to_0 sendBuffer)\<rbrace>
\<inter> \<lbrace>\<acute>receiveBuffer = Ptr (option_to_0 receiveBuffer)\<rbrace>
\<inter> \<lbrace>canGrant = to_bool \<acute>canGrant\<rbrace>
\<inter> \<lbrace>\<acute>badge = badge\<rbrace>
2016-02-10 03:11:09 +00:00
\<inter> \<lbrace>\<acute>endpoint = option_to_ptr endpoint\<rbrace>) []
2014-07-14 19:32:44 +00:00
(doNormalTransfer sender sendBuffer endpoint badge canGrant
2016-02-10 03:11:09 +00:00
receiver receiveBuffer)
2014-07-14 19:32:44 +00:00
(Call doNormalTransfer_'proc)"
proof -
2016-10-25 06:01:30 +00:00
note if_split[split del]
2014-07-14 19:32:44 +00:00
have word_0_le_helper:
"\<And>i :: sword32. \<lbrakk> i <s (1 << unat (scast seL4_MsgExtraCapBits :: word32)) - 1; 0 <=s i \<rbrakk>
\<Longrightarrow> 0 <=s i + 1"
apply (simp add: seL4_MsgExtraCapBits_def word_sle_msb_le
word_sless_msb_less msb_nth)
apply (clarsimp simp: word_eq_iff)
apply (drule bang_is_le)
apply unat_arith
done
show ?thesis
apply (cinit lift: sender_' receiver_' sendBuffer_' receiveBuffer_'
2016-02-10 03:11:09 +00:00
canGrant_' badge_' endpoint_'
2014-07-14 19:32:44 +00:00
cong: call_ignore_cong)
apply (clarsimp cong: call_ignore_cong simp del: dc_simp)
apply (ctac(c_lines 2, no_vcg) add: getMessageInfo_ccorres')
apply (rule_tac xf'=caps_' and r'="\<lambda>c c'. interpret_excaps c' = excaps_map c"
in ccorres_split_nothrow_novcg)
apply (rule ccorres_if_lhs)
apply (simp add: catch_def to_bool_def ccorres_cond_iffs)
apply (rule ccorres_rhs_assoc)+
apply (rule_tac xf'="\<lambda>s. (status_' s,
current_extra_caps_' (globals s))"
and ef'=fst and vf'=snd and es=errstate
2014-08-09 05:16:17 +00:00
in ccorres_split_nothrow_case_sum)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_call, rule lookupExtraCaps_ccorres, simp+)
apply (rule ceqv_tuple2, ceqv, ceqv)
apply (simp add: ccorres_cond_iffs)
apply (rule ccorres_from_vcg[where P=\<top> and P'=UNIV])
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp simp: return_def)
apply (simp add: ccorres_cond_iffs)
apply (rule ccorres_from_vcg[where P=\<top> and P'=UNIV])
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp simp: return_def excaps_map_def interpret_excaps_empty
word_sless_def word_sle_def)
apply wp
apply simp
apply (vcg exspec=lookupExtraCaps_modifies)
apply (simp add: to_bool_def ccorres_cond_iffs)
apply (rule ccorres_from_vcg[where P=\<top> and P'=UNIV])
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp simp: return_def excaps_map_def interpret_excaps_empty
word_sle_def word_sless_def)
apply ceqv
apply csymbr
apply (ctac(no_vcg) add: copyMRs_ccorres)
apply (ctac(no_vcg) add: transferCaps_ccorres)
apply csymbr
2017-05-02 01:12:26 +00:00
apply (ctac(c_lines 2, no_vcg) add: setMessageInfo_ccorres)
2014-07-14 19:32:44 +00:00
apply ctac
apply wp
2016-05-01 03:35:49 +00:00
apply (clarsimp simp: Kernel_C.badgeRegister_def ARM_H.badgeRegister_def
2016-05-05 22:59:33 +00:00
ARM.badgeRegister_def Kernel_C.R0_def)
2014-07-14 19:32:44 +00:00
apply wp
apply simp
2014-08-09 05:16:17 +00:00
apply (wp hoare_case_option_wp getMessageInfo_le3
2014-07-14 19:32:44 +00:00
getMessageInfo_msgLength lookupExtraCaps_excaps_in_mem
lookupExtraCaps_length
| simp)+
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
2016-01-08 07:43:33 +00:00
apply (clarsimp simp: seL4_MessageInfo_lift_def message_info_to_H_def mask_def
2014-07-14 19:32:44 +00:00
msgLengthBits_def word_bw_assocs)
apply (wp getMessageInfo_le3 getMessageInfo_msgLength[unfolded K_def] static_imp_wp
| simp)+
apply (simp add: Collect_const_mem)
apply (auto simp: excaps_in_mem_def valid_ipc_buffer_ptr'_def
option_to_0_def option_to_ptr_def
2016-01-08 07:43:33 +00:00
seL4_MessageInfo_lift_def mi_from_H_def message_info_to_H_def
2014-07-14 19:32:44 +00:00
split: option.split)
done
qed
lemma lookupIPCBuffer_not_Some_0:
"\<lbrace>\<top>\<rbrace> lookupIPCBuffer r t \<lbrace>\<lambda>rv. K (rv \<noteq> Some 0)\<rbrace>"
2016-05-01 03:35:49 +00:00
apply (simp add: lookupIPCBuffer_def ARM_H.lookupIPCBuffer_def)
2017-05-02 01:12:26 +00:00
apply (wp hoare_post_taut haskell_assert_wp
2016-07-04 07:35:42 +00:00
| simp add: Let_def getThreadBufferSlot_def locateSlotTCB_def
| intro conjI impI | wpc)+
2014-07-14 19:32:44 +00:00
done
lemma pageBitsForSize_2 [simp]:
"2 \<le> pageBitsForSize sz"
by (cases sz, auto)
lemma pbfs_msg_align_bits [simp]:
"msg_align_bits \<le> pageBitsForSize sz"
by (cases sz, auto simp: msg_align_bits)
lemma lookupIPCBuffer_aligned:
2014-08-09 05:16:17 +00:00
"\<lbrace>valid_objs'\<rbrace> lookupIPCBuffer r t \<lbrace>\<lambda>rv. K (case_option True (\<lambda>x. is_aligned x msg_align_bits) rv)\<rbrace>"
2017-05-02 01:12:26 +00:00
apply (simp add: lookupIPCBuffer_def ARM_H.lookupIPCBuffer_def
2015-11-16 03:12:37 +00:00
getThreadBufferSlot_def locateSlot_conv
2014-07-14 19:32:44 +00:00
Let_def getSlotCap_def cong: if_cong)
2016-07-04 07:35:42 +00:00
apply (rule hoare_pre)
apply (wp getCTE_wp' threadGet_wp | wpc)+
2014-07-14 19:32:44 +00:00
apply clarsimp
apply (drule (1) ctes_of_valid)
apply (drule (1) ko_at_valid_objs', simp add: projectKOs)
apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def valid_obj'_def valid_tcb'_def)
apply (auto elim: aligned_add_aligned intro: is_aligned_andI1)
done
lemma isArchPageCap_def2:
"\<And>cap. isArchPageCap cap = (isArchObjectCap cap \<and> isPageCap (capCap cap))"
by (fastforce simp: isCap_simps)
2016-07-04 07:35:42 +00:00
lemma replyFromKernel_error_ccorres [corres]:
"ccorres dc xfdc (valid_pspace' and tcb_at' thread)
(UNIV \<inter> \<lbrace>syscall_error_to_H \<acute>current_syscall_error
(lookup_fault_lift \<acute>current_lookup_fault)
= Some err\<rbrace>
2014-07-14 19:32:44 +00:00
\<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>) hs
2016-07-04 07:35:42 +00:00
(replyFromKernel thread (msgFromSyscallError err))
(Call replyFromKernel_error_'proc)"
apply (cinit lift: thread_')
apply clarsimp
apply wpc
apply (ctac add: lookupIPCBuffer_ccorres)
apply simp
apply ctac
apply (ctac add: setMRs_syscall_error_ccorres[where err=err])
apply ((rule ccorres_Guard_Seq)+)?
apply csymbr
apply (rule ccorres_abstract_cleanup)
apply (fold dc_def)[1]
apply (rule setMessageInfo_ccorres)
apply wp
apply (simp add: Collect_const_mem)
apply (vcg exspec=setMRs_syscall_error_modifies)
apply (wp hoare_case_option_wp)
apply (vcg exspec=setRegister_modifies)
apply simp
apply (wp lookupIPCBuffer_aligned_option_to_0)
apply (simp del: Collect_const)
apply (vcg exspec=lookupIPCBuffer_modifies)
2017-05-02 01:12:26 +00:00
apply (simp add: msgInfoRegister_def
2016-07-04 07:35:42 +00:00
Kernel_C.msgInfoRegister_def Kernel_C.R1_def
2016-09-22 09:12:33 +00:00
ARM_H.badgeRegister_def ARM.badgeRegister_def
2016-07-04 07:35:42 +00:00
Kernel_C.badgeRegister_def Kernel_C.R0_def
message_info_to_H_def valid_pspace_valid_objs')
apply (clarsimp simp: msgLengthBits_def msgFromSyscallError_def
syscall_error_to_H_def syscall_error_type_defs
mask_def true_def option_to_ptr_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2014-07-14 19:32:44 +00:00
done
lemma fault_to_fault_tag_nonzero:
"fault_to_fault_tag f \<noteq> 0"
2016-11-10 04:44:36 +00:00
apply (case_tac f; simp add: seL4_Fault_tag_defs)
apply (rename_tac af)
apply (case_tac af; simp add: seL4_Fault_tag_defs)
done
2014-07-14 19:32:44 +00:00
lemma doIPCTransfer_ccorres [corres]:
"ccorres dc xfdc
(valid_pspace' and cur_tcb' and tcb_at' sender and tcb_at' receiver
and K (receiver \<noteq> sender \<and> endpoint \<noteq> Some 0))
(UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
\<inter> \<lbrace>canGrant = to_bool \<acute>grant\<rbrace>
\<inter> \<lbrace>\<acute>badge = badge\<rbrace>
2016-02-10 03:11:09 +00:00
\<inter> \<lbrace>\<acute>endpoint = option_to_ptr endpoint\<rbrace>) []
(doIPCTransfer sender endpoint badge canGrant receiver)
2014-07-14 19:32:44 +00:00
(Call doIPCTransfer_'proc)"
2016-02-10 03:11:09 +00:00
apply (cinit lift: sender_' receiver_' grant_' badge_' endpoint_')
2014-07-14 19:32:44 +00:00
apply (rule_tac xf'="\<lambda>s. ptr_coerce (receiveBuffer___ptr_to_void_' s)"
in ccorres_split_nothrow_call_novcg)
apply (rule lookupIPCBuffer_ccorres)
apply simp_all[3]
apply ceqv
apply (rule ccorres_pre_threadGet)
apply (rename_tac fault)
apply (rule ccorres_move_c_guard_tcb)
2016-11-10 04:44:36 +00:00
apply (rule_tac val="case_option (scast seL4_Fault_NullFault) fault_to_fault_tag fault"
2015-12-08 06:29:42 +00:00
and xf'=ret__unsigned_'
2014-07-14 19:32:44 +00:00
and R="\<lambda>s. \<exists>t. ko_at' t sender s \<and> tcbFault t = fault"
in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
apply (vcg, clarsimp)
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
apply (fastforce simp: ctcb_relation_def typ_heap_simps
2016-11-10 04:44:36 +00:00
cfault_rel_def seL4_Fault_lift_def Let_def
2016-10-25 06:01:30 +00:00
split: if_split_asm option.split)
2014-07-14 19:32:44 +00:00
apply ceqv
apply wpc
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: seL4_Fault_NullFault_def ccorres_cond_univ_iff)
2014-07-14 19:32:44 +00:00
apply (rule_tac xf'="ptr_coerce \<circ> sendBuffer___ptr_to_void_'"
in ccorres_split_nothrow_call_novcg)
apply (rule lookupIPCBuffer_ccorres)
apply simp_all[3]
apply ceqv
apply (fold dc_def)[1]
apply ctac
apply (wp lookupIPCBuffer_not_Some_0 lookupIPCBuffer_aligned)
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: seL4_Fault_NullFault_def ccorres_cond_iffs
2014-07-14 19:32:44 +00:00
fault_to_fault_tag_nonzero)
apply (fold dc_def)[1]
apply ctac
2016-07-04 07:35:42 +00:00
apply (clarsimp simp: guard_is_UNIV_def false_def option_to_ptr_def split: option.splits)
2014-07-14 19:32:44 +00:00
apply (rule_tac Q="\<lambda>rv. valid_pspace' and cur_tcb' and tcb_at' sender
and tcb_at' receiver and K (rv \<noteq> Some 0)
2014-08-09 05:16:17 +00:00
and (case_option \<top> valid_ipc_buffer_ptr' rv)
2014-07-14 19:32:44 +00:00
and K (receiver \<noteq> sender \<and> endpoint \<noteq> Some 0)"
in hoare_post_imp)
apply (auto simp: valid_ipc_buffer_ptr'_def option_to_0_def
split: option.splits)[1]
apply (wp lookupIPCBuffer_not_Some_0 lookupIPCBuffer_aligned)
apply (auto simp: to_bool_def true_def)
done
lemma fault_case_absorb_bind:
2014-09-10 07:26:44 +00:00
"(do x \<leftarrow> f; case_fault (p x) (q x) (r x) (s x) ft od)
2016-11-10 04:44:36 +00:00
= case_fault (\<lambda>a b. f >>= (\<lambda>x. p x a b)) (\<lambda>a b c. f >>= (\<lambda>x. q x a b c))
(\<lambda>a. f >>= (\<lambda>x. r x a)) (\<lambda>a. f >>= (\<lambda>x. s x a)) ft"
2014-07-14 19:32:44 +00:00
by (simp split: fault.split)
lemma length_exceptionMessage:
2016-05-01 03:35:49 +00:00
"length ARM_H.exceptionMessage = unat n_exceptionMessage"
2016-05-05 22:59:33 +00:00
by (simp add: ARM_H.exceptionMessage_def ARM.exceptionMessage_def n_exceptionMessage_def)
2014-07-14 19:32:44 +00:00
2017-05-02 01:12:26 +00:00
lemma Arch_getSanitiseRegisterInfo_ccorres:
"ccorres (op = \<circ> from_bool) ret__unsigned_long_'
(\<top>)
(UNIV \<inter> {s. thread_' s = tcb_ptr_to_ctcb_ptr r}) hs
(getSanitiseRegisterInfo r)
(Call Arch_getSanitiseRegisterInfo_'proc)"
apply (cinit' lift: thread_' simp: getSanitiseRegisterInfo_def)
apply (rule ccorres_return_C, simp+)
apply (clarsimp simp: false_def)
done
2016-11-10 04:44:36 +00:00
lemma copyMRsFaultReply_ccorres_exception:
"ccorres dc xfdc
(valid_pspace' and tcb_at' s
2017-05-02 01:12:26 +00:00
and tcb_at' r
2016-11-10 04:44:36 +00:00
and obj_at' (\<lambda>t. tcbFault t = Some f) r
and K (r \<noteq> s)
and K (len \<le> unat n_exceptionMessage))
(UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr s\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr r\<rbrace>
\<inter> \<lbrace>\<acute>id___anonymous_enum = MessageID_Exception \<rbrace>
\<inter> \<lbrace>\<acute>length___unsigned_long = of_nat len \<rbrace>) hs
2017-05-02 01:12:26 +00:00
(do t \<leftarrow> getSanitiseRegisterInfo r;
zipWithM_x (\<lambda>rs rd. do v \<leftarrow> asUser s (getRegister rs);
2017-02-06 07:33:39 +00:00
asUser r (setRegister rd (ARM_H.sanitiseRegister t rd v))
2016-11-10 04:44:36 +00:00
od)
2017-05-02 01:12:26 +00:00
ARM_H.msgRegisters (take len ARM_H.exceptionMessage)
od)
2016-11-10 04:44:36 +00:00
(Call copyMRsFaultReply_'proc)"
proof -
show ?thesis
apply (unfold K_def, rule ccorres_gen_asm)
apply (cinit' lift: sender_' receiver_'
id___anonymous_enum_'
length___unsigned_long_'
simp: whileAnno_def)
2017-05-02 01:12:26 +00:00
apply (ctac(no_vcg) add: Arch_getSanitiseRegisterInfo_ccorres)
2016-11-10 04:44:36 +00:00
apply (rule ccorres_rhs_assoc2)
apply (simp add: MessageID_Exception_def)
apply ccorres_rewrite
apply (subst bind_return_unit)
apply (rule ccorres_split_nothrow_novcg)
apply (rule ccorres_zipWithM_x_while)
apply clarsimp
apply (intro ccorres_rhs_assoc)
apply (rule ccorres_symb_exec_r)
apply ctac
apply (rule ccorres_symb_exec_r)
apply ctac
apply vcg
apply (rule conseqPre, vcg)
apply fastforce
apply wp
apply vcg
apply vcg
apply (rule conjI, simp add: ARM_H.exceptionMessage_def
ARM.exceptionMessage_def word_of_nat_less)
apply (simp add: msgRegisters_ccorres n_msgRegisters_def length_msgRegisters
unat_of_nat exceptionMessage_ccorres[symmetric,simplified MessageID_Exception_def,simplified]
2017-02-06 07:33:39 +00:00
n_exceptionMessage_def length_exceptionMessage sanitiseRegister_def)
2016-11-10 04:44:36 +00:00
apply (simp add: word_less_nat_alt unat_of_nat)
apply (rule conseqPre, vcg)
apply (clarsimp simp: word_of_nat_less ARM_H.exceptionMessage_def
ARM.exceptionMessage_def)
apply (simp add: min_def length_msgRegisters)
apply (clarsimp simp: min_def n_exceptionMessage_def
ARM_H.exceptionMessage_def
ARM.exceptionMessage_def
length_msgRegisters n_msgRegisters_def
message_info_to_H_def word_of_nat_less
2016-10-25 06:01:30 +00:00
split: if_split)
2016-11-10 04:44:36 +00:00
apply (fastforce dest!: le_antisym)
apply clarsimp
apply (vcg spec=TrueI)
apply clarsimp
apply wp
2017-01-27 03:38:22 +00:00
apply simp+
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: ARM_H.exceptionMessage_def
ARM.exceptionMessage_def
word_bits_def)
apply unat_arith
apply ceqv
apply (simp add: length_exceptionMessage
length_msgRegisters
n_exceptionMessage_def
msgMaxLength_def
n_msgRegisters_def
of_nat_less_iff)
apply ccorres_rewrite
apply (rule ccorres_return_Skip[simplified dc_def])
apply (wp mapM_wp')
apply clarsimp+
apply (clarsimp simp: guard_is_UNIV_def message_info_to_H_def
Collect_const_mem
2016-10-25 06:01:30 +00:00
split: if_split)
2017-05-02 01:12:26 +00:00
apply wpsimp+
2016-11-10 04:44:36 +00:00
done
qed
lemma valid_drop_case: "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. P' rv s\<rbrace> \<rbrakk>
\<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. case rv of None \<Rightarrow> True | Some x \<Rightarrow> P' rv s\<rbrace>"
apply (simp only: valid_def Ball_def split: prod.split)
apply (rule allI impI)+
apply (case_tac x1)
apply simp+
done
lemma copyMRsFaultReply_ccorres_syscall:
fixes word_size :: "'a::len"
shows "ccorres dc xfdc
(valid_pspace' and tcb_at' s
2017-05-02 01:12:26 +00:00
and tcb_at' r
2016-11-10 04:44:36 +00:00
and obj_at' (\<lambda>t. tcbFault t = Some f) r
and K (r \<noteq> s)
and K (len \<le> unat n_syscallMessage))
(UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr s\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr r\<rbrace>
\<inter> \<lbrace>\<acute>id___anonymous_enum = MessageID_Syscall \<rbrace>
\<inter> \<lbrace>\<acute>length___unsigned_long = of_nat len \<rbrace>) hs
2017-05-02 01:12:26 +00:00
(do t \<leftarrow> getSanitiseRegisterInfo r;
a \<leftarrow> zipWithM_x (\<lambda>rs rd. do v \<leftarrow> asUser s (getRegister rs);
2017-02-06 07:33:39 +00:00
asUser r (setRegister rd (ARM_H.sanitiseRegister t rd v))
2016-11-10 04:44:36 +00:00
od)
ARM_H.msgRegisters (take len ARM_H.syscallMessage);
sendBuf \<leftarrow> lookupIPCBuffer False s;
case sendBuf of None \<Rightarrow> return ()
2017-05-02 01:12:26 +00:00
| Some bufferPtr \<Rightarrow>
2016-11-10 04:44:36 +00:00
zipWithM_x (\<lambda>i rd. do v \<leftarrow> loadWordUser (bufferPtr + i * 4);
2017-02-06 07:33:39 +00:00
asUser r (setRegister rd (ARM_H.sanitiseRegister t rd v))
2016-11-10 04:44:36 +00:00
od)
[scast n_msgRegisters + 1.e.scast n_syscallMessage]
(drop (unat (scast n_msgRegisters :: word32))
(take len ARM_H.syscallMessage))
od)
(Call copyMRsFaultReply_'proc)"
proof -
let ?obj_at_ft = "obj_at' (\<lambda>tcb. tcbFault tcb = Some f) s"
note symb_exec_r_fault = ccorres_symb_exec_r_known_rv_UNIV
[where xf'=ret__unsigned_' and R="?obj_at_ft" and R'=UNIV]
show ?thesis
apply (unfold K_def, rule ccorres_gen_asm)
apply (cinit' lift: sender_' receiver_'
id___anonymous_enum_'
length___unsigned_long_'
simp: whileAnno_def)
2017-05-02 01:12:26 +00:00
apply (ctac(no_vcg) add: Arch_getSanitiseRegisterInfo_ccorres)
2016-11-10 04:44:36 +00:00
apply (rule ccorres_rhs_assoc2)
apply (simp add: MessageID_Syscall_def)
apply ccorres_rewrite
apply (rule ccorres_split_nothrow_novcg)
apply (rule ccorres_zipWithM_x_while)
apply clarsimp
apply (intro ccorres_rhs_assoc)
apply (rule ccorres_symb_exec_r)
apply ctac
apply (rule ccorres_symb_exec_r)
apply ctac
apply vcg
apply (rule conseqPre, vcg)
apply fastforce
apply wp
apply vcg
apply vcg
apply (rule conjI, simp add: ARM_H.syscallMessage_def
ARM.syscallMessage_def word_of_nat_less
unat_of_nat msgRegisters_ccorres n_msgRegisters_def
length_msgRegisters)
apply (simp add: msgRegisters_ccorres n_msgRegisters_def length_msgRegisters unat_of_nat
syscallMessage_ccorres[symmetric,simplified MessageID_Syscall_def,simplified]
2017-02-06 07:33:39 +00:00
n_syscallMessage_def length_syscallMessage sanitiseRegister_def)
2016-11-10 04:44:36 +00:00
apply (simp add: word_less_nat_alt unat_of_nat)
apply (rule conseqPre, vcg)
apply (clarsimp simp: word_of_nat_less syscallMessage_unfold length_msgRegisters
n_syscallMessage_def n_msgRegisters_def)
apply (simp add: min_def length_msgRegisters)
apply (clarsimp simp: min_def n_syscallMessage_def
length_msgRegisters n_msgRegisters_def
length_syscallMessage
message_info_to_H_def word_of_nat_less
2016-10-25 06:01:30 +00:00
split: if_split)
2016-11-10 04:44:36 +00:00
apply (simp add: word_less_nat_alt unat_of_nat not_le)
apply clarsimp
apply (vcg spec=TrueI)
apply clarsimp
apply wp
2017-01-27 03:38:22 +00:00
apply simp+
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: length_syscallMessage
length_msgRegisters
n_msgRegisters_def n_syscallMessage_def
word_bits_def min_def
2016-10-25 06:01:30 +00:00
split: if_split)
2016-11-10 04:44:36 +00:00
apply ceqv
apply (rule_tac P'="if 4 < len then _ else _" in ccorres_inst)
2017-01-27 03:38:22 +00:00
apply (cases "4 < len" ; simp)
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: unat_ucast_less_no_overflow n_syscallMessage_def
length_syscallMessage msgRegisters_unfold
word_of_nat_less unat_of_nat unat_less_helper)
apply ccorres_rewrite
apply (ctac(no_vcg))
apply (rename_tac sb sb')
apply wpc
apply (simp add: option_to_0_def ccorres_cond_iffs option_to_ptr_def)
apply (rule ccorres_return_Skip')
2017-02-06 07:33:39 +00:00
apply (rule_tac P="sb \<noteq> Some 0" in ccorres_gen_asm)
apply (rule_tac P="case_option True (\<lambda>x. is_aligned x msg_align_bits) sb"
in ccorres_gen_asm)
apply (simp add: option_to_0_def option_to_ptr_def)
apply (subgoal_tac "sb'\<noteq> NULL") prefer 2
apply clarsimp
apply (simp add: ccorres_cond_iffs)
apply (subst ccorres_seq_skip' [symmetric])
apply (rule_tac r'="\<lambda>rv rv'. rv' = of_nat (unat n_msgRegisters) + _" in ccorres_rel_imp)
apply (drule_tac s="sb" in sym)
apply (simp only: zipWithM_x_mapM_x)
apply ccorres_rewrite
apply (rule_tac F="\<lambda>_. valid_pspace'
and (case sb of None \<Rightarrow> \<top>
| Some x \<Rightarrow> valid_ipc_buffer_ptr' x)
and tcb_at' r"
in ccorres_mapM_x_while')
apply clarsimp
apply (rule ccorres_guard_imp2)
apply (rule ccorres_pre_loadWordUser)
apply (intro ccorres_rhs_assoc)
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_move_array_assertion_ipc_buffer
ccorres_Guard_Seq[where S="{s. h_t_valid (htd s) c_guard (ptr s)}" for ptr htd])+
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_symb_exec_r)
apply ctac
apply vcg
apply (rule conseqPre, vcg)
apply fastforce
apply vcg
apply (rule conseqPre, vcg)
apply clarsimp
apply vcg
apply (rule conseqPre, vcg)
apply clarsimp
2016-11-10 04:44:36 +00:00
apply clarsimp
2017-02-06 07:33:39 +00:00
apply (subst aligned_add_aligned, assumption)
apply (rule is_aligned_mult_triv2[where n=2, simplified])
apply (simp add: msg_align_bits)
apply (simp add: of_nat_unat[simplified comp_def])
apply (simp only: n_msgRegisters_def)
apply (clarsimp simp: n_syscallMessage_def n_msgRegisters_def
word_unat.Rep_inverse[of "scast _ :: 'a word"]
msgRegisters_ccorres[symmetric]
length_msgRegisters[symmetric]
syscallMessage_ccorres[symmetric]
length_msgRegisters length_syscallMessage
syscallMessage_ccorres[symmetric, simplified MessageID_Syscall_def, simplified]
unat_of_nat32 word_bits_def
MessageID_Syscall_def
min_def message_info_to_H_def
upto_enum_def typ_heap_simps'
unat_add_lem[THEN iffD1]
msg_align_bits sanitiseRegister_def
simp del: upt_rec_numeral,
simp_all add: word_less_nat_alt unat_add_lem[THEN iffD1] unat_of_nat)[1]
apply (clarsimp simp: n_syscallMessage_def n_msgRegisters_def
msgRegisters_ccorres
syscallMessage_ccorres
length_syscallMessage length_msgRegisters
message_info_to_H_def min_def
split: if_split)
apply (fastforce dest!: le_antisym)
apply (vcg spec=TrueI)
2016-11-10 04:44:36 +00:00
apply clarsimp
2017-02-06 07:33:39 +00:00
apply (simp add: split_def)
apply (wp hoare_case_option_wp)
apply (fastforce elim: aligned_add_aligned
intro: is_aligned_mult_triv2 [where n=2,simplified]
simp: word_bits_def msg_align_bits)
apply (clarsimp simp: msgRegisters_unfold
n_msgRegisters_def
word_bits_def not_less)
apply (simp add: n_syscallMessage_def)
apply simp
2016-11-10 04:44:36 +00:00
apply (subst option.split[symmetric,where P=id, simplified])
apply (rule valid_drop_case)
2017-02-06 07:33:39 +00:00
apply (wp hoare_drop_imps hoare_vcg_all_lift lookupIPCBuffer_aligned[simplified K_def]
lookupIPCBuffer_not_Some_0[simplified K_def])
2016-11-10 04:44:36 +00:00
apply (simp add: length_syscallMessage
length_msgRegisters
n_syscallMessage_def
msgMaxLength_def
n_msgRegisters_def
of_nat_less_iff)
apply (rule_tac P'="{s. i_' s = of_nat len}" in ccorres_inst)
apply ccorres_rewrite
apply (rule ccorres_guard_imp)
apply (rule ccorres_symb_exec_l)
2017-05-02 01:12:26 +00:00
apply (case_tac rva; clarsimp)
2016-11-10 04:44:36 +00:00
apply (rule ccorres_return_Skip[simplified dc_def])+
2017-02-06 07:33:39 +00:00
apply (wp mapM_x_wp_inv user_getreg_inv'
| clarsimp simp: zipWithM_x_mapM_x split: prod.split)+
2016-11-10 04:44:36 +00:00
apply (cases "4 < len")
2017-05-02 01:12:26 +00:00
apply ((fastforce simp: guard_is_UNIV_def
2016-11-10 04:44:36 +00:00
msgRegisters_unfold
syscallMessage_unfold
n_syscallMessage_def
2017-01-27 03:38:22 +00:00
n_msgRegisters_def
2017-05-02 01:12:26 +00:00
intro: obj_tcb_at')+)[2]
apply wpsimp+
2016-11-10 04:44:36 +00:00
done
qed
lemma handleArchFaultReply_corres:
"ccorres (\<lambda>rv rv'. rv = to_bool rv') ret__unsigned_long_'
(valid_pspace' and tcb_at' sender
and tcb_at' receiver
and K (f = ArchFault af)
and K (sender \<noteq> receiver))
(UNIV \<inter> \<lbrace> \<acute>faultType = fault_to_fault_tag f \<rbrace>
\<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>)
hs
(handleArchFaultReply' af sender receiver msg)
(Call Arch_handleFaultReply_'proc)"
apply (unfold K_def)
apply (rule ccorres_gen_asm)+
apply (cinit lift: faultType_' sender_' receiver_')
apply (clarsimp simp: bind_assoc seL4_Fault_tag_defs ccorres_cond_iffs
2016-10-25 06:01:30 +00:00
split del: if_split split: arch_fault.split)
2016-11-10 04:44:36 +00:00
apply (rule ccorres_symb_exec_l)
apply (rule ccorres_stateAssert)
apply wpc
apply (clarsimp simp: ccorres_cond_iffs)
apply (rule ccorres_return_C)
apply simp+
apply (rule ccorres_symb_exec_l)
apply (ctac add: ccorres_return_C)
apply (wp mapM_wp' empty_fail_loadWordUser | clarsimp simp: to_bool_def true_def)+
done
(* MOVE *)
lemma monadic_rewrite_ccorres_assemble_nodrop:
assumes cc: "ccorres_underlying sr G r xf ar axf (P and Q) P' hs f c"
assumes mr: "monadic_rewrite True False Q g f"
shows "ccorres_underlying sr G r xf ar axf (P and Q) P' hs g c"
proof -
have snd: "\<And>s. \<lbrakk> Q s; \<not> snd (g s) \<rbrakk> \<Longrightarrow> \<not> snd (f s)"
using mr
by (simp add: monadic_rewrite_def)
have fst: "\<And>s v. \<lbrakk> Q s; \<not> snd (g s); v \<in> fst (f s) \<rbrakk> \<Longrightarrow> v \<in> fst (g s)"
using mr
by (auto simp add: monadic_rewrite_def)
show ?thesis
apply (rule ccorresI')
apply (erule ccorresE[OF cc], (simp add: snd)+)
apply clarsimp
apply (rule rev_bexI[OF fst], assumption+)
apply simp
done
qed
schematic_goal arch_fault_to_fault_tag_range:
"arch_fault_to_fault_tag x \<in> ?X"
by (case_tac x, fastforce simp: seL4_Fault_VMFault_def)
2014-07-14 19:32:44 +00:00
lemma handleFaultReply_ccorres [corres]:
"ccorres (\<lambda>rv rv'. rv = to_bool rv') ret__unsigned_long_'
2016-11-10 04:44:36 +00:00
(valid_pspace' and obj_at' (\<lambda>t. tcbFault t = Some f) r
and (tcb_at' s and tcb_at' r)
and K (r \<noteq> s))
2014-07-14 19:32:44 +00:00
(UNIV \<inter> \<lbrace>cfault_rel (Some f)
2016-11-10 04:44:36 +00:00
(seL4_Fault_lift (h_val (hrs_mem \<acute>t_hrs)
2014-07-14 19:32:44 +00:00
(Ptr &(tcb_ptr_to_ctcb_ptr r\<rightarrow>[''tcbFault_C'']))))
(lookup_fault_lift (h_val (hrs_mem \<acute>t_hrs)
(Ptr &(tcb_ptr_to_ctcb_ptr r\<rightarrow>[''tcbLookupFailure_C'']))))\<rbrace>
\<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr s\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr r\<rbrace>) hs
(do
tag \<leftarrow> getMessageInfo s;
sb \<leftarrow> lookupIPCBuffer False s;
msg \<leftarrow> getMRs s sb tag;
handleFaultReply f r (msgLabel tag) msg
od) (Call handleFaultReply_'proc)"
apply (unfold K_def, rule ccorres_gen_asm)
2016-11-10 04:44:36 +00:00
apply (rule monadic_rewrite_ccorres_assemble_nodrop[OF _ handleFaultReply',rotated], simp)
2014-07-14 19:32:44 +00:00
apply (cinit lift: sender_' receiver_' simp: whileAnno_def)
apply (clarsimp simp del: dc_simp)
apply (ctac(c_lines 2) add: getMessageInfo_ccorres')
apply (rename_tac tag tag')
apply csymbr
apply csymbr
apply (rule ccorres_move_c_guard_tcb)
apply (rule ccorres_symb_exec_r)
apply (rule_tac val="fault_to_fault_tag f"
2015-12-08 06:29:42 +00:00
and xf'=ret__unsigned_'
2014-07-14 19:32:44 +00:00
and R="\<lambda>s. \<exists>t. ko_at' t r s \<and> tcbFault t = Some f"
2016-11-10 04:44:36 +00:00
and R'="\<lbrace>cfault_rel (Some f) (seL4_Fault_lift \<acute>fault)
2014-07-14 19:32:44 +00:00
(lookup_fault_lift (h_val (hrs_mem \<acute>t_hrs)
(Ptr &(tcb_ptr_to_ctcb_ptr r\<rightarrow>[''tcbLookupFailure_C'']))))\<rbrace>"
2016-11-10 04:44:36 +00:00
in ccorres_symb_exec_r_known_rv)
2014-07-14 19:32:44 +00:00
apply (rule conseqPre, vcg, clarsimp)
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
apply (clarsimp simp: ctcb_relation_def typ_heap_simps
2016-11-10 04:44:36 +00:00
cfault_rel_def seL4_Fault_lift_def Let_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2014-07-14 19:32:44 +00:00
apply ceqv
apply (simp add: handleFaultReply_def fault_case_absorb_bind
2016-10-25 06:01:30 +00:00
del: Collect_const split del: if_split)
2014-07-14 19:32:44 +00:00
apply wpc
2016-11-10 04:44:36 +00:00
(* UserException *)
2014-07-14 19:32:44 +00:00
apply (rename_tac number code)
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: bind_assoc seL4_Fault_tag_defs ccorres_cond_iffs
2016-10-25 06:01:30 +00:00
split del: if_split)
2017-02-06 07:33:39 +00:00
apply (subst take_min_len[symmetric,where n="unat (msgLength _)"])
2017-05-02 01:12:26 +00:00
apply (simp add: bind_assoc[symmetric])
2017-02-06 07:33:39 +00:00
apply (ctac add: copyMRsFaultReply_ccorres_exception)
apply (ctac add: ccorres_return_C)
apply wp
apply (vcg exspec=copyMRsFaultReply_modifies)
apply (wpsimp wp: threadGet_wp)+
2016-11-10 04:44:36 +00:00
(* CapFault *)
apply (clarsimp simp: bind_assoc seL4_Fault_tag_defs ccorres_cond_iffs
2016-10-25 06:01:30 +00:00
split del: if_split)
2016-11-10 04:44:36 +00:00
apply (ctac add: ccorres_return_C)
(* UnknowSyscall *)
apply (rename_tac number)
apply (clarsimp simp: seL4_Fault_tag_defs ccorres_cond_iffs
2016-10-25 06:01:30 +00:00
split del: if_split)
2017-02-06 07:33:39 +00:00
apply (subst take_min_len[symmetric,where n="unat (msgLength _)"])
apply (subst take_min_len[symmetric,where n="unat (msgLength _)"])
apply (fold bind_assoc id_def)
apply (ctac add: copyMRsFaultReply_ccorres_syscall[simplified bind_assoc[symmetric]])
apply (ctac add: ccorres_return_C)
apply wp
apply (vcg exspec=copyMRsFaultReply_modifies)
apply (wpsimp wp: threadGet_wp)+
2016-11-10 04:44:36 +00:00
(* ArchFault *)
apply (rule ccorres_cond_false)
apply (rule ccorres_cond_false)
apply (rule ccorres_cond_false)
apply (rule ccorres_rhs_assoc)
(* apply (rule_tac P="\<lambda>s. \<exists>t. ko_at' t r s" in ccorres_cross_over_guard) *)
apply (rule_tac val="fault_to_fault_tag f"
and xf'=ret__unsigned_'
and R="\<lambda>s. \<exists>t. ko_at' t r s \<and> tcbFault t = Some f"
and R'="\<lbrace>cfault_rel (Some f) (seL4_Fault_lift \<acute>fault)
(lookup_fault_lift (h_val (hrs_mem \<acute>t_hrs)
(Ptr &(tcb_ptr_to_ctcb_ptr r\<rightarrow>[''tcbLookupFailure_C'']))))\<rbrace>"
in ccorres_symb_exec_r_known_rv_UNIV)
apply (rule conseqPre, vcg, clarsimp)
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
apply (clarsimp simp: ctcb_relation_def typ_heap_simps
cfault_rel_def seL4_Fault_lift_def Let_def
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2016-11-10 04:44:36 +00:00
apply ceqv
apply (rule ccorres_add_return2)
apply (ctac add: handleArchFaultReply_corres)
apply (rule ccorres_return_C)
apply simp+
apply wp
apply (vcg exspec=Arch_handleFaultReply_modifies)
apply (clarsimp simp: guard_is_UNIV_def)
apply (subst fault_to_fault_tag.simps(2))
2016-10-25 06:01:30 +00:00
apply (clarsimp split: if_split)
2016-11-10 04:44:36 +00:00
apply simp+
(* Done *)
apply clarsimp
apply vcg
2014-07-14 19:32:44 +00:00
apply vcg
apply clarsimp
2016-11-10 04:44:36 +00:00
apply vcg_step
apply (clarsimp simp: n_exceptionMessage_def n_syscallMessage_def
message_info_to_H_def to_bool_def scast_def
length_exceptionMessage length_syscallMessage
min_def word_less_nat_alt true_def
guard_is_UNIV_def seL4_Faults seL4_Arch_Faults
2016-10-25 06:01:30 +00:00
split: if_split)
2016-11-10 04:44:36 +00:00
apply (simp add: length_exceptionMessage length_syscallMessage)
2014-07-14 19:32:44 +00:00
apply wp
2016-11-10 04:44:36 +00:00
apply clarsimp
apply (vcg exspec=getRegister_modifies)
apply (clarsimp simp: n_exceptionMessage_def n_syscallMessage_def
message_info_to_H_def to_bool_def scast_def
length_exceptionMessage length_syscallMessage
min_def word_less_nat_alt true_def
obj_at'_def
2016-10-25 06:01:30 +00:00
split: if_split)
2016-11-10 04:44:36 +00:00
using arch_fault_to_fault_tag_range
apply (fastforce simp: seL4_Faults seL4_Arch_Faults)
2014-07-14 19:32:44 +00:00
done
(* FIXME: move *)
2015-11-02 00:00:32 +00:00
lemma cancelAllIPC_sch_act_wf:
2014-07-14 19:32:44 +00:00
"\<lbrace>\<lambda>s. sch_act_wf (ksSchedulerAction s) s\<rbrace>
2015-11-02 00:00:32 +00:00
cancelAllIPC ep
2014-07-14 19:32:44 +00:00
\<lbrace>\<lambda>rv s. sch_act_wf (ksSchedulerAction s) s\<rbrace>"
2015-11-02 00:00:32 +00:00
apply (simp add: cancelAllIPC_def)
2014-07-14 19:32:44 +00:00
apply (rule hoare_TrueI|wp getEndpoint_wp|wpc|simp)+
apply fastforce?
done
(* FIXME: move *)
2015-11-02 00:00:32 +00:00
lemma cancelAllSignals_sch_act_wf:
2014-07-14 19:32:44 +00:00
"\<lbrace>\<lambda>s. sch_act_wf (ksSchedulerAction s) s\<rbrace>
2015-11-02 00:00:32 +00:00
cancelAllSignals ep
2014-07-14 19:32:44 +00:00
\<lbrace>\<lambda>rv s. sch_act_wf (ksSchedulerAction s) s\<rbrace>"
2015-11-02 00:00:32 +00:00
apply (simp add: cancelAllSignals_def)
apply (rule hoare_TrueI|wp getNotification_wp|wpc|simp)+
2014-07-14 19:32:44 +00:00
apply fastforce?
done
(* FIXME: move *)
lemma cteDeleteOne_sch_act_wf:
"\<lbrace>\<lambda>s. sch_act_wf (ksSchedulerAction s) s\<rbrace>
cteDeleteOne slot
\<lbrace>\<lambda>rv s. sch_act_wf (ksSchedulerAction s) s\<rbrace>"
apply (simp add: cteDeleteOne_def unless_when split_def)
apply (simp add: finaliseCapTrue_standin_def Let_def)
2015-09-02 05:43:39 +00:00
apply (rule hoare_pre)
2017-05-02 01:12:26 +00:00
apply (wp isFinalCapability_inv cancelAllSignals_sch_act_wf
2015-11-02 00:00:32 +00:00
cancelAllIPC_sch_act_wf getCTE_wp' static_imp_wp
2015-11-16 03:12:37 +00:00
| wpc
2016-10-25 06:01:30 +00:00
| simp add: Let_def split: if_split)+
2014-07-14 19:32:44 +00:00
done
(* FIXME: move *)
lemma vp_invs_strg': "invs' s \<longrightarrow> valid_pspace' s" by auto
(* FIXME: move *)
lemma setCTE_tcbFault:
"\<lbrace>obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>
2017-05-02 01:12:26 +00:00
setCTE slot cte
2014-07-14 19:32:44 +00:00
\<lbrace>\<lambda>rv. obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>"
apply (simp add: setCTE_def)
apply (rule setObject_cte_obj_at_tcb', simp_all)
done
2016-09-21 00:33:03 +00:00
crunch tcbFault: emptySlot, tcbSchedEnqueue, rescheduleRequired
"obj_at' (\<lambda>tcb. P (tcbFault tcb)) t"
(wp: threadSet_obj_at'_strongish crunch_wps
simp: crunch_simps unless_def)
2014-07-14 19:32:44 +00:00
2015-09-30 18:05:05 +00:00
(* FIXME: move *)
lemmas threadSet_obj_at' = threadSet_obj_at'_strongish
2016-09-21 00:33:03 +00:00
crunch tcbFault: setThreadState, cancelAllIPC, cancelAllSignals
"obj_at' (\<lambda>tcb. P (tcbFault tcb)) t"
(wp: threadSet_obj_at'_strongish crunch_wps)
2014-07-14 19:32:44 +00:00
(* FIXME: move *)
2016-09-21 00:33:03 +00:00
lemmas setEndpoint_tcb = KHeap_R.setEndpoint_obj_at'_tcb
2014-07-14 19:32:44 +00:00
(* FIXME: move *)
2015-11-02 00:00:32 +00:00
lemma setNotification_tcb:
2014-07-14 19:32:44 +00:00
"\<lbrace>obj_at' (\<lambda>tcb::tcb. P tcb) t\<rbrace>
2015-11-02 00:00:32 +00:00
setNotification ntfn e
2014-07-14 19:32:44 +00:00
\<lbrace>\<lambda>_. obj_at' P t\<rbrace>"
2015-11-02 00:00:32 +00:00
apply (simp add: setNotification_def)
2014-07-14 19:32:44 +00:00
apply (rule obj_at_setObject2)
apply (clarsimp simp: updateObject_default_def in_monad)
done
2015-11-02 00:00:32 +00:00
lemma sbn_tcbFault:
2015-09-10 07:06:45 +00:00
"\<lbrace>obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>
2015-11-02 00:00:32 +00:00
setBoundNotification st t'
2015-09-10 07:06:45 +00:00
\<lbrace>\<lambda>_. obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>"
2015-11-02 00:00:32 +00:00
apply (simp add: setBoundNotification_def)
2015-09-10 07:06:45 +00:00
apply (wp threadSet_obj_at' | simp)+
done
2015-11-02 00:00:32 +00:00
crunch tcbFault: unbindNotification, unbindMaybeNotification "obj_at' (\<lambda>tcb. P (tcbFault tcb)) t"
(ignore: threadSet setObject wp: sbn_tcbFault)
2015-09-02 05:43:39 +00:00
2014-07-14 19:32:44 +00:00
(* FIXME: move *)
lemma cteDeleteOne_tcbFault:
"\<lbrace>obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>
cteDeleteOne slot
\<lbrace>\<lambda>_. obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>"
apply (simp add: cteDeleteOne_def unless_when split_def)
apply (simp add: finaliseCapTrue_standin_def Let_def)
2015-09-02 05:43:39 +00:00
apply (rule hoare_pre)
2015-11-02 00:00:32 +00:00
apply (wp emptySlot_tcbFault cancelAllIPC_tcbFault getCTE_wp'
cancelAllSignals_tcbFault unbindNotification_tcbFault
isFinalCapability_inv unbindMaybeNotification_tcbFault
2015-09-02 05:43:39 +00:00
static_imp_wp
| wpc | simp add: Let_def)+
2016-10-25 06:01:30 +00:00
apply (clarsimp split: if_split)
2014-07-14 19:32:44 +00:00
done
2015-07-13 06:17:55 +00:00
lemma transferCapsToSlots_local_slots:
assumes weak: "\<And>c cap. P (maskedAsFull c cap) = P c"
shows
"\<lbrace> cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot and K (slot \<notin> set destSlots) \<rbrace>
2016-02-10 03:11:09 +00:00
transferCapsToSlots ep rcvBuffer x caps destSlots mi
2015-07-13 06:17:55 +00:00
\<lbrace>\<lambda>tag'. cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot\<rbrace>"
proof (rule hoare_gen_asm, induct caps arbitrary: x mi destSlots)
case Nil show ?case by simp
next
case (Cons cp cps)
show ?case using Cons.prems
2016-10-25 06:01:30 +00:00
apply (clarsimp simp: Let_def split del: if_split)
2015-07-13 06:17:55 +00:00
apply (rule hoare_pre)
apply (wp Cons.hyps cteInsert_weak_cte_wp_at2
2016-10-25 06:01:30 +00:00
| wpc | simp add: weak whenE_def split del: if_split)+
2015-07-13 06:17:55 +00:00
done
qed
lemma transferCaps_local_slots:
assumes weak: "\<And>c cap. P (maskedAsFull c cap) = P c"
shows "\<lbrace> valid_objs' and (Not o real_cte_at' slot) and cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot \<rbrace>
2016-02-10 03:11:09 +00:00
transferCaps tag caps ep receiver receiveBuffer
2015-07-13 06:17:55 +00:00
\<lbrace>\<lambda>tag'. cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot\<rbrace>"
apply (simp add: transferCaps_def pred_conj_def)
apply (rule hoare_seq_ext[rotated])
apply (rule hoare_vcg_conj_lift)
apply (rule get_rs_real_cte_at')
apply (rule get_recv_slot_inv')
apply (rule hoare_pre)
apply (wp transferCapsToSlots_local_slots weak | wpc)+
apply clarsimp
done
lemma doNormalTransfer_local_slots:
assumes weak: "\<And>c cap. P (maskedAsFull c cap) = P c"
shows "\<lbrace> valid_objs' and (Not o real_cte_at' slot)
and cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot \<rbrace>
2016-02-10 03:11:09 +00:00
doNormalTransfer sender sendBuffer ep badge grant receiver receiveBuffer
2015-07-13 06:17:55 +00:00
\<lbrace>\<lambda>rv. cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot\<rbrace>"
apply (simp add: doNormalTransfer_def)
apply (wp transferCaps_local_slots weak copyMRs_typ_at'[where T=CTET, unfolded typ_at_cte]
| simp)+
done
lemma doIPCTransfer_local_slots:
assumes weak: "\<And>c cap. P (maskedAsFull c cap) = P c"
shows "\<lbrace> valid_objs' and (Not o real_cte_at' slot)
and cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot \<rbrace>
2016-02-10 03:11:09 +00:00
doIPCTransfer sender ep badge grant receiver
2015-07-13 06:17:55 +00:00
\<lbrace> \<lambda>rv. cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot \<rbrace>"
apply (simp add: doIPCTransfer_def)
apply (wp doNormalTransfer_local_slots weak threadGet_wp | wpc)+
apply simp
done
lemma doIPCTransfer_reply_or_replyslot:
"\<lbrace> cte_wp_at' (\<lambda>cte. isReplyCap (cteCap cte)) slot
or (valid_objs' and (Not o real_cte_at' slot)
and cte_wp_at' (\<lambda>cte. cteCap cte = capability.NullCap \<or> isReplyCap (cteCap cte)) slot)\<rbrace>
2016-02-10 03:11:09 +00:00
doIPCTransfer sender ep badge grant receiver
2015-07-13 06:17:55 +00:00
\<lbrace> \<lambda>rv. cte_wp_at' (\<lambda>cte. cteCap cte = capability.NullCap \<or> isReplyCap (cteCap cte)) slot\<rbrace>"
apply (rule hoare_name_pre_state)
apply (case_tac "cte_wp_at' (\<lambda>cte. isReplyCap (cteCap cte)) slot s")
apply (rule hoare_pre, rule hoare_strengthen_post,
rule_tac P="isReplyCap" and ptr=slot in doIPCTransfer_non_null_cte_wp_at2')
apply (clarsimp simp: isCap_simps)
apply (clarsimp simp: isCap_simps)
apply (clarsimp simp: cte_wp_at_ctes_of)
apply simp
apply (wp doIPCTransfer_local_slots)
2015-11-16 03:12:37 +00:00
apply (clarsimp simp: maskedAsFull_def cap_get_tag_isCap isCap_simps
2016-10-25 06:01:30 +00:00
split: if_split)
2015-07-13 06:17:55 +00:00
apply simp
done
2014-07-14 19:32:44 +00:00
lemma doReplyTransfer_ccorres [corres]:
"ccorres dc xfdc
2015-07-13 06:17:55 +00:00
(invs' and st_tcb_at' (Not \<circ> isReply) sender
2016-11-16 03:02:03 +00:00
and tcb_at' receiver and sch_act_simple
2015-07-13 06:17:55 +00:00
and ((Not o real_cte_at' slot) or cte_wp_at' (\<lambda>cte. isReplyCap (cteCap cte)) slot)
and cte_wp_at' (\<lambda>cte. cteCap cte = capability.NullCap \<or> isReplyCap (cteCap cte))
slot)
2014-07-14 19:32:44 +00:00
(UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
\<inter> \<lbrace>\<acute>slot = Ptr slot\<rbrace>) []
(doReplyTransfer sender receiver slot)
(Call doReplyTransfer_'proc)"
proof -
have invs_valid_queues_strg: "\<And>s. invs' s \<longrightarrow> valid_queues s"
by clarsimp
show ?thesis
apply (cinit lift: sender_' receiver_' slot_')
2017-05-02 01:12:26 +00:00
apply (rule getThreadState_ccorres_foo)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_assert2)
apply (simp add: liftM_def getSlotCap_def
2016-10-25 06:01:30 +00:00
del: Collect_const split del: if_split)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_pre_getCTE)
apply (rule ccorres_assert2)
apply (rule ccorres_pre_getCTE)
apply (rule ccorres_assert2)
apply (rule ccorres_pre_threadGet)
apply (rename_tac fault)
apply (rule ccorres_move_c_guard_tcb)
2016-11-10 04:44:36 +00:00
apply (rule_tac val="case_option (scast seL4_Fault_NullFault) fault_to_fault_tag fault"
2015-12-08 06:29:42 +00:00
and xf'=ret__unsigned_'
2014-07-14 19:32:44 +00:00
and R="\<lambda>s. \<exists>t. ko_at' t receiver s \<and> tcbFault t = fault"
in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
apply (vcg, clarsimp)
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
apply (fastforce simp: ctcb_relation_def typ_heap_simps
2016-11-10 04:44:36 +00:00
cfault_rel_def seL4_Fault_lift_def Let_def
2016-10-25 06:01:30 +00:00
split: if_split_asm option.split)
2014-07-14 19:32:44 +00:00
apply ceqv
apply wpc
2016-10-25 06:01:30 +00:00
apply (clarsimp simp: ccorres_cond_iffs split del: if_split)
2014-07-14 19:32:44 +00:00
apply (fold dc_def)[1]
apply (rule ccorres_rhs_assoc)+
2015-05-22 03:55:35 +00:00
apply (ctac(no_vcg))
apply (rule ccorres_symb_exec_r)
2015-09-10 07:06:45 +00:00
apply (ctac(no_vcg) add: cteDeleteOne_ccorres[where w="scast cap_reply_cap"])
2015-05-22 03:55:35 +00:00
apply (ctac(no_vcg) add: setThreadState_ccorres)
apply (ctac add: attemptSwitchTo_ccorres)
apply (wp sts_running_valid_queues setThreadState_st_tcb | simp)+
apply (wp cteDeleteOne_sch_act_wf)
apply vcg
apply (rule conseqPre, vcg)
apply (simp(no_asm_use) add: gs_set_assn_Delete_cstate_relation[unfolded o_def]
subset_iff rf_sr_def)
apply wp
2015-07-13 06:17:55 +00:00
apply (simp add: cap_get_tag_isCap)
2014-07-14 19:32:44 +00:00
apply (strengthen invs_weak_sch_act_wf_strg
2015-07-13 06:17:55 +00:00
cte_wp_at_imp_consequent'[where P="\<lambda>ct. Ex (ccap_relation (cteCap ct))" for ct]
2014-07-14 19:32:44 +00:00
invs_valid_queues_strg)
2015-07-13 06:17:55 +00:00
apply (simp add: cap_reply_cap_def)
apply (wp doIPCTransfer_reply_or_replyslot)
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: seL4_Fault_NullFault_def ccorres_cond_iffs
2014-07-14 19:32:44 +00:00
fault_to_fault_tag_nonzero
2016-10-25 06:01:30 +00:00
split del: if_split)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_rhs_assoc)+
apply (fold dc_def)[1]
apply csymbr
2015-05-22 03:55:35 +00:00
apply (rule ccorres_symb_exec_r)
2015-09-10 07:06:45 +00:00
apply (ctac (no_vcg) add: cteDeleteOne_ccorres[where w="scast cap_reply_cap"])
2015-05-22 03:55:35 +00:00
apply (rule_tac A'=UNIV in stronger_ccorres_guard_imp)
apply (rule ccorres_split_nothrow_novcg [OF ccorres_call,
OF handleFaultReply_ccorres,
unfolded bind_assoc,
where xf'=restart_'])
apply simp_all[3]
2014-07-14 19:32:44 +00:00
apply ceqv
2016-09-21 00:33:03 +00:00
apply csymbr
2015-05-22 03:55:35 +00:00
apply (rule ccorres_split_nothrow_novcg)
2016-09-21 00:33:03 +00:00
apply (rule threadSet_ccorres_lemma2[where P=\<top>])
apply vcg
apply (clarsimp simp: typ_heap_simps')
apply (erule(1) rf_sr_tcb_update_no_queue2,
(simp add: typ_heap_simps')+, simp_all?)[1]
apply (rule ball_tcb_cte_casesI, simp+)
apply (clarsimp simp: ctcb_relation_def
2016-11-10 04:44:36 +00:00
seL4_Fault_lift_NullFault
2016-09-21 00:33:03 +00:00
cfault_rel_def is_cap_fault_def
cthread_state_relation_def)
apply (case_tac "tcbState tcb", simp_all add: is_cap_fault_def)[1]
2015-05-22 03:55:35 +00:00
apply ceqv
apply (rule_tac R=\<top> in ccorres_cond2)
2015-11-16 03:12:37 +00:00
apply (clarsimp simp: to_bool_def Collect_const_mem)
2015-05-22 03:55:35 +00:00
apply (ctac (no_vcg))
apply (simp only: K_bind_def)
apply (ctac)
apply (wp sts_running_valid_queues setThreadState_st_tcb | simp)+
apply (fold dc_def)[1]
2015-09-10 07:06:45 +00:00
apply (ctac add: setThreadState_ccorres_valid_queues'_simple)
2015-05-22 03:55:35 +00:00
apply ((wp threadSet_valid_queues threadSet_sch_act threadSet_valid_queues' static_imp_wp
threadSet_valid_objs' threadSet_weak_sch_act_wf
| simp add: valid_tcb_state'_def)+)[1]
apply (clarsimp simp: guard_is_UNIV_def ThreadState_Restart_def
ThreadState_Inactive_def mask_def to_bool_def)
apply (rule_tac Q="\<lambda>rv. valid_queues and tcb_at' receiver and valid_queues' and
2016-11-16 03:02:03 +00:00
valid_objs' and sch_act_simple and
2015-05-22 03:55:35 +00:00
(\<lambda>s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp)
2015-09-10 07:06:45 +00:00
apply (clarsimp simp: inQ_def weak_sch_act_wf_def)
2017-05-02 01:12:26 +00:00
apply (wp threadSet_valid_queues threadSet_sch_act handleFaultReply_sch_act_wf)
2015-05-22 03:55:35 +00:00
apply (clarsimp simp: guard_is_UNIV_def)
apply assumption
apply clarsimp
apply (drule_tac p=receiver in obj_at_ko_at')
apply clarsimp
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
apply (clarsimp simp: ctcb_relation_def typ_heap_simps)
2017-05-02 01:12:26 +00:00
apply wp
2015-10-29 00:22:21 +00:00
apply (strengthen vp_invs_strg' invs_valid_queues')
2015-05-22 03:55:35 +00:00
apply (wp cteDeleteOne_tcbFault cteDeleteOne_sch_act_wf)
apply vcg
apply (rule conseqPre, vcg)
apply (simp(no_asm_use) add: gs_set_assn_Delete_cstate_relation[unfolded o_def]
subset_iff rf_sr_def)
2017-05-02 01:12:26 +00:00
apply (clarsimp simp: guard_is_UNIV_def to_bool_def true_def
2014-07-14 19:32:44 +00:00
option_to_ptr_def option_to_0_def false_def
2015-05-22 03:55:35 +00:00
ThreadState_Running_def mask_def
ghost_assertion_data_get_def ghost_assertion_data_set_def
2015-07-13 06:17:55 +00:00
cap_tag_defs
2015-05-22 03:55:35 +00:00
split: option.splits)
2015-09-10 07:06:45 +00:00
apply (clarsimp simp: pred_tcb_at' invs_valid_objs')
apply (clarsimp simp: pred_tcb_at'_def obj_at'_def cte_wp_at_ctes_of
2015-07-13 06:17:55 +00:00
cap_get_tag_isCap)
2014-07-14 19:32:44 +00:00
apply fastforce
done
qed
lemma ccorres_getCTE_cte_at:
"ccorresG rf_sr \<Gamma> r xf P P' hs (getCTE p >>= f) c
\<Longrightarrow> ccorresG rf_sr \<Gamma> r xf (\<lambda>s. cte_at' p s \<longrightarrow> P s) P' hs
(getCTE p >>= f) c"
apply (rule ccorres_guard_imp)
apply (subst gets_bind_ign[where f="cte_at' p", symmetric],
rule ccorres_symb_exec_l[OF _ _ gets_wp])
2014-08-11 08:51:04 +00:00
apply (rule_tac b=x in ccorres_case_bools)
2014-07-14 19:32:44 +00:00
apply assumption
apply (rule ccorres_getCTE)
apply (rule ccorres_False[where P'=UNIV])
apply wp
apply simp
apply (clarsimp simp: cte_wp_at_ctes_of)
apply simp
done
lemma setupCallerCap_ccorres [corres]:
"ccorres dc xfdc (valid_queues and valid_pspace' and (\<lambda>s. \<forall>d p. sender \<notin> set (ksReadyQueues s (d, p)))
and (\<lambda>s. sch_act_wf (ksSchedulerAction s) s) and sch_act_not sender
and tcb_at' sender and tcb_at' receiver
and tcb_at' sender and tcb_at' receiver)
(UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
\<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>) hs
(setupCallerCap sender receiver)
(Call setupCallerCap_'proc)"
apply (rule ccorres_gen_asm_state, rule ccorres_gen_asm_state)
apply (frule_tac p=sender in is_aligned_tcb_ptr_to_ctcb_ptr)
apply (cinit lift: sender_' receiver_')
2015-11-16 03:12:37 +00:00
apply (clarsimp simp: word_sle_def
tcb_cnode_index_defs[THEN ptr_add_assertion_positive[OF ptr_add_assertion_positive_helper]]
, fold dc_def)[1]
apply ccorres_remove_UNIV_guard
2014-07-14 19:32:44 +00:00
apply (ctac(no_vcg))
2015-11-16 03:12:37 +00:00
apply (rule ccorres_move_array_assertion_tcb_ctes)
2014-07-14 19:32:44 +00:00
apply (simp only: getThreadReplySlot_def getThreadCallerSlot_def)
apply (ctac(no_vcg))
apply (rename_tac replySlot replySlot')
apply (simp del: Collect_const)
apply (rule ccorres_getCTE_cte_at)
apply (rule ccorres_move_c_guard_cte)
apply (ctac(no_vcg) add: getSlotCap_h_val_ccorres[unfolded getSlotCap_def fun_app_def,
folded liftM_def, simplified ccorres_liftM_simp])
apply (rule ccorres_assert2)+
2015-11-16 03:12:37 +00:00
apply (simp add: ccorres_seq_skip locateSlot_conv
)
apply (rule ccorres_move_array_assertion_tcb_ctes)
2014-07-14 19:32:44 +00:00
apply csymbr
apply (rule ccorres_getSlotCap_cte_at)
apply (rule ccorres_move_c_guard_cte)
apply (ctac(no_vcg))
apply (rule ccorres_assert)
apply (simp only: ccorres_seq_skip dc_def[symmetric])
apply csymbr
apply (ctac add: cteInsert_ccorres)
apply simp
apply (wp getSlotCap_cte_wp_at)
apply (clarsimp simp: ccap_relation_def cap_lift_reply_cap
cap_to_H_simps cap_reply_cap_lift_def
false_def tcbSlots Kernel_C.tcbCaller_def
size_of_def cte_level_bits_def)
apply (simp add: is_aligned_neg_mask)
apply (wp getCTE_wp')
apply (simp add: tcbSlots Kernel_C.tcbCaller_def
2015-11-16 03:12:37 +00:00
size_of_def cte_level_bits_def
ptr_add_assertion_positive Collect_const_mem
tcb_cnode_index_defs)
2014-07-14 19:32:44 +00:00
apply simp
2015-11-16 03:12:37 +00:00
apply (rule_tac Q="\<lambda>rv. valid_pspace' and tcb_at' receiver" in hoare_post_imp)
2014-07-14 19:32:44 +00:00
apply (auto simp: cte_wp_at_ctes_of isCap_simps
2017-05-02 01:12:26 +00:00
tcbSlots Kernel_C.tcbCaller_def size_of_def
2014-07-14 19:32:44 +00:00
cte_level_bits_def)[1]
apply (case_tac cte,clarsimp)
apply (drule ctes_of_valid_cap')
apply fastforce
apply (simp add:valid_cap'_def capAligned_def)
apply (simp add: locateSlot_conv)
apply wp
apply (clarsimp simp: ccap_rights_relation_def allRights_def
mask_def true_def cap_rights_to_H_def tcbCallerSlot_def
Kernel_C.tcbCaller_def)
apply simp
apply wp
apply (clarsimp simp: Kernel_C.ThreadState_BlockedOnReply_def mask_def
2015-11-16 03:12:37 +00:00
valid_pspace'_def tcbReplySlot_def
valid_tcb_state'_def Collect_const_mem
tcb_cnode_index_defs)
2014-07-14 19:32:44 +00:00
done
lemma sendIPC_dequeue_ccorres_helper:
"ep_ptr = Ptr ep ==>
ccorres (\<lambda>rv rv'. rv' = tcb_ptr_to_ctcb_ptr dest) dest_'
(invs' and st_tcb_at' (\<lambda>st. isBlockedOnReceive st \<and>
2015-11-02 00:00:32 +00:00
blockingObject st = ep) dest
2014-07-14 19:32:44 +00:00
and ko_at' (RecvEP (dest#rest)) ep) UNIV hs
(setEndpoint ep $ case rest of [] \<Rightarrow> Structures_H.IdleEP
| (a#list) \<Rightarrow> Structures_H.RecvEP rest)
(\<acute>queue :== CALL ep_ptr_get_queue(ep_ptr);;
\<acute>dest :== head_C \<acute>queue;;
\<acute>queue :== CALL tcbEPDequeue(\<acute>dest,\<acute>queue);;
CALL ep_ptr_set_queue(ep_ptr,\<acute>queue);;
IF head_C \<acute>queue = Ptr 0 THEN
CALL endpoint_ptr_set_state(ep_ptr,scast EPState_Idle)
FI)"
apply (rule ccorres_from_vcg)
apply (rule allI)
apply (rule conseqPre, vcg)
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split simp del: comp_def)
2015-09-02 05:43:39 +00:00
apply (frule ep_blocked_in_queueD [OF pred_tcb'_weakenE])
2014-07-14 19:32:44 +00:00
apply simp
apply assumption+
apply (frule (1) ko_at_valid_ep' [OF _ invs_valid_objs'])
apply (elim conjE)
apply (frule (1) valid_ep_blockedD)
apply (elim conjE)
apply (frule cmap_relation_ep)
apply (erule (1) cmap_relation_ko_atE)
apply (intro conjI)
apply (erule h_t_valid_clift)
apply (rule impI)
apply (rule exI)
apply (rule conjI)
apply (rule_tac x=\<sigma> in exI)
apply (intro conjI)
apply assumption+
apply (drule (2) ep_to_ep_queue)
apply (simp add: tcb_queue_relation'_def)
apply (clarsimp simp: typ_heap_simps cendpoint_relation_def Let_def
2016-10-25 06:01:30 +00:00
cong: imp_cong split del: if_split simp del: comp_def)
2014-07-14 19:32:44 +00:00
apply (intro conjI impI allI)
apply (fastforce simp: h_t_valid_clift)
apply (fastforce simp: h_t_valid_clift)
-- "empty case"
apply clarsimp
apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
apply (frule iffD1 [OF tcb_queue_head_empty_iff
[OF tcb_queue_relation'_queue_rel]])
apply (rule ballI, erule bspec)
apply (erule subsetD [rotated])
apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
apply simp
apply (simp add: setEndpoint_def split_def)
apply (rule conjI)
apply (rule bexI [OF _ setObject_eq])
apply (simp add: rf_sr_def cstate_relation_def Let_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ep_map_tos
typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (elim conjE)
apply (intro conjI)
-- "tcb relation"
apply (erule ctcb_relation_null_queue_ptrs)
apply (clarsimp simp: comp_def)
-- "ep relation"
apply (rule cpspace_relation_ep_update_ep, assumption+)
apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def
tcb_queue_relation'_def)
apply simp
2015-11-02 00:00:32 +00:00
-- "ntfn relation"
2014-07-14 19:32:44 +00:00
apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
apply simp
2015-11-02 00:00:32 +00:00
apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+)
2014-07-14 19:32:44 +00:00
apply simp
apply (erule (1) map_to_ko_atI')
-- "queue relation"
apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
apply (clarsimp simp: comp_def)
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: cmachine_state_relation_def)
apply (simp add: h_t_valid_clift_Some_iff)
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
-- "non-empty case"
apply clarsimp
apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
apply (frule tcb_queue_head_empty_iff [OF tcb_queue_relation'_queue_rel])
apply (rule ballI, erule bspec)
apply (erule subsetD [rotated])
apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
apply (simp add: setEndpoint_def split_def)
apply (rule conjI)
apply (rule bexI [OF _ setObject_eq])
apply (frule(1) st_tcb_at_h_t_valid)
apply (simp add: rf_sr_def cstate_relation_def Let_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ep_map_tos
typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (elim conjE)
apply (intro conjI)
-- "tcb relation"
apply (erule ctcb_relation_null_queue_ptrs)
apply (clarsimp simp: comp_def)
-- "ep relation"
apply (rule cpspace_relation_ep_update_ep, assumption+)
apply (clarsimp simp: cendpoint_relation_def Let_def
isRecvEP_def isSendEP_def
tcb_queue_relation'_def valid_ep'_def
split: endpoint.splits list.splits
2016-10-25 06:01:30 +00:00
split del: if_split)
2014-09-10 07:26:44 +00:00
apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \<sigma>")
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: is_aligned_neg_mask
dest!: is_aligned_tcb_ptr_to_ctcb_ptr
2016-10-25 06:01:30 +00:00
split del: if_split)
apply (clarsimp split: if_split)
2014-07-14 19:32:44 +00:00
apply simp
2015-11-02 00:00:32 +00:00
-- "ntfn relation"
2014-07-14 19:32:44 +00:00
apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
apply simp
2015-11-02 00:00:32 +00:00
apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+)
2014-07-14 19:32:44 +00:00
apply simp
apply (erule (1) map_to_ko_atI')
-- "queue relation"
apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
apply (clarsimp simp: comp_def)
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: cmachine_state_relation_def)
apply (simp add: h_t_valid_clift_Some_iff)
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
done
2016-09-21 00:33:03 +00:00
lemma rf_sr_tcb_update_twice:
"h_t_valid (hrs_htd hrs) c_guard ptr
2017-05-02 01:12:26 +00:00
\<Longrightarrow> ((s, s'\<lparr>globals := globals s''\<lparr>t_hrs_' :=
2016-09-21 00:33:03 +00:00
hrs_mem_update (heap_update (ptr :: tcb_C ptr) v)
(hrs_mem_update (heap_update ptr v') hrs)\<rparr>\<rparr>) \<in> rf_sr)
2017-05-02 01:12:26 +00:00
= ((s, s'\<lparr>globals := globals s''\<lparr>t_hrs_' :=
2016-09-21 00:33:03 +00:00
hrs_mem_update (heap_update (ptr :: tcb_C ptr) v) hrs\<rparr>\<rparr>) \<in> rf_sr)"
by (simp add: rf_sr_def cstate_relation_def Let_def
cpspace_relation_def typ_heap_simps'
carch_state_relation_def
cmachine_state_relation_def)
2014-07-14 19:32:44 +00:00
lemma sendIPC_block_ccorres_helper:
2017-05-02 01:12:26 +00:00
"ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and
2014-07-14 19:32:44 +00:00
sch_act_not thread and ep_at' epptr and
(\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
(\<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))) and
K (bos = ThreadState_BlockedOnSend
\<and> epptr' = epptr \<and> badge' = badge
\<and> cg = from_bool canGrant \<and> dc' = from_bool do_call) and
K (epptr = epptr && ~~ mask 4) and
K (badge = badge && mask 28))
UNIV hs
(setThreadState (Structures_H.thread_state.BlockedOnSend
epptr badge canGrant do_call) thread)
(Guard C_Guard
\<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
(CALL thread_state_ptr_set_tsType(Ptr
&(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']),
scast bos));;
Guard C_Guard
\<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
2015-11-02 00:00:32 +00:00
(CALL thread_state_ptr_set_blockingObject(Ptr
2014-07-14 19:32:44 +00:00
&(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']), epptr'));;
Guard C_Guard
\<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
(CALL thread_state_ptr_set_blockingIPCBadge(Ptr
&(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']), badge'));;
Guard C_Guard
\<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
(CALL thread_state_ptr_set_blockingIPCCanGrant(Ptr
&(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']), cg));;
Guard C_Guard
\<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
(CALL thread_state_ptr_set_blockingIPCIsCall(Ptr
&(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']), dc'));;
CALL scheduleTCB(tcb_ptr_to_ctcb_ptr thread))"
unfolding K_def setThreadState_def
apply (intro ccorres_gen_asm)
apply (rule ccorres_guard_imp)
apply (rule ccorres_split_nothrow_novcg)
apply (rule_tac P=\<top> and P'="tcb_at' thread"
in threadSet_ccorres_lemma3)
apply vcg
apply clarsimp
apply (frule(1) tcb_at_h_t_valid)
apply (frule h_t_valid_c_guard)
2016-09-21 00:33:03 +00:00
apply (clarsimp simp: typ_heap_simps'
rf_sr_tcb_update_twice)
apply (erule(1) rf_sr_tcb_update_no_queue_gen,
(simp add: typ_heap_simps')+)[1]
2014-07-14 19:32:44 +00:00
apply (simp add: tcb_cte_cases_def)
apply (simp add: ctcb_relation_def cthread_state_relation_def
ThreadState_BlockedOnSend_def mask_def
from_bool_def to_bool_def)
apply (clarsimp split: bool.split)
apply ceqv
apply clarsimp
apply ctac
apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues
threadSet_valid_objs')
apply (clarsimp simp: guard_is_UNIV_def)
apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def
tcb_cte_cases_def)
apply clarsimp
done
lemma tcb_queue_relation_last_not_NULL:
assumes tq: "tcb_queue_relation getNext getPrev mp queue qprev qhead"
and valid_ep: "\<forall>t\<in>set queue. tcb_at' t s" "distinct queue"
and tcbs: "queue \<noteq> []"
shows "tcb_ptr_to_ctcb_ptr (last queue) \<noteq> NULL"
proof -
note last_in_set [where as = queue]
with tq valid_ep(1) show ?thesis
by (rule tcb_queue_relation_not_NULL') fact+
qed
lemma tcb_queue_relation_update_end:
fixes getNext_update :: "(tcb_C ptr \<Rightarrow> tcb_C ptr) \<Rightarrow> tcb_C \<Rightarrow> tcb_C" and
getPrev_update :: "(tcb_C ptr \<Rightarrow> tcb_C ptr) \<Rightarrow> tcb_C \<Rightarrow> tcb_C"
assumes qr: "tcb_queue_relation getNext getPrev mp queue qprev qhead"
and qe: "qend = (if queue = [] then NULL
else tcb_ptr_to_ctcb_ptr (last queue))"
and qe': "qend' \<notin> tcb_ptr_to_ctcb_ptr ` set queue"
and cs_tcb: "mp qend' = Some tcb"
and valid_ep: "\<forall>t\<in>set queue. tcb_at' t s" "distinct queue"
and qeN: "qend' \<noteq> NULL"
and qpN: "queue = [] \<longrightarrow> qprev = NULL"
and fgN: "fg_cons getNext (getNext_update \<circ> (\<lambda>x _. x))"
and fgP: "fg_cons getPrev (getPrev_update \<circ> (\<lambda>x _. x))"
and npu: "\<And>f t. getNext (getPrev_update f t) = getNext t"
and pnu: "\<And>f t. getPrev (getNext_update f t) = getPrev t"
shows "tcb_queue_relation getNext getPrev
(upd_unless_null qend (getNext_update (\<lambda>_. qend') (the (mp qend)))
(mp(qend' := Some (getNext_update (\<lambda>_. NULL) (getPrev_update (\<lambda>_. qend) tcb)))))
(queue @ [ctcb_ptr_to_tcb_ptr qend'])
qprev (if qhead = NULL then qend' else qhead)"
using qr qe qe' cs_tcb valid_ep qeN qpN
proof (induct queue arbitrary: qhead qprev qend)
case Nil
thus ?case
by (clarsimp simp: upd_unless_null_def fg_consD1 [OF fgN]
fg_consD1 [OF fgP] pnu npu)
next
case (Cons tcb' tcbs)
have not_NULL[simplified]: "tcb_ptr_to_ctcb_ptr (last (tcb'#tcbs)) \<noteq> NULL"
"qhead \<noteq> NULL"
using tcb_queue_relation_next_not_NULL tcb_queue_relation_last_not_NULL
Cons tcb_at_not_NULL
2016-10-25 06:01:30 +00:00
by (auto split: if_split)
2014-07-14 19:32:44 +00:00
thus ?case using Cons.prems
apply (clarsimp simp: upd_unless_null_def fg_consD1 [OF fgN]
2015-11-16 03:12:37 +00:00
fg_consD1 [OF fgP] pnu npu
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
apply (rule conjI, clarsimp)
apply (rule impI)
apply (subst tcb_queue_relation_cong)
prefer 5
apply (erule Cons.hyps [OF _ refl], simp_all add: upd_unless_null_def)
apply (frule(3) tcb_queue_relation_next_not_NULL, simp)
done
qed
lemma tcbEPAppend_update:
assumes sr: "ep_queue_relation' mp queue qhead qend"
and qe': "qend' \<notin> tcb_ptr_to_ctcb_ptr ` set queue"
and cs_tcb: "mp qend' = Some tcb"
and valid_ep: "\<forall>t\<in>set queue. tcb_at' t s" "distinct queue"
and qeN: "qend' \<noteq> NULL"
shows "ep_queue_relation'
(upd_unless_null qend (tcbEPNext_C_update (\<lambda>_. qend') (the (mp qend)))
(mp(qend' \<mapsto> tcb\<lparr>tcbEPPrev_C := qend, tcbEPNext_C := NULL\<rparr>)))
(queue @ [ctcb_ptr_to_tcb_ptr qend'])
(if qhead = NULL then qend' else qhead) qend'"
using sr qe' cs_tcb valid_ep qeN
apply -
apply (erule tcb_queue_relationE')
apply (rule tcb_queue_relationI')
apply (erule(6) tcb_queue_relation_update_end
[where getNext_update = tcbEPNext_C_update
and getPrev_update = tcbEPPrev_C_update])
apply simp_all
done
lemma tcb_queue_relation_qend_mem':
"\<lbrakk> tcb_queue_relation' getNext getPrev mp queue qhead qend;
(\<forall>tcb\<in>set queue. tcb_at' tcb t) \<rbrakk>
\<Longrightarrow> qend \<noteq> NULL \<longrightarrow> ctcb_ptr_to_tcb_ptr qend \<in> set queue"
2015-11-16 03:12:37 +00:00
by (clarsimp simp: tcb_queue_head_empty_iff tcb_queue_relation'_def
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
lemma tcb_queue_relation_qend_valid':
"\<lbrakk> tcb_queue_relation' getNext getPrev (cslift s') queue qhead qend;
(s, s') \<in> rf_sr; (\<forall>tcb\<in>set queue. tcb_at' tcb s) \<rbrakk>
\<Longrightarrow> qend \<noteq> NULL \<longrightarrow> s' \<Turnstile>\<^sub>c qend"
apply (frule (1) tcb_queue_relation_qend_mem')
apply clarsimp
apply (drule (3) tcb_queue_memberD [OF tcb_queue_relation'_queue_rel])
apply (simp add: h_t_valid_clift_Some_iff)
done
lemma tcbEPAppend_spec:
"\<forall>s queue. \<Gamma> \<turnstile> \<lbrace>s. \<exists>t. (t, s) \<in> rf_sr
\<and> (\<forall>tcb\<in>set queue. tcb_at' tcb t) \<and> distinct queue
\<and> tcb_at' (ctcb_ptr_to_tcb_ptr \<acute>tcb) t
\<and> (ctcb_ptr_to_tcb_ptr \<acute>tcb \<notin> set queue)
\<and> ep_queue_relation' (cslift s) queue
(head_C \<acute>queue) (end_C \<acute>queue)\<rbrace>
Call tcbEPAppend_'proc
{t. head_C (ret__struct_tcb_queue_C_' t) =
(if head_C \<^bsup>s\<^esup>queue = tcb_Ptr 0
then \<^bsup>s\<^esup>tcb
else head_C \<^bsup>s\<^esup>queue)
\<and> end_C (ret__struct_tcb_queue_C_' t) = \<^bsup>s\<^esup>tcb
\<and> ep_queue_relation' (cslift t)
(queue @ [ctcb_ptr_to_tcb_ptr \<^bsup>s\<^esup>tcb])
(head_C (ret__struct_tcb_queue_C_' t))
(end_C (ret__struct_tcb_queue_C_' t))
\<and> (cslift t |` (- tcb_ptr_to_ctcb_ptr ` set
((ctcb_ptr_to_tcb_ptr \<^bsup>s\<^esup>tcb) # queue))) =
(cslift s |` (- tcb_ptr_to_ctcb_ptr ` set
((ctcb_ptr_to_tcb_ptr \<^bsup>s\<^esup>tcb) # queue)))
\<and> option_map tcb_null_ep_ptrs \<circ> (cslift t) =
option_map tcb_null_ep_ptrs \<circ> (cslift s)
2016-09-21 00:33:03 +00:00
\<and> cslift_all_but_tcb_C t s \<and> (hrs_htd \<^bsup>t\<^esup>t_hrs) = (hrs_htd \<^bsup>s\<^esup>t_hrs)
\<and> (\<forall>rs. zero_ranges_are_zero rs (\<^bsup>s\<^esup>t_hrs)
\<longrightarrow> zero_ranges_are_zero rs (\<^bsup>t\<^esup>t_hrs))}"
2014-07-14 19:32:44 +00:00
apply (intro allI)
apply (rule conseqPre, vcg)
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split)
2014-07-14 19:32:44 +00:00
apply (frule obj_at_ko_at')
apply clarsimp
apply (frule cmap_relation_tcb)
apply (drule (1) cmap_relation_ko_atD)
apply clarsimp
apply (frule c_guard_clift)
apply (frule (1) tcb_queue'_head_end_NULL)
apply (frule (1) tcb_queue_relation_qend_mem')
apply (frule (2) tcb_queue_relation_qend_valid')
apply (subgoal_tac "end_C (queue_' x) \<noteq> tcb_' x")
prefer 2
apply clarsimp
apply (frule tcbEPAppend_update)
apply (erule contrapos_nn, erule tcb_ptr_to_ctcb_ptr_imageD)
apply assumption+
apply (drule tcb_at_not_NULL, simp)
apply (unfold upd_unless_null_def)
2016-10-25 06:01:30 +00:00
apply (clarsimp split: if_split_asm)
2016-09-21 00:33:03 +00:00
apply (simp add: typ_heap_simps')
apply (rule ext)
apply (clarsimp simp add: typ_heap_simps tcb_null_ep_ptrs_def
2016-10-25 06:01:30 +00:00
split: if_split)
2016-09-21 00:33:03 +00:00
apply (simp add: typ_heap_simps')
apply (intro conjI)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp add: typ_heap_simps h_t_valid_clift_Some_iff)
apply (erule iffD1 [OF tcb_queue_relation'_cong, OF refl refl refl, rotated -1])
2016-10-25 06:01:30 +00:00
apply (clarsimp split: if_split)
2014-07-14 19:32:44 +00:00
apply (rule ext)
apply (clarsimp dest!: ctcb_ptr_to_tcb_ptr_imageI simp add: typ_heap_simps h_t_valid_clift_Some_iff)
apply (rule ext)
2015-11-16 03:12:37 +00:00
apply (clarsimp simp add: tcb_null_ep_ptrs_def typ_heap_simps h_t_valid_clift_Some_iff
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
done
(* FIXME: move up to SR_lemmas_C and remove from Retype_C *)
lemma map_to_ko_atI2:
"\<lbrakk>(projectKO_opt \<circ>\<^sub>m (ksPSpace s)) x = Some v; pspace_aligned' s; pspace_distinct' s\<rbrakk> \<Longrightarrow> ko_at' v x s"
apply (clarsimp simp: map_comp_Some_iff)
apply (erule (2) aligned_distinct_obj_atI')
apply (simp add: project_inject)
done
lemma map_to_ko_at_updI':
"\<And>x x' y y' y''.
\<lbrakk> (projectKO_opt \<circ>\<^sub>m (ksPSpace s)) x = Some y;
valid_pspace' s; ko_at' y' x' s;
objBitsKO (injectKO y') = objBitsKO y''; x \<noteq> x' \<rbrakk> \<Longrightarrow>
ko_at' y x (s\<lparr>ksPSpace := ksPSpace s(x' \<mapsto> y'')\<rparr>)"
by (fastforce simp: obj_at'_def projectKOs objBitsKO_def ps_clear_upd
dest: map_to_ko_atI2)
(* FIXME: move *)
lemma state_refs_of'_upd:
"\<lbrakk> valid_pspace' s; ko_wp_at' (\<lambda>ko. objBitsKO ko = objBitsKO ko') ptr s \<rbrakk> \<Longrightarrow>
state_refs_of' (s\<lparr>ksPSpace := ksPSpace s(ptr \<mapsto> ko')\<rparr>) =
(state_refs_of' s)(ptr := refs_of' ko')"
apply (rule ext)
apply (clarsimp simp: ps_clear_upd valid_pspace'_def pspace_aligned'_def
obj_at'_def ko_wp_at'_def state_refs_of'_def
2016-10-25 06:01:30 +00:00
split: option.split if_split)
2014-07-14 19:32:44 +00:00
done
lemma sendIPC_enqueue_ccorres_helper:
"ccorres dc xfdc (valid_pspace'
and (\<lambda>s. sym_refs ((state_refs_of' s)(epptr := set queue \<times> {EPSend})))
and st_tcb_at' (\<lambda>st. isBlockedOnSend st \<and>
2015-11-02 00:00:32 +00:00
blockingObject st = epptr) thread
2014-07-14 19:32:44 +00:00
and ko_at' (ep::Structures_H.endpoint) epptr
and K ((ep = IdleEP \<and> queue = [thread]) \<or>
(\<exists>q. ep = SendEP q \<and> thread \<notin> set q \<and>
queue = q @ [thread])))
UNIV hs
(setEndpoint epptr (Structures_H.endpoint.SendEP queue))
(\<acute>queue :== CALL ep_ptr_get_queue(ep_Ptr epptr);;
(\<acute>queue :== CALL tcbEPAppend(tcb_ptr_to_ctcb_ptr thread,\<acute>queue);;
(CALL endpoint_ptr_set_state(ep_Ptr epptr, scast EPState_Send);;
CALL ep_ptr_set_queue(ep_Ptr epptr,\<acute>queue))))"
unfolding K_def
apply (rule ccorres_gen_asm)
apply (rule ccorres_from_vcg)
apply (rule allI, rule conseqPre, vcg)
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split simp del: comp_def)
2014-07-14 19:32:44 +00:00
apply (frule cmap_relation_ep)
apply (erule (1) cmap_relation_ko_atE)
apply (rule conjI)
apply (erule h_t_valid_clift)
apply (frule(1) st_tcb_at_h_t_valid)
2015-09-02 05:43:39 +00:00
apply (frule pred_tcb_at')
2014-07-14 19:32:44 +00:00
apply (rule impI)
apply (rule_tac x="init queue" in exI)
apply (frule(1) ko_at_valid_ep' [OF _ valid_pspace_valid_objs'])
apply (frule is_aligned_tcb_ptr_to_ctcb_ptr)
apply (rule conjI)
apply (rule_tac x=\<sigma> in exI)
apply (simp add: cendpoint_relation_def Let_def)
apply (case_tac ep, simp_all add: init_def valid_ep'_def)[1]
apply (subgoal_tac "sym_refs (state_refs_of' (\<sigma>\<lparr>ksPSpace :=
ksPSpace \<sigma>(epptr \<mapsto> KOEndpoint (SendEP queue))\<rparr>))")
prefer 2
apply (clarsimp simp: state_refs_of'_upd ko_wp_at'_def
obj_at'_def projectKOs objBitsKO_def)
apply (subgoal_tac "ko_at' (SendEP queue) epptr (\<sigma>\<lparr>ksPSpace :=
ksPSpace \<sigma>(epptr \<mapsto> KOEndpoint (SendEP queue))\<rparr>)")
prefer 2
apply (clarsimp simp: obj_at'_def projectKOs objBitsKO_def ps_clear_upd)
apply (intro conjI impI allI)
apply (fastforce simp: h_t_valid_clift)
apply (fastforce simp: h_t_valid_clift)
apply (case_tac ep, simp_all add: EPState_Idle_def EPState_Send_def)[1]
-- "IdleEP case"
apply clarsimp
apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
apply (simp add: setEndpoint_def split_def)
apply (rule bexI [OF _ setObject_eq])
apply (simp add: rf_sr_def cstate_relation_def init_def Let_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ep_map_tos
typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (elim conjE)
apply (intro conjI)
-- "tcb relation"
apply (erule ctcb_relation_null_queue_ptrs)
apply (clarsimp simp: comp_def)
-- "ep relation"
apply (rule cpspace_relation_ep_update_ep', assumption+)
apply (clarsimp simp: cendpoint_relation_def Let_def
mask_def [where n=2] EPState_Send_def)
apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask)
apply (simp add: isSendEP_def isRecvEP_def)
2015-11-02 00:00:32 +00:00
-- "ntfn relation"
2014-07-14 19:32:44 +00:00
apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
apply simp
2015-11-02 00:00:32 +00:00
apply (rule cnotification_relation_ep_queue, assumption+)
2014-07-14 19:32:44 +00:00
apply (simp add: isSendEP_def isRecvEP_def)
apply simp
apply (frule_tac x=p in map_to_ko_atI2, clarsimp, clarsimp)
apply (erule(2) map_to_ko_at_updI')
apply (simp only:projectKOs injectKO_ep objBits_simps)
apply clarsimp
apply (clarsimp simp: obj_at'_def projectKOs)
-- "queue relation"
apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
apply (clarsimp simp: comp_def)
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: cmachine_state_relation_def)
2016-09-21 00:33:03 +00:00
apply (simp add: typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
-- "SendEP case"
apply clarsimp
apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
apply (simp add: setEndpoint_def split_def)
apply (rule bexI [OF _ setObject_eq])
apply (simp add: rf_sr_def cstate_relation_def Let_def init_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ep_map_tos
typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (elim conjE)
apply (intro conjI)
-- "tcb relation"
apply (erule ctcb_relation_null_queue_ptrs)
apply (clarsimp simp: comp_def)
-- "ep relation"
apply (rule cpspace_relation_ep_update_ep', assumption+)
apply (clarsimp simp: cendpoint_relation_def Let_def
2015-11-16 03:12:37 +00:00
mask_def [where n=2] EPState_Send_def
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask
valid_ep'_def
dest: tcb_queue_relation_next_not_NULL)
apply (simp add: isSendEP_def isRecvEP_def)
2015-11-02 00:00:32 +00:00
-- "ntfn relation"
2014-07-14 19:32:44 +00:00
apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
apply simp
2015-11-02 00:00:32 +00:00
apply (rule cnotification_relation_ep_queue, assumption+)
2014-07-14 19:32:44 +00:00
apply (simp add: isSendEP_def isRecvEP_def)
apply simp
apply (frule_tac x=p in map_to_ko_atI2, clarsimp, clarsimp)
apply (erule(2) map_to_ko_at_updI')
apply (clarsimp simp: objBitsKO_def)
apply (clarsimp simp: obj_at'_def projectKOs)
-- "queue relation"
apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
apply (clarsimp simp: comp_def)
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: cmachine_state_relation_def)
apply (simp add: h_t_valid_clift_Some_iff)
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
done
lemmas attemptSwitchTo_sch_act_not
= possibleSwitchTo_sch_act_not[where b=True, folded attemptSwitchTo_def]
lemma sendIPC_ccorres [corres]:
"ccorres dc xfdc (invs' and st_tcb_at' simple' thread
and sch_act_not thread and ep_at' epptr and
(\<lambda>s. \<forall>d p. thread \<notin> set (ksReadyQueues s (d, p))))
(UNIV \<inter> \<lbrace>\<acute>blocking = from_bool blocking\<rbrace>
\<inter> \<lbrace>\<acute>do_call = from_bool do_call\<rbrace>
\<inter> \<lbrace>\<acute>badge = badge\<rbrace>
\<inter> \<lbrace>\<acute>canGrant = from_bool canGrant\<rbrace>
\<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>
\<inter> \<lbrace>\<acute>epptr = Ptr epptr\<rbrace>
\<inter> \<lbrace>badge && mask 28 = badge\<rbrace>) hs
(sendIPC blocking do_call badge canGrant thread epptr)
(Call sendIPC_'proc)"
unfolding K_def
apply (rule ccorres_gen_asm2)
apply (cinit' lift: blocking_' do_call_' badge_' canGrant_' thread_' epptr_')
apply (unfold sendIPC_def)[1]
apply (rule ccorres_pre_getEndpoint)
apply (rename_tac ep)
2015-12-08 06:29:42 +00:00
apply (rule_tac xf'=ret__unsigned_'
2014-07-14 19:32:44 +00:00
and val="case ep of IdleEP \<Rightarrow> scast EPState_Idle
2015-09-02 05:43:39 +00:00
| RecvEP _ \<Rightarrow> scast EPState_Recv
| SendEP _ \<Rightarrow> scast EPState_Send"
2014-07-14 19:32:44 +00:00
and R="ko_at' ep epptr"
in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
apply (vcg, clarsimp)
apply (erule cmap_relationE1 [OF cmap_relation_ep])
apply (erule ko_at_projectKO_opt)
apply (clarsimp simp: typ_heap_simps cendpoint_relation_def Let_def
split: endpoint.split_asm)
apply ceqv
apply (rule_tac A="invs' and st_tcb_at' simple' thread
and sch_act_not thread and ko_at' ep epptr
2015-09-02 05:43:39 +00:00
and ep_at' epptr
2014-07-14 19:32:44 +00:00
and (\<lambda>s. \<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))"
in ccorres_guard_imp2 [where A'=UNIV])
apply wpc
-- "RecvEP case"
apply (rule ccorres_cond_false)
2017-05-02 01:12:26 +00:00
apply (rule ccorres_cond_true)
2014-07-14 19:32:44 +00:00
apply (intro ccorres_rhs_assoc)
2016-02-10 03:11:09 +00:00
apply (csymbr, csymbr)
2014-07-14 19:32:44 +00:00
apply wpc
apply (simp only: haskell_fail_def)
2017-05-02 01:12:26 +00:00
apply (rule ccorres_fail)
2014-07-14 19:32:44 +00:00
apply (rename_tac dest rest)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
2017-05-02 01:12:26 +00:00
apply (rule ccorres_split_nothrow_novcg)
2014-07-14 19:32:44 +00:00
apply (rule_tac dest=dest in sendIPC_dequeue_ccorres_helper)
apply simp
apply ceqv
apply (rename_tac dest')
apply (simp only: K_bind_def haskell_assert_def return_bind)
2016-02-10 03:11:09 +00:00
2014-07-14 19:32:44 +00:00
apply (rule getThreadState_ccorres_foo)
apply (rename_tac recvState)
apply (rule ccorres_assert)
2016-02-10 03:11:09 +00:00
2017-05-02 01:12:26 +00:00
apply (ctac(no_vcg))
2014-07-14 19:32:44 +00:00
apply (ctac(no_vcg))
apply (ctac(no_vcg))
apply (rule ccorres_pre_threadGet)
apply (rename_tac fault)
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split)
2014-07-14 19:32:44 +00:00
apply wpc
2016-10-25 06:01:30 +00:00
apply (clarsimp simp: from_bool_def split del: if_split)
2015-09-02 05:43:39 +00:00
apply (fold dc_def)[1]
2014-07-14 19:32:44 +00:00
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_cond_true_seq)
apply (simp only: ccorres_seq_skip)
apply (rule ccorres_cond_true)
2017-05-02 01:12:26 +00:00
apply (simp only: case_bool_If Collect_const[symmetric])
2014-07-14 19:32:44 +00:00
apply (rule_tac R=\<top> in ccorres_cond)
2015-11-16 03:12:37 +00:00
apply (clarsimp simp: if_1_0_0 Collect_const_mem)
2014-07-14 19:32:44 +00:00
apply (ctac add: setupCallerCap_ccorres)
apply (ctac add: setThreadState_ccorres)
apply vcg
2016-02-10 03:11:09 +00:00
apply (rule conseqPre, vcg, clarsimp) (* do_call = False *)
2016-10-25 06:01:30 +00:00
apply (clarsimp simp: from_bool_def split del: if_split)
2014-07-14 19:32:44 +00:00
apply (fold dc_def)[1]
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_cond_false_seq)
apply (intro ccorres_rhs_assoc)
2016-11-10 04:44:36 +00:00
apply (rule ccorres_move_c_guard_tcb [simplified])
apply (rule_tac val="case_option (scast seL4_Fault_NullFault)
2014-07-14 19:32:44 +00:00
fault_to_fault_tag fault"
2015-12-08 06:29:42 +00:00
and xf'=ret__unsigned_'
2014-07-14 19:32:44 +00:00
and R="\<lambda>s. \<exists>t. ko_at' t thread s \<and> tcbFault t = fault"
in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
apply (rule conseqPre, vcg, clarsimp)
2015-09-02 05:43:39 +00:00
apply (erule(1) cmap_relation_ko_atE[OF cmap_relation_tcb])
2014-07-14 19:32:44 +00:00
apply (fastforce simp: ctcb_relation_def typ_heap_simps
2016-11-10 04:44:36 +00:00
cfault_rel_def seL4_Fault_lift_def Let_def
2016-10-25 06:01:30 +00:00
split: if_split_asm option.split)
2014-07-14 19:32:44 +00:00
apply ceqv
apply wpc
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_cond_false)
apply (fold dc_def)[1]
apply (rule ccorres_return_Skip)
apply vcg
apply (rule conseqPre, vcg, clarsimp)
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split)
2014-07-14 19:32:44 +00:00
apply (fold dc_def)[1]
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_cond_true)
2014-08-11 08:51:04 +00:00
apply (simp only: case_bool_If)
2014-07-14 19:32:44 +00:00
apply (rule_tac R=\<top> in ccorres_cond)
2015-11-16 03:12:37 +00:00
apply (clarsimp simp: Collect_const_mem if_1_0_0)
2014-07-14 19:32:44 +00:00
apply (ctac add: setupCallerCap_ccorres)
apply (ctac add: setThreadState_ccorres)
apply vcg
apply (rule conseqPre, vcg, clarsimp)
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: fault_to_fault_tag_nonzero seL4_Fault_NullFault_def
2014-07-14 19:32:44 +00:00
guard_is_UNIV_def ThreadState_Inactive_def)
apply vcg
apply (rule conseqPre, vcg, clarsimp)
2016-02-10 03:11:09 +00:00
2014-07-14 19:32:44 +00:00
apply (rule_tac Q="\<lambda>rv. valid_queues and valid_pspace' and valid_objs'
and sch_act_not thread and tcb_at' thread
and tcb_at' dest and
(\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
(\<forall>d p. thread \<notin> set (ksReadyQueues s (d, p))))"
2015-09-02 05:43:39 +00:00
in hoare_post_imp)
2014-07-14 19:32:44 +00:00
apply (fastforce simp: weak_sch_act_wf_def valid_tcb_state'_def
elim: obj_at'_weakenE)
apply (wp attemptSwitchTo_sch_act_not sts_st_tcb' hoare_vcg_all_lift
2017-01-13 12:58:40 +00:00
attemptSwitchTo_ksQ sts_valid_queues sts_ksQ')+
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: valid_tcb_state'_def)
2017-01-13 12:58:40 +00:00
apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift)+
2014-07-14 19:32:44 +00:00
apply (rule_tac Q="\<lambda>rv. valid_queues and valid_pspace' and valid_objs'
and valid_mdb' and tcb_at' dest and cur_tcb'
and tcb_at' thread and K (dest \<noteq> thread)
and sch_act_not thread and K (epptr \<noteq> 0)
and (\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
(\<forall>d p. thread \<notin> set (ksReadyQueues s (d, p))))"
in hoare_post_imp)
apply (clarsimp simp: st_tcb_at'_def obj_at'_def is_tcb weak_sch_act_wf_def)
apply (wp setEndpoint_ksQ hoare_vcg_all_lift set_ep_valid_objs'
2017-01-13 12:58:40 +00:00
setEndpoint_valid_mdb')+
apply (clarsimp simp: guard_is_UNIV_def ThreadState_Inactive_def
2016-02-10 03:11:09 +00:00
ThreadState_Running_def mask_def from_bool_def
option_to_ptr_def option_to_0_def
split: bool.split_asm)
2014-07-14 19:32:44 +00:00
-- "IdleEP case"
apply (rule ccorres_cond_true)
apply (rule ccorres_cond)
apply (clarsimp simp: from_bool_def split: bool.split)
-- "blocking case"
apply (intro ccorres_rhs_assoc)
apply csymbr
apply (simp only:)
-- "apply (ctac (trace, no_vcg,c_lines 6) add: sendIPC_block_ccorres_helper)"
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_split_nothrow_novcg)
apply (rule sendIPC_block_ccorres_helper)
apply ceqv
apply (simp only: K_bind_def fun_app_def)
apply (rule_tac ep=IdleEP in sendIPC_enqueue_ccorres_helper)
apply (simp add: valid_ep'_def)
apply (wp sts_st_tcb')
apply (rule_tac Q="\<lambda>rv. ko_wp_at' (\<lambda>x. projectKO_opt x = Some IdleEP
2015-09-02 05:43:39 +00:00
\<and> projectKO_opt x = (None::tcb option)) epptr"
2014-07-14 19:32:44 +00:00
in hoare_post_imp)
apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs)
apply wp
apply (clarsimp simp: guard_is_UNIV_def)
apply (rule ccorres_return_Skip)
-- "SendEP case"
apply (rule ccorres_cond_true)
apply (rule ccorres_cond)
apply (clarsimp simp: from_bool_def split: bool.split)
-- "blocking case"
apply (intro ccorres_rhs_assoc)
apply csymbr
-- "apply (ctac (no_vcg,c_lines 6) add: sendIPC_block_ccorres_helper)"
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
2015-05-20 10:39:47 +00:00
apply (rename_tac list)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_split_nothrow_novcg)
apply (simp only: )
apply (rule sendIPC_block_ccorres_helper)
apply ceqv
apply (simp only: K_bind_def fun_app_def)
apply (rule_tac ep="SendEP list" in sendIPC_enqueue_ccorres_helper)
apply (simp add: valid_ep'_def)
apply (wp sts_st_tcb')
apply (rule_tac Q="\<lambda>rv. ko_wp_at' (\<lambda>x. projectKO_opt x = Some (SendEP list)
2015-09-02 05:43:39 +00:00
\<and> projectKO_opt x = (None::tcb option)) epptr
and K (thread \<notin> set list)"
2014-07-14 19:32:44 +00:00
in hoare_post_imp)
apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs)
apply wp
apply (clarsimp simp: guard_is_UNIV_def)
apply (rule ccorres_return_Skip)
2015-12-01 05:29:29 +00:00
apply (clarsimp simp: EPState_Recv_def EPState_Send_def EPState_Idle_def
2016-10-25 06:01:30 +00:00
split: if_split)
2015-09-02 05:43:39 +00:00
apply (frule(1) ko_at_valid_objs'[OF _ invs_valid_objs'])
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: projectKO_opt_ep split: kernel_object.split_asm)
2015-09-02 05:43:39 +00:00
apply (subgoal_tac "epptr \<noteq> thread \<and> bound_tcb_at' (\<lambda>x. tcb_bound_refs' x =
state_refs_of' s thread) thread s \<and> (\<forall>r. (thread, r) \<notin>
ep_q_refs_of' ep)")
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: valid_obj'_def valid_ep'_def refs_of'_def
split: endpoint.splits)
2015-09-02 05:43:39 +00:00
apply (frule(1) sym_refs_obj_atD'[OF _ invs_sym'])
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: st_tcb_at_refs_of_rev' isBlockedOnReceive_def)
2017-05-02 01:12:26 +00:00
apply (auto split: list.splits elim!: pred_tcb'_weakenE)[1]
2014-07-14 19:32:44 +00:00
apply (subgoal_tac "state_refs_of' s epptr = {}")
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: obj_at'_def is_aligned_neg_mask objBitsKO_def
projectKOs invs'_def valid_state'_def
st_tcb_at'_def valid_tcb_state'_def ko_wp_at'_def
2014-07-14 19:32:44 +00:00
isBlockedOnSend_def projectKO_opt_tcb
2016-10-25 06:01:30 +00:00
split: if_split_asm if_split)
2017-05-02 01:12:26 +00:00
apply (rule conjI, simp, rule impI, clarsimp simp: valid_pspace_valid_objs')
2015-09-02 05:43:39 +00:00
apply (erule delta_sym_refs)
2016-10-25 06:01:30 +00:00
apply (clarsimp split: if_split_asm
2015-12-01 05:29:29 +00:00
dest!: symreftype_inverse')+
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: pred_tcb_at'_def obj_at'_def tcb_bound_refs'_def
2017-05-02 01:12:26 +00:00
projectKOs eq_sym_conv
2015-12-01 05:29:29 +00:00
dest!: symreftype_inverse'
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2017-05-02 01:12:26 +00:00
apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs
2015-09-02 05:43:39 +00:00
tcb_bound_refs'_def eq_sym_conv)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: obj_at'_def state_refs_of'_def projectKOs)
2015-09-02 05:43:39 +00:00
apply (frule(1) sym_refs_obj_atD'[OF _ invs_sym'])
2014-07-14 19:32:44 +00:00
apply clarsimp
apply (rule conjI, assumption)
2015-09-02 05:43:39 +00:00
apply (clarsimp dest!: st_tcb_strg'[rule_format]
2017-05-02 01:12:26 +00:00
simp: invs'_def valid_state'_def obj_at'_def objBits_simps
2015-09-02 05:43:39 +00:00
projectKOs valid_tcb_state'_def)
apply (rule conjI[rotated])
apply (clarsimp simp: isBlockedOnSend_def ko_wp_at'_def obj_at'_def
projectKOs projectKO_opt_tcb objBits_simps)
2016-10-25 06:01:30 +00:00
apply (fastforce split: if_split_asm
2015-09-02 05:43:39 +00:00
elim: delta_sym_refs
2017-05-02 01:12:26 +00:00
simp: pred_tcb_at'_def obj_at'_def projectKOs
2015-09-02 05:43:39 +00:00
tcb_bound_refs'_def eq_sym_conv symreftype_def)
apply clarsimp
apply (frule(1) sym_refs_obj_atD'[OF _ invs_sym'])
2014-07-14 19:32:44 +00:00
apply (frule simple_st_tcb_at_state_refs_ofD')
2015-09-02 05:43:39 +00:00
apply (case_tac ep, auto simp: st_tcb_at_refs_of_rev' st_tcb_at'_def
obj_at'_def projectKOs)[1]
2016-02-10 03:11:09 +00:00
apply (clarsimp simp: guard_is_UNIV_def)
apply (clarsimp simp: guard_is_UNIV_def)
done
2014-07-14 19:32:44 +00:00
lemma receiveIPC_block_ccorres_helper:
"ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and
sch_act_not thread and ep_at' epptr and
(\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
(\<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))) and
2016-02-10 03:11:09 +00:00
K (epptr = epptr && ~~ mask 4))
2014-07-14 19:32:44 +00:00
UNIV hs
(setThreadState (Structures_H.thread_state.BlockedOnReceive
2016-02-10 03:11:09 +00:00
epptr) thread)
2014-07-14 19:32:44 +00:00
(Guard C_Guard \<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
(CALL thread_state_ptr_set_tsType(Ptr
&(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']),
scast ThreadState_BlockedOnReceive));;
Guard C_Guard \<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
2015-11-02 00:00:32 +00:00
(CALL thread_state_ptr_set_blockingObject(Ptr
2014-07-14 19:32:44 +00:00
&(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']),
ucast (ptr_val (ep_Ptr epptr))));;
CALL scheduleTCB(tcb_ptr_to_ctcb_ptr thread))"
unfolding K_def setThreadState_def
apply (intro ccorres_gen_asm)
apply (rule ccorres_guard_imp)
apply (rule ccorres_split_nothrow_novcg)
apply (rule_tac P=\<top> and P'="tcb_at' thread"
in threadSet_ccorres_lemma3)
apply vcg
apply clarsimp
apply (frule(1) tcb_at_h_t_valid)
apply (frule h_t_valid_c_guard)
2016-09-21 00:33:03 +00:00
apply (clarsimp simp: typ_heap_simps' rf_sr_tcb_update_twice)
apply (erule(1) rf_sr_tcb_update_no_queue_gen, (simp add: typ_heap_simps)+)
2014-07-14 19:32:44 +00:00
apply (simp add: tcb_cte_cases_def)
apply (simp add: ctcb_relation_def cthread_state_relation_def
ThreadState_BlockedOnReceive_def mask_def
from_bool_def to_bool_def)
apply ceqv
apply clarsimp
apply ctac
apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs'
threadSet_weak_sch_act_wf_runnable')
apply (clarsimp simp: guard_is_UNIV_def)
apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def
tcb_cte_cases_def)
apply clarsimp
2017-05-02 01:12:26 +00:00
done
2014-07-14 19:32:44 +00:00
lemma receiveIPC_enqueue_ccorres_helper:
"ccorres dc xfdc (valid_pspace'
and (\<lambda>s. sym_refs ((state_refs_of' s)(epptr := set queue \<times> {EPRecv})))
and st_tcb_at' (\<lambda>st. isBlockedOnReceive st \<and>
2015-11-02 00:00:32 +00:00
blockingObject st = epptr) thread
2014-07-14 19:32:44 +00:00
and ko_at' (ep::Structures_H.endpoint) epptr
and K ((ep = IdleEP \<and> queue = [thread]) \<or>
(\<exists>q. ep = RecvEP q \<and> thread \<notin> set q \<and>
queue = q @ [thread])))
UNIV hs
(setEndpoint epptr (Structures_H.endpoint.RecvEP queue))
(\<acute>queue :== CALL ep_ptr_get_queue(ep_Ptr epptr);;
(\<acute>queue :== CALL tcbEPAppend(tcb_ptr_to_ctcb_ptr thread,\<acute>queue);;
(CALL endpoint_ptr_set_state(ep_Ptr epptr, scast EPState_Recv);;
CALL ep_ptr_set_queue(ep_Ptr epptr,\<acute>queue))))"
unfolding K_def
apply (rule ccorres_gen_asm)
apply (rule ccorres_from_vcg)
apply (rule allI, rule conseqPre, vcg)
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split simp del: comp_def)
2014-07-14 19:32:44 +00:00
apply (frule cmap_relation_ep)
apply (erule (1) cmap_relation_ko_atE)
apply (rule conjI)
apply (erule h_t_valid_clift)
apply (frule(1) st_tcb_at_h_t_valid)
2015-09-02 05:43:39 +00:00
apply (frule pred_tcb_at')
2014-07-14 19:32:44 +00:00
apply (rule impI)
apply (rule_tac x="init queue" in exI)
apply (frule(1) ko_at_valid_ep' [OF _ valid_pspace_valid_objs'])
apply (frule is_aligned_tcb_ptr_to_ctcb_ptr)
apply (rule conjI)
apply (rule_tac x=\<sigma> in exI)
apply (simp add: cendpoint_relation_def Let_def)
apply (case_tac ep, simp_all add: init_def valid_ep'_def)[1]
apply (subgoal_tac "sym_refs (state_refs_of' (\<sigma>\<lparr>ksPSpace :=
ksPSpace \<sigma>(epptr \<mapsto> KOEndpoint (RecvEP queue))\<rparr>))")
prefer 2
apply (clarsimp simp: state_refs_of'_upd ko_wp_at'_def
obj_at'_def projectKOs objBitsKO_def)
apply (subgoal_tac "ko_at' (RecvEP queue) epptr (\<sigma>\<lparr>ksPSpace :=
ksPSpace \<sigma>(epptr \<mapsto> KOEndpoint (RecvEP queue))\<rparr>)")
prefer 2
apply (clarsimp simp: obj_at'_def projectKOs objBitsKO_def ps_clear_upd)
apply (intro conjI impI allI)
apply (fastforce simp: h_t_valid_clift)
apply (fastforce simp: h_t_valid_clift)
apply (case_tac ep, simp_all add: EPState_Idle_def EPState_Recv_def)[1]
-- "RecvEP case"
apply clarsimp
apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
apply (simp add: setEndpoint_def split_def)
apply (rule bexI [OF _ setObject_eq])
apply (simp add: rf_sr_def cstate_relation_def Let_def init_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ep_map_tos
typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (elim conjE)
apply (intro conjI)
-- "tcb relation"
apply (erule ctcb_relation_null_queue_ptrs)
apply (clarsimp simp: comp_def)
-- "ep relation"
apply (rule cpspace_relation_ep_update_ep', assumption+)
apply (clarsimp simp: cendpoint_relation_def Let_def
2015-11-16 03:12:37 +00:00
mask_def [where n=2] EPState_Recv_def
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask
valid_ep'_def
dest: tcb_queue_relation_next_not_NULL)
apply (simp add: isSendEP_def isRecvEP_def)
2015-11-02 00:00:32 +00:00
-- "ntfn relation"
2014-07-14 19:32:44 +00:00
apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
apply simp
2015-11-02 00:00:32 +00:00
apply (rule cnotification_relation_ep_queue, assumption+)
2014-07-14 19:32:44 +00:00
apply (simp add: isSendEP_def isRecvEP_def)
apply simp
apply (frule_tac x=p in map_to_ko_atI2, clarsimp, clarsimp)
apply (erule(2) map_to_ko_at_updI')
apply (clarsimp simp: objBitsKO_def)
apply (clarsimp simp: obj_at'_def projectKOs)
-- "queue relation"
apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
apply (clarsimp simp: comp_def)
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: cmachine_state_relation_def)
apply (simp add: h_t_valid_clift_Some_iff)
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
-- "IdleEP case"
apply clarsimp
apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
apply (simp add: setEndpoint_def split_def)
apply (rule bexI [OF _ setObject_eq])
apply (simp add: rf_sr_def cstate_relation_def init_def Let_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ep_map_tos
typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (elim conjE)
apply (intro conjI)
-- "tcb relation"
apply (erule ctcb_relation_null_queue_ptrs)
apply (clarsimp simp: comp_def)
-- "ep relation"
apply (rule cpspace_relation_ep_update_ep', assumption+)
apply (clarsimp simp: cendpoint_relation_def Let_def
mask_def [where n=2] EPState_Recv_def)
apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask)
apply (simp add: isSendEP_def isRecvEP_def)
2015-11-02 00:00:32 +00:00
-- "ntfn relation"
2014-07-14 19:32:44 +00:00
apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
apply simp
2015-11-02 00:00:32 +00:00
apply (rule cnotification_relation_ep_queue, assumption+)
2014-07-14 19:32:44 +00:00
apply (simp add: isSendEP_def isRecvEP_def)
apply simp
apply (frule_tac x=p in map_to_ko_atI2, clarsimp, clarsimp)
apply (erule(2) map_to_ko_at_updI')
apply (clarsimp simp: objBitsKO_def)
apply (clarsimp simp: obj_at'_def projectKOs)
-- "queue relation"
apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
apply (clarsimp simp: comp_def)
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: cmachine_state_relation_def)
2016-09-21 00:33:03 +00:00
apply (simp add: typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
done
lemma receiveIPC_dequeue_ccorres_helper:
"ccorres (\<lambda>rv rv'. rv' = tcb_ptr_to_ctcb_ptr sender) sender_'
(invs' and st_tcb_at' (\<lambda>st. isBlockedOnSend st \<and>
2015-11-02 00:00:32 +00:00
blockingObject st = ep) sender
2014-07-14 19:32:44 +00:00
and ko_at' (SendEP (sender#rest)) ep) UNIV hs
(setEndpoint ep (case rest of [] \<Rightarrow> Structures_H.IdleEP
| (a#list) \<Rightarrow> Structures_H.SendEP rest))
(\<acute>queue :== CALL ep_ptr_get_queue(Ptr ep);;
\<acute>sender :== head_C \<acute>queue;;
\<acute>queue :== CALL tcbEPDequeue(\<acute>sender,\<acute>queue);;
CALL ep_ptr_set_queue(Ptr ep,\<acute>queue);;
IF head_C \<acute>queue = Ptr 0 THEN
CALL endpoint_ptr_set_state(Ptr ep,scast EPState_Idle)
FI)"
apply (rule ccorres_from_vcg)
apply (rule allI)
apply (rule conseqPre, vcg)
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split simp del: comp_def)
2015-09-02 05:43:39 +00:00
apply (frule ep_blocked_in_queueD [OF pred_tcb'_weakenE])
2014-07-14 19:32:44 +00:00
apply simp
apply assumption+
apply (frule (1) ko_at_valid_ep' [OF _ invs_valid_objs'])
apply (elim conjE)
apply (frule (1) valid_ep_blockedD)
apply (elim conjE)
apply (frule cmap_relation_ep)
apply (erule (1) cmap_relation_ko_atE)
apply (intro conjI)
apply (erule h_t_valid_clift)
apply (rule impI)
apply (rule exI)
apply (rule conjI)
apply (rule_tac x=\<sigma> in exI)
apply (intro conjI)
apply assumption+
apply (drule (2) ep_to_ep_queue)
apply (simp add: tcb_queue_relation'_def)
apply (clarsimp simp: typ_heap_simps cendpoint_relation_def Let_def
2016-10-25 06:01:30 +00:00
cong: imp_cong split del: if_split simp del: comp_def)
2014-07-14 19:32:44 +00:00
apply (intro conjI impI allI)
apply (fastforce simp: h_t_valid_clift)
apply (fastforce simp: h_t_valid_clift)
-- "empty case"
apply clarsimp
apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
apply (frule iffD1 [OF tcb_queue_head_empty_iff
[OF tcb_queue_relation'_queue_rel]])
apply (rule ballI, erule bspec)
apply (erule subsetD [rotated])
apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
apply simp
apply (simp add: setEndpoint_def split_def)
apply (rule conjI)
apply (rule bexI [OF _ setObject_eq])
apply (simp add: rf_sr_def cstate_relation_def Let_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ep_map_tos
typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (elim conjE)
apply (intro conjI)
-- "tcb relation"
apply (erule ctcb_relation_null_queue_ptrs)
apply (clarsimp simp: comp_def)
-- "ep relation"
apply (rule cpspace_relation_ep_update_ep, assumption+)
apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def
tcb_queue_relation'_def)
apply simp
2015-11-02 00:00:32 +00:00
-- "ntfn relation"
2014-07-14 19:32:44 +00:00
apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
apply simp
2015-11-02 00:00:32 +00:00
apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+)
2014-07-14 19:32:44 +00:00
apply simp
apply (erule (1) map_to_ko_atI')
-- "queue relation"
apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
apply (clarsimp simp: comp_def)
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: cmachine_state_relation_def)
2016-09-21 00:33:03 +00:00
apply (simp add: typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
-- "non-empty case"
apply clarsimp
apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
apply (frule tcb_queue_head_empty_iff [OF tcb_queue_relation'_queue_rel])
apply (rule ballI, erule bspec)
apply (erule subsetD [rotated])
apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
apply (simp add: setEndpoint_def split_def)
apply (rule conjI)
apply (rule bexI [OF _ setObject_eq])
apply (frule(1) st_tcb_at_h_t_valid)
apply (simp add: rf_sr_def cstate_relation_def Let_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ep_map_tos
typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (elim conjE)
apply (intro conjI)
-- "tcb relation"
apply (erule ctcb_relation_null_queue_ptrs)
apply (clarsimp simp: comp_def)
-- "ep relation"
apply (rule cpspace_relation_ep_update_ep, assumption+)
apply (clarsimp simp: cendpoint_relation_def Let_def
isRecvEP_def isSendEP_def
tcb_queue_relation'_def valid_ep'_def
split: endpoint.splits list.splits
2016-10-25 06:01:30 +00:00
split del: if_split)
2014-09-10 07:26:44 +00:00
apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \<sigma>")
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: is_aligned_neg_mask
dest!: is_aligned_tcb_ptr_to_ctcb_ptr
2016-10-25 06:01:30 +00:00
split del: if_split)
apply (clarsimp split: if_split)
2014-07-14 19:32:44 +00:00
apply simp
2015-11-02 00:00:32 +00:00
-- "ntfn relation"
2014-07-14 19:32:44 +00:00
apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
apply simp
2015-11-02 00:00:32 +00:00
apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+)
2014-07-14 19:32:44 +00:00
apply simp
apply (erule (1) map_to_ko_atI')
-- "queue relation"
apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
apply (clarsimp simp: comp_def)
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: cmachine_state_relation_def)
2016-09-21 00:33:03 +00:00
apply (simp add: typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
done
2015-11-02 00:00:32 +00:00
lemmas ccorres_pre_getBoundNotification = ccorres_pre_threadGet[where f=tcbBoundNotification, folded getBoundNotification_def]
2015-09-02 05:43:39 +00:00
2015-11-02 00:00:32 +00:00
lemma completeSignal_ccorres:
2016-10-25 06:01:30 +00:00
notes if_split[split del]
2015-09-02 05:43:39 +00:00
shows
"ccorres dc xfdc (invs' and tcb_at' thread)
(UNIV \<inter> \<lbrace>\<acute>tcb = tcb_ptr_to_ctcb_ptr thread\<rbrace>
2015-11-02 00:00:32 +00:00
\<inter> \<lbrace>\<acute>ntfnPtr = Ptr ntfnptr\<rbrace>) hs
(completeSignal ntfnptr thread)
(Call completeSignal_'proc)"
apply (cinit lift: tcb_' ntfnPtr_')
2015-09-02 05:43:39 +00:00
apply (rule_tac P="invs' and tcb_at' thread" in ccorres_gen_asm_state)
apply clarsimp
apply (subgoal_tac "tcb_ptr_to_ctcb_ptr thread \<noteq> NULL")
prefer 2
apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def
tcb_ptr_to_ctcb_ptr_def)
apply (drule sum_to_zero)
apply (clarsimp simp: obj_at'_def ctcb_offset_def projectKOs objBitsKO_def
is_aligned_def)
apply clarsimp
apply csymbr
apply simp
apply (rule ccorres_rhs_assoc)+
2015-11-02 00:00:32 +00:00
apply (rule ccorres_pre_getNotification, rename_tac ntfn)
2015-12-08 06:29:42 +00:00
apply (rule_tac xf'=ret__unsigned_'
2015-11-02 00:00:32 +00:00
and val="case ntfnObj ntfn of IdleNtfn \<Rightarrow> scast NtfnState_Idle
| WaitingNtfn _ \<Rightarrow> scast NtfnState_Waiting
| ActiveNtfn _ \<Rightarrow> scast NtfnState_Active"
and R="ko_at' ntfn ntfnptr"
2015-09-02 05:43:39 +00:00
in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
apply vcg
apply clarsimp
2015-11-02 00:00:32 +00:00
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_ntfn])
apply (clarsimp simp: cnotification_relation_def Let_def typ_heap_simps
split: Structures_H.ntfn.splits)
2015-09-02 05:43:39 +00:00
apply ceqv
apply wpc
2015-11-02 00:00:32 +00:00
-- "IdleNtfn case"
apply (clarsimp simp: NtfnState_Idle_def NtfnState_Active_def)
2015-09-02 05:43:39 +00:00
apply csymbr
apply (rule ccorres_cond_false)
apply (rule ccorres_fail)
2015-11-02 00:00:32 +00:00
-- "ActiveNtfn case"
2015-09-02 05:43:39 +00:00
apply (clarsimp, csymbr, rule ccorres_cond_true)
apply (rule ccorres_rhs_assoc)+
2015-09-10 07:06:45 +00:00
apply (rename_tac word)
2015-11-02 00:00:32 +00:00
apply (rule_tac val=word and xf'=badge_' and R="ko_at' ntfn ntfnptr"
2015-09-02 05:43:39 +00:00
in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
apply (vcg, clarsimp)
2015-11-02 00:00:32 +00:00
apply (erule(1) cmap_relation_ko_atE[OF cmap_relation_ntfn])
apply (clarsimp simp: cnotification_relation_def Let_def typ_heap_simps)
2015-09-02 05:43:39 +00:00
apply ceqv
apply (fold dc_def, ctac(no_vcg))
2015-11-02 00:00:32 +00:00
apply (rule_tac P="invs' and ko_at' ntfn ntfnptr" and P'=UNIV in ccorres_from_vcg)
2015-09-02 05:43:39 +00:00
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp)
2015-11-02 00:00:32 +00:00
apply (frule(1) cmap_relation_ko_atD [OF cmap_relation_ntfn])
apply (clarsimp simp: typ_heap_simps setNotification_def)
2015-09-02 05:43:39 +00:00
apply (rule bexI [OF _ setObject_eq])
2017-05-02 01:12:26 +00:00
apply (simp add: rf_sr_def cstate_relation_def Let_def update_ntfn_map_tos
2016-09-21 00:33:03 +00:00
cpspace_relation_def typ_heap_simps')
2015-09-02 05:43:39 +00:00
apply (elim conjE)
apply (intro conjI)
2015-11-02 00:00:32 +00:00
apply (rule cpspace_relation_ntfn_update_ntfn, assumption+)
apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def mask_def)
2015-09-02 05:43:39 +00:00
apply simp
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2015-09-02 05:43:39 +00:00
apply (simp add: cmachine_state_relation_def)
apply (simp add: h_t_valid_clift_Some_iff)
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
apply wp
2017-05-02 01:12:26 +00:00
apply (clarsimp simp: guard_is_UNIV_def ARM_H.badgeRegister_def
2016-05-05 22:59:33 +00:00
ARM.badgeRegister_def Kernel_C.badgeRegister_def
2015-09-02 05:43:39 +00:00
Kernel_C.R0_def)
2015-11-02 00:00:32 +00:00
-- "WaitingNtfn case"
apply (clarsimp simp: NtfnState_Active_def NtfnState_Waiting_def)
2015-09-02 05:43:39 +00:00
apply csymbr
apply (rule ccorres_cond_false)
apply (rule ccorres_fail)
apply (clarsimp simp: guard_is_UNIV_def)
apply (clarsimp)
2017-05-02 01:12:26 +00:00
done
2015-10-21 02:34:22 +00:00
2015-11-10 15:25:02 +00:00
lemma doNBRecvFailedTransfer_ccorres[corres]:
2015-10-21 02:34:22 +00:00
"ccorres dc xfdc
\<top>
(UNIV \<inter> {s. thread_' s = tcb_ptr_to_ctcb_ptr thread})
2015-11-10 15:25:02 +00:00
[] (doNBRecvFailedTransfer thread)
(Call doNBRecvFailedTransfer_'proc)"
2015-10-21 02:34:22 +00:00
apply (cinit lift: thread_')
apply (ctac add: setRegister_ccorres)
2016-05-01 03:35:49 +00:00
by (clarsimp simp: Kernel_C.badgeRegister_def ARM_H.badgeRegister_def
2016-05-05 22:59:33 +00:00
ARM.badgeRegister_def Kernel_C.R0_def)
2015-09-02 05:43:39 +00:00
2014-07-14 19:32:44 +00:00
lemma receiveIPC_ccorres [corres]:
2015-05-20 10:39:47 +00:00
notes option.case_cong_weak [cong]
shows
2014-07-14 19:32:44 +00:00
"ccorres dc xfdc (invs' and st_tcb_at' simple' thread and sch_act_not thread
and (\<lambda>s. \<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))
and valid_cap' cap and K (isEndpointCap cap))
(UNIV \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>
2015-10-21 02:34:22 +00:00
\<inter> \<lbrace>ccap_relation cap \<acute>cap\<rbrace>
\<inter> \<lbrace>\<acute>isBlocking = from_bool isBlocking\<rbrace>) hs
(receiveIPC thread cap isBlocking)
2014-07-14 19:32:44 +00:00
(Call receiveIPC_'proc)"
unfolding K_def
apply (rule ccorres_gen_asm)
2015-10-21 02:34:22 +00:00
apply (cinit lift: thread_' cap_' isBlocking_')
2014-07-14 19:32:44 +00:00
apply (rule ccorres_pre_getEndpoint)
apply (rename_tac ep)
apply (simp only: ccorres_seq_skip)
2015-12-08 06:29:42 +00:00
apply (rule_tac xf'=ret__unsigned_'
2014-07-14 19:32:44 +00:00
and val="capEPPtr cap"
and R=\<top>
in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
apply vcg
apply (clarsimp simp: cap_get_tag_isCap isCap_simps)
apply (frule cap_get_tag_isCap_unfolded_H_cap)
apply (simp add: cap_endpoint_cap_lift ccap_relation_def cap_to_H_def)
apply ceqv
apply csymbr
2015-09-02 05:43:39 +00:00
apply (rule ccorres_move_c_guard_tcb)
2015-11-02 00:00:32 +00:00
apply (rule_tac xf'=ntfnPtr_'
2015-09-02 05:43:39 +00:00
and r'="\<lambda>rv rv'. rv' = option_to_ptr rv \<and> rv \<noteq> Some 0"
in ccorres_split_nothrow_novcg)
2015-11-02 00:00:32 +00:00
apply (simp add: getBoundNotification_def)
2015-09-02 05:43:39 +00:00
apply (rule_tac P="no_0_obj' and valid_objs'" in threadGet_vcg_corres_P)
apply (rule allI, rule conseqPre, vcg)
apply clarsimp
apply (drule obj_at_ko_at', clarsimp)
apply (drule spec, drule(1) mp, clarsimp)
apply (clarsimp simp: typ_heap_simps ctcb_relation_def)
apply (drule(1) ko_at_valid_objs', simp add: projectKOs)
apply (clarsimp simp: option_to_ptr_def option_to_0_def projectKOs
valid_obj'_def valid_tcb'_def)
apply ceqv
2015-11-02 00:00:32 +00:00
apply (rename_tac ntfnptr ntfnptr')
2016-10-25 06:01:30 +00:00
apply (simp del: Collect_const split del: if_split cong: call_ignore_cong)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_rhs_assoc2)
2015-09-02 05:43:39 +00:00
apply (rule_tac xf'=ret__int_'
2015-11-02 00:00:32 +00:00
and r'="\<lambda>rv rv'. (rv' = 0) = (ntfnptr = None \<or> \<not> isActive rv)"
2015-09-02 05:43:39 +00:00
in ccorres_split_nothrow_novcg)
apply wpc
apply (rule ccorres_from_vcg[where P=\<top> and P'=UNIV])
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp simp: option_to_ptr_def option_to_0_def in_monad Bex_def)
2015-11-02 00:00:32 +00:00
apply (rule ccorres_pre_getNotification[where f=return, simplified])
apply (rule_tac P="\<lambda>s. ko_at' rv (the ntfnptr) s"
2015-09-02 05:43:39 +00:00
in ccorres_from_vcg[where P'=UNIV])
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp simp: option_to_ptr_def option_to_0_def in_monad Bex_def)
2015-11-02 00:00:32 +00:00
apply (erule cmap_relationE1[OF cmap_relation_ntfn])
2015-09-02 05:43:39 +00:00
apply (erule ko_at_projectKO_opt)
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: typ_heap_simps cnotification_relation_def Let_def
notification_state_defs isActive_def
split: Structures_H.ntfn.split_asm Structures_H.notification.splits)
2014-07-14 19:32:44 +00:00
apply ceqv
2015-09-02 05:43:39 +00:00
apply (rule ccorres_cond[where R=\<top>])
2015-12-01 05:29:29 +00:00
apply (simp add: Collect_const_mem)
2015-11-02 00:00:32 +00:00
apply (ctac add: completeSignal_ccorres[unfolded dc_def])
2015-12-08 06:29:42 +00:00
apply (rule_tac xf'=ret__unsigned_'
2015-09-02 05:43:39 +00:00
and val="case ep of IdleEP \<Rightarrow> scast EPState_Idle
| RecvEP _ \<Rightarrow> scast EPState_Recv
| SendEP _ \<Rightarrow> scast EPState_Send"
and R="ko_at' ep (capEPPtr cap)"
in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
2014-07-14 19:32:44 +00:00
apply (vcg, clarsimp)
2015-09-02 05:43:39 +00:00
apply (erule cmap_relationE1 [OF cmap_relation_ep])
apply (erule ko_at_projectKO_opt)
apply (clarsimp simp: typ_heap_simps cendpoint_relation_def Let_def
split: endpoint.split_asm)
2014-07-14 19:32:44 +00:00
apply ceqv
2015-09-02 05:43:39 +00:00
apply (rule_tac A="invs' and st_tcb_at' simple' thread
and sch_act_not thread
and (\<lambda>s. \<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))
and ko_at' ep (capEPPtr cap)"
in ccorres_guard_imp2 [where A'=UNIV])
apply wpc
-- "RecvEP case"
apply (rule ccorres_cond_true)
apply csymbr
2015-10-21 02:34:22 +00:00
apply (simp only: case_bool_If from_bool_neq_0)
2016-10-25 06:01:30 +00:00
apply (rule ccorres_Cond_rhs, simp cong: Collect_cong split del: if_split)
2015-10-21 02:34:22 +00:00
apply (intro ccorres_rhs_assoc)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_split_nothrow_novcg)
2016-10-25 06:01:30 +00:00
apply (simp split del: if_split)
2015-10-21 02:34:22 +00:00
apply (rule receiveIPC_block_ccorres_helper[unfolded ptr_val_def, simplified])
apply ceqv
apply simp
apply (rename_tac list NOo)
apply (rule_tac ep="RecvEP list"
in receiveIPC_enqueue_ccorres_helper[simplified, unfolded dc_def])
apply (simp add: valid_ep'_def)
apply (wp sts_st_tcb')
apply (rename_tac list)
apply (rule_tac Q="\<lambda>rv. ko_wp_at' (\<lambda>x. projectKO_opt x = Some (RecvEP list)
\<and> projectKO_opt x = (None::tcb option))
(capEPPtr cap)
and K (thread \<notin> set list)"
in hoare_post_imp)
apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs)
apply wp
apply (clarsimp simp: guard_is_UNIV_def)
apply simp
2015-11-10 15:25:02 +00:00
apply (ctac add: doNBRecvFailedTransfer_ccorres[unfolded dc_def])
2015-10-21 02:34:22 +00:00
-- "IdleEP case"
apply (rule ccorres_cond_true)
apply csymbr
apply (simp only: case_bool_If from_bool_neq_0)
2016-10-25 06:01:30 +00:00
apply (rule ccorres_Cond_rhs, simp cong: Collect_cong split del: if_split)
2015-10-21 02:34:22 +00:00
apply (intro ccorres_rhs_assoc)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_split_nothrow_novcg)
2016-10-25 06:01:30 +00:00
apply (simp split del: if_split)
2015-09-02 05:43:39 +00:00
apply (rule receiveIPC_block_ccorres_helper[unfolded ptr_val_def, simplified])
apply ceqv
apply simp
2015-10-21 02:34:22 +00:00
apply (rule_tac ep=IdleEP
in receiveIPC_enqueue_ccorres_helper[simplified, unfolded dc_def])
2015-09-02 05:43:39 +00:00
apply (simp add: valid_ep'_def)
apply (wp sts_st_tcb')
2015-10-21 02:34:22 +00:00
apply (rule_tac Q="\<lambda>rv. ko_wp_at' (\<lambda>x. projectKO_opt x = Some IdleEP
\<and> projectKO_opt x = (None::tcb option))
(capEPPtr cap)"
in hoare_post_imp)
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs)
apply wp
apply (clarsimp simp: guard_is_UNIV_def)
2015-10-21 02:34:22 +00:00
apply simp
2015-11-10 15:25:02 +00:00
apply (ctac add: doNBRecvFailedTransfer_ccorres[unfolded dc_def])
2015-09-02 05:43:39 +00:00
-- "SendEP case"
2015-10-21 02:34:22 +00:00
apply (thin_tac "isBlockinga = from_bool P" for P)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_cond_false)
apply (rule ccorres_cond_true)
apply (intro ccorres_rhs_assoc)
apply (csymbr, csymbr, csymbr, csymbr, csymbr)
apply wpc
apply (simp only: haskell_fail_def)
apply (rule ccorres_fail)
apply (rename_tac sender rest)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_split_nothrow_novcg)
apply simp
apply (rule_tac sender=sender in receiveIPC_dequeue_ccorres_helper[simplified])
2014-07-14 19:32:44 +00:00
apply ceqv
2015-09-02 05:43:39 +00:00
apply (rename_tac sender')
apply (simp only: K_bind_def haskell_assert_def return_bind)
apply (rule ccorres_move_c_guard_tcb)
apply (rule getThreadState_ccorres_foo)
apply (rename_tac sendState)
apply (rule ccorres_assert)
apply (rule_tac val="blockingIPCBadge sendState"
and xf'=badge_'
and R="\<lambda>s. \<exists>t. ko_at' t sender s \<and> tcbState t = sendState"
in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
apply (vcg, clarsimp)
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
apply (clarsimp simp: ctcb_relation_def typ_heap_simps
cthread_state_relation_def word_size
isSend_def thread_state_lift_def
split: Structures_H.thread_state.splits)
apply ceqv
2016-10-25 06:01:30 +00:00
apply (simp split del: if_split)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_move_c_guard_tcb)
apply (rule_tac val="from_bool (blockingIPCCanGrant sendState)"
and xf'=canGrant_'
and R="\<lambda>s. \<exists>t. ko_at' t sender s \<and> tcbState t = sendState"
in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
apply (vcg, clarsimp)
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
apply (clarsimp simp: ctcb_relation_def typ_heap_simps
cthread_state_relation_def word_size
isSend_def thread_state_lift_def
split: Structures_H.thread_state.splits)
apply ceqv
apply (ctac(no_vcg))
apply (rule ccorres_move_c_guard_tcb)
apply (rule_tac val="from_bool (blockingIPCIsCall sendState)"
and xf'=do_call_'
and R="\<lambda>s. \<exists>t. ko_at' t sender s \<and> tcbState t = sendState"
in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
apply (vcg, clarsimp)
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
apply (clarsimp simp: ctcb_relation_def typ_heap_simps
cthread_state_relation_def word_size
isSend_def thread_state_lift_def
split: Structures_H.thread_state.splits)
apply ceqv
apply (rule ccorres_pre_threadGet)
apply (rename_tac fault)
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split)
2015-09-02 05:43:39 +00:00
apply wpc
2016-10-25 06:01:30 +00:00
apply (clarsimp simp: from_bool_def split del: if_split)
2015-09-02 05:43:39 +00:00
apply (fold dc_def)[1]
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_cond_true_seq)
apply (simp only: ccorres_seq_skip)
apply (rule ccorres_cond_true)
2015-09-10 07:06:45 +00:00
apply (simp only: case_bool_If)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_cond)
2015-11-16 03:12:37 +00:00
apply (clarsimp simp: to_bool_def Collect_const_mem
2016-10-25 06:01:30 +00:00
split: if_split)
2015-09-02 05:43:39 +00:00
apply ctac
apply ctac
apply vcg
apply (rule conseqPre, vcg)
apply clarsimp
2016-10-25 06:01:30 +00:00
apply (clarsimp simp: from_bool_def split del: if_split)
2014-07-14 19:32:44 +00:00
apply (fold dc_def)[1]
apply (rule ccorres_symb_exec_r)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_cond_false_seq)
apply (intro ccorres_rhs_assoc)
apply (rule ccorres_move_c_guard_tcb [simplified])
2016-11-10 04:44:36 +00:00
apply (rule_tac val="case_option (scast seL4_Fault_NullFault)
2015-09-02 05:43:39 +00:00
fault_to_fault_tag fault"
2015-12-08 06:29:42 +00:00
and xf'=ret__unsigned_'
2015-09-02 05:43:39 +00:00
and R="\<lambda>s. \<exists>t. ko_at' t sender s \<and> tcbFault t = fault"
in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
apply (rule conseqPre, vcg, clarsimp)
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
apply (auto simp: ctcb_relation_def typ_heap_simps
2016-11-10 04:44:36 +00:00
cfault_rel_def seL4_Fault_lift_def Let_def
2016-10-25 06:01:30 +00:00
split: if_split_asm option.split)[1]
2015-09-02 05:43:39 +00:00
apply ceqv
apply wpc
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split)
2015-09-02 05:43:39 +00:00
apply (fold dc_def)[1]
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_cond_false)
apply (ctac(no_vcg))
apply ctac
apply (wp sts_st_tcb' sts_valid_queues)
apply vcg
apply (rule conseqPre, vcg, clarsimp)
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split)
2015-09-02 05:43:39 +00:00
apply (fold dc_def)[1]
apply (rule ccorres_symb_exec_r)
apply (rule ccorres_cond_true)
2015-09-10 07:06:45 +00:00
apply (simp only: case_bool_If)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_cond)
2016-10-25 06:01:30 +00:00
apply (clarsimp simp: to_bool_def split: if_split)
2015-09-02 05:43:39 +00:00
apply ctac
apply ctac
apply vcg
apply (rule conseqPre, vcg, clarsimp)
2016-11-10 04:44:36 +00:00
apply (clarsimp simp: fault_to_fault_tag_nonzero seL4_Fault_NullFault_def
2015-09-02 05:43:39 +00:00
guard_is_UNIV_def ThreadState_Inactive_def
mask_def ThreadState_Running_def)
2014-07-14 19:32:44 +00:00
apply vcg
apply (rule conseqPre, vcg, clarsimp)
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: guard_is_UNIV_def ThreadState_Inactive_def)
2014-07-14 19:32:44 +00:00
apply (rule_tac Q="\<lambda>rv. valid_queues and valid_pspace' and valid_objs'
2015-09-02 05:43:39 +00:00
and st_tcb_at' (op = sendState) sender
and tcb_at' thread and sch_act_not sender
and (\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
2014-07-14 19:32:44 +00:00
(\<forall>d p. sender \<notin> set (ksReadyQueues s (d, p))))"
2015-09-02 05:43:39 +00:00
in hoare_post_imp)
2015-09-10 07:06:45 +00:00
apply (auto simp: sch_act_wf_weak obj_at'_def st_tcb_at'_def
2015-10-21 02:34:22 +00:00
valid_tcb_state'_def cong: if_cong)[1] (*Long*)
2015-09-02 05:43:39 +00:00
apply wp
apply (clarsimp simp: guard_is_UNIV_def option_to_ptr_def option_to_0_def)
2016-10-25 06:01:30 +00:00
apply (clarsimp simp add: to_bool_def split: if_split)
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: guard_is_UNIV_def)
2014-07-14 19:32:44 +00:00
apply (rule_tac Q="\<lambda>rv. valid_queues and valid_pspace' and valid_objs'
and cur_tcb' and tcb_at' sender and tcb_at' thread
and sch_act_not sender and K (thread \<noteq> sender)
and ep_at' (capEPPtr cap)
2016-11-16 03:02:03 +00:00
and (\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
(\<forall>d p. sender \<notin> set (ksReadyQueues s (d, p))))"
2015-09-02 05:43:39 +00:00
in hoare_post_imp)
2015-09-10 07:06:45 +00:00
subgoal by (auto, auto simp: st_tcb_at'_def obj_at'_def)
2014-07-14 19:32:44 +00:00
apply (wp hoare_vcg_all_lift set_ep_valid_objs')
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: guard_is_UNIV_def)
apply (clarsimp simp: EPState_Recv_def EPState_Send_def EPState_Idle_def)
apply (frule(1) ko_at_valid_objs' [OF _ invs_valid_objs'])
apply (clarsimp simp: projectKO_opt_ep split: kernel_object.split_asm)
2017-05-02 01:12:26 +00:00
apply (subgoal_tac "(capEPPtr cap) \<noteq> thread
2015-09-02 05:43:39 +00:00
\<and> state_refs_of' s thread = {r \<in> state_refs_of' s thread. snd r = TCBBound}")
apply (clarsimp simp: valid_obj'_def valid_ep'_def refs_of'_def
split: endpoint.splits)
2015-09-10 07:06:45 +00:00
apply (rename_tac list)
2015-09-02 05:43:39 +00:00
apply (subgoal_tac "state_refs_of' s (capEPPtr cap) = (set list) \<times> {EPRecv}
\<and> thread \<notin> (set list)")
2015-09-10 07:06:45 +00:00
subgoal by (fastforce simp: obj_at'_def is_aligned_neg_mask objBitsKO_def
2015-09-02 05:43:39 +00:00
projectKOs invs'_def valid_state'_def st_tcb_at'_def
2014-07-14 19:32:44 +00:00
valid_tcb_state'_def ko_wp_at'_def invs_valid_objs'
2015-09-02 05:43:39 +00:00
isBlockedOnReceive_def projectKO_opt_tcb
from_bool_def to_bool_def
elim!: delta_sym_refs
2016-10-25 06:01:30 +00:00
split: if_split_asm bool.splits) (*very long*)
2015-09-02 05:43:39 +00:00
apply (frule(1) sym_refs_obj_atD' [OF _ invs_sym'])
apply (clarsimp simp: st_tcb_at'_def ko_wp_at'_def obj_at'_def projectKOs
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2015-09-02 05:43:39 +00:00
apply (drule(1) bspec)+
apply (case_tac "tcbState obj", simp_all add: tcb_bound_refs'_def)[1]
apply (subgoal_tac "state_refs_of' s (capEPPtr cap) = {}")
2015-09-10 07:06:45 +00:00
subgoal by (fastforce simp: obj_at'_def is_aligned_neg_mask objBitsKO_def
2015-09-02 05:43:39 +00:00
projectKOs invs'_def valid_state'_def st_tcb_at'_def
2014-07-14 19:32:44 +00:00
valid_tcb_state'_def ko_wp_at'_def invs_valid_objs'
2015-09-02 05:43:39 +00:00
isBlockedOnReceive_def projectKO_opt_tcb
from_bool_def to_bool_def
elim: delta_sym_refs
2016-10-25 06:01:30 +00:00
split: if_split_asm bool.splits) (*very long *)
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: obj_at'_def state_refs_of'_def projectKOs)
apply (frule(1) sym_refs_ko_atD' [OF _ invs_sym'])
apply (frule invs_queues)
apply clarsimp
2015-09-10 07:06:45 +00:00
apply (rename_tac list x xa)
2015-09-02 05:43:39 +00:00
apply (rule_tac P="x\<in>set list" in case_split)
apply (clarsimp simp:st_tcb_at_refs_of_rev')
2015-09-10 07:06:45 +00:00
apply (erule_tac x=x and P="\<lambda>x. st_tcb_at' P x s" for P in ballE)
2015-09-02 05:43:39 +00:00
apply (drule_tac t=x in valid_queues_not_runnable'_not_ksQ)
apply (clarsimp simp: st_tcb_at'_def obj_at'_def o_def)
apply (subgoal_tac "sch_act_not x s")
prefer 2
apply (frule invs_sch_act_wf')
apply (clarsimp simp:sch_act_wf_def)
apply (clarsimp simp: st_tcb_at'_def obj_at'_def o_def)
apply (clarsimp simp: obj_at'_def st_tcb_at'_def
projectKOs isBlockedOnSend_def
split: list.split | rule conjI)+
apply (clarsimp simp: state_refs_of'_def )
apply (case_tac "tcbState obj", clarsimp+)[1]
apply (clarsimp simp: guard_is_UNIV_def)+
2015-11-02 00:00:32 +00:00
apply (wp getNotification_wp | wpc)+
2015-12-01 05:29:29 +00:00
apply (clarsimp simp add: guard_is_UNIV_def option_to_ptr_def option_to_0_def
2016-10-25 06:01:30 +00:00
split: if_split)
2015-11-02 00:00:32 +00:00
apply (wp gbn_wp' | simp add: guard_is_UNIV_def)+
2015-09-02 05:43:39 +00:00
apply (auto simp: isCap_simps valid_cap'_def)
2015-10-21 02:34:22 +00:00
done
2014-07-14 19:32:44 +00:00
2015-11-02 00:00:32 +00:00
lemma sendSignal_dequeue_ccorres_helper:
2014-07-14 19:32:44 +00:00
"ccorres (\<lambda>rv rv'. rv' = tcb_ptr_to_ctcb_ptr dest) dest_'
2015-11-02 00:00:32 +00:00
(invs' and st_tcb_at' (op = (BlockedOnNotification ntfn)) dest
and ko_at' nTFN ntfn
and K (ntfnObj nTFN = WaitingNtfn (dest # rest))) UNIV hs
(setNotification ntfn $ ntfnObj_update (\<lambda>_. case rest of [] \<Rightarrow> Structures_H.ntfn.IdleNtfn
| (a#list) \<Rightarrow> Structures_H.ntfn.WaitingNtfn rest) nTFN)
(\<acute>ntfn_queue :== CALL ntfn_ptr_get_queue(Ptr ntfn);;
\<acute>dest :== head_C \<acute>ntfn_queue;;
\<acute>ntfn_queue :== CALL tcbEPDequeue(\<acute>dest,\<acute>ntfn_queue);;
CALL ntfn_ptr_set_queue(Ptr ntfn,\<acute>ntfn_queue);;
IF head_C \<acute>ntfn_queue = Ptr 0 THEN
CALL notification_ptr_set_state(Ptr ntfn,scast NtfnState_Idle)
2014-07-14 19:32:44 +00:00
FI)"
2015-09-02 05:43:39 +00:00
2014-07-14 19:32:44 +00:00
apply (rule ccorres_from_vcg)
apply (rule allI)
apply (rule conseqPre, vcg)
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split simp del: comp_def)
2015-11-02 00:00:32 +00:00
apply (frule (2) ntfn_blocked_in_queueD)
apply (frule (1) ko_at_valid_ntfn' [OF _ invs_valid_objs'])
2014-07-14 19:32:44 +00:00
apply (elim conjE)
2015-11-02 00:00:32 +00:00
apply (frule (1) valid_ntfn_isWaitingNtfnD)
2014-07-14 19:32:44 +00:00
apply (elim conjE)
2015-11-02 00:00:32 +00:00
apply (frule cmap_relation_ntfn)
2014-07-14 19:32:44 +00:00
apply (erule (1) cmap_relation_ko_atE)
apply (intro conjI)
apply (erule h_t_valid_clift)
apply (rule impI)
apply (rule exI)
apply (rule conjI)
apply (rule_tac x=\<sigma> in exI)
apply (intro conjI)
apply assumption+
apply clarsimp
2015-11-02 00:00:32 +00:00
apply (drule ntfn_to_ep_queue, (simp add: isWaitingNtfn_def)+)
2014-07-14 19:32:44 +00:00
apply (simp add: tcb_queue_relation'_def)
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: typ_heap_simps cnotification_relation_def Let_def
2016-10-25 06:01:30 +00:00
cong: imp_cong split del: if_split simp del: comp_def)
2014-07-14 19:32:44 +00:00
apply (intro conjI impI allI)
apply (fastforce simp: h_t_valid_clift)
apply (fastforce simp: h_t_valid_clift)
-- "empty case"
apply clarsimp
apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
apply (frule iffD1 [OF tcb_queue_head_empty_iff
[OF tcb_queue_relation'_queue_rel]])
apply (rule ballI, erule bspec)
apply (erule subsetD [rotated])
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: cnotification_relation_def Let_def
2014-07-14 19:32:44 +00:00
tcb_queue_relation'_def)
apply simp
2015-11-02 00:00:32 +00:00
apply (simp add: setNotification_def split_def)
2014-07-14 19:32:44 +00:00
apply (rule conjI)
apply (rule bexI [OF _ setObject_eq])
apply (simp add: rf_sr_def cstate_relation_def Let_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ntfn_map_tos
typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (elim conjE)
apply (intro conjI)
-- "tcb relation"
apply (erule ctcb_relation_null_queue_ptrs)
apply (clarsimp simp: comp_def)
-- "ep relation"
apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
apply simp
2015-11-02 00:00:32 +00:00
apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+)
2015-09-02 05:43:39 +00:00
apply simp+
2014-07-14 19:32:44 +00:00
apply (erule (1) map_to_ko_atI')
2015-11-02 00:00:32 +00:00
-- "ntfn relation"
apply (rule cpspace_relation_ntfn_update_ntfn, assumption+)
apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def
2014-07-14 19:32:44 +00:00
tcb_queue_relation'_def)
apply simp
-- "queue relation"
apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
apply (clarsimp simp: comp_def)
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: cmachine_state_relation_def)
apply (simp add: h_t_valid_clift_Some_iff)
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: cnotification_relation_def Let_def
2014-07-14 19:32:44 +00:00
tcb_queue_relation'_def)
-- "non-empty case"
apply clarsimp
apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
apply (frule tcb_queue_head_empty_iff [OF tcb_queue_relation'_queue_rel])
apply (rule ballI, erule bspec)
apply (erule subsetD [rotated])
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: cnotification_relation_def Let_def
2014-07-14 19:32:44 +00:00
tcb_queue_relation'_def)
2015-11-02 00:00:32 +00:00
apply (simp add: setNotification_def split_def)
2014-07-14 19:32:44 +00:00
apply (rule conjI)
apply (rule bexI [OF _ setObject_eq])
apply (frule(1) st_tcb_at_h_t_valid)
apply (simp add: rf_sr_def cstate_relation_def Let_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ntfn_map_tos
typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (elim conjE)
apply (intro conjI)
-- "tcb relation"
apply (erule ctcb_relation_null_queue_ptrs)
apply (clarsimp simp: comp_def)
-- "ep relation"
apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
apply simp
2015-11-02 00:00:32 +00:00
apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+)
2015-09-02 05:43:39 +00:00
apply simp+
2014-07-14 19:32:44 +00:00
apply (erule (1) map_to_ko_atI')
2015-11-02 00:00:32 +00:00
-- "ntfn relation"
apply (rule cpspace_relation_ntfn_update_ntfn, assumption+)
apply (clarsimp simp: cnotification_relation_def Let_def
isWaitingNtfn_def
tcb_queue_relation'_def valid_ntfn'_def
split: Structures_H.notification.splits list.splits
2016-10-25 06:01:30 +00:00
split del: if_split)
2014-09-10 07:26:44 +00:00
apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \<sigma>")
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: is_aligned_neg_mask
dest!: is_aligned_tcb_ptr_to_ctcb_ptr
2016-10-25 06:01:30 +00:00
split del: if_split)
apply (clarsimp split: if_split)
2014-07-14 19:32:44 +00:00
apply simp
-- "queue relation"
apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
apply (clarsimp simp: comp_def)
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: cmachine_state_relation_def)
apply (simp add: h_t_valid_clift_Some_iff)
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: cnotification_relation_def Let_def
2014-07-14 19:32:44 +00:00
tcb_queue_relation'_def)
done
2015-11-02 00:00:32 +00:00
lemma ntfn_set_active_ccorres:
"ccorres dc xfdc (invs' and ko_at' ntfn ntfnptr
and (\<lambda>_. \<not> isWaitingNtfn (ntfnObj ntfn)))
(UNIV \<inter> {s. ntfnPtr_' s = Ptr ntfnptr} \<inter> {s. badge_' s = badge}) hs
(setNotification ntfnptr
(ntfnObj_update (\<lambda>_. Structures_H.ntfn.ActiveNtfn badge) ntfn))
(Call ntfn_set_active_'proc)"
2015-09-02 05:43:39 +00:00
apply (rule ccorres_gen_asm)
2015-11-02 00:00:32 +00:00
apply (cinit lift: ntfnPtr_' badge_')
apply (simp only: setNotification_def)
apply (rule_tac P="ko_at' ntfn ntfnptr and invs'"
2015-09-02 05:43:39 +00:00
in ccorres_from_vcg[where P'=UNIV])
apply (rule allI, rule conseqPre, vcg)
apply clarsimp
2015-11-02 00:00:32 +00:00
apply (rule cmap_relation_ko_atE [OF cmap_relation_ntfn], assumption+)
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: typ_heap_simps)
apply (rule bexI[OF _ setObject_eq], simp_all)
2016-09-21 00:33:03 +00:00
apply (clarsimp simp: typ_heap_simps' rf_sr_def cstate_relation_def Let_def
2015-11-02 00:00:32 +00:00
cpspace_relation_def update_ntfn_map_tos
2015-09-02 05:43:39 +00:00
carch_state_relation_def cmachine_state_relation_def)
2015-11-02 00:00:32 +00:00
apply (rule cpspace_relation_ntfn_update_ntfn, assumption+)
apply (simp add: cnotification_relation_def Let_def NtfnState_Active_def
isWaitingNtfn_def mask_def
split: Structures_H.ntfn.split_asm)
2015-09-02 05:43:39 +00:00
apply (simp add: objBits_simps)+
2014-07-14 19:32:44 +00:00
done
lemma sts_runnable:
"\<lbrace>if t \<noteq> dest then st_tcb_at' runnable' t else st_tcb_at' \<top> t\<rbrace>
2017-05-02 01:12:26 +00:00
setThreadState Structures_H.thread_state.Running dest
2014-07-14 19:32:44 +00:00
\<lbrace>\<lambda>rv. st_tcb_at' runnable' t\<rbrace>"
apply (rule hoare_pre)
apply (wp sts_st_tcb_at'_cases)
apply auto
done
lemma st_tcb'_iff:
"st_tcb_at' \<top> t = tcb_at' t"
by (auto simp:st_tcb_at'_def)
2015-11-02 00:00:32 +00:00
lemma sendSignal_ccorres [corres]:
2015-09-02 05:43:39 +00:00
"ccorres dc xfdc (invs')
2015-11-02 00:00:32 +00:00
(UNIV \<inter> \<lbrace>\<acute>ntfnPtr = Ptr ntfnptr\<rbrace> \<inter> \<lbrace>\<acute>badge = badge\<rbrace>) hs
(sendSignal ntfnptr badge)
(Call sendSignal_'proc)"
apply (cinit lift: ntfnPtr_' badge_')
apply (rule ccorres_pre_getNotification, rename_tac ntfn)
2015-12-08 06:29:42 +00:00
apply (rule_tac xf'=ret__unsigned_'
2015-11-02 00:00:32 +00:00
and val="case ntfnObj ntfn of IdleNtfn \<Rightarrow> scast NtfnState_Idle
| WaitingNtfn _ \<Rightarrow> scast NtfnState_Waiting
| ActiveNtfn _ \<Rightarrow> scast NtfnState_Active"
and R="ko_at' ntfn ntfnptr"
2014-07-14 19:32:44 +00:00
in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
apply (vcg, clarsimp)
2015-11-02 00:00:32 +00:00
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_ntfn])
apply (clarsimp simp: cnotification_relation_def Let_def typ_heap_simps
split: Structures_H.ntfn.splits)
2014-07-14 19:32:44 +00:00
apply ceqv
2017-05-02 01:12:26 +00:00
apply (rule_tac P="ntfnBoundTCB ntfn \<noteq> None \<longrightarrow>
2015-11-02 00:00:32 +00:00
option_to_ctcb_ptr (ntfnBoundTCB ntfn) \<noteq> NULL"
2015-09-02 05:43:39 +00:00
in ccorres_gen_asm)
2014-07-14 19:32:44 +00:00
apply wpc
2015-11-02 00:00:32 +00:00
-- "IdleNtfn case"
2014-07-14 19:32:44 +00:00
apply (rule ccorres_cond_true)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_rhs_assoc)+
2015-12-08 06:29:42 +00:00
apply (rule_tac xf'=ret__unsigned_'
2015-11-02 00:00:32 +00:00
and val="ptr_val (option_to_ctcb_ptr (ntfnBoundTCB ntfn))"
and R="ko_at' ntfn ntfnptr"
2015-09-02 05:43:39 +00:00
in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
apply (rule conseqPre, vcg)
apply clarsimp
2015-11-02 00:00:32 +00:00
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_ntfn])
apply (clarsimp simp: cnotification_relation_def Let_def typ_heap_simps
split: Structures_H.ntfn.splits)
2015-09-02 05:43:39 +00:00
apply ceqv
apply csymbr
apply wpc
2016-10-25 06:01:30 +00:00
apply (simp add: option_to_ctcb_ptr_def split del: if_split)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_cond_false)
2015-11-02 00:00:32 +00:00
apply (ctac add: ntfn_set_active_ccorres[unfolded dc_def])
2015-09-02 05:43:39 +00:00
apply (rule ccorres_cond_true)
apply (rule getThreadState_ccorres_foo)
apply (rule ccorres_Guard_Seq)
apply csymbr
apply (rule ccorres_abstract_cleanup)
2015-12-08 06:29:42 +00:00
apply (rule_tac P="(ret__unsigned = scast ThreadState_BlockedOnReceive)
2015-09-02 05:43:39 +00:00
= receiveBlocked rv" in ccorres_gen_asm2)
apply (rule ccorres_cond[where R=\<top>])
2015-12-01 05:29:29 +00:00
apply (simp add: Collect_const_mem)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_rhs_assoc)+
apply simp
2015-11-02 00:00:32 +00:00
apply (ctac(no_vcg) add: cancelIPC_ccorres1[OF cteDeleteOne_ccorres])
2015-09-02 05:43:39 +00:00
apply (ctac(no_vcg) add: setThreadState_ccorres)
apply (ctac(no_vcg) add: setRegister_ccorres)
apply (ctac add: switchIfRequiredTo_ccorres[unfolded dc_def])
apply (wp sts_running_valid_queues sts_st_tcb_at'_cases
2016-10-25 06:01:30 +00:00
| simp add: option_to_ctcb_ptr_def split del: if_split)+
2015-11-02 00:00:32 +00:00
apply (rule_tac Q="\<lambda>_. tcb_at' (the (ntfnBoundTCB ntfn)) and invs'"
2015-09-02 05:43:39 +00:00
in hoare_post_imp)
apply auto[1]
apply wp
apply simp
2015-11-02 00:00:32 +00:00
apply (ctac add: ntfn_set_active_ccorres[unfolded dc_def])
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: guard_is_UNIV_def option_to_ctcb_ptr_def
2016-05-01 03:35:49 +00:00
ARM_H.badgeRegister_def Kernel_C.badgeRegister_def
2016-05-05 22:59:33 +00:00
ARM.badgeRegister_def Kernel_C.R0_def
2015-12-01 05:29:29 +00:00
"StrictC'_thread_state_defs"less_mask_eq
Collect_const_mem)
2015-09-02 05:43:39 +00:00
apply (case_tac ts, simp_all add: receiveBlocked_def typ_heap_simps
cthread_state_relation_def "StrictC'_thread_state_defs")[1]
2015-11-02 00:00:32 +00:00
-- "ActiveNtfn case"
2015-09-02 05:43:39 +00:00
apply (rename_tac old_badge)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_cond_false)
apply (rule ccorres_cond_false)
apply (rule ccorres_cond_true)
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: setNotification_def)
apply (rule_tac P="invs' and ko_at' ntfn ntfnptr"
2014-07-14 19:32:44 +00:00
and P'=UNIV
in ccorres_from_vcg)
apply (rule allI)
apply (rule conseqPre, vcg)
apply clarsimp
2015-11-02 00:00:32 +00:00
apply (frule(1) cmap_relation_ko_atD [OF cmap_relation_ntfn])
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: typ_heap_simps)
apply (rule bexI [OF _ setObject_eq])
apply (simp add: rf_sr_def cstate_relation_def Let_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ntfn_map_tos
typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (elim conjE)
apply (intro conjI)
2015-11-02 00:00:32 +00:00
apply (rule cpspace_relation_ntfn_update_ntfn, assumption+)
apply (simp add: cnotification_relation_def Let_def
NtfnState_Active_def mask_def word_bw_comms)
2014-07-14 19:32:44 +00:00
apply simp
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: cmachine_state_relation_def)
apply (simp add: h_t_valid_clift_Some_iff)
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
2015-11-02 00:00:32 +00:00
-- "WaitingNtfn case"
2014-07-14 19:32:44 +00:00
apply (rule ccorres_cond_false)
apply (rule ccorres_cond_true)
apply wpc
apply (simp only: haskell_fail_def)
apply (rule ccorres_fail)
apply (rename_tac dest rest)
apply (intro ccorres_rhs_assoc)
apply (csymbr, csymbr)
apply (intro ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc)
apply (rule ccorres_rhs_assoc)
apply (rule ccorres_split_nothrow_novcg)
apply (simp only: )
2015-11-02 00:00:32 +00:00
apply (rule_tac dest=dest in sendSignal_dequeue_ccorres_helper)
2014-07-14 19:32:44 +00:00
apply ceqv
apply (simp only: K_bind_def)
apply (ctac (no_vcg))
2015-09-02 05:43:39 +00:00
apply (simp, fold dc_def)
2014-07-14 19:32:44 +00:00
apply (ctac (no_vcg))
apply ctac
2015-09-02 05:43:39 +00:00
apply (simp)
2014-07-14 19:32:44 +00:00
apply (wp weak_sch_act_wf_lift_linear
setThreadState_oa_queued
sts_valid_queues tcb_in_cur_domain'_lift)[1]
apply (wp sts_valid_queues sts_runnable)
2015-11-02 00:00:32 +00:00
apply (wp setThreadState_st_tcb set_ntfn_valid_objs' | clarsimp)+
2017-05-02 01:12:26 +00:00
apply (clarsimp simp: guard_is_UNIV_def ThreadState_Running_def mask_def
badgeRegister_def Kernel_C.badgeRegister_def
2016-05-05 22:59:33 +00:00
ARM.badgeRegister_def Kernel_C.R0_def)
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: guard_is_UNIV_def NtfnState_Idle_def
NtfnState_Active_def NtfnState_Waiting_def)
2017-05-02 01:12:26 +00:00
apply clarsimp
2015-09-02 05:43:39 +00:00
apply (simp only: conj_assoc[symmetric])
apply (rule conjI)
apply (frule ko_at_valid_objs', (clarsimp simp: projectKOs)+)
2017-05-02 01:12:26 +00:00
apply (clarsimp simp: valid_obj'_def)
2015-11-02 00:00:32 +00:00
apply (auto simp: isWaitingNtfn_def st_tcb_at_refs_of_rev' valid_obj'_def valid_ntfn'_def
2017-05-02 01:12:26 +00:00
dest!: sym_refs_obj_atD' [OF _ invs_sym']
2015-09-02 05:43:39 +00:00
elim: pred_tcb'_weakenE
split: list.splits option.splits)[1]
2017-05-02 01:12:26 +00:00
apply (clarsimp simp: option_to_ctcb_ptr_def tcb_ptr_to_ctcb_ptr_def
2015-09-02 05:43:39 +00:00
ctcb_offset_def
dest!: sum_to_zero)
2015-11-02 00:00:32 +00:00
apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs'])
2017-05-02 01:12:26 +00:00
apply (auto simp: valid_ntfn'_def valid_bound_tcb'_def obj_at'_def projectKOs
2015-09-02 05:43:39 +00:00
objBitsKO_def is_aligned_def)
2014-07-14 19:32:44 +00:00
done
2015-11-02 00:00:32 +00:00
lemma receiveSignal_block_ccorres_helper:
2014-07-14 19:32:44 +00:00
"ccorres dc xfdc (tcb_at' thread and valid_queues and sch_act_not thread and
2015-11-02 00:00:32 +00:00
valid_objs' and ntfn_at' ntfnptr and
2014-07-14 19:32:44 +00:00
(\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
(\<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))) and
2015-11-02 00:00:32 +00:00
K (ntfnptr = ntfnptr && ~~ mask 4))
2014-07-14 19:32:44 +00:00
UNIV hs
2015-11-02 00:00:32 +00:00
(setThreadState (Structures_H.thread_state.BlockedOnNotification
ntfnptr) thread)
2015-10-16 00:01:54 +00:00
(Guard C_Guard {s. s \<Turnstile>\<^sub>c tcb_ptr_to_ctcb_ptr thread}
2014-07-14 19:32:44 +00:00
(CALL thread_state_ptr_set_tsType(Ptr
&(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']),
2015-11-02 00:00:32 +00:00
scast ThreadState_BlockedOnNotification));;
2015-10-16 00:01:54 +00:00
Guard C_Guard {s. s \<Turnstile>\<^sub>c tcb_ptr_to_ctcb_ptr thread}
2015-11-02 00:00:32 +00:00
(CALL thread_state_ptr_set_blockingObject(Ptr
2014-07-14 19:32:44 +00:00
&(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']),
2015-11-02 00:00:32 +00:00
ucast (ptr_val (ntfn_Ptr ntfnptr))));;
2014-07-14 19:32:44 +00:00
CALL scheduleTCB(tcb_ptr_to_ctcb_ptr thread))"
unfolding K_def setThreadState_def
apply (intro ccorres_gen_asm)
apply (rule ccorres_guard_imp)
apply (rule ccorres_split_nothrow_novcg)
apply (rule_tac P=\<top> and P'="tcb_at' thread"
in threadSet_ccorres_lemma3)
apply vcg
apply clarsimp
apply (frule(1) tcb_at_h_t_valid)
apply (frule h_t_valid_c_guard)
2016-09-21 00:33:03 +00:00
apply (clarsimp simp: typ_heap_simps' rf_sr_tcb_update_twice)
apply (erule(1) rf_sr_tcb_update_no_queue_gen,
(simp add: typ_heap_simps')+)
2014-07-14 19:32:44 +00:00
apply (simp add: tcb_cte_cases_def)
apply (simp add: ctcb_relation_def cthread_state_relation_def
2015-11-02 00:00:32 +00:00
ThreadState_BlockedOnNotification_def mask_def
2014-07-14 19:32:44 +00:00
from_bool_def to_bool_def)
apply ceqv
apply clarsimp
apply ctac
apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs'
threadSet_weak_sch_act_wf_runnable')
apply (clarsimp simp: guard_is_UNIV_def)
apply (auto simp: weak_sch_act_wf_def valid_tcb'_def tcb_cte_cases_def
valid_tcb_state'_def)
done
2015-11-02 00:00:32 +00:00
lemma cpspace_relation_ntfn_update_ntfn':
fixes ntfn :: "Structures_H.notification" and ntfn' :: "Structures_H.notification"
and ntfnptr :: "word32" and s :: "kernel_state"
defines "qs \<equiv> if isWaitingNtfn (ntfnObj ntfn') then set (ntfnQueue (ntfnObj ntfn')) else {}"
defines "s' \<equiv> s\<lparr>ksPSpace := ksPSpace s(ntfnptr \<mapsto> KONotification ntfn')\<rparr>"
assumes koat: "ko_at' ntfn ntfnptr s"
2014-07-14 19:32:44 +00:00
and vp: "valid_pspace' s"
2015-11-02 00:00:32 +00:00
and cp: "cmap_relation (map_to_ntfns (ksPSpace s)) (cslift t) Ptr (cnotification_relation (cslift t))"
2014-07-14 19:32:44 +00:00
and srs: "sym_refs (state_refs_of' s')"
2015-11-02 00:00:32 +00:00
and rel: "cnotification_relation (cslift t') ntfn' notification"
2014-07-14 19:32:44 +00:00
and mpeq: "(cslift t' |` (- (tcb_ptr_to_ctcb_ptr ` qs))) = (cslift t |` (- (tcb_ptr_to_ctcb_ptr ` qs)))"
2015-11-02 00:00:32 +00:00
shows "cmap_relation (map_to_ntfns (ksPSpace s(ntfnptr \<mapsto> KONotification ntfn')))
(cslift t(Ptr ntfnptr \<mapsto> notification)) Ptr
(cnotification_relation (cslift t'))"
2014-07-14 19:32:44 +00:00
proof -
2015-11-02 00:00:32 +00:00
from koat have koat': "ko_at' ntfn' ntfnptr s'"
2014-07-14 19:32:44 +00:00
by (clarsimp simp: obj_at'_def s'_def objBitsKO_def ps_clear_def projectKOs)
2017-05-02 01:12:26 +00:00
2015-11-02 00:00:32 +00:00
have ntfns':
"\<And>x. x \<noteq> ntfnptr \<Longrightarrow> map_to_ntfns (ksPSpace s) x =
map_to_ntfns (ksPSpace s') x"
2014-07-14 19:32:44 +00:00
unfolding s'_def
2015-11-02 00:00:32 +00:00
by (fastforce intro: ssubst [OF map_comp_update] simp: projectKO_opt_ntfn)
2014-07-14 19:32:44 +00:00
from koat have map_to_ko_atI'':
2015-11-02 00:00:32 +00:00
"\<And>x y. \<lbrakk> x \<noteq> ntfnptr; map_to_ntfns (ksPSpace s) x = Some y \<rbrakk> \<Longrightarrow> ko_at' y x s'"
2014-07-14 19:32:44 +00:00
using vp unfolding s'_def
2015-11-02 00:00:32 +00:00
by (simp add: map_to_ko_at_updI' injectKO_ntfn objBitsKO_def)
2014-07-14 19:32:44 +00:00
thus ?thesis using vp srs cp rel mpeq unfolding cmap_relation_def
apply -
apply (elim conjE)
2015-12-01 22:07:49 +00:00
apply (clarsimp elim!: obj_atE' simp: map_comp_update projectKO_opts_defs
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
apply (drule (1) bspec [OF _ domI])
apply simp
2015-11-02 00:00:32 +00:00
apply (erule(1) cnotification_relation_ntfn_queue [OF _ _ koat'])
2014-07-14 19:32:44 +00:00
apply (erule(1) map_to_ko_atI'')
apply (fold qs_def, rule mpeq)
apply assumption
done
qed
2015-11-02 00:00:32 +00:00
lemma ntfn_q_refs_of_no_NTFNBound':
"(x, NTFNBound) \<notin> ntfn_q_refs_of' ntfn"
by (auto simp: ntfn_q_refs_of'_def split: Structures_H.ntfn.splits)
2015-09-02 05:43:39 +00:00
2015-11-02 00:00:32 +00:00
lemma ntfnBound_state_refs_equivalence:
"ko_at' ntfn ntfnptr s \<Longrightarrow> {r \<in> state_refs_of' s ntfnptr. snd r = NTFNBound} = ntfn_bound_refs' (ntfnBoundTCB ntfn)"
by (auto simp: ko_at_state_refs_ofD' set_eq_subset ntfn_q_refs_of_no_NTFNBound' ntfn_bound_refs'_def)
2017-05-02 01:12:26 +00:00
2015-09-02 05:43:39 +00:00
2015-11-02 00:00:32 +00:00
lemma receiveSignal_enqueue_ccorres_helper:
2015-05-20 10:39:47 +00:00
notes option.case_cong_weak [cong]
shows
2014-07-14 19:32:44 +00:00
"ccorres dc xfdc (valid_pspace'
2015-11-02 00:00:32 +00:00
and (\<lambda>s. sym_refs ((state_refs_of' s)(ntfnptr := set queue \<times> {NTFNSignal} \<union> {r \<in> state_refs_of' s ntfnptr. snd r = NTFNBound})))
and st_tcb_at' (\<lambda>st. isBlockedOnNotification st \<and>
waitingOnNotification st = ntfnptr) thread
and ko_at' (ntfn::Structures_H.notification) ntfnptr
and K ((ntfnObj ntfn = IdleNtfn \<and> queue = [thread]) \<or>
(\<exists>q. ntfnObj ntfn = WaitingNtfn q \<and> thread \<notin> set q \<and>
2014-07-14 19:32:44 +00:00
queue = q @ [thread])))
UNIV hs
2015-11-02 00:00:32 +00:00
(setNotification ntfnptr $ ntfnObj_update (\<lambda>_. Structures_H.WaitingNtfn queue) ntfn)
(\<acute>ntfn_queue :== CALL ntfn_ptr_get_queue(ntfn_Ptr ntfnptr);;
(\<acute>ntfn_queue :== CALL tcbEPAppend(tcb_ptr_to_ctcb_ptr thread,\<acute>ntfn_queue);;
(CALL notification_ptr_set_state(ntfn_Ptr ntfnptr, scast NtfnState_Waiting);;
CALL ntfn_ptr_set_queue(ntfn_Ptr ntfnptr,\<acute>ntfn_queue))))"
2014-07-14 19:32:44 +00:00
unfolding K_def
apply (rule ccorres_gen_asm)
apply (rule ccorres_from_vcg)
apply (rule allI, rule conseqPre, vcg)
2016-10-25 06:01:30 +00:00
apply (clarsimp split del: if_split simp del: comp_def)
2015-11-02 00:00:32 +00:00
apply (frule cmap_relation_ntfn)
2014-07-14 19:32:44 +00:00
apply (erule (1) cmap_relation_ko_atE)
apply (rule conjI)
apply (erule h_t_valid_clift)
apply (frule(1) st_tcb_at_h_t_valid)
2015-09-02 05:43:39 +00:00
apply (frule pred_tcb_at')
2014-07-14 19:32:44 +00:00
apply (rule impI)
apply (rule_tac x="init queue" in exI)
2015-11-02 00:00:32 +00:00
apply (frule(1) ko_at_valid_ntfn' [OF _ valid_pspace_valid_objs'])
2014-07-14 19:32:44 +00:00
apply (frule is_aligned_tcb_ptr_to_ctcb_ptr)
apply (rule conjI)
apply (rule_tac x=\<sigma> in exI)
2015-11-02 00:00:32 +00:00
apply (simp add: cnotification_relation_def Let_def)
apply (case_tac "ntfnObj ntfn", simp_all add: init_def valid_ntfn'_def)[1]
2014-07-14 19:32:44 +00:00
apply (subgoal_tac "sym_refs (state_refs_of' (\<sigma>\<lparr>ksPSpace :=
2015-11-02 00:00:32 +00:00
ksPSpace \<sigma>(ntfnptr \<mapsto> KONotification (NTFN (WaitingNtfn queue) (ntfnBoundTCB ntfn)))\<rparr>))")
2014-07-14 19:32:44 +00:00
prefer 2
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: state_refs_of'_upd ko_wp_at'_def ntfnBound_state_refs_equivalence
2014-07-14 19:32:44 +00:00
obj_at'_def projectKOs objBitsKO_def)
2015-11-02 00:00:32 +00:00
apply (subgoal_tac "ko_at' (NTFN (WaitingNtfn queue) (ntfnBoundTCB ntfn)) ntfnptr (\<sigma>\<lparr>ksPSpace :=
ksPSpace \<sigma>(ntfnptr \<mapsto> KONotification (NTFN (WaitingNtfn queue) (ntfnBoundTCB ntfn)))\<rparr>)")
2014-07-14 19:32:44 +00:00
prefer 2
apply (clarsimp simp: obj_at'_def projectKOs objBitsKO_def ps_clear_upd)
apply (intro conjI impI allI)
apply (fastforce simp: h_t_valid_clift)
apply (fastforce simp: h_t_valid_clift)
2015-11-02 00:00:32 +00:00
apply (case_tac "ntfnObj ntfn", simp_all add: NtfnState_Idle_def NtfnState_Waiting_def)[1]
-- "IdleNtfn case"
2014-07-14 19:32:44 +00:00
apply clarsimp
apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
2015-11-02 00:00:32 +00:00
apply (simp add: setNotification_def split_def)
2014-07-14 19:32:44 +00:00
apply (rule bexI [OF _ setObject_eq])
apply (simp add: rf_sr_def cstate_relation_def Let_def init_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ntfn_map_tos
typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (elim conjE)
apply (intro conjI)
-- "tcb relation"
apply (erule ctcb_relation_null_queue_ptrs)
apply (clarsimp simp: comp_def)
-- "ep relation"
apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
apply simp
2015-11-02 00:00:32 +00:00
apply (rule cendpoint_relation_ntfn_queue, assumption+)
apply (simp add: isWaitingNtfn_def)
2014-07-14 19:32:44 +00:00
apply simp
apply (frule_tac x=p in map_to_ko_atI2, clarsimp, clarsimp)
apply (erule(2) map_to_ko_at_updI')
apply (clarsimp simp: objBitsKO_def)
apply (clarsimp simp: obj_at'_def projectKOs)
2015-11-02 00:00:32 +00:00
-- "ntfn relation"
apply (rule cpspace_relation_ntfn_update_ntfn', assumption+)
apply (case_tac "ntfn", simp_all)[1]
2017-05-02 01:12:26 +00:00
apply (clarsimp simp: cnotification_relation_def Let_def
2015-11-02 00:00:32 +00:00
mask_def [where n=2] NtfnState_Waiting_def)
2015-10-16 00:01:54 +00:00
subgoal by (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask
2015-11-02 00:00:32 +00:00
valid_ntfn'_def
2014-07-14 19:32:44 +00:00
dest: tcb_queue_relation_next_not_NULL)
2015-11-02 00:00:32 +00:00
apply (simp add: isWaitingNtfn_def)
2014-07-14 19:32:44 +00:00
-- "queue relation"
apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
2015-09-10 07:06:45 +00:00
subgoal by (clarsimp simp: comp_def)
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: cmachine_state_relation_def)
apply (simp add: h_t_valid_clift_Some_iff)
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
2015-11-02 00:00:32 +00:00
-- "WaitingNtfn case"
2014-07-14 19:32:44 +00:00
apply clarsimp
apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
2015-11-02 00:00:32 +00:00
apply (simp add: setNotification_def split_def)
2014-07-14 19:32:44 +00:00
apply (rule bexI [OF _ setObject_eq])
apply (simp add: rf_sr_def cstate_relation_def init_def Let_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ntfn_map_tos
typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (elim conjE)
apply (intro conjI)
-- "tcb relation"
apply (erule ctcb_relation_null_queue_ptrs)
apply (clarsimp simp: comp_def)
-- "ep relation"
apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
apply simp
2015-11-02 00:00:32 +00:00
apply (rule cendpoint_relation_ntfn_queue, assumption+)
apply (simp add: isWaitingNtfn_def)
2014-07-14 19:32:44 +00:00
apply simp
apply (frule_tac x=p in map_to_ko_atI2, clarsimp, clarsimp)
apply (erule(2) map_to_ko_at_updI')
apply (clarsimp simp: objBitsKO_def)
apply (clarsimp simp: obj_at'_def projectKOs)
2015-11-02 00:00:32 +00:00
-- "ntfn relation"
apply (rule cpspace_relation_ntfn_update_ntfn', assumption+)
apply (case_tac "ntfn", simp_all)[1]
apply (clarsimp simp: cnotification_relation_def Let_def
2015-12-01 22:07:49 +00:00
mask_def [where n=2] NtfnState_Waiting_def
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask)
2015-11-02 00:00:32 +00:00
apply (simp add: isWaitingNtfn_def)
2014-07-14 19:32:44 +00:00
-- "queue relation"
apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
apply (clarsimp simp: comp_def)
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: cmachine_state_relation_def)
apply (simp add: h_t_valid_clift_Some_iff)
apply (simp add: objBits_simps)
apply (simp add: objBits_simps)
apply assumption
done
2015-11-02 00:00:32 +00:00
lemma receiveSignal_ccorres [corres]:
2014-07-14 19:32:44 +00:00
"ccorres dc xfdc (invs' and valid_cap' cap and st_tcb_at' simple' thread
and sch_act_not thread
and (\<lambda>s. \<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))
2015-11-02 00:00:32 +00:00
and K (isNotificationCap cap))
2014-07-14 19:32:44 +00:00
(UNIV \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>
2015-10-16 00:01:54 +00:00
\<inter> \<lbrace>ccap_relation cap \<acute>cap\<rbrace>
\<inter> {s. isBlocking_' s = from_bool is_blocking}) hs
2015-11-02 00:00:32 +00:00
(receiveSignal thread cap is_blocking)
(Call receiveSignal_'proc)"
2014-07-14 19:32:44 +00:00
unfolding K_def
apply (rule ccorres_gen_asm)
2015-10-16 00:01:54 +00:00
apply (cinit lift: thread_' cap_' isBlocking_')
2015-11-02 00:00:32 +00:00
apply (rule ccorres_pre_getNotification, rename_tac ntfn)
2015-12-08 06:29:42 +00:00
apply (rule_tac xf'=ret__unsigned_'
2015-11-02 00:00:32 +00:00
and val="capNtfnPtr cap"
2014-07-14 19:32:44 +00:00
and R=\<top>
in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
apply vcg
apply (clarsimp simp: cap_get_tag_isCap isCap_simps)
apply (frule cap_get_tag_isCap_unfolded_H_cap)
2015-11-02 00:00:32 +00:00
apply (simp add: cap_notification_cap_lift ccap_relation_def cap_to_H_def)
2014-07-14 19:32:44 +00:00
apply ceqv
apply csymbr
2015-12-08 06:29:42 +00:00
apply (rule_tac xf'=ret__unsigned_'
2015-11-02 00:00:32 +00:00
and val="case ntfnObj ntfn of IdleNtfn \<Rightarrow> scast NtfnState_Idle
| WaitingNtfn _ \<Rightarrow> scast NtfnState_Waiting
| ActiveNtfn _ \<Rightarrow> scast NtfnState_Active"
and R="ko_at' ntfn (capNtfnPtr cap)"
2014-07-14 19:32:44 +00:00
in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
apply (vcg, clarsimp)
2015-11-02 00:00:32 +00:00
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_ntfn])
apply (clarsimp simp: cnotification_relation_def Let_def typ_heap_simps
split: Structures_H.ntfn.splits)
2015-09-02 05:43:39 +00:00
2014-07-14 19:32:44 +00:00
apply ceqv
apply wpc
2015-11-02 00:00:32 +00:00
-- "IdleNtfn case"
2014-07-14 19:32:44 +00:00
apply (rule ccorres_cond_true)
apply csymbr
2015-10-16 00:01:54 +00:00
apply (simp only: case_bool_If from_bool_neq_0)
apply (rule ccorres_Cond_rhs, simp cong: Collect_cong)
apply (intro ccorres_rhs_assoc)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_split_nothrow_novcg)
apply (simp)
2015-11-02 00:00:32 +00:00
apply (rule receiveSignal_block_ccorres_helper[simplified])
2015-10-16 00:01:54 +00:00
apply ceqv
apply (simp only: K_bind_def)
2015-11-02 00:00:32 +00:00
apply (rule receiveSignal_enqueue_ccorres_helper[unfolded dc_def, simplified])
apply (simp add: valid_ntfn'_def)
2015-10-16 00:01:54 +00:00
apply (wp sts_st_tcb')
2015-11-02 00:00:32 +00:00
apply (rule_tac Q="\<lambda>rv. ko_wp_at' (\<lambda>x. projectKO_opt x = Some ntfn
2015-10-16 00:01:54 +00:00
\<and> projectKO_opt x = (None::tcb option))
2015-11-02 00:00:32 +00:00
(capNtfnPtr cap)"
2015-10-16 00:01:54 +00:00
in hoare_post_imp)
apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs)
apply wp
apply (clarsimp simp: guard_is_UNIV_def)
apply simp
2015-11-10 15:25:02 +00:00
apply (ctac add: doNBRecvFailedTransfer_ccorres[unfolded dc_def])
2015-11-02 00:00:32 +00:00
-- "ActiveNtfn case"
2015-09-02 05:43:39 +00:00
apply (rename_tac badge)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_cond_false)
apply (rule ccorres_cond_true)
apply (intro ccorres_rhs_assoc)
apply (rule_tac val=badge
2015-12-08 06:29:42 +00:00
and xf'=ret__unsigned_'
2015-11-02 00:00:32 +00:00
and R="ko_at' ntfn (capNtfnPtr cap)"
2014-07-14 19:32:44 +00:00
in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
apply (vcg, clarsimp)
2015-11-02 00:00:32 +00:00
apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_ntfn])
apply (clarsimp simp: cnotification_relation_def Let_def typ_heap_simps
split: Structures_H.notification.splits)
2014-07-14 19:32:44 +00:00
apply ceqv
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: badgeRegister_def Kernel_C.badgeRegister_def, ctac(no_vcg))
2015-11-02 00:00:32 +00:00
apply (rule_tac P="invs' and ko_at' ntfn (capNtfnPtr cap)"
2015-09-02 05:43:39 +00:00
and P'=UNIV
in ccorres_from_vcg)
apply (rule allI, rule conseqPre, vcg)
apply clarsimp
2015-11-02 00:00:32 +00:00
apply (frule(1) cmap_relation_ko_atD [OF cmap_relation_ntfn])
apply (clarsimp simp: typ_heap_simps setNotification_def)
2015-09-02 05:43:39 +00:00
apply (rule bexI [OF _ setObject_eq])
apply (simp add: rf_sr_def cstate_relation_def Let_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ntfn_map_tos
typ_heap_simps')
2015-09-02 05:43:39 +00:00
apply (elim conjE)
apply (intro conjI)
2015-11-02 00:00:32 +00:00
apply (rule cpspace_relation_ntfn_update_ntfn, assumption+)
apply (simp add: cnotification_relation_def Let_def
NtfnState_Idle_def mask_def)
2015-09-02 05:43:39 +00:00
apply simp
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2015-09-02 05:43:39 +00:00
apply (simp add: cmachine_state_relation_def)
apply (simp add: h_t_valid_clift_Some_iff)
2014-07-14 19:32:44 +00:00
apply (simp add: objBits_simps)
2015-09-02 05:43:39 +00:00
apply (simp add: objBits_simps)
apply assumption
apply wp
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: guard_is_UNIV_def)
2016-05-05 22:59:33 +00:00
apply (clarsimp simp: ARM.badgeRegister_def Kernel_C.R0_def)
2015-11-02 00:00:32 +00:00
-- "WaitingNtfn case"
2015-05-20 10:39:47 +00:00
apply (rename_tac list)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_cond_true)
apply csymbr
2015-10-16 00:01:54 +00:00
apply (simp only: case_bool_If from_bool_neq_0)
apply (rule ccorres_Cond_rhs, simp cong: Collect_cong)
apply (intro ccorres_rhs_assoc)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_split_nothrow_novcg)
apply (simp only: )
2015-11-02 00:00:32 +00:00
apply (rule receiveSignal_block_ccorres_helper[simplified])
2015-10-16 00:01:54 +00:00
apply ceqv
apply (simp only: K_bind_def)
2015-11-02 00:00:32 +00:00
apply (rule_tac ntfn="ntfn"
in receiveSignal_enqueue_ccorres_helper[unfolded dc_def, simplified])
apply (simp add: valid_ntfn'_def)
2015-10-16 00:01:54 +00:00
apply (wp sts_st_tcb')
2015-11-02 00:00:32 +00:00
apply (rule_tac Q="\<lambda>rv. ko_wp_at' (\<lambda>x. projectKO_opt x = Some ntfn
2015-10-16 00:01:54 +00:00
\<and> projectKO_opt x = (None::tcb option))
2015-11-02 00:00:32 +00:00
(capNtfnPtr cap)
2015-10-16 00:01:54 +00:00
and K (thread \<notin> set list)"
in hoare_post_imp)
apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs)
apply wp
apply (clarsimp simp: guard_is_UNIV_def)
apply simp
2015-11-10 15:25:02 +00:00
apply (ctac add: doNBRecvFailedTransfer_ccorres[unfolded dc_def])
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: guard_is_UNIV_def NtfnState_Active_def
NtfnState_Waiting_def NtfnState_Idle_def)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: guard_is_UNIV_def)
2016-10-25 06:01:30 +00:00
apply (clarsimp split: if_split)
2015-09-02 05:43:39 +00:00
apply (rule conjI)
2017-05-02 01:12:26 +00:00
apply (clarsimp dest!: st_tcb_strg'[rule_format]
2015-11-02 00:00:32 +00:00
simp: isNotificationCap_def valid_cap'_def obj_at'_def projectKOs
2016-10-25 06:01:30 +00:00
split: capability.splits split del: if_split)
2015-09-02 05:43:39 +00:00
apply clarsimp
2014-07-14 19:32:44 +00:00
apply (frule(1) ko_at_valid_objs' [OF _ invs_valid_objs'])
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: projectKO_opt_ntfn split: kernel_object.split_asm)
2015-09-02 05:43:39 +00:00
apply (subgoal_tac "state_refs_of' s thread = {r \<in> state_refs_of' s thread. snd r = TCBBound}")
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: valid_obj'_def valid_ntfn'_def refs_of'_def
split: ntfn.splits)
2017-05-02 01:12:26 +00:00
apply (subgoal_tac "state_refs_of' s (capNtfnPtr cap) =
{r \<in> state_refs_of' s (capNtfnPtr cap). snd r = NTFNBound}")
2015-09-10 07:06:45 +00:00
subgoal by (fastforce simp: obj_at'_def is_aligned_neg_mask objBitsKO_def
2015-09-02 05:43:39 +00:00
projectKOs invs'_def valid_state'_def st_tcb_at'_def
valid_tcb_state'_def ko_wp_at'_def
2015-11-02 00:00:32 +00:00
isBlockedOnNotification_def projectKO_opt_tcb
2015-09-02 05:43:39 +00:00
elim: delta_sym_refs
2016-10-25 06:01:30 +00:00
split: if_split_asm if_split)
2015-11-02 00:00:32 +00:00
apply (auto simp: obj_at'_def state_refs_of'_def projectKOs ntfn_bound_refs'_def)[1]
2015-05-20 10:39:47 +00:00
apply (rename_tac list)
2017-05-02 01:12:26 +00:00
apply (subgoal_tac "state_refs_of' s (capNtfnPtr cap) = (set list) \<times> {NTFNSignal}
\<union> {r \<in> state_refs_of' s (capNtfnPtr cap). snd r = NTFNBound}
2015-09-02 05:43:39 +00:00
\<and> thread \<notin> (set list)")
2015-09-10 07:06:45 +00:00
subgoal by (fastforce simp: obj_at'_def is_aligned_neg_mask objBitsKO_def
2014-07-14 19:32:44 +00:00
projectKOs invs'_def valid_state'_def st_tcb_at'_def
valid_tcb_state'_def ko_wp_at'_def
2015-11-02 00:00:32 +00:00
isBlockedOnNotification_def projectKO_opt_tcb
2014-07-14 19:32:44 +00:00
elim: delta_sym_refs
2016-10-25 06:01:30 +00:00
split: if_split_asm if_split)
2014-07-14 19:32:44 +00:00
apply (frule(1) sym_refs_obj_atD' [OF _ invs_sym'])
2015-11-02 00:00:32 +00:00
apply (rule conjI, clarsimp simp: ko_wp_at'_def dest!: ntfnBound_state_refs_equivalence)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: st_tcb_at'_def ko_wp_at'_def obj_at'_def projectKOs
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2014-07-14 19:32:44 +00:00
apply (drule(1) bspec)+
2015-11-02 00:00:32 +00:00
apply (drule_tac x="(thread, NTFNSignal)" in bspec, clarsimp)
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: tcb_bound_refs'_def)
2014-07-14 19:32:44 +00:00
apply (case_tac "tcbState obj", simp_all)[1]
apply (frule(1) st_tcb_idle' [OF invs_valid_idle'], simp)
apply (clarsimp simp: st_tcb_at'_def obj_at'_def state_refs_of'_def projectKOs
2016-10-25 06:01:30 +00:00
split: if_split_asm)
2014-07-14 19:32:44 +00:00
apply (case_tac "tcbState obj", clarsimp+)[1]
done
end
end