2014-07-14 19:32:44 +00:00
(*
* Copyright 2014, General Dynamics C4 Systems
*
2020-03-09 06:18:30 +00:00
* SPDX-License-Identifier: GPL-2.0-only
2014-07-14 19:32:44 +00:00
*)
theory Tcb_C
2020-03-12 00:55:09 +00:00
imports Delete_C Ipc_C
2014-07-14 19:32:44 +00:00
begin
lemma asUser_obj_at' :
2017-01-13 12:58:40 +00:00
"\<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)
2014-07-14 19:32:44 +00:00
apply wp
2017-11-21 23:52:59 +00:00
apply (case_tac "t=t'"; clarsimp)
apply (rule hoare_drop_imps)
2014-07-14 19:32:44 +00:00
apply wp
2017-01-13 12:58:40 +00:00
done
2014-07-14 19:32:44 +00:00
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>))"
2017-07-12 05:13:51 +00:00
apply (clarsimp simp: in_monad getObject_def split_def loadObject_default_def
2014-07-14 19:32:44 +00:00
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
2016-05-04 05:07:51 +00:00
context begin interpretation Arch . (*FIXME: arch_split*)
2014-07-14 19:32:44 +00:00
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)
2016-05-04 05:07:51 +00:00
end
2014-07-14 19:32:44 +00:00
context kernel_m
begin
lemma getObject_state:
" \<lbrakk>(x, s') \<in> fst (getObject t' s); ko_at' ko t s\<rbrakk>
2017-07-12 05:13:51 +00:00
\<Longrightarrow> (if t = t' then tcbState_update (\<lambda>_. st) x else x,
2014-07-14 19:32:44 +00:00
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>))"
2016-10-25 06:01:30 +00:00
apply (simp split: if_split)
2014-07-14 19:32:44 +00:00
apply (rule conjI)
apply clarsimp
2017-07-12 05:13:51 +00:00
apply (clarsimp simp: getObject_def split_def loadObject_default_def in_monad
2017-10-05 02:47:10 +00:00
Corres_C.in_magnitude_check' projectKOs objBits_simps')
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (clarsimp split: if_split_asm)
2014-09-10 07:26:44 +00:00
apply (erule_tac x=x2 in allE)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: ps_clear_def)
2014-09-10 07:26:44 +00:00
apply (drule_tac x=x2 in orthD2)
2014-07-14 19:32:44 +00:00
apply fastforce
apply clarsimp
2017-07-12 05:13:51 +00:00
apply (erule impE)
2014-07-14 19:32:44 +00:00
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
2017-07-12 05:13:51 +00:00
apply (clarsimp simp: getObject_def split_def loadObject_default_def in_monad
2017-10-05 02:47:10 +00:00
Corres_C.in_magnitude_check' projectKOs objBits_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: magnitudeCheck_def in_monad split: option.splits)
apply clarsimp
apply (simp add: lookupAround2_char2)
2016-10-25 06:01:30 +00:00
apply (clarsimp split: if_split_asm)
2014-07-14 19:32:44 +00:00
apply (erule_tac x=t in allE)
apply simp
2017-07-12 05:13:51 +00:00
apply (clarsimp simp: obj_at'_real_def projectKOs
2014-07-14 19:32:44 +00:00
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
2014-09-10 07:26:44 +00:00
apply (erule_tac x=x2 in allE)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: ps_clear_def)
2014-09-10 07:26:44 +00:00
apply (drule_tac x=x2 in orthD2)
2014-07-14 19:32:44 +00:00
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:
2016-11-10 04:44:36 +00:00
"\<lbrakk> (uc, s') \<in> fst (threadGet (atcbContextGet o tcbArch) t' s); ko_at' ko t s \<rbrakk> \<Longrightarrow>
2017-07-12 05:13:51 +00:00
(uc, s'\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>) \<in>
2016-11-10 04:44:36 +00:00
fst (threadGet (atcbContextGet o tcbArch) t' (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>))"
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: threadGet_def liftM_def in_monad)
2017-07-12 05:13:51 +00:00
apply (drule (1) getObject_state [where st=st])
2014-07-14 19:32:44 +00:00
apply (rule exI)
apply (erule conjI)
apply (simp split: if_splits)
done
lemma asUser_state:
2018-06-09 08:30:53 +00:00
"\<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>
2017-07-12 05:13:51 +00:00
(x,s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbState_update (\<lambda>_. st) ko))\<rparr>) \<in>
2014-07-14 19:32:44 +00:00
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)
2018-06-09 08:30:53 +00:00
apply (frule use_valid, rule threadGet_inv [where P="(=) s"], rule refl)
2014-07-14 19:32:44 +00:00
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)
2018-06-09 08:30:53 +00:00
apply (frule use_valid, rule getObject_inv [where P="(=) s"])
2014-07-14 19:32:44 +00:00
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
2017-10-05 02:47:10 +00:00
objBits_simps' projectKOs in_monad)
2016-10-25 06:01:30 +00:00
apply (simp split: if_split)
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (clarsimp split: if_split)
2014-07-14 19:32:44 +00:00
apply (cases ko)
apply clarsimp
apply clarsimp
apply (rule conjI)
2016-10-25 06:01:30 +00:00
apply (clarsimp simp add: lookupAround2_char2 split: if_split_asm)
2014-09-10 07:26:44 +00:00
apply (erule_tac x=x2 in allE)
2014-07-14 19:32:44 +00:00
apply simp
apply (simp add: ps_clear_def)
2014-09-10 07:26:44 +00:00
apply (drule_tac x=x2 in orthD2)
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (rule ext, clarsimp split: if_split)
2014-07-14 19:32:44 +00:00
apply (cases ko, clarsimp)
apply (clarsimp simp: magnitudeCheck_def in_monad split: option.splits)
apply (rule conjI)
apply clarsimp
apply (cases s, clarsimp)
2016-10-25 06:01:30 +00:00
apply (rule ext, clarsimp split: if_split)
2014-07-14 19:32:44 +00:00
apply (case_tac tcb, clarsimp)
apply clarsimp
apply (rule conjI)
2016-10-25 06:01:30 +00:00
apply (clarsimp simp add: lookupAround2_char2 split: if_split_asm)
2014-07-14 19:32:44 +00:00
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
2014-09-10 07:26:44 +00:00
apply (erule_tac x=x2 in allE)
2014-07-14 19:32:44 +00:00
apply simp
apply (simp add: ps_clear_def)
2014-09-10 07:26:44 +00:00
apply (drule_tac x=x2 in orthD2)
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (rule ext, clarsimp split: if_split)
2014-07-14 19:32:44 +00:00
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))"
2018-06-09 08:30:53 +00:00
assumes inv: "\<And>x. \<lbrace>(=) s\<rbrace> f x \<lbrace>\<lambda>_. (=) s\<rbrace>"
2014-07-14 19:32:44 +00:00
shows "(rv,s) \<in> fst (mapM f xs s) \<Longrightarrow> (rv, g s) \<in> fst (mapM f xs (g s))"
using f inv
2014-09-10 07:26:44 +00:00
proof (induct xs arbitrary: rv s)
2014-07-14 19:32:44 +00:00
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
2017-07-12 05:13:51 +00:00
qed
2014-07-14 19:32:44 +00:00
lemma getMRs_rel_state:
2017-07-12 05:13:51 +00:00
"\<lbrakk>getMRs_rel args buffer s;
2014-08-09 05:16:17 +00:00
(cur_tcb' and case_option \<top> valid_ipc_buffer_ptr' buffer) s;
2014-07-14 19:32:44 +00:00
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)
2017-07-12 05:13:51 +00:00
apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs
2016-10-25 06:01:30 +00:00
objBits_simps ps_clear_def split: if_split)
2014-07-14 19:32:44 +00:00
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
2016-10-25 06:01:30 +00:00
objBits_simps ps_clear_def split: if_split)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: getMRs_def in_monad)
2018-06-09 08:30:53 +00:00
apply (frule use_valid, rule asUser_inv [where P="(=) s"])
2014-07-14 19:32:44 +00:00
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)
2017-07-12 05:13:51 +00:00
apply clarsimp
apply (drule mapM_upd_inv [rotated -1])
2014-07-14 19:32:44 +00:00
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)
2017-07-12 05:13:51 +00:00
apply (clarsimp simp: pointerInUserData_def typ_at'_def ko_wp_at'_def
2014-07-14 19:32:44 +00:00
projectKOs ps_clear_def obj_at'_real_def
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
apply (erule doMachineOp_state)
done
lemma setThreadState_getMRs_rel:
2014-08-09 05:16:17 +00:00
"\<lbrace>getMRs_rel args buffer and cur_tcb' and case_option \<top> valid_ipc_buffer_ptr' buffer
2017-07-12 05:13:51 +00:00
and (\<lambda>_. runnable' st)\<rbrace>
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (clarsimp split: if_split simp del: fun_upd_apply)
2014-07-14 19:32:44 +00:00
apply (simp add: getMRs_rel_state)
done
lemma setThreadState_sysargs_rel:
2017-07-12 05:13:51 +00:00
"\<lbrace>sysargs_rel args buffer and (\<lambda>_. runnable' st)\<rbrace> setThreadState st t \<lbrace>\<lambda>_. sysargs_rel args buffer\<rbrace>"
2014-07-14 19:32:44 +00:00
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:
2017-07-12 05:13:51 +00:00
"\<lbrakk> \<And>rv' t t'. ceqv \<Gamma> xf' rv' t t' g (g' rv'); ccorres rvr xf P P' hs f (g' val) \<rbrakk>
2014-07-14 19:32:44 +00:00
\<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
2019-10-04 02:22:39 +00:00
(\<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))
2014-07-14 19:32:44 +00:00
(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,
2016-09-21 00:33:03 +00:00
(simp add: typ_heap_simps')+, simp_all?)[1]
2014-07-14 19:32:44 +00:00
apply (rule ball_tcb_cte_casesI, simp+)
2019-10-04 02:22:39 +00:00
apply (simp add: ctcb_relation_def)
2014-07-14 19:32:44 +00:00
apply (ctac(no_vcg) add: isRunnable_ccorres)
2018-01-15 06:31:54 +00:00
apply (simp add: when_def to_bool_def del: Collect_const)
apply (rule ccorres_cond2[where R=\<top>], simp add: Collect_const_mem)
2019-10-04 02:22:39 +00:00
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])
2018-01-15 06:31:54 +00:00
apply (rule ccorres_return_Skip')
apply (wp isRunnable_wp)
2019-10-04 02:22:39 +00:00
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)
2018-01-15 06:31:54 +00:00
apply (simp add: guard_is_UNIV_def)
2019-10-04 02:22:39 +00:00
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)))"])
2018-01-15 06:31:54 +00:00
apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues tcbSchedDequeue_nonq)
apply (clarsimp simp: valid_tcb'_tcbPriority_update)
2019-10-04 02:22:39 +00:00
apply clarsimp
apply (frule (1) valid_objs'_maxDomain[where t=t])
apply (frule (1) valid_objs'_maxPriority[where t=t])
apply simp
done
2014-07-14 19:32:44 +00:00
2016-08-02 01:04:23 +00:00
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,
2016-09-21 00:33:03 +00:00
(simp add: typ_heap_simps')+)[1]
2016-08-02 01:04:23 +00:00
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
2016-09-21 00:33:03 +00:00
2014-07-14 19:32:44 +00:00
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))"
2018-06-09 08:30:53 +00:00
and R="cte_wp_at' ((=) x) slot and valid_cap' cap and invs'"
2014-07-14 19:32:44 +00:00
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_')
2017-07-12 05:13:51 +00:00
(invs' and sch_act_simple
2016-08-02 01:04:23 +00:00
and tcb_inv_wf' (ThreadControl target slot faultep mcp priority cRoot vRoot buf)
2014-07-14 19:32:44 +00:00
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}
2018-02-16 04:35:59 +00:00
\<inter> {s. mcp_' s = case_option 0 (ucast o fst) mcp}
\<inter> {s. priority_' s = case_option 0 (ucast o fst) priority}
2014-07-14 19:32:44 +00:00
\<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}
2016-08-02 01:04:23 +00:00
\<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)
2014-07-14 19:32:44 +00:00
|| (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)})
[]
2016-08-02 01:04:23 +00:00
(invokeTCB (ThreadControl target slot faultep mcp priority cRoot vRoot buf))
2014-07-14 19:32:44 +00:00
(Call invokeTCB_ThreadControl_'proc)"
(is "ccorres ?rvr ?xf (?P and (\<lambda>_. ?P')) ?Q [] ?af ?cf")
2020-03-17 08:50:19 +00:00
supply option.case_cong_weak[cong]
2014-07-14 19:32:44 +00:00
apply (rule ccorres_gen_asm)
2016-08-02 01:04:23 +00:00
apply (cinit lift: target_' slot_' faultep_' mcp_' priority_' cRoot_newCap_' cRoot_srcSlot_'
2014-07-14 19:32:44 +00:00
vRoot_newCap_' vRoot_srcSlot_' bufferAddr_' bufferSrcSlot_' bufferCap_'
updateFlags_')
apply csymbr
2014-08-09 05:16:17 +00:00
apply (simp add: liftE_bindE case_option_If2 thread_control_flag_defs
2014-07-14 19:32:44 +00:00
word_ao_dist if_and_helper if_n_0_0
2015-11-16 03:12:37 +00:00
tcb_cnode_index_defs[THEN ptr_add_assertion_positive[OF ptr_add_assertion_positive_helper]]
2014-07-14 19:32:44 +00:00
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,
2020-03-17 08:50:19 +00:00
(simp add: typ_heap_simps)+)
2014-07-14 19:32:44 +00:00
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)
2016-08-02 01:04:23 +00:00
apply (ctac add: setMCPriority_ccorres)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_return_Skip)
apply (rule ceqv_refl)
2019-10-04 02:22:39 +00:00
apply (rule ccorres_subgoal_tailE)
apply (rule ccorres_subgoal_tailE)
apply (rule_tac A="invs' and sch_act_simple and tcb_at' target
2020-03-17 08:50:19 +00:00
and (\<lambda>(s::kernel_state). (case priority of None \<Rightarrow> True | Some x \<Rightarrow> ((\<lambda>y. fst y \<le> maxPriority)) x))
2016-08-02 01:04:23 +00:00
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)"
2019-10-04 02:22:39 +00:00
(* 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
2019-06-22 00:12:48 +00:00
del: Collect_const)
2019-10-04 02:22:39 +00:00
apply (rule ccorres_rhs_assoc)+
2019-06-22 00:12:48 +00:00
apply (rule checkCapAt_ccorres)
apply ceqv
2016-06-04 12:28:27 +00:00
apply csymbr
2019-06-22 00:12:48 +00:00
apply (simp add: true_def Collect_True
2016-06-04 12:28:27 +00:00
del: Collect_const)
2019-10-04 02:22:39 +00:00
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')
2019-06-22 00:12:48 +00:00
apply (rule ccorres_split_nothrow_novcg_dc)
2020-03-17 08:50:19 +00:00
apply (rule ccorres_cond2[where R=\<top>], simp add: Collect_const_mem)
apply (ctac add: setPriority_ccorres)
apply (rule ccorres_return_Skip)
2019-06-22 00:12:48 +00:00
apply (rule ccorres_return_CE, simp+)[1]
2019-05-06 06:34:44 +00:00
apply (wp (once))
2019-06-22 00:12:48 +00:00
apply (clarsimp simp: guard_is_UNIV_def)
2019-10-04 02:22:39 +00:00
apply (wpsimp wp: when_def static_imp_wp)
apply (strengthen sch_act_wf_weak, wp)
2019-06-22 00:12:48 +00:00
apply clarsimp
2019-10-04 02:22:39 +00:00
apply wp
2020-03-17 08:50:19 +00:00
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
2019-10-04 02:22:39 +00:00
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)+
2019-06-22 00:12:48 +00:00
apply csymbr
2019-10-04 02:22:39 +00:00
apply (simp add: false_def Collect_False ccorres_cond_iffs
2019-06-22 00:12:48 +00:00
del: Collect_const)
2016-06-04 12:28:27 +00:00
apply (rule ccorres_pre_getCurThread)
2019-10-04 02:22:39 +00:00
apply (rename_tac curThread)
2016-06-04 12:28:27 +00:00
apply (rule ccorres_split_nothrow_novcg_dc)
2019-10-04 02:22:39 +00:00
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)
2020-03-17 08:50:19 +00:00
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
2019-10-04 02:22:39 +00:00
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)
2019-06-22 00:12:48 +00:00
apply (rule ccorres_cond_false_seq, simp)
apply (rule ccorres_pre_getCurThread)
2019-10-04 02:22:39 +00:00
apply (rename_tac curThread)
2019-06-22 00:12:48 +00:00
apply (simp add: when_def to_bool_def)
apply (rule ccorres_split_nothrow_novcg_dc)
2019-10-04 02:22:39 +00:00
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)
2019-06-22 00:12:48 +00:00
apply (ctac(no_vcg) add: rescheduleRequired_ccorres[unfolded dc_def])
2019-10-04 02:22:39 +00:00
apply (rule ccorres_return_Skip')
apply (rule ccorres_split_nothrow_novcg_dc)
2020-03-17 08:50:19 +00:00
apply(rule ccorres_cond2[where R=\<top>], simp add: Collect_const_mem)
apply(ctac add: setPriority_ccorres)
apply(rule ccorres_return_Skip)
2019-10-04 02:22:39 +00:00
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)
2020-03-17 08:50:19 +00:00
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
2019-10-04 02:22:39 +00:00
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+)
2019-06-22 00:12:48 +00:00
apply wp
apply (clarsimp simp: guard_is_UNIV_def)
2019-10-04 02:22:39 +00:00
apply wpsimp
apply (wp static_imp_wp, strengthen sch_act_wf_weak, wp )
apply wp
2020-03-17 08:50:19 +00:00
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
2019-10-04 02:22:39 +00:00
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>
2020-03-17 08:50:19 +00:00
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))"])
2019-10-04 02:22:39 +00:00
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',
2020-03-17 08:50:19 +00:00
simp add: o_def)
2019-10-04 02:22:39 +00:00
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
2020-03-17 08:50:19 +00:00
| strengthen invs_sch_act_wf' invs_valid_objs' invs_weak_sch_act_wf invs_queues
2019-10-04 02:22:39 +00:00
invs_valid_queues' | wp hoare_drop_imps)+
2020-03-17 08:50:19 +00:00
(* \<not> P *)
2019-10-04 02:22:39 +00:00
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
2020-03-17 08:50:19 +00:00
capAligned_def word_bits_conv obj_at'_def projectKOs)
2019-10-04 02:22:39 +00:00
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
2020-03-17 08:50:19 +00:00
bindE_assoc liftE_bindE
2019-10-04 02:22:39 +00:00
del: Collect_const)
apply csymbr
apply (ctac(no_vcg) add: cteDelete_ccorres)
apply (simp add: liftE_bindE Collect_False ccorres_cond_iffs
dc_def
2016-06-04 12:28:27 +00:00
del: Collect_const)
2019-10-04 02:22:39 +00:00
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
2014-07-14 19:32:44 +00:00
del: Collect_const)
apply (rule ccorres_rhs_assoc)+
apply (rule checkCapAt_ccorres2)
apply ceqv
apply csymbr
2017-11-21 23:52:59 +00:00
apply (simp add: true_def Collect_True
2019-10-04 02:22:39 +00:00
assertDerived_def bind_assoc
ccorres_cond_iffs dc_def[symmetric]
2014-07-14 19:32:44 +00:00
del: Collect_const)
2019-10-04 02:22:39 +00:00
apply (rule ccorres_symb_exec_l)
apply (ctac add: cteInsert_ccorres)
apply (wp empty_fail_stateAssert hoare_case_option_wp | simp del: Collect_const)+
2014-07-14 19:32:44 +00:00
apply csymbr
2019-10-04 02:22:39 +00:00
apply (simp add: false_def Collect_False ccorres_cond_iffs
2014-07-14 19:32:44 +00:00
del: Collect_const)
apply (rule ccorres_return_Skip[unfolded dc_def])
2020-03-17 08:50:19 +00:00
apply (fastforce simp: guard_is_UNIV_def Kernel_C.tcbVTable_def tcbVTableSlot_def
cte_level_bits_def size_of_def)
2019-10-04 02:22:39 +00:00
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)
2014-07-14 19:32:44 +00:00
apply simp
2019-10-04 02:22:39 +00:00
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
2020-03-17 08:50:19 +00:00
bindE_assoc liftE_bindE
2019-10-04 02:22:39 +00:00
del: Collect_const)
apply csymbr
apply (ctac(no_vcg) add: cteDelete_ccorres)
apply (simp add: liftE_bindE Collect_False ccorres_cond_iffs
dc_def
2016-06-04 12:28:27 +00:00
del: Collect_const)
2019-10-04 02:22:39 +00:00
apply ((rule ccorres_split_nothrow_novcg_dc[rotated], assumption)
2016-06-04 12:28:27 +00:00
| rule ccorres_rhs_assoc2)+
2019-10-04 02:22:39 +00:00
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)+
2020-03-17 08:50:19 +00:00
apply (fastforce simp: guard_is_UNIV_def
Kernel_C.tcbVTable_def tcbVTableSlot_def
cte_level_bits_def size_of_def
tcb_cnode_index_defs)
2019-10-04 02:22:39 +00:00
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)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_rhs_assoc)+
apply (rule checkCapAt_ccorres2)
apply ceqv
apply csymbr
2017-11-21 23:52:59 +00:00
apply (simp add: true_def Collect_True
2019-10-04 02:22:39 +00:00
assertDerived_def bind_assoc
ccorres_cond_iffs dc_def[symmetric]
2014-07-14 19:32:44 +00:00
del: Collect_const)
2019-10-04 02:22:39 +00:00
apply (rule ccorres_symb_exec_l)
apply (ctac add: cteInsert_ccorres)
apply (wp empty_fail_stateAssert hoare_case_option_wp | simp del: Collect_const)+
2014-07-14 19:32:44 +00:00
apply csymbr
2019-10-04 02:22:39 +00:00
apply (simp add: false_def Collect_False ccorres_cond_iffs
2014-07-14 19:32:44 +00:00
del: Collect_const)
apply (rule ccorres_return_Skip[unfolded dc_def])
2019-10-04 02:22:39 +00:00
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)
2014-07-14 19:32:44 +00:00
apply simp
2019-10-04 02:22:39 +00:00
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
2016-08-02 01:04:23 +00:00
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)+
2019-10-04 02:22:39 +00:00
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)
2015-05-16 09:52:49 +00:00
apply (simp add: conj_comms)
2014-08-09 05:16:17 +00:00
apply (wp hoare_case_option_wp threadSet_invs_trivial
2014-07-14 19:32:44 +00:00
threadSet_cap_to' static_imp_wp | simp)+
apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
apply (clarsimp simp: inQ_def)
2018-09-17 06:17:28 +00:00
apply (subst is_aligned_neg_mask_eq)
2014-07-14 19:32:44 +00:00
apply (simp add: tcb_ptr_to_ctcb_ptr_def)
apply (rule aligned_add_aligned)
2017-10-05 02:47:10 +00:00
apply (fastforce simp add: obj_at'_def projectKOs objBits_simps')
apply (simp add: ctcb_offset_defs is_aligned_def)
2016-06-04 12:28:27 +00:00
apply (simp add: word_bits_conv)
apply simp
2014-07-14 19:32:44 +00:00
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)
2017-10-05 02:47:10 +00:00
apply (clarsimp simp: valid_cap'_def capAligned_def word_bits_conv
obj_at'_def objBits_simps' projectKOs)
2014-07-14 19:32:44 +00:00
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_')
2015-11-16 03:12:37 +00:00
apply (rule ccorres_move_array_assertion_tcb_ctes ccorres_Guard_Seq)+
2014-07-14 19:32:44 +00:00
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)"
2018-06-09 08:30:53 +00:00
and R="cte_wp_at' ((=) oldCTE) rv"
2015-12-08 06:29:42 +00:00
and xf'=ret__unsigned_'
2014-07-14 19:32:44 +00:00
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
2016-09-21 00:33:03 +00:00
cpspace_relation_def Let_def
typ_heap_simps')
2014-07-14 19:32:44 +00:00
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)
2020-03-17 08:50:19 +00:00
apply (clarsimp simp: ccte_relation_def cap_reply_cap_lift cte_lift_def
cong: option.case_cong_weak)
2014-07-14 19:32:44 +00:00
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)
2018-09-17 06:17:28 +00:00
apply (subst is_aligned_neg_mask_weaken)
2014-07-14 19:32:44 +00:00
apply (erule is_aligned_tcb_ptr_to_ctcb_ptr)
2017-10-05 02:47:10 +00:00
apply (simp add: ctcb_size_bits_def)
2014-07-14 19:32:44 +00:00
apply (simp add: true_def mask_def to_bool_def)
apply simp
2017-07-12 05:13:51 +00:00
apply (simp add: cmachine_state_relation_def
2016-09-21 00:33:03 +00:00
typ_heap_simps'
2015-11-16 03:12:37 +00:00
carch_state_relation_def carch_globals_def
cvariable_array_map_const_add_map_option[where f="tcb_no_ctes_proj"])
2014-07-14 19:32:44 +00:00
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
2015-11-16 03:12:37 +00:00
tcb_cnode_index_defs tcbReplySlot_def)
2014-07-14 19:32:44 +00:00
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_')
2020-05-05 03:19:03 +00:00
apply (ctac(no_vcg) add: isStopped_ccorres)
2014-07-14 19:32:44 +00:00
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)+
2015-11-02 00:00:32 +00:00
apply (ctac(no_vcg) add: cancelIPC_ccorres1[OF cteDeleteOne_ccorres])
2014-07-14 19:32:44 +00:00
apply (ctac(no_vcg) add: setupReplyMaster_ccorres)
apply (ctac(no_vcg))
apply (ctac(no_vcg) add: tcbSchedEnqueue_ccorres)
2017-11-24 11:30:55 +00:00
apply (ctac add: possibleSwitchTo_ccorres)
2014-07-14 19:32:44 +00:00
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
2019-05-06 06:34:44 +00:00
apply (wp (once) sch_act_wf_lift, (wp tcb_in_cur_domain'_lift)+)
2014-07-14 19:32:44 +00:00
apply (rule hoare_strengthen_post)
apply (rule hoare_vcg_conj_lift)
2015-11-02 00:00:32 +00:00
apply (rule delete_one_conc_fr.cancelIPC_invs)
2015-09-02 05:43:39 +00:00
2015-11-02 00:00:32 +00:00
apply (rule cancelIPC_tcb_at'[where t=thread])
2014-07-14 19:32:44 +00:00
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>
2017-09-14 07:27:19 +00:00
\<inter> {s. v_' s = val}) []
2014-07-14 19:32:44 +00:00
(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
2016-05-04 05:07:51 +00:00
(*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
2014-07-14 19:32:44 +00:00
lemma frame_gp_registers_convs:
2016-05-01 03:35:49 +00:00
"length ARM_H.frameRegisters = unat n_frameRegisters"
"length ARM_H.gpRegisters = unat n_gpRegisters"
"n < length ARM_H.frameRegisters \<Longrightarrow>
2016-05-04 05:07:51 +00:00
index frameRegistersC n = register_from_H (ARM_H.frameRegisters ! n)"
2016-05-01 03:35:49 +00:00
"n < length ARM_H.gpRegisters \<Longrightarrow>
2016-05-04 05:07:51 +00:00
index gpRegistersC n = register_from_H (ARM_H.gpRegisters ! n)"
2016-05-01 03:35:49 +00:00
apply (simp_all add: ARM_H.gpRegisters_def ARM_H.frameRegisters_def
2016-05-05 22:59:33 +00:00
ARM.gpRegisters_def n_gpRegisters_def
ARM.frameRegisters_def n_frameRegisters_def
2016-05-04 05:07:51 +00:00
frameRegistersC_def gpRegistersC_def msgRegisters_unfold
2014-07-14 19:32:44 +00:00
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
2017-11-29 00:24:17 +00:00
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
2014-07-14 19:32:44 +00:00
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)"
2021-09-22 00:21:01 +00:00
including no_take_bit
2014-07-14 19:32:44 +00:00
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)
2017-01-13 12:58:40 +00:00
apply wp+
2014-07-14 19:32:44 +00:00
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)
2017-11-29 00:24:17 +00:00
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
2016-06-04 12:28:27 +00:00
apply (rule_tac Q="\<lambda>rv. invs' and tcb_at' destn" in hoare_strengthen_post[rotated])
apply (fastforce simp: sch_act_wf_weak)
2017-11-29 00:24:17 +00:00
apply (wpsimp wp: hoare_drop_imp)+
2016-06-04 12:28:27 +00:00
apply (clarsimp simp add: guard_is_UNIV_def)
apply (clarsimp simp: to_bool_def invs_weak_sch_act_wf invs_valid_objs'
2017-11-29 00:24:17 +00:00
split: if_split
cong: if_cong
| rule conjI)+
apply (clarsimp dest!: global'_no_ex_cap simp: invs'_def valid_state'_def | rule conjI)+
2014-07-14 19:32:44 +00:00
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
2015-09-02 05:43:39 +00:00
\<and> of_nat n < bnd \<and> of_nat n < bnd2 \<rbrakk> \<Longrightarrow>
2017-02-06 07:33:39 +00:00
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
2014-07-14 19:32:44 +00:00
(asUser dst (setRegister reg
2017-02-06 07:33:39 +00:00
(sanitiseRegister tcb reg (args ! incn))))
2014-07-14 19:32:44 +00:00
(\<acute>ret__unsigned_long :== CALL getSyscallArg(f (\<acute>i),option_to_ptr buffer);;
2015-09-02 05:43:39 +00:00
Guard ArrayBounds \<lbrace>\<acute>i < bnd\<rbrace>
2017-05-02 01:12:26 +00:00
(\<acute>unsigned_long_eret_2 :== CALL sanitiseRegister(g (\<acute>i),\<acute>ret__unsigned_long,from_bool t));;
2015-09-02 05:43:39 +00:00
Guard ArrayBounds \<lbrace>\<acute>i < bnd2\<rbrace>
2014-07-14 19:32:44 +00:00
(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)
2017-01-27 03:38:22 +00:00
apply (rule ccorres_rhs_assoc)+
2014-07-14 19:32:44 +00:00
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)
2017-03-02 05:42:15 +00:00
apply (fastforce)
2014-07-14 19:32:44 +00:00
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>
2017-07-12 05:13:51 +00:00
\<Longrightarrow> (if t = t' then tcbContext_update (\<lambda>_. st) x else x,
2014-07-14 19:32:44 +00:00
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>))"
2016-10-25 06:01:30 +00:00
apply (simp split: if_split)
2014-07-14 19:32:44 +00:00
apply (rule conjI)
apply clarsimp
2017-07-12 05:13:51 +00:00
apply (clarsimp simp: getObject_def split_def loadObject_default_def in_monad
2017-10-05 02:47:10 +00:00
Corres_C.in_magnitude_check' projectKOs objBits_simps')
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (clarsimp split: if_split_asm)
2014-09-10 07:26:44 +00:00
apply (erule_tac x=x2 in allE)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: ps_clear_def)
2014-09-10 07:26:44 +00:00
apply (drule_tac x=x2 in orthD2)
2014-07-14 19:32:44 +00:00
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
2017-07-12 05:13:51 +00:00
apply (clarsimp simp: getObject_def split_def loadObject_default_def in_monad
2017-10-05 02:47:10 +00:00
Corres_C.in_magnitude_check' projectKOs objBits_simps')
2014-07-14 19:32:44 +00:00
apply (simp add: magnitudeCheck_def in_monad split: option.splits)
apply clarsimp
apply (simp add: lookupAround2_char2)
2016-10-25 06:01:30 +00:00
apply (clarsimp split: if_split_asm)
2014-07-14 19:32:44 +00:00
apply (erule_tac x=t in allE)
apply simp
2017-07-12 05:13:51 +00:00
apply (clarsimp simp: obj_at'_real_def projectKOs
2014-07-14 19:32:44 +00:00
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)
2017-07-12 05:13:51 +00:00
apply simp
2014-09-10 07:26:44 +00:00
apply (erule_tac x=x2 in allE)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: ps_clear_def)
2014-09-10 07:26:44 +00:00
apply (drule_tac x=x2 in orthD2)
2014-07-14 19:32:44 +00:00
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:
2016-11-10 04:44:36 +00:00
"\<lbrakk> (uc, s') \<in> fst (threadGet (atcbContextGet o tcbArch) (ksCurThread s) s); ko_at' ko t s;
2014-07-14 19:32:44 +00:00
t \<noteq> ksCurThread s \<rbrakk> \<Longrightarrow>
2016-11-10 04:44:36 +00:00
(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>))"
2017-07-12 05:13:51 +00:00
apply (clarsimp simp: threadGet_def liftM_def in_monad)
apply (drule (1) getObject_context [where st=st])
2014-07-14 19:32:44 +00:00
apply (rule exI)
apply (erule conjI)
2017-07-12 05:13:51 +00:00
apply (simp split: if_splits)
2014-07-14 19:32:44 +00:00
done
lemma asUser_context:
2018-06-09 08:30:53 +00:00
"\<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> ;
2014-07-14 19:32:44 +00:00
t \<noteq> ksCurThread s\<rbrakk> \<Longrightarrow>
2016-11-10 04:44:36 +00:00
(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>))"
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: asUser_def in_monad select_f_def)
2018-06-09 08:30:53 +00:00
apply (frule use_valid, rule threadGet_inv [where P="(=) s"], rule refl)
2014-07-14 19:32:44 +00:00
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)
2018-06-09 08:30:53 +00:00
apply (frule use_valid, rule getObject_inv [where P="(=) s"])
2014-07-14 19:32:44 +00:00
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
2017-10-05 02:47:10 +00:00
objBits_simps' projectKOs in_monad)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: magnitudeCheck_def in_monad split: option.splits)
apply (rule conjI)
apply clarsimp
apply (cases s, simp)
2016-10-25 06:01:30 +00:00
apply (rule ext, clarsimp split: if_split)
2014-07-14 19:32:44 +00:00
apply (case_tac tcb, simp)
apply clarsimp
apply (rule conjI)
2016-10-25 06:01:30 +00:00
apply (clarsimp simp add: lookupAround2_char2 split: if_split_asm)
2014-07-14 19:32:44 +00:00
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
2014-09-10 07:26:44 +00:00
apply (erule_tac x=x2 in allE)
2014-07-14 19:32:44 +00:00
apply simp
apply (simp add: ps_clear_def)
2014-09-10 07:26:44 +00:00
apply (drule_tac x=x2 in orthD2)
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (rule ext, clarsimp split: if_split)
2014-07-14 19:32:44 +00:00
apply (case_tac tcb, clarsimp)
done
lemma getMRs_rel_context:
2017-07-12 05:13:51 +00:00
"\<lbrakk>getMRs_rel args buffer s;
2014-08-09 05:16:17 +00:00
(cur_tcb' and case_option \<top> valid_ipc_buffer_ptr' buffer) s;
2014-07-14 19:32:44 +00:00
ko_at' ko t s ; t \<noteq> ksCurThread s\<rbrakk> \<Longrightarrow>
2016-11-10 04:44:36 +00:00
getMRs_rel args buffer (s\<lparr>ksPSpace := ksPSpace s(t \<mapsto> KOTCB (tcbArch_update (\<lambda>_. atcbContextSet st (tcbArch ko)) ko))\<rparr>)"
2014-07-14 19:32:44 +00:00
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)
2017-07-12 05:13:51 +00:00
apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs
2016-10-25 06:01:30 +00:00
objBits_simps ps_clear_def split: if_split)
2014-07-14 19:32:44 +00:00
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
2016-10-25 06:01:30 +00:00
objBits_simps ps_clear_def split: if_split)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: getMRs_def in_monad)
2018-06-09 08:30:53 +00:00
apply (frule use_valid, rule asUser_inv [where P="(=) s"])
2014-07-14 19:32:44 +00:00
apply (wp mapM_wp' getRegister_inv)[1]
apply simp
apply clarsimp
apply (drule (1) asUser_context)
2017-07-12 05:13:51 +00:00
apply (wp mapM_wp' getRegister_inv)[1]
2014-07-14 19:32:44 +00:00
apply assumption
apply (intro exI)
apply (erule conjI)
apply (cases buffer)
apply (clarsimp simp: return_def)
2017-07-12 05:13:51 +00:00
apply clarsimp
apply (drule mapM_upd_inv [rotated -1])
2014-07-14 19:32:44 +00:00
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)
2017-07-12 05:13:51 +00:00
apply (clarsimp simp: pointerInUserData_def typ_at'_def ko_wp_at'_def
2014-07-14 19:32:44 +00:00
projectKOs ps_clear_def obj_at'_real_def
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
apply (erule doMachineOp_context)
done
lemma asUser_getMRs_rel:
2017-07-12 05:13:51 +00:00
"\<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>
2014-07-14 19:32:44 +00:00
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)
2017-01-13 12:58:40 +00:00
apply (wp threadGet_wp)+
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (clarsimp split: if_split simp del: fun_upd_apply)
2014-07-14 19:32:44 +00:00
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:
2017-07-12 05:13:51 +00:00
"\<lbrace>\<lambda>s. t \<noteq> ksCurThread s \<and> sysargs_rel args buffer s\<rbrace>
2014-07-14 19:32:44 +00:00
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
2017-02-06 07:33:39 +00:00
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
2014-07-14 19:32:44 +00:00
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)"
2021-09-22 00:21:01 +00:00
including no_take_bit
2014-07-14 19:32:44 +00:00
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? *)
2017-05-02 01:12:26 +00:00
apply (csymbr, csymbr, csymbr, csymbr)
2014-07-14 19:32:44 +00:00
apply (simp add: liftE_def bind_assoc
del: Collect_const)
apply (rule ccorres_pre_getCurThread)
2015-05-17 23:11:43 +00:00
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)
2014-07-14 19:32:44 +00:00
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)
2017-02-06 07:33:39 +00:00
apply (simp add: linorder_not_less[symmetric] n_gpRegisters_def n_frameRegisters_def)
2014-07-14 19:32:44 +00:00
apply ceqv
2017-05-02 01:12:26 +00:00
apply (ctac add: Arch_getSanitiseRegisterInfo_ccorres)
2017-02-06 07:33:39 +00:00
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)
2017-01-27 03:38:22 +00:00
and tcb_at' dst and (\<lambda>s. dst \<noteq> ksCurThread s)"
2017-02-06 07:33:39 +00:00
and Q=UNIV in ccorres_mapM_x_whileQ)
2014-07-14 19:32:44 +00:00
apply clarsimp
2017-03-02 05:42:15 +00:00
apply (rule invokeTCB_WriteRegisters_ccorres_helper [where args=args])
2017-02-06 07:33:39 +00:00
apply (simp add: unat_word_ariths frame_gp_registers_convs n_frameRegisters_def
unat_of_nat32 word_bits_def word_of_nat_less)
2014-07-14 19:32:44 +00:00
apply (simp add: n_frameRegisters_def n_gpRegisters_def
2017-02-06 07:33:39 +00:00
frame_gp_registers_convs word_less_nat_alt)
apply (simp add: unat_of_nat32 word_bits_def)
apply arith
2016-09-21 00:33:03 +00:00
apply clarsimp
2014-07-14 19:32:44 +00:00
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)
2017-02-06 07:33:39 +00:00
apply (clarsimp simp: n_msgRegisters_def sysargs_rel_def)
apply (simp add: frame_gp_registers_convs n_frameRegisters_def word_bits_def)
2014-07-14 19:32:44 +00:00
apply simp
2017-02-06 07:33:39 +00:00
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
2016-06-04 12:28:27 +00:00
word_bits_def n_frameRegisters_def word_of_nat_less)
2017-02-06 07:33:39 +00:00
apply (simp add: n_frameRegisters_def n_gpRegisters_def
frame_gp_registers_convs unat_of_nat32
2016-06-04 12:28:27 +00:00
word_less_nat_alt word_bits_def less_diff_conv)
2017-02-06 07:33:39 +00:00
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
2017-05-02 01:12:26 +00:00
apply (ctac(no_vcg) add: setNextPC_ccorres)
2017-11-29 00:24:17 +00:00
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)
2017-02-06 07:33:39 +00:00
apply (rule restart_ccorres)
apply simp
2017-11-29 00:24:17 +00:00
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"
2016-06-04 12:28:27 +00:00
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)+
2017-05-02 01:12:26 +00:00
apply simp
2016-06-04 12:28:27 +00:00
apply (rule mapM_x_wp')
apply (wpsimp)
2017-05-02 01:12:26 +00:00
apply (simp add: guard_is_UNIV_def)
apply (rule hoare_drop_imps)
apply (simp add: sysargs_rel_n_def)
2016-06-04 12:28:27 +00:00
apply (rule mapM_x_wp')
apply (rule hoare_pre, wp asUser_sysargs_rel)
apply clarsimp
2017-05-02 01:12:26 +00:00
apply (simp add: guard_is_UNIV_def)
apply (wp)
apply vcg
apply (wp threadGet_wp)
2014-07-14 19:32:44 +00:00
apply vcg
apply (rule ccorres_inst[where P=\<top> and P'=UNIV])
apply simp
apply (simp add: performTransfer_def)
apply wp
2017-05-02 01:12:26 +00:00
apply clarsimp
2014-07-14 19:32:44 +00:00
apply vcg
2016-10-25 06:01:30 +00:00
apply (clarsimp simp: n_msgRegisters_def sysargs_rel_n_def split: if_split)
2014-07-14 19:32:44 +00:00
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
2016-06-04 12:28:27 +00:00
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)
2015-09-02 05:43:39 +00:00
done
2014-07-14 19:32:44 +00:00
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:
2016-05-01 03:35:49 +00:00
"length ARM_H.msgRegisters = unat n_msgRegisters"
"n < length ARM_H.msgRegisters \<Longrightarrow>
2016-05-04 05:07:51 +00:00
index msgRegistersC n = register_from_H (ARM_H.msgRegisters ! n)"
2014-07-14 19:32:44 +00:00
apply (simp_all add: msgRegisters_unfold
2016-05-05 22:59:33 +00:00
ARM.msgRegisters_def n_msgRegisters_def
2016-05-04 05:07:51 +00:00
msgRegistersC_def fupdate_def Arrays.update_def)
2014-07-14 19:32:44 +00:00
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)
2015-10-12 13:11:13 +00:00
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
2016-07-04 07:35:42 +00:00
2014-07-14 19:32:44 +00:00
lemma lookupIPCBuffer_Some_0:
"\<lbrace>\<top>\<rbrace> lookupIPCBuffer w t \<lbrace>\<lambda>rv s. rv \<noteq> Some 0\<rbrace>"
apply (simp add: lookupIPCBuffer_def
2016-05-01 03:35:49 +00:00
ARM_H.lookupIPCBuffer_def
2014-07-14 19:32:44 +00:00
Let_def getThreadBufferSlot_def
locateSlot_conv
cong: if_cong)
2016-07-04 07:35:42 +00:00
apply (wp haskell_assert_wp | wpc | simp)+
2014-07-14 19:32:44 +00:00
done
2015-10-12 13:11:13 +00:00
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)
2014-07-14 19:32:44 +00:00
lemma invokeTCB_ReadRegisters_ccorres:
notes
2016-04-30 06:31:11 +00:00
nat_min_simps [simp del]
2015-09-30 18:05:05 +00:00
wordSize_def' [simp]
2014-07-14 19:32:44 +00:00
shows
"ccorres ((intr_and_se_rel \<circ> Inr) \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
2018-06-09 08:30:53 +00:00
(invs' and (\<lambda>s. ksCurThread s = thread) and ct_in_state' ((=) Restart)
2014-07-14 19:32:44 +00:00
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)"
2021-09-22 00:21:01 +00:00
including no_take_bit
2020-03-17 08:50:19 +00:00
supply option.case_cong_weak[cong]
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (simp add: when_def del: Collect_const split del: if_split)
2014-07-14 19:32:44 +00:00
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
2015-05-17 23:11:43 +00:00
zipWithM_x_mapM_x asUser_mapM_x split_def
2014-07-14 19:32:44 +00:00
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)
2016-11-10 04:44:36 +00:00
apply (rule_tac F="\<lambda>m s. obj_at' (\<lambda>tcb. map ((atcbContextGet o tcbArch) tcb) (genericTake n
2016-05-01 03:35:49 +00:00
(ARM_H.frameRegisters @ ARM_H.gpRegisters))
2014-07-14 19:32:44 +00:00
= 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
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (simp add: min_def word_less_nat_alt split: if_split)[1]
2014-07-14 19:32:44 +00:00
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,
2016-11-10 04:44:36 +00:00
rule_tac F="\<lambda>m s. obj_at' (\<lambda>tcb. map ((atcbContextGet o tcbArch) tcb) (genericTake n
2016-05-01 03:35:49 +00:00
(ARM_H.frameRegisters @ ARM_H.gpRegisters))
2014-07-14 19:32:44 +00:00
= reply) target s
2015-10-12 13:11:13 +00:00
\<and> valid_ipc_buffer_ptr' (the rva) s
\<and> valid_pspace' s"
2014-07-14 19:32:44 +00:00
and i="unat n_msgRegisters"
in ccorres_mapM_x_while')
2015-10-12 13:11:13 +00:00
apply (intro allI impI, elim conjE exE, hypsubst, simp)
apply (simp add: less_diff_conv)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_guard_imp2)
apply (rule ccorres_add_return,
ctac add: getRegister_ccorres_defer[where thread=target])
2015-11-16 03:12:37 +00:00
apply (rule ccorres_move_array_assertion_ipc_buffer
| (rule ccorres_flip_Guard,
rule ccorres_move_array_assertion_ipc_buffer))+
apply (rule storeWordUser_ccorres)
2014-07-14 19:32:44 +00:00
apply wp
apply (vcg exspec=getRegister_modifies)
apply (clarsimp simp: obj_at'_weakenE[OF _ TrueI]
2015-11-16 03:12:37 +00:00
word_size unat_gt_0 option_to_ptr_def
option_to_0_def)
2014-07-14 19:32:44 +00:00
apply (intro conjI[rotated] impI allI)
2015-11-16 03:12:37 +00:00
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
2015-09-30 18:05:05 +00:00
msg_registers_convs upto_enum_word wordSize_def'
2015-11-16 03:12:37 +00:00
del: upt.simps)
2014-07-14 19:32:44 +00:00
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)
2015-11-16 03:12:37 +00:00
apply (clarsimp simp: valid_ipc_buffer_ptr'_def)
apply (erule aligned_add_aligned)
apply (rule is_aligned_mult_triv2[where n=2, simplified])
2018-07-25 07:48:42 +00:00
apply (simp add: msg_align_bits)
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (simp add: min_def word_less_nat_alt split: if_split)[1]
apply (simp split: if_split_asm, arith+)[1]
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (simp add: min_def split: if_split_asm if_split)
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (simp add: min_def split: if_split option.split)
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (simp add: min_def split: if_split option.split)
2014-07-14 19:32:44 +00:00
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)
2016-11-10 04:44:36 +00:00
apply (rule_tac F="\<lambda>m s. obj_at' (\<lambda>tcb. map ((atcbContextGet o tcbArch) tcb) (genericTake n
2016-05-01 03:35:49 +00:00
(ARM_H.frameRegisters @ ARM_H.gpRegisters))
2014-07-14 19:32:44 +00:00
= reply) target s
2015-10-12 13:11:13 +00:00
\<and> valid_ipc_buffer_ptr' (the rva) s \<and> valid_pspace' s"
2014-07-14 19:32:44 +00:00
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])
2015-11-16 03:12:37 +00:00
apply (rule ccorres_move_array_assertion_ipc_buffer
| (rule ccorres_flip_Guard,
rule ccorres_move_array_assertion_ipc_buffer))+
apply (rule storeWordUser_ccorres)
2014-07-14 19:32:44 +00:00
apply wp
apply (vcg exspec=getRegister_modifies)
apply (clarsimp simp: obj_at'_weakenE[OF _ TrueI]
2015-11-16 03:12:37 +00:00
word_size unat_gt_0 option_to_ptr_def
option_to_0_def)
2014-07-14 19:32:44 +00:00
apply (intro conjI[rotated] impI allI)
2015-11-16 03:12:37 +00:00
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)
2014-07-14 19:32:44 +00:00
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)
2015-11-16 03:12:37 +00:00
apply (clarsimp simp: valid_ipc_buffer_ptr'_def,
erule aligned_add_aligned)
apply (rule is_aligned_mult_triv2[where n=2, simplified])
2018-07-25 07:48:42 +00:00
apply (simp add: msg_align_bits)
2014-07-14 19:32:44 +00:00
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
2016-10-25 06:01:30 +00:00
cong: if_cong split: if_split)
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: frame_gp_registers_convs n_gpRegisters_def
2014-09-10 07:26:44 +00:00
min.absorb1 unat_of_nat)
2014-07-14 19:32:44 +00:00
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
2016-10-25 06:01:30 +00:00
cong: if_cong split: if_split)
2014-07-14 19:32:44 +00:00
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
2016-10-25 06:01:30 +00:00
split: if_split if_split_asm, arith+)[1]
2014-07-14 19:32:44 +00:00
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
2014-09-10 07:26:44 +00:00
min.absorb1 n_msgRegisters_def)
2014-07-14 19:32:44 +00:00
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)
2017-07-12 05:13:51 +00:00
apply (clarsimp simp: n_frameRegisters_def n_msgRegisters_def
2014-07-14 19:32:44 +00:00
n_gpRegisters_def field_simps upto_enum_word
word_less_nat_alt Types_H.msgMaxLength_def
2017-07-12 05:13:51 +00:00
Types_H.msgLengthBits_def
2014-07-14 19:32:44 +00:00
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
2016-10-25 06:01:30 +00:00
split: if_split_asm dest!: word_unat.Rep_inverse')
2014-07-14 19:32:44 +00:00
apply (clarsimp simp: length_msgRegisters n_msgRegisters_def)
apply (clarsimp simp: min_def iffD2 [OF mask_eq_iff_w2p] word_size
2017-07-12 05:13:51 +00:00
word_less_nat_alt
2016-10-25 06:01:30 +00:00
split: if_split_asm dest!: word_unat.Rep_inverse')
2014-07-14 19:32:44 +00:00
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)
2015-10-12 13:11:13 +00:00
apply (wp asUser_obj_at'[where t'=target] static_imp_wp
asUser_valid_ipc_buffer_ptr')
2014-07-14 19:32:44 +00:00
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)
2019-05-06 06:34:44 +00:00
apply (wp (once) hoare_drop_imps)
2015-10-12 13:11:13 +00:00
apply (wp asUser_obj_at'[where t'=target] static_imp_wp
asUser_valid_ipc_buffer_ptr')
2014-07-14 19:32:44 +00:00
apply (vcg exspec=setRegister_modifies)
apply simp
2015-10-12 13:11:13 +00:00
apply (strengthen valid_ipc_buffer_ptr_the_strengthen)
2014-07-14 19:32:44 +00:00
apply simp
2019-05-06 06:34:44 +00:00
apply (wp lookupIPCBuffer_Some_0 | wp (once) hoare_drop_imps)+
2016-05-01 03:35:49 +00:00
apply (simp add: Collect_const_mem ARM_H.badgeRegister_def
2016-05-05 22:59:33 +00:00
ARM.badgeRegister_def
2014-07-14 19:32:44 +00:00
"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)
2017-01-13 12:58:40 +00:00
apply wp+
2014-07-14 19:32:44 +00:00
apply (simp cong: rev_conj_cong)
apply wp
2016-11-10 04:44:36 +00:00
apply (wp asUser_inv mapM_wp' getRegister_inv
2017-01-13 12:58:40 +00:00
asUser_get_registers[simplified] static_imp_wp)+
2014-07-14 19:32:44 +00:00
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
2018-06-09 08:30:53 +00:00
apply (rule_tac Q="\<lambda>rv. invs' and st_tcb_at' ((=) Restart) thread
2014-07-14 19:32:44 +00:00
and tcb_at' target" in hoare_post_imp)
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: pred_tcb_at')
apply (auto elim!: pred_tcb'_weakenE)[1]
2014-07-14 19:32:44 +00:00
apply (wp suspend_st_tcb_at')
apply (vcg exspec=suspend_modifies)
apply vcg
apply (rule conseqPre, vcg, clarsimp)
2016-07-04 07:35:42 +00:00
apply (clarsimp simp: rf_sr_ksCurThread ct_in_state'_def true_def
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
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)}
2016-01-08 07:43:33 +00:00
\<inter> {s. unat (length___unsigned_long_' s) = length args}
2014-07-14 19:32:44 +00:00
\<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)"
2016-01-08 07:43:33 +00:00
apply (cinit' lift: cap_' length___unsigned_long_' call_' buffer_')
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (simp split: if_split)
2014-07-14 19:32:44 +00:00
apply (rule conjI[rotated], rule impI, rule is_nondet_refinement_refl)
apply (rule impI)
2017-07-12 05:13:51 +00:00
apply (rule is_nondet_refinement_alternative1)
2014-07-14 19:32:44 +00:00
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
2015-09-02 05:43:39 +00:00
elim!: pred_tcb'_weakenE
2014-07-14 19:32:44 +00:00
dest!: st_tcb_at_idle_thread')[1]
2016-10-25 06:01:30 +00:00
apply (clarsimp simp: from_bool_def word_and_1 split: if_split)
2014-07-14 19:32:44 +00:00
done
lemma decodeWriteRegisters_ccorres:
"ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
2017-07-12 05:13:51 +00:00
(invs' and sch_act_simple
2014-07-14 19:32:44 +00:00
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)}
2016-01-08 07:43:33 +00:00
\<inter> {s. unat (length___unsigned_long_' s) = length args}
2014-07-14 19:32:44 +00:00
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
(decodeWriteRegisters args cp
>>= invocationCatch thread isBlocking isCall InvokeTCB)
(Call decodeWriteRegisters_'proc)"
2017-07-12 05:13:51 +00:00
apply (cinit' lift: cap_' length___unsigned_long_' buffer_' simp: decodeWriteRegisters_def)
2014-07-14 19:32:44 +00:00
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)
2015-05-17 23:11:43 +00:00
apply (rule_tac P="\<lambda>a. ccorres rvr xf P P' hs a c" for rvr xf P P' hs c in ssubst,
2014-07-14 19:32:44 +00:00
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)
2017-07-12 05:13:51 +00:00
apply (rule ccorres_cond_seq)
2014-07-14 19:32:44 +00:00
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)
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: Collect_const_mem ct_in_state'_def pred_tcb_at')
2014-07-14 19:32:44 +00:00
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
2021-09-22 00:21:01 +00:00
numeral_eqs
simp del: unsigned_numeral)
2014-07-14 19:32:44 +00:00
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
2017-07-12 05:13:51 +00:00
elim!: pred_tcb'_weakenE dest!: st_tcb_at_idle_thread')[1]
2014-07-14 19:32:44 +00:00
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
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
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_')
2017-07-12 05:13:51 +00:00
(invs' and sch_act_simple
2014-07-14 19:32:44 +00:00
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)}
2016-01-08 07:43:33 +00:00
\<inter> {s. unat (length___unsigned_long_' s) = length args}
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
2014-07-14 19:32:44 +00:00
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
(decodeCopyRegisters args cp (map fst extraCaps)
>>= invocationCatch thread isBlocking isCall InvokeTCB)
(Call decodeCopyRegisters_'proc)"
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
apply (cinit' lift: cap_' length___unsigned_long_' current_extra_caps_' buffer_' simp: decodeCopyRegisters_def)
2014-07-14 19:32:44 +00:00
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)
2015-05-17 23:11:43 +00:00
apply (rule_tac P="Q' (capTCBPtr rva) rva" for Q'
2014-07-14 19:32:44 +00:00
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)
2014-08-11 08:51:04 +00:00
apply (simp add: case_bool_If if_to_top_of_bindE
2014-07-14 19:32:44 +00:00
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
2017-07-12 05:13:51 +00:00
del: Collect_const)
2014-07-14 19:32:44 +00:00
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
2015-09-02 05:43:39 +00:00
ct_in_state'_def pred_tcb_at')
2014-07-14 19:32:44 +00:00
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
2015-09-02 05:43:39 +00:00
elim!: pred_tcb'_weakenE
2014-07-14 19:32:44 +00:00
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
2016-10-25 06:01:30 +00:00
split: if_split)
2014-07-14 19:32:44 +00:00
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
2016-10-25 06:01:30 +00:00
word_and_1_shiftl [where n=3,simplified] cap_get_tag_isCap[symmetric] split: if_split_asm)
2014-07-14 19:32:44 +00:00
done
2016-07-04 07:35:42 +00:00
lemma isDevice_PageCap_ccap_relation:
2016-09-22 02:05:17 +00:00
"ccap_relation (capability.ArchObjectCap (arch_capability.PageCap d ref rghts sz data)) cap
2016-07-04 07:35:42 +00:00
\<Longrightarrow> (generic_frame_cap_get_capFIsDevice_CL (cap_lift cap) \<noteq> 0) = d"
2017-07-12 05:13:51 +00:00
by (clarsimp elim!: ccap_relationE
2016-09-22 02:05:17 +00:00
simp: isPageCap_def generic_frame_cap_get_capFIsDevice_CL_def cap_to_H_def
Let_def to_bool_def
2016-10-25 06:01:30 +00:00
split: arch_capability.split_asm cap_CL.split_asm if_split_asm)
2016-07-04 07:35:42 +00:00
2014-07-14 19:32:44 +00:00
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)"
2016-09-22 09:12:33 +00:00
apply (simp add:checkValidIPCBuffer_def ARM_H.checkValidIPCBuffer_def)
2016-07-04 07:35:42 +00:00
apply (cases "isArchPageCap cp \<and> \<not> isDeviceCap cp")
apply (simp only: isCap_simps isDeviceCap.simps, safe)[1]
2014-07-14 19:32:44 +00:00
apply (cinit lift: vptr_' cap_')
2016-09-22 09:12:33 +00:00
apply (simp add: ARM_H.checkValidIPCBuffer_def if_1_0_0 del: Collect_const)
2016-07-04 07:35:42 +00:00
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)
2014-07-14 19:32:44 +00:00
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
2016-07-04 07:35:42 +00:00
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]
2016-09-22 02:05:17 +00:00
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)
2016-07-04 07:35:42 +00:00
apply vcg
2016-09-22 02:05:17 +00:00
apply (clarsimp simp: cap_get_tag_isCap isCap_simps pageSize_def
isDevice_PageCap_ccap_relation Collect_const_mem)
2016-07-04 07:35:42 +00:00
apply (rule conseqPre, vcg)
2016-09-22 02:05:17 +00:00
apply (clarsimp simp: cap_get_tag_isCap isCap_simps pageSize_def
isDevice_PageCap_ccap_relation Collect_const_mem if_1_0_0
2016-07-04 07:35:42 +00:00
word_sle_def)
2016-09-22 02:05:17 +00:00
apply (clarsimp simp: cap_get_tag_isCap isCap_simps pageSize_def
isDevice_PageCap_ccap_relation Collect_const_mem)
2016-07-04 07:35:42 +00:00
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_')
2016-09-22 09:12:33 +00:00
apply (simp add: ARM_H.checkValidIPCBuffer_def if_1_0_0 del: Collect_const)
2016-07-04 07:35:42 +00:00
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
2014-07-14 19:32:44 +00:00
apply (rule conseqPre, vcg)
apply (clarsimp simp: throwError_def return_def exception_defs
2016-09-22 02:05:17 +00:00
syscall_error_rel_def syscall_error_to_H_cases)
2016-07-04 07:35:42 +00:00
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
2016-09-22 02:05:17 +00:00
exception_defs throwError_def return_def if_1_0_0
2016-10-25 06:01:30 +00:00
split: capability.split arch_capability.split if_split_asm)+
2016-07-04 07:35:42 +00:00
apply (simp add: cap_get_tag_isCap isCap_simps pageSize_def Cond_if_mem)
apply (frule ccap_relation_page_is_device)
2017-07-12 05:13:51 +00:00
apply (auto simp add: isCap_simps isDeviceCap.simps pageSize_def
2016-09-22 02:05:17 +00:00
split: if_splits)[1]
2014-07-14 19:32:44 +00:00
apply (cinit lift: vptr_' cap_')
apply csymbr
2016-05-01 03:35:49 +00:00
apply (simp add: ARM_H.checkValidIPCBuffer_def
2014-07-14 19:32:44 +00:00
cap_get_tag_isCap)
apply csymbr
2016-07-04 07:35:42 +00:00
apply (rule ccorres_cond_true_seq)+
2014-07-14 19:32:44 +00:00
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)
2016-07-04 07:35:42 +00:00
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
2016-10-25 06:01:30 +00:00
split: capability.split arch_capability.split if_split_asm)
2016-07-04 07:35:42 +00:00
done
2014-07-14 19:32:44 +00:00
lemma slotCapLongRunningDelete_ccorres:
2018-06-09 08:30:53 +00:00
"ccorres ((=) \<circ> from_bool) ret__unsigned_long_' invs'
2014-07-14 19:32:44 +00:00
(UNIV \<inter> {s. slot_' s = cte_Ptr slot}) []
(slotCapLongRunningDelete slot) (Call slotCapLongRunningDelete_'proc)"
2020-06-18 17:40:22 +00:00
supply subst_all [simp del]
2014-07-14 19:32:44 +00:00
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)
2018-06-09 08:30:53 +00:00
apply (rule_tac P="cte_wp_at' ((=) rv) slot"
2014-07-14 19:32:44 +00:00
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)
2018-06-09 08:30:53 +00:00
apply (rule_tac P="cte_wp_at' ((=) rv) slot"
2014-07-14 19:32:44 +00:00
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)
2016-04-17 20:40:00 +00:00
apply (clarsimp simp: Collect_const_mem guard_is_UNIV_def)
apply (rename_tac rv')
apply (case_tac rv'; clarsimp simp: false_def true_def)
2014-07-14 19:32:44 +00:00
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)
2016-10-25 06:01:30 +00:00
apply (simp add: from_bool_def to_bool_def false_def split: if_split)
2014-07-14 19:32:44 +00:00
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
2016-05-01 03:35:49 +00:00
ARM_H.isValidVTableRoot_def)
2014-07-14 19:32:44 +00:00
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)
2016-04-18 20:25:44 +00:00
apply (clarsimp simp: ccap_relation_def map_option_Some_eq2
2014-07-14 19:32:44 +00:00
cap_page_directory_cap_lift cap_to_H_def
from_bool_def)
2016-10-25 06:01:30 +00:00
apply (clarsimp simp: to_bool_def split: if_split)
2014-07-14 19:32:44 +00:00
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
2015-11-16 03:12:37 +00:00
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
2017-10-05 02:47:10 +00:00
(cap_thread_cap_lift cap) && ~~mask tcbBlockSizeBits) s"
2015-11-16 03:12:37 +00:00
apply (clarsimp simp: cap_get_tag_isCap[symmetric]
valid_cap_simps'
dest!: cap_get_tag_to_H)
2017-10-05 02:47:10 +00:00
apply (frule ctcb_ptr_to_tcb_ptr_mask[OF tcb_aligned'], simp)
2015-11-16 03:12:37 +00:00
done
2017-07-12 05:13:51 +00:00
2016-08-02 01:04:23 +00:00
lemma checkPrio_ccorres:
2017-07-12 05:13:51 +00:00
"ccorres (syscall_error_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
2018-02-16 04:35:59 +00:00
(tcb_at' auth)
(UNIV \<inter> {s. prio_' s = prio} \<inter> {s. auth_' s = tcb_ptr_to_ctcb_ptr auth}) []
(checkPrio prio auth)
2016-08-02 01:04:23 +00:00
(Call checkPrio_'proc)"
2018-02-16 04:35:59 +00:00
apply (cinit lift: prio_' auth_')
2016-10-04 00:58:33 +00:00
apply (clarsimp simp: liftE_bindE)
2016-08-02 01:04:23 +00:00
apply (rule ccorres_split_nothrow_novcg[where r'="\<lambda>rv rv'. rv' = ucast rv" and xf'=mcp_'])
2018-02-16 04:35:59 +00:00
apply (rule threadGet_vcg_corres)
2016-08-02 01:04:23 +00:00
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp simp: rf_sr_ksCurThread obj_at'_def projectKOs
typ_heap_simps' ctcb_relation_def)
apply ceqv
2016-10-25 06:01:30 +00:00
apply (simp add: whenE_def del: Collect_const split: if_split)
2016-10-04 00:58:33 +00:00
apply (rule conjI; clarsimp)
2016-08-02 01:04:23 +00:00
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
2016-10-04 00:58:33 +00:00
apply (simp add: guard_is_UNIV_def)+
2016-08-02 01:04:23 +00:00
done
2015-11-16 03:12:37 +00:00
2016-10-04 00:58:33 +00:00
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
2021-09-22 00:21:01 +00:00
simp del: unsigned_uminus1
elim!: order.trans)
2016-10-04 00:58:33 +00:00
lemmas mcpriority_tcb_at'_prio_bounded
= mcpriority_tcb_at'_prio_bounded'[simplified priorityBits_def]
2016-11-21 07:37:54 +00:00
2014-07-14 19:32:44 +00:00
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)}
2016-01-08 07:43:33 +00:00
\<inter> {s. unat (length___unsigned_long_' s) = length args}
2014-07-14 19:32:44 +00:00
\<inter> {s. slot_' s = cte_Ptr slot}
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
2014-07-14 19:32:44 +00:00
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
(decodeTCBConfigure args cp slot extraCaps
>>= invocationCatch thread isBlocking isCall InvokeTCB)
(Call decodeTCBConfigure_'proc)"
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
apply (cinit' lift: cap_' length___unsigned_long_' slot_' current_extra_caps_' buffer_'
simp: decodeTCBConfigure_def)
2014-07-14 19:32:44 +00:00
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)
2015-05-17 23:11:43 +00:00
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,
2014-07-14 19:32:44 +00:00
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])
2018-02-16 04:35:59 +00:00
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)
2014-07-14 19:32:44 +00:00
apply csymbr
apply (rule ccorres_move_c_guard_cte)
2018-02-16 04:35:59 +00:00
apply (rule getSlotCap_ccorres_fudge_n[where vals=extraCaps and n=1])
2014-07-14 19:32:44 +00:00
apply ctac
apply (rule ccorres_assert2)
apply csymbr
2018-02-16 04:35:59 +00:00
apply (rule getSlotCap_ccorres_fudge_n[where vals=extraCaps and n=2])
2014-07-14 19:32:44 +00:00
apply (rule ccorres_move_c_guard_cte)
apply ctac
apply (rule ccorres_assert2)
2018-02-16 04:35:59 +00:00
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)
2016-08-02 01:04:23 +00:00
apply csymbr
2018-02-16 04:35:59 +00:00
apply (rule ccorres_move_array_assertion_tcb_ctes ccorres_Guard_Seq)+
apply (simp add: decodeSetSpace_def injection_bindE[OF refl] split_def
2016-08-02 01:04:23 +00:00
del: Collect_const)
2018-02-16 04:35:59 +00:00
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
2016-10-04 00:58:33 +00:00
apply ceqv
2018-02-16 04:35:59 +00:00
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)
2016-10-04 00:58:33 +00:00
apply simp
2018-02-16 04:35:59 +00:00
apply (rule ccorres_split_throws, rule ccorres_return_C_errorE, simp+)
2016-10-04 00:58:33 +00:00
apply vcg
2018-02-16 04:35:59 +00:00
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)
2019-05-06 06:34:44 +00:00
apply (wp | wp (once) hoare_drop_imps)+
2018-02-16 04:35:59 +00:00
apply (simp add: Collect_const_mem all_ex_eq_helper
cong: option.case_cong)
apply (vcg exspec=slotCapLongRunningDelete_modifies)
apply (simp cong: if_cong)
2019-05-06 06:34:44 +00:00
apply (wp | wp (once) hoare_drop_imps)+
2018-02-16 04:35:59 +00:00
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
2019-05-06 06:34:44 +00:00
apply (wp | wp (once) hoare_drop_imps)+
2018-02-16 04:35:59 +00:00
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
2014-07-14 19:32:44 +00:00
cong: option.case_cong)
2018-02-16 04:35:59 +00:00
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)
2019-05-06 06:34:44 +00:00
apply (wp | wp (once) hoare_drop_imps)+
2018-02-16 04:35:59 +00:00
apply (clarsimp simp: Collect_const_mem all_ex_eq_helper
cong: option.case_cong)
2014-07-14 19:32:44 +00:00
apply vcg
apply simp
2019-05-06 06:34:44 +00:00
apply (wp | wp (once) hoare_drop_imps)+
2018-02-16 04:35:59 +00:00
apply (simp add: Collect_const_mem all_ex_eq_helper)
2014-07-14 19:32:44 +00:00
apply vcg
2018-02-16 04:35:59 +00:00
apply simp
2019-05-06 06:34:44 +00:00
apply (wp | wp (once) hoare_drop_imps)+
2018-02-16 04:35:59 +00:00
apply (wpsimp | vcg exspec=getSyscallArg_modifies)+
apply (clarsimp simp: Collect_const_mem all_ex_eq_helper)
2014-07-14 19:32:44 +00:00
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')
2015-11-16 03:12:37 +00:00
apply (frule(2) tcb_at_capTCBPtr_CL)
2016-10-04 00:58:33 +00:00
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)
2017-10-05 02:47:10 +00:00
apply (erule disjE; simp add: objBits_defs mask_def)
2014-07-14 19:32:44 +00:00
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
2018-11-13 09:19:41 +00:00
capTCBPtr_eq
2014-07-14 19:32:44 +00:00
tcb_cnode_index_defs size_of_def
option_to_0_def rf_sr_ksCurThread
2016-10-04 00:58:33 +00:00
StrictC'_thread_state_defs mask_eq_iff_w2p word_size
2014-07-14 19:32:44 +00:00
from_bool_all_helper)
apply (frule(1) tcb_at_h_t_valid [OF tcb_at_invs'])
2016-10-04 00:58:33 +00:00
apply (clarsimp simp: typ_heap_simps numeral_eqs isCap_simps valid_cap'_def capAligned_def
2014-07-14 19:32:44 +00:00
objBits_simps)
2016-10-04 00:58:33 +00:00
done
2018-02-16 04:35:59 +00:00
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)
2016-10-04 00:58:33 +00:00
lemma decodeSetMCPriority_ccorres:
2018-02-16 04:35:59 +00:00
"\<lbrakk>interpret_excaps extraCaps' = excaps_map extraCaps\<rbrakk> \<Longrightarrow>
ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
2016-10-04 00:58:33 +00:00
(invs' and (\<lambda>s. ksCurThread s = thread)
and ct_active' and sch_act_simple
2018-02-16 04:35:59 +00:00
and (excaps_in_mem extraCaps \<circ> ctes_of)
2016-10-04 00:58:33 +00:00
and (\<lambda>s. \<forall>rf \<in> zobj_refs' cp. ex_nonz_cap_to' rf s)
and valid_cap' cp and K (isThreadCap cp)
2018-02-16 04:35:59 +00:00
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)
2016-10-04 00:58:33 +00:00
and sysargs_rel args buffer)
(UNIV
\<inter> {s. ccap_relation cp (cap_' s)}
\<inter> {s. unat (length___unsigned_long_' s) = length args}
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
2016-10-04 00:58:33 +00:00
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
2018-02-16 04:35:59 +00:00
(decodeSetMCPriority args cp extraCaps
2016-10-04 00:58:33 +00:00
>>= invocationCatch thread isBlocking isCall InvokeTCB)
(Call decodeSetMCPriority_'proc)"
2018-02-16 04:35:59 +00:00
supply Collect_const[simp del]
supply dc_simp[simp del]
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
apply (cinit' lift: cap_' length___unsigned_long_' current_extra_caps_' buffer_' simp: decodeSetMCPriority_def)
2018-02-16 04:35:59 +00:00
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)
2016-10-04 00:58:33 +00:00
apply simp
2018-02-16 04:35:59 +00:00
apply (rule injection_handler_wp)
apply (rule checkPrio_wp[simplified validE_R_def])
2016-10-04 00:58:33 +00:00
apply vcg
2019-05-06 06:34:44 +00:00
apply (wp | simp | wpc | wp (once) hoare_drop_imps)+
2018-02-16 04:35:59 +00:00
apply vcg
apply wp
apply (vcg exspec=getSyscallArg_modifies)
apply (clarsimp simp: EXCEPTION_SYSCALL_ERROR_def EXCEPTION_NONE_def)
apply vcg
apply clarsimp
2016-10-04 00:58:33 +00:00
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)
2020-06-05 09:04:50 +00:00
apply (clarsimp simp: maxPriority_def numPriorities_def FF_eq_minus_1)
2018-02-16 04:35:59 +00:00
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)
2016-10-04 00:58:33 +00:00
apply (frule rf_sr_ksCurThread)
apply (simp only: cap_get_tag_isCap[symmetric], drule(1) cap_get_tag_to_H)
2018-02-16 04:35:59 +00:00
apply (clarsimp simp: valid_cap'_def capAligned_def interpret_excaps_eq excaps_map_def)
2016-10-04 00:58:33 +00:00
apply (intro conjI impI allI)
2018-02-16 04:35:59 +00:00
apply (clarsimp simp: unat_eq_0 le_max_word_ucast_id cap_get_tag_isCap_unfolded_H_cap isCap_simps)+
2016-10-04 00:58:33 +00:00
done
2014-07-14 19:32:44 +00:00
lemma decodeSetPriority_ccorres:
2018-02-16 04:35:59 +00:00
"\<lbrakk>interpret_excaps extraCaps' = excaps_map extraCaps\<rbrakk> \<Longrightarrow>
ccorres (intr_and_se_rel \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
2014-07-14 19:32:44 +00:00
(invs' and (\<lambda>s. ksCurThread s = thread)
and ct_active' and sch_act_simple
2018-02-16 04:35:59 +00:00
and (excaps_in_mem extraCaps \<circ> ctes_of)
2014-07-14 19:32:44 +00:00
and (\<lambda>s. \<forall>rf \<in> zobj_refs' cp. ex_nonz_cap_to' rf s)
and valid_cap' cp and K (isThreadCap cp)
2018-02-16 04:35:59 +00:00
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)
2014-07-14 19:32:44 +00:00
and sysargs_rel args buffer)
(UNIV
\<inter> {s. ccap_relation cp (cap_' s)}
2016-01-08 07:43:33 +00:00
\<inter> {s. unat (length___unsigned_long_' s) = length args}
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
2014-07-14 19:32:44 +00:00
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
2018-02-16 04:35:59 +00:00
(decodeSetPriority args cp extraCaps
2014-07-14 19:32:44 +00:00
>>= invocationCatch thread isBlocking isCall InvokeTCB)
(Call decodeSetPriority_'proc)"
2018-02-16 04:35:59 +00:00
supply Collect_const[simp del] dc_simp[simp del]
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
apply (cinit' lift: cap_' length___unsigned_long_' current_extra_caps_' buffer_' simp: decodeSetPriority_def)
2018-02-16 04:35:59 +00:00
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)
2016-10-04 00:58:33 +00:00
apply simp
2018-02-16 04:35:59 +00:00
apply (rule injection_handler_wp)
apply (rule checkPrio_wp[simplified validE_R_def])
2016-10-04 00:58:33 +00:00
apply vcg
2019-05-06 06:34:44 +00:00
apply (wp | simp | wpc | wp (once) hoare_drop_imps)+
2018-02-16 04:35:59 +00:00
apply vcg
apply wp
apply (vcg exspec=getSyscallArg_modifies)
apply (clarsimp simp: EXCEPTION_SYSCALL_ERROR_def EXCEPTION_NONE_def)
apply vcg
apply clarsimp
2014-07-14 19:32:44 +00:00
apply (rule conjI)
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: ct_in_state'_def pred_tcb_at'
2014-07-14 19:32:44 +00:00
valid_cap'_def isCap_simps)
apply (rule conjI, clarsimp simp: sysargs_rel_n_def n_msgRegisters_def)
2020-06-05 09:04:50 +00:00
apply (clarsimp simp: maxPriority_def numPriorities_def FF_eq_minus_1)
2018-02-16 04:35:59 +00:00
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)
2014-07-14 19:32:44 +00:00
apply (frule rf_sr_ksCurThread)
apply (simp only: cap_get_tag_isCap[symmetric], drule(1) cap_get_tag_to_H)
2018-02-16 04:35:59 +00:00
apply (clarsimp simp: valid_cap'_def capAligned_def interpret_excaps_eq excaps_map_def)
2014-07-14 19:32:44 +00:00
apply (intro conjI impI allI)
2018-02-16 04:35:59 +00:00
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"
2021-09-22 00:21:01 +00:00
by (clarsimp simp: ucast_le_8_32_equiv mcpriority_tcb_at'_prio_bounded simp del: unsigned_uminus1)
2018-02-16 04:35:59 +00:00
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}
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
2018-02-16 04:35:59 +00:00
\<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]
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
apply (cinit' lift: cap_' length___unsigned_long_' current_extra_caps_' buffer_' simp: decodeSetSchedParams_def)
2018-02-16 04:35:59 +00:00
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
2019-05-06 06:34:44 +00:00
apply (wp | simp | wpc | wp (once) hoare_drop_imps)+
2018-02-16 04:35:59 +00:00
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)
2020-06-05 09:04:50 +00:00
apply (clarsimp simp: maxPriority_def numPriorities_def FF_eq_minus_1)
2018-02-16 04:35:59 +00:00
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)+
2014-07-14 19:32:44 +00:00
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)}
2016-01-08 07:43:33 +00:00
\<inter> {s. unat (length___unsigned_long_' s) = length args}
2014-07-14 19:32:44 +00:00
\<inter> {s. slot_' s = cte_Ptr slot}
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
2014-07-14 19:32:44 +00:00
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
(decodeSetIPCBuffer args cp slot extraCaps
>>= invocationCatch thread isBlocking isCall InvokeTCB)
(Call decodeSetIPCBuffer_'proc)"
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
apply (cinit' lift: cap_' length___unsigned_long_' slot_' current_extra_caps_' buffer_'
2014-07-14 19:32:44 +00:00
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
2018-02-16 04:35:59 +00:00
apply (simp del: Collect_const)
2014-07-14 19:32:44 +00:00
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)
2014-08-09 05:16:17 +00:00
apply (rule ccorres_split_nothrow_case_sum)
2014-07-14 19:32:44 +00:00
apply (ctac add: deriveCap_ccorres)
apply ceqv
apply (simp add: Collect_False del: Collect_const)
apply csymbr
2014-08-09 05:16:17 +00:00
apply (rule ccorres_split_nothrow_case_sum)
2014-07-14 19:32:44 +00:00
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
2019-05-06 06:34:44 +00:00
apply (wp | wp (once) hoare_drop_imps)+
2014-07-14 19:32:44 +00:00
apply (simp add: Collect_const_mem)
apply (vcg exspec=deriveCap_modifies)
apply simp
2019-05-06 06:34:44 +00:00
apply (wp | wp (once) hoare_drop_imps)+
2014-07-14 19:32:44 +00:00
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
2015-09-02 05:43:39 +00:00
pred_tcb_at' cintr_def intr_and_se_rel_def
2014-07-14 19:32:44 +00:00
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')
2015-11-16 03:12:37 +00:00
apply (frule(2) tcb_at_capTCBPtr_CL)
2014-07-14 19:32:44 +00:00
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
2015-09-02 05:43:39 +00:00
elim: pred_tcb'_weakenE dest!: st_tcb_at_idle_thread'
2014-07-14 19:32:44 +00:00
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
2015-11-02 00:00:32 +00:00
lemma bindNTFN_alignment_junk:
2017-10-05 02:47:10 +00:00
"\<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)
2018-09-17 06:17:28 +00:00
apply (rule is_aligned_neg_mask_eq)
2015-09-02 05:43:39 +00:00
apply (erule aligned_add_aligned)
2017-10-05 02:47:10 +00:00
apply (erule is_aligned_weaken[rotated])
by (auto simp add: is_aligned_def objBits_defs ctcb_offset_defs)
2015-09-02 05:43:39 +00:00
2015-11-02 00:00:32 +00:00
lemma bindNotification_ccorres:
2017-07-12 05:13:51 +00:00
"ccorres dc xfdc (invs' and tcb_at' tcb)
2015-09-02 05:43:39 +00:00
(UNIV \<inter> {s. tcb_' s = tcb_ptr_to_ctcb_ptr tcb}
2015-11-02 00:00:32 +00:00
\<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])
2017-07-12 05:13:51 +00:00
apply (rule_tac P="invs' and ko_at' rv ntfnptr and tcb_at' tcb" and P'=UNIV
2015-09-02 05:43:39 +00:00
in ccorres_split_nothrow_novcg)
apply (rule ccorres_from_vcg[where rrel=dc and xf=xfdc])
apply (rule allI, rule conseqPre, vcg)
apply (clarsimp)
2015-11-02 00:00:32 +00:00
apply (frule cmap_relation_ntfn)
2015-09-02 05:43:39 +00:00
apply (erule (1) cmap_relation_ko_atE)
apply (rule conjI)
apply (erule h_t_valid_clift)
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: setNotification_def split_def)
2015-09-02 05:43:39 +00:00
apply (rule bexI [OF _ setObject_eq])
apply (simp add: rf_sr_def cstate_relation_def Let_def init_def
2016-09-21 00:33:03 +00:00
cpspace_relation_def update_ntfn_map_tos
typ_heap_simps')
2015-09-02 05:43:39 +00:00
apply (elim conjE)
apply (intro conjI)
2018-06-09 08:27:30 +00:00
\<comment> \<open>tcb relation\<close>
2015-11-02 00:00:32 +00:00
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")
2017-10-05 02:47:10 +00:00
apply (auto simp: option_to_ctcb_ptr_def obj_at'_def objBits_simps projectKOs
bindNTFN_alignment_junk)[4]
2016-09-21 00:33:03 +00:00
apply (simp add: carch_state_relation_def typ_heap_simps')
2015-09-02 05:43:39 +00:00
apply (simp add: cmachine_state_relation_def)
apply (simp add: h_t_valid_clift_Some_iff)
2017-10-05 02:47:10 +00:00
apply (simp add: objBits_simps')
2015-09-02 05:43:39 +00:00
apply (simp add: objBits_simps)
apply assumption
apply ceqv
apply (rule ccorres_move_c_guard_tcb)
2015-11-02 00:00:32 +00:00
apply (simp add: setBoundNotification_def)
2015-09-02 05:43:39 +00:00
apply (rule_tac P'=\<top> and P=\<top> in threadSet_ccorres_lemma3[unfolded dc_def])
apply vcg
apply simp
2016-09-21 00:33:03 +00:00
apply (erule (1) rf_sr_tcb_update_no_queue2,
(simp add: typ_heap_simps')+, simp_all?)[1]
2015-09-02 05:43:39 +00:00
apply (simp add: ctcb_relation_def option_to_ptr_def option_to_0_def)
apply simp
2015-11-02 00:00:32 +00:00
apply (wp get_ntfn_ko'| simp add: guard_is_UNIV_def)+
2015-09-02 05:43:39 +00:00
done
2015-11-02 00:00:32 +00:00
lemma invokeTCB_NotificationControl_bind_ccorres:
2015-09-02 05:43:39 +00:00
"ccorres (cintr \<currency> (\<lambda>rv rv'. rv = [])) (liftxf errstate id (K ()) ret__unsigned_long_')
2015-11-02 00:00:32 +00:00
(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_')
2015-09-02 05:43:39 +00:00
apply (clarsimp simp: option_to_0_def liftE_def)
apply (rule ccorres_cond_true_seq)
2015-11-02 00:00:32 +00:00
apply (ctac(no_vcg) add: bindNotification_ccorres)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_return_CE[unfolded returnOk_def, simplified])
apply simp
apply simp
apply simp
apply wp
apply (case_tac "a = 0", auto)
done
2015-11-02 00:00:32 +00:00
lemma invokeTCB_NotificationControl_unbind_ccorres:
2015-09-02 05:43:39 +00:00
"ccorres (cintr \<currency> (\<lambda>rv rv'. rv = [])) (liftxf errstate id (K ()) ret__unsigned_long_')
2015-11-02 00:00:32 +00:00
(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))
2017-07-12 05:13:51 +00:00
(Call invokeTCB_NotificationControl_'proc)"
2015-11-02 00:00:32 +00:00
apply (cinit lift: tcb_' ntfnPtr_')
2015-09-02 05:43:39 +00:00
apply (clarsimp simp add: option_to_0_def liftE_def)
2015-11-02 00:00:32 +00:00
apply (ctac(no_vcg) add: unbindNotification_ccorres)
2015-09-02 05:43:39 +00:00
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
2015-11-02 00:00:32 +00:00
lemma valid_objs_boundNTFN_NULL:
"ko_at' tcb p s ==> valid_objs' s \<Longrightarrow> no_0_obj' s \<Longrightarrow> tcbBoundNotification tcb \<noteq> Some 0"
2015-09-02 05:43:39 +00:00
apply (drule(1) obj_at_valid_objs')
apply (clarsimp simp: valid_tcb'_def projectKOs valid_obj'_def)
done
2015-11-02 00:00:32 +00:00
lemma decodeUnbindNotification_ccorres:
2015-09-02 05:43:39 +00:00
"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)}) []
2015-11-02 00:00:32 +00:00
(decodeUnbindNotification cp >>= invocationCatch thread isBlocking isCall InvokeTCB)
(Call decodeUnbindNotification_'proc)"
apply (cinit' lift: cap_' simp: decodeUnbindNotification_def)
2015-09-02 05:43:39 +00:00
apply csymbr
apply csymbr
apply (rule ccorres_Guard_Seq)
apply (simp add: liftE_bindE bind_assoc)
2015-11-02 00:00:32 +00:00
apply (rule ccorres_pre_getBoundNotification)
2015-09-02 05:43:39 +00:00
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)
2015-11-02 00:00:32 +00:00
apply (ctac add: invokeTCB_NotificationControl_unbind_ccorres)
2015-09-02 05:43:39 +00:00
apply simp
apply (rule ccorres_alternative2)
apply (rule ccorres_return_CE, simp+)[1]
apply (rule ccorres_return_C_errorE, simp+)[1]
apply wp
2015-11-02 00:00:32 +00:00
apply (vcg exspec=invokeTCB_NotificationControl_modifies)
2015-09-02 05:43:39 +00:00
apply simp
2015-09-10 07:06:45 +00:00
apply (wp sts_invs_minor' hoare_case_option_wp sts_bound_tcb_at' | wpc | simp)+
2015-09-02 05:43:39 +00:00
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
2015-11-02 00:00:32 +00:00
dest!: valid_objs_boundNTFN_NULL)
2015-09-02 05:43:39 +00:00
done
2015-11-02 00:00:32 +00:00
lemma nTFN_case_If_ptr:
2017-07-12 05:13:51 +00:00
"(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)"
2015-11-02 00:00:32 +00:00
by (auto simp: isNotificationCap_def split: capability.splits)
2015-09-02 05:43:39 +00:00
2015-11-02 00:00:32 +00:00
lemma decodeBindNotification_ccorres:
2015-09-02 05:43:39 +00:00
"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
2017-07-12 05:13:51 +00:00
and valid_cap' cp
2015-09-02 05:43:39 +00:00
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)}
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}) []
2015-11-02 00:00:32 +00:00
(decodeBindNotification cp extraCaps >>= invocationCatch thread isBlocking isCall InvokeTCB)
(Call decodeBindNotification_'proc)"
2015-09-02 05:43:39 +00:00
apply (simp, rule ccorres_gen_asm)
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
apply (cinit' lift: cap_' current_extra_caps_' simp: decodeBindNotification_def)
2015-09-02 05:43:39 +00:00
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)
2015-11-02 00:00:32 +00:00
apply (rule ccorres_pre_getBoundNotification)
2015-09-02 05:43:39 +00:00
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)
2015-09-16 00:35:23 +00:00
apply (simp add: returnOk_bind ccorres_invocationCatch_Inr performInvocation_def
2015-09-02 05:43:39 +00:00
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)
2015-11-02 00:00:32 +00:00
apply (rule_tac P="Q (capNtfnPtr rva) (capNtfnCanReceive rva) rva"for Q in ccorres_inst)
2015-09-02 05:43:39 +00:00
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) )
2015-09-10 07:06:45 +00:00
apply (simp add: case_bool_If if_to_top_of_bindE if_to_top_of_bind bind_assoc
2015-09-02 05:43:39 +00:00
del: Collect_const cong: if_cong call_ignore_cong)
2015-09-16 00:35:23 +00:00
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)
2015-11-02 00:00:32 +00:00
apply (rule ccorres_pre_getNotification)
apply (rename_tac ntfn)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_rhs_assoc2)
apply (rule ccorres_rhs_assoc2)
2015-11-02 00:00:32 +00:00
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"
2015-09-16 00:35:23 +00:00
and R'=UNIV
in ccorres_symb_exec_r_known_rv_UNIV)
2015-09-02 05:43:39 +00:00
apply (rule conseqPre, vcg)
apply (clarsimp simp: if_1_0_0)
2015-11-02 00:00:32 +00:00
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
2016-10-25 06:01:30 +00:00
false_def true_def split: option.split_asm if_split,
2015-09-16 00:35:23 +00:00
auto simp: neq_Nil_conv tcb_queue_relation'_def tcb_at_not_NULL[symmetric]
tcb_at_not_NULL)[1]
2015-09-02 05:43:39 +00:00
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
2018-06-09 08:27:30 +00:00
\<comment> \<open>IdleNtfn\<close>
2015-09-10 07:06:45 +00:00
apply (simp add: case_option_If del: Collect_const)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_Cond_rhs_Seq)
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: isWaitingNtfn_def from_bool_neq_0)
2015-09-02 05:43:39 +00:00
apply (simp add: bindE_bind_linearise[symmetric] injection_handler_throwError
2015-09-16 00:35:23 +00:00
invocationCatch_use_injection_handler throwError_bind invocationCatch_def)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
apply vcg
apply (rule conseqPre, vcg)
2015-09-16 00:35:23 +00:00
apply (clarsimp simp: throwError_def return_def syscall_error_rel_def
2015-09-02 05:43:39 +00:00
syscall_error_to_H_cases exception_defs)
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: isWaitingNtfn_def from_bool_neq_0 returnOk_bind)
apply (clarsimp simp: isWaitingNtfn_def from_bool_neq_0 returnOk_bind
2015-09-02 05:43:39 +00:00
ccorres_invocationCatch_Inr performInvocation_def)
apply (ctac add: setThreadState_ccorres)
2015-11-02 00:00:32 +00:00
apply (ctac add: invokeTCB_NotificationControl_bind_ccorres)
2015-09-02 05:43:39 +00:00
apply simp
apply (rule ccorres_alternative2)
apply (rule ccorres_return_CE, simp+)[1]
apply (rule ccorres_return_C_errorE, simp+)[1]
apply wp
2015-11-02 00:00:32 +00:00
apply (vcg exspec=invokeTCB_NotificationControl_modifies)
2015-09-02 05:43:39 +00:00
apply simp
2015-09-10 07:06:45 +00:00
apply (wp sts_invs_minor' hoare_case_option_wp sts_bound_tcb_at' | wpc | simp)+
2015-09-02 05:43:39 +00:00
apply (vcg exspec=setThreadState_modifies)
2015-09-10 07:06:45 +00:00
apply (simp add: case_option_If del: Collect_const)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_Cond_rhs_Seq)
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: isWaitingNtfn_def from_bool_neq_0)
2015-09-02 05:43:39 +00:00
apply (simp add: bindE_bind_linearise[symmetric] injection_handler_throwError
2015-09-16 00:35:23 +00:00
invocationCatch_use_injection_handler throwError_bind invocationCatch_def)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_from_vcg_split_throws[where P=\<top> and P'=UNIV])
apply vcg
apply (rule conseqPre, vcg)
2015-09-16 00:35:23 +00:00
apply (clarsimp simp: throwError_def return_def syscall_error_rel_def
2015-09-02 05:43:39 +00:00
syscall_error_to_H_cases exception_defs)
2015-11-02 00:00:32 +00:00
apply (clarsimp simp: isWaitingNtfn_def from_bool_neq_0 returnOk_bind)
apply (clarsimp simp: isWaitingNtfn_def from_bool_neq_0 returnOk_bind
2015-09-02 05:43:39 +00:00
ccorres_invocationCatch_Inr performInvocation_def)
apply (ctac add: setThreadState_ccorres)
2015-11-02 00:00:32 +00:00
apply (ctac add: invokeTCB_NotificationControl_bind_ccorres)
2015-09-02 05:43:39 +00:00
apply simp
apply (rule ccorres_alternative2)
apply (rule ccorres_return_CE, simp+)[1]
apply (rule ccorres_return_C_errorE, simp+)[1]
apply wp
2015-11-02 00:00:32 +00:00
apply (vcg exspec=invokeTCB_NotificationControl_modifies)
2015-09-02 05:43:39 +00:00
apply simp
2015-09-10 07:06:45 +00:00
apply (wp sts_invs_minor' hoare_case_option_wp sts_bound_tcb_at' | wpc | simp)+
2015-09-02 05:43:39 +00:00
apply (vcg exspec=setThreadState_modifies)
apply (simp add: bindE_bind_linearise[symmetric] injection_handler_throwError
2015-09-16 00:35:23 +00:00
invocationCatch_use_injection_handler throwError_bind invocationCatch_def)
2015-09-02 05:43:39 +00:00
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)
2015-09-16 00:35:23 +00:00
apply (clarsimp simp: throwError_def return_def syscall_error_rel_def
2015-09-02 05:43:39 +00:00
syscall_error_to_H_cases exception_defs)
2015-11-02 00:00:32 +00:00
apply (clarsimp simp add: guard_is_UNIV_def isWaitingNtfn_def from_bool_0
2015-09-02 05:43:39 +00:00
ThreadState_Restart_def mask_def true_def
rf_sr_ksCurThread capTCBPtr_eq)
2015-11-02 00:00:32 +00:00
apply (simp add: hd_conv_nth bindE_bind_linearise nTFN_case_If_ptr throwError_bind invocationCatch_def)
2015-09-02 05:43:39 +00:00
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
2019-05-06 06:34:44 +00:00
apply (wp | simp | wpc | wp (once) hoare_drop_imps)+
2015-09-02 05:43:39 +00:00
apply vcg
apply clarsimp
2015-09-16 00:35:23 +00:00
apply (rule conjI)
2015-09-02 05:43:39 +00:00
apply safe[1]
2015-09-16 00:35:23 +00:00
apply (fastforce simp: invs'_def valid_state'_def valid_pspace'_def
2015-11-02 00:00:32 +00:00
dest!: valid_objs_boundNTFN_NULL)
2015-09-02 05:43:39 +00:00
apply ((fastforce elim!: pred_tcb'_weakenE obj_at'_weakenE
2015-09-16 00:35:23 +00:00
simp: ct_in_state'_def from_bool_0 isCap_simps excaps_map_def
2015-09-02 05:43:39 +00:00
neq_Nil_conv obj_at'_def pred_tcb_at'_def valid_tcb_state'_def)+)[12]
2015-09-16 00:35:23 +00:00
apply (clarsimp dest!: obj_at_valid_objs'[OF _ invs_valid_objs']
2015-09-02 05:43:39 +00:00
simp: projectKOs valid_obj'_def)
2015-09-16 00:35:23 +00:00
apply (clarsimp simp: excaps_map_Nil cte_wp_at_ctes_of excaps_map_def neq_Nil_conv
2015-09-02 05:43:39 +00:00
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]
2015-09-16 00:35:23 +00:00
apply (clarsimp simp: typ_heap_simps excaps_map_def neq_Nil_conv
2015-09-02 05:43:39 +00:00
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
2016-10-25 06:01:30 +00:00
split: if_split)
2015-09-02 05:43:39 +00:00
done
2014-07-14 19:32:44 +00:00
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)}
2016-01-08 07:43:33 +00:00
\<inter> {s. unat (length___unsigned_long_' s) = length args}
2014-07-14 19:32:44 +00:00
\<inter> {s. slot_' s = cte_Ptr slot}
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
2014-07-14 19:32:44 +00:00
\<inter> {s. buffer_' s = option_to_ptr buffer}) []
(decodeSetSpace args cp slot extraCaps
>>= invocationCatch thread isBlocking isCall InvokeTCB)
(Call decodeSetSpace_'proc)"
2021-09-22 00:21:01 +00:00
supply unsigned_numeral[simp del]
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
apply (cinit' lift: cap_' length___unsigned_long_' slot_' current_extra_caps_' buffer_'
2014-07-14 19:32:44 +00:00
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)
2016-01-08 07:43:33 +00:00
apply (subgoal_tac "unat length___unsigned_long < 3")
2014-07-14 19:32:44 +00:00
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)
2015-05-17 23:11:43 +00:00
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)
2014-07-14 19:32:44 +00:00
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)
2015-05-17 23:11:43 +00:00
apply (rule_tac P="\<lambda>a. ccorres rvr xf P P' hs a c" for rvr xf P P' hs c in ssubst,
2014-07-14 19:32:44 +00:00
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]
2015-11-16 03:12:37 +00:00
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)+
2014-07-14 19:32:44 +00:00
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)
2015-11-16 03:12:37 +00:00
apply (rule ccorres_move_array_assertion_tcb_ctes)
apply (simp del: Collect_const)
2014-07-14 19:32:44 +00:00
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)
2017-01-13 12:58:40 +00:00
apply wp+
2014-07-14 19:32:44 +00:00
apply (rule ccorres_rhs_assoc)+
apply csymbr
2015-11-16 03:12:37 +00:00
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)+
2014-07-14 19:32:44 +00:00
apply (ctac add: slotCapLongRunningDelete_ccorres)
2015-11-16 03:12:37 +00:00
apply (rule ccorres_move_array_assertion_tcb_ctes)
apply (simp del: Collect_const)
2014-07-14 19:32:44 +00:00
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
2017-01-13 12:58:40 +00:00
apply (wp hoare_drop_imps)
2014-07-14 19:32:44 +00:00
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)+
2021-09-22 00:21:01 +00:00
apply (clarsimp simp: word_less_nat_alt)
2014-07-14 19:32:44 +00:00
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)
2015-11-16 03:12:37 +00:00
apply (frule(2) tcb_at_capTCBPtr_CL)
2017-10-05 02:47:10 +00:00
apply (auto simp: isCap_simps valid_tcb_state'_def objBits_defs mask_def
2015-09-02 05:43:39 +00:00
elim!: pred_tcb'_weakenE
2014-07-14 19:32:44 +00:00
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
2017-02-06 07:33:39 +00:00
capTCBPtr_eq tcb_cnode_index_defs size_of_def
2014-07-14 19:32:44 +00:00
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)
2017-10-05 02:47:10 +00:00
apply (clarsimp simp: objBits_defs)
2014-07-14 19:32:44 +00:00
apply fastforce
apply clarsimp
done
2018-02-02 03:35:57 +00:00
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
2019-06-22 00:12:48 +00:00
invs_weak_sch_act_wf invs_queues TLS_BASE_def TPIDRURW_def
2018-02-02 03:35:57 +00:00
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
2014-07-14 19:32:44 +00:00
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
2016-01-08 07:43:33 +00:00
\<inter> {s. invLabel_' s = label}
2014-07-14 19:32:44 +00:00
\<inter> {s. ccap_relation cp (cap_' s)}
2016-01-08 07:43:33 +00:00
\<inter> {s. unat (length___unsigned_long_' s) = length args}
2014-07-14 19:32:44 +00:00
\<inter> {s. slot_' s = cte_Ptr slot}
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
\<inter> {s. current_extra_caps_' (globals s) = extraCaps'}
2014-07-14 19:32:44 +00:00
\<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)"
crefine: remove large structs passed by value
The RISC-V calling convention specifies that when a C function takes an
argument by value, the binary function should take the argument by
reference, if the value is larger than 2 pointer words.
For binary verification, we avoid implementing this aspect of the RISC-V
calling convention, by eliminating all such function arguments for
functions which are not inlined. This commit includes the proof updates
corresponding to the kernel source update, which is in the seL4
repository.
This includes arguments of types `slot_range_t` and `extra_caps_t`.
`slot_range_t` is only used in two functions, so for those cases, we
unpack the arguments, and remove the type altogether.
`extra_caps_t` is used extensively in invocation decoding, and also in
inter-process communication. Since extra caps are already stored in a
global variable `current_extra_caps`, we remove the function argument,
and use the global variable instead. However, this adds significant
difficulty to the proofs, because the variable lifting performed by
`cinit` worked for the function argument, but not for the global
variable. We have therefore recently improved the `cinit` automation to
support this change to the kernel.
Even though this change was for the benefit of RISC-V binary
verification, we update all architectures for consistency.
Signed-off-by: Matthew Brecknell <Matthew.Brecknell@data61.csiro.au>
2020-06-12 07:44:30 +00:00
apply (cinit' lift: invLabel_' cap_' length___unsigned_long_' slot_' current_extra_caps_' call_' buffer_')
2019-11-28 06:55:26 +00:00
apply (simp add: decodeTCBInvocation_def invocation_eq_use_types gen_invocation_type_eq
2014-07-14 19:32:44 +00:00
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)
2016-10-04 00:58:33 +00:00
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)
2018-02-16 04:35:59 +00:00
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)
2014-07-14 19:32:44 +00:00
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
2015-09-02 05:43:39 +00:00
apply (rule ccorres_Cond_rhs)
apply simp
2015-11-02 00:00:32 +00:00
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeBindNotification_ccorres)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_return_CE, simp+)[1]
apply (rule ccorres_return_C_errorE, simp+)[1]
apply wp
apply (rule ccorres_Cond_rhs)
apply simp
2015-11-02 00:00:32 +00:00
apply (rule ccorres_add_returnOk, ctac(no_vcg) add: decodeUnbindNotification_ccorres)
2015-09-02 05:43:39 +00:00
apply (rule ccorres_return_CE, simp+)[1]
apply (rule ccorres_return_C_errorE, simp+)[1]
apply wp
2018-02-02 03:35:57 +00:00
apply (rule ccorres_Cond_rhs)
2019-11-28 06:55:26 +00:00
apply (simp add: gen_invocation_type_eq)
2018-02-02 03:35:57 +00:00
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
2014-07-14 19:32:44 +00:00
apply (rule ccorres_equals_throwError)
apply (fastforce simp: throwError_bind invocationCatch_def
2019-11-28 06:55:26 +00:00
split: invocation_label.split gen_invocation_labels.split)
2014-07-14 19:32:44 +00:00
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
2015-09-02 05:43:39 +00:00
elim!: pred_tcb'_weakenE
2014-07-14 19:32:44 +00:00
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