(* * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) * * SPDX-License-Identifier: GPL-2.0-only *) theory Tcb_R imports CNodeInv_R begin context begin interpretation Arch . (*FIXME: arch_split*) lemma asUser_setNextPC_corres: "corres dc (tcb_at t and invs) (tcb_at' t and invs') (as_user t (setNextPC v)) (asUser t (setNextPC v))" apply (rule asUser_corres) apply (rule corres_Id, simp, simp) apply (rule no_fail_setNextPC) done lemma activateIdleThread_corres: "corres dc (invs and st_tcb_at idle t) (invs' and st_tcb_at' idle' t) (arch_activate_idle_thread t) (activateIdleThread t)" by (simp add: arch_activate_idle_thread_def activateIdleThread_def) lemma activateThread_corres: "corres dc (invs and ct_in_state activatable) (invs' and ct_in_state' activatable') activate_thread activateThread" supply subst_all [simp del] apply (simp add: activate_thread_def activateThread_def) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF getCurThread_corres]) apply (rule_tac R="\ts s. valid_tcb_state ts s \ (idle ts \ runnable ts) \ invs s \ st_tcb_at ((=) ts) thread s" and R'="\ts s. valid_tcb_state' ts s \ (idle' ts \ runnable' ts) \ invs' s \ st_tcb_at' (\ts'. ts' = ts) thread s" in corres_split[OF getThreadState_corres]) apply (rule_tac F="idle rv \ runnable rv" in corres_req, simp) apply (rule_tac F="idle' rv' \ runnable' rv'" in corres_req, simp) apply (case_tac rv, simp_all add: isRunning_def isRestart_def, safe, simp_all)[1] apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) apply (rule corres_split_nor[OF asUser_setNextPC_corres]) apply (rule setThreadState_corres) apply (simp | wp weak_sch_act_wf_lift_linear)+ apply (clarsimp simp: st_tcb_at_tcb_at invs_distinct) apply fastforce apply (rule corres_guard_imp) apply (rule activateIdleThread_corres) apply (clarsimp elim!: st_tcb_weakenE) apply (clarsimp elim!: pred_tcb'_weakenE) apply (wp gts_st_tcb gts_st_tcb' gts_st_tcb_at)+ apply (clarsimp simp: ct_in_state_def tcb_at_invs invs_distinct invs_psp_aligned elim!: st_tcb_weakenE) apply (clarsimp simp: tcb_at_invs' ct_in_state'_def elim!: pred_tcb'_weakenE) done lemma bindNotification_corres: "corres dc (invs and tcb_at t and ntfn_at a) (invs' and tcb_at' t and ntfn_at' a) (bind_notification t a) (bindNotification t a)" apply (simp add: bind_notification_def bindNotification_def) apply (rule corres_guard_imp) apply (rule corres_split[OF getNotification_corres]) apply (rule corres_split[OF setNotification_corres]) apply (clarsimp simp: ntfn_relation_def split: Structures_A.ntfn.splits) apply (rule setBoundNotification_corres) apply (wp)+ apply auto done abbreviation "ct_idle' \ ct_in_state' idle'" lemma gts_st_tcb': "\tcb_at' t\ getThreadState t \\rv. st_tcb_at' (\st. st = rv) t\" apply (rule hoare_vcg_precond_imp) apply (rule hoare_post_imp[where Q="\rv s. \rv'. rv = rv' \ st_tcb_at' (\st. st = rv') t s"]) apply simp apply (wp hoare_vcg_ex_lift) apply (clarsimp simp add: pred_tcb_at'_def obj_at'_def) done lemma activateIdle_invs: "\invs' and ct_idle'\ activateIdleThread thread \\rv. invs' and ct_idle'\" by (simp add: activateIdleThread_def) lemma activate_invs': "\invs' and sch_act_simple and ct_in_state' activatable'\ activateThread \\rv. invs' and (ct_running' or ct_idle')\" apply (simp add: activateThread_def) apply (rule hoare_seq_ext) apply (rule_tac B="\state s. invs' s \ sch_act_simple s \ st_tcb_at' (\st. st = state) thread s \ thread = ksCurThread s \ (runnable' state \ idle' state)" in hoare_seq_ext) apply (case_tac x; simp add: isTS_defs split del: if_split cong: if_cong) apply (wp) apply (clarsimp simp: ct_in_state'_def) apply (rule_tac Q="\rv. invs' and ct_idle'" in hoare_post_imp, simp) apply (wp activateIdle_invs) apply (clarsimp simp: ct_in_state'_def) apply (rule_tac Q="\rv. invs' and ct_running' and sch_act_simple" in hoare_post_imp, simp) apply (rule hoare_weaken_pre) apply (wp ct_in_state'_set asUser_ct sts_invs_minor' | wp (once) sch_act_simple_lift)+ apply (rule_tac Q="\_. st_tcb_at' runnable' thread and sch_act_simple and invs' and (\s. thread = ksCurThread s)" in hoare_post_imp, clarsimp) apply (wp sch_act_simple_lift)+ apply (clarsimp simp: valid_idle'_def invs'_def valid_state'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def elim!: pred_tcb'_weakenE) apply (wp gts_st_tcb')+ apply (clarsimp simp: tcb_at_invs' ct_in_state'_def pred_disj_def) done declare not_psubset_eq[dest!] lemma setThreadState_runnable_simp: "runnable' ts \ setThreadState ts t = threadSet (tcbState_update (\x. ts)) t" apply (simp add: setThreadState_def isRunnable_def isStopped_def liftM_def) apply (subst bind_return[symmetric], rule bind_cong[OF refl]) apply (drule use_valid[OF _ threadSet_pred_tcb_at_state[where proj="itcbState" and p=t and P="(=) ts"]]) apply simp apply (subst bind_known_operation_eq) apply wp+ apply clarsimp apply (subst eq_commute, erule conjI[OF _ refl]) apply (rule empty_fail_getThreadState) apply (simp add: getCurThread_def getSchedulerAction_def exec_gets) apply (auto simp: when_def split: Structures_H.thread_state.split) done lemma activate_sch_act: "\ct_in_state' activatable' and (\s. P (ksSchedulerAction s))\ activateThread \\rv s. P (ksSchedulerAction s)\" apply (simp add: activateThread_def getCurThread_def cong: if_cong Structures_H.thread_state.case_cong) apply (rule hoare_seq_ext [OF _ gets_sp]) apply (rule hoare_seq_ext[where B="\st s. (runnable' or idle') st \ P (ksSchedulerAction s)"]) apply (rule hoare_pre) apply (wp | wpc | simp add: setThreadState_runnable_simp)+ apply (clarsimp simp: ct_in_state'_def cur_tcb'_def pred_tcb_at' elim!: pred_tcb'_weakenE) done lemma runnable_tsr: "thread_state_relation ts ts' \ runnable' ts' = runnable ts" by (case_tac ts, auto) lemma idle_tsr: "thread_state_relation ts ts' \ idle' ts' = idle ts" by (case_tac ts, auto) crunches cancelIPC, setupReplyMaster for cur [wp]: cur_tcb' (wp: crunch_wps simp: crunch_simps o_def) lemma setCTE_weak_sch_act_wf[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ setCTE c cte \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" apply (simp add: weak_sch_act_wf_def) apply (wp hoare_vcg_all_lift hoare_convert_imp setCTE_pred_tcb_at' setCTE_tcb_in_cur_domain') done lemma setupReplyMaster_weak_sch_act_wf[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ setupReplyMaster thread \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" apply (simp add: setupReplyMaster_def) apply (wp) apply (rule_tac Q="\_ s. weak_sch_act_wf (ksSchedulerAction s) s" in hoare_post_imp, clarsimp) apply (wp)+ apply assumption done crunches setupReplyMaster for valid_queues[wp]: "Invariants_H.valid_queues" and valid_queues'[wp]: "valid_queues'" (wp: crunch_wps simp: crunch_simps) crunches setup_reply_master, Tcb_A.restart, arch_post_modify_registers for pspace_aligned[wp]: "pspace_aligned :: det_ext state \ _" and pspace_distinct[wp]: "pspace_distinct :: det_ext state \ _" (wp: crunch_wps simp: crunch_simps) lemma restart_corres: "corres dc (einvs and tcb_at t) (invs' and tcb_at' t) (Tcb_A.restart t) (ThreadDecls_H.restart t)" apply (simp add: Tcb_A.restart_def Thread_H.restart_def) apply (simp add: isStopped_def2 liftM_def) apply (rule corres_guard_imp) apply (rule corres_split[OF getThreadState_corres]) apply (clarsimp simp add: runnable_tsr idle_tsr when_def) apply (rule corres_split_nor[OF cancel_ipc_corres]) apply (rule corres_split_nor[OF setupReplyMaster_corres]) apply (rule corres_split_nor[OF setThreadState_corres], simp) apply (rule corres_split[OF tcbSchedEnqueue_corres possibleSwitchTo_corres]) apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_valid_queues sts_st_tcb' | clarsimp simp: valid_tcb_state'_def)+ apply (rule_tac Q="\rv. valid_sched and cur_tcb and pspace_aligned and pspace_distinct" in hoare_strengthen_post) apply wp apply (simp add: valid_sched_def valid_sched_action_def) apply (rule_tac Q="\rv. invs' and tcb_at' t" in hoare_strengthen_post) apply wp apply (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak valid_pspace'_def) apply wp+ apply (simp add: valid_sched_def invs_def tcb_at_is_etcb_at invs_psp_aligned invs_distinct) apply (clarsimp simp add: invs'_def valid_state'_def sch_act_wf_weak) done lemma restart_invs': "\invs' and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ ThreadDecls_H.restart t \\rv. invs'\" apply (simp add: restart_def isStopped_def2) apply (wp setThreadState_nonqueued_state_update cancelIPC_simple setThreadState_st_tcb | wp (once) sch_act_simple_lift)+ apply (wp hoare_convert_imp) apply (wp setThreadState_nonqueued_state_update setThreadState_st_tcb) apply (clarsimp) apply (wp hoare_convert_imp)[1] apply (clarsimp) apply (wp)+ apply (clarsimp simp: comp_def) apply (rule hoare_strengthen_post, rule gts_sp') prefer 2 apply assumption apply (clarsimp simp: pred_tcb_at' invs'_def valid_state'_def ct_in_state'_def) apply (fastforce simp: pred_tcb_at'_def obj_at'_def) done lemma restart_tcb'[wp]: "\tcb_at' t'\ ThreadDecls_H.restart t \\rv. tcb_at' t'\" apply (simp add: restart_def isStopped_def2) apply wpsimp done lemma no_fail_setRegister: "no_fail \ (setRegister r v)" by (simp add: setRegister_def) lemma suspend_cap_to'[wp]: "\ex_nonz_cap_to' p\ suspend t \\rv. ex_nonz_cap_to' p\" apply (simp add: suspend_def) unfolding updateRestartPC_def apply (wp threadSet_cap_to' | simp)+ done declare det_getRegister[simp] declare det_setRegister[simp] lemma no_fail_getRegister[wp]: "no_fail \ (getRegister r)" by (simp add: getRegister_def) lemma invokeTCB_ReadRegisters_corres: "corres (dc \ (=)) (einvs and tcb_at src and ex_nonz_cap_to src) (invs' and sch_act_simple and tcb_at' src and ex_nonz_cap_to' src) (invoke_tcb (tcb_invocation.ReadRegisters src susp n arch)) (invokeTCB (tcbinvocation.ReadRegisters src susp n arch'))" apply (simp add: invokeTCB_def performTransfer_def genericTake_def frame_registers_def gp_registers_def frameRegisters_def gpRegisters_def) apply (rule corres_guard_imp) apply (rule corres_split_nor) apply (rule corres_when[OF refl]) apply (rule suspend_corres) apply (rule corres_split[OF getCurThread_corres]) apply (simp add: liftM_def[symmetric]) apply (rule asUser_corres) apply (rule corres_Id) apply simp apply simp apply (rule no_fail_mapM) apply (simp add: no_fail_getRegister) apply wp+ apply (clarsimp simp: invs_def valid_state_def valid_pspace_def dest!: idle_no_ex_cap) apply (clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) done lemma asUser_postModifyRegisters_corres: "corres dc (tcb_at t) (tcb_at' t and tcb_at' ct) (arch_post_modify_registers ct t) (asUser t $ postModifyRegisters ct t)" apply (rule corres_guard_imp) apply (clarsimp simp: arch_post_modify_registers_def postModifyRegisters_def when_def) apply safe apply (subst submonad_asUser.return) apply (rule corres_stateAssert_assume) by simp+ lemma invokeTCB_WriteRegisters_corres: "corres (dc \ (=)) (einvs and tcb_at dest and ex_nonz_cap_to dest) (invs' and sch_act_simple and tcb_at' dest and ex_nonz_cap_to' dest) (invoke_tcb (tcb_invocation.WriteRegisters dest resume values arch)) (invokeTCB (tcbinvocation.WriteRegisters dest resume values arch'))" apply (simp add: invokeTCB_def performTransfer_def arch_get_sanitise_register_info_def sanitiseRegister_def sanitise_register_def getSanitiseRegisterInfo_def frameRegisters_def gpRegisters_def) apply (rule corres_guard_imp) apply (rule corres_split[OF getCurThread_corres]) apply (rule corres_split_nor) apply (rule asUser_corres) apply (simp add: zipWithM_mapM getRestartPC_def setNextPC_def) apply (rule corres_Id) apply (clarsimp simp: mask_def user_vtop_def cong: if_cong) apply simp apply (wpsimp wp: no_fail_mapM no_fail_setRegister) apply simp apply (rule corres_split_nor[OF asUser_postModifyRegisters_corres[simplified]]) apply (rule corres_split_nor[OF corres_when[OF refl restart_corres]]) apply (rule corres_split_nor[OF corres_when[OF refl rescheduleRequired_corres]]) apply (rule_tac P=\ and P'=\ in corres_inst) apply simp apply (wp+)[2] apply ((wp hoare_weak_lift_imp restart_invs' | strengthen valid_sched_weak_strg einvs_valid_etcbs invs_valid_queues' invs_queues invs_weak_sch_act_wf | clarsimp simp: invs_def valid_state_def valid_sched_def invs'_def valid_state'_def dest!: global'_no_ex_cap idle_no_ex_cap)+)[2] apply (rule_tac Q="\_. einvs and tcb_at dest and ex_nonz_cap_to dest" in hoare_post_imp) apply (fastforce simp: invs_def valid_sched_weak_strg valid_sched_def valid_state_def dest!: idle_no_ex_cap) prefer 2 apply (rule_tac Q="\_. invs' and tcb_at' dest and ex_nonz_cap_to' dest" in hoare_post_imp) apply (fastforce simp: sch_act_wf_weak invs'_def valid_state'_def dest!: global'_no_ex_cap) apply wpsimp+ done lemma tcbSchedDequeue_ResumeCurrentThread_imp_notct[wp]: "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ tcbSchedDequeue t \\rv s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" by (wp hoare_convert_imp) lemma updateRestartPC_ResumeCurrentThread_imp_notct[wp]: "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ updateRestartPC t \\rv s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" unfolding updateRestartPC_def apply (wp hoare_convert_imp) done lemma suspend_ResumeCurrentThread_imp_notct[wp]: "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ suspend t \\rv s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" by (wpsimp simp: suspend_def) lemma invokeTCB_CopyRegisters_corres: "corres (dc \ (=)) (einvs and simple_sched_action and tcb_at dest and tcb_at src and ex_nonz_cap_to src and ex_nonz_cap_to dest) (invs' and sch_act_simple and tcb_at' dest and tcb_at' src and ex_nonz_cap_to' src and ex_nonz_cap_to' dest) (invoke_tcb (tcb_invocation.CopyRegisters dest src susp resume frames ints arch)) (invokeTCB (tcbinvocation.CopyRegisters dest src susp resume frames ints arch'))" proof - have Q: "\src src' des des' r r'. \ src = src'; des = des' \ \ corres dc (tcb_at src and tcb_at des and invs) (tcb_at' src' and tcb_at' des' and invs') (do v \ as_user src (getRegister r); as_user des (setRegister r' v) od) (do v \ asUser src' (getRegister r); asUser des' (setRegister r' v) od)" apply clarsimp apply (rule corres_guard_imp) apply (rule corres_split_eqr) apply (rule asUser_getRegister_corres) apply (simp add: setRegister_def) apply (rule asUser_corres) apply (rule corres_modify') apply simp apply simp apply (simp add: invs_distinct invs_psp_aligned| wp)+ done have R: "\src src' des des' xs ys. \ src = src'; des = des'; xs = ys \ \ corres dc (tcb_at src and tcb_at des and invs) (tcb_at' src' and tcb_at' des' and invs') (mapM_x (\r. do v \ as_user src (getRegister r); as_user des (setRegister r v) od) xs) (mapM_x (\r'. do v \ asUser src' (getRegister r'); asUser des' (setRegister r' v) od) ys)" apply (rule corres_mapM_x [where S=Id]) apply simp apply (rule Q) apply (clarsimp simp: set_zip_same | wp)+ done have U: "\t. corres dc (tcb_at t and invs) (tcb_at' t and invs') (do pc \ as_user t getRestartPC; as_user t (setNextPC pc) od) (do pc \ asUser t getRestartPC; asUser t (setNextPC pc) od)" apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) apply (rule asUser_setNextPC_corres) apply wp+ apply (simp add: invs_distinct invs_psp_aligned)+ done show ?thesis apply (simp add: invokeTCB_def performTransfer_def) apply (rule corres_guard_imp) apply (rule corres_split[OF corres_when [OF refl suspend_corres]], simp) apply (rule corres_split[OF corres_when [OF refl restart_corres]], simp) apply (rule corres_split_nor) apply (rule corres_when[OF refl]) apply (rule corres_split_nor) apply (rule R[OF refl refl]) apply (simp add: frame_registers_def frameRegisters_def) apply (simp add: getRestartPC_def setNextPC_def dc_def[symmetric]) apply (rule Q[OF refl refl]) apply (wp mapM_x_wp' | simp)+ apply (rule corres_split_nor) apply (rule corres_when[OF refl]) apply (rule R[OF refl refl]) apply (simp add: gpRegisters_def) apply (rule corres_split_eqr[OF getCurThread_corres]) apply (rule corres_split_nor[OF asUser_postModifyRegisters_corres[simplified]]) apply (rule corres_split[OF corres_when[OF refl rescheduleRequired_corres]]) apply (rule_tac P=\ and P'=\ in corres_inst) apply simp apply (solves \wp hoare_weak_lift_imp\)+ apply (rule_tac Q="\_. einvs and tcb_at dest" in hoare_post_imp) apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_sched_weak_strg valid_sched_def) prefer 2 apply (rule_tac Q="\_. invs' and tcb_at' dest" in hoare_post_imp) apply (clarsimp simp: invs'_def valid_state'_def invs_weak_sch_act_wf cur_tcb'_def) apply ((wp mapM_x_wp' hoare_weak_lift_imp | simp+)+)[4] apply ((wp hoare_weak_lift_imp restart_invs' | wpc | clarsimp simp: if_apply_def2)+)[2] apply (wp suspend_nonz_cap_to_tcb hoare_weak_lift_imp | simp add: if_apply_def2)+ apply (fastforce simp: invs_def valid_state_def valid_pspace_def dest!: idle_no_ex_cap) by (fastforce simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) qed lemma readreg_invs': "\invs' and sch_act_simple and tcb_at' src and ex_nonz_cap_to' src\ invokeTCB (tcbinvocation.ReadRegisters src susp n arch) \\rv. invs'\" by (simp add: invokeTCB_def performTransfer_def | wp | clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap)+ crunches getSanitiseRegisterInfo for invs'[wp]: invs' and ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' d" and it'[wp]: "\s. P (ksIdleThread s)" and tcb_at'[wp]: "tcb_at' t" lemma writereg_invs': "\invs' and sch_act_simple and tcb_at' dest and ex_nonz_cap_to' dest\ invokeTCB (tcbinvocation.WriteRegisters dest resume values arch) \\rv. invs'\" by (simp add: invokeTCB_def performTransfer_def | wp restart_invs' | rule conjI | clarsimp | clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap)+ lemma copyreg_invs'': "\invs' and sch_act_simple and tcb_at' src and tcb_at' dest and ex_nonz_cap_to' src and ex_nonz_cap_to' dest\ invokeTCB (tcbinvocation.CopyRegisters dest src susp resume frames ints arch) \\rv. invs' and tcb_at' dest\" apply (simp add: invokeTCB_def performTransfer_def if_apply_def2) apply (wpsimp wp: mapM_x_wp' restart_invs' hoare_drop_imps split_del: if_split simp: if_apply_def2 invs_cur' cur_tcb'_def[symmetric] cong: rev_conj_cong) by (fastforce simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) lemma copyreg_invs': "\invs' and sch_act_simple and tcb_at' src and tcb_at' dest and ex_nonz_cap_to' src and ex_nonz_cap_to' dest\ invokeTCB (tcbinvocation.CopyRegisters dest src susp resume frames ints arch) \\rv. invs'\" by (rule hoare_strengthen_post, rule copyreg_invs'', simp) lemma threadSet_valid_queues_no_state: "\Invariants_H.valid_queues and (\s. \p. t \ set (ksReadyQueues s p))\ threadSet f t \\_. Invariants_H.valid_queues\" apply (simp add: threadSet_def) apply wp apply (simp add: valid_queues_def valid_queues_no_bitmap_def' pred_tcb_at'_def) apply (wp setObject_queues_unchanged_tcb hoare_Ball_helper hoare_vcg_all_lift setObject_tcb_strongest)[1] apply (wp getObject_tcb_wp) apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def' pred_tcb_at'_def) apply (clarsimp simp: obj_at'_def) done lemma threadSet_valid_queues'_no_state: "(\tcb. tcbQueued tcb = tcbQueued (f tcb)) \ \valid_queues' and (\s. \p. t \ set (ksReadyQueues s p))\ threadSet f t \\_. valid_queues'\" apply (simp add: valid_queues'_def threadSet_def obj_at'_real_def split del: if_split) apply (simp only: imp_conv_disj) apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) apply (wp setObject_ko_wp_at | simp add: objBits_simps')+ apply (wp getObject_tcb_wp updateObject_default_inv | simp split del: if_split)+ apply (clarsimp simp: obj_at'_def ko_wp_at'_def objBits_simps addToQs_def split del: if_split cong: if_cong) apply (fastforce simp: inQ_def split: if_split_asm) done lemma isRunnable_corres: "corres (\ts runn. runnable ts = runn) (tcb_at t and pspace_aligned and pspace_distinct) \ (get_thread_state t) (isRunnable t)" apply (simp add: isRunnable_def) apply (subst bind_return[symmetric]) apply (rule corres_guard_imp) apply (rule corres_split[OF getThreadState_corres]) apply (case_tac rv, clarsimp+) apply (wp hoare_TrueI)+ apply auto done lemma tcbSchedDequeue_not_queued: "\\\ tcbSchedDequeue t \\rv. obj_at' (Not \ tcbQueued) t\" apply (simp add: tcbSchedDequeue_def) apply (wp | simp)+ apply (rule_tac Q="\rv. obj_at' (\obj. tcbQueued obj = rv) t" in hoare_post_imp) apply (clarsimp simp: obj_at'_def) apply (wp tg_sp' [where P=\, simplified] | simp)+ done lemma tcbSchedDequeue_not_in_queue: "\p. \Invariants_H.valid_queues and tcb_at' t and valid_objs'\ tcbSchedDequeue t \\rv s. t \ set (ksReadyQueues s p)\" apply (rule_tac Q="\rv. Invariants_H.valid_queues and obj_at' (Not \ tcbQueued) t" in hoare_post_imp) apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def ) apply (wp tcbSchedDequeue_not_queued tcbSchedDequeue_valid_queues | simp add: valid_objs'_maxDomain valid_objs'_maxPriority)+ done lemma threadSet_ct_in_state': "(\tcb. tcbState (f tcb) = tcbState tcb) \ \ct_in_state' test\ threadSet f t \\rv. ct_in_state' test\" apply (simp add: ct_in_state'_def) apply (rule hoare_lift_Pf [where f=ksCurThread]) apply (wp threadSet_pred_tcb_no_state)+ apply simp+ apply wp done lemma valid_tcb'_tcbPriority_update: "\valid_tcb' tcb s; f (tcbPriority tcb) \ maxPriority \ \ valid_tcb' (tcbPriority_update f tcb) s" apply (simp add: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) done lemma threadSet_valid_objs_tcbPriority_update: "\valid_objs' and (\_. x \ maxPriority)\ threadSet (tcbPriority_update (\_. x)) t \\_. valid_objs'\" including no_pre apply (simp add: threadSet_def) apply wp prefer 2 apply (rule getObject_tcb_sp) apply (rule hoare_weaken_pre) apply (rule setObject_tcb_valid_objs) apply (clarsimp simp: valid_obj'_def) apply (frule (1) ko_at_valid_objs') apply simp apply (simp add: valid_obj'_def) apply (subgoal_tac "tcb_at' t s") apply simp apply (rule valid_tcb'_tcbPriority_update) apply (fastforce simp: obj_at'_def)+ done lemma tcbSchedDequeue_ct_in_state'[wp]: "\ct_in_state' test\ tcbSchedDequeue t \\rv. ct_in_state' test\" apply (simp add: ct_in_state'_def) apply (rule hoare_lift_Pf [where f=ksCurThread]; wp) done crunch cur[wp]: tcbSchedDequeue cur_tcb' lemma sp_corres2: "corres dc (valid_etcbs and weak_valid_sched_action and cur_tcb and pspace_aligned and pspace_distinct) (Invariants_H.valid_queues and valid_queues' and tcb_at' t and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs' and (\_. x \ maxPriority)) (set_priority t x) (setPriority t x)" apply (simp add: setPriority_def set_priority_def thread_set_priority_def) apply (rule stronger_corres_guard_imp) apply (rule corres_split[OF tcbSchedDequeue_corres]) apply (rule corres_split[OF ethread_set_corres], simp_all)[1] apply (simp add: etcb_relation_def) apply (rule corres_split[OF isRunnable_corres]) apply (erule corres_when) apply(rule corres_split[OF getCurThread_corres]) apply (wp corres_if; clarsimp) apply (rule rescheduleRequired_corres) apply (rule possibleSwitchTo_corres) apply ((clarsimp | wp hoare_weak_lift_imp hoare_vcg_if_lift hoare_wp_combs gts_wp isRunnable_wp)+)[4] apply (wp hoare_vcg_imp_lift' hoare_vcg_if_lift hoare_vcg_all_lift) apply clarsimp apply ((wp hoare_drop_imps hoare_vcg_if_lift hoare_vcg_all_lift isRunnable_wp threadSet_pred_tcb_no_state threadSet_valid_queues_no_state threadSet_valid_queues'_no_state threadSet_cur threadSet_valid_objs_tcbPriority_update threadSet_weak_sch_act_wf threadSet_ct_in_state'[simplified ct_in_state'_def] | simp add: etcb_relation_def)+)[1] apply ((wp hoare_vcg_imp_lift' hoare_vcg_if_lift hoare_vcg_all_lift hoare_vcg_disj_lift tcbSchedDequeue_not_in_queue tcbSchedDequeue_valid_queues tcbSchedDequeue_ct_in_state'[simplified ct_in_state'_def] | simp add: etcb_relation_def)+)[2] apply (force simp: valid_etcbs_def tcb_at_st_tcb_at[symmetric] state_relation_def dest: pspace_relation_tcb_at intro: st_tcb_at_opeqI) apply (force simp: state_relation_def elim: valid_objs'_maxDomain valid_objs'_maxPriority) done lemma setPriority_corres: "corres dc (einvs and tcb_at t) (invs' and tcb_at' t and valid_objs' and (\_. x \ maxPriority)) (set_priority t x) (setPriority t x)" apply (rule corres_guard_imp) apply (rule sp_corres2) apply (simp add: valid_sched_def valid_sched_action_def invs_psp_aligned invs_distinct invs_def) apply (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak) done lemma setMCPriority_corres: "corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ (set_mcpriority t x) (setMCPriority t x)" apply (rule corres_guard_imp) apply (clarsimp simp: setMCPriority_def set_mcpriority_def) apply (rule threadset_corresT) by (clarsimp simp: tcb_relation_def tcb_cap_cases_tcb_mcpriority tcb_cte_cases_def cteSizeBits_def exst_same_def)+ definition "out_rel fn fn' v v' \ ((v = None) = (v' = None)) \ (\tcb tcb'. tcb_relation tcb tcb' \ tcb_relation (case_option id fn v tcb) (case_option id fn' v' tcb'))" lemma out_corresT: assumes x: "\tcb v. \(getF, setF)\ran tcb_cap_cases. getF (fn v tcb) = getF tcb" assumes y: "\v. \tcb. \(getF, setF)\ran tcb_cte_cases. getF (fn' v tcb) = getF tcb" assumes e: "\tcb v. exst_same tcb (fn' v tcb)" shows "out_rel fn fn' v v' \ corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ (option_update_thread t fn v) (case_option (return ()) (\x. threadSet (fn' x) t) v')" apply (case_tac v, simp_all add: out_rel_def option_update_thread_def) apply clarsimp apply (clarsimp simp add: threadset_corresT [OF _ x y e]) done lemmas out_corres = out_corresT [OF _ all_tcbI, OF ball_tcb_cap_casesI ball_tcb_cte_casesI] lemma tcbSchedDequeue_sch_act_simple[wp]: "tcbSchedDequeue t \sch_act_simple\" by (wpsimp simp: sch_act_simple_def) lemma setP_invs': "\invs' and tcb_at' t and K (p \ maxPriority)\ setPriority t p \\rv. invs'\" apply (rule hoare_gen_asm) apply (simp add: setPriority_def) apply (wp rescheduleRequired_all_invs_but_ct_not_inQ) apply simp apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift') unfolding st_tcb_at'_def apply (strengthen not_obj_at'_strengthen, wp) apply (wp hoare_vcg_imp_lift') apply (rule_tac Q="\rv s. invs' s" in hoare_post_imp) apply (clarsimp simp: invs_sch_act_wf' invs'_def invs_queues) apply (clarsimp simp: valid_state'_def) apply (wp hoare_drop_imps threadSet_invs_trivial, simp_all add: inQ_def cong: conj_cong)[1] apply (wp hoare_drop_imps threadSet_invs_trivial, simp_all add: inQ_def cong: conj_cong)[1] apply (wp hoare_drop_imps threadSet_invs_trivial, simp_all add: inQ_def cong: conj_cong)[1] apply (rule_tac Q="\_. invs' and obj_at' (Not \ tcbQueued) t and (\s. \d p. t \ set (ksReadyQueues s (d,p)))" in hoare_post_imp) apply (clarsimp simp: obj_at'_def inQ_def) apply (wp tcbSchedDequeue_not_queued)+ apply clarsimp done crunches setPriority, setMCPriority for typ_at'[wp]: "\s. P (typ_at' T p s)" (simp: crunch_simps) lemmas setPriority_typ_ats [wp] = typ_at_lifts [OF setPriority_typ_at'] crunches setPriority, setMCPriority for valid_cap[wp]: "valid_cap' c" (wp: getObject_inv_tcb) definition newroot_rel :: "(cap \ cslot_ptr) option \ (capability \ machine_word) option \ bool" where "newroot_rel \ opt_rel (\(cap, ptr) (cap', ptr'). cap_relation cap cap' \ ptr' = cte_map ptr)" function recursive :: "nat \ ((nat \ nat), unit) nondet_monad" where "recursive (Suc n) s = (do f \ gets fst; s \ gets snd; put ((f + s), n); recursive n od) s" | "recursive 0 s = (modify (\(a, b). (a, 0))) s" by (case_tac "fst x", fastforce+) termination recursive apply (rule recursive.termination) apply (rule wf_measure [where f=fst]) apply simp done lemma cte_map_tcb_0: "cte_map (t, tcb_cnode_index 0) = t" by (simp add: cte_map_def tcb_cnode_index_def) lemma cte_map_tcb_1: "cte_map (t, tcb_cnode_index 1) = t + 2^cteSizeBits" by (simp add: cte_map_def tcb_cnode_index_def to_bl_1 objBits_defs cte_level_bits_def) lemma sameRegion_corres2: "\ cap_relation c c'; cap_relation d d' \ \ same_region_as c d = sameRegionAs c' d'" by (erule(1) same_region_as_relation) lemma sameObject_corres2: "\ cap_relation c c'; cap_relation d d' \ \ same_object_as c d = sameObjectAs c' d'" apply (frule(1) sameRegion_corres2[symmetric, where c=c and d=d]) apply (case_tac c; simp add: sameObjectAs_def same_object_as_def isCap_simps is_cap_simps bits_of_def) apply (case_tac d; simp) apply (case_tac d'; simp) apply (rename_tac arch_cap) apply clarsimp apply (case_tac d, (simp_all split: arch_cap.split)[11]) apply (rename_tac arch_capa) apply (clarsimp simp add: RISCV64_H.sameObjectAs_def Let_def) apply (intro conjI impI) apply (case_tac arch_cap; simp add: sameRegionAs_def isCap_simps) apply (case_tac arch_capa; fastforce simp add: add_mask_fold) apply (case_tac arch_cap; simp add: sameRegionAs_def isCap_simps) apply (case_tac arch_capa; simp) done lemma checkCapAt_corres: assumes r: "cap_relation cap cap'" assumes c: "corres dc Q Q' f f'" assumes Q: "\s. P s \ cte_wp_at (same_object_as cap) slot s \ Q s" assumes Q': "\s. P' s \ cte_wp_at' (sameObjectAs cap' o cteCap) (cte_map slot) s \ Q' s" shows "corres dc (P and cte_at slot and invs) (P' and pspace_aligned' and pspace_distinct') (check_cap_at cap slot f) (checkCapAt cap' (cte_map slot) f')" using r c apply (simp add: check_cap_at_def checkCapAt_def liftM_def when_def) apply (rule corres_guard_imp) apply (rule corres_split[OF get_cap_corres]) apply (rule corres_if [unfolded if_apply_def2]) apply (erule(1) sameObject_corres2) apply assumption apply (rule corres_trivial, simp) apply (wp get_cap_wp getCTE_wp')+ apply (fastforce elim: cte_wp_at_weakenE intro: Q) apply (fastforce elim: cte_wp_at_weakenE' intro: Q') done lemma checkCapAt_weak_corres: assumes r: "cap_relation cap cap'" assumes c: "corres dc P P' f f'" shows "corres dc (P and cte_at slot and invs) (P' and pspace_aligned' and pspace_distinct') (check_cap_at cap slot f) (checkCapAt cap' (cte_map slot) f')" apply (rule checkCapAt_corres, rule r, rule c) apply auto done defs assertDerived_def: "assertDerived src cap f \ do stateAssert (\s. cte_wp_at' (is_derived' (ctes_of s) src cap o cteCap) src s) []; f od" lemma checkCapAt_cteInsert_corres: "cap_relation new_cap newCap \ corres dc (einvs and cte_wp_at (\c. c = cap.NullCap) (target, ref) and cte_at slot and K (is_cnode_or_valid_arch new_cap \ (is_pt_cap new_cap \ cap_asid new_cap \ None)) and cte_wp_at (\c. obj_refs c = obj_refs new_cap \ table_cap_ref c = table_cap_ref new_cap \ vspace_asid c = vspace_asid new_cap) src_slot) (invs' and cte_wp_at' (\cte. cteCap cte = NullCap) (cte_map (target, ref)) and valid_cap' newCap) (check_cap_at new_cap src_slot (check_cap_at (cap.ThreadCap target) slot (cap_insert new_cap src_slot (target, ref)))) (checkCapAt newCap (cte_map src_slot) (checkCapAt (ThreadCap target) (cte_map slot) (assertDerived (cte_map src_slot) newCap (cteInsert newCap (cte_map src_slot) (cte_map (target, ref))))))" apply (rule corres_guard_imp) apply (rule_tac P="cte_wp_at (\c. c = cap.NullCap) (target, ref) and cte_at slot and cte_wp_at (\c. obj_refs c = obj_refs new_cap \ table_cap_ref c = table_cap_ref new_cap \ vspace_asid c = vspace_asid new_cap) src_slot and einvs and K (is_cnode_or_valid_arch new_cap \ (is_pt_cap new_cap \ cap_asid new_cap \ None))" and P'="cte_wp_at' (\c. cteCap c = NullCap) (cte_map (target, ref)) and invs' and valid_cap' newCap" in checkCapAt_corres, assumption) apply (rule checkCapAt_weak_corres, simp) apply (unfold assertDerived_def)[1] apply (rule corres_stateAssert_implied [where P'=\]) apply simp apply (erule cteInsert_corres [OF _ refl refl]) apply clarsimp apply (drule cte_wp_at_norm [where p=src_slot]) apply (case_tac src_slot) apply (clarsimp simp: state_relation_def) apply (drule (1) pspace_relation_cte_wp_at) apply fastforce apply fastforce apply (clarsimp simp: cte_wp_at_ctes_of) apply (erule (2) is_derived_eq [THEN iffD1]) apply (erule cte_wp_at_weakenE, rule TrueI) apply assumption apply clarsimp apply (rule conjI, fastforce)+ apply (cases src_slot) apply (clarsimp simp: cte_wp_at_caps_of_state) apply (rule conjI) apply (frule same_object_as_cap_master) apply (clarsimp simp: cap_master_cap_simps is_cnode_or_valid_arch_def is_cap_simps is_valid_vtable_root_def dest!: cap_master_cap_eqDs) apply (erule(1) checked_insert_is_derived) apply simp apply simp apply fastforce apply (clarsimp simp: cte_wp_at_caps_of_state) apply clarsimp apply fastforce done lemma capBadgeNone_masters: "capMasterCap cap = capMasterCap cap' \ (capBadge cap = None) = (capBadge cap' = None)" apply (rule master_eqI) apply (auto simp add: capBadge_def capMasterCap_def isCap_simps split: capability.split) done definition "vspace_asid' cap \ case cap of ArchObjectCap (PageTableCap _ (Some (asid, _))) \ Some asid | _ \ None" lemma untyped_derived_eq_from_sameObjectAs: "sameObjectAs cap cap2 \ untyped_derived_eq cap cap2" by (clarsimp simp: untyped_derived_eq_def sameObjectAs_def2 isCap_Master) lemmas vspace_asid'_simps [simp] = vspace_asid'_def [split_simps capability.split arch_capability.split option.split prod.split] lemma checked_insert_tcb_invs'[wp]: "\invs' and cte_wp_at' (\cte. cteCap cte = NullCap) slot and valid_cap' new_cap and K (capBadge new_cap = None) and K (slot \ cte_refs' (ThreadCap target) 0) and K (\ isReplyCap new_cap \ \ isIRQControlCap new_cap)\ checkCapAt new_cap src_slot (checkCapAt (ThreadCap target) slot' (assertDerived src_slot new_cap (cteInsert new_cap src_slot slot))) \\rv. invs'\" supply option.case_cong[cong] apply (simp add: checkCapAt_def liftM_def assertDerived_def stateAssert_def) apply (wp getCTE_cteCap_wp cteInsert_invs) apply (clarsimp split: option.splits) apply (subst(asm) tree_cte_cteCap_eq[unfolded o_def]) apply (clarsimp split: option.splits) apply (rule conjI) apply (clarsimp simp: sameObjectAs_def3) apply (clarsimp simp: tree_cte_cteCap_eq[unfolded o_def] is_derived'_def untyped_derived_eq_from_sameObjectAs ex_cte_cap_to'_cteCap) apply (erule sameObjectAsE)+ apply (clarsimp simp: badge_derived'_def) apply (frule capBadgeNone_masters, simp) apply (rule conjI) apply (rule_tac x=slot' in exI) subgoal by (clarsimp simp: isCap_simps) apply (clarsimp simp: isCap_simps cteCaps_of_def) apply (erule(1) valid_irq_handlers_ctes_ofD) apply (clarsimp simp: invs'_def valid_state'_def) done lemma checkCap_inv: assumes x: "\P\ f \\rv. P\" shows "\P\ checkCapAt cap slot f \\rv. P\" unfolding checkCapAt_def by (wp x | simp)+ lemma isValidVTableRootD: "isValidVTableRoot cap \ isArchObjectCap cap \ isPageTableCap (capCap cap) \ capPTMappedAddress (capCap cap) \ None" by (simp add: isValidVTableRoot_def isCap_simps split: capability.split_asm arch_capability.split_asm option.split_asm) lemma assertDerived_wp: "\P and (\s. cte_wp_at' (is_derived' (ctes_of s) slot cap o cteCap) slot s)\ f \Q\ \ \P\ assertDerived slot cap f \Q\" unfolding assertDerived_def by wpsimp lemma setMCPriority_invs': "\invs' and tcb_at' t and K (prio \ maxPriority)\ setMCPriority t prio \\rv. invs'\" unfolding setMCPriority_def apply (rule hoare_gen_asm) apply (rule hoare_pre) by (wp threadSet_invs_trivial, (clarsimp simp: inQ_def)+) lemma valid_tcb'_tcbMCP_update: "\valid_tcb' tcb s \ f (tcbMCP tcb) \ maxPriority\ \ valid_tcb' (tcbMCP_update f tcb) s" apply (simp add: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) done lemma setMCPriority_valid_objs'[wp]: "\valid_objs' and K (prio \ maxPriority)\ setMCPriority t prio \\rv. valid_objs'\" unfolding setMCPriority_def including no_pre apply (simp add: threadSet_def) apply wp prefer 2 apply (rule getObject_tcb_sp) apply (rule hoare_weaken_pre) apply (rule setObject_tcb_valid_objs) apply (clarsimp simp: valid_obj'_def) apply (frule (1) ko_at_valid_objs') apply simp apply (simp add: valid_obj'_def) apply (subgoal_tac "tcb_at' t s") apply simp apply (rule valid_tcb'_tcbMCP_update) apply (fastforce simp: obj_at'_def)+ done crunch sch_act_simple[wp]: setMCPriority sch_act_simple (wp: ssa_sch_act_simple crunch_wps rule: sch_act_simple_lift simp: crunch_simps) (* For some reason, when this was embedded in a larger expression clarsimp wouldn't remove it. Adding it as a simp rule does *) lemma inQ_tc_corres_helper: "(\d p. (\tcb. tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d \ (tcbQueued tcb \ tcbDomain tcb \ d)) \ a \ set (ksReadyQueues s (d, p)))" by clarsimp abbreviation "valid_option_prio \ case_option True (\(p, auth). p \ maxPriority)" definition valid_tcb_invocation :: "tcbinvocation \ bool" where "valid_tcb_invocation i \ case i of ThreadControl _ _ _ mcp p _ _ _ \ valid_option_prio p \ valid_option_prio mcp | _ \ True" lemma thread_set_ipc_weak_valid_sched_action: "\ einvs and simple_sched_action\ thread_set (tcb_ipc_buffer_update f) a \\x. weak_valid_sched_action\" apply (rule hoare_pre) apply (simp add: thread_set_def) apply (wp set_object_wp) apply (simp | intro impI | elim exE conjE)+ apply (frule get_tcb_SomeD) apply (erule ssubst) apply (clarsimp simp add: weak_valid_sched_action_def valid_etcbs_2_def st_tcb_at_kh_def get_tcb_def obj_at_kh_def obj_at_def is_etcb_at'_def valid_sched_def valid_sched_action_def) done lemma threadcontrol_corres_helper2: "is_aligned a msg_align_bits \ \invs' and tcb_at' t\ threadSet (tcbIPCBuffer_update (\_. a)) t \\x s. Invariants_H.valid_queues s \ valid_queues' s\" by (wp threadSet_invs_trivial | strengthen invs_valid_queues' invs_queues invs_weak_sch_act_wf | clarsimp simp: inQ_def )+ lemma threadcontrol_corres_helper3: "\ einvs and simple_sched_action\ check_cap_at cap p (check_cap_at (cap.ThreadCap cap') slot (cap_insert cap p (t, tcb_cnode_index 4))) \\x. weak_valid_sched_action and valid_etcbs \" apply (rule hoare_pre) apply (wp check_cap_inv | simp add:)+ by (clarsimp simp add: weak_valid_sched_action_def valid_etcbs_2_def st_tcb_at_kh_def get_tcb_def obj_at_kh_def obj_at_def is_etcb_at'_def valid_sched_def valid_sched_action_def) lemma threadcontrol_corres_helper4: "isArchObjectCap ac \ \invs' and cte_wp_at' (\cte. cteCap cte = capability.NullCap) (cte_map (a, tcb_cnode_index 4)) and valid_cap' ac \ checkCapAt ac (cte_map (ab, ba)) (checkCapAt (capability.ThreadCap a) (cte_map slot) (assertDerived (cte_map (ab, ba)) ac (cteInsert ac (cte_map (ab, ba)) (cte_map (a, tcb_cnode_index 4))))) \\x. Invariants_H.valid_queues and valid_queues'\" apply (wp | strengthen invs_valid_queues' invs_queues invs_weak_sch_act_wf | clarsimp simp: )+ by (case_tac ac; clarsimp simp: capBadge_def isCap_simps tcb_cnode_index_def cte_map_def cte_wp_at'_def cte_level_bits_def) crunches cap_delete for pspace_alinged[wp]: "pspace_aligned :: det_ext state \ _" and pspace_distinct[wp]: "pspace_distinct :: det_ext state \ _" (simp: crunch_simps preemption_point_def wp: crunch_wps OR_choiceE_weak_wp) lemmas check_cap_pspace_aligned[wp] = check_cap_inv[of pspace_aligned] lemmas check_cap_pspace_distinct[wp] = check_cap_inv[of pspace_distinct] lemma is_valid_vtable_root_simp: "is_valid_vtable_root cap = (\r asid vref. cap = cap.ArchObjectCap (arch_cap.PageTableCap r (Some (asid, vref))))" by (simp add: is_valid_vtable_root_def split: cap.splits arch_cap.splits option.splits) lemma threadSet_invs_trivialT2: assumes x: "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" assumes z: "\tcb. tcbState (F tcb) = tcbState tcb \ tcbDomain (F tcb) = tcbDomain tcb" assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification tcb" assumes v: "\tcb. tcbDomain tcb \ maxDomain \ tcbDomain (F tcb) \ maxDomain" assumes u: "\tcb. tcbPriority tcb \ maxPriority \ tcbPriority (F tcb) \ maxPriority" assumes b: "\tcb. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" shows "\\s. invs' s \ tcb_at' t s \ (\tcb. is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits) \ (\d p. (\tcb. inQ d p tcb \ \ inQ d p (F tcb)) \ t \ set (ksReadyQueues s (d, p))) \ (\ko d p. ko_at' ko t s \ inQ d p (F ko) \ \ inQ d p ko \ t \ set (ksReadyQueues s (d, p))) \ ((\tcb. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s \ t \ ksCurThread s) \ (\tcb. tcbQueued (F tcb) \ ksSchedulerAction s = ResumeCurrentThread \ tcbQueued tcb \ t \ ksCurThread s)\ threadSet F t \\rv. invs'\" proof - from z have domains: "\tcb. tcbDomain (F tcb) = tcbDomain tcb" by blast note threadSet_sch_actT_P[where P=False, simplified] have y: "\tcb. tcb_st_refs_of' (tcbState (F tcb)) = tcb_st_refs_of' (tcbState tcb) \ valid_tcb_state' (tcbState (F tcb)) = valid_tcb_state' (tcbState tcb)" by (auto simp: z) show ?thesis apply (simp add: invs'_def valid_state'_def split del: if_split) apply (rule hoare_pre) apply (rule hoare_gen_asm [where P="(\tcb. is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits)"]) apply (wp x v u b threadSet_valid_pspace'T threadSet_sch_actT_P[where P=False, simplified] threadSet_valid_queues threadSet_state_refs_of'T[where f'=id] threadSet_iflive'T threadSet_ifunsafe'T threadSet_idle'T threadSet_global_refsT irqs_masked_lift valid_irq_node_lift valid_irq_handlers_lift'' threadSet_ctes_ofT threadSet_not_inQ threadSet_ct_idle_or_in_cur_domain' threadSet_valid_dom_schedule' threadSet_valid_queues' threadSet_cur untyped_ranges_zero_lift |clarsimp simp: y z a domains cteCaps_of_def |rule refl)+ apply (clarsimp simp: obj_at'_def pred_tcb_at'_def) apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) by (fastforce simp: domains ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def z a) qed lemma threadSet_valid_queues'_no_state2: "\ \tcb. tcbQueued tcb = tcbQueued (f tcb); \tcb. tcbState tcb = tcbState (f tcb); \tcb. tcbPriority tcb = tcbPriority (f tcb); \tcb. tcbDomain tcb = tcbDomain (f tcb) \ \ \valid_queues'\ threadSet f t \\_. valid_queues'\" apply (simp add: valid_queues'_def threadSet_def obj_at'_real_def split del: if_split) apply (simp only: imp_conv_disj) apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) apply (wp setObject_ko_wp_at | simp add: objBits_simps')+ apply (wp getObject_tcb_wp updateObject_default_inv | simp split del: if_split)+ apply (clarsimp simp: obj_at'_def ko_wp_at'_def objBits_simps addToQs_def split del: if_split cong: if_cong) apply (fastforce simp: inQ_def split: if_split_asm) done lemma getThreadBufferSlot_dom_tcb_cte_cases: "\\\ getThreadBufferSlot a \\rv s. rv \ (+) a ` dom tcb_cte_cases\" by (wpsimp simp: tcb_cte_cases_def getThreadBufferSlot_def locateSlot_conv cte_level_bits_def tcbIPCBufferSlot_def cteSizeBits_def) lemma tcb_at'_cteInsert[wp]: "\\s. tcb_at' (ksCurThread s) s\ cteInsert t x y \\_ s. tcb_at' (ksCurThread s) s\" by (rule hoare_weaken_pre, wps cteInsert_ct, wp, simp) lemma tcb_at'_asUser[wp]: "\\s. tcb_at' (ksCurThread s) s\ asUser a (setTCBIPCBuffer b) \\_ s. tcb_at' (ksCurThread s) s\" by (rule hoare_weaken_pre, wps asUser_typ_ats(1), wp, simp) lemma tcb_at'_threadSet[wp]: "\\s. tcb_at' (ksCurThread s) s\ threadSet (tcbIPCBuffer_update (\_. b)) a \\_ s. tcb_at' (ksCurThread s) s\" by (rule hoare_weaken_pre, wps threadSet_tcb', wp, simp) lemma cteDelete_it [wp]: "\\s. P (ksIdleThread s)\ cteDelete slot e \\_ s. P (ksIdleThread s)\" by (rule cteDelete_preservation) (wp | clarsimp)+ lemmas threadSet_invs_trivial2 = threadSet_invs_trivialT2 [OF all_tcbI all_tcbI all_tcbI all_tcbI, OF ball_tcb_cte_casesI] lemma valid_tcb_ipc_buffer_update: "\buf s. is_aligned buf msg_align_bits \ (\tcb. valid_tcb' tcb s \ valid_tcb' (tcbIPCBuffer_update (\_. buf) tcb) s)" by (simp add: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) lemma checkCap_wp: assumes x: "\P\ f \\rv. Q\" and PQ: "\s. P s \ Q s" shows "\P\ checkCapAt cap slot f \\rv. Q\" unfolding checkCapAt_def apply (wp x) apply (rule hoare_strengthen_post[rotated]) apply clarsimp apply (strengthen PQ) apply assumption apply simp apply (wp x | simp)+ done lemma assertDerived_wp_weak: "\P\ f \Q\ \ \P\ assertDerived slot cap f \Q\" apply (wpsimp simp: assertDerived_def) done crunches option_update_thread for aligned[wp]: "pspace_aligned" and distinct[wp]: "pspace_distinct" lemma transferCaps_corres: assumes x: "newroot_rel e e'" and y: "newroot_rel f f'" and z: "(case g of None \ g' = None | Some (vptr, g'') \ \g'''. g' = Some (vptr, g''') \ newroot_rel g'' g''')" and u: "{e, f, option_map undefined g} \ {None} \ sl' = cte_map slot" shows "corres (dc \ (=)) (einvs and simple_sched_action and tcb_at a and (\s. {e, f, option_map undefined g} \ {None} \ cte_at slot s) and case_option \ (valid_cap o fst) e and case_option \ (cte_at o snd) e and case_option \ (no_cap_to_obj_dr_emp o fst) e and K (case_option True (is_cnode_cap o fst) e) and case_option \ (valid_cap o fst) f and case_option \ (cte_at o snd) f and case_option \ (no_cap_to_obj_dr_emp o fst) f and K (case_option True (is_valid_vtable_root o fst) f) and case_option \ (case_option \ (cte_at o snd) o snd) g and case_option \ (case_option \ (no_cap_to_obj_dr_emp o fst) o snd) g and case_option \ (case_option \ (valid_cap o fst) o snd) g and K (case_option True ((\v. is_aligned v msg_align_bits) o fst) g) and K (case_option True (\v. case_option True ((swp valid_ipc_buffer_cap (fst v) and is_arch_cap and is_cnode_or_valid_arch) o fst) (snd v)) g) and (\s. case_option True (\(pr, auth). mcpriority_tcb_at (\m. pr \ m) auth s) p_auth) \ \only set prio \ mcp\ and (\s. case_option True (\(mcp, auth). mcpriority_tcb_at (\m. mcp \ m) auth s) mcp_auth) \ \only set mcp \ prev_mcp\) (invs' and sch_act_simple and case_option \ (valid_cap' o fst) e' and (\s. {e', f', option_map undefined g'} \ {None} \ cte_at' (cte_map slot) s) and K (case_option True (isCNodeCap o fst) e') and case_option \ (valid_cap' o fst) f' and K (case_option True (isValidVTableRoot o fst) f') and K (case_option True ((\v. is_aligned v msg_align_bits) o fst) g') and K (case_option True (case_option True (isArchObjectCap o fst) o snd) g') and case_option \ (case_option \ (valid_cap' o fst) o snd) g' and tcb_at' a and ex_nonz_cap_to' a and K (valid_option_prio p_auth \ valid_option_prio mcp_auth) and (\s. case_option True (\(pr, auth). mcpriority_tcb_at' ((\) pr) auth s) p_auth) and (\s. case_option True (\(m, auth). mcpriority_tcb_at' ((\) m) auth s) mcp_auth)) (invoke_tcb (tcb_invocation.ThreadControl a slot (option_map to_bl b') mcp_auth p_auth e f g)) (invokeTCB (tcbinvocation.ThreadControl a sl' b' mcp_auth p_auth e' f' g'))" proof - have P: "\t v. corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ (option_update_thread t (tcb_fault_handler_update o (%x _. x)) (option_map to_bl v)) (case v of None \ return () | Some x \ threadSet (tcbFaultHandler_update (%_. x)) t)" apply (rule out_corres, simp_all add: exst_same_def) apply (case_tac v, simp_all add: out_rel_def) apply (safe, case_tac tcb', simp add: tcb_relation_def split: option.split) done have R: "\t v. corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ (option_update_thread t (tcb_ipc_buffer_update o (%x _. x)) v) (case v of None \ return () | Some x \ threadSet (tcbIPCBuffer_update (%_. x)) t)" apply (rule out_corres, simp_all add: exst_same_def) apply (case_tac v, simp_all add: out_rel_def) apply (safe, case_tac tcb', simp add: tcb_relation_def) done have S: "\t x. corres dc (einvs and tcb_at t) (invs' and tcb_at' t and valid_objs' and K (valid_option_prio p_auth)) (case_option (return ()) (\(p, auth). set_priority t p) p_auth) (case_option (return ()) (\p'. setPriority t (fst p')) p_auth)" apply (case_tac p_auth; clarsimp simp: setPriority_corres) done have S': "\t x. corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ (case_option (return ()) (\(mcp, auth). set_mcpriority t mcp) mcp_auth) (case_option (return ()) (\mcp'. setMCPriority t (fst mcp')) mcp_auth)" apply(case_tac mcp_auth; clarsimp simp: setMCPriority_corres) done have T: "\x x' ref getfn target. \ newroot_rel x x'; getfn = return (cte_map (target, ref)); x \ None \ {e, f, option_map undefined g} \ {None} \ \ corres (dc \ dc) (einvs and simple_sched_action and cte_at (target, ref) and emptyable (target, ref) and (\s. \(sl, c) \ (case x of None \ {} | Some (c, sl) \ {(sl, c), (slot, c)}). cte_at sl s \ no_cap_to_obj_dr_emp c s \ valid_cap c s) and K (case x of None \ True | Some (c, sl) \ is_cnode_or_valid_arch c)) (invs' and sch_act_simple and cte_at' (cte_map (target, ref)) and (\s. \cp \ (case x' of None \ {} | Some (c, sl) \ {c}). s \' cp)) (case x of None \ returnOk () | Some pr \ case_prod (\new_cap src_slot. doE cap_delete (target, ref); liftE $ check_cap_at new_cap src_slot $ check_cap_at (cap.ThreadCap target) slot $ cap_insert new_cap src_slot (target, ref) odE) pr) (case x' of None \ returnOk () | Some pr \ (\(newCap, srcSlot). do slot \ getfn; doE uu \ cteDelete slot True; liftE (checkCapAt newCap srcSlot (checkCapAt (capability.ThreadCap target) sl' (assertDerived srcSlot newCap (cteInsert newCap srcSlot slot)))) odE od) pr)" apply (case_tac "x = None") apply (simp add: newroot_rel_def returnOk_def) apply (drule(1) mp, drule mp [OF u]) apply (clarsimp simp add: newroot_rel_def returnOk_def split_def) apply (rule corres_gen_asm) apply (rule corres_guard_imp) apply (rule corres_split_norE[OF cteDelete_corres]) apply (simp del: dc_simp) apply (erule checkCapAt_cteInsert_corres) apply (fold validE_R_def) apply (wp cap_delete_deletes cap_delete_cte_at cap_delete_valid_cap | strengthen use_no_cap_to_obj_asid_strg)+ apply (wp cteDelete_invs' cteDelete_deletes) apply (clarsimp dest!: is_cnode_or_valid_arch_cap_asid) apply clarsimp done have U2: "getThreadBufferSlot a = return (cte_map (a, tcb_cnode_index 4))" by (simp add: getThreadBufferSlot_def locateSlot_conv cte_map_def tcb_cnode_index_def tcbIPCBufferSlot_def cte_level_bits_def) have T2: "corres (dc \ dc) (einvs and simple_sched_action and tcb_at a and (\s. \(sl, c) \ (case g of None \ {} | Some (x, v) \ {(slot, cap.NullCap)} \ (case v of None \ {} | Some (c, sl) \ {(sl, c), (slot, c)})). cte_at sl s \ no_cap_to_obj_dr_emp c s \ valid_cap c s) and K (case g of None \ True | Some (x, v) \ (case v of None \ True | Some (c, sl) \ is_cnode_or_valid_arch c \ is_arch_cap c \ valid_ipc_buffer_cap c x \ is_aligned x msg_align_bits))) (invs' and sch_act_simple and tcb_at' a and (\s. \cp \ (case g' of None \ {} | Some (x, v) \ (case v of None \ {} | Some (c, sl) \ {c})). s \' cp) and K (case g' of None \ True | Some (x, v) \ is_aligned x msg_align_bits \ (case v of None \ True | Some (ac, _) \ isArchObjectCap ac)) ) (case_option (returnOk ()) (case_prod (\ptr frame. doE cap_delete (a, tcb_cnode_index 4); do y \ thread_set (tcb_ipc_buffer_update (\_. ptr)) a; y \ case_option (return ()) (case_prod (\new_cap src_slot. check_cap_at new_cap src_slot $ check_cap_at (cap.ThreadCap a) slot $ cap_insert new_cap src_slot (a, tcb_cnode_index 4))) frame; cur \ gets cur_thread; liftE $ when (cur = a) (reschedule_required) od odE)) g) (case_option (returnOk ()) (\(ptr, frame). do bufferSlot \ getThreadBufferSlot a; doE y \ cteDelete bufferSlot True; do y \ threadSet (tcbIPCBuffer_update (\_. ptr)) a; y \ (case_option (return ()) (case_prod (\newCap srcSlot. checkCapAt newCap srcSlot $ checkCapAt (capability.ThreadCap a) sl' $ assertDerived srcSlot newCap $ cteInsert newCap srcSlot bufferSlot)) frame); cur \ getCurThread; liftE $ when (cur = a) rescheduleRequired od odE od) g')" (is "corres _ ?T2_pre ?T2_pre' _ _") using z u apply - apply (rule corres_guard_imp[where P=P and P'=P' and Q="P and cte_at (a, tcb_cnode_index 4)" and Q'="P' and cte_at' (cte_map (a, cap))" for P P' a cap]) apply (cases g) apply (simp, simp add: returnOk_def) apply (clarsimp simp: liftME_def[symmetric] U2 liftE_bindE) apply (case_tac b, simp_all add: newroot_rel_def) apply (rule corres_guard_imp) apply (rule corres_split_norE) apply (rule cteDelete_corres) apply (rule_tac F="is_aligned aa msg_align_bits" in corres_gen_asm2) apply (rule corres_split_nor) apply (rule threadset_corres, (simp add: tcb_relation_def), (simp add: exst_same_def)+)[1] apply (rule corres_split[OF getCurThread_corres], clarsimp) apply (rule corres_when[OF refl rescheduleRequired_corres]) apply (wpsimp wp: gct_wp)+ apply (wp thread_set_ipc_weak_valid_sched_action|wp (once) hoare_drop_imp)+ apply simp apply (wp threadcontrol_corres_helper2 | wpc | simp)+ apply (wp|strengthen einvs_valid_etcbs)+ apply (wpsimp wp: cteDelete_invs' hoare_vcg_conj_lift) apply (fastforce simp: emptyable_def) apply fastforce apply clarsimp apply (rule corres_guard_imp) apply (rule corres_split_norE[OF cteDelete_corres]) apply (rule_tac F="is_aligned aa msg_align_bits" in corres_gen_asm) apply (rule_tac F="isArchObjectCap ac" in corres_gen_asm2) apply (rule corres_split_nor) apply (rule threadset_corres, simp add: tcb_relation_def, (simp add: exst_same_def)+) apply (rule corres_split) apply (erule checkCapAt_cteInsert_corres) apply (rule corres_split[OF getCurThread_corres], clarsimp) apply (rule corres_when[OF refl rescheduleRequired_corres]) apply (wp gct_wp)+ apply (wp hoare_drop_imp threadcontrol_corres_helper3)[1] apply (wp hoare_drop_imp threadcontrol_corres_helper4)[1] apply (wp thread_set_tcb_ipc_buffer_cap_cleared_invs thread_set_cte_wp_at_trivial thread_set_not_state_valid_sched | simp add: ran_tcb_cap_cases)+ apply (wp threadSet_invs_trivial threadSet_cte_wp_at' | simp)+ apply (wp cap_delete_deletes cap_delete_cte_at cap_delete_valid_cap cteDelete_deletes cteDelete_invs' | strengthen use_no_cap_to_obj_asid_strg | clarsimp simp: inQ_def inQ_tc_corres_helper)+ apply (clarsimp simp: cte_wp_at_caps_of_state dest!: is_cnode_or_valid_arch_cap_asid) apply (fastforce simp: emptyable_def) apply (clarsimp simp: inQ_def) apply (clarsimp simp: obj_at_def is_tcb) apply (rule cte_wp_at_tcbI, simp, fastforce, simp) apply (clarsimp simp: cte_map_def tcb_cnode_index_def obj_at'_def objBits_simps) apply (erule(2) cte_wp_at_tcbI', fastforce simp: objBits_defs cte_level_bits_def, simp) done have U: "getThreadCSpaceRoot a = return (cte_map (a, tcb_cnode_index 0))" apply (clarsimp simp add: getThreadCSpaceRoot) apply (simp add: cte_map_def tcb_cnode_index_def cte_level_bits_def word_bits_def) done have V: "getThreadVSpaceRoot a = return (cte_map (a, tcb_cnode_index 1))" apply (clarsimp simp add: getThreadVSpaceRoot) apply (simp add: cte_map_def tcb_cnode_index_def to_bl_1 objBits_defs cte_level_bits_def word_bits_def) done have X: "\x P Q R M. (\y. x = Some y \ \P y\ M y \Q\,\R\) \ \case_option (Q ()) P x\ case_option (returnOk ()) M x \Q\,\R\" by (case_tac x, simp_all, wp) have Y: "\x P Q M. (\y. x = Some y \ \P y\ M y \Q\,-) \ \case_option (Q ()) P x\ case_option (returnOk ()) M x \Q\,-" by (case_tac x, simp_all, wp) have Z: "\P f R Q x. \P\ f \\rv. Q and R\ \ \P\ f \\rv. case_option Q (\y. R) x\" apply (rule hoare_post_imp) defer apply assumption apply (case_tac x, simp_all) done have A: "\x P Q M. (\y. x = Some y \ \P y\ M y \Q\) \ \case_option (Q ()) P x\ case_option (return ()) M x \Q\" by (case_tac x, simp_all, wp) have B: "\t v. \invs' and tcb_at' t\ threadSet (tcbFaultHandler_update v) t \\rv. invs'\" by (wp threadSet_invs_trivial | clarsimp simp: inQ_def)+ note stuff = Z B out_invs_trivial hoare_case_option_wp hoare_vcg_const_Ball_lift hoare_vcg_const_Ball_lift_R cap_delete_deletes cap_delete_valid_cap out_valid_objs cap_insert_objs cteDelete_deletes cteDelete_sch_act_simple out_valid_cap out_cte_at out_tcb_valid out_emptyable CSpaceInv_AI.cap_insert_valid_cap cap_insert_cte_at cap_delete_cte_at cap_delete_tcb cteDelete_invs' checkCap_inv [where P="valid_cap' c0" for c0] check_cap_inv[where P="tcb_at p0" for p0] checkCap_inv [where P="tcb_at' p0" for p0] check_cap_inv[where P="cte_at p0" for p0] checkCap_inv [where P="cte_at' p0" for p0] check_cap_inv[where P="valid_cap c" for c] checkCap_inv [where P="valid_cap' c" for c] check_cap_inv[where P="tcb_cap_valid c p1" for c p1] check_cap_inv[where P=valid_sched] check_cap_inv[where P=simple_sched_action] checkCap_inv [where P=sch_act_simple] out_no_cap_to_trivial [OF ball_tcb_cap_casesI] checked_insert_no_cap_to note if_cong [cong] option.case_cong [cong] show ?thesis apply (simp add: invokeTCB_def liftE_bindE) apply (simp only: eq_commute[where a= "a"]) apply (rule corres_guard_imp) apply (rule corres_split_nor[OF P]) apply (rule corres_split_nor[OF S', simplified]) apply (rule corres_split_norE[OF T [OF x U], simplified]) apply (rule corres_split_norE[OF T [OF y V], simplified]) apply (rule corres_split_norE) apply (rule T2[simplified]) apply (rule corres_split_nor[OF S, simplified]) apply (rule corres_returnOkTT, simp) apply wp apply wp apply (wpsimp wp: hoare_vcg_const_imp_lift_R hoare_vcg_const_imp_lift hoare_vcg_all_lift_R hoare_vcg_all_lift as_user_invs thread_set_ipc_tcb_cap_valid thread_set_tcb_ipc_buffer_cap_cleared_invs thread_set_cte_wp_at_trivial thread_set_valid_cap reschedule_preserves_valid_sched check_cap_inv[where P=valid_sched] (* from stuff *) check_cap_inv[where P="tcb_at p0" for p0] thread_set_not_state_valid_sched cap_delete_deletes cap_delete_valid_cap simp: ran_tcb_cap_cases) apply (strengthen use_no_cap_to_obj_asid_strg) apply (wpsimp wp: cap_delete_cte_at cap_delete_valid_cap) apply (wpsimp wp: hoare_drop_imps) apply ((wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_imp_lift' hoare_vcg_all_lift threadSet_cte_wp_at' threadSet_invs_trivialT2 cteDelete_invs' simp: tcb_cte_cases_def cteSizeBits_def), (fastforce+)[6]) apply wpsimp apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift threadSet_invs_trivialT2 threadSet_cte_wp_at' simp: tcb_cte_cases_def cteSizeBits_def, (fastforce+)[6]) apply wpsimp apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift rescheduleRequired_invs' threadSet_cte_wp_at' simp: tcb_cte_cases_def) apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift rescheduleRequired_invs' threadSet_invs_trivialT2 threadSet_cte_wp_at' simp: tcb_cte_cases_def cteSizeBits_def, (fastforce+)[6]) apply wpsimp apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift rescheduleRequired_invs' threadSet_invs_trivialT2 threadSet_cte_wp_at' simp: tcb_cte_cases_def cteSizeBits_def, (fastforce+)[6]) apply wpsimp apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift rescheduleRequired_invs' threadSet_cap_to' threadSet_invs_trivialT2 threadSet_cte_wp_at' hoare_drop_imps simp: tcb_cte_cases_def cteSizeBits_def) apply (clarsimp) apply ((wpsimp wp: stuff hoare_vcg_all_lift_R hoare_vcg_all_lift hoare_vcg_const_imp_lift_R hoare_vcg_const_imp_lift threadSet_valid_objs' thread_set_not_state_valid_sched thread_set_tcb_ipc_buffer_cap_cleared_invs thread_set_cte_wp_at_trivial thread_set_no_cap_to_trivial getThreadBufferSlot_dom_tcb_cte_cases assertDerived_wp_weak threadSet_cap_to' out_pred_tcb_at_preserved checkCap_wp assertDerived_wp_weak cap_insert_objs' | simp add: ran_tcb_cap_cases split_def U V emptyable_def | strengthen tcb_cap_always_valid_strg tcb_at_invs use_no_cap_to_obj_asid_strg | (erule exE, clarsimp simp: word_bits_def))+) apply (strengthen valid_tcb_ipc_buffer_update) apply (strengthen invs_valid_objs') apply (wpsimp wp: cteDelete_invs' hoare_vcg_imp_lift' hoare_vcg_all_lift) apply wpsimp apply wpsimp apply (clarsimp cong: imp_cong conj_cong simp: emptyable_def) apply (rule_tac Q'="\_. ?T2_pre" in hoare_post_imp_R[simplified validE_R_def, rotated]) (* beginning to deal with is_nondevice_page_cap *) apply (clarsimp simp: emptyable_def is_cap_simps is_cnode_or_valid_arch_def obj_ref_none_no_asid cap_asid_def cong: conj_cong imp_cong split: option.split_asm) apply (simp add: case_bool_If valid_ipc_buffer_cap_def split: arch_cap.splits if_splits) (* is_nondevice_page_cap discharged *) apply ((wp stuff checkCap_wp assertDerived_wp_weak cap_insert_objs' | simp add: ran_tcb_cap_cases split_def U V emptyable_def | wpc | strengthen tcb_cap_always_valid_strg use_no_cap_to_obj_asid_strg)+)[1] apply (clarsimp cong: imp_cong conj_cong) apply (rule_tac Q'="\_. ?T2_pre' and (\s. valid_option_prio p_auth)" in hoare_post_imp_R[simplified validE_R_def, rotated]) apply (case_tac g'; clarsimp simp: isCap_simps ; clarsimp cong:imp_cong) apply (wp add: stuff hoare_vcg_all_lift_R hoare_vcg_all_lift hoare_vcg_const_imp_lift_R hoare_vcg_const_imp_lift setMCPriority_invs' threadSet_valid_objs' thread_set_not_state_valid_sched setP_invs' typ_at_lifts [OF setPriority_typ_at'] typ_at_lifts [OF setMCPriority_typ_at'] threadSet_cap_to' out_pred_tcb_at_preserved assertDerived_wp del: cteInsert_invs | simp add: ran_tcb_cap_cases split_def U V emptyable_def | wpc | strengthen tcb_cap_always_valid_strg use_no_cap_to_obj_asid_strg | wp (once) add: sch_act_simple_lift hoare_drop_imps del: cteInsert_invs | (erule exE, clarsimp simp: word_bits_def))+ apply (clarsimp simp: tcb_at_cte_at_0 tcb_at_cte_at_1[simplified] tcb_at_st_tcb_at[symmetric] tcb_cap_valid_def is_cnode_or_valid_arch_def invs_valid_objs emptyable_def obj_ref_none_no_asid no_cap_to_obj_with_diff_ref_Null is_valid_vtable_root_simp is_cap_simps cap_asid_def vs_cap_ref_def arch_cap_fun_lift_def invs_psp_aligned invs_distinct cong: conj_cong imp_cong split: option.split_asm) by (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def objBits_defs cte_map_tcb_0 cte_map_tcb_1[simplified] tcb_at_cte_at' cte_at_tcb_at_32' isCap_simps domIff valid_tcb'_def tcb_cte_cases_def split: option.split_asm dest!: isValidVTableRootD) qed lemmas threadSet_ipcbuffer_trivial = threadSet_invs_trivial[where F="tcbIPCBuffer_update F'" for F', simplified inQ_def, simplified] crunches setPriority, setMCPriority for cap_to'[wp]: "ex_nonz_cap_to' a" (simp: crunch_simps) lemma cteInsert_sa_simple[wp]: "cteInsert newCap srcSlot destSlot \sch_act_simple\" by (simp add: sch_act_simple_def, wp) lemma isReplyCapD: "isReplyCap cap \ \ptr master grant. cap = capability.ReplyCap ptr master grant" by (simp add: isCap_simps) lemma tc_invs': "\invs' and sch_act_simple and tcb_at' a and ex_nonz_cap_to' a and K (valid_option_prio d \ valid_option_prio mcp) and case_option \ (valid_cap' o fst) e' and K (case_option True (isCNodeCap o fst) e') and case_option \ (valid_cap' o fst) f' and K (case_option True (isValidVTableRoot o fst) f') and case_option \ (valid_cap') (case_option None (case_option None (Some o fst) o snd) g) and K (case_option True isArchObjectCap (case_option None (case_option None (Some o fst) o snd) g)) and K (case_option True (swp is_aligned msg_align_bits o fst) g) \ invokeTCB (tcbinvocation.ThreadControl a sl b' mcp d e' f' g) \\rv. invs'\" apply (rule hoare_gen_asm) apply (simp add: split_def invokeTCB_def getThreadCSpaceRoot getThreadVSpaceRoot getThreadBufferSlot_def locateSlot_conv cong: option.case_cong) apply (simp only: eq_commute[where a="a"]) apply (rule hoare_walk_assmsE) apply (clarsimp simp: pred_conj_def option.splits [where P="\x. x s" for s]) apply ((wp case_option_wp threadSet_invs_trivial hoare_weak_lift_imp hoare_vcg_all_lift threadSet_cap_to' | clarsimp simp: inQ_def)+)[2] apply (rule hoare_walk_assmsE) apply (clarsimp simp: pred_conj_def option.splits [where P="\x. x s" for s]) apply ((wp case_option_wp threadSet_invs_trivial hoare_weak_lift_imp setMCPriority_invs' typ_at_lifts[OF setMCPriority_typ_at'] hoare_vcg_all_lift threadSet_cap_to' | clarsimp simp: inQ_def)+)[2] apply (wp add: setP_invs' hoare_weak_lift_imp hoare_vcg_all_lift)+ apply (rule case_option_wp_None_return[OF setP_invs'[simplified pred_conj_assoc]]) apply clarsimp apply wpfix apply assumption apply (rule case_option_wp_None_returnOk) apply (wpsimp wp: hoare_weak_lift_imp hoare_vcg_all_lift checkCap_inv[where P="tcb_at' t" for t] assertDerived_wp_weak threadSet_invs_trivial2 threadSet_tcb' hoare_vcg_all_lift threadSet_cte_wp_at')+ apply (wpsimp wp: hoare_weak_lift_imp_R cteDelete_deletes hoare_vcg_all_lift_R hoare_vcg_conj_liftE1 hoare_vcg_const_imp_lift_R hoare_vcg_propE_R cteDelete_invs' cteDelete_invs' cteDelete_typ_at'_lifts)+ apply (assumption | clarsimp cong: conj_cong imp_cong | (rule case_option_wp_None_returnOk) | wpsimp wp: hoare_weak_lift_imp hoare_vcg_all_lift checkCap_inv[where P="tcb_at' t" for t] assertDerived_wp_weak hoare_vcg_imp_lift' hoare_vcg_all_lift checkCap_inv[where P="tcb_at' t" for t] checkCap_inv[where P="valid_cap' c" for c] checkCap_inv[where P=sch_act_simple] hoare_vcg_const_imp_lift_R assertDerived_wp_weak hoare_weak_lift_imp_R cteDelete_deletes hoare_vcg_all_lift_R hoare_vcg_conj_liftE1 hoare_vcg_const_imp_lift_R hoare_vcg_propE_R cteDelete_invs' cteDelete_typ_at'_lifts cteDelete_sch_act_simple)+ apply (clarsimp simp: tcb_cte_cases_def cte_level_bits_def objBits_defs tcbIPCBufferSlot_def) by (auto dest!: isCapDs isReplyCapD isValidVTableRootD simp: isCap_simps) lemma setSchedulerAction_invs'[wp]: "\invs' and sch_act_wf sa and (\s. sa = ResumeCurrentThread \ obj_at' (Not \ tcbQueued) (ksCurThread s) s) and (\s. sa = ResumeCurrentThread \ ksCurThread s = ksIdleThread s \ tcb_in_cur_domain' (ksCurThread s) s)\ setSchedulerAction sa \\rv. invs'\" apply (simp add: setSchedulerAction_def) apply wp apply (clarsimp simp add: invs'_def valid_state'_def valid_irq_node'_def valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs cur_tcb'_def ct_not_inQ_def) apply (simp add: ct_idle_or_in_cur_domain'_def) done end consts copyregsets_map :: "arch_copy_register_sets \ Arch.copy_register_sets" context begin interpretation Arch . (*FIXME: arch_split*) primrec tcbinv_relation :: "tcb_invocation \ tcbinvocation \ bool" where "tcbinv_relation (tcb_invocation.ReadRegisters a b c d) x = (x = tcbinvocation.ReadRegisters a b c (copyregsets_map d))" | "tcbinv_relation (tcb_invocation.WriteRegisters a b c d) x = (x = tcbinvocation.WriteRegisters a b c (copyregsets_map d))" | "tcbinv_relation (tcb_invocation.CopyRegisters a b c d e f g) x = (x = tcbinvocation.CopyRegisters a b c d e f (copyregsets_map g))" | "tcbinv_relation (tcb_invocation.ThreadControl a sl flt_ep mcp prio croot vroot buf) x = (\flt_ep' croot' vroot' sl' buf'. flt_ep = option_map to_bl flt_ep' \ newroot_rel croot croot' \ newroot_rel vroot vroot' \ ({croot, vroot, option_map undefined buf} \ {None} \ sl' = cte_map sl) \ (case buf of None \ buf' = None | Some (vptr, g'') \ \g'''. buf' = Some (vptr, g''') \ newroot_rel g'' g''') \ x = tcbinvocation.ThreadControl a sl' flt_ep' mcp prio croot' vroot' buf')" | "tcbinv_relation (tcb_invocation.Suspend a) x = (x = tcbinvocation.Suspend a)" | "tcbinv_relation (tcb_invocation.Resume a) x = (x = tcbinvocation.Resume a)" | "tcbinv_relation (tcb_invocation.NotificationControl t ntfnptr) x = (x = tcbinvocation.NotificationControl t ntfnptr)" | "tcbinv_relation (tcb_invocation.SetTLSBase ref w) x = (x = tcbinvocation.SetTLSBase ref w)" primrec tcb_inv_wf' :: "tcbinvocation \ kernel_state \ bool" where "tcb_inv_wf' (tcbinvocation.Suspend t) = (tcb_at' t and ex_nonz_cap_to' t)" | "tcb_inv_wf' (tcbinvocation.Resume t) = (tcb_at' t and ex_nonz_cap_to' t)" | "tcb_inv_wf' (tcbinvocation.ThreadControl t sl fe mcp p croot vroot buf) = (tcb_at' t and ex_nonz_cap_to' t and K (valid_option_prio p \ valid_option_prio mcp) and case_option \ (valid_cap' o fst) croot and K (case_option True (isCNodeCap o fst) croot) and case_option \ (valid_cap' o fst) vroot and K (case_option True (isValidVTableRoot o fst) vroot) and case_option \ (case_option \ (valid_cap' o fst) o snd) buf and case_option \ (case_option \ (cte_at' o snd) o snd) buf and K (case_option True (swp is_aligned msg_align_bits o fst) buf) and K (case_option True (case_option True (isArchObjectCap o fst) o snd) buf) and (\s. {croot, vroot, option_map undefined buf} \ {None} \ cte_at' sl s) and (\s. case_option True (\(pr, auth). mcpriority_tcb_at' ((\) pr) auth s) p) and (\s. case_option True (\(m, auth). mcpriority_tcb_at' ((\) m) auth s) mcp))" | "tcb_inv_wf' (tcbinvocation.ReadRegisters src susp n arch) = (tcb_at' src and ex_nonz_cap_to' src)" | "tcb_inv_wf' (tcbinvocation.WriteRegisters dest resume values arch) = (tcb_at' dest and ex_nonz_cap_to' dest)" | "tcb_inv_wf' (tcbinvocation.CopyRegisters dest src suspend_source resume_target trans_frame trans_int trans_arch) = (tcb_at' dest and tcb_at' src and ex_nonz_cap_to' src and ex_nonz_cap_to' dest)" | "tcb_inv_wf' (tcbinvocation.NotificationControl t ntfn) = (tcb_at' t and ex_nonz_cap_to' t and (case ntfn of None \ \ | Some ntfnptr \ obj_at' (\ko. ntfnBoundTCB ko = None \ (\q. ntfnObj ko \ WaitingNtfn q)) ntfnptr and ex_nonz_cap_to' ntfnptr and bound_tcb_at' ((=) None) t) )" | "tcb_inv_wf' (tcbinvocation.SetTLSBase ref w) = (tcb_at' ref and ex_nonz_cap_to' ref)" lemma invokeTCB_corres: "tcbinv_relation ti ti' \ corres (dc \ (=)) (einvs and simple_sched_action and Tcb_AI.tcb_inv_wf ti) (invs' and sch_act_simple and tcb_inv_wf' ti') (invoke_tcb ti) (invokeTCB ti')" apply (case_tac ti, simp_all only: tcbinv_relation.simps valid_tcb_invocation_def) apply (rule corres_guard_imp [OF invokeTCB_WriteRegisters_corres], simp+)[1] apply (rule corres_guard_imp [OF invokeTCB_ReadRegisters_corres], simp+)[1] apply (rule corres_guard_imp [OF invokeTCB_CopyRegisters_corres], simp+)[1] apply (clarsimp simp del: invoke_tcb.simps) apply (rename_tac word one t2 mcp t3 t4 t5 t6 t7 t8 t9 t10 t11) apply (rule_tac F="is_aligned word 5" in corres_req) apply (clarsimp simp add: is_aligned_weaken [OF tcb_aligned]) apply (rule corres_guard_imp [OF transferCaps_corres], clarsimp+) apply (clarsimp simp: is_cnode_or_valid_arch_def split: option.split option.split_asm) apply clarsimp apply (auto split: option.split_asm simp: newroot_rel_def)[1] apply (simp add: invokeTCB_def liftM_def[symmetric] o_def dc_def[symmetric]) apply (rule corres_guard_imp [OF suspend_corres], simp+) apply (simp add: invokeTCB_def liftM_def[symmetric] o_def dc_def[symmetric]) apply (rule corres_guard_imp [OF restart_corres], simp+) apply (simp add:invokeTCB_def) apply (rename_tac option) apply (case_tac option) apply simp apply (rule corres_guard_imp) apply (rule corres_split[OF unbindNotification_corres]) apply (rule corres_trivial, simp) apply wp+ apply (clarsimp) apply clarsimp apply simp apply (rule corres_guard_imp) apply (rule corres_split[OF bindNotification_corres]) apply (rule corres_trivial, simp) apply wp+ apply clarsimp apply (clarsimp simp: obj_at_def is_ntfn) apply (clarsimp simp: obj_at'_def) apply (simp add: invokeTCB_def tlsBaseRegister_def) apply (rule corres_guard_imp) apply (rule corres_split[OF TcbAcc_R.asUser_setRegister_corres]) apply (rule corres_split[OF Bits_R.getCurThread_corres]) apply (rule corres_split[OF Corres_UL.corres_when]) apply simp apply (rule TcbAcc_R.rescheduleRequired_corres) apply (rule corres_trivial, simp) apply (wpsimp wp: hoare_drop_imp)+ apply (clarsimp simp: valid_sched_weak_strg einvs_valid_etcbs invs_distinct) apply (clarsimp simp: invs_valid_queues' invs_queues) done lemma tcbBoundNotification_caps_safe[simp]: "\(getF, setF)\ran tcb_cte_cases. getF (tcbBoundNotification_update (\_. Some ntfnptr) tcb) = getF tcb" by (case_tac tcb, simp add: tcb_cte_cases_def cteSizeBits_def) lemma valid_bound_ntfn_lift: assumes P: "\P T p. \\s. P (typ_at' T p s)\ f \\rv s. P (typ_at' T p s)\" shows "\\s. valid_bound_ntfn' a s\ f \\rv s. valid_bound_ntfn' a s\" apply (simp add: valid_bound_ntfn'_def, case_tac a, simp_all) apply (wp typ_at_lifts[OF P])+ done lemma bindNotification_invs': "\bound_tcb_at' ((=) None) tcbptr and ex_nonz_cap_to' ntfnptr and ex_nonz_cap_to' tcbptr and obj_at' (\ntfn. ntfnBoundTCB ntfn = None \ (\q. ntfnObj ntfn \ WaitingNtfn q)) ntfnptr and invs'\ bindNotification tcbptr ntfnptr \\_. invs'\" including no_pre apply (simp add: bindNotification_def invs'_def valid_state'_def) apply (rule hoare_seq_ext[OF _ get_ntfn_sp']) apply (rule hoare_pre) apply (wp set_ntfn_valid_pspace' sbn_sch_act' sbn_valid_queues valid_irq_node_lift setBoundNotification_ct_not_inQ valid_bound_ntfn_lift untyped_ranges_zero_lift | clarsimp dest!: global'_no_ex_cap simp: cteCaps_of_def)+ apply (clarsimp simp: valid_pspace'_def) apply (cases "tcbptr = ntfnptr") apply (clarsimp dest!: pred_tcb_at' simp: obj_at'_def) apply (clarsimp simp: pred_tcb_at' conj_comms o_def) apply (subst delta_sym_refs, assumption) apply (fastforce simp: ntfn_q_refs_of'_def obj_at'_def dest!: symreftype_inverse' split: ntfn.splits if_split_asm) apply (clarsimp split: if_split_asm) apply (fastforce simp: tcb_st_refs_of'_def dest!: bound_tcb_at_state_refs_ofD' split: if_split_asm thread_state.splits) apply (fastforce simp: obj_at'_def state_refs_of'_def dest!: symreftype_inverse') apply (clarsimp simp: valid_pspace'_def) apply (frule_tac P="\k. k=ntfn" in obj_at_valid_objs', simp) apply (clarsimp simp: valid_obj'_def valid_ntfn'_def obj_at'_def dest!: pred_tcb_at' split: ntfn.splits) done lemma tcbntfn_invs': "\invs' and tcb_inv_wf' (tcbinvocation.NotificationControl tcb ntfnptr)\ invokeTCB (tcbinvocation.NotificationControl tcb ntfnptr) \\rv. invs'\" apply (simp add: invokeTCB_def) apply (case_tac ntfnptr, simp_all) apply (wp unbindNotification_invs bindNotification_invs' | simp)+ done lemma setTLSBase_invs'[wp]: "\invs' and tcb_inv_wf' (tcbinvocation.SetTLSBase tcb tls_base)\ invokeTCB (tcbinvocation.SetTLSBase tcb tls_base) \\rv. invs'\" by (wpsimp simp: invokeTCB_def) lemma tcbinv_invs': "\invs' and sch_act_simple and ct_in_state' runnable' and tcb_inv_wf' ti\ invokeTCB ti \\rv. invs'\" apply (case_tac ti, simp_all only:) apply (simp add: invokeTCB_def) apply wp apply (clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) apply (simp add: invokeTCB_def) apply (wp restart_invs') apply (clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) apply (wp tc_invs') apply (clarsimp split: option.split dest!: isCapDs) apply (wp writereg_invs' readreg_invs' copyreg_invs' tcbntfn_invs' | simp)+ done declare assertDerived_wp [wp] lemma copyregsets_map_only[simp]: "copyregsets_map v = RISCVNoExtraRegisters" by (cases "copyregsets_map v", simp) lemma decodeReadRegisters_corres: "corres (ser \ tcbinv_relation) (invs and tcb_at t) (invs' and tcb_at' t) (decode_read_registers args (cap.ThreadCap t)) (decodeReadRegisters args (ThreadCap t))" apply (simp add: decode_read_registers_def decodeReadRegisters_def) apply (cases args, simp_all) apply (case_tac list, simp_all) apply (simp add: decodeTransfer_def) apply (simp add: range_check_def rangeCheck_def frameRegisters_def gpRegisters_def) apply (simp add: unlessE_def split del: if_split, simp add: returnOk_def split del: if_split) apply (rule corres_guard_imp) apply (rule corres_split_norE) apply (rule corres_trivial) apply (fastforce simp: returnOk_def) apply (simp add: liftE_bindE) apply (rule corres_split[OF getCurThread_corres]) apply (rule corres_trivial) apply (clarsimp simp: whenE_def) apply (wp|simp)+ done lemma decodeWriteRegisters_corres: notes if_cong [cong] shows "\ length args < 2 ^ word_bits \ \ corres (ser \ tcbinv_relation) (invs and tcb_at t) (invs' and tcb_at' t) (decode_write_registers args (cap.ThreadCap t)) (decodeWriteRegisters args (ThreadCap t))" apply (simp add: decode_write_registers_def decodeWriteRegisters_def) apply (cases args, simp_all) apply (case_tac list, simp_all) apply (simp add: decodeTransfer_def genericLength_def) apply (simp add: word_less_nat_alt unat_of_nat64) apply (simp add: whenE_def, simp add: returnOk_def) apply (simp add: genericTake_def) apply clarsimp apply (rule corres_guard_imp) apply (simp add: liftE_bindE) apply (rule corres_split[OF getCurThread_corres]) apply (rule corres_split_norE) apply (rule corres_trivial, simp) apply (rule corres_trivial, simp) apply (wp)+ apply simp+ done lemma decodeCopyRegisters_corres: "\ list_all2 cap_relation extras extras'; length args < 2 ^ word_bits \ \ corres (ser \ tcbinv_relation) (invs and tcb_at t) (invs' and tcb_at' t) (decode_copy_registers args (cap.ThreadCap t) extras) (decodeCopyRegisters args (ThreadCap t) extras')" apply (simp add: decode_copy_registers_def decodeCopyRegisters_def) apply (cases args, simp_all) apply (cases extras, simp_all add: decodeTransfer_def null_def) apply (clarsimp simp: list_all2_Cons1 null_def) apply (case_tac aa, simp_all) apply (simp add: returnOk_def) apply clarsimp done lemma decodeReadReg_wf: "\invs' and tcb_at' t and ex_nonz_cap_to' t\ decodeReadRegisters args (ThreadCap t) \tcb_inv_wf'\,-" apply (simp add: decodeReadRegisters_def decodeTransfer_def whenE_def cong: list.case_cong) apply (rule hoare_pre) apply (wp | wpc)+ apply simp done lemma decodeWriteReg_wf: "\invs' and tcb_at' t and ex_nonz_cap_to' t\ decodeWriteRegisters args (ThreadCap t) \tcb_inv_wf'\,-" apply (simp add: decodeWriteRegisters_def whenE_def decodeTransfer_def cong: list.case_cong) apply (rule hoare_pre) apply (wp | wpc)+ apply simp done lemma decodeCopyReg_wf: "\invs' and tcb_at' t and ex_nonz_cap_to' t and (\s. \x \ set extras. s \' x \ (\y \ zobj_refs' x. ex_nonz_cap_to' y s))\ decodeCopyRegisters args (ThreadCap t) extras \tcb_inv_wf'\,-" apply (simp add: decodeCopyRegisters_def whenE_def decodeTransfer_def cong: list.case_cong capability.case_cong bool.case_cong split del: if_split) apply (rule hoare_pre) apply (wp | wpc)+ apply (clarsimp simp: null_def neq_Nil_conv valid_cap'_def[where c="ThreadCap t" for t]) done lemma eq_ucast_word8[simp]: "((ucast (x :: 8 word) :: machine_word) = ucast y) = (x = y)" apply safe apply (drule_tac f="ucast :: (machine_word \ 8 word)" in arg_cong) apply (simp add: ucast_up_ucast_id is_up_def source_size_def target_size_def word_size) done lemma checkPrio_corres: "corres (ser \ dc) (tcb_at auth and pspace_aligned and pspace_distinct) \ (check_prio p auth) (checkPrio p auth)" apply (simp add: check_prio_def checkPrio_def) apply (rule corres_guard_imp) apply (simp add: liftE_bindE) apply (rule corres_split[OF threadGet_corres[where r="(=)"]]) apply (clarsimp simp: tcb_relation_def) apply (rule_tac rvr = dc and R = \ and R' = \ in whenE_throwError_corres'[where m="returnOk ()" and m'="returnOk ()", simplified]) apply (simp add: minPriority_def) apply (clarsimp simp: minPriority_def) apply (rule corres_returnOkTT) apply (simp add: minPriority_def) apply (wp gct_wp)+ apply (simp add: cur_tcb_def cur_tcb'_def)+ done lemma decodeSetPriority_corres: "\ cap_relation cap cap'; is_thread_cap cap; list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras' \ \ corres (ser \ tcbinv_relation) (cur_tcb and valid_etcbs and (pspace_aligned and pspace_distinct and (\s. \x \ set extras. s \ (fst x)))) (invs' and (\s. \x \ set extras'. s \' (fst x))) (decode_set_priority args cap slot extras) (decodeSetPriority args cap' extras')" apply (cases args; cases extras; cases extras'; clarsimp simp: decode_set_priority_def decodeSetPriority_def) apply (rename_tac auth_cap auth_slot auth_path rest auth_cap' rest') apply (rule corres_split_eqrE) apply corresKsimp apply (rule corres_splitEE[OF checkPrio_corres]) apply (rule corres_returnOkTT) apply (clarsimp simp: newroot_rel_def elim!: is_thread_cap.elims(2)) by (wpsimp simp: valid_cap_def valid_cap'_def)+ lemma decodeSetMCPriority_corres: "\ cap_relation cap cap'; is_thread_cap cap; list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras' \ \ corres (ser \ tcbinv_relation) (cur_tcb and valid_etcbs and (pspace_aligned and pspace_distinct and (\s. \x \ set extras. s \ (fst x)))) (invs' and (\s. \x \ set extras'. s \' (fst x))) (decode_set_mcpriority args cap slot extras) (decodeSetMCPriority args cap' extras')" apply (cases args; cases extras; cases extras'; clarsimp simp: decode_set_mcpriority_def decodeSetMCPriority_def) apply (rename_tac auth_cap auth_slot auth_path rest auth_cap' rest') apply (rule corres_split_eqrE) apply corresKsimp apply (rule corres_splitEE[OF checkPrio_corres]) apply (rule corres_returnOkTT) apply (clarsimp simp: newroot_rel_def elim!: is_thread_cap.elims(2)) by (wpsimp simp: valid_cap_def valid_cap'_def)+ lemma valid_objs'_maxPriority': "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbMCP tcb \ maxPriority) t s" apply (erule (1) valid_objs_valid_tcbE) apply (clarsimp simp: valid_tcb'_def) done lemma getMCP_sp: "\P\ threadGet tcbMCP t \\rv. mcpriority_tcb_at' (\st. st = rv) t and P\" apply (simp add: threadGet_def) apply wp apply (simp add: o_def pred_tcb_at'_def) apply (wp getObject_tcb_wp) apply (clarsimp simp: obj_at'_def) done lemma getMCP_wp: "\\s. \mcp. mcpriority_tcb_at' ((=) mcp) t s \ P mcp s\ threadGet tcbMCP t \P\" apply (rule hoare_post_imp) prefer 2 apply (rule getMCP_sp) apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) done lemma checkPrio_wp: "\ \s. mcpriority_tcb_at' (\mcp. prio \ ucast mcp) auth s \ P s \ checkPrio prio auth \ \rv. P \,-" apply (simp add: checkPrio_def) apply (wp Nondet_VCG.whenE_throwError_wp getMCP_wp) by (auto simp add: pred_tcb_at'_def obj_at'_def) lemma checkPrio_lt_ct: "\\\ checkPrio prio auth \\rv s. mcpriority_tcb_at' (\mcp. prio \ ucast mcp) auth s\, -" by (wp checkPrio_wp) simp lemma checkPrio_lt_ct_weak: "\\\ checkPrio prio auth \\rv s. mcpriority_tcb_at' (\mcp. ucast prio \ mcp) auth s\, -" apply (rule hoare_post_imp_R) apply (rule checkPrio_lt_ct) apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) by (rule le_ucast_ucast_le) simp crunch inv: checkPrio "P" lemma decodeSetPriority_wf[wp]: "\invs' and tcb_at' t and ex_nonz_cap_to' t \ decodeSetPriority args (ThreadCap t) extras \tcb_inv_wf'\,-" unfolding decodeSetPriority_def apply (wpsimp wp: checkPrio_lt_ct_weak | wp (once) checkPrio_inv)+ apply (clarsimp simp: maxPriority_def numPriorities_def) apply unat_arith apply simp done lemma decodeSetPriority_inv[wp]: "\P\ decodeSetPriority args cap extras \\rv. P\" apply (simp add: decodeSetPriority_def Let_def split del: if_split) apply (rule hoare_pre) apply (wp checkPrio_inv | simp add: whenE_def split del: if_split | rule hoare_drop_imps | wpcw)+ done lemma decodeSetMCPriority_wf[wp]: "\invs' and tcb_at' t and ex_nonz_cap_to' t \ decodeSetMCPriority args (ThreadCap t) extras \tcb_inv_wf'\,-" unfolding decodeSetMCPriority_def Let_def apply (rule hoare_pre) apply (wp checkPrio_lt_ct_weak | wpc | simp | wp (once) checkPrio_inv)+ apply (clarsimp simp: maxPriority_def numPriorities_def) using max_word_max [of \UCAST(64 \ 8) x\ for x] apply (simp add: max_word_mask numeral_eq_Suc mask_Suc) done lemma decodeSetMCPriority_inv[wp]: "\P\ decodeSetMCPriority args cap extras \\rv. P\" apply (simp add: decodeSetMCPriority_def Let_def split del: if_split) apply (rule hoare_pre) apply (wp checkPrio_inv | simp add: whenE_def split del: if_split | rule hoare_drop_imps | wpcw)+ done lemma decodeSetSchedParams_wf[wp]: "\invs' and tcb_at' t and ex_nonz_cap_to' t \ decodeSetSchedParams args (ThreadCap t) extras \tcb_inv_wf'\,-" unfolding decodeSetSchedParams_def apply (wpsimp wp: checkPrio_lt_ct_weak | wp (once) checkPrio_inv)+ apply (clarsimp simp: maxPriority_def numPriorities_def) using max_word_max [of \UCAST(64 \ 8) x\ for x] apply (simp add: max_word_mask numeral_eq_Suc mask_Suc) done lemma decodeSetSchedParams_corres: "\ cap_relation cap cap'; is_thread_cap cap; list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras' \ \ corres (ser \ tcbinv_relation) (cur_tcb and valid_etcbs and (pspace_aligned and pspace_distinct and (\s. \x \ set extras. s \ (fst x)))) (invs' and (\s. \x \ set extras'. s \' (fst x))) (decode_set_sched_params args cap slot extras) (decodeSetSchedParams args cap' extras')" apply (simp add: decode_set_sched_params_def decodeSetSchedParams_def) apply (cases "length args < 2") apply (clarsimp split: list.split) apply (cases "length extras < 1") apply (clarsimp split: list.split simp: list_all2_Cons2) apply (clarsimp simp: list_all2_Cons1 neq_Nil_conv val_le_length_Cons linorder_not_less) apply (rule corres_split_eqrE) apply corresKsimp apply (rule corres_split_norE[OF checkPrio_corres]) apply (rule corres_splitEE[OF checkPrio_corres]) apply (rule corres_returnOkTT) apply (clarsimp simp: newroot_rel_def elim!: is_thread_cap.elims(2)) apply (wpsimp wp: check_prio_inv checkPrio_inv simp: valid_cap_def valid_cap'_def)+ done lemma checkValidIPCBuffer_corres: "cap_relation cap cap' \ corres (ser \ dc) \ \ (check_valid_ipc_buffer vptr cap) (checkValidIPCBuffer vptr cap')" apply (simp add: check_valid_ipc_buffer_def checkValidIPCBuffer_def unlessE_def Let_def split: cap_relation_split_asm arch_cap.split_asm bool.splits) apply (simp add: capTransferDataSize_def msgMaxLength_def msg_max_length_def msgMaxExtraCaps_def cap_transfer_data_size_def word_size ipcBufferSizeBits_def msgLengthBits_def msgExtraCapBits_def msg_align_bits msgAlignBits_def msg_max_extra_caps_def is_aligned_mask whenE_def split:vmpage_size.splits) apply (auto simp add: returnOk_def) done lemma checkValidIPCBuffer_ArchObject_wp: "\\s. isArchObjectCap cap \ is_aligned x msg_align_bits \ P s\ checkValidIPCBuffer x cap \\rv s. P s\,-" apply (simp add: checkValidIPCBuffer_def whenE_def unlessE_def cong: capability.case_cong arch_capability.case_cong split del: if_split) apply (rule hoare_pre) apply (wp whenE_throwError_wp | wpc | clarsimp simp: ipcBufferSizeBits_def isCap_simps is_aligned_mask msg_align_bits msgAlignBits_def)+ done lemma decodeSetIPCBuffer_corres: notes if_cong [cong] shows "\ cap_relation cap cap'; is_thread_cap cap; list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras' \ \ corres (ser \ tcbinv_relation) (\s. \x \ set extras. cte_at (snd x) s) (\s. invs' s \ (\x \ set extras'. cte_at' (snd x) s)) (decode_set_ipc_buffer args cap slot extras) (decodeSetIPCBuffer args cap' (cte_map slot) extras')" apply (simp add: decode_set_ipc_buffer_def decodeSetIPCBuffer_def split del: if_split) apply (cases args) apply simp apply (cases extras) apply simp apply (clarsimp simp: list_all2_Cons1 liftME_def[symmetric] is_cap_simps split del: if_split) apply (clarsimp simp add: returnOk_def newroot_rel_def) apply (rule corres_guard_imp) apply (rule corres_splitEE) apply (rule deriveCap_corres; simp) apply (simp add: o_def newroot_rel_def split_def dc_def[symmetric]) apply (erule checkValidIPCBuffer_corres) apply (wp hoareE_TrueI | simp)+ apply fastforce done lemma decodeSetIPC_wf[wp]: "\invs' and tcb_at' t and ex_nonz_cap_to' t and cte_at' slot and (\s. \v \ set extras. s \' fst v \ cte_at' (snd v) s)\ decodeSetIPCBuffer args (ThreadCap t) slot extras \tcb_inv_wf'\,-" apply (simp add: decodeSetIPCBuffer_def Let_def whenE_def split del: if_split cong: list.case_cong prod.case_cong) apply (rule hoare_pre) apply (wp | wpc | simp)+ apply (rule checkValidIPCBuffer_ArchObject_wp) apply simp apply (wp hoare_drop_imps) apply clarsimp done lemma decodeSetIPCBuffer_is_tc[wp]: "\\\ decodeSetIPCBuffer args cap slot extras \\rv s. isThreadControl rv\,-" apply (simp add: decodeSetIPCBuffer_def Let_def split del: if_split cong: list.case_cong prod.case_cong) apply (rule hoare_pre) apply (wp | wpc)+ apply (simp only: isThreadControl_def tcbinvocation.simps) apply wp+ apply (clarsimp simp: isThreadControl_def) done lemma decodeSetPriority_is_tc[wp]: "\\\ decodeSetPriority args cap extras \\rv s. isThreadControl rv\,-" apply (simp add: decodeSetPriority_def) apply wpsimp apply (clarsimp simp: isThreadControl_def) done lemma decodeSetMCPriority_is_tc[wp]: "\\\ decodeSetMCPriority args cap extras \\rv s. isThreadControl rv\,-" apply (simp add: decodeSetMCPriority_def) apply wpsimp apply (clarsimp simp: isThreadControl_def) done crunch inv[wp]: decodeSetIPCBuffer "P" (simp: crunch_simps) lemma slotCapLongRunningDelete_corres: "cte_map ptr = ptr' \ corres (=) (cte_at ptr and invs) invs' (slot_cap_long_running_delete ptr) (slotCapLongRunningDelete ptr')" apply (clarsimp simp: slot_cap_long_running_delete_def slotCapLongRunningDelete_def) apply (rule corres_guard_imp) apply (rule corres_split[OF get_cap_corres]) apply (auto split: cap_relation_split_asm arch_cap.split_asm intro!: corres_rel_imp [OF isFinalCapability_corres[where ptr=ptr]] simp: liftM_def[symmetric] final_matters'_def long_running_delete_def longRunningDelete_def isCap_simps)[1] apply (wp get_cap_wp getCTE_wp)+ apply clarsimp apply (clarsimp simp: cte_wp_at_ctes_of) apply fastforce done lemma slot_long_running_inv'[wp]: "\P\ slotCapLongRunningDelete ptr \\rv. P\" apply (simp add: slotCapLongRunningDelete_def) apply (rule hoare_seq_ext [OF _ getCTE_inv]) apply (rule hoare_pre, wpcw, (wp isFinalCapability_inv)+) apply simp done lemma cap_CNode_case_throw: "(case cap of CNodeCap a b c d \ m | _ \ throw x) = (doE unlessE (isCNodeCap cap) (throw x); m odE)" by (cases cap, simp_all add: isCap_simps unlessE_def) lemma decodeSetSpace_corres: notes if_cong [cong] shows "\ cap_relation cap cap'; list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras'; is_thread_cap cap \ \ corres (ser \ tcbinv_relation) (invs and valid_cap cap and (\s. \x \ set extras. cte_at (snd x) s)) (invs' and valid_cap' cap' and (\s. \x \ set extras'. cte_at' (snd x) s)) (decode_set_space args cap slot extras) (decodeSetSpace args cap' (cte_map slot) extras')" apply (simp add: decode_set_space_def decodeSetSpace_def Let_def split del: if_split) apply (cases "3 \ length args \ 2 \ length extras'") apply (clarsimp simp: val_le_length_Cons list_all2_Cons2 split del: if_split) apply (simp add: liftE_bindE liftM_def unlessE_throwError_returnOk unlessE_whenE bindE_assoc cap_CNode_case_throw getThreadCSpaceRoot getThreadVSpaceRoot split del: if_split) apply (rule corres_guard_imp) apply (rule corres_split[OF slotCapLongRunningDelete_corres]) apply (clarsimp simp: is_cap_simps get_tcb_ctable_ptr_def cte_map_tcb_0) apply (rule corres_split[OF slotCapLongRunningDelete_corres]) apply (clarsimp simp: is_cap_simps get_tcb_vtable_ptr_def cte_map_tcb_1[simplified]) apply (rule corres_split_norE) apply (rule corres_whenE) apply simp apply (rule corres_trivial, simp) apply simp apply (rule corres_splitEE[OF deriveCap_corres]) apply (fastforce dest: list_all2_nthD2[where p=0] simp: cap_map_update_data) apply (fastforce dest: list_all2_nthD2[where p=0]) apply (rule corres_split_norE) apply (rule corres_whenE) apply simp apply (rule corres_trivial, simp) apply simp apply (rule corres_splitEE[OF deriveCap_corres]) apply (clarsimp simp: cap_map_update_data) apply simp apply (rule corres_split_norE) apply (rule corres_whenE) apply (case_tac vroot_cap', simp_all add: is_valid_vtable_root_def isValidVTableRoot_def)[1] apply (rename_tac arch_cap) apply (clarsimp, case_tac arch_cap, simp_all)[1] apply (simp split: option.split) apply (rule corres_trivial, simp) apply simp apply (rule corres_trivial) apply (clarsimp simp: returnOk_def newroot_rel_def is_cap_simps list_all2_conv_all_nth split_def) apply wp+ apply ((simp only: simp_thms pred_conj_def | wp)+)[2] apply (unfold whenE_def, wp+)[2] apply ((simp split del: if_split | wp | rule hoare_drop_imps)+)[2] apply (unfold whenE_def, wp+)[2] apply simp apply (wp hoare_drop_imps)+ apply (clarsimp simp: get_tcb_ctable_ptr_def get_tcb_vtable_ptr_def is_cap_simps valid_cap_def tcb_at_cte_at_0 tcb_at_cte_at_1[simplified]) apply fastforce apply (frule list_all2_lengthD) apply (clarsimp split: list.split) done lemma decodeSetSpace_wf[wp]: "\invs' and tcb_at' t and ex_nonz_cap_to' t and cte_at' slot and (\s. \x \ set extras. s \' fst x \ cte_at' (snd x) s \ t \ snd x \ t + 32 \ snd x)\ decodeSetSpace args (ThreadCap t) slot extras \tcb_inv_wf'\,-" apply (simp add: decodeSetSpace_def Let_def split_def unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot cap_CNode_case_throw split del: if_split cong: if_cong list.case_cong) apply (rule hoare_pre) apply (wp | simp add: o_def split_def split del: if_split | wpc | rule hoare_drop_imps)+ apply (clarsimp simp del: length_greater_0_conv split del: if_split) apply (simp del: length_greater_0_conv add: valid_updateCapDataI) done lemma decodeSetSpace_inv[wp]: "\P\ decodeSetSpace args cap slot extras \\rv. P\" apply (simp add: decodeSetSpace_def Let_def split_def unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot split del: if_split cong: if_cong list.case_cong) apply (rule hoare_pre) apply (wp hoare_drop_imps | simp add: o_def split_def split del: if_split | wpcw)+ done lemma decodeSetSpace_is_tc[wp]: "\\\ decodeSetSpace args cap slot extras \\rv s. isThreadControl rv\,-" apply (simp add: decodeSetSpace_def Let_def split_def unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot split del: if_split cong: list.case_cong) apply (rule hoare_pre) apply (wp hoare_drop_imps | simp only: isThreadControl_def tcbinvocation.simps | wpcw)+ apply simp done lemma decodeSetSpace_tc_target[wp]: "\\s. P (capTCBPtr cap)\ decodeSetSpace args cap slot extras \\rv s. P (tcThread rv)\,-" apply (simp add: decodeSetSpace_def Let_def split_def unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot split del: if_split cong: list.case_cong) apply (rule hoare_pre) apply (wp hoare_drop_imps | simp only: tcbinvocation.sel | wpcw)+ apply simp done lemma decodeSetSpace_tc_slot[wp]: "\\s. P slot\ decodeSetSpace args cap slot extras \\rv s. P (tcThreadCapSlot rv)\,-" apply (simp add: decodeSetSpace_def split_def unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot cong: list.case_cong) apply (rule hoare_pre) apply (wp hoare_drop_imps | wpcw | simp only: tcbinvocation.sel)+ apply simp done lemma decodeTCBConfigure_corres: notes if_cong [cong] option.case_cong [cong] shows "\ cap_relation cap cap'; list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras'; is_thread_cap cap \ \ corres (ser \ tcbinv_relation) (einvs and valid_cap cap and (\s. \x \ set extras. cte_at (snd x) s)) (invs' and valid_cap' cap' and (\s. \x \ set extras'. cte_at' (snd x) s)) (decode_tcb_configure args cap slot extras) (decodeTCBConfigure args cap' (cte_map slot) extras')" apply (clarsimp simp add: decode_tcb_configure_def decodeTCBConfigure_def) apply (cases "length args < 4") apply (clarsimp split: list.split) apply (cases "length extras < 3") apply (clarsimp split: list.split simp: list_all2_Cons2) apply (clarsimp simp: linorder_not_less val_le_length_Cons list_all2_Cons1 priorityBits_def) apply (rule corres_guard_imp) apply (rule corres_splitEE) apply (rule decodeSetIPCBuffer_corres; simp) apply (rule corres_splitEE) apply (rule decodeSetSpace_corres; simp) apply (rule_tac F="tcb_invocation.is_ThreadControl set_params" in corres_gen_asm) apply (rule_tac F="tcb_invocation.is_ThreadControl set_space" in corres_gen_asm) apply (rule_tac F="tcThreadCapSlot setSpace = cte_map slot" in corres_gen_asm2) apply (rule corres_trivial) apply (clarsimp simp: tcb_invocation.is_ThreadControl_def returnOk_def is_cap_simps) apply (wp | simp add: invs_def valid_sched_def)+ done lemma isThreadControl_def2: "isThreadControl tinv = (\a b c d e f g h. tinv = ThreadControl a b c d e f g h)" by (cases tinv, simp_all add: isThreadControl_def) lemma decodeSetSpaceSome[wp]: "\\\ decodeSetSpace xs cap y zs \\rv s. tcNewCRoot rv \ None\,-" apply (simp add: decodeSetSpace_def split_def cap_CNode_case_throw cong: list.case_cong if_cong del: not_None_eq) apply (rule hoare_pre) apply (wp hoare_drop_imps | wpcw | simp only: tcbinvocation.sel option.simps)+ apply simp done lemma decodeTCBConf_wf[wp]: "\invs' and tcb_at' t and ex_nonz_cap_to' t and cte_at' slot and (\s. \x \ set extras. s \' fst x \ cte_at' (snd x) s \ t \ snd x \ t + 2^cteSizeBits \ snd x)\ decodeTCBConfigure args (ThreadCap t) slot extras \tcb_inv_wf'\,-" apply (clarsimp simp add: decodeTCBConfigure_def Let_def split del: if_split cong: list.case_cong) apply (rule hoare_pre) apply (wp | wpc)+ apply (rule_tac Q'="\setSpace s. tcb_inv_wf' setSpace s \ tcb_inv_wf' setIPCParams s \ isThreadControl setSpace \ isThreadControl setIPCParams \ tcThread setSpace = t \ tcNewCRoot setSpace \ None" in hoare_post_imp_R) apply wp apply (clarsimp simp: isThreadControl_def2 cong: option.case_cong) apply wpsimp apply (fastforce simp: isThreadControl_def2 objBits_defs) done declare hoare_True_E_R [simp del] lemma lsft_real_cte: "\valid_objs'\ lookupSlotForThread t x \\rv. real_cte_at' rv\, -" apply (simp add: lookupSlotForThread_def) apply (wp resolveAddressBits_real_cte_at'|simp add: split_def)+ done lemma tcb_real_cte_32: "\ real_cte_at' (t + 2^cteSizeBits) s; tcb_at' t s \ \ False" by (clarsimp simp: obj_at'_def objBitsKO_def ps_clear_32) lemma corres_splitEE': assumes x: "corres_underlying sr nf nf' (f \ r') P P' a c" assumes y: "\x y x' y'. r' (x, y) (x', y') \ corres_underlying sr nf nf' (f \ r) (R x y) (R' x' y') (b x y) (d x' y')" assumes z: "\Q\ a \%(x, y). R x y \,\\\\" "\Q'\ c \%(x, y). R' x y\,\\\\" shows "corres_underlying sr nf nf' (f \ r) (P and Q) (P' and Q') (a >>=E (\(x, y). b x y)) (c >>=E (\(x, y). d x y))" using assms apply (unfold bindE_def validE_def split_def) apply (rule corres_split[rotated 2]) apply assumption+ apply (case_tac rv) apply (clarsimp simp: lift_def y)+ done lemma decodeBindNotification_corres: notes if_cong[cong] shows "\ list_all2 (\x y. cap_relation (fst x) (fst y)) extras extras' \ \ corres (ser \ tcbinv_relation) (invs and tcb_at t and (\s. \x \ set extras. s \ (fst x))) (invs' and tcb_at' t and (\s. \x \ set extras'. s \' (fst x))) (decode_bind_notification (cap.ThreadCap t) extras) (decodeBindNotification (capability.ThreadCap t) extras')" apply (simp add: decode_bind_notification_def decodeBindNotification_def) apply (simp add: null_def returnOk_def) apply (rule corres_guard_imp) apply (rule corres_split_norE) apply (rule corres_trivial) apply (auto simp: returnOk_def whenE_def)[1] apply (rule_tac F="extras \ []" in corres_gen_asm) apply (rule corres_split_eqrE) apply simp apply (rule getBoundNotification_corres) apply (rule corres_split_norE) apply (rule corres_trivial, simp split: option.splits add: returnOk_def) apply (rule corres_splitEE'[where r'="\rv rv'. ((fst rv) = (fst rv')) \ ((snd rv') = (AllowRead \ (snd rv)))"]) apply (rule corres_trivial, simp) apply (case_tac extras, simp, clarsimp simp: list_all2_Cons1) apply (fastforce split: cap.splits capability.splits simp: returnOk_def) apply (rule corres_split_norE) apply (rule corres_trivial, clarsimp simp: whenE_def returnOk_def) apply (clarsimp split del: if_split) apply (rule corres_splitEE[where r'=ntfn_relation]) apply simp apply (rule getNotification_corres) apply (rule corres_trivial, simp split del: if_split) apply (simp add: ntfn_relation_def split: Structures_A.ntfn.splits Structures_H.ntfn.splits option.splits) apply wp+ apply (wp | simp add: whenE_def split del: if_split)+ apply (wp | wpc | simp)+ apply (simp | wp gbn_wp gbn_wp')+ apply (fastforce simp: valid_cap_def valid_cap'_def dest: hd_in_set)+ done lemma decodeUnbindNotification_corres: "corres (ser \ tcbinv_relation) (tcb_at t and pspace_aligned and pspace_distinct) \ (decode_unbind_notification (cap.ThreadCap t)) (decodeUnbindNotification (capability.ThreadCap t))" apply (simp add: decode_unbind_notification_def decodeUnbindNotification_def) apply (rule corres_guard_imp) apply (rule corres_split_eqrE) apply simp apply (rule getBoundNotification_corres) apply (rule corres_trivial) apply (simp split: option.splits) apply (simp add: returnOk_def) apply wp+ apply auto done lemma decodeSetTLSBase_corres: "corres (ser \ tcbinv_relation) (tcb_at t) (tcb_at' t) (decode_set_tls_base w (cap.ThreadCap t)) (decodeSetTLSBase w (capability.ThreadCap t))" by (clarsimp simp: decode_set_tls_base_def decodeSetTLSBase_def returnOk_def split: list.split) lemma decodeTCBInvocation_corres: "\ c = Structures_A.ThreadCap t; cap_relation c c'; list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras'; length args < 2 ^ word_bits \ \ corres (ser \ tcbinv_relation) (einvs and tcb_at t and (\s. \x \ set extras. s \ fst x \ cte_at (snd x) s)) (invs' and tcb_at' t and (\s. \x \ set extras'. s \' fst x \ cte_at' (snd x) s)) (decode_tcb_invocation label args c slot extras) (decodeTCBInvocation label args c' (cte_map slot) extras')" apply (rule_tac F="cap_aligned c \ capAligned c'" in corres_req) apply (clarsimp simp: cap_aligned_def capAligned_def objBits_simps word_bits_def) apply (drule obj_at_aligned', simp_all add: objBits_simps') apply (clarsimp simp: decode_tcb_invocation_def decodeTCBInvocation_def split del: if_split split: gen_invocation_labels.split) apply (simp add: returnOk_def) apply (intro conjI impI corres_guard_imp[OF decodeReadRegisters_corres] corres_guard_imp[OF decodeWriteRegisters_corres] corres_guard_imp[OF decodeCopyRegisters_corres] corres_guard_imp[OF decodeTCBConfigure_corres] corres_guard_imp[OF decodeSetPriority_corres] corres_guard_imp[OF decodeSetMCPriority_corres] corres_guard_imp[OF decodeSetSchedParams_corres] corres_guard_imp[OF decodeSetIPCBuffer_corres] corres_guard_imp[OF decodeSetSpace_corres] corres_guard_imp[OF decodeBindNotification_corres] corres_guard_imp[OF decodeUnbindNotification_corres] corres_guard_imp[OF decodeSetTLSBase_corres], simp_all add: valid_cap_simps valid_cap_simps' invs_def valid_state_def valid_pspace_def valid_sched_def) apply (auto simp: list_all2_map1 list_all2_map2 elim!: list_all2_mono) done crunch inv[wp]: decodeTCBInvocation P (simp: crunch_simps) lemma real_cte_at_not_tcb_at': "real_cte_at' x s \ \ tcb_at' x s" "real_cte_at' (x + 2^cteSizeBits) s \ \ tcb_at' x s" apply (clarsimp simp: obj_at'_def) apply (clarsimp elim!: tcb_real_cte_32) done lemma decodeBindNotification_wf: "\invs' and tcb_at' t and ex_nonz_cap_to' t and (\s. \x \ set extras. s \' (fst x) \ (\y \ zobj_refs' (fst x). ex_nonz_cap_to' y s))\ decodeBindNotification (capability.ThreadCap t) extras \tcb_inv_wf'\,-" apply (simp add: decodeBindNotification_def whenE_def cong: list.case_cong split del: if_split) apply (rule hoare_pre) apply (wp getNotification_wp getObject_tcb_wp | wpc | simp add: threadGet_def getBoundNotification_def)+ apply (fastforce simp: valid_cap'_def[where c="capability.ThreadCap t"] is_ntfn invs_def valid_state'_def valid_pspace'_def null_def pred_tcb_at'_def obj_at'_def dest!: global'_no_ex_cap hd_in_set) done lemma decodeUnbindNotification_wf: "\invs' and tcb_at' t and ex_nonz_cap_to' t\ decodeUnbindNotification (capability.ThreadCap t) \tcb_inv_wf'\,-" apply (simp add: decodeUnbindNotification_def) apply (wp getObject_tcb_wp | wpc | simp add: threadGet_def getBoundNotification_def)+ apply (auto simp: obj_at'_def pred_tcb_at'_def) done lemma decodeSetTLSBase_wf: "\invs' and tcb_at' t and ex_nonz_cap_to' t\ decodeSetTLSBase w (capability.ThreadCap t) \tcb_inv_wf'\,-" apply (simp add: decodeSetTLSBase_def cong: list.case_cong) by wpsimp lemma decodeTCBInv_wf: "\invs' and tcb_at' t and cte_at' slot and ex_nonz_cap_to' t and (\s. \x \ set extras. real_cte_at' (snd x) s \ s \' fst x \ (\y \ zobj_refs' (fst x). ex_nonz_cap_to' y s))\ decodeTCBInvocation label args (capability.ThreadCap t) slot extras \tcb_inv_wf'\,-" apply (simp add: decodeTCBInvocation_def Let_def cong: if_cong gen_invocation_labels.case_cong split del: if_split) apply (rule hoare_pre) apply (wpc, (wp decodeTCBConf_wf decodeReadReg_wf decodeWriteReg_wf decodeSetTLSBase_wf decodeCopyReg_wf decodeBindNotification_wf decodeUnbindNotification_wf)+) apply (clarsimp simp: real_cte_at') apply (fastforce simp: real_cte_at_not_tcb_at' objBits_defs) done lemma restart_makes_simple': "\st_tcb_at' simple' t\ restart t' \\rv. st_tcb_at' simple' t\" apply (simp add: restart_def) apply (wp sts_st_tcb_at'_cases cancelIPC_simple cancelIPC_st_tcb_at hoare_weak_lift_imp | simp)+ apply (rule hoare_strengthen_post [OF isStopped_inv]) prefer 2 apply assumption apply clarsimp done lemma setPriority_st_tcb_at'[wp]: "\st_tcb_at' P t\ setPriority t' p \\rv. st_tcb_at' P t\" apply (simp add: setPriority_def) apply (wp threadSet_pred_tcb_no_state | simp)+ done lemma setMCPriority_st_tcb_at'[wp]: "\st_tcb_at' P t\ setMCPriority t' p \\rv. st_tcb_at' P t\" apply (simp add: setMCPriority_def) apply (wp threadSet_pred_tcb_no_state | simp)+ done lemma cteDelete_makes_simple': "\st_tcb_at' simple' t\ cteDelete slot v \\rv. st_tcb_at' simple' t\" by (wp cteDelete_st_tcb_at' | simp)+ crunches getThreadBufferSlot, setPriority, setMCPriority for irq_states'[wp]: valid_irq_states' (simp: crunch_simps) lemma inv_tcb_IRQInactive: "\valid_irq_states'\ invokeTCB tcb_inv -, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" including no_pre apply (simp add: invokeTCB_def) apply (rule hoare_pre) apply (wpc | wp withoutPreemption_R cteDelete_IRQInactive checkCap_inv hoare_vcg_const_imp_lift_R cteDelete_irq_states' hoare_vcg_const_imp_lift | simp add: split_def)+ done end end