(* * Copyright 2014, General Dynamics C4 Systems * * This software may be distributed and modified according to the terms of * the GNU General Public License version 2. Note that NO WARRANTY is provided. * See "LICENSE_GPLv2.txt" for details. * * @TAG(GD_GPL) *) theory Syscall_C imports Interrupt_C Ipc_C Invoke_C Schedule_C Arch_C begin context begin interpretation Arch . (*FIXME: arch_split*) crunch sch_act_wf [wp]: replyFromKernel "\s. sch_act_wf (ksSchedulerAction s) s" end context kernel_m begin (* FIXME: should do this from the beginning *) declare true_def [simp] false_def [simp] lemma ccorres_If_False: "ccorres_underlying sr Gamm r xf arrel axf R R' hs b c \ ccorres_underlying sr Gamm r xf arrel axf (R and (\_. \ P)) R' hs (If P a b) c" by (rule ccorres_gen_asm, simp) definition one_on_true :: "bool \ nat" where "one_on_true P \ if P then 1 else 0" lemma one_on_true_True[simp]: "one_on_true True = 1" by (simp add: one_on_true_def) lemma one_on_true_eq_0[simp]: "(one_on_true P = 0) = (\ P)" by (simp add: one_on_true_def split: if_split) lemma cap_cases_one_on_true_sum: "one_on_true (isZombie cap) + one_on_true (isArchObjectCap cap) + one_on_true (isThreadCap cap) + one_on_true (isCNodeCap cap) + one_on_true (isNotificationCap cap) + one_on_true (isEndpointCap cap) + one_on_true (isUntypedCap cap) + one_on_true (isReplyCap cap) + one_on_true (isIRQControlCap cap) + one_on_true (isIRQHandlerCap cap) + one_on_true (isNullCap cap) + one_on_true (isDomainCap cap) = 1" by (cases cap, simp_all add: isCap_simps) lemma performInvocation_Endpoint_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and st_tcb_at' simple' thread and ep_at' epptr and sch_act_sane and (\s. thread = ksCurThread s \ (\p. ksCurThread s \ set (ksReadyQueues s p)))) (UNIV \ {s. block_' s = from_bool blocking} \ {s. call_' s = from_bool do_call} \ {s. badge_' s = badge} \ {s. canGrant_' s = from_bool canGrant} \ {s. ep_' s = ep_Ptr epptr} \ \badge && mask 28 = badge\) [] (liftE (sendIPC blocking do_call badge canGrant thread epptr)) (Call performInvocation_Endpoint_'proc)" apply cinit apply (ctac add: sendIPC_ccorres) apply (simp add: return_returnOk) apply (rule ccorres_return_CE, simp+)[1] apply wp apply simp apply (vcg exspec=sendIPC_modifies) apply (clarsimp simp add: rf_sr_ksCurThread sch_act_sane_not) done (* This lemma now assumes 'weak_sch_act_wf (ksSchedulerAction s) s' in place of 'sch_act_simple'. *) lemma performInvocation_Notification_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) (UNIV \ {s. ntfn_' s = ntfn_Ptr ntfnptr} \ {s. badge_' s = badge} \ {s. message_' s = message}) [] (liftE (sendSignal ntfnptr badge)) (Call performInvocation_Notification_'proc)" apply cinit apply (ctac add: sendSignal_ccorres) apply (simp add: return_returnOk) apply (rule ccorres_return_CE, simp+)[1] apply wp apply simp apply (vcg exspec=sendSignal_modifies) apply simp done lemma performInvocation_Reply_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and tcb_at' receiver and st_tcb_at' active' sender and sch_act_simple and ((Not o real_cte_at' slot) or cte_wp_at' (\cte. isReplyCap (cteCap cte)) slot) and cte_wp_at' (\cte. cteCap cte = capability.NullCap \ isReplyCap (cteCap cte)) slot and (\s. ksCurThread s = sender)) (UNIV \ {s. thread_' s = tcb_ptr_to_ctcb_ptr receiver} \ {s. slot_' s = cte_Ptr slot}) [] (liftE (doReplyTransfer sender receiver slot)) (Call performInvocation_Reply_'proc)" apply cinit apply (ctac add: doReplyTransfer_ccorres) apply (simp add: return_returnOk) apply (rule ccorres_return_CE, simp+)[1] apply wp apply simp apply (vcg exspec=doReplyTransfer_modifies) apply (simp add: rf_sr_ksCurThread) apply (auto simp: isReply_def elim!: pred_tcb'_weakenE) done lemma decodeInvocation_ccorres: "interpret_excaps extraCaps' = excaps_map extraCaps \ ccorres (intr_and_se_rel \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and (\s. ksCurThread s = thread) and ct_active' and sch_act_simple and valid_cap' cp and (\s. \x \ zobj_refs' cp. ex_nonz_cap_to' x s) and (excaps_in_mem extraCaps \ ctes_of) and cte_wp_at' (diminished' cp \ cteCap) slot and (\s. \v \ set extraCaps. ex_cte_cap_wp_to' isCNodeCap (snd v) s) and (\s. \v \ set extraCaps. s \' fst v \ cte_at' (snd v) s) and (\s. \v \ set extraCaps. \y \ zobj_refs' (fst v). ex_nonz_cap_to' y s) and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) and sysargs_rel args buffer) (UNIV \ {s. call_' s = from_bool isCall} \ {s. block_' s = from_bool isBlocking} \ {s. call_' s = from_bool isCall} \ {s. block_' s = from_bool isBlocking} \ {s. invLabel_' s = label} \ {s. unat (length___unsigned_long_' s) = length args} \ {s. capIndex_' s = cptr} \ {s. slot_' s = cte_Ptr slot} \ {s. excaps_' s = extraCaps'} \ {s. ccap_relation cp (cap_' s)} \ {s. buffer_' s = option_to_ptr buffer}) [] (decodeInvocation label args cptr slot cp extraCaps >>= invocationCatch thread isBlocking isCall id) (Call decodeInvocation_'proc)" apply (cinit' lift: call_' block_' invLabel_' length___unsigned_long_' capIndex_' slot_' excaps_' cap_' buffer_') apply csymbr apply (simp add: cap_get_tag_isCap decodeInvocation_def cong: if_cong StateSpace.state.fold_congs globals.fold_congs del: Collect_const) apply (cut_tac cap=cp in cap_cases_one_on_true_sum) apply (rule ccorres_Cond_rhs_Seq) apply (simp add: Let_def isArchCap_T_isArchObjectCap liftME_invocationCatch from_bool_neq_0) apply (rule ccorres_split_throws) apply (rule ccorres_trim_returnE) apply simp apply simp apply (rule ccorres_call, rule Arch_decodeInvocation_ccorres [where buffer=buffer]) apply assumption apply simp+ apply (vcg exspec=Arch_decodeInvocation_modifies) apply simp apply csymbr apply (simp add: cap_get_tag_isCap del: Collect_const) apply (rule ccorres_Cond_rhs) apply (simp add: invocationCatch_def throwError_bind) apply (rule syscall_error_throwError_ccorres_n) apply (simp add: syscall_error_to_H_cases) apply (rule ccorres_Cond_rhs) apply (simp add: invocationCatch_def throwError_bind) apply (rule syscall_error_throwError_ccorres_n) apply (simp add: syscall_error_to_H_cases) apply (rule ccorres_Cond_rhs) apply (simp add: if_to_top_of_bind) apply (rule ccorres_rhs_assoc)+ apply csymbr apply (rule ccorres_if_cond_throws2[where Q=\ and Q'=\]) apply (clarsimp simp: isCap_simps Collect_const_mem) apply (frule cap_get_tag_isCap_unfolded_H_cap) apply (drule(1) cap_get_tag_to_H) apply (clarsimp simp: to_bool_def) apply (simp add: throwError_bind invocationCatch_def) apply (rule syscall_error_throwError_ccorres_n) apply (simp add: syscall_error_to_H_cases) apply (simp add: returnOk_bind ccorres_invocationCatch_Inr performInvocation_def bind_assoc liftE_bindE) apply (ctac add: setThreadState_ccorres) apply csymbr apply csymbr apply csymbr apply (rule ccorres_pre_getCurThread) apply (simp only: liftE_bindE[symmetric]) apply (ctac add: performInvocation_Endpoint_ccorres) apply (rule ccorres_alternative2) apply (rule ccorres_return_CE, simp+)[1] apply (rule ccorres_return_C_errorE, simp+)[1] apply wp apply simp apply (vcg exspec=performInvocation_Endpoint_modifies) apply simp apply (rule hoare_use_eq[where f=ksCurThread]) apply (wp sts_invs_minor' sts_st_tcb_at'_cases setThreadState_ct' hoare_vcg_all_lift sts_ksQ')+ apply simp apply (vcg exspec=setThreadState_modifies) apply vcg apply (rule ccorres_Cond_rhs) apply (rule ccorres_rhs_assoc)+ apply (csymbr) apply (simp add: if_to_top_of_bind Collect_const[symmetric] del: Collect_const) apply (rule ccorres_if_cond_throws2[where Q=\ and Q'=\]) apply (clarsimp simp: isCap_simps Collect_const_mem) apply (frule cap_get_tag_isCap_unfolded_H_cap) apply (drule(1) cap_get_tag_to_H) apply (clarsimp simp: to_bool_def) apply (simp add: throwError_bind invocationCatch_def) apply (rule syscall_error_throwError_ccorres_n) apply (simp add: syscall_error_to_H_cases) apply (simp add: returnOk_bind ccorres_invocationCatch_Inr performInvocation_def bindE_assoc) apply (simp add: liftE_bindE) apply (ctac add: setThreadState_ccorres) apply csymbr apply csymbr apply (simp only: liftE_bindE[symmetric]) apply (ctac(no_vcg) add: performInvocation_Notification_ccorres) apply (rule ccorres_alternative2) apply (rule ccorres_return_CE, simp+)[1] apply (rule ccorres_return_C_errorE, simp+)[1] apply wp apply (wp sts_invs_minor') apply simp apply (vcg exspec=setThreadState_modifies) apply vcg apply (rule ccorres_Cond_rhs) apply (simp add: if_to_top_of_bind) apply (rule ccorres_rhs_assoc)+ apply csymbr apply (rule ccorres_if_cond_throws2[where Q=\ and Q'=\]) apply (clarsimp simp: isCap_simps Collect_const_mem) apply (frule cap_get_tag_isCap_unfolded_H_cap) apply (clarsimp simp: cap_get_tag_ReplyCap to_bool_def) apply (simp add: throwError_bind invocationCatch_def) apply (rule syscall_error_throwError_ccorres_n) apply (simp add: syscall_error_to_H_cases) apply (simp add: returnOk_bind ccorres_invocationCatch_Inr performInvocation_def liftE_bindE bind_assoc) apply (ctac add: setThreadState_ccorres) apply csymbr apply (rule ccorres_pre_getCurThread) apply (simp only: liftE_bindE[symmetric]) apply (ctac add: performInvocation_Reply_ccorres) apply (rule ccorres_alternative2) apply (rule ccorres_return_CE, simp+)[1] apply (rule ccorres_return_C_errorE, simp+)[1] apply wp apply simp apply (vcg exspec=performInvocation_Reply_modifies) apply (simp add: cur_tcb'_def[symmetric]) apply (rule_tac R="\rv s. ksCurThread s = thread" in hoare_post_add) apply (simp cong: conj_cong) apply (strengthen imp_consequent) apply (wp sts_invs_minor' sts_st_tcb_at'_cases) apply simp apply (vcg exspec=setThreadState_modifies) apply vcg apply (rule ccorres_Cond_rhs) apply (simp add: if_to_top_of_bind) apply (rule ccorres_trim_returnE, simp+) apply (simp add: liftME_invocationCatch o_def) apply (rule ccorres_call, rule decodeTCBInvocation_ccorres) apply assumption apply (simp+)[3] apply (rule ccorres_Cond_rhs) apply (rule ccorres_trim_returnE, simp+) apply (simp add: liftME_invocationCatch o_def) apply (rule ccorres_call, erule decodeDomainInvocation_ccorres[unfolded o_def], simp+)[1] apply (rule ccorres_Cond_rhs) apply (simp add: if_to_top_of_bind) apply (rule ccorres_trim_returnE, simp+) apply (simp add: liftME_invocationCatch o_def) apply (rule ccorres_call, erule decodeCNodeInvocation_ccorres[unfolded o_def], simp+)[1] apply (rule ccorres_Cond_rhs) apply simp apply (rule ccorres_trim_returnE, simp+) apply (simp add: liftME_invocationCatch) apply (rule ccorres_call, erule decodeUntypedInvocation_ccorres, simp+)[1] apply (rule ccorres_Cond_rhs) apply (simp add: liftME_invocationCatch) apply (rule ccorres_trim_returnE, simp+) apply (rule ccorres_call, erule decodeIRQControlInvocation_ccorres, simp+)[1] apply (rule ccorres_Cond_rhs) apply (simp add: Let_def liftME_invocationCatch) apply (rule ccorres_rhs_assoc)+ apply csymbr apply (rule ccorres_trim_returnE, simp+) apply (rule ccorres_call, erule decodeIRQHandlerInvocation_ccorres, simp+) apply (rule ccorres_inst[where P=\ and P'=UNIV]) apply (simp add: isArchCap_T_isArchObjectCap one_on_true_def from_bool_0) apply (rule conjI) apply (clarsimp simp: tcb_at_invs' ct_in_state'_def simple_sane_strg) apply (clarsimp simp: cte_wp_at_ctes_of valid_cap'_def isCap_simps from_bool_neq_0 unat_eq_0 sysargs_rel_n_def n_msgRegisters_def valid_tcb_state'_def | rule conjI | erule pred_tcb'_weakenE disjE | drule st_tcb_at_idle_thread')+ apply fastforce apply (simp add: cap_lift_capEPBadge_mask_eq) apply (clarsimp simp: rf_sr_ksCurThread Collect_const_mem cap_get_tag_isCap "StrictC'_thread_state_defs") apply (frule word_unat.Rep_inverse') apply (simp add: cap_get_tag_isCap[symmetric] cap_get_tag_ReplyCap) apply (rule conjI) apply (simp add: cap_get_tag_isCap) apply (clarsimp simp: isCap_simps cap_get_tag_to_H from_bool_neq_0) apply (insert ccap_relation_IRQHandler_mask, elim meta_allE, drule(1) meta_mp) apply (rule conjI | clarsimp | drule(1) cap_get_tag_to_H | simp add: cap_endpoint_cap_lift_def cap_notification_cap_lift_def cap_reply_cap_lift_def cap_lift_endpoint_cap cap_lift_notification_cap cap_lift_reply_cap from_bool_to_bool_and_1 word_size order_le_less_trans[OF word_and_le1] mask_eq_iff_w2p word_size ucast_ucast_mask isCap_simps mask_eq_ucast_eq mask_eq_iff_w2p[THEN trans[OF eq_commute]])+ done lemma ccorres_Call_Seq: "\ \ f = Some v; ccorres r xf P P' hs a (v ;; c) \ \ ccorres r xf P P' hs a (Call f ;; c)" apply (erule ccorres_semantic_equivD1) apply (rule semantic_equivI) apply (auto elim!: exec_elim_cases intro: exec.intros) done lemma wordFromRights_mask_0: "wordFromRights rghts && ~~ mask 4 = 0" apply (simp add: wordFromRights_def word_ao_dist word_or_zero split: cap_rights.split) apply (simp add: mask_def split: if_split) done lemma wordFromRights_mask_eq: "wordFromRights rghts && mask 4 = wordFromRights rghts" apply (cut_tac x="wordFromRights rghts" and y="mask 4" and z="~~ mask 4" in word_bool_alg.conj_disj_distrib) apply (simp add: wordFromRights_mask_0) done lemma loadWordUser_user_word_at: "\\s. \rv. user_word_at rv x s \ Q rv s\ loadWordUser x \Q\" apply (simp add: loadWordUser_def user_word_at_def doMachineOp_def split_def) apply wp apply (clarsimp simp: pointerInUserData_def loadWord_def in_monad is_aligned_mask) done lemma mapM_loadWordUser_user_words_at: "\\s. \rv. (\x < length xs. user_word_at (rv ! x) (xs ! x) s) \ length rv = length xs \ Q rv s\ mapM loadWordUser xs \Q\" apply (induct xs arbitrary: Q) apply (simp add: mapM_def sequence_def) apply wp apply (simp add: mapM_Cons) apply wp apply assumption apply (wp loadWordUser_user_word_at) apply clarsimp apply (drule spec, erule mp) apply clarsimp apply (case_tac x) apply simp apply simp done lemma getSlotCap_slotcap_in_mem: "\\\ getSlotCap slot \\cap s. slotcap_in_mem cap slot (ctes_of s)\" apply (simp add: getSlotCap_def) apply (wp getCTE_wp') apply (clarsimp simp: cte_wp_at_ctes_of slotcap_in_mem_def) done lemma lookupExtraCaps_excaps_in_mem[wp]: "\\\ lookupExtraCaps thread buffer info \\rv s. excaps_in_mem rv (ctes_of s)\,-" apply (simp add: excaps_in_mem_def lookupExtraCaps_def lookupCapAndSlot_def split_def) apply (wp mapME_set) apply (wp getSlotCap_slotcap_in_mem | simp)+ done lemma getCurThread_ccorres: "ccorres (op = \ tcb_ptr_to_ctcb_ptr) thread_' \ UNIV hs getCurThread (\thread :== \ksCurThread)" apply (rule ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: getCurThread_def simpler_gets_def rf_sr_ksCurThread) done lemma getMessageInfo_ccorres: "ccorres (\rv rv'. rv = messageInfoFromWord rv') ret__unsigned_long_' \ (UNIV \ {s. thread_' s = tcb_ptr_to_ctcb_ptr thread} \ {s. reg_' s = register_from_H ARM_H.msgInfoRegister}) [] (getMessageInfo thread) (Call getRegister_'proc)" apply (simp add: getMessageInfo_def liftM_def[symmetric] ccorres_liftM_simp) apply (rule ccorres_rel_imp, rule ccorres_guard_imp2, rule getRegister_ccorres) apply simp apply simp done lemma messageInfoFromWord_spec: "\s. \ \ {s} Call messageInfoFromWord_'proc {s'. seL4_MessageInfo_lift (ret__struct_seL4_MessageInfo_C_' s') = mi_from_H (messageInfoFromWord (w_' s))}" apply (rule allI, rule conseqPost, rule messageInfoFromWord_spec[rule_format]) apply simp_all apply (clarsimp simp: seL4_MessageInfo_lift_def mi_from_H_def messageInfoFromWord_def Let_def Types_H.msgLengthBits_def Types_H.msgExtraCapBits_def Types_H.msgMaxExtraCaps_def shiftL_nat) apply (fold mask_def[where n=20, simplified]) apply (rule less_mask_eq) apply (rule shiftr_less_t2n') apply simp apply simp done lemma threadGet_tcbIpcBuffer_ccorres [corres]: "ccorres (op =) w_bufferPtr_' (tcb_at' tptr) UNIV hs (threadGet tcbIPCBuffer tptr) (Guard C_Guard \hrs_htd \t_hrs \\<^sub>t (Ptr &(tcb_ptr_to_ctcb_ptr tptr\ [''tcbIPCBuffer_C''])::word32 ptr)\ (\w_bufferPtr :== h_val (hrs_mem \t_hrs) (Ptr &(tcb_ptr_to_ctcb_ptr tptr\[''tcbIPCBuffer_C''])::word32 ptr)))" apply (rule ccorres_guard_imp2) apply (rule ccorres_add_return2) apply (rule ccorres_pre_threadGet) apply (rule_tac P = "obj_at' (\tcb. tcbIPCBuffer tcb = x) tptr" and P'="{s'. \ctcb. cslift s' (tcb_ptr_to_ctcb_ptr tptr) = Some ctcb \ tcbIPCBuffer_C ctcb = x }" in ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply clarsimp apply (clarsimp simp: return_def typ_heap_simps') apply (clarsimp simp: obj_at'_def ctcb_relation_def) done lemma handleInvocation_def2: "handleInvocation isCall isBlocking = do thread \ getCurThread; info \ getMessageInfo thread; ptr \ asUser thread (getRegister ARM_H.capRegister); v \ (doE (cap, slot) \ capFaultOnFailure ptr False (lookupCapAndSlot thread ptr); buffer \ withoutFailure (VSpace_H.lookupIPCBuffer False thread); extracaps \ lookupExtraCaps thread buffer info; returnOk (slot, cap, extracaps, buffer) odE); case v of Inl f \ liftE (when isBlocking (handleFault thread f)) | Inr (slot, cap, extracaps, buffer) \ do args \ getMRs thread buffer info; v' \ do v \ RetypeDecls_H.decodeInvocation (msgLabel info) args ptr slot cap extracaps; invocationCatch thread isBlocking isCall id v od; case v' of Inr _ \ liftE (replyOnRestart thread [] isCall) | Inl (Inl syserr) \ liftE (when isCall (replyFromKernel thread (msgFromSyscallError syserr))) | Inl (Inr preempt) \ throwError preempt od od" apply (simp add: handleInvocation_def Syscall_H.syscall_def runErrorT_def liftE_bindE cong: sum.case_cong) apply (rule ext, (rule bind_apply_cong [OF refl])+) apply (clarsimp simp: bind_assoc split: sum.split) apply (rule bind_apply_cong [OF refl])+ apply (clarsimp simp: invocationCatch_def throwError_bind liftE_bindE bind_assoc split: sum.split) apply (rule bind_apply_cong [OF refl])+ apply (simp add: bindE_def bind_assoc) apply (rule bind_apply_cong [OF refl])+ apply (clarsimp simp: lift_def throwError_bind returnOk_bind split: sum.split) apply (simp cong: bind_cong add: ts_Restart_case_helper') apply (simp add: when_def[symmetric] replyOnRestart_def[symmetric]) apply (simp add: liftE_def replyOnRestart_twice alternative_bind alternative_refl split: if_split) done lemma thread_state_to_tsType_eq_Restart: "(thread_state_to_tsType ts = scast ThreadState_Restart) = (ts = Restart)" by (cases ts, simp_all add: "StrictC'_thread_state_defs") lemma wordFromMessageInfo_spec: "\s. \\ {s} Call wordFromMessageInfo_'proc {s'. \mi. seL4_MessageInfo_lift (mi_' s) = mi_from_H mi \ ret__unsigned_long_' s' = wordFromMessageInfo mi}" apply (rule allI, rule conseqPost, rule wordFromMessageInfo_spec2[rule_format]) prefer 2 apply simp apply (clarsimp simp: wordFromMessageInfo_def Let_def Types_H.msgExtraCapBits_def Types_H.msgLengthBits_def Types_H.msgMaxExtraCaps_def shiftL_nat) apply (clarsimp simp: mi_from_H_def seL4_MessageInfo_lift_def word_bw_comms word_bw_assocs word_bw_lcs) done lemma handleDoubleFault_ccorres: "ccorres dc xfdc (invs' and tcb_at' tptr and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and sch_act_not tptr and (\s. \p. tptr \ set (ksReadyQueues s p))) (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr tptr}) [] (handleDoubleFault tptr ex1 ex2) (Call handleDoubleFault_'proc)" apply (cinit lift: tptr_') apply (subst ccorres_seq_skip'[symmetric]) apply (ctac (no_vcg)) apply (rule ccorres_symb_exec_l) apply (rule ccorres_return_Skip) apply (wp asUser_inv getRestartPC_inv)+ apply (rule empty_fail_asUser) apply (simp add: getRestartPC_def) apply wp apply clarsimp apply (simp add: ThreadState_Inactive_def) apply (fastforce simp: valid_tcb_state'_def) done lemma cap_case_EndpointCap_CanSend_CanGrant: "(case cap of EndpointCap v0 v1 True v3 True \ f v0 v1 v3 | _ \ g) = (if (isEndpointCap cap \ capEPCanSend cap \ capEPCanGrant cap) then f (capEPPtr cap) (capEPBadge cap) (capEPCanReceive cap) else g)" by (simp add: isCap_simps split: capability.split bool.split) lemma threadGet_tcbFaultHandler_ccorres [corres]: "ccorres (op =) handlerCPtr_' (tcb_at' tptr) UNIV hs (threadGet tcbFaultHandler tptr) (Guard C_Guard \hrs_htd \t_hrs \\<^sub>t (tcb_ptr_to_ctcb_ptr tptr)\ (\handlerCPtr :== h_val (hrs_mem \t_hrs) (Ptr &(tcb_ptr_to_ctcb_ptr tptr\[''tcbFaultHandler_C''])::word32 ptr)))" apply (rule ccorres_guard_imp2) apply (rule ccorres_add_return2) apply (rule ccorres_pre_threadGet) apply (rule_tac P = "obj_at' (\tcb. tcbFaultHandler tcb = x) tptr" and P'="{s'. \ ctcb. cslift s' (tcb_ptr_to_ctcb_ptr tptr) = Some ctcb \ tcbFaultHandler_C ctcb = x }" in ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply clarsimp apply (clarsimp simp: return_def typ_heap_simps') apply (clarsimp simp: obj_at'_def ctcb_relation_def) done lemma rf_sr_tcb_update_twice: "h_t_valid (hrs_htd (hrs2 (globals s') (t_hrs_' (gs2 (globals s'))))) c_guard (ptr (t_hrs_' (gs2 (globals s'))) (globals s')) \ ((s, globals_update (\gs. t_hrs_'_update (\ths. hrs_mem_update (heap_update (ptr ths gs :: tcb_C ptr) (v ths gs)) (hrs_mem_update (heap_update (ptr ths gs) (v' ths gs)) (hrs2 gs ths))) (gs2 gs)) s') \ rf_sr) = ((s, globals_update (\gs. t_hrs_'_update (\ths. hrs_mem_update (heap_update (ptr ths gs) (v ths gs)) (hrs2 gs ths)) (gs2 gs)) s') \ rf_sr)" by (simp add: rf_sr_def cstate_relation_def Let_def cpspace_relation_def typ_heap_simps' carch_state_relation_def cmachine_state_relation_def) lemma hrs_mem_update_use_hrs_mem: "hrs_mem_update f = (\hrs. (hrs_mem_update $ (\_. f (hrs_mem hrs))) hrs)" by (simp add: hrs_mem_update_def hrs_mem_def fun_eq_iff) lemma sendFaultIPC_ccorres: "ccorres (cfault_rel2 \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and st_tcb_at' simple' tptr and sch_act_not tptr and (\s. \p. tptr \ set (ksReadyQueues s p))) (UNIV \ {s. (cfault_rel (Some fault) (seL4_Fault_lift(current_fault_' (globals s))) (lookup_fault_lift(current_lookup_fault_' (globals s))))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr tptr}) [] (sendFaultIPC tptr fault) (Call sendFaultIPC_'proc)" apply (cinit lift: tptr_' cong: call_ignore_cong) apply (simp add: liftE_bindE del:Collect_const cong:call_ignore_cong) apply (rule ccorres_symb_exec_r) apply (rule ccorres_split_nothrow) apply (rule threadGet_tcbFaultHandler_ccorres) apply ceqv apply (rule_tac xf'=lu_ret___struct_lookupCap_ret_C_' in ccorres_split_nothrow_callE) apply (rule capFaultOnFailure_ccorres) apply (rule lookupCap_ccorres) apply simp apply simp apply simp apply simp apply ceqv apply clarsimp apply csymbr+ apply (simp add: cap_case_EndpointCap_CanSend_CanGrant) apply (rule ccorres_rhs_assoc2) apply (rule ccorres_symb_exec_r) apply (rule_tac Q=\ and Q'="\s'. ( ret__int_' s' = (if ( (cap_get_tag (lookupCap_ret_C.cap_C rv'a) = scast cap_endpoint_cap) \ (capCanSend_CL (cap_endpoint_cap_lift (lookupCap_ret_C.cap_C rv'a)))\0 \ (capCanGrant_CL (cap_endpoint_cap_lift (lookupCap_ret_C.cap_C rv'a)))\0) then 1 else 0))" in ccorres_cond_both') apply clarsimp apply (frule cap_get_tag_isCap(4)[symmetric], clarsimp simp: cap_get_tag_EndpointCap to_bool_def split:if_splits) apply (rule ccorres_rhs_assoc) apply (rule ccorres_rhs_assoc) apply (rule ccorres_rhs_assoc) apply (simp add: liftE_def bind_assoc) apply (rule_tac ccorres_split_nothrow_novcg) apply (rule_tac P=\ and P'=invs' and R="{s. (cfault_rel (Some fault) (seL4_Fault_lift(current_fault_' (globals s))) (lookup_fault_lift(original_lookup_fault_' s)))}" in threadSet_ccorres_lemma4) apply vcg apply (clarsimp simp: typ_heap_simps' rf_sr_tcb_update_twice) apply (intro conjI allI impI) apply (simp add: typ_heap_simps' rf_sr_def) apply (rule rf_sr_tcb_update_no_queue2[unfolded rf_sr_def, simplified], assumption+, (simp add: typ_heap_simps')+) apply (rule ball_tcb_cte_casesI, simp+) apply (simp add: ctcb_relation_def cthread_state_relation_def ) apply (case_tac "tcbState tcb", simp+) apply (simp add: rf_sr_def) apply (rule rf_sr_tcb_update_no_queue2[unfolded rf_sr_def, simplified], assumption+, (simp add: typ_heap_simps' | simp only: hrs_mem_update_use_hrs_mem)+) apply (rule ball_tcb_cte_casesI, simp+) apply (clarsimp simp: typ_heap_simps') apply (simp add: ctcb_relation_def cthread_state_relation_def) apply (rule conjI) apply (case_tac "tcbState tcb", simp+) apply (simp add: cfault_rel_def) apply (clarsimp) apply (clarsimp simp: seL4_Fault_lift_def Let_def is_cap_fault_def split: if_split_asm) apply ceqv apply csymbr apply csymbr apply (ctac (no_vcg) add: sendIPC_ccorres) apply (ctac (no_vcg) add: ccorres_return_CE [unfolded returnOk_def comp_def]) apply wp apply (wp threadSet_pred_tcb_no_state threadSet_invs_trivial threadSet_typ_at_lifts | simp)+ apply (clarsimp simp: guard_is_UNIV_def) apply (frule cap_get_tag_isCap(4)[symmetric]) apply (clarsimp simp: cap_get_tag_EndpointCap to_bool_def) apply (drule cap_get_tag_isCap(4) [symmetric]) apply (clarsimp simp: isCap_simps cap_endpoint_cap_lift cap_lift_capEPBadge_mask_eq) apply clarsimp apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply clarsimp apply (clarsimp simp add: throwError_def throw_def return_def) apply (rule conseqPre, vcg) apply (clarsimp simp: EXCEPTION_FAULT_def EXCEPTION_NONE_def) apply (simp add: cfault_rel2_def cfault_rel_def EXCEPTION_FAULT_def) apply (simp add: seL4_Fault_CapFault_lift) apply (simp add: lookup_fault_missing_capability_lift is_cap_fault_def) apply vcg apply (clarsimp simp: if_1_0_0) apply (rule conseqPre, vcg) apply clarsimp apply clarsimp apply (rule ccorres_split_throws) apply (rule_tac P=\ and P'="{x. errstate x= err'}" in ccorres_from_vcg_throws) apply clarsimp apply (clarsimp simp add: throwError_def throw_def return_def) apply (rule conseqPre, vcg) apply (clarsimp simp: EXCEPTION_FAULT_def EXCEPTION_NONE_def) apply (simp add: cfault_rel2_def cfault_rel_def EXCEPTION_FAULT_def) apply (simp add: seL4_Fault_CapFault_lift is_cap_fault_def) apply (erule lookup_failure_rel_fault_lift [rotated, unfolded EXCEPTION_NONE_def, simplified], assumption) apply vcg apply (clarsimp simp: inQ_def) apply (rule_tac Q="\a b. invs' b \ st_tcb_at' simple' tptr b \ sch_act_not tptr b \ valid_cap' a b \ (\p. tptr \ set (ksReadyQueues b p))" and E="\ _. \" in hoare_post_impErr) apply (wp) apply (clarsimp simp: isCap_simps) apply (clarsimp simp: valid_cap'_def pred_tcb_at') apply simp apply (clarsimp simp: if_1_0_0) apply (vcg exspec=lookupCap_modifies) apply clarsimp apply wp apply (clarsimp simp: if_1_0_0) apply (vcg) apply (clarsimp, vcg) apply (rule conseqPre, vcg) apply clarsimp apply (clarsimp simp: if_1_0_0) apply fastforce done lemma handleFault_ccorres: "ccorres dc xfdc (invs' and st_tcb_at' simple' t and sch_act_not t and (\s. \p. t \ set (ksReadyQueues s p))) (UNIV \ {s. (cfault_rel (Some flt) (seL4_Fault_lift(current_fault_' (globals s))) (lookup_fault_lift(current_lookup_fault_' (globals s))) )} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr t}) [] (handleFault t flt) (Call handleFault_'proc)" apply (cinit lift: tptr_') apply (simp add: catch_def) apply (rule ccorres_symb_exec_r) apply (rule ccorres_split_nothrow_novcg_case_sum) apply (ctac (no_vcg) add: sendFaultIPC_ccorres) apply ceqv apply clarsimp apply (rule ccorres_cond_empty) apply (rule ccorres_return_Skip') apply clarsimp apply (rule ccorres_cond_univ) apply (ctac (no_vcg) add: handleDoubleFault_ccorres [unfolded dc_def]) apply (simp add: sendFaultIPC_def) apply wp apply ((wp hoare_vcg_all_lift_R hoare_drop_impE_R |wpc |simp add: throw_def)+)[1] apply clarsimp apply ((wp hoare_vcg_all_lift_R hoare_drop_impE_R |wpc |simp add: throw_def)+)[1] apply (wp) apply (simp add: guard_is_UNIV_def) apply (simp add: guard_is_UNIV_def) apply clarsimp apply vcg apply clarsimp apply (rule conseqPre, vcg) apply clarsimp apply (clarsimp simp: pred_tcb_at') done lemma getMessageInfo_less_4: "\\\ getMessageInfo t \\rv s. msgExtraCaps rv < 4\" including no_pre apply (simp add: getMessageInfo_def) apply wp apply (rule hoare_strengthen_post, rule hoare_vcg_prop) apply (simp add: messageInfoFromWord_def Let_def Types_H.msgExtraCapBits_def) apply (rule minus_one_helper5, simp) apply simp apply (rule word_and_le1) done lemma invs_queues_imp: "invs' s \ valid_queues s" by clarsimp (* FIXME: move *) lemma length_CL_from_H [simp]: "length_CL (mi_from_H mi) = msgLength mi" by (simp add: mi_from_H_def) lemma getMRs_length: "\\s. msgLength mi \ 120\ getMRs thread buffer mi \\args s. if buffer = None then length args = min (unat n_msgRegisters) (unat (msgLength mi)) else length args = unat (msgLength mi)\" apply (cases buffer) apply (simp add: getMRs_def) apply (rule hoare_pre, wp) apply (rule asUser_const_rv) apply simp apply (wp mapM_length) apply (simp add: min_def length_msgRegisters) apply (clarsimp simp: n_msgRegisters_def) apply (simp add: getMRs_def) apply (rule hoare_pre, wp) apply simp apply (wp mapM_length asUser_const_rv mapM_length)+ apply (clarsimp simp: length_msgRegisters) apply (simp add: min_def split: if_splits) apply (clarsimp simp: word_le_nat_alt) apply (simp add: msgMaxLength_def msgLengthBits_def n_msgRegisters_def) done lemma getMessageInfo_msgLength': "\\\ getMessageInfo t \\rv s. msgLength rv \ 0x78\" including no_pre apply (simp add: getMessageInfo_def) apply wp apply (rule hoare_strengthen_post, rule hoare_vcg_prop) apply (simp add: messageInfoFromWord_def Let_def msgMaxLength_def not_less Types_H.msgExtraCapBits_def split: if_split ) done lemma handleInvocation_ccorres: "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and ct_active' and sch_act_simple and (\s. \x. ksCurThread s \ set (ksReadyQueues s x))) (UNIV \ {s. isCall_' s = from_bool isCall} \ {s. isBlocking_' s = from_bool isBlocking}) [] (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" apply (cinit' lift: isCall_' isBlocking_' simp: whileAnno_def handleInvocation_def2) apply (simp add: liftE_bindE del: Collect_const cong: call_ignore_cong) apply (ctac(no_vcg) add: getCurThread_ccorres) apply (ctac(no_vcg) add: getMessageInfo_ccorres) apply (simp del: Collect_const cong: call_ignore_cong) apply csymbr apply (ctac(no_vcg) add: getRegister_ccorres) apply (simp add: Syscall_H.syscall_def liftE_bindE split_def bindE_bind_linearise cong: call_ignore_cong del: Collect_const) apply (rule_tac ccorres_split_nothrow_case_sum) apply (ctac add: capFaultOnFailure_ccorres [OF lookupCapAndSlot_ccorres]) apply ceqv apply (simp add: ccorres_cond_iffs Collect_False cong: call_ignore_cong del: Collect_const) apply (simp only: bind_assoc) apply (ctac(no_vcg) add: lookupIPCBuffer_ccorres) apply (simp add: liftME_def bindE_assoc del: Collect_const) apply (simp add: bindE_bind_linearise del: Collect_const) apply (rule_tac xf'="\s. (status_' s, current_extra_caps_' (globals s))" and ef'=fst and vf'=snd and es=errstate in ccorres_split_nothrow_novcg_case_sum) apply (rule ccorres_call, rule lookupExtraCaps_ccorres, simp+) apply (rule ceqv_tuple2, ceqv, ceqv) apply (simp add: returnOk_bind liftE_bindE Collect_False ccorres_cond_iffs ts_Restart_case_helper' del: Collect_const cong: bind_cong) apply (rule ccorres_rhs_assoc2, rule_tac xf'="length___unsigned_long_'" and r'="\rv rv'. unat rv' = length rv" in ccorres_split_nothrow) apply (rule ccorres_add_return2) apply (rule ccorres_symb_exec_l) apply (rule_tac P="\s. rvd \ Some 0 \ (if rvd = None then length x = min (unat (n_msgRegisters)) (unat (msgLength (messageInfoFromWord ret__unsigned_long))) else length x = (unat (msgLength (messageInfoFromWord ret__unsigned_long))))" and P'=UNIV in ccorres_from_vcg) apply (clarsimp simp: return_def) apply (rule conseqPre, vcg) apply (clarsimp simp: word_less_nat_alt) apply (rule conjI) apply clarsimp apply (case_tac rvd, clarsimp simp: option_to_ptr_def option_to_0_def min_def n_msgRegisters_def) apply (clarsimp simp: option_to_0_def option_to_ptr_def) apply clarsimp apply (case_tac rvd, clarsimp simp: option_to_0_def min_def option_to_ptr_def n_msgRegisters_def split: if_splits) apply (clarsimp simp: option_to_0_def option_to_ptr_def) apply wp apply (wp getMRs_length) apply simp apply ceqv apply csymbr apply (simp only: bind_assoc[symmetric]) apply (rule ccorres_split_nothrow_novcg_case_sum) apply (ctac add: decodeInvocation_ccorres) apply ceqv apply (simp add: Collect_False exception_defs replyOnRestart_def liftE_def bind_assoc del: Collect_const) apply (rule ccorres_move_c_guard_tcb) apply (rule getThreadState_ccorres_foo) apply csymbr apply (rule ccorres_abstract_cleanup) apply (rule_tac P="ret__unsigned = thread_state_to_tsType rvg" in ccorres_gen_asm2) apply (simp add: thread_state_to_tsType_eq_Restart from_bool_0 del: Collect_const add: Collect_const[symmetric]) apply (rule ccorres_Cond_rhs_Seq) apply (rule ccorres_rhs_assoc)+ apply (rule ccorres_Cond_rhs_Seq) apply (simp add: bind_assoc) apply (ctac(no_vcg) add: replyFromKernel_success_empty_ccorres) apply (ctac(no_vcg) add: setThreadState_ccorres) apply (rule ccorres_return_CE[folded return_returnOk], simp+)[1] apply wp+ apply (rule hoare_strengthen_post, rule rfk_invs') apply auto[1] apply simp apply (ctac(no_vcg) add: setThreadState_ccorres) apply (rule ccorres_return_CE[folded return_returnOk], simp+)[1] apply wp apply simp apply (rule ccorres_return_CE[folded return_returnOk], simp+)[1] apply wpc apply (simp add: syscall_error_rel_def from_bool_0 exception_defs Collect_False ccorres_cond_iffs Collect_True del: Collect_const) apply (rule ccorres_rhs_assoc)+ apply (simp add: liftE_def Collect_const[symmetric] del: Collect_const) apply (rule ccorres_Cond_rhs_Seq) apply simp apply (ctac(no_vcg) add: replyFromKernel_error_ccorres) apply (rule ccorres_split_throws) apply (rule ccorres_return_CE[folded return_returnOk], simp+)[1] apply vcg apply wp apply simp apply (rule ccorres_split_throws) apply (rule ccorres_return_CE[folded return_returnOk], simp+)[1] apply vcg apply (simp add: cintr_def) apply (rule ccorres_split_throws) apply (rule ccorres_return_C_errorE, simp+)[1] apply vcg apply (simp add: invocationCatch_def o_def) apply (rule_tac Q="\rv'. invs' and tcb_at' rv" and E="\ft. invs' and tcb_at' rv" in hoare_post_impErr) apply (wp hoare_split_bind_case_sumE alternative_wp hoare_drop_imps setThreadState_nonqueued_state_update ct_in_state'_set setThreadState_st_tcb hoare_vcg_all_lift sts_ksQ' | wpc | wps)+ apply auto[1] apply clarsimp apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem) apply (simp add: "StrictC'_thread_state_defs" mask_def) apply (simp add: typ_heap_simps) apply (case_tac ts, simp_all add: cthread_state_relation_def)[1] apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem) apply (clarsimp simp add: intr_and_se_rel_def exception_defs syscall_error_rel_def cintr_def split: sum.split_asm) apply (simp add: conj_comms) apply (wp getMRs_sysargs_rel) apply (simp add: ) apply vcg apply (simp add: ccorres_cond_iffs ccorres_seq_cond_raise Collect_True Collect_False del: Collect_const) apply (rule ccorres_rhs_assoc)+ apply (simp add: ccorres_cond_iffs Collect_const[symmetric] del: Collect_const) apply (rule ccorres_Cond_rhs_Seq) apply (simp add: from_bool_0 liftE_def) apply (ctac(no_vcg) add: handleFault_ccorres) apply (rule ccorres_split_throws) apply (rule ccorres_return_CE[folded return_returnOk], simp+)[1] apply vcg apply wp apply (simp add: from_bool_0 liftE_def) apply (rule ccorres_split_throws) apply (rule ccorres_return_CE[folded return_returnOk], simp+)[1] apply vcg apply (simp add: ball_conj_distrib) apply (wp lookupExtraCaps_excaps_in_mem lec_dimished'[unfolded o_def] lec_derived'[unfolded o_def]) apply (clarsimp simp: guard_is_UNIV_def option_to_ptr_def mi_from_H_def) apply (clarsimp simp: guard_is_UNIV_def) apply simp apply (wp lookupIPCBuffer_Some_0) apply (simp add: Collect_True liftE_def return_returnOk del: Collect_const) apply (rule ccorres_rhs_assoc)+ apply (rule_tac P=\ in ccorres_cross_over_guard) apply (rule ccorres_symb_exec_r) apply (rule ccorres_split_nothrow_novcg_dc) apply (rule ccorres_when[where R=\]) apply (simp add: from_bool_0 Collect_const_mem) apply (ctac add: handleFault_ccorres) apply (rule ccorres_split_throws) apply (rule ccorres_return_CE, simp+)[1] apply vcg apply wp apply (simp add: guard_is_UNIV_def) apply vcg apply (rule conseqPre, vcg) apply clarsimp apply (simp, wp lcs_diminished'[unfolded o_def]) apply clarsimp apply (vcg exspec= lookupCapAndSlot_modifies) apply simp apply (wp getMessageInfo_less_4 getMessageInfo_le3 getMessageInfo_msgLength')+ apply (simp add: msgMaxLength_def, wp getMessageInfo_msgLength')[1] apply simp apply wp apply (clarsimp simp: Collect_const_mem) apply (simp add: Kernel_C.msgInfoRegister_def ARM_H.msgInfoRegister_def ARM.msgInfoRegister_def Kernel_C.R1_def Kernel_C.capRegister_def ARM_H.capRegister_def ARM.capRegister_def Kernel_C.R0_def) apply (clarsimp simp: cfault_rel_def option_to_ptr_def) apply (simp add: seL4_Fault_CapFault_lift is_cap_fault_def) apply (frule lookup_failure_rel_fault_lift, assumption) apply clarsimp apply (clarsimp simp: ct_in_state'_def pred_tcb_at') apply (auto simp: ct_in_state'_def sch_act_simple_def intro!: active_ex_cap' elim!: pred_tcb'_weakenE dest!: st_tcb_at_idle_thread')[1] done lemma ccorres_return_void_catchbrk: "ccorres_underlying sr G r xf ar axf P P' hs f return_void_C \ ccorres_underlying sr G r xf ar axf P P' (catchbrk_C # hs) f return_void_C" apply (simp add: return_void_C_def catchbrk_C_def) apply (rule ccorresI') apply clarsimp apply (erule exec_handlers_Seq_cases') prefer 2 apply (clarsimp elim!: exec_Normal_elim_cases) apply (clarsimp elim!: exec_Normal_elim_cases) apply (erule exec_handlers.cases, simp_all) prefer 2 apply (auto elim!: exec_Normal_elim_cases)[1] apply (clarsimp elim!: exec_Normal_elim_cases) apply (erule exec_Normal_elim_cases, simp_all) apply (clarsimp elim!: exec_Normal_elim_cases) apply (erule(4) ccorresE) apply (rule EHAbrupt) apply (fastforce intro: exec.intros) apply assumption apply clarsimp apply (frule exec_handlers_less) apply clarsimp apply fastforce done lemma real_cte_tcbCallerSlot: "tcb_at' t s \ \ real_cte_at' (t + 2 ^ cte_level_bits * tcbCallerSlot) s" apply (clarsimp simp: obj_at'_def projectKOs objBits_simps cte_level_bits_def tcbCallerSlot_def) apply (drule_tac x=t and y="t + a" for a in ps_clearD, assumption) apply (rule le_neq_trans, simp_all)[1] apply (erule is_aligned_no_wrap') apply simp apply (subst field_simps[symmetric], rule is_aligned_no_overflow3, assumption, simp_all) apply (simp add: word_bits_def) done lemma handleReply_ccorres: "ccorres dc xfdc (\s. invs' s \ st_tcb_at' (\a. \ isReply a) (ksCurThread s) s \ sch_act_simple s) UNIV [] (handleReply) (Call handleReply_'proc)" apply cinit apply (rule ccorres_pre_getCurThread) apply (simp only: getThreadCallerSlot_def locateSlot_conv) apply (rule_tac P="\s. thread=ksCurThread s \ invs' s \ is_aligned thread 9" and r'="\ a c. c = cte_Ptr a" and xf'="callerSlot_'" and P'=UNIV in ccorres_split_nothrow) apply (rule ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def word_sle_def) apply (frule aligned_neg_mask) apply (frule tcb_at_invs') apply (simp add: mask_def tcbCallerSlot_def cte_level_bits_def size_of_def ptr_add_assertion_positive tcb_cnode_index_defs rf_sr_ksCurThread rf_sr_tcb_ctes_array_assertion2[THEN array_assertion_shrink_right]) apply ceqv apply (simp del: Collect_const) apply (rule ccorres_getSlotCap_cte_at) apply (rule ccorres_move_c_guard_cte) apply ctac apply (wpc, simp_all) apply (rule ccorres_fail) apply (simp add: ccap_relation_NullCap_iff cap_tag_defs) apply (rule ccorres_split_throws) apply (rule ccorres_Catch) apply csymbr apply (rule ccorres_cond_false) apply (rule ccorres_cond_true) apply simp apply (rule ccorres_return_void_catchbrk) apply (rule ccorres_return_void_C[unfolded dc_def]) apply (vcg exspec=doReplyTransfer_modifies) apply (rule ccorres_fail)+ apply (wpc, simp_all) apply (rule ccorres_fail) apply (rule ccorres_split_throws) apply (rule ccorres_Catch) apply csymbr apply (rule ccorres_cond_true) apply (frule cap_get_tag_isCap_unfolded_H_cap(8)) apply simp apply (rule ccorres_rhs_assoc)+ apply csymbr+ apply (frule cap_get_tag_ReplyCap) apply (clarsimp simp: to_bool_def) apply (csymbr, csymbr) apply simp apply (rule ccorres_assert2) apply (fold dc_def) apply (rule ccorres_add_return2) apply (ctac (no_vcg)) apply (rule ccorres_return_void_catchbrk) apply (rule ccorres_return_void_C) apply wp apply (vcg exspec=doReplyTransfer_modifies) apply (rule ccorres_fail)+ apply simp_all apply (simp add: getSlotCap_def) apply (wp getCTE_wp')[1] apply vcg apply wp apply vcg apply clarsimp apply (intro allI conjI impI, simp_all add: cap_get_tag_isCap_unfolded_H_cap cap_tag_defs) apply (rule tcb_aligned', rule tcb_at_invs', simp) apply (auto simp: cte_wp_at_ctes_of valid_cap'_def dest!: ctes_of_valid')[1] apply (simp add: real_cte_tcbCallerSlot[OF pred_tcb_at']) apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) apply clarsimp apply (frule cap_get_tag_isCap_unfolded_H_cap) apply (simp add: cap_get_tag_ReplyCap) apply clarsimp apply (frule cap_get_tag_isCap_unfolded_H_cap) apply (simp add: cap_get_tag_ReplyCap to_bool_def) done lemma deleteCallerCap_ccorres [corres]: "ccorres dc xfdc (\s. invs' s \ tcb_at' receiver s) (UNIV \ {s. receiver_' s = tcb_ptr_to_ctcb_ptr receiver}) [] (deleteCallerCap receiver) (Call deleteCallerCap_'proc)" apply (cinit lift: receiver_') apply (simp only: getThreadCallerSlot_def locateSlot_conv) apply (rule ccorres_move_array_assertion_tcb_ctes ccorres_Guard_Seq)+ apply (rule_tac P="\_. is_aligned receiver 9" and r'="\ a c. cte_Ptr a = c" and xf'="callerSlot_'" and P'=UNIV in ccorres_split_nothrow_novcg) apply (rule ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def word_sle_def) apply (frule aligned_neg_mask) apply (simp add: mask_def tcbCallerSlot_def Kernel_C.tcbCaller_def cte_level_bits_def size_of_def) apply (drule ptr_val_tcb_ptr_mask2) apply (simp add: mask_def) apply ceqv apply (rule ccorres_symb_exec_l) apply (rule ccorres_symb_exec_l) apply (rule ccorres_symb_exec_r) apply (ctac add: cteDeleteOne_ccorres[where w="ucast cap_reply_cap"]) apply vcg apply (rule conseqPre, vcg, clarsimp simp: rf_sr_def gs_set_assn_Delete_cstate_relation[unfolded o_def]) apply (wp | simp)+ apply (simp add: getSlotCap_def) apply (wp getCTE_wp)+ apply clarsimp apply (simp add: guard_is_UNIV_def ghost_assertion_data_get_def ghost_assertion_data_set_def) apply (clarsimp simp: cte_wp_at_ctes_of cap_get_tag_isCap[symmetric] cap_tag_defs tcb_cnode_index_defs word_sle_def tcb_aligned') done (* FIXME: MOVE *) lemma cap_case_EndpointCap_NotificationCap: "(case cap of EndpointCap v0 v1 v2 v3 v4 \ f v0 v1 v2 v3 v4 | NotificationCap v0 v1 v2 v3 \ g v0 v1 v2 v3 | _ \ h) = (if isEndpointCap cap then f (capEPPtr cap) (capEPBadge cap) (capEPCanSend cap) (capEPCanReceive cap) (capEPCanGrant cap) else if isNotificationCap cap then g (capNtfnPtr cap) (capNtfnBadge cap) (capNtfnCanSend cap) (capNtfnCanReceive cap) else h)" by (simp add: isCap_simps split: capability.split) (* FIXME: MOVE *) lemma capFaultOnFailure_if_case_sum: " (capFaultOnFailure epCPtr b (if c then f else g) >>= sum.case_sum (handleFault thread) return) = (if c then ((capFaultOnFailure epCPtr b f) >>= sum.case_sum (handleFault thread) return) else ((capFaultOnFailure epCPtr b g) >>= sum.case_sum (handleFault thread) return))" by (case_tac c, clarsimp, clarsimp) (* FIXME: MOVE to Corres_C.thy *) lemma ccorres_trim_redundant_throw_break: "\ccorres_underlying rf_sr \ arrel axf arrel axf G G' (SKIP # hs) a c; \s f. axf (global_exn_var_'_update f s) = axf s \ \ ccorres_underlying rf_sr \ r xf arrel axf G G' (SKIP # hs) a (c;; Basic (global_exn_var_'_update (\_. Break));; THROW)" apply - apply (rule ccorres_trim_redundant_throw') apply simp apply simp apply simp done lemma invs_valid_objs_strengthen: "invs' s \ valid_objs' s" by fastforce lemma ct_not_ksQ_strengthen: "thread = ksCurThread s \ ksCurThread s \ set (ksReadyQueues s p) \ thread \ set (ksReadyQueues s p)" by fastforce lemma option_to_ctcb_ptr_valid_ntfn: "valid_ntfn' ntfn s ==> (option_to_ctcb_ptr (ntfnBoundTCB ntfn) = NULL) = (ntfnBoundTCB ntfn = None)" apply (cases "ntfnBoundTCB ntfn", simp_all add: option_to_ctcb_ptr_def) apply (clarsimp simp: valid_ntfn'_def tcb_at_not_NULL) done lemma deleteCallerCap_valid_ntfn'[wp]: "\\s. valid_ntfn' x s\ deleteCallerCap c \\rv s. valid_ntfn' x s\" apply (wp hoare_vcg_ex_lift hoare_vcg_all_lift hoare_vcg_ball_lift hoare_vcg_imp_lift | simp add: valid_ntfn'_def split: ntfn.splits)+ apply auto done lemma hoare_vcg_imp_liftE: "\\P'\ f \\rv s. \ P rv s\, \E\; \Q'\ f \Q\, \E\\ \ \\s. P' s \ Q' s\ f \\rv s. P rv s \ Q rv s\, \E\" apply (simp add: validE_def valid_def split_def split: sum.splits) done lemma not_obj_at'_ntfn: "(\obj_at' (P::Structures_H.notification \ bool) t s) = (\ typ_at' NotificationT t s \ obj_at' (Not \ P) t s)" apply (simp add: obj_at'_real_def projectKOs typ_at'_def ko_wp_at'_def objBits_simps) apply (rule iffI) apply (clarsimp) apply (case_tac ko) apply (clarsimp)+ done lemma handleRecv_ccorres: notes rf_sr_upd_safe[simp del] shows "ccorres dc xfdc (\s. invs' s \ st_tcb_at' simple' (ksCurThread s) s \ sch_act_sane s \ (\p. ksCurThread s \ set (ksReadyQueues s p))) {s. isBlocking_' s = from_bool isBlocking} [] (handleRecv isBlocking) (Call handleRecv_'proc)" apply (cinit lift: isBlocking_') apply (rule ccorres_pre_getCurThread) apply (ctac) apply (simp add: catch_def) apply (simp add: capFault_bindE) apply (simp add: bindE_bind_linearise) apply (rule_tac xf'=lu_ret___struct_lookupCap_ret_C_' in ccorres_split_nothrow_case_sum) apply (rule capFaultOnFailure_ccorres) apply (ctac add: lookupCap_ccorres) apply ceqv apply clarsimp apply (rule ccorres_Catch) apply csymbr apply (simp add: cap_get_tag_isCap del: Collect_const) apply (clarsimp simp: cap_case_EndpointCap_NotificationCap capFaultOnFailure_if_case_sum) apply (rule ccorres_cond_both' [where Q=\ and Q'=\]) apply clarsimp apply (rule ccorres_rhs_assoc)+ apply csymbr apply (simp add: case_bool_If capFaultOnFailure_if_case_sum) apply (rule ccorres_if_cond_throws_break2 [where Q=\ and Q'=\]) apply clarsimp apply (simp add: cap_get_tag_isCap[symmetric] cap_get_tag_EndpointCap del: Collect_const) apply (simp add: to_bool_def) apply (rule ccorres_rhs_assoc)+ apply (simp add: capFaultOnFailure_def rethrowFailure_def handleE'_def throwError_def) apply (rule ccorres_cross_over_guard[where P=\]) apply (rule ccorres_symb_exec_r) apply (rule ccorres_cross_over_guard[where P=\]) apply (rule ccorres_symb_exec_r) apply (rule ccorres_add_return2) apply (rule ccorres_split_nothrow_call[where xf'=xfdc and d'="\_. break_C" and Q="\_ _. True" and Q'="\_ _. UNIV"]) apply (ctac add: handleFault_ccorres[unfolded dc_def]) apply simp+ apply ceqv apply (rule ccorres_break_return) apply simp+ apply wp apply (vcg exspec=handleFault_modifies) apply vcg apply (rule conseqPre, vcg) apply (clarsimp simp: rf_sr_upd_safe) apply vcg apply (rule conseqPre, vcg) apply (clarsimp simp: rf_sr_upd_safe) apply (simp add: liftE_bind) apply (ctac) apply (rule_tac P="\s. ksCurThread s = rv" in ccorres_cross_over_guard) apply (ctac add: receiveIPC_ccorres[unfolded dc_def]) apply (wp deleteCallerCap_ksQ_ct' hoare_vcg_all_lift) apply (rule conseqPost[where Q'=UNIV and A'="{}"], vcg exspec=deleteCallerCap_modifies) apply (clarsimp dest!: rf_sr_ksCurThread) apply simp apply clarsimp apply (vcg exspec=handleFault_modifies) apply (clarsimp simp: case_bool_If capFaultOnFailure_if_case_sum capFault_bindE) apply (simp add: liftE_bindE bind_bindE_assoc bind_assoc) apply (rule ccorres_cond_both' [where Q=\ and Q'=\]) apply clarsimp apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply csymbr apply csymbr apply (rename_tac thread epCPtr rv rva ntfnptr) apply (rule_tac P="valid_cap' rv" in ccorres_cross_over_guard) apply (simp only: capFault_injection injection_handler_If injection_liftE injection_handler_throwError if_to_top_of_bind) apply csymbr apply (rule ccorres_abstract_cleanup) apply csymbr apply csymbr apply (rule ccorres_if_lhs) apply (rule ccorres_pre_getNotification) apply (rename_tac ntfn) apply (rule_tac Q="valid_ntfn' ntfn and (\s. thread = ksCurThread s)" and Q'="\s. ret__unsigneda = ptr_val (option_to_ctcb_ptr (ntfnBoundTCB ntfn))" in ccorres_if_cond_throws_break2) apply (clarsimp simp: cap_get_tag_isCap[symmetric] cap_get_tag_NotificationCap option_to_ctcb_ptr_valid_ntfn rf_sr_ksCurThread) apply (auto simp: option_to_ctcb_ptr_def)[1] apply (rule ccorres_rhs_assoc)+ apply (simp add: capFaultOnFailure_def rethrowFailure_def handleE'_def throwError_def) apply (rule ccorres_cross_over_guard[where P=\]) apply (rule ccorres_symb_exec_r) apply (rule ccorres_cross_over_guard[where P=\]) apply (rule ccorres_symb_exec_r) apply (rule ccorres_add_return2) apply (rule ccorres_split_nothrow_call[where xf'=xfdc and d'="\_. break_C" and Q="\_ _. True" and Q'="\_ _. UNIV"]) apply (ctac add: handleFault_ccorres[unfolded dc_def]) apply simp+ apply ceqv apply (rule ccorres_break_return) apply simp+ apply wp apply (vcg exspec=handleFault_modifies) apply vcg apply (rule conseqPre, vcg) apply (clarsimp simp: rf_sr_upd_safe) apply vcg apply (rule conseqPre, vcg) apply (clarsimp simp: rf_sr_upd_safe) apply (simp add: liftE_bind) apply (ctac add: receiveSignal_ccorres[unfolded dc_def]) apply clarsimp apply (vcg exspec=handleFault_modifies) apply (rule ccorres_cond_true_seq) apply (rule ccorres_split_throws) apply (rule ccorres_rhs_assoc)+ apply (simp add: capFaultOnFailure_def rethrowFailure_def handleE'_def throwError_def) apply (rule ccorres_cross_over_guard[where P=\]) apply (rule ccorres_symb_exec_r) apply (rule ccorres_cross_over_guard[where P=\]) apply (rule ccorres_symb_exec_r) apply (rule ccorres_add_return2) apply (ctac add: handleFault_ccorres[unfolded dc_def]) apply (rule ccorres_break_return[where P=\ and P'=UNIV]) apply simp+ apply wp apply (vcg exspec=handleFault_modifies) apply vcg apply (rule conseqPre, vcg) apply (clarsimp simp: rf_sr_upd_safe) apply vcg apply (rule conseqPre, vcg) apply (clarsimp simp: rf_sr_upd_safe) apply (vcg exspec=handleFault_modifies) apply (simp add: capFaultOnFailure_def rethrowFailure_def handleE'_def throwError_def) apply (rule ccorres_rhs_assoc)+ apply (rule ccorres_cross_over_guard[where P=\]) apply (rule ccorres_symb_exec_r) apply (rule ccorres_cross_over_guard[where P=\]) apply (rule ccorres_symb_exec_r) apply (ctac add: handleFault_ccorres[unfolded dc_def]) apply vcg apply (rule conseqPre, vcg) apply (clarsimp simp: rf_sr_upd_safe) apply vcg apply (rule conseqPre, vcg) apply (clarsimp simp: rf_sr_upd_safe) apply clarsimp apply (rule ccorres_add_return2) apply (rule ccorres_rhs_assoc)+ apply (rule ccorres_cross_over_guard[where P=\]) apply (rule ccorres_symb_exec_r) apply (ctac add: handleFault_ccorres[unfolded dc_def]) apply (rule ccorres_split_throws) apply (rule ccorres_return_void_C [unfolded dc_def]) apply vcg apply wp apply (vcg exspec=handleFault_modifies) apply vcg apply (rule conseqPre, vcg) apply (clarsimp simp: rf_sr_upd_safe) apply (wp) apply clarsimp apply (rename_tac thread epCPtr) apply (rule_tac Q'="(\rv s. invs' s \ st_tcb_at' simple' thread s \ sch_act_sane s \ (\p. thread \ set (ksReadyQueues s p)) \ thread = ksCurThread s \ valid_cap' rv s)" in hoare_post_imp_R[rotated]) apply (clarsimp simp: sch_act_sane_def) apply (auto dest!: obj_at_valid_objs'[OF _ invs_valid_objs'] simp: projectKOs valid_obj'_def, auto simp: pred_tcb_at'_def obj_at'_def objBits_simps projectKOs ct_in_state'_def)[1] apply wp apply clarsimp apply (vcg exspec=isBlocked_modifies exspec=lookupCap_modifies) apply wp apply clarsimp apply vcg apply (clarsimp simp add: sch_act_sane_def) apply (simp add: cap_get_tag_isCap[symmetric] del: rf_sr_upd_safe) apply (simp add: Kernel_C.capRegister_def ARM_H.capRegister_def ct_in_state'_def ARM.capRegister_def Kernel_C.R0_def tcb_at_invs') apply (frule invs_valid_objs') apply (frule tcb_aligned'[OF tcb_at_invs']) apply clarsimp apply (intro conjI impI allI) apply (clarsimp simp: cfault_rel_def seL4_Fault_CapFault_lift lookup_fault_missing_capability_lift is_cap_fault_def)+ apply (clarsimp simp: cap_get_tag_NotificationCap) apply (rule cmap_relationE1[OF cmap_relation_ntfn], assumption, erule ko_at_projectKO_opt) apply (clarsimp simp: cnotification_relation_def Let_def) apply (clarsimp simp: cfault_rel_def seL4_Fault_CapFault_lift lookup_fault_missing_capability_lift is_cap_fault_def)+ apply (clarsimp simp: cap_get_tag_NotificationCap) apply (simp add: ccap_relation_def to_bool_def) apply (clarsimp simp: cap_get_tag_NotificationCap valid_cap'_def) apply (drule obj_at_ko_at', clarsimp) apply (rule cmap_relationE1[OF cmap_relation_ntfn], assumption, erule ko_at_projectKO_opt) apply (clarsimp simp: typ_heap_simps) apply (clarsimp simp: cfault_rel_def seL4_Fault_CapFault_lift lookup_fault_missing_capability_lift is_cap_fault_def)+ apply (case_tac w, clarsimp+) done lemma handleYield_ccorres: "ccorres dc xfdc (invs' and ct_active') UNIV [] (handleYield) (Call handleYield_'proc)" apply cinit apply (rule ccorres_pre_getCurThread) apply (ctac add: tcbSchedDequeue_ccorres) apply (ctac add: tcbSchedAppend_ccorres) apply (ctac add: rescheduleRequired_ccorres) apply (wp weak_sch_act_wf_lift_linear tcbSchedAppend_valid_objs') apply (vcg exspec= tcbSchedAppend_modifies) apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues) apply (vcg exspec= tcbSchedDequeue_modifies) apply (clarsimp simp: tcb_at_invs' invs_valid_objs' valid_objs'_maxPriority valid_objs'_maxDomain) apply (auto simp: obj_at'_def st_tcb_at'_def ct_in_state'_def valid_objs'_maxDomain) done lemma getIRQState_sp: "\P\ getIRQState irq \\rv s. rv = intStateIRQTable (ksInterruptState s) irq \ P s\" apply (simp add: getIRQState_def getInterruptState_def) apply wp apply simp done lemma ccorres_pre_getIRQState: assumes cc: "\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c" shows "ccorres r xf (\s. irq \ ucast Kernel_C.maxIRQ \ P (intStateIRQTable (ksInterruptState s) irq) s) {s. \rv. index (intStateIRQTable_' (globals s)) (unat irq) = irqstate_to_C rv \ s \ P' rv } hs (getIRQState irq >>= (\rv. f rv)) c" apply (rule ccorres_guard_imp) apply (rule ccorres_symb_exec_l) defer apply (simp add: getIRQState_def getInterruptState_def) apply wp apply simp apply (rule getIRQState_sp) apply (simp add: getIRQState_def getInterruptState_def) apply assumption prefer 2 apply (rule ccorres_guard_imp) apply (rule cc) apply simp apply assumption apply clarsimp apply (erule allE) apply (erule impE) prefer 2 apply assumption apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cinterrupt_relation_def) done (* FIXME: move *) lemma ccorres_ntfn_cases: assumes P: "\p b send d. cap = NotificationCap p b send d \ ccorres r xf (P p b send d) (P' p b send d) hs (a cap) (c cap)" assumes Q: "\isNotificationCap cap \ ccorres r xf (Q cap) (Q' cap) hs (a cap) (c cap)" shows "ccorres r xf (\s. (\p b send d. cap = NotificationCap p b send d \ P p b send d s) \ (\isNotificationCap cap \ Q cap s)) ({s. \p b send d. cap = NotificationCap p b send d \ s \ P' p b send d} \ {s. \isNotificationCap cap \ s \ Q' cap}) hs (a cap) (c cap)" apply (cases "isNotificationCap cap") apply (simp add: isCap_simps) apply (elim exE) apply (rule ccorres_guard_imp) apply (erule P) apply simp apply simp apply (rule ccorres_guard_imp) apply (erule Q) apply clarsimp apply clarsimp done (* FIXME: generalise the one in Interrupt_C *) lemma getIRQSlot_ccorres2: "ccorres (op = \ Ptr) slot_' \ UNIV hs (getIRQSlot irq) (\slot :== CTypesDefs.ptr_add \intStateIRQNode (uint (ucast irq :: word32)))" apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: getIRQSlot_def liftM_def getInterruptState_def locateSlot_conv) apply (simp add: simpler_gets_def bind_def return_def) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cinterrupt_relation_def size_of_def cte_level_bits_def mult.commute mult.left_commute ucast_nat_def) done lemma getIRQSlot_ccorres3: "(\rv. ccorresG rf_sr \ r xf (P rv) (P' rv) hs (f rv) c) \ ccorresG rf_sr \ r xf (\s. P (intStateIRQNode (ksInterruptState s) + 2 ^ cte_level_bits * of_nat (unat irq)) s) {s. s \ P' (ptr_val (CTypesDefs.ptr_add (intStateIRQNode_' (globals s)) (uint (ucast irq :: word32))))} hs (getIRQSlot irq >>= f) c" apply (simp add: getIRQSlot_def locateSlot_conv liftM_def getInterruptState_def) apply (rule ccorres_symb_exec_l'[OF _ _ gets_sp]) apply (rule ccorres_guard_imp2, assumption) apply (clarsimp simp: getIRQSlot_ccorres_stuff objBits_simps cte_level_bits_def ucast_nat_def uint_ucast uint_up_ucast is_up) apply wp+ done lemma ucast_eq_0[OF refl]: "c = ucast \ is_up c \ (c x = 0) = (x = 0)" apply (frule(1) inj_ucast) apply (drule inj_eq[where x=x and y=0], simp) done lemma is_up_compose': fixes uc :: "('a::len) word \ ('b::len) word" and uc' :: "'b word \ ('c::len) sword" shows "\is_up uc; is_up uc'\ \ is_up (uc' \ uc)" unfolding is_up_def by (simp add: Word.target_size Word.source_size) lemma is_up_compose: shows "\is_up uc; is_up uc'\ \ is_up (uc' \ uc)" unfolding is_up_def by (simp add: Word.target_size Word.source_size) lemma uint_is_up_compose: fixes uc :: "('a::len) word \ ('b::len) word" and uc' :: "'b word \ ('c::len) sword" assumes "uc = ucast" and "uc' = ucast" and " uuc = uc' \ uc" shows "\ is_up uc; is_up uc' \ \ uint (uuc b) = uint b" apply (simp add: assms) apply (frule is_up_compose) apply (simp_all ) apply (simp only: Word.uint_up_ucast) done lemma uint_is_up_compose_pred: fixes uc :: "('a::len) word \ ('b::len) word" and uc' :: "'b word \ ('c::len) sword" assumes "uc = ucast" and "uc' = ucast" and " uuc = uc' \ uc" shows "\ is_up uc; is_up uc' \ \ P (uint (uuc b)) \ P( uint b)" apply (simp add: assms) apply (frule is_up_compose) apply (simp_all ) apply (simp only: Word.uint_up_ucast) done lemma is_down_up_sword: fixes uc :: "('a::len) word \ ('b::len) sword" shows "\uc = ucast; len_of TYPE('a) < len_of TYPE('b) \ \ is_up uc = (\ is_down uc)" by (simp add: target_size source_size is_up_def is_down_def ) lemma is_not_down_compose: fixes uc :: "('a::len) word \ ('b::len) word" and uc' :: "'b word \ ('c::len) sword" shows "\uc = ucast; uc' = ucast; len_of TYPE('a) < len_of TYPE('c)\ \ \ is_down (uc' \ uc) " unfolding is_down_def by (simp add: Word.target_size Word.source_size) lemma sint_ucast_uint: fixes uc :: "('a::len) word \ ('b::len) word" and uc' :: "'b word \ ('c::len) sword" assumes "uc = ucast" and " uc' = ucast" and "uuc=uc' \ uc " and "len_of TYPE('a) < len_of TYPE('c signed)" shows "\ is_up uc; is_up uc'\ \ sint (uuc b) = uint b" apply (simp add: assms) apply (frule is_up_compose') apply simp_all apply (simp add: ucast_ucast_b) apply (rule sint_ucast_eq_uint) apply (insert assms) apply (simp add: is_down_def target_size source_size) done lemma sint_ucast_uint_pred: fixes uc :: "('a::len) word \ ('b::len) word" and uc' :: "'b word \ ('c::len) sword" and uuc :: "'a word \ 'c sword" assumes "uc = ucast" and " uc' = ucast" and "uuc=uc' \ uc " and "len_of TYPE('a) < len_of TYPE('c )" shows "\is_up uc; is_up uc'\ \ P (uint b) \ P (sint (uuc b))" apply (simp add: assms ) apply (insert sint_ucast_uint[where uc=uc and uc'=uc' and uuc=uuc and b = b]) apply (simp add: assms) done lemma sint_uucast_uint_uucast_pred: fixes uc :: "('a::len) word \ ('b::len) word" and uc' :: "'b word \ ('c::len) sword" assumes "uc = ucast" and " uc' = ucast" and "uuc=uc' \ uc " and "len_of TYPE('a) < len_of TYPE('c )" shows "\is_up uc; is_up uc'\ \ P (uint(uuc b)) \ P (sint (uuc b))" apply (simp add: assms ) apply (insert sint_ucast_uint[where uc=uc and uc'=uc' and uuc=uuc and b = b]) apply (insert uint_is_up_compose_pred[where uc=uc and uc'=uc' and uuc=uuc and b=b]) apply (simp add: assms uint_is_up_compose_pred) done lemma scast_maxIRQ_is_less: fixes uc :: "irq \ 16 word" and uc' :: "16 word\ 32 sword" and b :: irq shows "(Kernel_C.maxIRQ) (ucast :: irq \ 16 word)) b \ scast Kernel_C.maxIRQ < b" apply (simp add: Kernel_C.maxIRQ_def word_sless_def word_sle_def, uint_arith, clarify,simp) apply (subgoal_tac "sint (ucast Kernel_C.maxIRQ :: 32 sword) \ uint b"; (simp only: Kernel_C.maxIRQ_def)?) apply (subgoal_tac "sint (ucast Kernel_C.maxIRQ :: 32 sword) \ uint b"; (simp only: Kernel_C.maxIRQ_def)?) apply (simp ) apply (subst uint_is_up_compose[where uc="(ucast :: irq \ 16 word)" and uc' = "(ucast :: 16 word \ 32 sword)",symmetric]; (simp add: is_up_def target_size source_size )?) apply fastforce apply (subst sint_ucast_uint_pred[where uc="(ucast :: irq \ 16 word)" and uc' = "(ucast :: 16 word \ 32 sword)"]; (simp add: is_up_def target_size source_size )?) apply fastforce done lemma validIRQcastingLess: "Kernel_C.maxIRQ ARM.maxIRQ < b" by (simp add: Platform_maxIRQ scast_maxIRQ_is_less is_up_def target_size source_size) lemma scast_maxIRQ_is_not_less: "(\ (Kernel_C.maxIRQ) (ucast :: irq \ 16 word)) b) \ \ (scast Kernel_C.maxIRQ < b)" apply (subgoal_tac "sint (ucast Kernel_C.maxIRQ :: 32 sword) \ sint (ucast (ucast b))"; (simp only: Kernel_C.maxIRQ_def word_sless_def word_sle_def )?) apply (simp add: maxIRQ_def word_sless_def word_sle_def, uint_arith, clarify,simp) apply (subst (asm) sint_ucast_uint[where b=b and 'c = 32 and 'b = 16 and uc=ucast and uc' = ucast and uuc = "ucast \ ucast" , simplified]; (simp add: is_up_def target_size source_size)?) apply (subst (asm) uint_is_up_compose[where 'b = 16 and uuc="ucast \ ucast", simplified]; (simp add: is_up_def target_size source_size)?) apply (simp add: maxIRQ_def word_sless_def word_sle_def, uint_arith, clarify,simp) apply (subst (asm) (2) sint_ucast_uint_pred[where 'a = 10 and 'b = 16 and 'c = 32 and uuc = "ucast \ ucast", simplified,symmetric ]; ((simp add: is_up_def target_size source_size)?)) apply (subst sint_ucast_uint_pred[where 'a = 10 and 'b = 16 and 'c = 32 and uuc = "ucast \ ucast", simplified,symmetric ]; ((simp add: is_up_def target_size source_size)?)) apply (subst (asm) (2) uint_is_up_compose[where 'b = 16 and uuc="ucast \ ucast", simplified]; (simp add: is_up_def target_size source_size)?) apply (uint_arith) done lemma ccorres_handleReserveIRQ: "ccorres dc xfdc \ UNIV hs (handleReservedIRQ irq) (Call handleReservedIRQ_'proc)" apply cinit apply (rule ccorres_return_Skip) apply simp done lemma handleInterrupt_ccorres: "ccorres dc xfdc (invs') (UNIV \ \\irq = ucast irq\) [] (handleInterrupt irq) (Call handleInterrupt_'proc)" apply (cinit lift: irq_' cong: call_ignore_cong) apply (rule ccorres_Cond_rhs_Seq) apply (simp add: Platform_maxIRQ del: Collect_const) apply (drule scast_maxIRQ_is_less[simplified]) apply (simp del: Collect_const) apply (rule ccorres_rhs_assoc)+ apply (subst doMachineOp_bind) apply (rule maskInterrupt_empty_fail) apply (rule ackInterrupt_empty_fail) apply (ctac add: maskInterrupt_ccorres[unfolded dc_def]) apply (subst bind_return_unit[where f="doMachineOp (ackInterrupt irq)"]) apply (ctac add: ackInterrupt_ccorres[unfolded dc_def]) apply (rule ccorres_split_throws) apply (rule ccorres_return_void_C[unfolded dc_def]) apply vcg apply wp apply (vcg exspec=ackInterrupt_modifies) apply wp apply (vcg exspec=maskInterrupt_modifies) apply (simp add: scast_maxIRQ_is_not_less Platform_maxIRQ del: Collect_const) apply (rule ccorres_pre_getIRQState) apply wpc apply simp apply (rule ccorres_fail) apply (simp add: bind_assoc cong: call_ignore_cong) apply (rule ccorres_move_const_guards)+ apply (rule ccorres_cond_true_seq) apply (rule ccorres_rhs_assoc)+ apply csymbr apply (rule getIRQSlot_ccorres3) apply (rule ccorres_getSlotCap_cte_at) apply (rule_tac P="cte_at' rv" in ccorres_cross_over_guard) apply (rule ptr_add_assertion_irq_guard[unfolded dc_def]) apply (rule ccorres_move_array_assertion_irq ccorres_move_c_guard_cte)+ apply ctac apply csymbr apply csymbr apply (rule ccorres_ntfn_cases) apply (clarsimp cong: call_ignore_cong simp del: Collect_const) apply (rule_tac b=send in ccorres_case_bools) apply simp apply (rule ccorres_cond_true_seq) apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply (rule ccorres_cond_true_seq) apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply (ctac (no_vcg) add: sendSignal_ccorres) apply (ctac (no_vcg) add: maskInterrupt_ccorres) apply (ctac add: ackInterrupt_ccorres [unfolded dc_def]) apply wp+ apply (simp del: Collect_const) apply (rule ccorres_cond_true_seq) apply (rule ccorres_rhs_assoc)+ apply csymbr+ apply (rule ccorres_cond_false_seq) apply simp apply (ctac (no_vcg) add: maskInterrupt_ccorres) apply (ctac add: ackInterrupt_ccorres [unfolded dc_def]) apply wp apply (rule_tac P=\ and P'="{s. ret__int_' s = 0 \ cap_get_tag cap \ scast cap_notification_cap}" in ccorres_inst) apply (clarsimp simp: isCap_simps simp del: Collect_const) apply (case_tac rva, simp_all del: Collect_const)[1] prefer 3 apply metis apply ((rule ccorres_guard_imp2, rule ccorres_cond_false_seq, simp, rule ccorres_cond_false_seq, simp, ctac (no_vcg) add: maskInterrupt_ccorres, ctac (no_vcg) add: ackInterrupt_ccorres [unfolded dc_def], wp, simp)+) apply (wp getSlotCap_wp) apply simp apply vcg apply (simp add: bind_assoc) apply (rule ccorres_move_const_guards)+ apply (rule ccorres_cond_false_seq) apply (rule ccorres_cond_true_seq) apply (fold dc_def)[1] apply (rule ccorres_rhs_assoc)+ apply (ctac (no_vcg) add: timerTick_ccorres) apply (ctac (no_vcg) add: resetTimer_ccorres) apply (ctac add: ackInterrupt_ccorres ) apply wp+ apply (simp add: Platform_maxIRQ maxIRQ_def del: Collect_const) apply (rule ccorres_move_const_guards)+ apply (rule ccorres_cond_false_seq) apply (rule ccorres_cond_false_seq) apply (rule ccorres_cond_true_seq) apply (ctac add: ccorres_handleReserveIRQ) apply (ctac (no_vcg) add: ackInterrupt_ccorres [unfolded dc_def]) apply wp apply vcg apply (simp add: sint_ucast_eq_uint is_down uint_up_ucast is_up ) apply (clarsimp simp: word_sless_alt word_less_alt word_le_def Kernel_C.maxIRQ_def uint_up_ucast is_up_def source_size_def target_size_def word_size sint_ucast_eq_uint is_down is_up word_0_sle_from_less) apply (rule conjI) apply (clarsimp simp: cte_wp_at_ctes_of ) apply (clarsimp simp add: if_1_0_0 Collect_const_mem ) apply (clarsimp simp: Kernel_C.IRQTimer_def Kernel_C.IRQSignal_def cte_wp_at_ctes_of ucast_ucast_b is_up) apply (intro conjI impI) apply clarsimp apply (erule(1) cmap_relationE1[OF cmap_relation_cte]) apply (clarsimp simp: typ_heap_simps') apply (simp add: cap_get_tag_isCap) apply (clarsimp simp: isCap_simps) apply (frule cap_get_tag_isCap_unfolded_H_cap) apply (frule cap_get_tag_to_H, assumption) apply (clarsimp simp: to_bool_def) apply (cut_tac un_ui_le[where b = 159 and a = irq, simplified word_size]) apply (simp add: ucast_eq_0 is_up_def source_size_def target_size_def word_size unat_gt_0 | subst array_assertion_abs_irq[rule_format, OF conjI])+ apply (erule exE conjE)+ apply (erule(1) rf_sr_cte_at_valid[OF ctes_of_cte_at]) apply (clarsimp simp:nat_le_iff) apply (clarsimp simp: IRQReserved_def)+ done end end