4614 lines
239 KiB
Plaintext
4614 lines
239 KiB
Plaintext
(*
|
|
* Copyright 2014, General Dynamics C4 Systems
|
|
*
|
|
* SPDX-License-Identifier: GPL-2.0-only
|
|
*)
|
|
|
|
theory Tcb_C
|
|
imports Delete_C Ipc_C
|
|
begin
|
|
|
|
lemma asUser_obj_at' :
|
|
"\<lbrace> K(t\<noteq>t') and obj_at' P t' \<rbrace> asUser t f \<lbrace> \<lambda>_. obj_at' (P::Structures_H.tcb \<Rightarrow> bool) t' \<rbrace>"
|
|
including no_pre
|
|
apply (simp add: asUser_def)
|
|
apply wp
|
|
apply (case_tac "t=t'"; clarsimp)
|
|
apply (rule hoare_drop_imps)
|
|
apply wp
|
|
done
|
|
|
|
|
|
lemma getObject_sched:
|
|
"(x::tcb, s') \<in> fst (getObject t s) \<Longrightarrow>
|
|
(x,s'\<lparr>ksSchedulerAction := ChooseNewThread\<rparr>) \<in> fst (getObject t (s\<lparr>ksSchedulerAction := ChooseNewThread\<rparr>))"
|
|
apply (clarsimp simp: in_monad getObject_def split_def loadObject_default_def
|
|
magnitudeCheck_def projectKOs
|
|
split: option.splits)
|
|
done
|
|
|
|
lemma threadGet_sched:
|
|
"(x, s') \<in> fst (threadGet t f s) \<Longrightarrow>
|
|
(x,s'\<lparr>ksSchedulerAction := ChooseNewThread\<rparr>) \<in> fst (threadGet t f (s\<lparr>ksSchedulerAction := ChooseNewThread\<rparr>))"
|
|
apply (clarsimp simp: in_monad threadGet_def liftM_def)
|
|
apply (drule getObject_sched)
|
|
apply fastforce
|
|
done
|
|
|
|
lemma setObject_sched:
|
|
"(x, s') \<in> fst (setObject t (v::tcb) s) \<Longrightarrow>
|
|
(x, s'\<lparr>ksSchedulerAction := ChooseNewThread\<rparr>) \<in> fst (setObject t v (s\<lparr>ksSchedulerAction := ChooseNewThread\<rparr>))"
|
|
apply (clarsimp simp: in_monad setObject_def split_def updateObject_default_def
|
|
magnitudeCheck_def projectKOs
|
|
split: option.splits)
|
|
done
|
|
|
|
lemma threadSet_sched:
|
|
"(x, s') \<in> fst (threadSet f t s) \<Longrightarrow>
|
|
(x,s'\<lparr>ksSchedulerAction := ChooseNewThread\<rparr>) \<in> fst (threadSet f t (s\<lparr>ksSchedulerAction := ChooseNewThread\<rparr>))"
|
|
apply (clarsimp simp: in_monad threadSet_def)
|
|
apply (drule getObject_sched)
|
|
apply (drule setObject_sched)
|
|
apply fastforce
|
|
done
|
|
|
|
lemma asUser_sched:
|
|
"(rv,s') \<in> fst (asUser t f s) \<Longrightarrow>
|
|
(rv,s'\<lparr>ksSchedulerAction := ChooseNewThread\<rparr>) \<in> fst (asUser t f (s\<lparr>ksSchedulerAction := ChooseNewThread\<rparr>))"
|
|
apply (clarsimp simp: asUser_def split_def in_monad select_f_def)
|
|
apply (drule threadGet_sched)
|
|
apply (drule threadSet_sched)
|
|
apply fastforce
|
|
done
|
|
|
|
lemma doMachineOp_sched:
|
|
"(rv,s') \<in> fst (doMachineOp f s) \<Longrightarrow>
|
|
(rv,s'\<lparr>ksSchedulerAction := ChooseNewThread\<rparr>) \<in> fst (doMachineOp f (s\<lparr>ksSchedulerAction := ChooseNewThread\<rparr>))"
|
|
apply (clarsimp simp: doMachineOp_def split_def in_monad select_f_def)
|
|
apply fastforce
|
|
done
|
|
|
|
context begin interpretation Arch . (*FIXME: arch_split*)
|
|
crunch queues[wp]: setupReplyMaster "valid_queues"
|
|
(simp: crunch_simps wp: crunch_wps)
|
|
|
|
crunch curThread [wp]: restart "\<lambda>s. P (ksCurThread s)"
|
|
(wp: crunch_wps simp: crunch_simps)
|
|
end
|
|
|
|
context kernel_m
|
|
begin
|
|
|
|
lemma getObject_state:
|
|
" \<lbrakk>(x, s') \<in> fst (getObject t' s); ko_at' ko t s\<rbrakk>
|
|
\<Longrightarrow> (if t = t' then tcbState_update (\<lambda>_. st) x else x,
|
|
s'\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>)
|
|
\<in> fst (getObject t' (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>))"
|
|
apply (simp split: if_split)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (clarsimp simp: getObject_def split_def loadObject_default_def in_monad
|
|
Corres_C.in_magnitude_check' projectKOs objBits_simps')
|
|
apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs objBits_simps)
|
|
apply (simp add: magnitudeCheck_def in_monad split: option.splits)
|
|
apply clarsimp
|
|
apply (simp add: lookupAround2_char2)
|
|
apply (clarsimp split: if_split_asm)
|
|
apply (erule_tac x=x2 in allE)
|
|
apply (clarsimp simp: ps_clear_def)
|
|
apply (drule_tac x=x2 in orthD2)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule impE)
|
|
apply simp
|
|
apply (erule notE, rule word_diff_ls'(3))
|
|
apply unat_arith
|
|
apply (drule is_aligned_no_overflow, simp add: word_bits_def)
|
|
apply clarsimp
|
|
apply (clarsimp simp: getObject_def split_def loadObject_default_def in_monad
|
|
Corres_C.in_magnitude_check' projectKOs objBits_simps')
|
|
apply (simp add: magnitudeCheck_def in_monad split: option.splits)
|
|
apply clarsimp
|
|
apply (simp add: lookupAround2_char2)
|
|
apply (clarsimp split: if_split_asm)
|
|
apply (erule_tac x=t in allE)
|
|
apply simp
|
|
apply (clarsimp simp: obj_at'_real_def projectKOs
|
|
ko_wp_at'_def objBits_simps)
|
|
apply (simp add: ps_clear_def)
|
|
apply (drule_tac x=t in orthD2)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule impE)
|
|
apply simp
|
|
apply (erule notE, rule word_diff_ls'(3))
|
|
apply unat_arith
|
|
apply (drule is_aligned_no_overflow)
|
|
apply simp
|
|
apply (erule_tac x=x2 in allE)
|
|
apply (clarsimp simp: ps_clear_def)
|
|
apply (drule_tac x=x2 in orthD2)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule impE)
|
|
apply (rule word_diff_ls'(3))
|
|
apply unat_arith
|
|
apply (drule is_aligned_no_overflow)
|
|
apply simp
|
|
apply fastforce
|
|
done
|
|
|
|
|
|
lemma threadGet_state:
|
|
"\<lbrakk> (uc, s') \<in> fst (threadGet (atcbContextGet o tcbArch) t' s); ko_at' ko t s \<rbrakk> \<Longrightarrow>
|
|
(uc, s'\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>) \<in>
|
|
fst (threadGet (atcbContextGet o tcbArch) t' (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>))"
|
|
apply (clarsimp simp: threadGet_def liftM_def in_monad)
|
|
apply (drule (1) getObject_state [where st=st])
|
|
apply (rule exI)
|
|
apply (erule conjI)
|
|
apply (simp split: if_splits)
|
|
done
|
|
|
|
lemma asUser_state:
|
|
"\<lbrakk>(x,s) \<in> fst (asUser t' f s); ko_at' ko t s; \<And>s. \<lbrace>(=) s\<rbrace> f \<lbrace>\<lambda>_. (=) s\<rbrace> \<rbrakk> \<Longrightarrow>
|
|
(x,s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>) \<in>
|
|
fst (asUser t' f (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>))"
|
|
apply (clarsimp simp: asUser_def in_monad select_f_def)
|
|
apply (frule use_valid, rule threadGet_inv [where P="(=) s"], rule refl)
|
|
apply (frule use_valid, assumption, rule refl)
|
|
apply clarsimp
|
|
apply (frule (1) threadGet_state)
|
|
apply (intro exI)
|
|
apply (erule conjI)
|
|
apply (rule exI, erule conjI)
|
|
apply (clarsimp simp: threadSet_def in_monad)
|
|
apply (frule use_valid, rule getObject_inv [where P="(=) s"])
|
|
apply (simp add: loadObject_default_def)
|
|
apply wp
|
|
apply simp
|
|
apply (rule refl)
|
|
apply clarsimp
|
|
apply (frule (1) getObject_state)
|
|
apply (intro exI)
|
|
apply (erule conjI)
|
|
apply (clarsimp simp: setObject_def split_def updateObject_default_def threadGet_def
|
|
in_magnitude_check' getObject_def loadObject_default_def liftM_def
|
|
objBits_simps' projectKOs in_monad)
|
|
apply (simp split: if_split)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: obj_at'_def projectKOs objBits_simps)
|
|
apply (clarsimp simp: magnitudeCheck_def in_monad split: option.splits)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (cases s, simp)
|
|
apply (rule ext)
|
|
apply (clarsimp split: if_split)
|
|
apply (cases ko)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply (clarsimp simp add: lookupAround2_char2 split: if_split_asm)
|
|
apply (erule_tac x=x2 in allE)
|
|
apply simp
|
|
apply (simp add: ps_clear_def)
|
|
apply (drule_tac x=x2 in orthD2)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule impE, simp)
|
|
apply (erule notE, rule word_diff_ls'(3))
|
|
apply unat_arith
|
|
apply (drule is_aligned_no_overflow)
|
|
apply simp
|
|
apply (rule exI)
|
|
apply (rule conjI, fastforce)
|
|
apply clarsimp
|
|
apply (cases s, clarsimp)
|
|
apply (rule ext, clarsimp split: if_split)
|
|
apply (cases ko, clarsimp)
|
|
apply (clarsimp simp: magnitudeCheck_def in_monad split: option.splits)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (cases s, clarsimp)
|
|
apply (rule ext, clarsimp split: if_split)
|
|
apply (case_tac tcb, clarsimp)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply (clarsimp simp add: lookupAround2_char2 split: if_split_asm)
|
|
apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs objBits_simps)
|
|
apply (erule_tac x=t in allE)
|
|
apply simp
|
|
apply (simp add: ps_clear_def)
|
|
apply (drule_tac x=t in orthD2)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule impE, simp)
|
|
apply (erule notE, rule word_diff_ls'(3))
|
|
apply unat_arith
|
|
apply (drule is_aligned_no_overflow)
|
|
apply simp
|
|
apply (erule_tac x=x2 in allE)
|
|
apply simp
|
|
apply (simp add: ps_clear_def)
|
|
apply (drule_tac x=x2 in orthD2)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule impE)
|
|
apply (rule word_diff_ls'(3))
|
|
apply unat_arith
|
|
apply (drule is_aligned_no_overflow)
|
|
apply simp
|
|
apply (erule impE, simp)
|
|
apply simp
|
|
apply (rule exI)
|
|
apply (rule conjI, fastforce)
|
|
apply clarsimp
|
|
apply (cases s, clarsimp)
|
|
apply (rule ext, clarsimp split: if_split)
|
|
apply (case_tac tcb, clarsimp)
|
|
done
|
|
|
|
lemma doMachineOp_state:
|
|
"(rv,s') \<in> fst (doMachineOp f s) \<Longrightarrow>
|
|
(rv,s'\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>)
|
|
\<in> fst (doMachineOp f (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>))"
|
|
apply (clarsimp simp: doMachineOp_def split_def in_monad select_f_def)
|
|
apply fastforce
|
|
done
|
|
|
|
lemma mapM_upd_inv:
|
|
assumes f: "\<And>x rv. (rv,s) \<in> fst (f x s) \<Longrightarrow> x \<in> set xs \<Longrightarrow> (rv, g s) \<in> fst (f x (g s))"
|
|
assumes inv: "\<And>x. \<lbrace>(=) s\<rbrace> f x \<lbrace>\<lambda>_. (=) s\<rbrace>"
|
|
shows "(rv,s) \<in> fst (mapM f xs s) \<Longrightarrow> (rv, g s) \<in> fst (mapM f xs (g s))"
|
|
using f inv
|
|
proof (induct xs arbitrary: rv s)
|
|
case Nil
|
|
thus ?case by (simp add: mapM_Nil return_def)
|
|
next
|
|
case (Cons z zs)
|
|
from Cons.prems
|
|
show ?case
|
|
apply (clarsimp simp: mapM_Cons in_monad)
|
|
apply (frule use_valid, assumption, rule refl)
|
|
apply clarsimp
|
|
apply (drule Cons.prems, simp)
|
|
apply (rule exI, erule conjI)
|
|
apply (drule Cons.hyps)
|
|
apply simp
|
|
apply assumption
|
|
apply simp
|
|
done
|
|
qed
|
|
|
|
lemma getMRs_rel_state:
|
|
"\<lbrakk>getMRs_rel args buffer s;
|
|
(cur_tcb' and case_option \<top> valid_ipc_buffer_ptr' buffer) s;
|
|
ko_at' ko t s \<rbrakk> \<Longrightarrow>
|
|
getMRs_rel args buffer (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>)"
|
|
apply (clarsimp simp: getMRs_rel_def)
|
|
apply (rule exI, erule conjI)
|
|
apply (subst (asm) det_wp_use, rule det_wp_getMRs)
|
|
apply (simp add: cur_tcb'_def)
|
|
apply (subst det_wp_use, rule det_wp_getMRs)
|
|
apply (simp add: cur_tcb'_def)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs
|
|
objBits_simps ps_clear_def split: if_split)
|
|
apply (clarsimp simp: valid_ipc_buffer_ptr'_def split: option.splits)
|
|
apply (clarsimp simp: typ_at'_def ko_wp_at'_def projectKOs obj_at'_real_def
|
|
objBits_simps ps_clear_def split: if_split)
|
|
apply (clarsimp simp: getMRs_def in_monad)
|
|
apply (frule use_valid, rule asUser_inv [where P="(=) s"])
|
|
apply (wp mapM_wp' getRegister_inv)[1]
|
|
apply simp
|
|
apply clarsimp
|
|
apply (drule (1) asUser_state)
|
|
apply (wp mapM_wp' getRegister_inv)[1]
|
|
apply (intro exI)
|
|
apply (erule conjI)
|
|
apply (cases buffer)
|
|
apply (clarsimp simp: return_def)
|
|
apply clarsimp
|
|
apply (drule mapM_upd_inv [rotated -1])
|
|
prefer 3
|
|
apply fastforce
|
|
prefer 2
|
|
apply wp
|
|
apply (clarsimp simp: loadWordUser_def in_monad stateAssert_def word_size
|
|
simp del: fun_upd_apply)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: pointerInUserData_def typ_at'_def ko_wp_at'_def
|
|
projectKOs ps_clear_def obj_at'_real_def
|
|
split: if_split)
|
|
apply (erule doMachineOp_state)
|
|
done
|
|
|
|
lemma setThreadState_getMRs_rel:
|
|
"\<lbrace>getMRs_rel args buffer and cur_tcb' and case_option \<top> valid_ipc_buffer_ptr' buffer
|
|
and (\<lambda>_. runnable' st)\<rbrace>
|
|
setThreadState st t \<lbrace>\<lambda>_. getMRs_rel args buffer\<rbrace>"
|
|
apply (rule hoare_gen_asm')
|
|
apply (simp add: setThreadState_runnable_simp)
|
|
apply (simp add: threadSet_def)
|
|
apply wp
|
|
apply (simp add: setObject_def split_def updateObject_default_def)
|
|
apply wp
|
|
apply (simp del: fun_upd_apply)
|
|
apply (wp getObject_tcb_wp)
|
|
apply (clarsimp simp del: fun_upd_apply)
|
|
apply (drule obj_at_ko_at')+
|
|
apply (clarsimp simp del: fun_upd_apply)
|
|
apply (rule exI, rule conjI, assumption)
|
|
apply (clarsimp split: if_split simp del: fun_upd_apply)
|
|
apply (simp add: getMRs_rel_state)
|
|
done
|
|
|
|
lemma setThreadState_sysargs_rel:
|
|
"\<lbrace>sysargs_rel args buffer and (\<lambda>_. runnable' st)\<rbrace> setThreadState st t \<lbrace>\<lambda>_. sysargs_rel args buffer\<rbrace>"
|
|
apply (cases buffer, simp_all add: sysargs_rel_def)
|
|
apply (rule hoare_pre)
|
|
apply (wp setThreadState_getMRs_rel hoare_valid_ipc_buffer_ptr_typ_at'|simp)+
|
|
done
|
|
|
|
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 setPriority_ccorres:
|
|
"ccorres dc xfdc
|
|
(\<lambda>s. tcb_at' t s \<and> Invariants_H.valid_queues s \<and> ksCurDomain s \<le> maxDomain \<and>
|
|
valid_queues' s \<and> valid_objs' s \<and> weak_sch_act_wf (ksSchedulerAction s) s \<and> (priority \<le> maxPriority))
|
|
(UNIV \<inter> {s. tptr_' s = tcb_ptr_to_ctcb_ptr t} \<inter> {s. prio_' s = ucast priority})
|
|
[] (setPriority t priority) (Call setPriority_'proc)"
|
|
apply (cinit lift: tptr_' prio_')
|
|
apply (ctac(no_vcg) add: tcbSchedDequeue_ccorres)
|
|
apply (rule ccorres_move_c_guard_tcb)
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule threadSet_ccorres_lemma2[where P=\<top>])
|
|
apply vcg
|
|
apply clarsimp
|
|
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 (simp add: ctcb_relation_def)
|
|
apply (ctac(no_vcg) add: isRunnable_ccorres)
|
|
apply (simp add: when_def to_bool_def del: Collect_const)
|
|
apply (rule ccorres_cond2[where R=\<top>], simp add: Collect_const_mem)
|
|
apply (rule ccorres_pre_getCurThread)
|
|
apply (rule_tac R = "\<lambda>s. rv = ksCurThread s" in ccorres_cond2)
|
|
apply (clarsimp simp: rf_sr_ksCurThread)
|
|
apply (ctac add: rescheduleRequired_ccorres[unfolded dc_def])
|
|
apply (ctac add: possibleSwitchTo_ccorres[unfolded dc_def])
|
|
apply (rule ccorres_return_Skip')
|
|
apply (wp isRunnable_wp)
|
|
apply (wpsimp wp: hoare_drop_imps threadSet_valid_queues threadSet_valid_objs'
|
|
weak_sch_act_wf_lift_linear threadSet_pred_tcb_at_state
|
|
threadSet_tcbDomain_triv
|
|
simp: st_tcb_at'_def o_def split: if_splits)
|
|
apply (simp add: guard_is_UNIV_def)
|
|
apply (rule hoare_strengthen_post[
|
|
where Q="\<lambda>rv s.
|
|
obj_at' (\<lambda>_. True) t s \<and>
|
|
priority \<le> maxPriority \<and>
|
|
Invariants_H.valid_queues s \<and>
|
|
ksCurDomain s \<le> maxDomain \<and>
|
|
valid_objs' s \<and>
|
|
valid_queues' s \<and>
|
|
weak_sch_act_wf (ksSchedulerAction s) s \<and>
|
|
(\<forall>d p. \<not> t \<in> set (ksReadyQueues s (d, p)))"])
|
|
apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues tcbSchedDequeue_nonq)
|
|
apply (clarsimp simp: valid_tcb'_tcbPriority_update)
|
|
apply clarsimp
|
|
apply (frule (1) valid_objs'_maxDomain[where t=t])
|
|
apply (frule (1) valid_objs'_maxPriority[where t=t])
|
|
apply simp
|
|
done
|
|
|
|
lemma setMCPriority_ccorres:
|
|
"ccorres dc xfdc
|
|
(invs' and tcb_at' t and (\<lambda>s. priority \<le> maxPriority))
|
|
(UNIV \<inter> {s. tptr_' s = tcb_ptr_to_ctcb_ptr t} \<inter> {s. mcp_' s = ucast priority})
|
|
[] (setMCPriority t priority) (Call setMCPriority_'proc)"
|
|
apply (rule ccorres_gen_asm)
|
|
apply (cinit lift: tptr_' mcp_')
|
|
apply (rule ccorres_move_c_guard_tcb)
|
|
apply (rule threadSet_ccorres_lemma2[where P=\<top>])
|
|
apply vcg
|
|
apply clarsimp
|
|
apply (erule(1) rf_sr_tcb_update_no_queue2,
|
|
(simp add: typ_heap_simps')+)[1]
|
|
apply (rule ball_tcb_cte_casesI, simp+)
|
|
apply (simp add: ctcb_relation_def cast_simps)
|
|
apply (clarsimp simp: down_cast_same [symmetric] ucast_up_ucast is_up is_down)
|
|
done
|
|
|
|
lemma ccorres_subgoal_tailE:
|
|
"\<lbrakk> ccorres rvr xf Q Q' hs (b ()) d;
|
|
ccorres rvr xf Q Q' hs (b ()) d \<Longrightarrow> ccorres rvr xf P P' hs (a >>=E b) (c ;; d) \<rbrakk>
|
|
\<Longrightarrow> ccorres rvr xf P P' hs (a >>=E b) (c ;; d)"
|
|
by simp
|
|
|
|
lemma checkCapAt_ccorres:
|
|
"\<lbrakk> \<And>rv' t t'. ceqv \<Gamma> ret__unsigned_long_' rv' t t' c (c' rv');
|
|
ccorres rvr xf P P' hs (f >>= g) (c' (scast true));
|
|
ccorres rvr xf Q Q' hs (g ()) (c' (scast false));
|
|
guard_is_UNIV dc xfdc (\<lambda>_ _. P' \<inter> Q') \<rbrakk>
|
|
\<Longrightarrow> ccorres rvr xf (invs' and valid_cap' cap and P and Q)
|
|
(UNIV \<inter> {s. ccap_relation cap cap'} \<inter> {s. slot' = cte_Ptr slot}) hs
|
|
(checkCapAt cap slot f >>= g)
|
|
(Guard C_Guard \<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t slot'\<rbrace>
|
|
(\<acute>ret__unsigned_long :== CALL sameObjectAs(cap',
|
|
h_val (hrs_mem \<acute>t_hrs) (cap_Ptr &(slot'\<rightarrow>[''cap_C'']))));;c)"
|
|
apply (rule ccorres_gen_asm2)+
|
|
apply (simp add: checkCapAt_def liftM_def bind_assoc del: Collect_const)
|
|
apply (rule ccorres_symb_exec_l' [OF _ getCTE_inv getCTE_sp empty_fail_getCTE])
|
|
apply (rule ccorres_guard_imp2)
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply (rule_tac xf'=ret__unsigned_long_' and val="from_bool (sameObjectAs cap (cteCap x))"
|
|
and R="cte_wp_at' ((=) x) slot and valid_cap' cap and invs'"
|
|
in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
|
|
apply vcg
|
|
apply (clarsimp simp: cte_wp_at_ctes_of)
|
|
apply (erule(1) cmap_relationE1[OF cmap_relation_cte])
|
|
apply (rule exI, rule conjI, assumption)
|
|
apply (clarsimp simp: typ_heap_simps dest!: ccte_relation_ccap_relation)
|
|
apply (rule exI, rule conjI, assumption)
|
|
apply (auto intro: valid_capAligned dest: ctes_of_valid')[1]
|
|
apply assumption
|
|
apply (simp only: when_def if_to_top_of_bind)
|
|
apply (rule ccorres_if_lhs)
|
|
apply (simp add: from_bool_def true_def)
|
|
apply (simp add: from_bool_def false_def)
|
|
apply (simp add: guard_is_UNIV_def)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of)
|
|
done
|
|
|
|
lemmas checkCapAt_ccorres2
|
|
= checkCapAt_ccorres[where g=return, simplified bind_return]
|
|
|
|
lemma cte_is_derived_capMasterCap_strg:
|
|
"cte_wp_at' (is_derived' (ctes_of s) ptr cap \<circ> cteCap) ptr s
|
|
\<longrightarrow> cte_wp_at' (\<lambda>scte. capMasterCap (cteCap scte) = capMasterCap cap \<or> P) ptr s"
|
|
by (clarsimp simp: cte_wp_at_ctes_of is_derived'_def
|
|
badge_derived'_def)
|
|
|
|
lemma invokeTCB_ThreadControl_ccorres:
|
|
"ccorres (cintr \<currency> (\<lambda>rv rv'. rv = [])) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and sch_act_simple
|
|
and tcb_inv_wf' (ThreadControl target slot faultep mcp priority cRoot vRoot buf)
|
|
and (\<lambda>_. (faultep = None) = (cRoot = None) \<and> (cRoot = None) = (vRoot = None)
|
|
\<and> (case buf of Some (ptr, Some (cap, slot)) \<Rightarrow> slot \<noteq> 0 | _ \<Rightarrow> True)))
|
|
(UNIV \<inter> {s. target_' s = tcb_ptr_to_ctcb_ptr target}
|
|
\<inter> {s. (cRoot \<noteq> None \<or> buf \<noteq> None) \<longrightarrow> slot_' s = cte_Ptr slot}
|
|
\<inter> {s. faultep_' s = option_to_0 faultep}
|
|
\<inter> {s. mcp_' s = case_option 0 (ucast o fst) mcp}
|
|
\<inter> {s. priority_' s = case_option 0 (ucast o fst) priority}
|
|
\<inter> {s. case cRoot of None \<Rightarrow> True | Some (cRootCap, cRootSlot) \<Rightarrow> ccap_relation cRootCap (cRoot_newCap_' s)}
|
|
\<inter> {s. cRoot_srcSlot_' s = cte_Ptr (option_to_0 (option_map snd cRoot))}
|
|
\<inter> {s. case vRoot of None \<Rightarrow> True | Some (vRootCap, vRootSlot) \<Rightarrow> ccap_relation vRootCap (vRoot_newCap_' s)}
|
|
\<inter> {s. vRoot_srcSlot_' s = cte_Ptr (option_to_0 (option_map snd vRoot))}
|
|
\<inter> {s. bufferAddr_' s = option_to_0 (option_map fst buf)}
|
|
\<inter> {s. bufferSrcSlot_' s = cte_Ptr (case buf of Some (ptr, Some (cap, slot)) \<Rightarrow> slot | _ \<Rightarrow> 0)}
|
|
\<inter> {s. case buf of Some (ptr, Some (cap, slot)) \<Rightarrow> ccap_relation cap (bufferCap_' s) | _ \<Rightarrow> True}
|
|
\<inter> {s. updateFlags_' s = (if mcp \<noteq> None then scast thread_control_update_mcp else 0)
|
|
|| (if priority \<noteq> None then scast thread_control_update_priority else 0)
|
|
|| (if buf \<noteq> None then scast thread_control_update_ipc_buffer else 0)
|
|
|| (if cRoot \<noteq> None then scast thread_control_update_space else 0)})
|
|
[]
|
|
(invokeTCB (ThreadControl target slot faultep mcp priority cRoot vRoot buf))
|
|
(Call invokeTCB_ThreadControl_'proc)"
|
|
(is "ccorres ?rvr ?xf (?P and (\<lambda>_. ?P')) ?Q [] ?af ?cf")
|
|
supply option.case_cong_weak[cong]
|
|
apply (rule ccorres_gen_asm)
|
|
apply (cinit lift: target_' slot_' faultep_' mcp_' priority_' cRoot_newCap_' cRoot_srcSlot_'
|
|
vRoot_newCap_' vRoot_srcSlot_' bufferAddr_' bufferSrcSlot_' bufferCap_'
|
|
updateFlags_')
|
|
apply csymbr
|
|
apply (simp add: liftE_bindE case_option_If2 thread_control_flag_defs
|
|
word_ao_dist if_and_helper if_n_0_0
|
|
tcb_cnode_index_defs[THEN ptr_add_assertion_positive[OF ptr_add_assertion_positive_helper]]
|
|
del: Collect_const cong: call_ignore_cong if_cong)
|
|
apply (rule_tac P="ptr_val (tcb_ptr_to_ctcb_ptr target) && ~~ mask 4
|
|
= ptr_val (tcb_ptr_to_ctcb_ptr target)
|
|
\<and> ptr_val (tcb_ptr_to_ctcb_ptr target) && 0xFFFFFE00 = target"
|
|
in ccorres_gen_asm)
|
|
apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow_novcg)
|
|
apply (rule ccorres_cond_both'[where Q=\<top> and Q'=\<top>])
|
|
apply (simp add: Collect_const_mem)
|
|
apply (rule ccorres_move_c_guard_tcb)
|
|
apply (rule threadSet_ccorres_lemma2[where P=\<top>])
|
|
apply vcg
|
|
apply clarsimp
|
|
apply (subst StateSpace.state.fold_congs[OF refl refl])
|
|
apply (rule globals.fold_congs[OF refl refl])
|
|
apply (rule heap_update_field_hrs)
|
|
apply (simp add: typ_heap_simps)
|
|
apply (fastforce intro: typ_heap_simps)
|
|
apply simp
|
|
apply (erule(1) rf_sr_tcb_update_no_queue2,
|
|
(simp add: typ_heap_simps)+)
|
|
apply (rule ball_tcb_cte_casesI, simp+)
|
|
apply (clarsimp simp: ctcb_relation_def option_to_0_def)
|
|
apply (rule ccorres_return_Skip)
|
|
apply (rule ceqv_refl)
|
|
apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow_novcg)
|
|
apply (rule ccorres_cond_both'[where Q=\<top> and Q'=\<top>])
|
|
apply (simp add: Collect_const_mem)
|
|
apply (ctac add: setMCPriority_ccorres)
|
|
apply (rule ccorres_return_Skip)
|
|
apply (rule ceqv_refl)
|
|
apply (rule ccorres_subgoal_tailE)
|
|
apply (rule ccorres_subgoal_tailE)
|
|
apply (rule_tac A="invs' and sch_act_simple and tcb_at' target
|
|
and (\<lambda>(s::kernel_state). (case priority of None \<Rightarrow> True | Some x \<Rightarrow> ((\<lambda>y. fst y \<le> maxPriority)) x))
|
|
and case_option \<top> (case_option \<top> (valid_cap' \<circ> fst) \<circ> snd) buf
|
|
and case_option \<top> (case_option \<top> (cte_at' \<circ> snd) \<circ> snd) buf
|
|
and K (case_option True (swp is_aligned msg_align_bits \<circ> fst) buf)
|
|
and K (case_option True (case_option True (isArchObjectCap \<circ> fst) \<circ> snd) buf)"
|
|
(* bits of tcb_inv_wf' *)
|
|
in ccorres_guard_imp2[where A'=UNIV])
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (simp only: if_True Collect_True split_def bindE_assoc)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply csymbr
|
|
apply (rule ccorres_move_array_assertion_tcb_ctes ccorres_Guard_Seq)+
|
|
apply csymbr
|
|
apply (simp add: liftE_bindE[symmetric] bindE_assoc getThreadBufferSlot_def
|
|
locateSlot_conv o_def
|
|
del: Collect_const)
|
|
apply (simp add: liftE_bindE del: Collect_const)
|
|
apply (ctac(no_vcg) add: cteDelete_ccorres)
|
|
apply (simp del: Collect_const add: Collect_False)
|
|
apply (rule ccorres_move_c_guard_tcb)
|
|
apply (rule ccorres_split_nothrow_novcg)
|
|
apply (rule threadSet_ccorres_lemma2[where P=\<top>])
|
|
apply vcg
|
|
apply clarsimp
|
|
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 option_to_0_def)
|
|
apply (rule ceqv_refl)
|
|
apply csymbr
|
|
apply (simp add: ccorres_cond_iffs Collect_False split_def
|
|
del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
(* P *)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (simp add: case_option_If2 if_n_0_0 split_def
|
|
del: Collect_const)
|
|
apply (rule checkCapAt_ccorres)
|
|
apply ceqv
|
|
apply csymbr
|
|
apply (simp add: true_def Collect_True
|
|
del: Collect_const)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (rule checkCapAt_ccorres)
|
|
apply ceqv
|
|
apply csymbr
|
|
apply (simp add: true_def Collect_True
|
|
del: Collect_const)
|
|
apply (simp add: assertDerived_def bind_assoc del: Collect_const)
|
|
apply (rule ccorres_symb_exec_l)
|
|
apply (ctac(no_vcg) add: cteInsert_ccorres)
|
|
apply (rule ccorres_pre_getCurThread)
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (simp add: when_def)
|
|
apply (rename_tac curThread)
|
|
apply (rule_tac C'="{s. target = curThread}"
|
|
and Q="\<lambda>s. ksCurThread s = curThread"
|
|
and Q'=UNIV in ccorres_rewrite_cond_sr)
|
|
apply (clarsimp simp: Collect_const_mem rf_sr_ksCurThread)
|
|
apply (rule ccorres_Cond_rhs; clarsimp)
|
|
apply (ctac (no_vcg) add: rescheduleRequired_ccorres[unfolded dc_def])
|
|
apply (rule ccorres_return_Skip')
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule ccorres_cond2[where R=\<top>], simp add: Collect_const_mem)
|
|
apply (ctac add: setPriority_ccorres)
|
|
apply (rule ccorres_return_Skip)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (wp (once))
|
|
apply (clarsimp simp: guard_is_UNIV_def)
|
|
apply (wpsimp wp: when_def static_imp_wp)
|
|
apply (strengthen sch_act_wf_weak, wp)
|
|
apply clarsimp
|
|
apply wp
|
|
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
|
|
apply (rule hoare_strengthen_post[
|
|
where Q= "\<lambda>rv s.
|
|
Invariants_H.valid_queues s \<and>
|
|
valid_objs' s \<and>
|
|
weak_sch_act_wf (ksSchedulerAction s) s \<and>
|
|
((\<exists>a b. priority = Some (a, b)) \<longrightarrow>
|
|
tcb_at' target s \<and> ksCurDomain s \<le> maxDomain \<and>
|
|
valid_queues' s \<and> fst (the priority) \<le> maxPriority)"])
|
|
apply (strengthen sch_act_wf_weak)
|
|
apply (wp static_imp_wp)
|
|
apply (clarsimp split: if_splits)
|
|
apply (wp empty_fail_stateAssert hoare_case_option_wp | simp del: Collect_const)+
|
|
apply csymbr
|
|
apply (simp add: false_def Collect_False ccorres_cond_iffs
|
|
del: Collect_const)
|
|
apply (rule ccorres_pre_getCurThread)
|
|
apply (rename_tac curThread)
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (simp add: when_def to_bool_def)
|
|
apply (rule_tac C'="{s. target = curThread}"
|
|
and Q="\<lambda>s. ksCurThread s = curThread"
|
|
and Q'=UNIV in ccorres_rewrite_cond_sr)
|
|
apply (clarsimp simp: Collect_const_mem rf_sr_ksCurThread)
|
|
apply (rule ccorres_Cond_rhs; clarsimp)
|
|
apply (ctac (no_vcg) add: rescheduleRequired_ccorres[unfolded dc_def])
|
|
apply (rule ccorres_return_Skip')
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule ccorres_cond2[where R=\<top>], simp add: Collect_const_mem)
|
|
apply (ctac add: setPriority_ccorres)
|
|
apply (rule ccorres_return_Skip)
|
|
apply (rule ccorres_return_CE, simp+)
|
|
apply wp
|
|
apply (clarsimp simp: guard_is_UNIV_def)
|
|
apply (simp add: when_def)
|
|
apply (wp hoare_vcg_if_lift2(1) static_imp_wp, strengthen sch_act_wf_weak; wp)
|
|
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
|
|
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem
|
|
tcbBuffer_def size_of_def cte_level_bits_def
|
|
tcbIPCBufferSlot_def)
|
|
apply csymbr
|
|
apply (simp add: Collect_False false_def
|
|
del: Collect_const)
|
|
apply (rule ccorres_cond_false_seq, simp)
|
|
apply (rule ccorres_pre_getCurThread)
|
|
apply (rename_tac curThread)
|
|
apply (simp add: when_def to_bool_def)
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule_tac C'="{s. target = curThread}"
|
|
and Q="\<lambda>s. ksCurThread s = curThread"
|
|
and Q'=UNIV in ccorres_rewrite_cond_sr)
|
|
apply (clarsimp simp: Collect_const_mem rf_sr_ksCurThread)
|
|
apply (rule ccorres_Cond_rhs; clarsimp)
|
|
apply (ctac(no_vcg) add: rescheduleRequired_ccorres[unfolded dc_def])
|
|
apply (rule ccorres_return_Skip')
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply(rule ccorres_cond2[where R=\<top>], simp add: Collect_const_mem)
|
|
apply(ctac add: setPriority_ccorres)
|
|
apply(rule ccorres_return_Skip)
|
|
apply (rule ccorres_return_CE, simp+)
|
|
apply wp
|
|
apply (clarsimp simp: guard_is_UNIV_def)
|
|
apply (wp hoare_vcg_if_lift2(1) static_imp_wp, strengthen sch_act_wf_weak; wp)
|
|
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
|
|
apply (simp add: guard_is_UNIV_def false_def Collect_const_mem)
|
|
apply (clarsimp simp: ccap_relation_def cap_thread_cap_lift cap_to_H_def)
|
|
apply simp
|
|
apply (rule ccorres_cond_false_seq, simp)
|
|
apply (rule ccorres_cond_false_seq, simp)
|
|
apply (simp split: option.split_asm)
|
|
apply (rule ccorres_pre_getCurThread)
|
|
apply (rename_tac curThread)
|
|
apply (simp add: when_def to_bool_def)
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule_tac C'="{s. target = curThread}"
|
|
and Q="\<lambda>s. ksCurThread s = curThread"
|
|
and Q'=UNIV in ccorres_rewrite_cond_sr)
|
|
apply (clarsimp simp: Collect_const_mem rf_sr_ksCurThread)
|
|
apply (rule ccorres_Cond_rhs; clarsimp)
|
|
apply (ctac(no_vcg) add: rescheduleRequired_ccorres[unfolded dc_def])
|
|
apply (rule ccorres_return_Skip')
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule ccorres_cond2[where R=\<top>], simp add: Collect_const_mem)
|
|
apply (ctac add: setPriority_ccorres)
|
|
apply (rule ccorres_return_Skip)
|
|
apply (rule ccorres_return_CE, simp+)
|
|
apply wp
|
|
apply (clarsimp simp: guard_is_UNIV_def)
|
|
apply wpsimp
|
|
apply (wp static_imp_wp, strengthen sch_act_wf_weak, wp )
|
|
apply wp
|
|
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
|
|
apply (simp cong: conj_cong)
|
|
apply (rule hoare_strengthen_post[
|
|
where Q="\<lambda>a b. (Invariants_H.valid_queues b \<and>
|
|
valid_objs' b \<and>
|
|
sch_act_wf (ksSchedulerAction b) b \<and>
|
|
((\<exists>a b. priority = Some (a, b)) \<longrightarrow>
|
|
tcb_at' target b \<and>
|
|
ksCurDomain b \<le> maxDomain \<and> valid_queues' b \<and>
|
|
fst (the priority) \<le> maxPriority)) \<and>
|
|
((case snd (the buf)
|
|
of None \<Rightarrow> 0
|
|
| Some x \<Rightarrow> snd x) \<noteq> 0 \<longrightarrow>
|
|
invs' b \<and>
|
|
valid_cap' (capability.ThreadCap target) b \<and>
|
|
valid_cap' (fst (the (snd (the buf)))) b \<and>
|
|
(cte_wp_at' (\<lambda>a. is_derived' (map_to_ctes (ksPSpace b))
|
|
(snd (the (snd (the buf))))
|
|
(fst (the (snd (the buf))))
|
|
(cteCap a))
|
|
(snd (the (snd (the buf)))) b \<longrightarrow>
|
|
cte_wp_at' (\<lambda>scte. capMasterCap (cteCap scte)
|
|
= capMasterCap (fst (the (snd (the buf))))
|
|
\<or> is_simple_cap' (fst (the (snd (the buf)))))
|
|
(snd (the (snd (the buf)))) b \<and>
|
|
valid_mdb' b \<and>
|
|
pspace_aligned' b \<and>
|
|
cte_wp_at' (\<lambda>c. True) (snd (the (snd (the buf)))) b))"])
|
|
prefer 2
|
|
apply fastforce
|
|
apply (strengthen cte_is_derived_capMasterCap_strg
|
|
invs_queues invs_weak_sch_act_wf invs_sch_act_wf'
|
|
invs_valid_objs' invs_mdb' invs_pspace_aligned',
|
|
simp add: o_def)
|
|
apply (rule_tac P="is_aligned (fst (the buf)) msg_align_bits"
|
|
in hoare_gen_asm)
|
|
apply (wp threadSet_ipcbuffer_trivial static_imp_wp
|
|
| simp
|
|
| strengthen invs_sch_act_wf' invs_valid_objs' invs_weak_sch_act_wf invs_queues
|
|
invs_valid_queues' | wp hoare_drop_imps)+
|
|
(* \<not> P *)
|
|
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem
|
|
option_to_0_def
|
|
split: option.split_asm)
|
|
apply (clarsimp simp: ccap_relation_def cap_thread_cap_lift cap_to_H_def)
|
|
apply (rule ccorres_split_throws)
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply vcg
|
|
apply (simp add: conj_comms cong: conj_cong)
|
|
apply (strengthen invs_ksCurDomain_maxDomain')
|
|
apply (wp hoare_vcg_const_imp_lift_R cteDelete_invs')
|
|
apply simp
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule ccorres_cond2[where R=\<top>], simp add: Collect_const_mem)
|
|
apply (ctac add: setPriority_ccorres)
|
|
apply (rule ccorres_return_Skip)
|
|
apply (rule ccorres_return_CE, simp+)
|
|
apply wp
|
|
apply (clarsimp simp: guard_is_UNIV_def)
|
|
apply (clarsimp simp: inQ_def Collect_const_mem cintr_def
|
|
exception_defs tcb_cnode_index_defs)
|
|
apply (simp add: tcbBuffer_def tcbIPCBufferSlot_def word_sle_def
|
|
cte_level_bits_def from_bool_def true_def size_of_def case_option_If2 )
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: case_option_If2 if_n_0_0 objBits_simps' valid_cap'_def
|
|
capAligned_def word_bits_conv obj_at'_def projectKOs)
|
|
apply (clarsimp simp: invs_valid_objs' invs_valid_queues'
|
|
Invariants_H.invs_queues invs_ksCurDomain_maxDomain')
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply csymbr
|
|
apply (rule ccorres_move_array_assertion_tcb_ctes ccorres_Guard_Seq)+
|
|
apply (simp add: split_def getThreadVSpaceRoot_def locateSlot_conv
|
|
bindE_assoc liftE_bindE
|
|
del: Collect_const)
|
|
apply csymbr
|
|
apply (ctac(no_vcg) add: cteDelete_ccorres)
|
|
apply (simp add: liftE_bindE Collect_False ccorres_cond_iffs
|
|
dc_def
|
|
del: Collect_const)
|
|
apply ((rule ccorres_split_nothrow_novcg_dc[rotated], assumption) | rule ccorres_rhs_assoc2)+
|
|
apply (simp add: conj_comms pred_conj_def)
|
|
apply (simp add: o_def cong: conj_cong option.case_cong)
|
|
apply (wp checked_insert_tcb_invs' hoare_case_option_wp
|
|
checkCap_inv [where P="tcb_at' p0" for p0]
|
|
checkCap_inv [where P="cte_at' p0" for p0]
|
|
checkCap_inv [where P="valid_cap' c" for c]
|
|
checkCap_inv [where P="sch_act_simple"]
|
|
| simp)+
|
|
apply (simp add: guard_is_UNIV_def)
|
|
apply (thin_tac "ccorres a1 a2 a3 a4 a5 a6 a7" for a1 a2 a3 a4 a5 a6 a7)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (rule checkCapAt_ccorres2)
|
|
apply ceqv
|
|
apply csymbr
|
|
apply (simp add: true_def Collect_True
|
|
del: Collect_const)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (rule checkCapAt_ccorres2)
|
|
apply ceqv
|
|
apply csymbr
|
|
apply (simp add: true_def Collect_True
|
|
assertDerived_def bind_assoc
|
|
ccorres_cond_iffs dc_def[symmetric]
|
|
del: Collect_const)
|
|
apply (rule ccorres_symb_exec_l)
|
|
apply (ctac add: cteInsert_ccorres)
|
|
apply (wp empty_fail_stateAssert hoare_case_option_wp | simp del: Collect_const)+
|
|
apply csymbr
|
|
apply (simp add: false_def Collect_False ccorres_cond_iffs
|
|
del: Collect_const)
|
|
apply (rule ccorres_return_Skip[unfolded dc_def])
|
|
apply (fastforce simp: guard_is_UNIV_def Kernel_C.tcbVTable_def tcbVTableSlot_def
|
|
cte_level_bits_def size_of_def)
|
|
apply csymbr
|
|
apply (simp add: false_def Collect_False
|
|
del: Collect_const)
|
|
apply (rule ccorres_cond_false)
|
|
apply (rule ccorres_return_Skip[unfolded dc_def])
|
|
apply (clarsimp simp: guard_is_UNIV_def false_def
|
|
ccap_relation_def cap_thread_cap_lift
|
|
cap_to_H_def)
|
|
apply simp
|
|
apply (rule ccorres_split_throws, rule ccorres_return_C_errorE, simp+)
|
|
apply vcg
|
|
apply (simp add: conj_comms, simp cong: conj_cong add: invs_mdb' invs_pspace_aligned')
|
|
apply (simp add: cte_is_derived_capMasterCap_strg o_def)
|
|
apply (wp cteDelete_invs' hoare_case_option_wp cteDelete_deletes
|
|
cteDelete_sch_act_simple
|
|
| strengthen invs_valid_objs')+
|
|
apply (rule hoare_post_imp_R[where Q' = "\<lambda>r. invs'"])
|
|
apply (wp cteDelete_invs')
|
|
apply (clarsimp simp:cte_wp_at_ctes_of)
|
|
apply simp
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply csymbr
|
|
apply (rule ccorres_move_array_assertion_tcb_ctes ccorres_Guard_Seq)+
|
|
apply (simp add: split_def getThreadCSpaceRoot_def locateSlot_conv
|
|
bindE_assoc liftE_bindE
|
|
del: Collect_const)
|
|
apply csymbr
|
|
apply (ctac(no_vcg) add: cteDelete_ccorres)
|
|
apply (simp add: liftE_bindE Collect_False ccorres_cond_iffs
|
|
dc_def
|
|
del: Collect_const)
|
|
apply ((rule ccorres_split_nothrow_novcg_dc[rotated], assumption)
|
|
| rule ccorres_rhs_assoc2)+
|
|
apply (simp add: conj_comms pred_conj_def)
|
|
apply (simp add: o_def cong: conj_cong option.case_cong)
|
|
apply (wp checked_insert_tcb_invs' hoare_case_option_wp
|
|
checkCap_inv [where P="tcb_at' p0" for p0]
|
|
checkCap_inv [where P="cte_at' p0" for p0]
|
|
checkCap_inv [where P="valid_cap' c" for c]
|
|
checkCap_inv [where P="sch_act_simple"]
|
|
| simp)+
|
|
apply (fastforce simp: guard_is_UNIV_def
|
|
Kernel_C.tcbVTable_def tcbVTableSlot_def
|
|
cte_level_bits_def size_of_def
|
|
tcb_cnode_index_defs)
|
|
apply (thin_tac "ccorres a1 a2 a3 a4 a5 a6 a7" for a1 a2 a3 a4 a5 a6 a7)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (rule checkCapAt_ccorres2)
|
|
apply ceqv
|
|
apply csymbr
|
|
apply (simp add: true_def Collect_True
|
|
del: Collect_const)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (rule checkCapAt_ccorres2)
|
|
apply ceqv
|
|
apply csymbr
|
|
apply (simp add: true_def Collect_True
|
|
assertDerived_def bind_assoc
|
|
ccorres_cond_iffs dc_def[symmetric]
|
|
del: Collect_const)
|
|
apply (rule ccorres_symb_exec_l)
|
|
apply (ctac add: cteInsert_ccorres)
|
|
apply (wp empty_fail_stateAssert hoare_case_option_wp | simp del: Collect_const)+
|
|
apply csymbr
|
|
apply (simp add: false_def Collect_False ccorres_cond_iffs
|
|
del: Collect_const)
|
|
apply (rule ccorres_return_Skip[unfolded dc_def])
|
|
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem
|
|
Kernel_C.tcbCTable_def tcbCTableSlot_def
|
|
cte_level_bits_def size_of_def option_to_0_def)
|
|
apply csymbr
|
|
apply (simp add: false_def Collect_False
|
|
del: Collect_const)
|
|
apply (rule ccorres_cond_false)
|
|
apply (rule ccorres_return_Skip[unfolded dc_def])
|
|
apply (clarsimp simp: guard_is_UNIV_def false_def
|
|
ccap_relation_def cap_thread_cap_lift
|
|
cap_to_H_def)
|
|
apply simp
|
|
apply (rule ccorres_split_throws, rule ccorres_return_C_errorE, simp+)
|
|
apply vcg
|
|
apply (simp add: conj_comms, simp cong: conj_cong add: invs_mdb' invs_pspace_aligned')
|
|
apply (simp add: cte_is_derived_capMasterCap_strg o_def)
|
|
apply (wp cteDelete_invs' hoare_case_option_wp cteDelete_deletes cteDelete_sch_act_simple
|
|
| strengthen invs_valid_objs')+
|
|
apply (rule hoare_post_imp_R[where Q' = "\<lambda>r. invs'"])
|
|
apply (wp cteDelete_invs')
|
|
apply (clarsimp simp:cte_wp_at_ctes_of)
|
|
apply simp
|
|
apply (simp add: conj_comms)
|
|
apply (wp hoare_case_option_wp threadSet_invs_trivial setMCPriority_invs'
|
|
typ_at_lifts[OF setMCPriority_typ_at']
|
|
threadSet_cap_to' static_imp_wp | simp)+
|
|
apply (clarsimp simp: guard_is_UNIV_def tcbCTableSlot_def Kernel_C.tcbCTable_def
|
|
cte_level_bits_def size_of_def word_sle_def option_to_0_def
|
|
true_def from_bool_def cintr_def Collect_const_mem)
|
|
apply (simp add: conj_comms)
|
|
apply (wp hoare_case_option_wp threadSet_invs_trivial
|
|
threadSet_cap_to' static_imp_wp | simp)+
|
|
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
|
|
apply (clarsimp simp: inQ_def)
|
|
apply (subst is_aligned_neg_mask_eq)
|
|
apply (simp add: tcb_ptr_to_ctcb_ptr_def)
|
|
apply (rule aligned_add_aligned)
|
|
apply (fastforce simp add: obj_at'_def projectKOs objBits_simps')
|
|
apply (simp add: ctcb_offset_defs is_aligned_def)
|
|
apply (simp add: word_bits_conv)
|
|
apply simp
|
|
apply (subgoal_tac "s \<turnstile>' capability.ThreadCap target")
|
|
apply (clarsimp simp: cte_level_bits_def Kernel_C.tcbCTable_def Kernel_C.tcbVTable_def
|
|
tcbCTableSlot_def tcbVTableSlot_def size_of_def
|
|
tcb_cte_cases_def isCap_simps
|
|
split: option.split_asm
|
|
dest!: isValidVTableRootD)
|
|
apply (clarsimp simp: valid_cap'_def capAligned_def word_bits_conv
|
|
obj_at'_def objBits_simps' projectKOs)
|
|
done
|
|
|
|
lemma setupReplyMaster_ccorres:
|
|
"ccorres dc xfdc (tcb_at' t)
|
|
(UNIV \<inter> {s. thread_' s = tcb_ptr_to_ctcb_ptr t}) []
|
|
(setupReplyMaster t) (Call setupReplyMaster_'proc)"
|
|
apply (cinit lift: thread_')
|
|
apply (rule ccorres_move_array_assertion_tcb_ctes ccorres_Guard_Seq)+
|
|
apply ctac
|
|
apply (simp del: Collect_const add: dc_def[symmetric])
|
|
apply (rule ccorres_pre_getCTE)
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply (rule_tac F="\<lambda>rv'. (rv' = scast cap_null_cap) = (cteCap oldCTE = NullCap)"
|
|
and R="cte_wp_at' ((=) oldCTE) rv"
|
|
and xf'=ret__unsigned_'
|
|
in ccorres_symb_exec_r_abstract_UNIV[where R'=UNIV])
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of)
|
|
apply (erule(1) cmap_relationE1[OF cmap_relation_cte])
|
|
apply (clarsimp simp: typ_heap_simps cap_get_tag_isCap
|
|
dest!: ccte_relation_ccap_relation)
|
|
apply ceqv
|
|
apply (simp only:)
|
|
apply (rule ccorres_when[where R=\<top>])
|
|
apply (simp add: Collect_const_mem)
|
|
apply (rule ccorres_symb_exec_l [OF _ _ _ empty_fail_stateAssert])
|
|
apply (rule_tac P="cte_at' rv and tcb_at' t" in ccorres_from_vcg[where P'=UNIV])
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of)
|
|
apply (rule cmap_relationE1[OF cmap_relation_cte], assumption+)
|
|
apply (rule conjI, fastforce intro: typ_heap_simps)
|
|
apply (clarsimp simp: typ_heap_simps)
|
|
apply (rule fst_setCTE[OF ctes_of_cte_at], assumption)
|
|
apply (rule rev_bexI, assumption)
|
|
apply (clarsimp simp: rf_sr_def cstate_relation_def
|
|
cpspace_relation_def Let_def
|
|
typ_heap_simps')
|
|
apply (subst setCTE_tcb_case, assumption+)
|
|
apply (rule_tac r="s'" in KernelStateData_H.kernel_state.cases)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply (erule(2) cmap_relation_updI)
|
|
apply (clarsimp simp: ccte_relation_def cap_reply_cap_lift cte_lift_def
|
|
cong: option.case_cong_weak)
|
|
apply (simp add: cte_to_H_def cap_to_H_def mdb_node_to_H_def
|
|
nullMDBNode_def c_valid_cte_def)
|
|
apply (simp add: cap_reply_cap_lift)
|
|
apply (subst is_aligned_neg_mask_weaken)
|
|
apply (erule is_aligned_tcb_ptr_to_ctcb_ptr)
|
|
apply (simp add: ctcb_size_bits_def)
|
|
apply (simp add: true_def mask_def to_bool_def)
|
|
apply simp
|
|
apply (simp add: cmachine_state_relation_def
|
|
typ_heap_simps'
|
|
carch_state_relation_def carch_globals_def
|
|
cvariable_array_map_const_add_map_option[where f="tcb_no_ctes_proj"])
|
|
apply (wp | simp)+
|
|
apply (clarsimp simp: guard_is_UNIV_def)
|
|
apply (wp | simp add: locateSlot_conv)+
|
|
apply vcg
|
|
apply (clarsimp simp: word_sle_def cte_wp_at_ctes_of
|
|
tcb_cnode_index_defs tcbReplySlot_def)
|
|
done
|
|
|
|
lemma restart_ccorres:
|
|
"ccorres dc xfdc (invs' and tcb_at' thread and sch_act_simple)
|
|
(UNIV \<inter> {s. target_' s = tcb_ptr_to_ctcb_ptr thread}) []
|
|
(restart thread) (Call restart_'proc)"
|
|
apply (cinit lift: target_')
|
|
apply (ctac(no_vcg) add: isStopped_ccorres)
|
|
apply (simp only: when_def)
|
|
apply (rule ccorres_cond2[where R=\<top>])
|
|
apply (simp add: to_bool_def Collect_const_mem)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (ctac(no_vcg) add: cancelIPC_ccorres1[OF cteDeleteOne_ccorres])
|
|
apply (ctac(no_vcg) add: setupReplyMaster_ccorres)
|
|
apply (ctac(no_vcg))
|
|
apply (ctac(no_vcg) add: tcbSchedEnqueue_ccorres)
|
|
apply (ctac add: possibleSwitchTo_ccorres)
|
|
apply (wp weak_sch_act_wf_lift)[1]
|
|
apply (wp sts_valid_queues setThreadState_st_tcb)[1]
|
|
apply (simp add: valid_tcb_state'_def)
|
|
apply wp
|
|
apply (wp (once) sch_act_wf_lift, (wp tcb_in_cur_domain'_lift)+)
|
|
apply (rule hoare_strengthen_post)
|
|
apply (rule hoare_vcg_conj_lift)
|
|
apply (rule delete_one_conc_fr.cancelIPC_invs)
|
|
|
|
apply (rule cancelIPC_tcb_at'[where t=thread])
|
|
apply fastforce
|
|
apply (rule ccorres_return_Skip)
|
|
apply (wp hoare_drop_imps)
|
|
apply (auto simp: Collect_const_mem mask_def "StrictC'_thread_state_defs")
|
|
done
|
|
|
|
lemma setNextPC_ccorres:
|
|
"ccorres dc xfdc \<top>
|
|
(UNIV \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>
|
|
\<inter> {s. v_' s = val}) []
|
|
(asUser thread (setNextPC val))
|
|
(Call setNextPC_'proc)"
|
|
apply (cinit')
|
|
apply (simp add: setNextPC_def)
|
|
apply (ctac add: setRegister_ccorres)
|
|
apply simp
|
|
done
|
|
|
|
lemma Arch_performTransfer_ccorres:
|
|
"ccorres (K (K \<bottom>) \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
\<top> UNIV []
|
|
(liftE (performTransfer a b c))
|
|
(Call Arch_performTransfer_'proc)"
|
|
apply (cinit' simp: performTransfer_def)
|
|
apply (fold returnOk_liftE)
|
|
apply (rule ccorres_return_CE)
|
|
apply simp+
|
|
done
|
|
|
|
(*FIXME: arch_split: C kernel names hidden by Haskell names *)
|
|
abbreviation "frameRegistersC \<equiv> kernel_all_substitute.frameRegisters"
|
|
lemmas frameRegistersC_def = kernel_all_substitute.frameRegisters_def
|
|
abbreviation "gpRegistersC \<equiv> kernel_all_substitute.gpRegisters"
|
|
lemmas gpRegistersC_def = kernel_all_substitute.gpRegisters_def
|
|
|
|
lemma frame_gp_registers_convs:
|
|
"length ARM_H.frameRegisters = unat n_frameRegisters"
|
|
"length ARM_H.gpRegisters = unat n_gpRegisters"
|
|
"n < length ARM_H.frameRegisters \<Longrightarrow>
|
|
index frameRegistersC n = register_from_H (ARM_H.frameRegisters ! n)"
|
|
"n < length ARM_H.gpRegisters \<Longrightarrow>
|
|
index gpRegistersC n = register_from_H (ARM_H.gpRegisters ! n)"
|
|
apply (simp_all add: ARM_H.gpRegisters_def ARM_H.frameRegisters_def
|
|
ARM.gpRegisters_def n_gpRegisters_def
|
|
ARM.frameRegisters_def n_frameRegisters_def
|
|
frameRegistersC_def gpRegistersC_def msgRegisters_unfold
|
|
fupdate_def Arrays.update_def toEnum_def
|
|
upto_enum_def fromEnum_def enum_register)
|
|
apply (auto simp: less_Suc_eq fcp_beta Kernel_C.LR_def R14_def)
|
|
done
|
|
|
|
lemma postModifyRegisters_ccorres:
|
|
"ccorres dc xfdc \<top> UNIV hs
|
|
(asUser dest $ postModifyRegisters ct dest)
|
|
(Call Arch_postModifyRegisters_'proc)"
|
|
apply (cinit simp: postModifyRegisters_def)
|
|
apply (subst asUser_return)
|
|
apply (rule ccorres_stateAssert)
|
|
apply (rule ccorres_return_Skip)
|
|
apply simp
|
|
done
|
|
|
|
lemma invokeTCB_CopyRegisters_ccorres:
|
|
"ccorres (cintr \<currency> (\<lambda>rv rv'. rv = [])) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and sch_act_simple and tcb_at' destn and tcb_at' source
|
|
and ex_nonz_cap_to' destn and ex_nonz_cap_to' source)
|
|
(UNIV \<inter> {s. dest_' s = tcb_ptr_to_ctcb_ptr destn}
|
|
\<inter> {s. tcb_src_' s = tcb_ptr_to_ctcb_ptr source}
|
|
\<inter> {s. to_bool (resumeTarget_' s) = resume}
|
|
\<inter> {s. to_bool (suspendSource_' s) = susp}
|
|
\<inter> {s. to_bool (transferFrame_' s) = frames}
|
|
\<inter> {s. to_bool (transferInteger_' s) = ints}) []
|
|
(invokeTCB (CopyRegisters destn source susp resume frames ints arch))
|
|
(Call invokeTCB_CopyRegisters_'proc)"
|
|
including no_take_bit
|
|
apply (cinit lift: dest_' tcb_src_' resumeTarget_'
|
|
suspendSource_' transferFrame_' transferInteger_'
|
|
simp: whileAnno_def)
|
|
apply (simp add: liftE_def bind_assoc whileAnno_def
|
|
del: Collect_const)
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule ccorres_when[where R=\<top>])
|
|
apply (simp add: to_bool_def del: Collect_const)
|
|
apply (ctac add: suspend_ccorres[OF cteDeleteOne_ccorres])
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule ccorres_when[where R=\<top>])
|
|
apply (simp add: to_bool_def del: Collect_const)
|
|
apply (ctac add: restart_ccorres)
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule ccorres_when[where R=\<top>])
|
|
apply (simp add: to_bool_def Collect_const_mem)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (csymbr, csymbr, csymbr)
|
|
apply (rule ccorres_rhs_assoc2, rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule ccorres_rel_imp)
|
|
apply (rule ccorres_mapM_x_while[where F="\<lambda>x. tcb_at' destn and tcb_at' source"])
|
|
apply clarsimp
|
|
apply (rule ccorres_guard_imp2)
|
|
apply (ctac(no_vcg) add: getRegister_ccorres)
|
|
apply (ctac add: setRegister_ccorres)
|
|
apply wp
|
|
apply (clarsimp simp: frame_gp_registers_convs
|
|
n_frameRegisters_def unat_of_nat32
|
|
word_bits_def word_of_nat_less)
|
|
apply (simp add: frame_gp_registers_convs n_frameRegisters_def)
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply clarsimp
|
|
apply (wp | simp)+
|
|
apply (simp add: frame_gp_registers_convs n_frameRegisters_def
|
|
word_bits_def)
|
|
apply simp
|
|
apply (ctac(no_vcg) add: getRestartPC_ccorres)
|
|
apply (ctac add: setNextPC_ccorres)
|
|
apply wp+
|
|
apply (clarsimp simp: guard_is_UNIV_def)
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule ccorres_when[where R=\<top>])
|
|
apply (simp add: to_bool_def Collect_const_mem)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (csymbr, csymbr)
|
|
apply (rule ccorres_rel_imp)
|
|
apply (rule ccorres_mapM_x_while[where F="\<lambda>x. tcb_at' destn and tcb_at' source"])
|
|
apply clarsimp
|
|
apply (rule ccorres_guard_imp2)
|
|
apply ((wp | ctac(no_vcg) add: getRegister_ccorres setRegister_ccorres)+)[1]
|
|
apply (clarsimp simp: frame_gp_registers_convs n_gpRegisters_def
|
|
unat_of_nat32 word_bits_def word_of_nat_less)
|
|
apply (simp add: frame_gp_registers_convs n_gpRegisters_def)
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply clarsimp
|
|
apply (wp | simp)+
|
|
apply (simp add: word_bits_def frame_gp_registers_convs n_gpRegisters_def)
|
|
apply simp
|
|
apply (rule ccorres_pre_getCurThread)
|
|
apply (ctac add: postModifyRegisters_ccorres[simplified])
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule_tac R="\<lambda>s. rvd = ksCurThread s"
|
|
in ccorres_when)
|
|
apply (clarsimp simp: rf_sr_ksCurThread)
|
|
apply clarsimp
|
|
apply (ctac (no_vcg) add: rescheduleRequired_ccorres)
|
|
apply (simp only: liftE_bindE[symmetric] return_returnOk)
|
|
apply (ctac(no_vcg) add: Arch_performTransfer_ccorres)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply simp
|
|
apply wp+
|
|
apply (clarsimp simp: guard_is_UNIV_def)
|
|
apply simp
|
|
apply (wpsimp simp: postModifyRegisters_def pred_conj_def
|
|
cong: if_cong
|
|
wp: hoare_drop_imps)
|
|
apply vcg
|
|
apply (wp hoare_drop_imp)
|
|
apply (simp add: pred_conj_def guard_is_UNIV_def cong: if_cong
|
|
| wp mapM_x_wp_inv hoare_drop_imp)+
|
|
apply clarsimp
|
|
apply (rule_tac Q="\<lambda>rv. invs' and tcb_at' destn" in hoare_strengthen_post[rotated])
|
|
apply (fastforce simp: sch_act_wf_weak)
|
|
apply (wpsimp wp: hoare_drop_imp restart_invs')+
|
|
apply (clarsimp simp add: guard_is_UNIV_def)
|
|
apply (wp hoare_drop_imp hoare_vcg_if_lift)+
|
|
apply simp
|
|
apply (rule_tac Q="\<lambda>rv. invs' and tcb_at' destn" in hoare_strengthen_post[rotated])
|
|
apply (fastforce simp: sch_act_wf_weak)
|
|
apply (wpsimp wp: hoare_drop_imp)+
|
|
apply (clarsimp simp add: guard_is_UNIV_def)
|
|
apply (clarsimp simp: to_bool_def invs_weak_sch_act_wf invs_valid_objs'
|
|
split: if_split
|
|
cong: if_cong
|
|
| rule conjI)+
|
|
apply (clarsimp dest!: global'_no_ex_cap simp: invs'_def valid_state'_def | rule conjI)+
|
|
done
|
|
|
|
lemma invokeTCB_WriteRegisters_ccorres_helper:
|
|
"\<lbrakk> unat (f (of_nat n)) = incn
|
|
\<and> g (of_nat n) = register_from_H reg \<and> n'=incn
|
|
\<and> of_nat n < bnd \<and> of_nat n < bnd2 \<rbrakk> \<Longrightarrow>
|
|
ccorres dc xfdc (sysargs_rel args buffer and sysargs_rel_n args buffer n' and tcb_at' dst and P)
|
|
(\<lbrace>\<acute>i = of_nat n\<rbrace>) hs
|
|
(asUser dst (setRegister reg
|
|
(sanitiseRegister tcb reg (args ! incn))))
|
|
(\<acute>ret__unsigned_long :== CALL getSyscallArg(f (\<acute>i),option_to_ptr buffer);;
|
|
Guard ArrayBounds \<lbrace>\<acute>i < bnd\<rbrace>
|
|
(\<acute>unsigned_long_eret_2 :== CALL sanitiseRegister(g (\<acute>i),\<acute>ret__unsigned_long,from_bool t));;
|
|
Guard ArrayBounds \<lbrace>\<acute>i < bnd2\<rbrace>
|
|
(CALL setRegister(tcb_ptr_to_ctcb_ptr dst,g (\<acute>i),\<acute>unsigned_long_eret_2)))"
|
|
apply (rule ccorres_guard_imp2)
|
|
apply (rule ccorres_add_return)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (ctac add: getSyscallArg_ccorres_foo[where args=args and n="incn" and buffer=buffer])
|
|
apply (rule ccorres_symb_exec_r)
|
|
apply (ctac add: setRegister_ccorres)
|
|
apply vcg
|
|
apply (rule conseqPre, vcg, clarsimp)
|
|
apply wp
|
|
apply simp
|
|
apply (vcg exspec=getSyscallArg_modifies)
|
|
apply (fastforce)
|
|
done
|
|
|
|
lemma doMachineOp_context:
|
|
"(rv,s') \<in> fst (doMachineOp f s) \<Longrightarrow>
|
|
(rv,s'\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbContext_update (\<lambda>_. st) ko))\<rparr>)
|
|
\<in> fst (doMachineOp f (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbContext_update (\<lambda>_. st) ko))\<rparr>))"
|
|
apply (clarsimp simp: doMachineOp_def split_def in_monad select_f_def)
|
|
apply fastforce
|
|
done
|
|
|
|
|
|
lemma getObject_context:
|
|
" \<lbrakk>(x, s') \<in> fst (getObject t' s); ko_at' ko t s\<rbrakk>
|
|
\<Longrightarrow> (if t = t' then tcbContext_update (\<lambda>_. st) x else x,
|
|
s'\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbContext_update (\<lambda>_. st) ko))\<rparr>)
|
|
\<in> fst (getObject t' (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbContext_update (\<lambda>_. st) ko))\<rparr>))"
|
|
apply (simp split: if_split)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (clarsimp simp: getObject_def split_def loadObject_default_def in_monad
|
|
Corres_C.in_magnitude_check' projectKOs objBits_simps')
|
|
apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs objBits_simps)
|
|
apply (simp add: magnitudeCheck_def in_monad split: option.splits)
|
|
apply clarsimp
|
|
apply (simp add: lookupAround2_char2)
|
|
apply (clarsimp split: if_split_asm)
|
|
apply (erule_tac x=x2 in allE)
|
|
apply (clarsimp simp: ps_clear_def)
|
|
apply (drule_tac x=x2 in orthD2)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule impE)
|
|
apply simp
|
|
apply (erule notE, rule word_diff_ls'(3))
|
|
apply unat_arith
|
|
apply (drule is_aligned_no_overflow)
|
|
apply simp
|
|
apply clarsimp
|
|
apply (clarsimp simp: getObject_def split_def loadObject_default_def in_monad
|
|
Corres_C.in_magnitude_check' projectKOs objBits_simps')
|
|
apply (simp add: magnitudeCheck_def in_monad split: option.splits)
|
|
apply clarsimp
|
|
apply (simp add: lookupAround2_char2)
|
|
apply (clarsimp split: if_split_asm)
|
|
apply (erule_tac x=t in allE)
|
|
apply simp
|
|
apply (clarsimp simp: obj_at'_real_def projectKOs
|
|
ko_wp_at'_def objBits_simps)
|
|
apply (simp add: ps_clear_def)
|
|
apply (drule_tac x=t in orthD2)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule impE)
|
|
apply simp
|
|
apply (erule notE, rule word_diff_ls'(3))
|
|
apply unat_arith
|
|
apply (drule is_aligned_no_overflow)
|
|
apply simp
|
|
apply (erule_tac x=x2 in allE)
|
|
apply (clarsimp simp: ps_clear_def)
|
|
apply (drule_tac x=x2 in orthD2)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule impE)
|
|
apply (rule word_diff_ls'(3))
|
|
apply unat_arith
|
|
apply (drule is_aligned_no_overflow)
|
|
apply simp
|
|
apply fastforce
|
|
done
|
|
|
|
lemma threadGet_context:
|
|
"\<lbrakk> (uc, s') \<in> fst (threadGet (atcbContextGet o tcbArch) (ksCurThread s) s); ko_at' ko t s;
|
|
t \<noteq> ksCurThread s \<rbrakk> \<Longrightarrow>
|
|
(uc, s'\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>) \<in>
|
|
fst (threadGet (atcbContextGet o tcbArch) (ksCurThread s) (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>))"
|
|
apply (clarsimp simp: threadGet_def liftM_def in_monad)
|
|
apply (drule (1) getObject_context [where st=st])
|
|
apply (rule exI)
|
|
apply (erule conjI)
|
|
apply (simp split: if_splits)
|
|
done
|
|
|
|
|
|
lemma asUser_context:
|
|
"\<lbrakk>(x,s) \<in> fst (asUser (ksCurThread s) f s); ko_at' ko t s; \<And>s. \<lbrace>(=) s\<rbrace> f \<lbrace>\<lambda>_. (=) s\<rbrace> ;
|
|
t \<noteq> ksCurThread s\<rbrakk> \<Longrightarrow>
|
|
(x,s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>) \<in>
|
|
fst (asUser (ksCurThread s) f (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>))"
|
|
apply (clarsimp simp: asUser_def in_monad select_f_def)
|
|
apply (frule use_valid, rule threadGet_inv [where P="(=) s"], rule refl)
|
|
apply (frule use_valid, assumption, rule refl)
|
|
apply clarsimp
|
|
apply (frule (2) threadGet_context)
|
|
apply (intro exI)
|
|
apply (erule conjI)
|
|
apply (rule exI, erule conjI)
|
|
apply (clarsimp simp: threadSet_def in_monad)
|
|
apply (frule use_valid, rule getObject_inv [where P="(=) s"])
|
|
apply (simp add: loadObject_default_def)
|
|
apply wp
|
|
apply simp
|
|
apply (rule refl)
|
|
apply clarsimp
|
|
apply (frule (1) getObject_context)
|
|
apply (intro exI)
|
|
apply (erule conjI)
|
|
apply (clarsimp simp: setObject_def split_def updateObject_default_def threadGet_def
|
|
Corres_C.in_magnitude_check' getObject_def loadObject_default_def liftM_def
|
|
objBits_simps' projectKOs in_monad)
|
|
|
|
apply (clarsimp simp: magnitudeCheck_def in_monad split: option.splits)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (cases s, simp)
|
|
apply (rule ext, clarsimp split: if_split)
|
|
apply (case_tac tcb, simp)
|
|
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply (clarsimp simp add: lookupAround2_char2 split: if_split_asm)
|
|
apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs objBits_simps)
|
|
apply (erule_tac x=t in allE)
|
|
apply simp
|
|
apply (simp add: ps_clear_def)
|
|
apply (drule_tac x=t in orthD2)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule impE, simp)
|
|
apply (erule notE, rule word_diff_ls'(3))
|
|
apply unat_arith
|
|
apply (drule is_aligned_no_overflow)
|
|
apply simp
|
|
apply (erule_tac x=x2 in allE)
|
|
apply simp
|
|
apply (simp add: ps_clear_def)
|
|
apply (drule_tac x=x2 in orthD2)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule impE)
|
|
apply (rule word_diff_ls'(3))
|
|
apply unat_arith
|
|
apply (drule is_aligned_no_overflow)
|
|
apply simp
|
|
apply (erule impE, simp)
|
|
apply simp
|
|
apply (rule exI)
|
|
apply (rule conjI, fastforce)
|
|
apply clarsimp
|
|
apply (cases s, clarsimp)
|
|
apply (rule ext, clarsimp split: if_split)
|
|
apply (case_tac tcb, clarsimp)
|
|
done
|
|
|
|
|
|
lemma getMRs_rel_context:
|
|
"\<lbrakk>getMRs_rel args buffer s;
|
|
(cur_tcb' and case_option \<top> valid_ipc_buffer_ptr' buffer) s;
|
|
ko_at' ko t s ; t \<noteq> ksCurThread s\<rbrakk> \<Longrightarrow>
|
|
getMRs_rel args buffer (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>)"
|
|
apply (clarsimp simp: getMRs_rel_def)
|
|
apply (rule exI, erule conjI)
|
|
apply (subst (asm) det_wp_use, rule det_wp_getMRs)
|
|
apply (simp add: cur_tcb'_def)
|
|
apply (subst det_wp_use, rule det_wp_getMRs)
|
|
apply (simp add: cur_tcb'_def)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs
|
|
objBits_simps ps_clear_def split: if_split)
|
|
apply (clarsimp simp: valid_ipc_buffer_ptr'_def split: option.splits)
|
|
apply (clarsimp simp: typ_at'_def ko_wp_at'_def projectKOs obj_at'_real_def
|
|
objBits_simps ps_clear_def split: if_split)
|
|
apply (clarsimp simp: getMRs_def in_monad)
|
|
apply (frule use_valid, rule asUser_inv [where P="(=) s"])
|
|
apply (wp mapM_wp' getRegister_inv)[1]
|
|
apply simp
|
|
apply clarsimp
|
|
apply (drule (1) asUser_context)
|
|
apply (wp mapM_wp' getRegister_inv)[1]
|
|
apply assumption
|
|
apply (intro exI)
|
|
apply (erule conjI)
|
|
apply (cases buffer)
|
|
apply (clarsimp simp: return_def)
|
|
apply clarsimp
|
|
apply (drule mapM_upd_inv [rotated -1])
|
|
prefer 3
|
|
apply fastforce
|
|
prefer 2
|
|
apply wp
|
|
apply (clarsimp simp: loadWordUser_def in_monad stateAssert_def word_size
|
|
simp del: fun_upd_apply)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: pointerInUserData_def typ_at'_def ko_wp_at'_def
|
|
projectKOs ps_clear_def obj_at'_real_def
|
|
split: if_split)
|
|
apply (erule doMachineOp_context)
|
|
done
|
|
|
|
lemma asUser_getMRs_rel:
|
|
"\<lbrace>(\<lambda>s. t \<noteq> ksCurThread s) and getMRs_rel args buffer and cur_tcb'
|
|
and case_option \<top> valid_ipc_buffer_ptr' buffer \<rbrace>
|
|
asUser t f \<lbrace>\<lambda>_. getMRs_rel args buffer\<rbrace>"
|
|
apply (simp add: asUser_def)
|
|
apply (rule hoare_pre, wp)
|
|
apply (simp add: threadSet_def)
|
|
apply (simp add: setObject_def split_def updateObject_default_def)
|
|
apply wp
|
|
apply (simp del: fun_upd_apply)
|
|
apply (wp getObject_tcb_wp)
|
|
apply (wp threadGet_wp)+
|
|
apply (clarsimp simp del: fun_upd_apply)
|
|
apply (drule obj_at_ko_at')+
|
|
apply (clarsimp simp del: fun_upd_apply)
|
|
apply (rule exI, rule conjI, assumption)
|
|
apply (clarsimp split: if_split simp del: fun_upd_apply)
|
|
apply (erule getMRs_rel_context, simp)
|
|
apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs)
|
|
apply simp
|
|
done
|
|
|
|
|
|
lemma asUser_sysargs_rel:
|
|
"\<lbrace>\<lambda>s. t \<noteq> ksCurThread s \<and> sysargs_rel args buffer s\<rbrace>
|
|
asUser t f \<lbrace>\<lambda>_. sysargs_rel args buffer\<rbrace>"
|
|
apply (cases buffer, simp_all add: sysargs_rel_def)
|
|
apply (rule hoare_pre)
|
|
apply (wp asUser_getMRs_rel hoare_valid_ipc_buffer_ptr_typ_at'|simp)+
|
|
done
|
|
|
|
lemma threadSet_same:
|
|
"\<lbrace>\<lambda>s. \<exists>tcb'. ko_at' tcb' t s \<and> tcb = f tcb'\<rbrace> threadSet f t \<lbrace>\<lambda>rv. ko_at' tcb t\<rbrace>"
|
|
unfolding threadSet_def
|
|
by (wpsimp wp: setObject_tcb_strongest getObject_tcb_wp) fastforce
|
|
|
|
lemma invokeTCB_WriteRegisters_ccorres[where S=UNIV]:
|
|
notes static_imp_wp [wp]
|
|
shows
|
|
"ccorres (cintr \<currency> (\<lambda>rv rv'. rv = [])) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and tcb_at' dst and ex_nonz_cap_to' dst and sch_act_simple
|
|
and sysargs_rel args buffer
|
|
and (\<lambda>s. dst \<noteq> ksCurThread s)
|
|
and (\<lambda>_. values = take someNum (drop 2 args)
|
|
\<and> someNum + 2 \<le> length args))
|
|
({s. unat (n_' s) = length values} \<inter> S
|
|
\<inter> {s. unat (n_' s) = length values}
|
|
\<inter> {s. dest_' s = tcb_ptr_to_ctcb_ptr dst}
|
|
\<inter> {s. resumeTarget_' s = from_bool resume}
|
|
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
|
|
(invokeTCB (WriteRegisters dst resume values arch))
|
|
(Call invokeTCB_WriteRegisters_'proc)"
|
|
including no_take_bit
|
|
apply (rule ccorres_gen_asm)
|
|
apply (erule conjE)
|
|
apply (cinit lift: n_' dest_' resumeTarget_' buffer_'
|
|
simp: whileAnno_def)
|
|
(* using S not univ seems to stop cinit doing this? *)
|
|
apply (csymbr, csymbr, csymbr, csymbr)
|
|
apply (simp add: liftE_def bind_assoc
|
|
del: Collect_const)
|
|
apply (rule ccorres_pre_getCurThread)
|
|
apply (rule_tac P="\<lambda>a. ccorres_underlying rf_sr \<Gamma> r' xf arrel axf P P' hs a c" for r' xf arrel axf P P' hs c in subst)
|
|
apply (rule liftE_bindE)
|
|
|
|
apply (ctac add: Arch_performTransfer_ccorres)
|
|
apply (simp add: Collect_False whileAnno_def del: Collect_const)
|
|
apply (rule ccorres_add_return)
|
|
apply (rule_tac xf'=n_' and r'="\<lambda>rv rv'. rv' = min n (scast n_frameRegisters + scast n_gpRegisters)"
|
|
in ccorres_split_nothrow)
|
|
apply (rule_tac P'="{s. n_' s = n}" in ccorres_from_vcg[where P=\<top>])
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (clarsimp simp: return_def min_def)
|
|
apply (simp add: linorder_not_less[symmetric] n_gpRegisters_def n_frameRegisters_def)
|
|
apply ceqv
|
|
apply (ctac add: Arch_getSanitiseRegisterInfo_ccorres)
|
|
apply (simp add: zipWithM_mapM split_def zip_append1 mapM_discarded mapM_x_append
|
|
del: Collect_const)
|
|
apply (simp add: asUser_bind_distrib getRestartPC_def setNextPC_def bind_assoc
|
|
del: Collect_const)
|
|
apply (simp only: getRestartPC_def[symmetric] setNextPC_def[symmetric])
|
|
apply (simp add: asUser_mapM_x bind_assoc)
|
|
apply (rule ccorres_stateAssert)
|
|
apply (rule ccorres_rhs_assoc2, rule ccorres_split_nothrow_novcg)
|
|
apply (rule_tac F="\<lambda>n. sysargs_rel args buffer and sysargs_rel_n args buffer (n + 2)
|
|
and tcb_at' dst and (\<lambda>s. dst \<noteq> ksCurThread s)"
|
|
and Q=UNIV in ccorres_mapM_x_whileQ)
|
|
apply clarsimp
|
|
apply (rule invokeTCB_WriteRegisters_ccorres_helper [where args=args])
|
|
apply (simp add: unat_word_ariths frame_gp_registers_convs n_frameRegisters_def
|
|
unat_of_nat32 word_bits_def word_of_nat_less)
|
|
apply (simp add: n_frameRegisters_def n_gpRegisters_def
|
|
frame_gp_registers_convs word_less_nat_alt)
|
|
apply (simp add: unat_of_nat32 word_bits_def)
|
|
apply arith
|
|
apply clarsimp
|
|
apply (vcg exspec=setRegister_modifies exspec=getSyscallArg_modifies
|
|
exspec=sanitiseRegister_modifies)
|
|
apply clarsimp
|
|
apply (simp add: sysargs_rel_n_def)
|
|
apply (rule hoare_pre, wp asUser_sysargs_rel)
|
|
apply (clarsimp simp: n_msgRegisters_def sysargs_rel_def)
|
|
apply (simp add: frame_gp_registers_convs n_frameRegisters_def word_bits_def)
|
|
apply simp
|
|
apply (rule ceqv_refl)
|
|
apply (rule ccorres_stateAssert)
|
|
apply (rule ccorres_rhs_assoc2, rule ccorres_split_nothrow_novcg)
|
|
apply (rule_tac F="\<lambda>n. sysargs_rel args buffer
|
|
and sysargs_rel_n args buffer (n + length ARM_H.frameRegisters + 2)
|
|
and tcb_at' dst
|
|
and (\<lambda>s. dst \<noteq> ksCurThread s)"
|
|
and Q=UNIV in ccorres_mapM_x_whileQ)
|
|
apply clarsimp
|
|
apply (rule invokeTCB_WriteRegisters_ccorres_helper [where args=args])
|
|
apply (simp add: n_gpRegisters_def unat_word_ariths
|
|
frame_gp_registers_convs unat_of_nat32
|
|
word_bits_def n_frameRegisters_def word_of_nat_less)
|
|
apply (simp add: n_frameRegisters_def n_gpRegisters_def
|
|
frame_gp_registers_convs unat_of_nat32
|
|
word_less_nat_alt word_bits_def less_diff_conv)
|
|
apply (simp add: unat_word_ariths cong: conj_cong)
|
|
apply clarsimp
|
|
apply (vcg exspec=setRegister_modifies exspec=getSyscallArg_modifies
|
|
exspec=sanitiseRegister_modifies)
|
|
apply clarsimp
|
|
apply (simp add: sysargs_rel_n_def)
|
|
apply (rule hoare_pre, wp asUser_sysargs_rel)
|
|
apply (clarsimp simp: n_msgRegisters_def frame_gp_registers_convs
|
|
n_frameRegisters_def)
|
|
apply arith
|
|
apply (simp add: ARM_H.gpRegisters_def word_bits_def
|
|
ARM.gpRegisters_def)
|
|
apply simp
|
|
apply (rule ceqv_refl)
|
|
apply (ctac(no_vcg) add: getRestartPC_ccorres)
|
|
apply simp
|
|
apply (ctac(no_vcg) add: setNextPC_ccorres)
|
|
apply (ctac (no_vcg) add: postModifyRegisters_ccorres[simplified])
|
|
apply (rule ccorres_split_nothrow_novcg)
|
|
apply (rule ccorres_when[where R=\<top>])
|
|
apply (simp add: from_bool_0 Collect_const_mem)
|
|
apply (rule_tac xf'="\<lambda>_. 0" in ccorres_call)
|
|
apply (rule restart_ccorres)
|
|
apply simp
|
|
apply (simp add: xfdc_def)
|
|
apply simp
|
|
apply (rule ceqv_refl)
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule_tac R="\<lambda>s. rv = ksCurThread s"
|
|
in ccorres_when)
|
|
apply (clarsimp simp: rf_sr_ksCurThread)
|
|
apply clarsimp
|
|
apply (ctac (no_vcg) add: rescheduleRequired_ccorres)
|
|
apply (unfold return_returnOk)[1]
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply wp
|
|
apply (simp add: guard_is_UNIV_def)
|
|
apply (wp hoare_drop_imp)
|
|
apply (rule_tac Q="\<lambda>rv. invs' and tcb_at' dst" in hoare_strengthen_post[rotated])
|
|
apply (fastforce simp: sch_act_wf_weak)
|
|
apply (wpsimp wp: restart_invs')+
|
|
apply (clarsimp simp add: guard_is_UNIV_def)
|
|
apply (wp hoare_drop_imp hoare_vcg_if_lift)+
|
|
apply simp
|
|
apply (rule mapM_x_wp')
|
|
apply (wpsimp)
|
|
apply (simp add: guard_is_UNIV_def)
|
|
apply (rule hoare_drop_imps)
|
|
apply (simp add: sysargs_rel_n_def)
|
|
apply (rule mapM_x_wp')
|
|
apply (rule hoare_pre, wp asUser_sysargs_rel)
|
|
apply clarsimp
|
|
apply (simp add: guard_is_UNIV_def)
|
|
apply (wp)
|
|
apply vcg
|
|
apply (wp threadGet_wp)
|
|
apply vcg
|
|
apply (rule ccorres_inst[where P=\<top> and P'=UNIV])
|
|
apply simp
|
|
apply (simp add: performTransfer_def)
|
|
apply wp
|
|
apply clarsimp
|
|
apply vcg
|
|
apply (clarsimp simp: n_msgRegisters_def sysargs_rel_n_def split: if_split)
|
|
apply (rule conjI)
|
|
apply (cases args, simp)
|
|
apply (case_tac list, simp)
|
|
apply (case_tac lista, clarsimp simp: unat_eq_0)
|
|
apply simp
|
|
apply (clarsimp simp: frame_gp_registers_convs word_less_nat_alt
|
|
sysargs_rel_def n_frameRegisters_def n_msgRegisters_def
|
|
split: if_split_asm)
|
|
apply (simp add: invs_weak_sch_act_wf invs_valid_objs' invs_queues)
|
|
apply (fastforce dest!: global'_no_ex_cap simp: invs'_def valid_state'_def)
|
|
done
|
|
|
|
lemma invokeTCB_Suspend_ccorres:
|
|
"ccorres (cintr \<currency> (\<lambda>rv rv'. rv = [])) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and sch_act_simple and tcb_at' t and ex_nonz_cap_to' t)
|
|
(UNIV \<inter> {s. thread_' s = tcb_ptr_to_ctcb_ptr t}) []
|
|
(invokeTCB (Suspend t)) (Call invokeTCB_Suspend_'proc)"
|
|
apply (cinit lift: thread_')
|
|
apply (simp add: liftE_def return_returnOk)
|
|
apply (ctac(no_vcg) add: suspend_ccorres[OF cteDeleteOne_ccorres])
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply wp
|
|
apply (clarsimp simp: from_bool_def true_def)
|
|
apply (auto simp: invs'_def valid_state'_def global'_no_ex_cap)
|
|
done
|
|
|
|
lemma invokeTCB_Resume_ccorres:
|
|
"ccorres (cintr \<currency> (\<lambda>rv rv'. rv = [])) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and tcb_at' t and ex_nonz_cap_to' t and sch_act_simple)
|
|
(UNIV \<inter> {s. thread_' s = tcb_ptr_to_ctcb_ptr t}) []
|
|
(invokeTCB (Resume t)) (Call invokeTCB_Resume_'proc)"
|
|
apply (cinit lift: thread_')
|
|
apply (simp add: liftE_def return_returnOk)
|
|
apply (ctac(no_vcg) add: restart_ccorres)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply wp
|
|
apply (clarsimp simp: from_bool_def true_def)
|
|
done
|
|
|
|
lemma Arch_decodeTransfer_spec:
|
|
"\<forall>s. \<Gamma> \<turnstile> {s} Call Arch_decodeTransfer_'proc {s'. ret__unsigned_long_' s' = 0}"
|
|
by (vcg, simp)
|
|
|
|
lemmas ccorres_split_nothrow_dc
|
|
= ccorres_split_nothrow[where r'=dc and xf'=xfdc, OF _ ceqv_refl]
|
|
|
|
lemmas getRegister_ccorres_defer
|
|
= ccorres_defer[OF getRegister_ccorres, OF no_fail_asUser [OF no_fail_getRegister]]
|
|
|
|
lemma msg_registers_convs:
|
|
"length ARM_H.msgRegisters = unat n_msgRegisters"
|
|
"n < length ARM_H.msgRegisters \<Longrightarrow>
|
|
index msgRegistersC n = register_from_H (ARM_H.msgRegisters ! n)"
|
|
apply (simp_all add: msgRegisters_unfold
|
|
ARM.msgRegisters_def n_msgRegisters_def
|
|
msgRegistersC_def fupdate_def Arrays.update_def)
|
|
apply (auto simp: less_Suc_eq fcp_beta)
|
|
done
|
|
|
|
lemma mapM_x_split_append:
|
|
"mapM_x f xs = do _ \<leftarrow> mapM_x f (take n xs); mapM_x f (drop n xs) od"
|
|
using mapM_x_append[where f=f and xs="take n xs" and ys="drop n xs"]
|
|
by simp
|
|
|
|
lemma ccorres_abstract_cong:
|
|
"\<lbrakk> \<And>s s'. \<lbrakk> P s ; s' \<in> P'; (s, s') \<in> sr \<rbrakk> \<Longrightarrow> a s = b s \<rbrakk> \<Longrightarrow>
|
|
ccorres_underlying sr G r xf ar axf P P' hs a c
|
|
= ccorres_underlying sr G r xf ar axf P P' hs b c"
|
|
by (simp add: ccorres_underlying_def split_paired_Ball imp_conjL
|
|
cong: conj_cong xstate.case_cong)
|
|
|
|
lemma valid_ipc_buffer_ptr_the_strengthen:
|
|
"x \<noteq> None \<and> case_option \<top> valid_ipc_buffer_ptr' x s \<longrightarrow> valid_ipc_buffer_ptr' (the x) s"
|
|
by clarsimp
|
|
|
|
|
|
lemma lookupIPCBuffer_Some_0:
|
|
"\<lbrace>\<top>\<rbrace> lookupIPCBuffer w t \<lbrace>\<lambda>rv s. rv \<noteq> Some 0\<rbrace>"
|
|
apply (simp add: lookupIPCBuffer_def
|
|
ARM_H.lookupIPCBuffer_def
|
|
Let_def getThreadBufferSlot_def
|
|
locateSlot_conv
|
|
cong: if_cong)
|
|
apply (wp haskell_assert_wp | wpc | simp)+
|
|
done
|
|
|
|
lemma asUser_valid_ipc_buffer_ptr':
|
|
"\<lbrace> valid_ipc_buffer_ptr' p \<rbrace> asUser t m \<lbrace> \<lambda>rv s. valid_ipc_buffer_ptr' p s \<rbrace>"
|
|
by (simp add: valid_ipc_buffer_ptr'_def, wp, auto simp: valid_ipc_buffer_ptr'_def)
|
|
|
|
lemma invokeTCB_ReadRegisters_ccorres:
|
|
notes
|
|
nat_min_simps [simp del]
|
|
wordSize_def' [simp]
|
|
shows
|
|
"ccorres ((intr_and_se_rel \<circ> Inr) \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and (\<lambda>s. ksCurThread s = thread) and ct_in_state' ((=) Restart)
|
|
and tcb_at' target and sch_act_simple and (\<lambda>s. target \<noteq> ksIdleThread s)
|
|
and (\<lambda>_. target \<noteq> thread))
|
|
(UNIV
|
|
\<inter> {s. tcb_src_' s = tcb_ptr_to_ctcb_ptr target}
|
|
\<inter> {s. suspendSource_' s = from_bool susp}
|
|
\<inter> {s. n_' s = n}
|
|
\<inter> {s. call_' s = from_bool isCall}) []
|
|
(doE reply \<leftarrow> invokeTCB (ReadRegisters target susp n archCp);
|
|
liftE (replyOnRestart thread reply isCall) odE)
|
|
(Call invokeTCB_ReadRegisters_'proc)"
|
|
including no_take_bit
|
|
supply option.case_cong_weak[cong]
|
|
apply (rule ccorres_gen_asm)
|
|
apply (cinit' lift: tcb_src_' suspendSource_' n_' call_'
|
|
simp: invokeTCB_def liftE_bindE bind_assoc)
|
|
apply (rule ccorres_symb_exec_r)
|
|
apply (rule_tac xf'=thread_' in ccorres_abstract, ceqv)
|
|
apply (rename_tac cthread,
|
|
rule_tac P="cthread = tcb_ptr_to_ctcb_ptr thread" in ccorres_gen_asm2)
|
|
apply (rule ccorres_split_nothrow_dc)
|
|
apply (simp add: when_def del: Collect_const split del: if_split)
|
|
apply (rule ccorres_cond2[where R=\<top>], simp add: from_bool_0 Collect_const_mem)
|
|
apply (ctac add: suspend_ccorres[OF cteDeleteOne_ccorres])
|
|
apply (rule ccorres_return_Skip)
|
|
apply (rule ccorres_pre_getCurThread)
|
|
apply (simp only: liftE_bindE[symmetric])
|
|
apply (ctac add: Arch_performTransfer_ccorres)
|
|
apply (simp add: liftE_bindE Collect_False
|
|
del: Collect_const)
|
|
apply (simp add: replyOnRestart_def liftE_def bind_assoc when_def
|
|
replyFromKernel_def if_to_top_of_bind setMRs_def
|
|
zipWithM_x_mapM_x asUser_mapM_x split_def
|
|
del: Collect_const cong: if_cong)
|
|
apply (rule ccorres_symb_exec_l)
|
|
apply (rule ccorres_symb_exec_l[OF _ _ _ empty_fail_getThreadState])
|
|
apply (rule ccorres_if_lhs[OF _ ccorres_False[where P'=UNIV]])
|
|
apply (rule ccorres_if_lhs)
|
|
apply (simp add: Collect_True true_def whileAnno_def del: Collect_const)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply csymbr
|
|
apply (ctac add: lookupIPCBuffer_ccorres)
|
|
apply (ctac add: setRegister_ccorres)
|
|
apply (rule ccorres_stateAssert)
|
|
apply (rule ccorres_rhs_assoc2)
|
|
apply (rule_tac P="length reply
|
|
= min (unat n) (unat n_frameRegisters + unat n_gpRegisters)"
|
|
in ccorres_gen_asm)
|
|
apply (rule ccorres_split_nothrow_novcg)
|
|
apply (rule_tac F="\<lambda>m s. obj_at' (\<lambda>tcb. map ((atcbContextGet o tcbArch) tcb) (genericTake n
|
|
(ARM_H.frameRegisters @ ARM_H.gpRegisters))
|
|
= reply) target s"
|
|
in ccorres_mapM_x_while)
|
|
apply clarsimp
|
|
apply (rule ccorres_guard_imp2)
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getRegister_ccorres_defer
|
|
[where thread=target])
|
|
apply (ctac add: setRegister_ccorres)
|
|
apply wp
|
|
apply simp
|
|
apply (vcg exspec=getRegister_modifies)
|
|
apply (clarsimp simp: getRegister_def submonad_asUser.guarded_gets)
|
|
apply (clarsimp simp: simpler_gets_def obj_at'_weakenE[OF _ TrueI]
|
|
msg_registers_convs)
|
|
apply (cut_tac x=na in unat_of_nat32)
|
|
apply (simp add: word_bits_def n_msgRegisters_def)
|
|
apply (simp add: msg_registers_convs n_msgRegisters_def
|
|
word_of_nat_less)
|
|
apply (subgoal_tac "na < unat n_frameRegisters")
|
|
apply (intro conjI[rotated] allI impI)
|
|
apply (assumption | erule sym)
|
|
apply (rule frame_gp_registers_convs)
|
|
apply (simp add: frame_gp_registers_convs)
|
|
apply (drule obj_at_ko_at')
|
|
apply (clarsimp simp: obj_at'_def projectKOs asUser_fetch_def
|
|
frame_gp_registers_convs genericTake_def
|
|
nth_append
|
|
split: if_split)
|
|
apply (simp add: n_frameRegisters_def n_msgRegisters_def)
|
|
apply (simp add: frame_gp_registers_convs msg_registers_convs
|
|
n_msgRegisters_def n_frameRegisters_def
|
|
n_gpRegisters_def msgMaxLength_def msgLengthBits_def
|
|
split: option.split)
|
|
apply (simp add: min_def word_less_nat_alt split: if_split)[1]
|
|
apply arith
|
|
apply (rule allI, rule conseqPre, vcg exspec=setRegister_modifies
|
|
exspec=getRegister_modifies)
|
|
apply clarsimp
|
|
apply (wp asUser_obj_at')
|
|
apply simp
|
|
apply (simp add: word_bits_def msgMaxLength_def
|
|
msg_registers_convs n_msgRegisters_def)
|
|
apply ceqv
|
|
(* got to split reply into frameregisters part and gpregisters
|
|
part remaining, match against 2nd and 4th loop. 3rd loop
|
|
never executes with current configuration *)
|
|
apply (simp add: msg_registers_convs del: Collect_const)
|
|
apply (rule iffD2 [OF ccorres_abstract_cong])
|
|
apply (rule bind_apply_cong[OF _ refl])
|
|
apply (rule_tac n1="min (unat n_frameRegisters - unat n_msgRegisters) (unat n)"
|
|
in fun_cong [OF mapM_x_split_append])
|
|
apply (rule_tac P="rva \<noteq> Some 0" in ccorres_gen_asm)
|
|
apply (subgoal_tac "(ipcBuffer = NULL) = (rva = None)")
|
|
prefer 2
|
|
apply (clarsimp simp: option_to_ptr_def option_to_0_def
|
|
split: option.split_asm)
|
|
apply (simp add: bind_assoc del: Collect_const)
|
|
apply (rule_tac xf'=i_' and r'="\<lambda>_ rv. unat rv = min (unat n_frameRegisters)
|
|
(min (unat n)
|
|
(case rva of None \<Rightarrow> unat n_msgRegisters
|
|
| _ \<Rightarrow> unat n_frameRegisters))"
|
|
in ccorres_split_nothrow_novcg)
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply (rule ccorres_rel_imp,
|
|
rule_tac F="\<lambda>m s. obj_at' (\<lambda>tcb. map ((atcbContextGet o tcbArch) tcb) (genericTake n
|
|
(ARM_H.frameRegisters @ ARM_H.gpRegisters))
|
|
= reply) target s
|
|
\<and> valid_ipc_buffer_ptr' (the rva) s
|
|
\<and> valid_pspace' s"
|
|
and i="unat n_msgRegisters"
|
|
in ccorres_mapM_x_while')
|
|
apply (intro allI impI, elim conjE exE, hypsubst, simp)
|
|
apply (simp add: less_diff_conv)
|
|
apply (rule ccorres_guard_imp2)
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getRegister_ccorres_defer[where thread=target])
|
|
apply (rule ccorres_move_array_assertion_ipc_buffer
|
|
| (rule ccorres_flip_Guard,
|
|
rule ccorres_move_array_assertion_ipc_buffer))+
|
|
apply (rule storeWordUser_ccorres)
|
|
apply wp
|
|
apply (vcg exspec=getRegister_modifies)
|
|
apply (clarsimp simp: obj_at'_weakenE[OF _ TrueI]
|
|
word_size unat_gt_0 option_to_ptr_def
|
|
option_to_0_def)
|
|
apply (intro conjI[rotated] impI allI)
|
|
apply (simp add: n_msgRegisters_def n_frameRegisters_def
|
|
word_less_nat_alt)
|
|
apply (subst unat_add_lem[THEN iffD1], simp_all add: unat_of_nat)[1]
|
|
prefer 3
|
|
apply (erule sym)
|
|
apply (simp add: n_msgRegisters_def msg_registers_convs
|
|
msg_align_bits msgMaxLength_def)
|
|
apply (simp(no_asm) add: unat_arith_simps unat_of_nat
|
|
cong: if_cong, simp)
|
|
apply (simp add: n_msgRegisters_def msg_registers_convs
|
|
msg_align_bits msgMaxLength_def)
|
|
apply (simp(no_asm) add: unat_arith_simps unat_of_nat
|
|
cong: if_cong, simp)
|
|
apply (simp add: option_to_ptr_def option_to_0_def
|
|
msg_registers_convs upto_enum_word wordSize_def'
|
|
del: upt.simps)
|
|
apply (rule frame_gp_registers_convs)
|
|
apply (simp add: frame_gp_registers_convs less_diff_conv)
|
|
apply (subst iffD1 [OF unat_add_lem])
|
|
apply (simp add: n_msgRegisters_def n_frameRegisters_def
|
|
word_le_nat_alt unat_of_nat)
|
|
apply (simp add: n_frameRegisters_def n_msgRegisters_def
|
|
unat_of_nat)
|
|
apply (clarsimp simp: valid_ipc_buffer_ptr'_def)
|
|
apply (erule aligned_add_aligned)
|
|
apply (rule is_aligned_mult_triv2[where n=2, simplified])
|
|
apply (simp add: msg_align_bits)
|
|
apply (clarsimp simp: getRegister_def submonad_asUser.guarded_gets
|
|
obj_at'_weakenE[OF _ TrueI])
|
|
apply (clarsimp simp: asUser_fetch_def simpler_gets_def
|
|
obj_at'_def projectKOs genericTake_def
|
|
nth_append frame_gp_registers_convs)
|
|
apply (simp add: n_msgRegisters_def unat_of_nat n_frameRegisters_def)
|
|
apply (subst iffD1 [OF unat_add_lem])
|
|
apply (simp add: unat_of_nat)+
|
|
apply (clarsimp simp: less_diff_conv)
|
|
apply (simp add: frame_gp_registers_convs msg_registers_convs
|
|
n_msgRegisters_def n_frameRegisters_def
|
|
n_gpRegisters_def Types_H.msgMaxLength_def
|
|
Types_H.msgLengthBits_def
|
|
split: option.split)
|
|
apply (simp add: min_def word_less_nat_alt split: if_split)[1]
|
|
apply (simp split: if_split_asm, arith+)[1]
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply clarsimp
|
|
apply (wp)
|
|
apply (clarsimp simp: less_diff_conv)
|
|
apply (simp add: word_bits_def n_msgRegisters_def n_frameRegisters_def
|
|
Types_H.msgLengthBits_def Types_H.msgMaxLength_def
|
|
msg_registers_convs)
|
|
apply (clarsimp simp: n_msgRegisters_def n_frameRegisters_def
|
|
msgMaxLength_def Types_H.msgLengthBits_def
|
|
n_gpRegisters_def msg_registers_convs
|
|
split: option.split_asm)
|
|
apply (simp add: min_def split: if_split_asm if_split)
|
|
apply arith
|
|
apply (drule_tac s=rv'a in sym, simp)
|
|
apply (rule_tac P=\<top> and P'="{s. i_' s = rv'a}" in ccorres_inst)
|
|
apply clarsimp
|
|
apply (elim disjE impCE)
|
|
apply (clarsimp simp: word_le_nat_alt linorder_not_less)
|
|
apply (subst (asm) unat_of_nat32)
|
|
apply (simp add: n_msgRegisters_def word_bits_def)
|
|
apply (clarsimp simp: mapM_x_Nil)
|
|
apply (rule ccorres_guard_imp2, rule ccorres_return_Skip')
|
|
apply (simp add: n_msgRegisters_def n_frameRegisters_def
|
|
n_gpRegisters_def cong: option.case_cong)
|
|
apply (simp add: min_def split: if_split option.split)
|
|
apply (simp add: mapM_x_Nil)
|
|
apply (rule ccorres_guard_imp2, rule ccorres_return_Skip')
|
|
apply (simp add: n_msgRegisters_def n_frameRegisters_def
|
|
n_gpRegisters_def cong: option.case_cong)
|
|
apply (simp add: min_def split: if_split option.split)
|
|
apply (clarsimp simp only: unat_arith_simps, simp)
|
|
apply (clarsimp simp: less_diff_conv word_le_nat_alt linorder_not_less)
|
|
apply (subst(asm) unat_of_nat32)
|
|
apply (simp add: word_bits_def n_msgRegisters_def)
|
|
apply (simp add: mapM_x_Nil n_frameRegisters_def n_gpRegisters_def)
|
|
apply (rule ccorres_guard_imp2, rule ccorres_return_Skip')
|
|
apply (simp add: n_msgRegisters_def n_frameRegisters_def
|
|
n_gpRegisters_def cong: option.case_cong)
|
|
apply ceqv
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (rule iffD1[OF ccorres_expand_while_iff_Seq])
|
|
apply (rule ccorres_cond_false)
|
|
apply (rule ccorres_split_nothrow_novcg)
|
|
apply (rule_tac xf'=i_' in ccorres_abstract, ceqv)
|
|
apply (rename_tac i_c, rule_tac P="i_c = 0" in ccorres_gen_asm2)
|
|
apply (simp add: drop_zip del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply (simp del: Collect_const)
|
|
apply (rule_tac F="\<lambda>m s. obj_at' (\<lambda>tcb. map ((atcbContextGet o tcbArch) tcb) (genericTake n
|
|
(ARM_H.frameRegisters @ ARM_H.gpRegisters))
|
|
= reply) target s
|
|
\<and> valid_ipc_buffer_ptr' (the rva) s \<and> valid_pspace' s"
|
|
and i="0" in ccorres_mapM_x_while')
|
|
apply (clarsimp simp: less_diff_conv drop_zip)
|
|
apply (rule ccorres_guard_imp2)
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getRegister_ccorres_defer[where thread=target])
|
|
apply (rule ccorres_move_array_assertion_ipc_buffer
|
|
| (rule ccorres_flip_Guard,
|
|
rule ccorres_move_array_assertion_ipc_buffer))+
|
|
apply (rule storeWordUser_ccorres)
|
|
apply wp
|
|
apply (vcg exspec=getRegister_modifies)
|
|
apply (clarsimp simp: obj_at'_weakenE[OF _ TrueI]
|
|
word_size unat_gt_0 option_to_ptr_def
|
|
option_to_0_def)
|
|
apply (intro conjI[rotated] impI allI)
|
|
apply (simp add: n_frameRegisters_def n_msgRegisters_def
|
|
length_msgRegisters word_of_nat_less
|
|
n_gpRegisters_def)
|
|
prefer 3
|
|
apply (erule sym)
|
|
apply (simp add: n_frameRegisters_def n_msgRegisters_def msg_registers_convs
|
|
msg_align_bits msgMaxLength_def)
|
|
apply (simp(no_asm) add: unat_arith_simps unat_of_nat
|
|
cong: if_cong, simp)
|
|
apply (simp add: n_frameRegisters_def n_msgRegisters_def msg_registers_convs
|
|
msg_align_bits msgMaxLength_def)
|
|
apply (simp(no_asm) add: unat_arith_simps unat_of_nat
|
|
cong: if_cong, simp)
|
|
apply (simp add: option_to_ptr_def option_to_0_def
|
|
msg_registers_convs upto_enum_word
|
|
n_msgRegisters_def n_frameRegisters_def
|
|
n_gpRegisters_def msgMaxLength_def msgLengthBits_def
|
|
del: upt.simps upt_rec_numeral)
|
|
apply (rule frame_gp_registers_convs)
|
|
apply (simp add: frame_gp_registers_convs n_msgRegisters_def n_frameRegisters_def
|
|
n_gpRegisters_def msgMaxLength_def msgLengthBits_def
|
|
unat_of_nat)
|
|
apply (clarsimp simp: valid_ipc_buffer_ptr'_def,
|
|
erule aligned_add_aligned)
|
|
apply (rule is_aligned_mult_triv2[where n=2, simplified])
|
|
apply (simp add: msg_align_bits)
|
|
apply (clarsimp simp: getRegister_def submonad_asUser.guarded_gets
|
|
obj_at'_weakenE[OF _ TrueI])
|
|
apply (clarsimp simp: asUser_fetch_def simpler_gets_def
|
|
obj_at'_def projectKOs genericTake_def
|
|
nth_append frame_gp_registers_convs
|
|
n_frameRegisters_def n_gpRegisters_def
|
|
n_msgRegisters_def frame_gp_registers_convs
|
|
cong: if_cong split: if_split)
|
|
apply (clarsimp simp: frame_gp_registers_convs n_gpRegisters_def
|
|
min.absorb1 unat_of_nat)
|
|
apply (clarsimp simp: less_diff_conv)
|
|
apply (clarsimp simp: nth_append frame_gp_registers_convs
|
|
n_frameRegisters_def n_gpRegisters_def
|
|
n_msgRegisters_def frame_gp_registers_convs
|
|
Types_H.msgMaxLength_def Types_H.msgLengthBits_def
|
|
msg_registers_convs
|
|
cong: if_cong split: if_split)
|
|
apply (simp add: word_less_nat_alt unat_of_nat)
|
|
apply (simp add: iffD1[OF unat_add_lem] cong: conj_cong)
|
|
apply (simp add: min_def
|
|
split: if_split if_split_asm, arith+)[1]
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply clarsimp
|
|
apply wp
|
|
apply (simp add: word_bits_def n_frameRegisters_def n_gpRegisters_def
|
|
n_msgRegisters_def)
|
|
apply (simp add: min_less_iff_disj less_imp_diff_less)
|
|
apply (simp add: drop_zip n_gpRegisters_def)
|
|
apply (elim disjE impCE)
|
|
apply (clarsimp simp: mapM_x_Nil)
|
|
apply (rule ccorres_return_Skip')
|
|
apply (simp add: linorder_not_less word_le_nat_alt
|
|
drop_zip mapM_x_Nil n_frameRegisters_def
|
|
min.absorb1 n_msgRegisters_def)
|
|
apply (rule ccorres_guard_imp2, rule ccorres_return_Skip')
|
|
apply simp
|
|
apply ceqv
|
|
apply csymbr
|
|
apply (rule ccorres_rhs_assoc2)
|
|
apply (ctac (no_vcg) add: setMessageInfo_ccorres)
|
|
apply (ctac (no_vcg))
|
|
apply (rule_tac P=\<top> and P'=UNIV in ccorres_from_vcg_throws)
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (clarsimp simp: return_def)
|
|
apply (wp | simp add: valid_tcb_state'_def)+
|
|
apply (clarsimp simp: ThreadState_Running_def mask_def)
|
|
apply (rule mapM_x_wp')
|
|
apply (rule hoare_pre)
|
|
apply (wp sch_act_wf_lift valid_queues_lift tcb_in_cur_domain'_lift)
|
|
apply clarsimp
|
|
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
|
|
apply (simp add: message_info_to_H_def)
|
|
apply (clarsimp simp: n_frameRegisters_def n_msgRegisters_def
|
|
n_gpRegisters_def field_simps upto_enum_word
|
|
word_less_nat_alt Types_H.msgMaxLength_def
|
|
Types_H.msgLengthBits_def
|
|
simp del: upt.simps
|
|
split: option.split_asm)
|
|
apply (clarsimp simp: min_def iffD2 [OF mask_eq_iff_w2p] word_size
|
|
word_less_nat_alt
|
|
split: if_split_asm dest!: word_unat.Rep_inverse')
|
|
apply (clarsimp simp: length_msgRegisters n_msgRegisters_def)
|
|
apply (clarsimp simp: min_def iffD2 [OF mask_eq_iff_w2p] word_size
|
|
word_less_nat_alt
|
|
split: if_split_asm dest!: word_unat.Rep_inverse')
|
|
apply simp
|
|
apply (wp mapM_x_wp' sch_act_wf_lift valid_queues_lift static_imp_wp
|
|
tcb_in_cur_domain'_lift)
|
|
apply (simp add: n_frameRegisters_def n_msgRegisters_def
|
|
guard_is_UNIV_def)
|
|
apply simp
|
|
apply (rule mapM_x_wp')
|
|
apply (rule hoare_pre)
|
|
apply (wp asUser_obj_at'[where t'=target] static_imp_wp
|
|
asUser_valid_ipc_buffer_ptr')
|
|
apply clarsimp
|
|
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem
|
|
msg_registers_convs n_msgRegisters_def
|
|
n_frameRegisters_def n_gpRegisters_def
|
|
msgMaxLength_def msgLengthBits_def
|
|
word_less_nat_alt unat_of_nat)
|
|
apply (wp (once) hoare_drop_imps)
|
|
apply (wp asUser_obj_at'[where t'=target] static_imp_wp
|
|
asUser_valid_ipc_buffer_ptr')
|
|
apply (vcg exspec=setRegister_modifies)
|
|
apply simp
|
|
apply (strengthen valid_ipc_buffer_ptr_the_strengthen)
|
|
apply simp
|
|
apply (wp lookupIPCBuffer_Some_0 | wp (once) hoare_drop_imps)+
|
|
apply (simp add: Collect_const_mem ARM_H.badgeRegister_def
|
|
ARM.badgeRegister_def
|
|
"StrictC'_register_defs")
|
|
apply (vcg exspec=lookupIPCBuffer_modifies)
|
|
apply (simp add: false_def)
|
|
apply (ctac(no_vcg) add: setThreadState_ccorres)
|
|
apply (rule ccorres_from_vcg_throws[where P=\<top> and P'=UNIV])
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (simp add: return_def)
|
|
apply wp+
|
|
apply (simp cong: rev_conj_cong)
|
|
apply wp
|
|
apply (wp asUser_inv mapM_wp' getRegister_inv
|
|
asUser_get_registers[simplified] static_imp_wp)+
|
|
apply (rule hoare_strengthen_post, rule asUser_get_registers)
|
|
apply (clarsimp simp: obj_at'_def genericTake_def
|
|
frame_gp_registers_convs)
|
|
apply arith
|
|
apply (wp static_imp_wp)
|
|
apply simp
|
|
apply (rule ccorres_inst[where P=\<top> and P'=UNIV], simp)
|
|
apply (simp add: performTransfer_def)
|
|
apply wp
|
|
apply (simp add: Collect_const_mem "StrictC'_thread_state_defs"
|
|
mask_def)
|
|
apply vcg
|
|
apply (rule_tac Q="\<lambda>rv. invs' and st_tcb_at' ((=) Restart) thread
|
|
and tcb_at' target" in hoare_post_imp)
|
|
apply (clarsimp simp: pred_tcb_at')
|
|
apply (auto elim!: pred_tcb'_weakenE)[1]
|
|
apply (wp suspend_st_tcb_at')
|
|
apply (vcg exspec=suspend_modifies)
|
|
apply vcg
|
|
apply (rule conseqPre, vcg, clarsimp)
|
|
apply (clarsimp simp: rf_sr_ksCurThread ct_in_state'_def true_def
|
|
split: if_split)
|
|
done
|
|
|
|
lemma capTCBPtr_eq:
|
|
"\<lbrakk> ccap_relation cap cap'; isThreadCap cap \<rbrakk>
|
|
\<Longrightarrow> cap_thread_cap_CL.capTCBPtr_CL (cap_thread_cap_lift cap')
|
|
= ptr_val (tcb_ptr_to_ctcb_ptr (capTCBPtr cap))"
|
|
apply (simp add: cap_get_tag_isCap[symmetric])
|
|
apply (drule(1) cap_get_tag_to_H)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma decodeReadRegisters_ccorres:
|
|
"ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and sch_act_simple and (\<lambda>s. ksCurThread s = thread) and ct_active'
|
|
and sysargs_rel args buffer
|
|
and tcb_at' (capTCBPtr cp) and ex_nonz_cap_to' (capTCBPtr cp)
|
|
and K (isThreadCap cp))
|
|
(UNIV
|
|
\<inter> {s. ccap_relation cp (cap_' s)}
|
|
\<inter> {s. unat (length___unsigned_long_' s) = length args}
|
|
\<inter> {s. call_' s = from_bool isCall}
|
|
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
|
|
(decodeReadRegisters args cp
|
|
>>= invocationCatch thread isBlocking isCall InvokeTCB)
|
|
(Call decodeReadRegisters_'proc)"
|
|
apply (cinit' lift: cap_' length___unsigned_long_' call_' buffer_')
|
|
apply (simp add: decodeReadRegisters_def decodeTransfer_def
|
|
del: Collect_const cong: list.case_cong)
|
|
apply wpc
|
|
apply (drule word_unat.Rep_inverse')
|
|
apply (simp add: throwError_bind invocationCatch_def
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply wpc
|
|
apply (drule word_unat.Rep_inverse')
|
|
apply (simp add: throwError_bind invocationCatch_def
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (simp add: word_less_nat_alt Collect_False del: Collect_const)
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo[where args=args and n=0 and buffer=buffer])
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo[where args=args and n=1 and buffer=buffer])
|
|
apply (rule ccorres_move_const_guards)+
|
|
apply (simp add: rangeCheck_def unlessE_whenE whenE_def if_to_top_of_bindE
|
|
ccorres_seq_cond_raise if_to_top_of_bind
|
|
del: Collect_const)
|
|
apply (rule ccorres_cond2[where R=\<top>])
|
|
apply (simp add: frame_gp_registers_convs n_frameRegisters_def
|
|
n_gpRegisters_def Collect_const_mem)
|
|
apply unat_arith
|
|
apply (simp add: throwError_bind invocationCatch_def
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def intr_and_se_rel_def
|
|
syscall_error_rel_def syscall_error_to_H_cases
|
|
exception_defs Collect_const_mem)
|
|
apply (simp add: frame_gp_registers_convs n_frameRegisters_def
|
|
n_gpRegisters_def)
|
|
apply (simp add: ccorres_invocationCatch_Inr returnOk_bind
|
|
performInvocation_def
|
|
del: Collect_const)
|
|
apply csymbr
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (simp add: liftE_bindE bind_assoc)
|
|
apply (rule ccorres_pre_getCurThread)
|
|
apply (rule ccorres_cond_seq)
|
|
apply (rule_tac R="\<lambda>s. rv = ksCurThread s \<and> isThreadCap cp" and P="\<lambda>s. capTCBPtr cp = rv" in ccorres_cond_both)
|
|
apply clarsimp
|
|
apply (frule rf_sr_ksCurThread)
|
|
apply clarsimp
|
|
apply (frule (1) cap_get_tag_isCap[symmetric, THEN iffD1])
|
|
apply (drule (1) cap_get_tag_to_H)
|
|
apply clarsimp
|
|
apply (rule iffI)
|
|
apply (drule_tac t="ksCurThread s" in sym)
|
|
apply simp
|
|
apply simp
|
|
apply (rule_tac P="capTCBPtr cp = rv" in ccorres_gen_asm)
|
|
apply simp
|
|
apply (simp add: throwError_bind invocationCatch_def
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (rule_tac P="capTCBPtr cp \<noteq> rv" in ccorres_gen_asm)
|
|
apply (simp add: returnOk_bind)
|
|
apply (simp add: ccorres_invocationCatch_Inr del: Collect_const)
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply csymbr
|
|
apply (rule ccorres_Guard_Seq)+
|
|
apply (rule ccorres_nondet_refinement)
|
|
apply (rule is_nondet_refinement_bindE)
|
|
apply (rule is_nondet_refinement_refl)
|
|
apply (simp split: if_split)
|
|
apply (rule conjI[rotated], rule impI, rule is_nondet_refinement_refl)
|
|
apply (rule impI)
|
|
apply (rule is_nondet_refinement_alternative1)
|
|
apply (simp add: performInvocation_def)
|
|
apply (rule ccorres_add_returnOk)
|
|
apply (ctac(no_vcg) add: invokeTCB_ReadRegisters_ccorres)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (wp ct_in_state'_set sts_invs_minor')
|
|
apply (simp add: Collect_const_mem intr_and_se_rel_def
|
|
cintr_def exception_defs)
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply wp
|
|
apply (vcg exspec=getSyscallArg_modifies)
|
|
apply wp
|
|
apply (vcg exspec=getSyscallArg_modifies)
|
|
apply (clarsimp simp: Collect_const_mem rf_sr_ksCurThread
|
|
"StrictC'_thread_state_defs" word_sless_def word_sle_def
|
|
mask_eq_iff_w2p word_size isCap_simps
|
|
ReadRegistersFlags_defs tcb_at_invs'
|
|
cap_get_tag_isCap capTCBPtr_eq)
|
|
apply (frule global'_no_ex_cap[OF invs_valid_global'], clarsimp)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (rule conjI, clarsimp simp: sysargs_rel_n_def n_msgRegisters_def)
|
|
apply (rule conjI, clarsimp simp: sysargs_rel_n_def n_msgRegisters_def)
|
|
apply (auto simp: ct_in_state'_def n_frameRegisters_def n_gpRegisters_def
|
|
valid_tcb_state'_def
|
|
elim!: pred_tcb'_weakenE
|
|
dest!: st_tcb_at_idle_thread')[1]
|
|
apply (clarsimp simp: from_bool_def word_and_1 split: if_split)
|
|
done
|
|
|
|
lemma decodeWriteRegisters_ccorres:
|
|
"ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and sch_act_simple
|
|
and (\<lambda>s. ksCurThread s = thread) and ct_active' and K (isThreadCap cp)
|
|
and valid_cap' cp and (\<lambda>s. \<forall>x \<in> zobj_refs' cp. ex_nonz_cap_to' x s)
|
|
and sysargs_rel args buffer)
|
|
(UNIV
|
|
\<inter> {s. ccap_relation cp (cap_' s)}
|
|
\<inter> {s. unat (length___unsigned_long_' s) = length args}
|
|
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
|
|
(decodeWriteRegisters args cp
|
|
>>= invocationCatch thread isBlocking isCall InvokeTCB)
|
|
(Call decodeWriteRegisters_'proc)"
|
|
apply (cinit' lift: cap_' length___unsigned_long_' buffer_' simp: decodeWriteRegisters_def)
|
|
apply (rename_tac length' cap')
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply wpc
|
|
apply (simp add: throwError_bind invocationCatch_def
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (simp add: word_less_nat_alt)
|
|
apply (simp add: throwError_bind invocationCatch_def
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (simp add: word_less_nat_alt del: Collect_const)
|
|
apply (rule_tac P="\<lambda>a. ccorres rvr xf P P' hs a c" for rvr xf P P' hs c in ssubst,
|
|
rule bind_cong [OF _ refl], rule list_case_helper,
|
|
clarsimp simp: tl_drop_1)+
|
|
apply (rule ccorres_add_return)
|
|
apply (ctac add: getSyscallArg_ccorres_foo[where args=args and n=0 and buffer=buffer])
|
|
apply (rule ccorres_add_return)
|
|
apply (ctac add: getSyscallArg_ccorres_foo[where args=args and n=1 and buffer=buffer])
|
|
apply (rule_tac P="unat (of_nat (length args) :: word32) = length args"
|
|
in ccorres_gen_asm)
|
|
apply (simp add: unat_sub word_le_nat_alt genericLength_def
|
|
word_less_nat_alt hd_drop_conv_nth2 tl_drop_1
|
|
del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (simp add: whenE_def throwError_bind invocationCatch_def
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (simp add: whenE_def decodeTransfer_def returnOk_bind del: Collect_const)
|
|
apply csymbr
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (simp add: liftE_bindE bind_assoc)
|
|
apply (rule ccorres_pre_getCurThread)
|
|
apply (rule ccorres_cond_seq)
|
|
apply (rule_tac R="\<lambda>s. rv = ksCurThread s \<and> isThreadCap cp" and P="\<lambda>s. capTCBPtr cp = rv" in ccorres_cond_both)
|
|
apply clarsimp
|
|
apply (frule rf_sr_ksCurThread)
|
|
apply clarsimp
|
|
apply (frule (1) cap_get_tag_isCap[symmetric, THEN iffD1])
|
|
apply (drule (1) cap_get_tag_to_H)
|
|
apply clarsimp
|
|
apply (rule iffI)
|
|
apply (drule_tac t="ksCurThread s" in sym)
|
|
apply simp
|
|
apply simp
|
|
apply (rule_tac P="capTCBPtr cp = rv" in ccorres_gen_asm)
|
|
apply simp
|
|
apply (simp add: throwError_bind invocationCatch_def
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (rule_tac P="capTCBPtr cp \<noteq> rv" in ccorres_gen_asm)
|
|
apply (simp add: returnOk_bind)
|
|
apply (simp add: ccorres_invocationCatch_Inr del: Collect_const)
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply (rule ccorres_Guard_Seq)+
|
|
apply (simp add: performInvocation_def)
|
|
apply (ctac(no_vcg) add: invokeTCB_WriteRegisters_ccorres
|
|
[where args=args and someNum="unat (args ! 1)"])
|
|
apply (simp add: dc_def[symmetric] o_def)
|
|
apply (rule ccorres_alternative2, rule ccorres_return_CE, simp+)
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp[1]
|
|
apply simp
|
|
apply (wp sts_invs_minor' setThreadState_sysargs_rel)
|
|
apply (simp add: Collect_const_mem cintr_def intr_and_se_rel_def
|
|
exception_defs)
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply wp
|
|
apply (vcg exspec=getSyscallArg_modifies)
|
|
apply wp
|
|
apply (vcg exspec=getSyscallArg_modifies)
|
|
apply (clarsimp simp: Collect_const_mem ct_in_state'_def pred_tcb_at')
|
|
apply (simp add: cap_get_tag_isCap[symmetric], drule(1) cap_get_tag_to_H)
|
|
apply (clarsimp simp: valid_cap'_def "StrictC'_thread_state_defs"
|
|
mask_eq_iff_w2p word_size rf_sr_ksCurThread
|
|
WriteRegisters_resume_def word_sle_def word_sless_def
|
|
numeral_eqs
|
|
simp del: unsigned_numeral)
|
|
apply (frule arg_cong[where f="\<lambda>x. unat (of_nat x :: word32)"],
|
|
simp(no_asm_use) only: word_unat.Rep_inverse o_def,
|
|
simp)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (rule conjI, clarsimp simp: sysargs_rel_n_def n_msgRegisters_def word_less_nat_alt)
|
|
apply (rule conjI, clarsimp simp: sysargs_rel_n_def n_msgRegisters_def word_less_nat_alt)
|
|
apply (auto simp: genericTake_def cur_tcb'_def linorder_not_less word_le_nat_alt
|
|
valid_tcb_state'_def
|
|
elim!: pred_tcb'_weakenE dest!: st_tcb_at_idle_thread')[1]
|
|
apply (intro allI impI)
|
|
apply (rule disjCI2)
|
|
apply (clarsimp simp: genericTake_def linorder_not_less)
|
|
apply (subst hd_conv_nth, clarsimp simp: unat_eq_0)
|
|
apply (clarsimp simp: from_bool_def word_and_1
|
|
split: if_split)
|
|
done
|
|
|
|
lemma excaps_map_Nil: "(excaps_map caps = []) = (caps = [])"
|
|
by (simp add: excaps_map_def)
|
|
|
|
lemma decodeCopyRegisters_ccorres:
|
|
"interpret_excaps extraCaps' = excaps_map extraCaps \<Longrightarrow>
|
|
ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and sch_act_simple
|
|
and (\<lambda>s. ksCurThread s = thread) and ct_active'
|
|
and (excaps_in_mem extraCaps o ctes_of)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
ex_cte_cap_wp_to' isCNodeCap (snd v) s)
|
|
and tcb_at' (capTCBPtr cp) and ex_nonz_cap_to' (capTCBPtr cp)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps. \<forall>y \<in> zobj_refs' (fst v).
|
|
ex_nonz_cap_to' y s)
|
|
and sysargs_rel args buffer
|
|
and K (isThreadCap cp))
|
|
(UNIV
|
|
\<inter> {s. ccap_relation cp (cap_' s)}
|
|
\<inter> {s. unat (length___unsigned_long_' s) = length args}
|
|
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
|
|
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
|
|
(decodeCopyRegisters args cp (map fst extraCaps)
|
|
>>= invocationCatch thread isBlocking isCall InvokeTCB)
|
|
(Call decodeCopyRegisters_'proc)"
|
|
apply (cinit' lift: cap_' length___unsigned_long_' current_extra_caps_' buffer_' simp: decodeCopyRegisters_def)
|
|
apply csymbr
|
|
apply wpc
|
|
apply (simp add: if_1_0_0 unat_eq_0)
|
|
apply (rule ccorres_cond_true_seq)
|
|
apply (simp add: invocationCatch_def throwError_bind
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (simp add: if_1_0_0 del: Collect_const)
|
|
apply (subst unat_eq_0[symmetric], simp add: Collect_False del: Collect_const)
|
|
apply csymbr
|
|
apply (simp add: if_1_0_0 interpret_excaps_test_null decodeTransfer_def
|
|
del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (simp add: excaps_map_def invocationCatch_def throwError_bind null_def
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (simp add: excaps_map_def null_def del: Collect_const)
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo[where args=args and n=0 and buffer=buffer])
|
|
apply (rule ccorres_symb_exec_r)
|
|
apply (rule getSlotCap_ccorres_fudge_n[where vals=extraCaps and n=0])
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply ctac
|
|
apply csymbr
|
|
apply (simp add: cap_get_tag_isCap if_1_0_0 del: Collect_const)
|
|
apply (rule ccorres_assert2)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule_tac P="Q' (capTCBPtr rva) rva" for Q'
|
|
in ccorres_inst)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (csymbr, csymbr)
|
|
apply (simp add: hd_map del: Collect_const,
|
|
simp add: hd_conv_nth del: Collect_const)
|
|
apply (simp only: cap_get_tag_isCap[symmetric],
|
|
drule(1) cap_get_tag_to_H)
|
|
apply (simp add: case_bool_If if_to_top_of_bindE
|
|
if_to_top_of_bind
|
|
del: Collect_const cong: if_cong)
|
|
apply (simp add: to_bool_def returnOk_bind Collect_True
|
|
ccorres_invocationCatch_Inr performInvocation_def
|
|
del: Collect_const)
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply csymbr
|
|
apply (rule ccorres_Guard_Seq)+
|
|
apply (ctac add: invokeTCB_CopyRegisters_ccorres)
|
|
apply simp
|
|
apply (rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (simp add: cintr_def intr_and_se_rel_def exception_defs)
|
|
apply (vcg exspec=invokeTCB_CopyRegisters_modifies)
|
|
apply (wp sts_invs_minor')
|
|
apply (simp add: Collect_const_mem)
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (simp add: hd_map isCap_simps hd_conv_nth)
|
|
apply (clarsimp simp: invocationCatch_def throwError_bind
|
|
split: capability.split,
|
|
auto simp: throwError_def return_def intr_and_se_rel_def
|
|
syscall_error_rel_def syscall_error_to_H_cases
|
|
exception_defs)[1]
|
|
apply (simp add: getSlotCap_def)
|
|
apply (wp getCTE_wp)
|
|
apply (simp add: Collect_const_mem if_1_0_0 cap_get_tag_isCap)
|
|
apply vcg
|
|
apply (simp add: Collect_const_mem)
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply clarsimp
|
|
apply wp
|
|
apply (simp add: Collect_const_mem)
|
|
apply (vcg exspec=getSyscallArg_modifies)
|
|
apply (clarsimp simp: Collect_const_mem excaps_map_Nil)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: excaps_in_mem_def neq_Nil_conv
|
|
slotcap_in_mem_def cte_wp_at_ctes_of
|
|
ct_in_state'_def pred_tcb_at')
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: sysargs_rel_n_def n_msgRegisters_def)
|
|
apply (cut_tac msk=ba and cap="cteCap cte" in capMasterCap_maskCapRights)
|
|
apply (clarsimp simp: isCap_simps simp del: capMasterCap_maskCapRights)
|
|
apply (frule ctes_of_valid', clarsimp+)
|
|
apply (auto simp: valid_cap'_def excaps_map_def valid_tcb_state'_def
|
|
elim!: pred_tcb'_weakenE
|
|
dest!: st_tcb_at_idle_thread' interpret_excaps_eq)[1]
|
|
apply (clarsimp simp: word_sle_def CopyRegistersFlags_defs word_sless_def
|
|
"StrictC'_thread_state_defs" rf_sr_ksCurThread
|
|
split: if_split)
|
|
apply (drule interpret_excaps_eq)
|
|
apply (clarsimp simp: mask_def excaps_map_def split_def ccap_rights_relation_def
|
|
rightsFromWord_wordFromRights excaps_map_Nil)
|
|
apply (simp only: cap_get_tag_isCap[symmetric],
|
|
drule(1) cap_get_tag_to_H)
|
|
apply (clarsimp simp: cap_get_tag_isCap to_bool_def)
|
|
apply (auto simp: unat_eq_of_nat word_and_1_shiftls
|
|
word_and_1_shiftl [where n=3,simplified] cap_get_tag_isCap[symmetric] split: if_split_asm)
|
|
done
|
|
|
|
lemma isDevice_PageCap_ccap_relation:
|
|
"ccap_relation (capability.ArchObjectCap (arch_capability.PageCap d ref rghts sz data)) cap
|
|
\<Longrightarrow> (generic_frame_cap_get_capFIsDevice_CL (cap_lift cap) \<noteq> 0) = d"
|
|
by (clarsimp elim!: ccap_relationE
|
|
simp: isPageCap_def generic_frame_cap_get_capFIsDevice_CL_def cap_to_H_def
|
|
Let_def to_bool_def
|
|
split: arch_capability.split_asm cap_CL.split_asm if_split_asm)
|
|
|
|
lemma checkValidIPCBuffer_ccorres:
|
|
"ccorres (syscall_error_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs') (UNIV \<inter> {s. vptr_' s = vptr} \<inter> {s. ccap_relation cp (cap_' s)}) []
|
|
(checkValidIPCBuffer vptr cp)
|
|
(Call checkValidIPCBuffer_'proc)"
|
|
apply (simp add:checkValidIPCBuffer_def ARM_H.checkValidIPCBuffer_def)
|
|
apply (cases "isArchPageCap cp \<and> \<not> isDeviceCap cp")
|
|
apply (simp only: isCap_simps isDeviceCap.simps, safe)[1]
|
|
apply (cinit lift: vptr_' cap_')
|
|
apply (simp add: ARM_H.checkValidIPCBuffer_def if_1_0_0 del: Collect_const)
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (clarsimp simp : if_1_0_0)
|
|
apply (rule ccorres_symb_exec_r)
|
|
apply simp
|
|
apply (rule_tac xf'=ret__int_' in ccorres_abstract, ceqv)
|
|
apply (rename_tac cond_is_frame)
|
|
apply (rule ccorres_cond_false_seq)
|
|
apply simp
|
|
apply csymbr
|
|
apply (rule ccorres_cond_false_seq)
|
|
apply clarsimp
|
|
apply (simp only:Cond_if_mem)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (clarsimp simp add: msgAlignBits_def mask_def whenE_def)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def exception_defs
|
|
syscall_error_rel_def syscall_error_to_H_cases)
|
|
apply (simp add: whenE_def msgAlignBits_def mask_def)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (clarsimp simp: cap_get_tag_isCap isCap_simps pageSize_def
|
|
isDevice_PageCap_ccap_relation Collect_const_mem if_1_0_0
|
|
word_sle_def)
|
|
apply vcg
|
|
apply (clarsimp simp: cap_get_tag_isCap isCap_simps pageSize_def
|
|
isDevice_PageCap_ccap_relation Collect_const_mem)
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: cap_get_tag_isCap isCap_simps pageSize_def
|
|
isDevice_PageCap_ccap_relation Collect_const_mem if_1_0_0
|
|
word_sle_def)
|
|
apply (clarsimp simp: cap_get_tag_isCap isCap_simps pageSize_def
|
|
isDevice_PageCap_ccap_relation Collect_const_mem)
|
|
apply (clarsimp simp: Collect_const_mem if_1_0_0
|
|
word_sle_def)
|
|
apply (cases "isArchPageCap cp")
|
|
apply (simp only: isCap_simps isDeviceCap.simps, safe)[1]
|
|
apply (cinit lift: vptr_' cap_')
|
|
apply (simp add: ARM_H.checkValidIPCBuffer_def if_1_0_0 del: Collect_const)
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (clarsimp simp : if_1_0_0)
|
|
apply (rule ccorres_symb_exec_r)
|
|
apply simp
|
|
apply (rule_tac xf'=ret__int_' in ccorres_abstract, ceqv)
|
|
apply (rename_tac cond_is_frame)
|
|
apply (rule ccorres_cond_false_seq)
|
|
apply simp
|
|
apply csymbr
|
|
apply (rule ccorres_cond_true_seq)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def exception_defs
|
|
syscall_error_rel_def syscall_error_to_H_cases)
|
|
apply (simp add: cap_get_tag_isCap isCap_simps pageSize_def)
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (case_tac cp)
|
|
apply (clarsimp simp: syscall_error_rel_def syscall_error_to_H_cases isCap_simps
|
|
exception_defs throwError_def return_def if_1_0_0
|
|
split: capability.split arch_capability.split if_split_asm)+
|
|
apply (simp add: cap_get_tag_isCap isCap_simps pageSize_def Cond_if_mem)
|
|
apply (frule ccap_relation_page_is_device)
|
|
apply (auto simp add: isCap_simps isDeviceCap.simps pageSize_def
|
|
split: if_splits)[1]
|
|
apply (cinit lift: vptr_' cap_')
|
|
apply csymbr
|
|
apply (simp add: ARM_H.checkValidIPCBuffer_def
|
|
cap_get_tag_isCap)
|
|
apply csymbr
|
|
apply (rule ccorres_cond_true_seq)+
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (simp add: cap_get_tag_isCap)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (case_tac cp)
|
|
apply (auto simp: syscall_error_rel_def syscall_error_to_H_cases isCap_simps
|
|
exception_defs throwError_def return_def if_1_0_0
|
|
split: capability.split arch_capability.split if_split_asm)
|
|
done
|
|
|
|
lemma slotCapLongRunningDelete_ccorres:
|
|
"ccorres ((=) \<circ> from_bool) ret__unsigned_long_' invs'
|
|
(UNIV \<inter> {s. slot_' s = cte_Ptr slot}) []
|
|
(slotCapLongRunningDelete slot) (Call slotCapLongRunningDelete_'proc)"
|
|
supply subst_all [simp del]
|
|
apply (cinit lift: slot_')
|
|
apply (simp add: case_Null_If del: Collect_const)
|
|
apply (rule ccorres_pre_getCTE)
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply (rule_tac P="cte_wp_at' ((=) rv) slot"
|
|
in ccorres_cross_over_guard)
|
|
apply (rule ccorres_symb_exec_r)
|
|
apply (rule ccorres_if_lhs)
|
|
apply (rule ccorres_cond_true_seq)
|
|
apply (rule ccorres_split_throws, rule ccorres_return_C, simp+)
|
|
apply vcg
|
|
apply (rule ccorres_cond_false_seq)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (rule_tac xf'=ret__unsigned_long_' in ccorres_split_nothrow_novcg)
|
|
apply (ctac add: isFinalCapability_ccorres[where slot=slot])
|
|
apply (rule Seq_weak_ceqv)
|
|
apply (rule Cond_ceqv [OF _ ceqv_refl ceqv_refl])
|
|
apply simp
|
|
apply (rule impI, rule sym, rule mem_simps)
|
|
apply (clarsimp simp del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule ccorres_split_throws, rule ccorres_return_C, simp+)
|
|
apply vcg
|
|
apply (simp del: Collect_const)
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply (rule_tac P="cte_wp_at' ((=) rv) slot"
|
|
in ccorres_from_vcg_throws[where P'=UNIV])
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of return_def)
|
|
apply (erule(1) cmap_relationE1 [OF cmap_relation_cte])
|
|
apply (clarsimp simp: typ_heap_simps cap_get_tag_isCap
|
|
from_bool_0
|
|
dest!: ccte_relation_ccap_relation)
|
|
apply (simp add: from_bool_def false_def true_def
|
|
split: bool.split)
|
|
apply (auto simp add: longRunningDelete_def isCap_simps
|
|
split: capability.split)[1]
|
|
apply simp
|
|
apply (wp hoare_drop_imps isFinalCapability_inv)
|
|
apply (clarsimp simp: Collect_const_mem guard_is_UNIV_def)
|
|
apply (rename_tac rv')
|
|
apply (case_tac rv'; clarsimp simp: false_def true_def)
|
|
apply vcg
|
|
apply (rule conseqPre, vcg, clarsimp)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of)
|
|
apply (erule(1) cmap_relationE1 [OF cmap_relation_cte])
|
|
apply (clarsimp simp: typ_heap_simps cap_get_tag_isCap
|
|
from_bool_def false_def map_comp_Some_iff
|
|
dest!: ccte_relation_ccap_relation)
|
|
done
|
|
|
|
definition
|
|
isValidVTableRoot_C :: "cap_C \<Rightarrow> bool"
|
|
where
|
|
"isValidVTableRoot_C cap \<equiv> cap_get_tag cap = scast cap_page_directory_cap
|
|
\<and> to_bool (capPDIsMapped_CL (cap_page_directory_cap_lift cap))"
|
|
|
|
lemma isValidVTableRoot_spec:
|
|
"\<forall>s. \<Gamma> \<turnstile> {s} Call isValidVTableRoot_'proc
|
|
{s'. ret__unsigned_long_' s' = from_bool (isValidVTableRoot_C (cap_' s))}"
|
|
apply vcg
|
|
apply (clarsimp simp: isValidVTableRoot_C_def if_1_0_0 from_bool_0)
|
|
apply (simp add: from_bool_def to_bool_def false_def split: if_split)
|
|
done
|
|
|
|
lemma isValidVTableRoot_conv:
|
|
"\<lbrakk> ccap_relation cap cap' \<rbrakk>
|
|
\<Longrightarrow> isValidVTableRoot_C cap' = isValidVTableRoot cap"
|
|
apply (clarsimp simp: isValidVTableRoot_C_def
|
|
if_1_0_0 from_bool_0 isValidVTableRoot_def
|
|
ARM_H.isValidVTableRoot_def)
|
|
apply (case_tac "isArchCap_tag (cap_get_tag cap')")
|
|
apply (clarsimp simp: cap_get_tag_isCap cap_get_tag_isCap_ArchObject)
|
|
apply (case_tac "cap_get_tag cap' = scast cap_page_directory_cap")
|
|
apply (clarsimp split: arch_capability.split simp: isCap_simps)
|
|
apply (clarsimp simp: ccap_relation_def map_option_Some_eq2
|
|
cap_page_directory_cap_lift cap_to_H_def
|
|
from_bool_def)
|
|
apply (clarsimp simp: to_bool_def split: if_split)
|
|
apply (clarsimp simp: cap_get_tag_isCap cap_get_tag_isCap_ArchObject)
|
|
apply (simp split: arch_capability.split_asm add: isCap_simps)
|
|
apply (case_tac "cap_get_tag cap' = scast cap_page_directory_cap")
|
|
apply (clarsimp simp: cap_page_directory_cap_def isArchCap_tag_def2)
|
|
apply (clarsimp simp: cap_get_tag_isCap split: capability.split_asm)
|
|
done
|
|
|
|
lemma updateCapData_spec:
|
|
"\<forall>cap preserve newData. \<Gamma>\<turnstile> \<lbrace>ccap_relation cap \<acute>cap \<and> preserve = to_bool \<acute>preserve \<and> newData = \<acute>newData\<rbrace>
|
|
Call updateCapData_'proc
|
|
\<lbrace>ccap_relation (RetypeDecls_H.updateCapData preserve newData cap) \<acute>ret__struct_cap_C\<rbrace>"
|
|
by (simp add: updateCapData_spec)
|
|
|
|
lemma length_excaps_map:
|
|
"length (excaps_map xcs) = length xcs"
|
|
by (simp add: excaps_map_def)
|
|
|
|
lemma getSyscallArg_ccorres_foo':
|
|
"ccorres (\<lambda>a rv. rv = ucast (args ! n)) (\<lambda>x. ucast (ret__unsigned_long_' x))
|
|
(sysargs_rel args buffer and sysargs_rel_n args buffer n)
|
|
(UNIV \<inter> \<lbrace>unat \<acute>i = n\<rbrace> \<inter> \<lbrace>\<acute>ipc_buffer = option_to_ptr buffer\<rbrace>) []
|
|
(return ()) (Call getSyscallArg_'proc)"
|
|
apply (insert getSyscallArg_ccorres_foo
|
|
[where args=args and n=n and buffer=buffer])
|
|
apply (clarsimp simp: ccorres_underlying_def)
|
|
apply (erule (1) my_BallE)
|
|
apply clarsimp
|
|
apply (erule allE, erule allE, erule (1) impE)
|
|
apply (clarsimp simp: return_def unif_rrel_def split: xstate.splits)
|
|
done
|
|
|
|
lemma tcb_at_capTCBPtr_CL:
|
|
"ccap_relation cp cap \<Longrightarrow> valid_cap' cp s
|
|
\<Longrightarrow> isThreadCap cp
|
|
\<Longrightarrow> tcb_at' (cap_thread_cap_CL.capTCBPtr_CL
|
|
(cap_thread_cap_lift cap) && ~~mask tcbBlockSizeBits) s"
|
|
apply (clarsimp simp: cap_get_tag_isCap[symmetric]
|
|
valid_cap_simps'
|
|
dest!: cap_get_tag_to_H)
|
|
apply (frule ctcb_ptr_to_tcb_ptr_mask[OF tcb_aligned'], simp)
|
|
done
|
|
|
|
lemma checkPrio_ccorres:
|
|
"ccorres (syscall_error_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(tcb_at' auth)
|
|
(UNIV \<inter> {s. prio_' s = prio} \<inter> {s. auth_' s = tcb_ptr_to_ctcb_ptr auth}) []
|
|
(checkPrio prio auth)
|
|
(Call checkPrio_'proc)"
|
|
apply (cinit lift: prio_' auth_')
|
|
apply (clarsimp simp: liftE_bindE)
|
|
apply (rule ccorres_split_nothrow_novcg[where r'="\<lambda>rv rv'. rv' = ucast rv" and xf'=mcp_'])
|
|
apply (rule threadGet_vcg_corres)
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (clarsimp simp: rf_sr_ksCurThread obj_at'_def projectKOs
|
|
typ_heap_simps' ctcb_relation_def)
|
|
apply ceqv
|
|
apply (simp add: whenE_def del: Collect_const split: if_split)
|
|
apply (rule conjI; clarsimp)
|
|
apply (rule ccorres_from_vcg_split_throws)
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def syscall_error_rel_def syscall_error_to_H_cases
|
|
exception_defs Collect_const_mem rf_sr_ksCurThread return_def
|
|
seL4_MinPrio_def minPriority_def)
|
|
apply clarsimp
|
|
apply (rule ccorres_return_CE)
|
|
apply clarsimp+
|
|
apply wp
|
|
apply (simp add: guard_is_UNIV_def)+
|
|
done
|
|
|
|
lemma mcpriority_tcb_at'_prio_bounded':
|
|
assumes "mcpriority_tcb_at' (\<lambda>mcp. prio \<le> ucast mcp) t s"
|
|
"priorityBits \<le> len_of TYPE('a)"
|
|
shows "(prio::'a::len word) \<le> ucast (max_word :: priority)"
|
|
using assms
|
|
by (clarsimp simp: pred_tcb_at'_def obj_at'_def priorityBits_def ucast_le_ucast
|
|
simp del: unsigned_uminus1
|
|
elim!: order.trans)
|
|
|
|
lemmas mcpriority_tcb_at'_prio_bounded
|
|
= mcpriority_tcb_at'_prio_bounded'[simplified priorityBits_def]
|
|
|
|
lemma decodeTCBConfigure_ccorres:
|
|
notes tl_drop_1[simp] scast_mask_8 [simp]
|
|
shows
|
|
"interpret_excaps extraCaps' = excaps_map extraCaps \<Longrightarrow>
|
|
ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and sch_act_simple
|
|
and (\<lambda>s. ksCurThread s = thread) and ct_active'
|
|
and (excaps_in_mem extraCaps o ctes_of)
|
|
and valid_cap' cp and cte_at' slot and K (isThreadCap cp)
|
|
and ex_nonz_cap_to' (capTCBPtr cp) and tcb_at' (capTCBPtr cp)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
s \<turnstile>' fst v \<and> cte_at' (snd v) s)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
ex_cte_cap_wp_to' isCNodeCap (snd v) s)
|
|
and sysargs_rel args buffer)
|
|
(UNIV
|
|
\<inter> {s. ccap_relation cp (cap_' s)}
|
|
\<inter> {s. unat (length___unsigned_long_' s) = length args}
|
|
\<inter> {s. slot_' s = cte_Ptr slot}
|
|
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
|
|
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
|
|
(decodeTCBConfigure args cp slot extraCaps
|
|
>>= invocationCatch thread isBlocking isCall InvokeTCB)
|
|
(Call decodeTCBConfigure_'proc)"
|
|
apply (cinit' lift: cap_' length___unsigned_long_' slot_' current_extra_caps_' buffer_'
|
|
simp: decodeTCBConfigure_def)
|
|
apply csymbr
|
|
apply (clarsimp cong: StateSpace.state.fold_congs globals.fold_congs
|
|
simp del: Collect_const
|
|
simp add: interpret_excaps_test_null2 excaps_map_Nil)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule ccorres_cond_true_seq | simp)+
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: if_1_0_0 word_less_nat_alt)
|
|
apply (clarsimp split: list.split
|
|
simp: throwError_def invocationCatch_def fst_return
|
|
intr_and_se_rel_def
|
|
Collect_const_mem syscall_error_rel_def
|
|
exception_defs syscall_error_to_H_cases)
|
|
apply csymbr
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule ccorres_cond_true_seq | simp)+
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: if_1_0_0 word_less_nat_alt)
|
|
apply (clarsimp split: list.split
|
|
simp: throwError_def invocationCatch_def fst_return
|
|
intr_and_se_rel_def
|
|
Collect_const_mem syscall_error_rel_def
|
|
exception_defs syscall_error_to_H_cases)
|
|
apply csymbr
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule ccorres_cond_true_seq | simp)+
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: if_1_0_0 word_less_nat_alt)
|
|
apply (clarsimp split: list.split
|
|
simp: throwError_def invocationCatch_def fst_return
|
|
intr_and_se_rel_def excaps_map_def
|
|
Collect_const_mem syscall_error_rel_def
|
|
exception_defs syscall_error_to_H_cases)
|
|
apply csymbr
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule ccorres_cond_true_seq | simp)+
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: if_1_0_0 word_less_nat_alt)
|
|
apply (clarsimp split: list.split
|
|
simp: throwError_def invocationCatch_def fst_return
|
|
intr_and_se_rel_def excaps_map_def
|
|
Collect_const_mem syscall_error_rel_def
|
|
exception_defs syscall_error_to_H_cases)
|
|
apply (simp add: if_1_0_0 word_less_nat_alt linorder_not_less
|
|
del: Collect_const)
|
|
apply (rename_tac length' cap')
|
|
apply (subgoal_tac "length extraCaps \<ge> 3")
|
|
prefer 2
|
|
apply (clarsimp simp: idButNot_def interpret_excaps_test_null
|
|
excaps_map_def neq_Nil_conv)
|
|
apply (thin_tac "P \<longrightarrow> index exc n \<noteq> NULL" for P exc n)+
|
|
apply (rule_tac P="\<lambda>a. ccorres rvr xf P P' hs a c" for rvr xf P P' hs c in ssubst,
|
|
rule bind_cong [OF _ refl], rule list_case_helper, clarsimp)+
|
|
apply (simp add: hd_drop_conv_nth2 del: Collect_const)
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo[where args=args and n=0 and buffer=buffer])
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo'[where args=args and n=1 and buffer=buffer])
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo[where args=args and n=2 and buffer=buffer])
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo[where args=args and n=3 and buffer=buffer])
|
|
apply csymbr
|
|
apply (rule getSlotCap_ccorres_fudge_n[where vals=extraCaps and n=0])
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply ctac
|
|
apply (rule ccorres_assert2)
|
|
apply csymbr
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply (rule getSlotCap_ccorres_fudge_n[where vals=extraCaps and n=1])
|
|
apply ctac
|
|
apply (rule ccorres_assert2)
|
|
apply csymbr
|
|
apply (rule getSlotCap_ccorres_fudge_n[where vals=extraCaps and n=2])
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply ctac
|
|
apply (rule ccorres_assert2)
|
|
apply (simp add: decodeSetIPCBuffer_def split_def
|
|
bindE_assoc invocationCatch_use_injection_handler
|
|
injection_bindE[OF refl refl] injection_handler_returnOk
|
|
injection_handler_If
|
|
del: Collect_const cong: if_cong)
|
|
apply (rule_tac xf'="\<lambda>s. (bufferCap_' s, bufferSlot_' s)" and
|
|
r'="\<lambda>v (cp', sl'). case v of None \<Rightarrow> args ! 3 = 0 \<and> sl' = cte_Ptr 0
|
|
| Some (cp, sl) \<Rightarrow> ccap_relation cp cp'
|
|
\<and> args ! 3 \<noteq> 0
|
|
\<and> sl' = cte_Ptr sl"
|
|
in ccorres_splitE)
|
|
apply (rule ccorres_cond2[where R=\<top>])
|
|
apply (clarsimp simp add: Collect_const_mem numeral_eqs)
|
|
apply (rule_tac P="\<lambda>s. args ! 3 = 0" in ccorres_from_vcg[where P'=UNIV])
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (clarsimp simp: returnOk_def return_def)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (rule ccorres_split_nothrowE)
|
|
apply (simp add: numeral_eqs)
|
|
apply (ctac add: ccorres_injection_handler_csum1[OF deriveCap_ccorres])
|
|
apply ceqv
|
|
apply simp
|
|
apply (clarsimp simp: numeral_eqs)
|
|
apply csymbr
|
|
apply (rule ccorres_split_nothrowE)
|
|
apply (ctac add: ccorres_injection_handler_csum1[OF checkValidIPCBuffer_ccorres])
|
|
apply ceqv
|
|
apply (match premises in "ccap_relation _ (deriveCap_ret_C.cap_C ccap)" for ccap
|
|
\<Rightarrow> \<open>rule ccorres_from_vcg
|
|
[where P'="{s. bufferCap_' s = (deriveCap_ret_C.cap_C ccap)
|
|
\<and> bufferSlot_' s = cte_Ptr (snd (extraCaps ! 2))}"
|
|
and P="\<lambda>s. args ! 3 \<noteq> 0"]\<close>)
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (clarsimp simp: returnOk_def return_def numeral_eqs)
|
|
apply (rule_tac P'="{s. err' = errstate s}"
|
|
in ccorres_from_vcg_throws[where P=\<top>])
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def
|
|
syscall_error_rel_def
|
|
intr_and_se_rel_def)
|
|
apply wp
|
|
apply simp
|
|
apply (vcg exspec=checkValidIPCBuffer_modifies)
|
|
apply simp
|
|
apply (rule_tac P'="{s. err' = errstate s}"
|
|
in ccorres_from_vcg_split_throws[where P=\<top>])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def
|
|
intr_and_se_rel_def syscall_error_rel_def)
|
|
apply simp
|
|
apply (wp injection_wp_E [OF refl])
|
|
apply (simp add: all_ex_eq_helper Collect_const_mem numeral_eqs)
|
|
apply (vcg exspec=deriveCap_modifies)
|
|
apply (rule ceqv_tuple2, ceqv, ceqv)
|
|
apply (rename_tac rv'dc)
|
|
apply (rule_tac P="P (fst rv'dc) (snd rv'dc)"
|
|
and P'="P' (fst rv'dc) (snd rv'dc)"
|
|
for P P' in ccorres_inst)
|
|
apply (clarsimp simp: tcb_cnode_index_defs
|
|
[THEN ptr_add_assertion_positive
|
|
[OF ptr_add_assertion_positive_helper]]
|
|
simp del: Collect_const)
|
|
apply csymbr
|
|
apply (rule ccorres_move_array_assertion_tcb_ctes ccorres_Guard_Seq)+
|
|
apply (simp add: decodeSetSpace_def injection_bindE[OF refl] split_def
|
|
del: Collect_const)
|
|
apply (simp add: injection_liftE[OF refl] bindE_assoc
|
|
liftM_def getThreadCSpaceRoot
|
|
getThreadVSpaceRoot del: Collect_const)
|
|
apply (simp add: liftE_bindE del: Collect_const)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (ctac add: slotCapLongRunningDelete_ccorres)
|
|
apply (rule ccorres_move_array_assertion_tcb_ctes)
|
|
apply (simp del: Collect_const)
|
|
apply csymbr
|
|
apply (clarsimp simp add: if_1_0_0 from_bool_0
|
|
simp del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule ccorres_symb_exec_l3
|
|
[OF _ _ _ empty_fail_slotCapLongRunningDelete])
|
|
apply (simp add: unlessE_def injection_handler_throwError
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule ccorres_cond_true_seq)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply wp+
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply csymbr
|
|
apply (simp del: Collect_const)
|
|
apply (rule ccorres_move_array_assertion_tcb_ctes ccorres_Guard_Seq
|
|
ccorres_rhs_assoc)+
|
|
apply (ctac add: slotCapLongRunningDelete_ccorres)
|
|
apply (rule ccorres_move_array_assertion_tcb_ctes)
|
|
apply (simp del: Collect_const)
|
|
apply csymbr
|
|
apply (clarsimp simp add: if_1_0_0 from_bool_0
|
|
simp del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (simp add: unlessE_def injection_handler_throwError
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (simp add: unlessE_def injection_handler_returnOk
|
|
del: Collect_const)
|
|
apply (rule ccorres_add_return,
|
|
rule_tac r'="\<lambda>rv rv'. ccap_relation
|
|
(if args ! 1 = 0
|
|
then fst (hd extraCaps)
|
|
else updateCapData False (args ! 1) (fst (hd extraCaps))) rv'"
|
|
and xf'="cRootCap_'"
|
|
in ccorres_split_nothrow)
|
|
apply (rule_tac P'="{s. cRootCap = cRootCap_' s}"
|
|
in ccorres_from_vcg[where P=\<top>])
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (subgoal_tac "extraCaps \<noteq> []")
|
|
apply (clarsimp simp: returnOk_def return_def hd_conv_nth false_def)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply ceqv
|
|
apply (ctac add: ccorres_injection_handler_csum1
|
|
[OF deriveCap_ccorres])
|
|
apply (simp add: Collect_False del: Collect_const)
|
|
apply (csymbr, csymbr)
|
|
apply (simp add: cap_get_tag_isCap cnode_cap_case_if
|
|
del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (simp add: injection_handler_throwError
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (simp add: injection_handler_returnOk del: Collect_const)
|
|
apply (rule ccorres_add_return,
|
|
rule_tac r'="\<lambda>rv rv'. ccap_relation
|
|
(if args ! 2 = 0
|
|
then fst (extraCaps ! Suc 0)
|
|
else updateCapData False (args ! 2) (fst (extraCaps ! Suc 0))) rv'"
|
|
and xf'="vRootCap_'"
|
|
in ccorres_split_nothrow)
|
|
apply (rule_tac P'="{s. vRootCap = vRootCap_' s}"
|
|
in ccorres_from_vcg[where P=\<top>])
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (clarsimp simp: returnOk_def return_def
|
|
hd_drop_conv_nth2 false_def)
|
|
apply fastforce
|
|
apply ceqv
|
|
apply (ctac add: ccorres_injection_handler_csum1
|
|
[OF deriveCap_ccorres])
|
|
apply (simp add: Collect_False del: Collect_const)
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (simp add: from_bool_0 isValidVTableRoot_conv del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (simp add: injection_handler_throwError
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (simp add: injection_handler_returnOk ccorres_invocationCatch_Inr
|
|
performInvocation_def)
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply csymbr
|
|
apply (ctac(no_vcg) add: invokeTCB_ThreadControl_ccorres)
|
|
apply (simp, rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE, simp+)
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (simp add: o_def)
|
|
apply (wp sts_invs_minor' hoare_case_option_wp)
|
|
apply (simp add: Collect_const_mem cintr_def intr_and_se_rel_def
|
|
exception_defs
|
|
cong: option.case_cong)
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply simp
|
|
apply (rule ccorres_split_throws, rule ccorres_return_C_errorE, simp+)
|
|
apply vcg
|
|
apply simp
|
|
apply (wp injection_wp_E[OF refl] hoare_drop_imps)
|
|
apply (vcg exspec=deriveCap_modifies)
|
|
apply (simp add: pred_conj_def cong: if_cong)
|
|
apply wp
|
|
apply (simp add: Collect_const_mem)
|
|
apply (vcg)
|
|
apply simp
|
|
apply (rule ccorres_split_throws, rule ccorres_return_C_errorE, simp+)
|
|
apply vcg
|
|
apply (simp cong: if_cong)
|
|
apply (wp injection_wp_E[OF refl] hoare_drop_imps)
|
|
apply (simp add: Collect_const_mem intr_and_se_rel_def
|
|
syscall_error_rel_def exception_defs
|
|
cong: option.case_cong sum.case_cong)
|
|
apply (simp add: all_ex_eq_helper numeral_eqs)
|
|
apply (vcg exspec=deriveCap_modifies)
|
|
apply (simp cong: if_cong)
|
|
apply wp
|
|
apply (simp add: Collect_const_mem del: Collect_const)
|
|
apply vcg
|
|
apply (simp cong: if_cong)
|
|
apply (wp | wp (once) hoare_drop_imps)+
|
|
apply (simp add: Collect_const_mem all_ex_eq_helper
|
|
cong: option.case_cong)
|
|
apply (vcg exspec=slotCapLongRunningDelete_modifies)
|
|
apply (simp cong: if_cong)
|
|
apply (wp | wp (once) hoare_drop_imps)+
|
|
apply (simp add: Collect_const_mem)
|
|
apply (vcg exspec=slotCapLongRunningDelete_modifies)
|
|
apply (simp add: pred_conj_def cong: if_cong)
|
|
apply (wp injection_wp_E[OF refl] checkValidIPCBuffer_ArchObject_wp)
|
|
apply simp
|
|
apply (wp | wp (once) hoare_drop_imps)+
|
|
apply (simp add: Collect_const_mem all_ex_eq_helper)
|
|
apply (rule_tac P="{s. cRootCap_' s = cRootCap \<and> vRootCap_' s = vRootCap
|
|
\<and> bufferAddr_' s = args ! 3
|
|
\<and> ccap_relation cp cap' \<and> isThreadCap cp
|
|
\<and> is_aligned (capTCBPtr cp) tcbBlockSizeBits
|
|
\<and> ksCurThread_' (globals s) = tcb_ptr_to_ctcb_ptr thread}"
|
|
in conseqPre)
|
|
apply (simp add: cong: option.case_cong)
|
|
apply (vcg exspec=deriveCap_modifies exspec=checkValidIPCBuffer_modifies)
|
|
apply (clarsimp simp: excaps_map_def Collect_const_mem ccHoarePost_def
|
|
numeral_eqs
|
|
cong: option.case_cong)
|
|
apply (frule interpret_excaps_eq[rule_format, where n=0], clarsimp)
|
|
apply (frule interpret_excaps_eq[rule_format, where n=1], clarsimp)
|
|
apply (frule interpret_excaps_eq[rule_format, where n=2], clarsimp)
|
|
apply (clarsimp simp: mask_def[where n=4] ccap_rights_relation_def
|
|
rightsFromWord_wordFromRights capTCBPtr_eq
|
|
ptr_val_tcb_ptr_mask2[unfolded mask_def objBits_defs, simplified]
|
|
tcb_cnode_index_defs size_of_def
|
|
option_to_0_def rf_sr_ksCurThread
|
|
StrictC'_thread_state_defs mask_eq_iff_w2p word_size
|
|
from_bool_all_helper all_ex_eq_helper
|
|
ucast_ucast_mask objBits_defs)
|
|
apply (subgoal_tac "args \<noteq> [] \<and> extraCaps \<noteq> []")
|
|
apply (simp add: word_sle_def cap_get_tag_isCap numeral_eqs
|
|
hd_conv_nth hd_drop_conv_nth2
|
|
word_FF_is_mask split_def
|
|
thread_control_update_priority_def
|
|
thread_control_update_mcp_def
|
|
thread_control_update_space_def
|
|
thread_control_update_ipc_buffer_def)
|
|
apply (auto split: option.split elim!: inl_inrE)[1]
|
|
apply (fastforce+)[2]
|
|
apply clarsimp
|
|
apply (strengthen if_n_updateCapData_valid_strg)
|
|
apply (wp | wp (once) hoare_drop_imps)+
|
|
apply (clarsimp simp: Collect_const_mem all_ex_eq_helper
|
|
cong: option.case_cong)
|
|
apply vcg
|
|
apply simp
|
|
apply (wp | wp (once) hoare_drop_imps)+
|
|
apply (simp add: Collect_const_mem all_ex_eq_helper)
|
|
apply vcg
|
|
apply simp
|
|
apply (wp | wp (once) hoare_drop_imps)+
|
|
apply (wpsimp | vcg exspec=getSyscallArg_modifies)+
|
|
apply (clarsimp simp: Collect_const_mem all_ex_eq_helper)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: idButNot_def interpret_excaps_test_null
|
|
excaps_map_def neq_Nil_conv)
|
|
apply (clarsimp simp: sysargs_rel_to_n word_less_nat_alt)
|
|
apply (frule invs_mdb')
|
|
apply (frule(2) tcb_at_capTCBPtr_CL)
|
|
apply (rule conjI, fastforce)
|
|
apply (drule interpret_excaps_eq)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of valid_tcb_state'_def numeral_eqs le_ucast_ucast_le
|
|
tcb_at_invs' invs_valid_objs' invs_queues invs_sch_act_wf'
|
|
ct_in_state'_def pred_tcb_at'_def obj_at'_def tcb_st_refs_of'_def)
|
|
apply (erule disjE; simp add: objBits_defs mask_def)
|
|
apply (clarsimp simp: idButNot_def interpret_excaps_test_null
|
|
excaps_map_def neq_Nil_conv word_sle_def word_sless_def)
|
|
apply (frule interpret_excaps_eq[rule_format, where n=0], simp)
|
|
apply (frule interpret_excaps_eq[rule_format, where n=1], simp)
|
|
apply (frule interpret_excaps_eq[rule_format, where n=2], simp)
|
|
apply (clarsimp simp: mask_def[where n=4] ccap_rights_relation_def
|
|
rightsFromWord_wordFromRights
|
|
capTCBPtr_eq
|
|
tcb_cnode_index_defs size_of_def
|
|
option_to_0_def rf_sr_ksCurThread
|
|
StrictC'_thread_state_defs mask_eq_iff_w2p word_size
|
|
from_bool_all_helper)
|
|
apply (frule(1) tcb_at_h_t_valid [OF tcb_at_invs'])
|
|
apply (clarsimp simp: typ_heap_simps numeral_eqs isCap_simps valid_cap'_def capAligned_def
|
|
objBits_simps)
|
|
done
|
|
|
|
|
|
lemma not_isThreadCap_case:
|
|
"\<lbrakk>\<not>isThreadCap cap\<rbrakk> \<Longrightarrow>
|
|
(case cap of ThreadCap x \<Rightarrow> f x | _ \<Rightarrow> g) = g"
|
|
by (clarsimp simp: isThreadCap_def split: capability.splits)
|
|
|
|
lemma decodeSetMCPriority_ccorres:
|
|
"\<lbrakk>interpret_excaps extraCaps' = excaps_map extraCaps\<rbrakk> \<Longrightarrow>
|
|
ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and (\<lambda>s. ksCurThread s = thread)
|
|
and ct_active' and sch_act_simple
|
|
and (excaps_in_mem extraCaps \<circ> ctes_of)
|
|
and (\<lambda>s. \<forall>rf \<in> zobj_refs' cp. ex_nonz_cap_to' rf s)
|
|
and valid_cap' cp and K (isThreadCap cp)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
ex_cte_cap_wp_to' isCNodeCap (snd v) s)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
s \<turnstile>' fst v \<and> cte_at' (snd v) s)
|
|
and sysargs_rel args buffer)
|
|
(UNIV
|
|
\<inter> {s. ccap_relation cp (cap_' s)}
|
|
\<inter> {s. unat (length___unsigned_long_' s) = length args}
|
|
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
|
|
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
|
|
(decodeSetMCPriority args cp extraCaps
|
|
>>= invocationCatch thread isBlocking isCall InvokeTCB)
|
|
(Call decodeSetMCPriority_'proc)"
|
|
supply Collect_const[simp del]
|
|
supply dc_simp[simp del]
|
|
apply (cinit' lift: cap_' length___unsigned_long_' current_extra_caps_' buffer_' simp: decodeSetMCPriority_def)
|
|
apply (simp cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule ccorres_rhs_assoc2)
|
|
apply (rule_tac xf'=ret__int_' and R'=UNIV and R=\<top> and
|
|
val="from_bool (length args = 0 \<or> length extraCaps = 0)" in
|
|
ccorres_symb_exec_r_known_rv)
|
|
apply vcg
|
|
apply (force simp: interpret_excaps_test_null excaps_map_def from_bool_def unat_eq_0
|
|
split: bool.splits)
|
|
apply ceqv
|
|
apply clarsimp
|
|
apply wpc
|
|
(* Case args = [] *)
|
|
apply (rule ccorres_cond_true_seq)
|
|
apply (clarsimp simp: throwError_bind invocationCatch_def)
|
|
apply (rule ccorres_rhs_assoc)
|
|
apply (ccorres_rewrite)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
(* Case args is Cons *)
|
|
apply wpc
|
|
(* Sub-case extraCaps = [] *)
|
|
apply (rule ccorres_cond_true_seq)
|
|
apply (clarsimp simp: throwError_bind invocationCatch_def)
|
|
apply (rule ccorres_rhs_assoc)
|
|
apply (ccorres_rewrite)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
(* Main case where args and extraCaps are both Cons *)
|
|
apply (rule ccorres_cond_false_seq)
|
|
apply (simp add: split_def)
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo'[where args=args and n=0 and buffer=buffer])
|
|
apply (rule getSlotCap_ccorres_fudge_n[where vals=extraCaps and n=0])
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply ctac
|
|
apply csymbr
|
|
apply (simp add: cap_get_tag_isCap cong: call_ignore_cong)
|
|
apply (rule ccorres_assert2)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule ccorres_rhs_assoc)
|
|
apply ccorres_rewrite
|
|
apply (clarsimp simp: not_isThreadCap_case throwError_bind invocationCatch_def
|
|
simp del: id_simps)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply csymbr
|
|
apply csymbr
|
|
(* Pre-conditions need to depend on the inner value of the thread cap *)
|
|
apply (rule ccorres_inst[where P="Q (capTCBPtr (fst (extraCaps ! 0)))" and
|
|
P'="Q' (capTCBPtr (fst (extraCaps ! 0)))" for Q Q'])
|
|
apply (clarsimp simp: capTCBPtr_eq isCap_simps invocationCatch_use_injection_handler
|
|
injection_bindE[OF refl refl] bindE_assoc injection_handler_returnOk)
|
|
apply (ctac add: ccorres_injection_handler_csum1[OF checkPrio_ccorres])
|
|
apply (rule_tac P="hd args \<le> ucast (max_word :: priority)"
|
|
in ccorres_cross_over_guard_no_st)
|
|
apply (simp add: ccorres_invocationCatch_Inr performInvocation_def)
|
|
apply ccorres_rewrite
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply (simp add: invocationCatch_def)
|
|
apply ccorres_rewrite
|
|
apply csymbr
|
|
apply csymbr
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (ctac (no_vcg) add: invokeTCB_ThreadControl_ccorres)
|
|
(* HACK: delete rules from the simpset to avoid the RVRs getting out of sync *)
|
|
apply (clarsimp simp del: intr_and_se_rel_simps comp_apply dc_simp)
|
|
apply (rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE; simp)
|
|
apply (rule ccorres_return_C_errorE; simp)
|
|
apply wp
|
|
apply (wpsimp wp: sts_invs_minor')
|
|
apply simp
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply simp
|
|
apply (rename_tac err_c)
|
|
apply (rule_tac P'="{s. err_c = errstate s}" in ccorres_from_vcg_split_throws)
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def intr_and_se_rel_def syscall_error_rel_def)
|
|
apply simp
|
|
apply (rule injection_handler_wp)
|
|
apply (rule checkPrio_wp[simplified validE_R_def])
|
|
apply vcg
|
|
apply (wp | simp | wpc | wp (once) hoare_drop_imps)+
|
|
apply vcg
|
|
apply wp
|
|
apply (vcg exspec=getSyscallArg_modifies)
|
|
apply (clarsimp simp: EXCEPTION_SYSCALL_ERROR_def EXCEPTION_NONE_def)
|
|
apply vcg
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: ct_in_state'_def pred_tcb_at'
|
|
valid_cap'_def isCap_simps)
|
|
apply (rule conjI, clarsimp simp: sysargs_rel_n_def n_msgRegisters_def)
|
|
apply (clarsimp simp: maxPriority_def numPriorities_def FF_eq_minus_1)
|
|
apply (rule conjI, clarsimp)
|
|
apply (frule mcpriority_tcb_at'_prio_bounded, simp)
|
|
apply (auto simp: valid_tcb_state'_def le_ucast_ucast_le
|
|
elim!: obj_at'_weakenE pred_tcb'_weakenE
|
|
dest!: st_tcb_at_idle_thread')[1]
|
|
apply (clarsimp simp: interpret_excaps_eq excaps_map_def)
|
|
apply (simp add: StrictC'_thread_state_defs mask_eq_iff_w2p word_size option_to_0_def)
|
|
apply (frule rf_sr_ksCurThread)
|
|
apply (simp only: cap_get_tag_isCap[symmetric], drule(1) cap_get_tag_to_H)
|
|
apply (clarsimp simp: valid_cap'_def capAligned_def interpret_excaps_eq excaps_map_def)
|
|
apply (intro conjI impI allI)
|
|
apply (clarsimp simp: unat_eq_0 le_max_word_ucast_id cap_get_tag_isCap_unfolded_H_cap isCap_simps)+
|
|
done
|
|
|
|
lemma decodeSetPriority_ccorres:
|
|
"\<lbrakk>interpret_excaps extraCaps' = excaps_map extraCaps\<rbrakk> \<Longrightarrow>
|
|
ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and (\<lambda>s. ksCurThread s = thread)
|
|
and ct_active' and sch_act_simple
|
|
and (excaps_in_mem extraCaps \<circ> ctes_of)
|
|
and (\<lambda>s. \<forall>rf \<in> zobj_refs' cp. ex_nonz_cap_to' rf s)
|
|
and valid_cap' cp and K (isThreadCap cp)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
ex_cte_cap_wp_to' isCNodeCap (snd v) s)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
s \<turnstile>' fst v \<and> cte_at' (snd v) s)
|
|
and sysargs_rel args buffer)
|
|
(UNIV
|
|
\<inter> {s. ccap_relation cp (cap_' s)}
|
|
\<inter> {s. unat (length___unsigned_long_' s) = length args}
|
|
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
|
|
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
|
|
(decodeSetPriority args cp extraCaps
|
|
>>= invocationCatch thread isBlocking isCall InvokeTCB)
|
|
(Call decodeSetPriority_'proc)"
|
|
supply Collect_const[simp del] dc_simp[simp del]
|
|
apply (cinit' lift: cap_' length___unsigned_long_' current_extra_caps_' buffer_' simp: decodeSetPriority_def)
|
|
apply (simp cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule ccorres_rhs_assoc2)
|
|
apply (rule_tac xf'=ret__int_' and R'=UNIV and R=\<top> and
|
|
val="from_bool (length args = 0 \<or> length extraCaps = 0)" in
|
|
ccorres_symb_exec_r_known_rv)
|
|
apply vcg
|
|
apply (force simp: interpret_excaps_test_null excaps_map_def from_bool_def unat_eq_0
|
|
split: bool.splits)
|
|
apply ceqv
|
|
apply clarsimp
|
|
apply wpc
|
|
(* Case args = [] *)
|
|
apply (rule ccorres_cond_true_seq)
|
|
apply (clarsimp simp: throwError_bind invocationCatch_def)
|
|
apply (rule ccorres_rhs_assoc)
|
|
apply (ccorres_rewrite)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
(* Case args is Cons *)
|
|
apply wpc
|
|
(* Sub-case extraCaps = [] *)
|
|
apply (rule ccorres_cond_true_seq)
|
|
apply (clarsimp simp: throwError_bind invocationCatch_def)
|
|
apply (rule ccorres_rhs_assoc)
|
|
apply (ccorres_rewrite)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
(* Main case where args and extraCaps are both Cons *)
|
|
apply (rule ccorres_cond_false_seq)
|
|
apply (simp add: split_def)
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo'[where args=args and n=0 and buffer=buffer])
|
|
apply (rule getSlotCap_ccorres_fudge_n[where vals=extraCaps and n=0])
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply ctac
|
|
apply csymbr
|
|
apply (simp add: cap_get_tag_isCap cong: call_ignore_cong)
|
|
apply (rule ccorres_assert2)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule ccorres_rhs_assoc)
|
|
apply ccorres_rewrite
|
|
apply (clarsimp simp: not_isThreadCap_case throwError_bind invocationCatch_def
|
|
simp del: id_simps)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply csymbr
|
|
apply csymbr
|
|
(* Pre-conditions need to depend on the inner value of the thread cap *)
|
|
apply (rule ccorres_inst[where P="Q (capTCBPtr (fst (extraCaps ! 0)))" and
|
|
P'="Q' (capTCBPtr (fst (extraCaps ! 0)))" for Q Q'])
|
|
apply (clarsimp simp: capTCBPtr_eq isCap_simps invocationCatch_use_injection_handler
|
|
injection_bindE[OF refl refl] bindE_assoc injection_handler_returnOk)
|
|
apply (ctac add: ccorres_injection_handler_csum1[OF checkPrio_ccorres])
|
|
apply (rule_tac P="hd args \<le> ucast (max_word :: priority)"
|
|
in ccorres_cross_over_guard_no_st)
|
|
apply (simp add: ccorres_invocationCatch_Inr performInvocation_def)
|
|
apply ccorres_rewrite
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply (simp add: invocationCatch_def)
|
|
apply ccorres_rewrite
|
|
apply csymbr
|
|
apply csymbr
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (ctac (no_vcg) add: invokeTCB_ThreadControl_ccorres)
|
|
(* HACK: delete rules from the simpset to avoid the RVRs getting out of sync *)
|
|
apply (clarsimp simp del: intr_and_se_rel_simps comp_apply dc_simp)
|
|
apply (rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE; simp)
|
|
apply (rule ccorres_return_C_errorE; simp)
|
|
apply wp
|
|
apply (wpsimp wp: sts_invs_minor')
|
|
apply simp
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply simp
|
|
apply (rename_tac err_c)
|
|
apply (rule_tac P'="{s. err_c = errstate s}" in ccorres_from_vcg_split_throws)
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def intr_and_se_rel_def syscall_error_rel_def)
|
|
apply simp
|
|
apply (rule injection_handler_wp)
|
|
apply (rule checkPrio_wp[simplified validE_R_def])
|
|
apply vcg
|
|
apply (wp | simp | wpc | wp (once) hoare_drop_imps)+
|
|
apply vcg
|
|
apply wp
|
|
apply (vcg exspec=getSyscallArg_modifies)
|
|
apply (clarsimp simp: EXCEPTION_SYSCALL_ERROR_def EXCEPTION_NONE_def)
|
|
apply vcg
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: ct_in_state'_def pred_tcb_at'
|
|
valid_cap'_def isCap_simps)
|
|
apply (rule conjI, clarsimp simp: sysargs_rel_n_def n_msgRegisters_def)
|
|
apply (clarsimp simp: maxPriority_def numPriorities_def FF_eq_minus_1)
|
|
apply (rule conjI, clarsimp)
|
|
apply (frule mcpriority_tcb_at'_prio_bounded, simp)
|
|
apply (auto simp: valid_tcb_state'_def le_ucast_ucast_le
|
|
elim!: obj_at'_weakenE pred_tcb'_weakenE
|
|
dest!: st_tcb_at_idle_thread')[1]
|
|
apply (clarsimp simp: interpret_excaps_eq excaps_map_def)
|
|
apply (simp add: StrictC'_thread_state_defs mask_eq_iff_w2p word_size option_to_0_def)
|
|
apply (frule rf_sr_ksCurThread)
|
|
apply (simp only: cap_get_tag_isCap[symmetric], drule(1) cap_get_tag_to_H)
|
|
apply (clarsimp simp: valid_cap'_def capAligned_def interpret_excaps_eq excaps_map_def)
|
|
apply (intro conjI impI allI)
|
|
apply (clarsimp simp: unat_eq_0 le_max_word_ucast_id cap_get_tag_isCap_unfolded_H_cap isCap_simps)+
|
|
done
|
|
|
|
lemma ucast_le_8_32_equiv:
|
|
"x \<le> UCAST (8 \<rightarrow> 32) max_word \<Longrightarrow>
|
|
(UCAST (32 \<rightarrow> 8) x \<le> y) = (x \<le> UCAST (8 \<rightarrow> 32) y)"
|
|
apply (rule iffI)
|
|
apply (word_bitwise; simp)
|
|
apply (simp add: le_ucast_ucast_le)
|
|
done
|
|
|
|
lemma mcpriority_tcb_at'_le_ucast:
|
|
"pred_tcb_at' itcbMCP (\<lambda>mcp. x \<le> UCAST(8 \<rightarrow> 32) mcp) v s \<Longrightarrow>
|
|
pred_tcb_at' itcbMCP (\<lambda>mcp. UCAST(32 \<rightarrow> 8) x \<le> mcp) v s"
|
|
by (clarsimp simp: ucast_le_8_32_equiv mcpriority_tcb_at'_prio_bounded simp del: unsigned_uminus1)
|
|
|
|
lemma decodeSetSchedParams_ccorres:
|
|
"\<lbrakk>interpret_excaps extraCaps' = excaps_map extraCaps\<rbrakk> \<Longrightarrow>
|
|
ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and (\<lambda>s. ksCurThread s = thread)
|
|
and ct_active' and sch_act_simple
|
|
and (excaps_in_mem extraCaps \<circ> ctes_of)
|
|
and (\<lambda>s. \<forall>rf \<in> zobj_refs' cp. ex_nonz_cap_to' rf s)
|
|
and valid_cap' cp and K (isThreadCap cp)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
ex_cte_cap_wp_to' isCNodeCap (snd v) s)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
s \<turnstile>' fst v \<and> cte_at' (snd v) s)
|
|
and sysargs_rel args buffer)
|
|
(UNIV
|
|
\<inter> {s. ccap_relation cp (cap_' s)}
|
|
\<inter> {s. unat (length___unsigned_long_' s) = length args}
|
|
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
|
|
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
|
|
(decodeSetSchedParams args cp extraCaps
|
|
>>= invocationCatch thread isBlocking isCall InvokeTCB)
|
|
(Call decodeSetSchedParams_'proc)"
|
|
supply Collect_const[simp del] dc_simp[simp del]
|
|
apply (cinit' lift: cap_' length___unsigned_long_' current_extra_caps_' buffer_' simp: decodeSetSchedParams_def)
|
|
apply (simp cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule ccorres_rhs_assoc2)
|
|
apply (rule_tac xf'=ret__int_' and R'=UNIV and R=\<top> and
|
|
val="from_bool (length args < 2 \<or> length extraCaps = 0)" in
|
|
ccorres_symb_exec_r_known_rv)
|
|
apply vcg
|
|
apply (auto simp: interpret_excaps_test_null excaps_map_def from_bool_def unat_eq_0
|
|
split: bool.splits)[1]
|
|
apply (unat_arith+)[2]
|
|
apply ceqv
|
|
apply clarsimp
|
|
apply (wpc,
|
|
rule ccorres_cond_true_seq,
|
|
clarsimp simp: throwError_bind invocationCatch_def,
|
|
rule ccorres_rhs_assoc,
|
|
ccorres_rewrite,
|
|
fastforce intro: syscall_error_throwError_ccorres_n simp: syscall_error_to_H_cases)+
|
|
(* Main case where args and extraCaps are both well-formed *)
|
|
apply (rule ccorres_cond_false_seq)
|
|
apply (simp add: split_def)
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo'[where args=args and n=0 and buffer=buffer])
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo'[where args=args and n=1 and buffer=buffer])
|
|
apply (rule getSlotCap_ccorres_fudge_n[where vals=extraCaps and n=0])
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply ctac
|
|
apply csymbr
|
|
apply (simp add: cap_get_tag_isCap cong: call_ignore_cong)
|
|
apply (rule ccorres_assert2)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule ccorres_rhs_assoc)
|
|
apply ccorres_rewrite
|
|
apply (clarsimp simp: not_isThreadCap_case throwError_bind invocationCatch_def
|
|
simp del: id_simps)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply csymbr
|
|
apply csymbr
|
|
(* Pre-conditions need to depend on the inner value of the thread cap *)
|
|
apply (rule ccorres_inst[where P="Q (capTCBPtr (fst (extraCaps ! 0)))" and
|
|
P'="Q' (capTCBPtr (fst (extraCaps ! 0)))" for Q Q'])
|
|
apply (clarsimp simp: capTCBPtr_eq isCap_simps invocationCatch_use_injection_handler
|
|
injection_bindE[OF refl refl] bindE_assoc injection_handler_returnOk)
|
|
apply (ctac add: ccorres_injection_handler_csum1[OF checkPrio_ccorres])
|
|
apply (rule_tac P="args ! 0 \<le> ucast (max_word :: priority)"
|
|
in ccorres_cross_over_guard_no_st)
|
|
apply (simp add: ccorres_invocationCatch_Inr performInvocation_def)
|
|
apply ccorres_rewrite
|
|
apply (clarsimp simp: capTCBPtr_eq isCap_simps invocationCatch_use_injection_handler
|
|
injection_bindE[OF refl refl] bindE_assoc injection_handler_returnOk)
|
|
apply (ctac add: ccorres_injection_handler_csum1[OF checkPrio_ccorres])
|
|
apply (rule_tac P="args ! 1 \<le> ucast (max_word :: priority)"
|
|
in ccorres_cross_over_guard_no_st)
|
|
apply (simp add: ccorres_invocationCatch_Inr performInvocation_def)
|
|
apply ccorres_rewrite
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply (simp add: invocationCatch_def)
|
|
apply ccorres_rewrite
|
|
apply csymbr
|
|
apply csymbr
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (ctac (no_vcg) add: invokeTCB_ThreadControl_ccorres)
|
|
(* HACK: delete rules from the simpset to avoid the RVRs getting out of sync *)
|
|
apply (clarsimp simp del: intr_and_se_rel_simps comp_apply dc_simp)
|
|
apply (rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE; simp)
|
|
apply (rule ccorres_return_C_errorE; simp)
|
|
apply wp
|
|
apply (wpsimp wp: sts_invs_minor')
|
|
apply simp
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply simp
|
|
apply (rename_tac err_c)
|
|
apply (rule_tac P'="{s. err_c = errstate s}" in ccorres_from_vcg_split_throws)
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def intr_and_se_rel_def syscall_error_rel_def)
|
|
apply simp
|
|
apply (rule injection_handler_wp)
|
|
apply (rule checkPrio_wp[simplified validE_R_def])
|
|
apply vcg
|
|
apply clarsimp
|
|
apply ccorres_rewrite
|
|
apply (rule ccorres_return_C_errorE; simp)
|
|
apply simp
|
|
apply (rule injection_handler_wp)
|
|
apply (rule checkPrio_wp[simplified validE_R_def])
|
|
apply vcg
|
|
apply (wp | simp | wpc | wp (once) hoare_drop_imps)+
|
|
apply vcg
|
|
apply simp
|
|
apply (rule return_wp)
|
|
apply (vcg exspec=getSyscallArg_modifies)
|
|
apply simp
|
|
apply (rule return_wp)
|
|
apply simp
|
|
apply (vcg exspec=getSyscallArg_modifies)
|
|
apply simp
|
|
apply (vcg exspec=getSyscallArg_modifies)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: ct_in_state'_def pred_tcb_at'
|
|
valid_cap'_def isCap_simps)
|
|
apply (rule conjI; clarsimp simp: sysargs_rel_to_n n_msgRegisters_def)
|
|
apply (clarsimp simp: maxPriority_def numPriorities_def FF_eq_minus_1)
|
|
apply (rule conjI, clarsimp)
|
|
apply (insert mcpriority_tcb_at'_prio_bounded[where prio="args ! 0"])
|
|
apply (insert mcpriority_tcb_at'_prio_bounded[where prio="args ! 1"])
|
|
apply (auto simp: valid_tcb_state'_def mcpriority_tcb_at'_le_ucast
|
|
elim!: obj_at'_weakenE pred_tcb'_weakenE
|
|
dest!: st_tcb_at_idle_thread')[1]
|
|
apply (clarsimp simp: interpret_excaps_eq excaps_map_def)
|
|
apply (simp add: StrictC'_thread_state_defs mask_eq_iff_w2p word_size option_to_0_def)
|
|
apply (frule rf_sr_ksCurThread)
|
|
apply (simp only: cap_get_tag_isCap[symmetric], drule(1) cap_get_tag_to_H)
|
|
apply (clarsimp simp: valid_cap'_def capAligned_def interpret_excaps_eq excaps_map_def)
|
|
apply (intro conjI impI allI)
|
|
apply (clarsimp simp: unat_eq_0 le_max_word_ucast_id
|
|
thread_control_update_mcp_def thread_control_update_priority_def
|
|
cap_get_tag_isCap_unfolded_H_cap isCap_simps
|
|
interpret_excaps_eq excaps_map_def)+
|
|
done
|
|
|
|
lemma decodeSetIPCBuffer_ccorres:
|
|
"interpret_excaps extraCaps' = excaps_map extraCaps \<Longrightarrow>
|
|
ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and (\<lambda>s. ksCurThread s = thread) and ct_active' and sch_act_simple
|
|
and valid_cap' cp and cte_at' slot and K (isThreadCap cp)
|
|
and (excaps_in_mem extraCaps o ctes_of)
|
|
and (\<lambda>s. \<forall>rf \<in> zobj_refs' cp. ex_nonz_cap_to' rf s)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
s \<turnstile>' fst v \<and> cte_at' (snd v) s)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
ex_cte_cap_wp_to' isCNodeCap (snd v) s)
|
|
and sysargs_rel args buffer)
|
|
(UNIV
|
|
\<inter> {s. ccap_relation cp (cap_' s)}
|
|
\<inter> {s. unat (length___unsigned_long_' s) = length args}
|
|
\<inter> {s. slot_' s = cte_Ptr slot}
|
|
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
|
|
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
|
|
(decodeSetIPCBuffer args cp slot extraCaps
|
|
>>= invocationCatch thread isBlocking isCall InvokeTCB)
|
|
(Call decodeSetIPCBuffer_'proc)"
|
|
apply (cinit' lift: cap_' length___unsigned_long_' slot_' current_extra_caps_' buffer_'
|
|
simp: decodeSetIPCBuffer_def)
|
|
apply wpc
|
|
apply (simp add: unat_eq_0)
|
|
apply csymbr
|
|
apply simp
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (simp add: throwError_bind invocationCatch_def)
|
|
apply (clarsimp simp: throwError_def return_def
|
|
intr_and_se_rel_def exception_defs
|
|
syscall_error_rel_def syscall_error_to_H_cases)
|
|
apply csymbr
|
|
apply (rule ccorres_cond_false_seq)
|
|
apply csymbr
|
|
apply (simp del: Collect_const)
|
|
apply (simp add: interpret_excaps_test_null excaps_map_Nil if_1_0_0
|
|
del: Collect_const)
|
|
apply wpc
|
|
apply (simp add: throwError_bind invocationCatch_def
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (rule ccorres_cond_false_seq)
|
|
apply (simp add: split_def
|
|
del: Collect_const)
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo [where args=args and n=0 and buffer=buffer])
|
|
apply csymbr
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply (rule getSlotCap_ccorres_fudge_n[where vals=extraCaps and n=0])
|
|
apply ctac
|
|
apply (rule ccorres_assert2)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (simp add: returnOk_bind ccorres_invocationCatch_Inr performInvocation_def)
|
|
apply csymbr
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply csymbr
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (ctac add: invokeTCB_ThreadControl_ccorres)
|
|
apply simp
|
|
apply (rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (vcg exspec=invokeTCB_ThreadControl_modifies)
|
|
apply simp
|
|
apply (wp sts_invs_minor')
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply (simp add: bindE_assoc del: Collect_const)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (csymbr, csymbr)
|
|
apply (simp add: bindE_bind_linearise)
|
|
apply (rule ccorres_split_nothrow_case_sum)
|
|
apply (ctac add: deriveCap_ccorres)
|
|
apply ceqv
|
|
apply (simp add: Collect_False del: Collect_const)
|
|
apply csymbr
|
|
apply (rule ccorres_split_nothrow_case_sum)
|
|
apply (ctac add: checkValidIPCBuffer_ccorres)
|
|
apply ceqv
|
|
apply (simp add: Collect_False returnOk_bind
|
|
ccorres_invocationCatch_Inr
|
|
del: Collect_const)
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply (simp add: performInvocation_def)
|
|
apply (csymbr, csymbr, csymbr)
|
|
apply (ctac add: invokeTCB_ThreadControl_ccorres)
|
|
apply simp
|
|
apply (rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (vcg exspec=invokeTCB_ThreadControl_modifies)
|
|
apply simp
|
|
apply (wp sts_invs_minor')
|
|
apply (simp add: Collect_const_mem cintr_def intr_and_se_rel_def)
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply (simp add: invocationCatch_def)
|
|
apply (rule ccorres_split_throws, rule ccorres_return_C_errorE, simp+)
|
|
apply vcg
|
|
apply simp
|
|
apply (wp checkValidIPCBuffer_ArchObject_wp)
|
|
apply (simp add: intr_and_se_rel_def syscall_error_rel_def
|
|
exception_defs)
|
|
apply (vcg exspec=checkValidIPCBuffer_modifies)
|
|
apply (simp add: invocationCatch_def)
|
|
apply (rule ccorres_split_throws)
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply vcg
|
|
apply simp
|
|
apply (wp | wp (once) hoare_drop_imps)+
|
|
apply (simp add: Collect_const_mem)
|
|
apply (vcg exspec=deriveCap_modifies)
|
|
apply simp
|
|
apply (wp | wp (once) hoare_drop_imps)+
|
|
apply simp
|
|
apply vcg
|
|
apply wp
|
|
apply simp
|
|
apply (vcg exspec=getSyscallArg_modifies)
|
|
apply (clarsimp simp: Collect_const_mem if_1_0_0 ct_in_state'_def
|
|
pred_tcb_at' cintr_def intr_and_se_rel_def
|
|
exception_defs syscall_error_rel_def)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: excaps_in_mem_def slotcap_in_mem_def)
|
|
apply (rule conjI, clarsimp simp: sysargs_rel_n_def n_msgRegisters_def)
|
|
apply (frule invs_mdb')
|
|
apply (frule(2) tcb_at_capTCBPtr_CL)
|
|
apply (auto simp: isCap_simps valid_cap'_def valid_mdb'_def valid_tcb_state'_def
|
|
valid_mdb_ctes_def no_0_def excaps_map_def
|
|
elim: pred_tcb'_weakenE dest!: st_tcb_at_idle_thread'
|
|
dest!: interpret_excaps_eq)[1]
|
|
apply (clarsimp simp: option_to_0_def rf_sr_ksCurThread word_sless_def
|
|
word_sle_def ThreadState_Restart_def mask_def)
|
|
apply (rule conjI[rotated], clarsimp+)
|
|
apply (drule interpret_excaps_eq[rule_format, where n=0], simp add: excaps_map_Nil)
|
|
apply (simp add: mask_def "StrictC'_thread_state_defs" excaps_map_def)
|
|
apply (clarsimp simp: ccap_rights_relation_def rightsFromWord_wordFromRights
|
|
cap_get_tag_isCap)
|
|
apply (frule cap_get_tag_to_H, subst cap_get_tag_isCap, assumption, assumption)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma bindNTFN_alignment_junk:
|
|
"\<lbrakk> is_aligned tcb tcbBlockSizeBits; bits \<le> ctcb_size_bits \<rbrakk>
|
|
\<Longrightarrow> ptr_val (tcb_ptr_to_ctcb_ptr tcb) && ~~ mask bits = ptr_val (tcb_ptr_to_ctcb_ptr tcb)"
|
|
apply (clarsimp simp: tcb_ptr_to_ctcb_ptr_def projectKOs)
|
|
apply (rule is_aligned_neg_mask_eq)
|
|
apply (erule aligned_add_aligned)
|
|
apply (erule is_aligned_weaken[rotated])
|
|
by (auto simp add: is_aligned_def objBits_defs ctcb_offset_defs)
|
|
|
|
lemma bindNotification_ccorres:
|
|
"ccorres dc xfdc (invs' and tcb_at' tcb)
|
|
(UNIV \<inter> {s. tcb_' s = tcb_ptr_to_ctcb_ptr tcb}
|
|
\<inter> {s. ntfnPtr_' s = ntfn_Ptr ntfnptr}) []
|
|
(bindNotification tcb ntfnptr)
|
|
(Call bindNotification_'proc)"
|
|
apply (cinit lift: tcb_' ntfnPtr_' simp: bindNotification_def)
|
|
apply (rule ccorres_symb_exec_l [OF _ get_ntfn_inv' _ empty_fail_getNotification])
|
|
apply (rule_tac P="invs' and ko_at' rv ntfnptr and tcb_at' tcb" and P'=UNIV
|
|
in ccorres_split_nothrow_novcg)
|
|
apply (rule ccorres_from_vcg[where rrel=dc and xf=xfdc])
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (clarsimp)
|
|
apply (frule cmap_relation_ntfn)
|
|
apply (erule (1) cmap_relation_ko_atE)
|
|
apply (rule conjI)
|
|
apply (erule h_t_valid_clift)
|
|
apply (clarsimp simp: setNotification_def split_def)
|
|
apply (rule bexI [OF _ setObject_eq])
|
|
apply (simp add: rf_sr_def cstate_relation_def Let_def init_def
|
|
cpspace_relation_def update_ntfn_map_tos
|
|
typ_heap_simps')
|
|
apply (elim conjE)
|
|
apply (intro conjI)
|
|
\<comment> \<open>tcb relation\<close>
|
|
apply (rule cpspace_relation_ntfn_update_ntfn, assumption+)
|
|
apply (clarsimp simp: cnotification_relation_def Let_def
|
|
mask_def [where n=2] NtfnState_Waiting_def)
|
|
apply (case_tac "ntfnObj rv")
|
|
apply (auto simp: option_to_ctcb_ptr_def obj_at'_def objBits_simps projectKOs
|
|
bindNTFN_alignment_junk)[4]
|
|
apply (simp add: carch_state_relation_def typ_heap_simps')
|
|
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 ceqv
|
|
apply (rule ccorres_move_c_guard_tcb)
|
|
apply (simp add: setBoundNotification_def)
|
|
apply (rule_tac P'=\<top> and P=\<top> in threadSet_ccorres_lemma3[unfolded dc_def])
|
|
apply vcg
|
|
apply simp
|
|
apply (erule (1) rf_sr_tcb_update_no_queue2,
|
|
(simp add: typ_heap_simps')+, simp_all?)[1]
|
|
apply (simp add: ctcb_relation_def option_to_ptr_def option_to_0_def)
|
|
apply simp
|
|
apply (wp get_ntfn_ko'| simp add: guard_is_UNIV_def)+
|
|
done
|
|
|
|
lemma invokeTCB_NotificationControl_bind_ccorres:
|
|
"ccorres (cintr \<currency> (\<lambda>rv rv'. rv = [])) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and tcb_inv_wf' (tcbinvocation.NotificationControl t (Some a)))
|
|
(UNIV \<inter> {s. tcb_' s = tcb_ptr_to_ctcb_ptr t} \<inter> {s. ntfnPtr_' s = ntfn_Ptr a}) []
|
|
(invokeTCB (tcbinvocation.NotificationControl t (Some a)))
|
|
(Call invokeTCB_NotificationControl_'proc)"
|
|
apply (cinit lift: tcb_' ntfnPtr_')
|
|
apply (clarsimp simp: option_to_0_def liftE_def)
|
|
apply (rule ccorres_cond_true_seq)
|
|
apply (ctac(no_vcg) add: bindNotification_ccorres)
|
|
apply (rule ccorres_return_CE[unfolded returnOk_def, simplified])
|
|
apply simp
|
|
apply simp
|
|
apply simp
|
|
apply wp
|
|
apply (case_tac "a = 0", auto)
|
|
done
|
|
|
|
lemma invokeTCB_NotificationControl_unbind_ccorres:
|
|
"ccorres (cintr \<currency> (\<lambda>rv rv'. rv = [])) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and tcb_inv_wf' (tcbinvocation.NotificationControl t None))
|
|
(UNIV \<inter> {s. tcb_' s = tcb_ptr_to_ctcb_ptr t} \<inter> {s. ntfnPtr_' s = NULL}) []
|
|
(invokeTCB (tcbinvocation.NotificationControl t None))
|
|
(Call invokeTCB_NotificationControl_'proc)"
|
|
apply (cinit lift: tcb_' ntfnPtr_')
|
|
apply (clarsimp simp add: option_to_0_def liftE_def)
|
|
apply (ctac(no_vcg) add: unbindNotification_ccorres)
|
|
apply (rule ccorres_return_CE[unfolded returnOk_def, simplified])
|
|
apply simp
|
|
apply simp
|
|
apply simp
|
|
apply wp
|
|
apply (clarsimp simp: option_to_0_def)
|
|
done
|
|
|
|
lemma valid_objs_boundNTFN_NULL:
|
|
"ko_at' tcb p s ==> valid_objs' s \<Longrightarrow> no_0_obj' s \<Longrightarrow> tcbBoundNotification tcb \<noteq> Some 0"
|
|
apply (drule(1) obj_at_valid_objs')
|
|
apply (clarsimp simp: valid_tcb'_def projectKOs valid_obj'_def)
|
|
done
|
|
|
|
lemma decodeUnbindNotification_ccorres:
|
|
"ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and (\<lambda>s. ksCurThread s = thread) and ct_active' and sch_act_simple
|
|
and valid_cap' cp and K (isThreadCap cp)
|
|
and tcb_at' (capTCBPtr cp)
|
|
and (\<lambda>s. \<forall>rf \<in> zobj_refs' cp. ex_nonz_cap_to' rf s))
|
|
(UNIV \<inter> {s. ccap_relation cp (cap_' s)}) []
|
|
(decodeUnbindNotification cp >>= invocationCatch thread isBlocking isCall InvokeTCB)
|
|
(Call decodeUnbindNotification_'proc)"
|
|
apply (cinit' lift: cap_' simp: decodeUnbindNotification_def)
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (rule ccorres_Guard_Seq)
|
|
apply (simp add: liftE_bindE bind_assoc)
|
|
apply (rule ccorres_pre_getBoundNotification)
|
|
apply (rule_tac P="\<lambda>s. rv \<noteq> Some 0" in ccorres_cross_over_guard)
|
|
apply (simp add: bindE_bind_linearise)
|
|
apply wpc
|
|
apply (simp add: bindE_bind_linearise[symmetric]
|
|
injection_handler_throwError
|
|
invocationCatch_use_injection_handler)
|
|
apply (rule ccorres_cond_true_seq)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def syscall_error_rel_def
|
|
syscall_error_to_H_cases exception_defs)
|
|
apply (simp add: returnOk_bind ccorres_invocationCatch_Inr
|
|
performInvocation_def)
|
|
apply (rule ccorres_cond_false_seq)
|
|
apply simp
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply (ctac add: invokeTCB_NotificationControl_unbind_ccorres)
|
|
apply simp
|
|
apply (rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (vcg exspec=invokeTCB_NotificationControl_modifies)
|
|
apply simp
|
|
apply (wp sts_invs_minor' hoare_case_option_wp sts_bound_tcb_at' | wpc | simp)+
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply (clarsimp, frule obj_at_ko_at', clarsimp)
|
|
apply (rule cmap_relationE1[OF cmap_relation_tcb], assumption)
|
|
apply (erule ko_at_projectKO_opt)
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply (frule cap_get_tag_isCap_unfolded_H_cap)
|
|
apply (auto simp: ctcb_relation_def typ_heap_simps cap_get_tag_ThreadCap ct_in_state'_def
|
|
option_to_ptr_def option_to_0_def ThreadState_Restart_def
|
|
mask_def rf_sr_ksCurThread valid_tcb_state'_def
|
|
elim!: pred_tcb'_weakenE
|
|
dest!: valid_objs_boundNTFN_NULL)
|
|
done
|
|
|
|
lemma nTFN_case_If_ptr:
|
|
"(case x of capability.NotificationCap a b c d \<Rightarrow> P a d | _ \<Rightarrow> Q) = (if (isNotificationCap x) then P (capNtfnPtr x) (capNtfnCanReceive x) else Q)"
|
|
by (auto simp: isNotificationCap_def split: capability.splits)
|
|
|
|
lemma decodeBindNotification_ccorres:
|
|
"interpret_excaps extraCaps' = excaps_map extraCaps \<Longrightarrow>
|
|
ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and (\<lambda>s. ksCurThread s = thread) and ct_active' and sch_act_simple
|
|
and valid_cap' cp
|
|
and tcb_at' (capTCBPtr cp) and ex_nonz_cap_to' (capTCBPtr cp)
|
|
and (\<lambda>s. \<forall>rf \<in> zobj_refs' cp. ex_nonz_cap_to' rf s)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps. \<forall>y \<in> zobj_refs' (fst v). ex_nonz_cap_to' y s )
|
|
and (excaps_in_mem extraCaps o ctes_of)
|
|
and K (isThreadCap cp))
|
|
(UNIV \<inter> {s. ccap_relation cp (cap_' s)}
|
|
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}) []
|
|
(decodeBindNotification cp extraCaps >>= invocationCatch thread isBlocking isCall InvokeTCB)
|
|
(Call decodeBindNotification_'proc)"
|
|
apply (simp, rule ccorres_gen_asm)
|
|
apply (cinit' lift: cap_' current_extra_caps_' simp: decodeBindNotification_def)
|
|
apply (simp add: bind_assoc whenE_def bind_bindE_assoc interpret_excaps_test_null
|
|
del: Collect_const cong: call_ignore_cong)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (simp add: excaps_map_def invocationCatch_def throwError_bind null_def
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (simp add: excaps_map_def null_def del: Collect_const cong: call_ignore_cong)
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (rule ccorres_Guard_Seq)
|
|
apply (simp add: liftE_bindE bind_assoc cong: call_ignore_cong)
|
|
apply (rule ccorres_pre_getBoundNotification)
|
|
apply (rule_tac P="\<lambda>s. rv \<noteq> Some 0" in ccorres_cross_over_guard)
|
|
apply (simp add: bindE_bind_linearise cong: call_ignore_cong)
|
|
apply wpc
|
|
prefer 2
|
|
apply (simp add: bindE_bind_linearise[symmetric] injection_handler_throwError
|
|
invocationCatch_use_injection_handler throwError_bind invocationCatch_def)
|
|
apply (rule ccorres_cond_true_seq)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def syscall_error_rel_def syscall_error_to_H_cases
|
|
exception_defs)
|
|
apply (simp add: returnOk_bind ccorres_invocationCatch_Inr performInvocation_def
|
|
bindE_bind_linearise[symmetric] cong: call_ignore_cong)
|
|
apply (rule ccorres_cond_false_seq)
|
|
apply (simp cong: call_ignore_cong)
|
|
apply (rule getSlotCap_ccorres_fudge_n[where vals=extraCaps and n=0])
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply ctac
|
|
apply csymbr
|
|
apply (simp add: cap_get_tag_isCap if_1_0_0 del: Collect_const cong: call_ignore_cong)
|
|
apply (rule ccorres_assert2)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule_tac P="Q (capNtfnPtr rva) (capNtfnCanReceive rva) rva"for Q in ccorres_inst)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (simp add: hd_conv_nth del: Collect_const cong: call_ignore_cong)
|
|
apply (simp only: cap_get_tag_isCap(3)[symmetric] cong: call_ignore_cong, frule(1) cap_get_tag_to_H(3) )
|
|
apply (simp add: case_bool_If if_to_top_of_bindE if_to_top_of_bind bind_assoc
|
|
del: Collect_const cong: if_cong call_ignore_cong)
|
|
apply csymbr
|
|
apply (clarsimp simp add: if_to_top_of_bind to_bool_eq_0[symmetric] simp del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (clarsimp simp: to_bool_def throwError_bind invocationCatch_def)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def syscall_error_rel_def syscall_error_to_H_cases exception_defs)
|
|
apply (clarsimp simp: to_bool_def)
|
|
apply (rule ccorres_pre_getNotification)
|
|
apply (rename_tac ntfn)
|
|
apply (rule ccorres_rhs_assoc2)
|
|
apply (rule ccorres_rhs_assoc2)
|
|
apply (rule_tac xf'="ret__int_'" and val="from_bool (ntfnBoundTCB ntfn \<noteq> None \<or>
|
|
isWaitingNtfn (ntfnObj ntfn))"
|
|
and R="ko_at' ntfn (capNtfnPtr_CL (cap_notification_cap_lift ntfn_cap))
|
|
and valid_ntfn' ntfn"
|
|
and R'=UNIV
|
|
in ccorres_symb_exec_r_known_rv_UNIV)
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: if_1_0_0)
|
|
|
|
apply (erule cmap_relationE1[OF cmap_relation_ntfn], erule ko_at_projectKO_opt)
|
|
apply (clarsimp simp: typ_heap_simps cnotification_relation_def Let_def
|
|
valid_ntfn'_def)
|
|
apply (case_tac "ntfnObj ntfn", simp_all add: isWaitingNtfn_def option_to_ctcb_ptr_def
|
|
false_def true_def split: option.split_asm if_split,
|
|
auto simp: neq_Nil_conv tcb_queue_relation'_def tcb_at_not_NULL[symmetric]
|
|
tcb_at_not_NULL)[1]
|
|
apply ceqv
|
|
apply (rule_tac P="\<lambda>s. ksCurThread s = thread" in ccorres_cross_over_guard)
|
|
apply (simp add: bindE_bind_linearise del: Collect_const)
|
|
apply wpc
|
|
\<comment> \<open>IdleNtfn\<close>
|
|
apply (simp add: case_option_If del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (clarsimp simp: isWaitingNtfn_def from_bool_neq_0)
|
|
apply (simp add: bindE_bind_linearise[symmetric] injection_handler_throwError
|
|
invocationCatch_use_injection_handler throwError_bind invocationCatch_def)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def syscall_error_rel_def
|
|
syscall_error_to_H_cases exception_defs)
|
|
apply (clarsimp simp: isWaitingNtfn_def from_bool_neq_0 returnOk_bind)
|
|
apply (clarsimp simp: isWaitingNtfn_def from_bool_neq_0 returnOk_bind
|
|
ccorres_invocationCatch_Inr performInvocation_def)
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply (ctac add: invokeTCB_NotificationControl_bind_ccorres)
|
|
apply simp
|
|
apply (rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (vcg exspec=invokeTCB_NotificationControl_modifies)
|
|
apply simp
|
|
apply (wp sts_invs_minor' hoare_case_option_wp sts_bound_tcb_at' | wpc | simp)+
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply (simp add: case_option_If del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (clarsimp simp: isWaitingNtfn_def from_bool_neq_0)
|
|
apply (simp add: bindE_bind_linearise[symmetric] injection_handler_throwError
|
|
invocationCatch_use_injection_handler throwError_bind invocationCatch_def)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def syscall_error_rel_def
|
|
syscall_error_to_H_cases exception_defs)
|
|
apply (clarsimp simp: isWaitingNtfn_def from_bool_neq_0 returnOk_bind)
|
|
apply (clarsimp simp: isWaitingNtfn_def from_bool_neq_0 returnOk_bind
|
|
ccorres_invocationCatch_Inr performInvocation_def)
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply (ctac add: invokeTCB_NotificationControl_bind_ccorres)
|
|
apply simp
|
|
apply (rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (vcg exspec=invokeTCB_NotificationControl_modifies)
|
|
apply simp
|
|
apply (wp sts_invs_minor' hoare_case_option_wp sts_bound_tcb_at' | wpc | simp)+
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply (simp add: bindE_bind_linearise[symmetric] injection_handler_throwError
|
|
invocationCatch_use_injection_handler throwError_bind invocationCatch_def)
|
|
apply (rule ccorres_cond_true_seq)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def syscall_error_rel_def
|
|
syscall_error_to_H_cases exception_defs)
|
|
apply (clarsimp simp add: guard_is_UNIV_def isWaitingNtfn_def from_bool_0
|
|
ThreadState_Restart_def mask_def true_def
|
|
rf_sr_ksCurThread capTCBPtr_eq)
|
|
apply (simp add: hd_conv_nth bindE_bind_linearise nTFN_case_If_ptr throwError_bind invocationCatch_def)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def syscall_error_rel_def syscall_error_to_H_cases
|
|
exception_defs)
|
|
apply clarsimp
|
|
apply (wp | simp | wpc | wp (once) hoare_drop_imps)+
|
|
apply vcg
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply safe[1]
|
|
apply (fastforce simp: invs'_def valid_state'_def valid_pspace'_def
|
|
dest!: valid_objs_boundNTFN_NULL)
|
|
apply ((fastforce elim!: pred_tcb'_weakenE obj_at'_weakenE
|
|
simp: ct_in_state'_def from_bool_0 isCap_simps excaps_map_def
|
|
neq_Nil_conv obj_at'_def pred_tcb_at'_def valid_tcb_state'_def)+)[12]
|
|
apply (clarsimp dest!: obj_at_valid_objs'[OF _ invs_valid_objs']
|
|
simp: projectKOs valid_obj'_def)
|
|
apply (clarsimp simp: excaps_map_Nil cte_wp_at_ctes_of excaps_map_def neq_Nil_conv
|
|
dest!: interpret_excaps_eq )
|
|
apply (clarsimp simp: excaps_map_Nil)
|
|
apply (frule obj_at_ko_at', clarsimp)
|
|
apply (rule cmap_relationE1[OF cmap_relation_tcb], assumption)
|
|
apply (erule ko_at_projectKO_opt)
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply (frule cap_get_tag_isCap_unfolded_H_cap)
|
|
apply safe[1]
|
|
apply (clarsimp simp: typ_heap_simps excaps_map_def neq_Nil_conv
|
|
dest!: interpret_excaps_eq)
|
|
apply clarsimp
|
|
apply (frule cap_get_tag_isCap_unfolded_H_cap(3))
|
|
apply (clarsimp simp: typ_heap_simps cap_get_tag_ThreadCap ccap_relation_def)
|
|
apply (auto simp: word_sless_alt typ_heap_simps cap_get_tag_ThreadCap ctcb_relation_def
|
|
option_to_ptr_def option_to_0_def
|
|
split: if_split)
|
|
done
|
|
|
|
lemma decodeSetSpace_ccorres:
|
|
notes tl_drop_1[simp] scast_mask_8 [simp]
|
|
shows
|
|
"interpret_excaps extraCaps' = excaps_map extraCaps \<Longrightarrow>
|
|
ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and (\<lambda>s. ksCurThread s = thread) and ct_active' and sch_act_simple
|
|
and valid_cap' cp and cte_at' slot and K (isThreadCap cp)
|
|
and tcb_at' (capTCBPtr cp)
|
|
and (\<lambda>s. \<forall>rf \<in> zobj_refs' cp. ex_nonz_cap_to' rf s)
|
|
and (excaps_in_mem extraCaps o ctes_of)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
s \<turnstile>' fst v \<and> cte_at' (snd v) s)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
ex_cte_cap_wp_to' isCNodeCap (snd v) s)
|
|
and sysargs_rel args buffer)
|
|
(UNIV
|
|
\<inter> {s. ccap_relation cp (cap_' s)}
|
|
\<inter> {s. unat (length___unsigned_long_' s) = length args}
|
|
\<inter> {s. slot_' s = cte_Ptr slot}
|
|
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
|
|
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
|
|
(decodeSetSpace args cp slot extraCaps
|
|
>>= invocationCatch thread isBlocking isCall InvokeTCB)
|
|
(Call decodeSetSpace_'proc)"
|
|
supply unsigned_numeral[simp del]
|
|
apply (cinit' lift: cap_' length___unsigned_long_' slot_' current_extra_caps_' buffer_'
|
|
simp: decodeSetSpace_def)
|
|
apply csymbr
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (simp add: if_1_0_0)
|
|
apply (rule ccorres_cond_true_seq | simp)+
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (subgoal_tac "unat length___unsigned_long < 3")
|
|
apply (clarsimp simp: throwError_def invocationCatch_def fst_return
|
|
intr_and_se_rel_def syscall_error_rel_def
|
|
syscall_error_to_H_cases exception_defs
|
|
subset_iff
|
|
split: list.split)
|
|
apply unat_arith
|
|
apply csymbr
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (simp add: if_1_0_0 interpret_excaps_test_null excaps_map_Nil)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply clarsimp
|
|
apply (clarsimp simp: throwError_def invocationCatch_def fst_return
|
|
intr_and_se_rel_def syscall_error_rel_def
|
|
syscall_error_to_H_cases exception_defs
|
|
split: list.split)
|
|
apply csymbr
|
|
apply (simp add: if_1_0_0 interpret_excaps_test_null del: Collect_const)
|
|
apply (rule_tac P="\<lambda>c. ccorres rvr xf P P' hs a (Cond c c1 c2 ;; c3)" for rvr xf P P' hs a c1 c2 c3 in ssubst)
|
|
apply (rule Collect_cong)
|
|
apply (rule interpret_excaps_test_null)
|
|
apply (clarsimp simp: neq_Nil_conv)
|
|
apply simp
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply clarsimp
|
|
apply (clarsimp simp: throwError_def invocationCatch_def fst_return
|
|
intr_and_se_rel_def syscall_error_rel_def
|
|
syscall_error_to_H_cases exception_defs
|
|
excaps_map_def
|
|
split: list.split)
|
|
apply (clarsimp simp add: linorder_not_less word_le_nat_alt
|
|
excaps_map_Nil length_excaps_map
|
|
simp del: Collect_const)
|
|
apply (drule_tac a="Suc 0" in neq_le_trans [OF not_sym])
|
|
apply (clarsimp simp: neq_Nil_conv)
|
|
apply (rule_tac P="\<lambda>a. ccorres rvr xf P P' hs a c" for rvr xf P P' hs c in ssubst,
|
|
rule bind_cong [OF _ refl], rule list_case_helper,
|
|
clarsimp)+
|
|
apply (simp add: hd_drop_conv_nth2 del: Collect_const)
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo[where args=args and n=0 and buffer=buffer])
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo[where args=args and n=1 and buffer=buffer])
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo[where args=args and n=2 and buffer=buffer])
|
|
apply csymbr
|
|
apply (rule getSlotCap_ccorres_fudge_n[where vals=extraCaps and n=0])
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply ctac
|
|
apply (rule ccorres_assert2)
|
|
apply csymbr
|
|
apply (rule getSlotCap_ccorres_fudge_n[where vals=extraCaps and n=1])
|
|
apply (rule ccorres_move_c_guard_cte)
|
|
apply ctac
|
|
apply (rule ccorres_assert2)
|
|
apply csymbr
|
|
apply (simp add: decodeSetSpace_def injection_bindE[OF refl]
|
|
split_def
|
|
tcb_cnode_index_defs[THEN ptr_add_assertion_positive[OF ptr_add_assertion_positive_helper]]
|
|
del: Collect_const)
|
|
apply (rule ccorres_move_array_assertion_tcb_ctes ccorres_Guard_Seq
|
|
ccorres_rhs_assoc)+
|
|
apply (simp add: injection_liftE[OF refl] bindE_assoc
|
|
liftM_def getThreadCSpaceRoot
|
|
getThreadVSpaceRoot del: Collect_const)
|
|
apply (simp add: liftE_bindE bind_assoc del: Collect_const)
|
|
apply (ctac add: slotCapLongRunningDelete_ccorres)
|
|
apply (rule ccorres_move_array_assertion_tcb_ctes)
|
|
apply (simp del: Collect_const)
|
|
apply csymbr
|
|
apply (clarsimp simp add: if_1_0_0 from_bool_0
|
|
simp del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (rule ccorres_symb_exec_l [OF _ _ _ empty_fail_slotCapLongRunningDelete])
|
|
apply (simp add: unlessE_def throwError_bind invocationCatch_def
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule ccorres_cond_true_seq)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply wp+
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply csymbr
|
|
apply (simp add: tcb_cnode_index_defs[THEN ptr_add_assertion_positive[OF ptr_add_assertion_positive_helper]]
|
|
del: Collect_const)
|
|
apply (rule ccorres_move_array_assertion_tcb_ctes ccorres_Guard_Seq
|
|
ccorres_rhs_assoc)+
|
|
apply (ctac add: slotCapLongRunningDelete_ccorres)
|
|
apply (rule ccorres_move_array_assertion_tcb_ctes)
|
|
apply (simp del: Collect_const)
|
|
apply csymbr
|
|
apply (clarsimp simp add: if_1_0_0 from_bool_0
|
|
simp del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (simp add: unlessE_def throwError_bind invocationCatch_def
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (simp add: unlessE_def
|
|
del: Collect_const)
|
|
apply (rule ccorres_add_return,
|
|
rule_tac r'="\<lambda>rv rv'. ccap_relation (if args ! Suc 0 = 0 then fst (hd extraCaps)
|
|
else updateCapData False (args ! Suc 0) (fst (hd extraCaps))) rv'"
|
|
and xf'="cRootCap_'" in ccorres_split_nothrow)
|
|
apply (rule_tac P'="{s. cRootCap = cRootCap_' s}"
|
|
in ccorres_from_vcg[where P=\<top>])
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (subgoal_tac "extraCaps \<noteq> []")
|
|
apply (clarsimp simp: returnOk_def return_def hd_conv_nth false_def)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply ceqv
|
|
apply (simp add: invocationCatch_use_injection_handler
|
|
injection_bindE [OF refl refl] bindE_assoc
|
|
del: Collect_const)
|
|
apply (ctac add: ccorres_injection_handler_csum1
|
|
[OF deriveCap_ccorres])
|
|
apply (simp add: Collect_False del: Collect_const)
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (simp add: cnode_cap_case_if cap_get_tag_isCap dc_def[symmetric]
|
|
del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (simp add: injection_handler_throwError
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (simp add: injection_handler_returnOk del: Collect_const)
|
|
apply (rule ccorres_add_return,
|
|
rule_tac r'="\<lambda>rv rv'. ccap_relation (if args ! 2 = 0 then fst (extraCaps ! Suc 0)
|
|
else updateCapData False (args ! 2) (fst (extraCaps ! Suc 0))) rv'"
|
|
and xf'="vRootCap_'" in ccorres_split_nothrow)
|
|
apply (rule_tac P'="{s. vRootCap = vRootCap_' s}"
|
|
in ccorres_from_vcg[where P=\<top>])
|
|
apply (rule allI, rule conseqPre, vcg)
|
|
apply (clarsimp simp: returnOk_def return_def
|
|
hd_drop_conv_nth2 false_def)
|
|
apply fastforce
|
|
apply ceqv
|
|
apply (ctac add: ccorres_injection_handler_csum1
|
|
[OF deriveCap_ccorres])
|
|
apply (simp add: Collect_False del: Collect_const)
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (simp add: from_bool_0 isValidVTableRoot_conv del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs_Seq)
|
|
apply (simp add: injection_handler_throwError
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (simp add: injection_handler_returnOk ccorres_invocationCatch_Inr
|
|
performInvocation_def)
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply csymbr
|
|
apply csymbr
|
|
apply (ctac(no_vcg) add: invokeTCB_ThreadControl_ccorres)
|
|
apply simp
|
|
apply (rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply simp
|
|
apply (wp sts_invs_minor')
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply simp
|
|
apply (rule ccorres_split_throws, rule ccorres_return_C_errorE, simp+)
|
|
apply vcg
|
|
apply simp
|
|
apply (wp hoare_drop_imps)
|
|
apply (wp injection_wp_E [OF refl])
|
|
apply (simp add: Collect_const_mem cintr_def intr_and_se_rel_def
|
|
all_ex_eq_helper syscall_error_rel_def
|
|
exception_defs)
|
|
apply (vcg exspec=deriveCap_modifies)
|
|
apply (simp cong: if_cong)
|
|
apply wp
|
|
apply (simp add: Collect_const_mem all_ex_eq_helper)
|
|
apply vcg
|
|
apply simp
|
|
apply (rule ccorres_split_throws, rule ccorres_return_C_errorE, simp+)
|
|
apply vcg
|
|
apply (simp cong: if_cong)
|
|
apply (wp hoare_drop_imps injection_wp_E[OF refl])
|
|
apply (simp add: Collect_const_mem all_ex_eq_helper
|
|
numeral_eqs syscall_error_rel_def
|
|
exception_defs cintr_def intr_and_se_rel_def)
|
|
apply (vcg exspec=deriveCap_modifies)
|
|
apply (simp cong: if_cong)
|
|
apply wp
|
|
apply (simp add: Collect_const_mem all_ex_eq_helper
|
|
numeral_eqs syscall_error_rel_def
|
|
exception_defs cintr_def intr_and_se_rel_def
|
|
hd_drop_conv_nth2
|
|
cong: if_cong)
|
|
apply vcg
|
|
apply (simp cong: if_cong)
|
|
apply (wp hoare_drop_imps)
|
|
apply (simp add: Collect_const_mem)
|
|
apply (vcg exspec=slotCapLongRunningDelete_modifies)
|
|
apply (simp cong: if_cong)
|
|
apply (wp hoare_drop_imps)
|
|
apply (simp add: Collect_const_mem all_ex_eq_helper
|
|
numeral_eqs syscall_error_rel_def
|
|
exception_defs cintr_def intr_and_se_rel_def)
|
|
apply (vcg exspec=slotCapLongRunningDelete_modifies)
|
|
apply (simp add: pred_conj_def cong: if_cong)
|
|
apply (strengthen if_n_updateCapData_valid_strg)
|
|
apply (wp hoare_drop_imps)
|
|
apply (simp add: Collect_const_mem all_ex_eq_helper
|
|
numeral_eqs syscall_error_rel_def
|
|
exception_defs cintr_def intr_and_se_rel_def)
|
|
apply vcg
|
|
apply simp
|
|
apply (wp hoare_drop_imps)
|
|
apply (simp add: Collect_const_mem all_ex_eq_helper
|
|
numeral_eqs syscall_error_rel_def
|
|
exception_defs cintr_def intr_and_se_rel_def)
|
|
apply vcg
|
|
apply simp
|
|
apply (wp hoare_drop_imps)
|
|
apply (simp add: Collect_const_mem all_ex_eq_helper
|
|
numeral_eqs syscall_error_rel_def
|
|
exception_defs cintr_def intr_and_se_rel_def
|
|
cong: if_cong
|
|
| vcg exspec=getSyscallArg_modifies
|
|
| wp)+
|
|
apply (clarsimp simp: word_less_nat_alt)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: ct_in_state'_def interpret_excaps_test_null
|
|
excaps_map_def neq_Nil_conv)
|
|
apply (rule conjI, clarsimp simp: sysargs_rel_n_def n_msgRegisters_def)
|
|
apply (rule conjI, clarsimp simp: sysargs_rel_n_def n_msgRegisters_def)
|
|
apply (rule conjI, clarsimp simp: sysargs_rel_n_def n_msgRegisters_def)
|
|
apply (frule(2) tcb_at_capTCBPtr_CL)
|
|
apply (auto simp: isCap_simps valid_tcb_state'_def objBits_defs mask_def
|
|
elim!: pred_tcb'_weakenE
|
|
dest!: st_tcb_at_idle_thread' interpret_excaps_eq)[1]
|
|
apply (clarsimp simp: linorder_not_le interpret_excaps_test_null
|
|
excaps_map_def neq_Nil_conv word_sle_def
|
|
word_sless_def)
|
|
apply (frule interpret_excaps_eq[rule_format, where n=0], simp)
|
|
apply (frule interpret_excaps_eq[rule_format, where n=1], simp)
|
|
apply (clarsimp simp: mask_def[where n=4] ccap_rights_relation_def
|
|
rightsFromWord_wordFromRights
|
|
capTCBPtr_eq tcb_cnode_index_defs size_of_def
|
|
option_to_0_def rf_sr_ksCurThread
|
|
"StrictC'_thread_state_defs" mask_eq_iff_w2p word_size)
|
|
apply (simp add: word_sle_def cap_get_tag_isCap)
|
|
apply (subgoal_tac "args \<noteq> []")
|
|
apply (clarsimp simp: hd_conv_nth)
|
|
apply (drule sym, simp, simp add: true_def from_bool_0)
|
|
apply (clarsimp simp: objBits_defs)
|
|
apply fastforce
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma invokeTCB_SetTLSBase_ccorres:
|
|
notes static_imp_wp [wp]
|
|
shows
|
|
"ccorres (cintr \<currency> (\<lambda>rv rv'. rv = [])) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs')
|
|
({s. thread_' s = tcb_ptr_to_ctcb_ptr tcb}
|
|
\<inter> {s. tls_base_' s = tls_base}) []
|
|
(invokeTCB (SetTLSBase tcb tls_base))
|
|
(Call invokeSetTLSBase_'proc)"
|
|
apply (cinit lift: thread_' tls_base_')
|
|
apply (simp add: liftE_def bind_assoc
|
|
del: Collect_const)
|
|
apply (ctac add: setRegister_ccorres[simplified dc_def])
|
|
apply (rule ccorres_pre_getCurThread)
|
|
apply (rename_tac cur_thr)
|
|
apply (rule ccorres_split_nothrow_novcg_dc)
|
|
apply (rule_tac R="\<lambda>s. cur_thr = ksCurThread s" in ccorres_when)
|
|
apply (clarsimp simp: rf_sr_ksCurThread)
|
|
apply clarsimp
|
|
apply (ctac (no_vcg) add: rescheduleRequired_ccorres)
|
|
apply (unfold return_returnOk)[1]
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (wpsimp wp: hoare_drop_imp simp: guard_is_UNIV_def)+
|
|
apply vcg
|
|
apply (clarsimp simp: tlsBaseRegister_def ARM.tlsBaseRegister_def
|
|
invs_weak_sch_act_wf invs_queues TLS_BASE_def TPIDRURW_def
|
|
split: if_split)
|
|
done
|
|
|
|
lemma decodeSetTLSBase_ccorres:
|
|
"ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and sch_act_simple
|
|
and (\<lambda>s. ksCurThread s = thread) and ct_active' and K (isThreadCap cp)
|
|
and valid_cap' cp and (\<lambda>s. \<forall>x \<in> zobj_refs' cp. ex_nonz_cap_to' x s)
|
|
and sysargs_rel args buffer)
|
|
(UNIV
|
|
\<inter> {s. ccap_relation cp (cap_' s)}
|
|
\<inter> {s. unat (length___unsigned_long_' s) = length args}
|
|
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
|
|
(decodeSetTLSBase args cp
|
|
>>= invocationCatch thread isBlocking isCall InvokeTCB)
|
|
(Call decodeSetTLSBase_'proc)"
|
|
apply (cinit' lift: cap_' length___unsigned_long_' buffer_'
|
|
simp: decodeSetTLSBase_def)
|
|
apply wpc
|
|
apply (simp add: throwError_bind invocationCatch_def)
|
|
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
|
|
apply vcg
|
|
apply (rule conseqPre, vcg)
|
|
apply (clarsimp simp: throwError_def return_def
|
|
exception_defs syscall_error_rel_def
|
|
syscall_error_to_H_cases)
|
|
apply (rule ccorres_cond_false_seq; simp)
|
|
apply (rule ccorres_add_return,
|
|
ctac add: getSyscallArg_ccorres_foo'[where args=args and n=0 and buffer=buffer])
|
|
apply (simp add: invocationCatch_use_injection_handler
|
|
bindE_assoc injection_handler_returnOk
|
|
ccorres_invocationCatch_Inr performInvocation_def)
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply csymbr
|
|
apply (ctac (no_vcg) add: invokeTCB_SetTLSBase_ccorres)
|
|
apply simp
|
|
apply (rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply (wpsimp wp: sts_invs_minor')+
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply wp
|
|
apply vcg
|
|
apply (clarsimp simp: Collect_const_mem)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: ct_in_state'_def sysargs_rel_n_def n_msgRegisters_def)
|
|
apply (auto simp: valid_tcb_state'_def
|
|
elim!: pred_tcb'_weakenE)[1]
|
|
apply (simp add: StrictC'_thread_state_defs mask_eq_iff_w2p word_size)
|
|
apply (frule rf_sr_ksCurThread)
|
|
apply (simp only: cap_get_tag_isCap[symmetric], drule(1) cap_get_tag_to_H)
|
|
apply (auto simp: unat_eq_0 le_max_word_ucast_id)+
|
|
done
|
|
|
|
lemma decodeTCBInvocation_ccorres:
|
|
"interpret_excaps extraCaps' = excaps_map extraCaps \<Longrightarrow>
|
|
ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
|
|
(invs' and (\<lambda>s. ksCurThread s = thread) and ct_active' and sch_act_simple
|
|
and valid_cap' cp and cte_at' slot and K (isThreadCap cp)
|
|
and (excaps_in_mem extraCaps o ctes_of)
|
|
and tcb_at' (capTCBPtr cp) and ex_nonz_cap_to' (capTCBPtr cp)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps. \<forall>y \<in> zobj_refs' (fst v).
|
|
ex_nonz_cap_to' y s)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
s \<turnstile>' fst v \<and> cte_at' (snd v) s)
|
|
and (\<lambda>s. \<forall>v \<in> set extraCaps.
|
|
ex_cte_cap_wp_to' isCNodeCap (snd v) s)
|
|
and sysargs_rel args buffer)
|
|
(UNIV
|
|
\<inter> {s. invLabel_' s = label}
|
|
\<inter> {s. ccap_relation cp (cap_' s)}
|
|
\<inter> {s. unat (length___unsigned_long_' s) = length args}
|
|
\<inter> {s. slot_' s = cte_Ptr slot}
|
|
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
|
|
\<inter> {s. call_' s = from_bool isCall}
|
|
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
|
|
(decodeTCBInvocation label args cp slot extraCaps
|
|
>>= invocationCatch thread isBlocking isCall InvokeTCB)
|
|
(Call decodeTCBInvocation_'proc)"
|
|
apply (cinit' lift: invLabel_' cap_' length___unsigned_long_' slot_' current_extra_caps_' call_' buffer_')
|
|
apply (simp add: decodeTCBInvocation_def invocation_eq_use_types gen_invocation_type_eq
|
|
del: Collect_const)
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply simp
|
|
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeReadRegisters_ccorres [where buffer=buffer])
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply simp
|
|
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeWriteRegisters_ccorres [where buffer=buffer])
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply simp
|
|
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeCopyRegisters_ccorres [where buffer=buffer])
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply (simp add: returnOk_bind ccorres_invocationCatch_Inr)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply csymbr
|
|
apply (simp add: performInvocation_def)
|
|
apply (ctac add: invokeTCB_Suspend_ccorres)
|
|
apply simp
|
|
apply (rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (vcg exspec=invokeTCB_Suspend_modifies)
|
|
apply (wp sts_invs_minor')
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply (simp add: returnOk_bind ccorres_invocationCatch_Inr)
|
|
apply (rule ccorres_rhs_assoc)+
|
|
apply (ctac add: setThreadState_ccorres)
|
|
apply csymbr
|
|
apply (simp add: performInvocation_def)
|
|
apply (ctac add: invokeTCB_Resume_ccorres)
|
|
apply simp
|
|
apply (rule ccorres_alternative2)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (vcg exspec=invokeTCB_Resume_modifies)
|
|
apply (wp sts_invs_minor')
|
|
apply (vcg exspec=setThreadState_modifies)
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply simp
|
|
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeTCBConfigure_ccorres [where buffer=buffer])
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply simp
|
|
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeSetPriority_ccorres [where buffer=buffer])
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply simp
|
|
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeSetMCPriority_ccorres [where buffer=buffer])
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply simp
|
|
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeSetSchedParams_ccorres [where buffer=buffer])
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply simp
|
|
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeSetIPCBuffer_ccorres [where buffer=buffer])
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply simp
|
|
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeSetSpace_ccorres [where buffer=buffer])
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply simp
|
|
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeBindNotification_ccorres)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply simp
|
|
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeUnbindNotification_ccorres)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (rule ccorres_Cond_rhs)
|
|
apply (simp add: gen_invocation_type_eq)
|
|
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeSetTLSBase_ccorres)
|
|
apply (rule ccorres_return_CE, simp+)[1]
|
|
apply (rule ccorres_return_C_errorE, simp+)[1]
|
|
apply wp
|
|
apply (rule ccorres_equals_throwError)
|
|
apply (fastforce simp: throwError_bind invocationCatch_def
|
|
split: invocation_label.split gen_invocation_labels.split)
|
|
apply (simp add: ccorres_cond_iffs
|
|
cong: StateSpace.state.fold_congs globals.fold_congs)
|
|
apply (rule syscall_error_throwError_ccorres_n)
|
|
apply (simp add: syscall_error_to_H_cases)
|
|
apply (clarsimp simp: cintr_def intr_and_se_rel_def
|
|
exception_defs rf_sr_ksCurThread
|
|
Collect_const_mem)
|
|
apply (rule conjI)
|
|
apply (auto simp: ct_in_state'_def isCap_simps valid_tcb_state'_def
|
|
elim!: pred_tcb'_weakenE
|
|
dest!: st_tcb_at_idle_thread')[1]
|
|
apply (simp split: sum.split add: cintr_def intr_and_se_rel_def
|
|
exception_defs syscall_error_rel_def)
|
|
apply (simp add: "StrictC'_thread_state_defs" mask_eq_iff_w2p word_size
|
|
cap_get_tag_isCap)
|
|
apply (simp add: cap_get_tag_isCap[symmetric], drule(1) cap_get_tag_to_H)
|
|
apply clarsimp
|
|
done
|
|
|
|
end
|
|
end
|