From 9d404be331ea4cb94baa48876ea35470ed7cdcf6 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Thu, 5 May 2022 16:26:38 +1000 Subject: [PATCH] crefine: split fastpath, rearrange Refine-based theory imports Several parts of CRefine did not or should not depend on anything C-related, but the import hierarchy (and theory content) did not reflect this. Namely: * Move_C and ArchMove_C were intended to hold items that could be moved to Refine yet used `kernel_m` locale and imported the C spec. * IsolatedThreadAction indicates how to rearrange statements in the design spec and has nothing to do with the C spec or framework. * Fastpath_C contained the design spec of the fastpath, the design spec rewrite proofs, and the C refinement. Having to rebuild nearly all of CRefine to work on rewrite proofs wasted time. In the new import hierarchy: * Move_C imports only Refine; ArchMove_C builds on Move_C * IsolatedThreadAction imports only ArchMove_C * The fastpath proofs are split into the spec definition (Fastpath_Defs) and rewrite proofs (Fastpath_Equiv), which don't depend on anything C-related, with their C refinement remaining in Fastpath_C. While it is possible to separate out the fastpath definitions and rewire proofs into a separate image or even move them to Refine, development experience indicates keeping them alongside their C refinement remains more convenient for the proof engineer involved. Signed-off-by: Rafal Kolanski --- proof/crefine/ARM/ArchMove_C.thy | 77 + proof/crefine/ARM/CLevityCatch.thy | 45 +- proof/crefine/ARM/CSpaceAcc_C.thy | 4 - proof/crefine/ARM/CSpace_RAB_C.thy | 7 - proof/crefine/ARM/Fastpath_C.thy | 1761 +------------ proof/crefine/ARM/Fastpath_Defs.thy | 167 ++ proof/crefine/ARM/Fastpath_Equiv.thy | 1901 ++++++++++++++ proof/crefine/ARM/Finalise_C.thy | 5 - proof/crefine/ARM/Invoke_C.thy | 4 - proof/crefine/ARM/IpcCancel_C.thy | 7 - proof/crefine/ARM/Ipc_C.thy | 7 - proof/crefine/ARM/IsolatedThreadAction.thy | 52 +- proof/crefine/ARM/PSpace_C.thy | 11 +- proof/crefine/ARM/Refine_C.thy | 12 +- proof/crefine/ARM/Retype_C.thy | 5 - proof/crefine/ARM/SR_lemmas_C.thy | 74 +- proof/crefine/ARM/Syscall_C.thy | 16 - proof/crefine/ARM/Tcb_C.thy | 11 - proof/crefine/ARM/VSpace_C.thy | 12 - proof/crefine/ARM_HYP/ArchMove_C.thy | 89 +- proof/crefine/ARM_HYP/CLevityCatch.thy | 42 +- proof/crefine/ARM_HYP/CSpaceAcc_C.thy | 3 - proof/crefine/ARM_HYP/CSpace_RAB_C.thy | 8 - proof/crefine/ARM_HYP/Fastpath_C.thy | 2219 +---------------- proof/crefine/ARM_HYP/Fastpath_Defs.thy | 167 ++ proof/crefine/ARM_HYP/Fastpath_Equiv.thy | 1908 ++++++++++++++ proof/crefine/ARM_HYP/Finalise_C.thy | 5 - proof/crefine/ARM_HYP/IpcCancel_C.thy | 7 - proof/crefine/ARM_HYP/Ipc_C.thy | 7 - .../crefine/ARM_HYP/IsolatedThreadAction.thy | 66 +- proof/crefine/ARM_HYP/PSpace_C.thy | 7 - proof/crefine/ARM_HYP/Refine_C.thy | 10 +- proof/crefine/ARM_HYP/Retype_C.thy | 5 - proof/crefine/ARM_HYP/SR_lemmas_C.thy | 65 - proof/crefine/ARM_HYP/Tcb_C.thy | 11 - proof/crefine/ARM_HYP/VSpace_C.thy | 12 - proof/crefine/Move_C.thy | 152 +- proof/crefine/RISCV64/ArchMove_C.thy | 67 + proof/crefine/RISCV64/CLevityCatch.thy | 43 +- proof/crefine/RISCV64/CSpaceAcc_C.thy | 4 - proof/crefine/RISCV64/CSpace_RAB_C.thy | 7 - proof/crefine/RISCV64/Finalise_C.thy | 5 - proof/crefine/RISCV64/Invoke_C.thy | 6 - proof/crefine/RISCV64/IpcCancel_C.thy | 7 - proof/crefine/RISCV64/Ipc_C.thy | 7 - .../crefine/RISCV64/IsolatedThreadAction.thy | 67 +- proof/crefine/RISCV64/PSpace_C.thy | 7 - proof/crefine/RISCV64/Retype_C.thy | 5 - proof/crefine/RISCV64/SR_lemmas_C.thy | 65 - proof/crefine/RISCV64/Syscall_C.thy | 15 - proof/crefine/RISCV64/Tcb_C.thy | 5 - proof/crefine/RISCV64/VSpace_C.thy | 16 - proof/crefine/X64/ArchMove_C.thy | 78 + proof/crefine/X64/CLevityCatch.thy | 43 +- proof/crefine/X64/CSpaceAcc_C.thy | 6 +- proof/crefine/X64/CSpace_RAB_C.thy | 7 - proof/crefine/X64/Finalise_C.thy | 5 - proof/crefine/X64/IpcCancel_C.thy | 7 - proof/crefine/X64/Ipc_C.thy | 7 - proof/crefine/X64/IsolatedThreadAction.thy | 73 +- proof/crefine/X64/PSpace_C.thy | 7 - proof/crefine/X64/Retype_C.thy | 5 - proof/crefine/X64/SR_lemmas_C.thy | 65 - proof/crefine/X64/Syscall_C.thy | 15 - proof/crefine/X64/Tcb_C.thy | 5 - proof/crefine/X64/VSpace_C.thy | 29 - 66 files changed, 4848 insertions(+), 4791 deletions(-) create mode 100644 proof/crefine/ARM/Fastpath_Defs.thy create mode 100644 proof/crefine/ARM/Fastpath_Equiv.thy create mode 100644 proof/crefine/ARM_HYP/Fastpath_Defs.thy create mode 100644 proof/crefine/ARM_HYP/Fastpath_Equiv.thy diff --git a/proof/crefine/ARM/ArchMove_C.thy b/proof/crefine/ARM/ArchMove_C.thy index 88f935a33..6dcd98e18 100644 --- a/proof/crefine/ARM/ArchMove_C.thy +++ b/proof/crefine/ARM/ArchMove_C.thy @@ -178,6 +178,83 @@ lemma valid_untyped': nat_le_linear power_overflow sub_wrap add_0 add_0_right word_add_increasing word_less_1 word_less_sub_1) +(* We don't have access to n_msgRegisters from C here, but the number of msg registers in C should + be equivalent to what we have in the abstract/design specs. We want a number for this definition + that automatically updates if the number of registers changes, and we sanity check it later + in msgRegisters_size_sanity *) +definition size_msgRegisters :: nat where + size_msgRegisters_pre_def: "size_msgRegisters \ size (ARM.msgRegisters)" + +schematic_goal size_msgRegisters_def: + "size_msgRegisters = numeral ?x" + unfolding size_msgRegisters_pre_def ARM.msgRegisters_def + by (simp add: upto_enum_red fromEnum_def enum_register del: Suc_eq_numeral) + (simp only: Suc_eq_plus1_left, simp del: One_nat_def) + +lemma length_msgRegisters[simplified size_msgRegisters_def]: + "length ARM_H.msgRegisters = size_msgRegisters" + by (simp add: size_msgRegisters_pre_def ARM_H.msgRegisters_def) + +lemma cap_case_isPageDirectoryCap: + "(case cap of capability.ArchObjectCap (arch_capability.PageDirectoryCap pd ( Some asid)) \ fn pd asid + | _ => g) + = (if ( if (isArchObjectCap cap) then if (isPageDirectoryCap (capCap cap)) then capPDMappedASID (capCap cap) \ None else False else False) + then fn (capPDBasePtr (capCap cap)) (the ( capPDMappedASID (capCap cap))) else g)" + apply (cases cap; simp add: isArchObjectCap_def) + apply (rename_tac arch_capability) + apply (case_tac arch_capability, simp_all add: isPageDirectoryCap_def) + apply (rename_tac option) + apply (case_tac option; simp) + done + +lemma empty_fail_loadWordUser[intro!, simp]: + "empty_fail (loadWordUser x)" + by (simp add: loadWordUser_def ef_loadWord ef_dmo') + +lemma empty_fail_getMRs[iff]: + "empty_fail (getMRs t buf mi)" + by (auto simp add: getMRs_def split: option.split) + +lemma empty_fail_getReceiveSlots: + "empty_fail (getReceiveSlots r rbuf)" +proof - + note + empty_fail_assertE[iff] + empty_fail_resolveAddressBits[iff] + show ?thesis + apply (clarsimp simp: getReceiveSlots_def loadCapTransfer_def split_def + split: option.split) + apply (rule empty_fail_bind) + apply (simp add: capTransferFromWords_def) + apply (simp add: emptyOnFailure_def unifyFailure_def) + apply (intro empty_fail_catch empty_fail_bindE empty_fail_rethrowFailure, + simp_all add: empty_fail_whenEs) + apply (simp_all add: lookupCap_def split_def lookupCapAndSlot_def + lookupSlotForThread_def liftME_def + getThreadCSpaceRoot_def locateSlot_conv bindE_assoc + lookupSlotForCNodeOp_def lookupErrorOnFailure_def + cong: if_cong) + apply (intro empty_fail_bindE, + simp_all add: getSlotCap_def) + apply (intro empty_fail_If empty_fail_bindE empty_fail_rethrowFailure impI, + simp_all add: empty_fail_whenEs rangeCheck_def) + done +qed + +lemma user_getreg_rv: + "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb r)) t\ asUser t (getRegister r) \\rv s. P rv\" + apply (simp add: asUser_def split_def) + apply (wp threadGet_wp) + apply (clarsimp simp: obj_at'_def projectKOs getRegister_def in_monad atcbContextGet_def) + done + +crunches insertNewCap, Arch_createNewCaps, threadSet, Arch.createObject, setThreadState, + updateFreeIndex, preemptionPoint + for gsCNodes[wp]: "\s. P (gsCNodes s)" + (wp: crunch_wps setObject_ksPSpace_only + simp: unless_def updateObject_default_def crunch_simps + ignore_del: preemptionPoint) + end end diff --git a/proof/crefine/ARM/CLevityCatch.thy b/proof/crefine/ARM/CLevityCatch.thy index f5bd1303c..cb74756fc 100644 --- a/proof/crefine/ARM/CLevityCatch.thy +++ b/proof/crefine/ARM/CLevityCatch.thy @@ -14,8 +14,6 @@ begin context begin interpretation Arch . (*FIXME: arch_split*) -declare word_neq_0_conv [simp del] - (* Rule previously in the simpset, now not. *) declare ptr_add_def' [simp] @@ -60,14 +58,6 @@ lemma no_overlap_new_cap_addrs_disjoint: declare empty_fail_doMachineOp [simp] -lemma empty_fail_loadWordUser[intro!, simp]: - "empty_fail (loadWordUser x)" - by (simp add: loadWordUser_def ef_loadWord) - -lemma empty_fail_getMRs[iff]: - "empty_fail (getMRs t buf mi)" - by (auto simp add: getMRs_def split: option.split) - lemma asUser_get_registers: "\tcb_at' target\ asUser target (mapM getRegister xs) @@ -93,36 +83,19 @@ lemma asUser_get_registers: obj_at'_def) done -lemma empty_fail_getReceiveSlots: - "empty_fail (getReceiveSlots r rbuf)" -proof - - note - empty_fail_assertE[iff] - empty_fail_resolveAddressBits[iff] - show ?thesis - apply (clarsimp simp: getReceiveSlots_def loadCapTransfer_def split_def - split: option.split) - apply (rule empty_fail_bind) - apply (simp add: capTransferFromWords_def) - apply (simp add: emptyOnFailure_def unifyFailure_def) - apply (intro empty_fail_catch empty_fail_bindE empty_fail_rethrowFailure, - simp_all add: empty_fail_whenEs) - apply (simp_all add: lookupCap_def split_def lookupCapAndSlot_def - lookupSlotForThread_def liftME_def - getThreadCSpaceRoot_def locateSlot_conv bindE_assoc - lookupSlotForCNodeOp_def lookupErrorOnFailure_def - cong: if_cong) - apply (intro empty_fail_bindE, - simp_all add: getSlotCap_def) - apply (intro empty_fail_If empty_fail_bindE empty_fail_rethrowFailure impI, - simp_all add: empty_fail_whenEs rangeCheck_def) - done -qed - (* only exists in Haskell, only used for C refinement *) crunches writeTTBR0Ptr for (empty_fail) empty_fail[wp,simp] end +schematic_goal sz8_helper: + "((-1) << 8 :: addr) = ?v" + by (simp add: shiftl_t2n) + +lemmas reset_name_seq_bound_helper2 + = reset_name_seq_bound_helper[where sz=8 and v="v :: addr" for v, + simplified sz8_helper word_bits_def[symmetric], + THEN name_seq_bound_helper] + end diff --git a/proof/crefine/ARM/CSpaceAcc_C.thy b/proof/crefine/ARM/CSpaceAcc_C.thy index e9fb7012f..153b5e36b 100644 --- a/proof/crefine/ARM/CSpaceAcc_C.thy +++ b/proof/crefine/ARM/CSpaceAcc_C.thy @@ -181,10 +181,6 @@ lemma ccorres_pre_getIdleThread: apply (clarsimp simp: rf_sr_ksIdleThread) done - -lemma cd_wp [wp]: "\\s. P (ksCurDomain s) s\ curDomain \P\" - by (unfold curDomain_def, wp) - lemma curDomain_sp: "\P\ curDomain \\rv s. ksCurDomain s = rv \ P s\" apply wp diff --git a/proof/crefine/ARM/CSpace_RAB_C.thy b/proof/crefine/ARM/CSpace_RAB_C.thy index ca62f330c..71023e1d9 100644 --- a/proof/crefine/ARM/CSpace_RAB_C.thy +++ b/proof/crefine/ARM/CSpace_RAB_C.thy @@ -74,13 +74,6 @@ lemma ccorres_req: apply (clarsimp elim!: bexI [rotated]) done -lemma valid_cap_cte_at': - "\isCNodeCap cap; valid_cap' cap s'\ \ cte_at' (capCNodePtr cap + 2^cteSizeBits * (addr && mask (capCNodeBits cap))) s'" - apply (clarsimp simp: isCap_simps valid_cap'_def) - apply (rule real_cte_at') - apply (erule spec) - done - declare ucast_id [simp] declare resolveAddressBits.simps [simp del] diff --git a/proof/crefine/ARM/Fastpath_C.thy b/proof/crefine/ARM/Fastpath_C.thy index cbd196aa8..4b2625c25 100644 --- a/proof/crefine/ARM/Fastpath_C.thy +++ b/proof/crefine/ARM/Fastpath_C.thy @@ -4,163 +4,20 @@ * SPDX-License-Identifier: GPL-2.0-only *) +(* Proof that the C fast path functions are refinements of their design + specifications in Fastpath_Defs. *) + theory Fastpath_C imports SyscallArgs_C Delete_C Syscall_C - "Refine.RAB_FN" + Fastpath_Defs "CLib.MonadicRewrite_C" begin context begin interpretation Arch . (*FIXME: arch_split*) -definition - "fastpaths sysc \ case sysc of - SysCall \ doE - curThread \ liftE $ getCurThread; - mi \ liftE $ getMessageInfo curThread; - cptr \ liftE $ asUser curThread $ getRegister capRegister; - - fault \ liftE $ threadGet tcbFault curThread; - pickFastpath \ liftE $ alternative (return True) (return False); - unlessE (fault = None \ msgExtraCaps mi = 0 - \ msgLength mi \ scast n_msgRegisters \ pickFastpath) - $ throwError (); - - ctab \ liftE $ getThreadCSpaceRoot curThread >>= getCTE; - epCap \ unifyFailure (doE t \ resolveAddressBits (cteCap ctab) cptr (size cptr); - liftE (getSlotCap (fst t)) odE); - unlessE (isEndpointCap epCap \ capEPCanSend epCap) - $ throwError (); - ep \ liftE $ getEndpoint (capEPPtr epCap); - unlessE (isRecvEP ep) $ throwError (); - dest \ returnOk $ hd $ epQueue ep; - newVTable \ liftE $ getThreadVSpaceRoot dest >>= getCTE; - unlessE (isValidVTableRoot $ cteCap newVTable) $ throwError (); - pd \ returnOk $ capPDBasePtr $ capCap $ cteCap newVTable; - curDom \ liftE $ curDomain; - curPrio \ liftE $ threadGet tcbPriority curThread; - destPrio \ liftE $ threadGet tcbPriority dest; - highest \ liftE $ isHighestPrio curDom destPrio; - unlessE (destPrio \ curPrio \ highest) $ throwError (); - unlessE (capEPCanGrant epCap \ capEPCanGrantReply epCap) $ throwError (); - asidMap \ liftE $ gets $ armKSASIDMap o ksArchState; - unlessE (\v. {hwasid. (hwasid, pd) \ ran asidMap} = {v}) - $ throwError (); - destDom \ liftE $ threadGet tcbDomain dest; - unlessE (destDom = curDom) $ throwError (); - - liftE $ do - setEndpoint (capEPPtr epCap) - (case tl (epQueue ep) of [] \ IdleEP | _ \ RecvEP (tl (epQueue ep))); - threadSet (tcbState_update (\_. BlockedOnReply)) curThread; - replySlot \ getThreadReplySlot curThread; - callerSlot \ getThreadCallerSlot dest; - replySlotCTE \ getCTE replySlot; - assert (mdbNext (cteMDBNode replySlotCTE) = 0 - \ isReplyCap (cteCap replySlotCTE) - \ capReplyMaster (cteCap replySlotCTE) - \ mdbFirstBadged (cteMDBNode replySlotCTE) - \ mdbRevocable (cteMDBNode replySlotCTE)); - destState \ getThreadState dest; - cteInsert (ReplyCap curThread False (blockingIPCCanGrant destState)) replySlot callerSlot; - - forM_x (take (unat (msgLength mi)) ARM_H.msgRegisters) - (\r. do v \ asUser curThread (getRegister r); - asUser dest (setRegister r v) od); - setThreadState Running dest; - Arch.switchToThread dest; - setCurThread dest; - - asUser dest $ zipWithM_x setRegister - [ARM_H.badgeRegister, ARM_H.msgInfoRegister] - [capEPBadge epCap, wordFromMessageInfo (mi\ msgCapsUnwrapped := 0 \)]; - - stateAssert kernelExitAssertions [] - od - - odE (\_. callKernel (SyscallEvent sysc)) - | SysReplyRecv \ doE - curThread \ liftE $ getCurThread; - mi \ liftE $ getMessageInfo curThread; - cptr \ liftE $ asUser curThread $ getRegister capRegister; - - fault \ liftE $ threadGet tcbFault curThread; - pickFastpath \ liftE $ alternative (return True) (return False); - unlessE (fault = None \ msgExtraCaps mi = 0 - \ msgLength mi \ scast n_msgRegisters \ pickFastpath) - $ throwError (); - - ctab \ liftE $ getThreadCSpaceRoot curThread >>= getCTE; - epCap \ unifyFailure (doE t \ resolveAddressBits (cteCap ctab) cptr (size cptr); - liftE (getSlotCap (fst t)) odE); - - unlessE (isEndpointCap epCap \ capEPCanReceive epCap) - $ throwError (); - - bound_ntfn \ liftE $ getBoundNotification curThread; - active_ntfn \ liftE $ case bound_ntfn of None \ return False - | Some ntfnptr \ liftM isActive $ getNotification ntfnptr; - unlessE (\ active_ntfn) $ throwError (); - - ep \ liftE $ getEndpoint (capEPPtr epCap); - unlessE (\ isSendEP ep) $ throwError (); - - callerSlot \ liftE $ getThreadCallerSlot curThread; - callerCTE \ liftE $ getCTE callerSlot; - callerCap \ returnOk $ cteCap callerCTE; - unlessE (isReplyCap callerCap \ \ capReplyMaster callerCap) - $ throwError (); - - caller \ returnOk $ capTCBPtr callerCap; - callerFault \ liftE $ threadGet tcbFault caller; - unlessE (callerFault = None) $ throwError (); - newVTable \ liftE $ getThreadVSpaceRoot caller >>= getCTE; - unlessE (isValidVTableRoot $ cteCap newVTable) $ throwError (); - - curDom \ liftE $ curDomain; - callerPrio \ liftE $ threadGet tcbPriority caller; - highest \ liftE $ isHighestPrio curDom callerPrio; - unlessE highest $ throwError (); - - pd \ returnOk $ capPDBasePtr $ capCap $ cteCap newVTable; - asidMap \ liftE $ gets $ armKSASIDMap o ksArchState; - unlessE (\v. {hwasid. (hwasid, pd) \ ran asidMap} = {v}) - $ throwError (); - callerDom \ liftE $ threadGet tcbDomain caller; - unlessE (callerDom = curDom) $ throwError (); - - liftE $ do - epCanGrant \ return $ capEPCanGrant epCap; - threadSet (tcbState_update (\_. BlockedOnReceive (capEPPtr epCap) epCanGrant)) curThread; - setEndpoint (capEPPtr epCap) - (case ep of IdleEP \ RecvEP [curThread] | RecvEP ts \ RecvEP (ts @ [curThread])); - mdbPrev \ liftM (mdbPrev o cteMDBNode) $ getCTE callerSlot; - assert (mdbPrev \ 0); - updateMDB mdbPrev (mdbNext_update (K 0) o mdbFirstBadged_update (K True) - o mdbRevocable_update (K True)); - setCTE callerSlot makeObject; - - forM_x (take (unat (msgLength mi)) ARM_H.msgRegisters) - (\r. do v \ asUser curThread (getRegister r); - asUser caller (setRegister r v) od); - setThreadState Running caller; - Arch.switchToThread caller; - setCurThread caller; - - asUser caller $ zipWithM_x setRegister - [ARM_H.badgeRegister, ARM_H.msgInfoRegister] - [0, wordFromMessageInfo (mi\ msgCapsUnwrapped := 0 \)]; - - stateAssert kernelExitAssertions [] - od - - odE (\_. callKernel (SyscallEvent sysc)) - - | _ \ callKernel (SyscallEvent sysc)" - - lemma setCTE_obj_at'_queued: "\obj_at' (\tcb. P (tcbQueued tcb)) t\ setCTE p v \\rv. obj_at' (\tcb. P (tcbQueued tcb)) t\" unfolding setCTE_def @@ -779,11 +636,6 @@ lemma dmo_clearExMonitor_setCurThread_swap: simp_all add: select_f_oblivious) done -lemma monadic_rewrite_gets_l: - "(\x. monadic_rewrite F E (P x) (g x) m) - \ monadic_rewrite F E (\s. P (f s) s) (gets f >>= (\x. g x)) m" - by (auto simp add: monadic_rewrite_def exec_gets) - lemma pd_at_asid_inj': "pd_at_asid' pd asid s \ pd_at_asid' pd' asid s \ pd' = pd" by (clarsimp simp: pd_at_asid'_def obj_at'_def) @@ -1844,6 +1696,10 @@ lemma recv_ep_queued_st_tcb_at': apply (clarsimp simp: isBlockedOnReceive_def projectKOs) done +lemma signed_n_msgRegisters_to_H: + "(signed n_msgRegisters :: machine_word) = of_nat size_msgRegisters" + by (simp add: n_msgRegisters_def size_msgRegisters_def) + lemma fastpath_call_ccorres: notes hoare_TrueI[simp] shows "ccorres dc xfdc @@ -1932,7 +1788,7 @@ proof - apply (rule ccorres_alternative1) apply (rule ccorres_if_lhs[rotated]) apply (rule ccorres_inst[where P=\ and P'=UNIV]) - apply simp + apply (solves \simp add: signed_n_msgRegisters_to_H\) apply (simp del: Collect_const cong: call_ignore_cong) apply (elim conjE) apply (rule ccorres_abstract_ksCurThread, ceqv) @@ -2762,7 +2618,7 @@ lemma fastpath_reply_recv_ccorres: apply (rule ccorres_alternative1) apply (rule ccorres_if_lhs[rotated]) apply (rule ccorres_inst[where P=\ and P'=UNIV]) - apply simp + apply (solves \simp add: signed_n_msgRegisters_to_H\) apply (simp del: Collect_const cong: call_ignore_cong) apply (elim conjE) apply (simp add: getThreadCSpaceRoot_def locateSlot_conv @@ -3327,1603 +3183,6 @@ lemma fastpath_reply_recv_ccorres: done qed -lemmas monadic_rewrite_symb_exec_l' = monadic_rewrite_symb_exec_l'_preserve_names - -lemma possibleSwitchTo_rewrite: - "monadic_rewrite True True - (\s. obj_at' (\tcb. tcbPriority tcb = destPrio \ tcbDomain tcb = destDom) t s - \ ksSchedulerAction s = ResumeCurrentThread - \ ksCurThread s = thread - \ ksCurDomain s = curDom - \ destDom = curDom) - (possibleSwitchTo t) (setSchedulerAction (SwitchToThread t))" - apply (simp add: possibleSwitchTo_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_symb_exec_l'[OF threadGet_inv empty_fail_threadGet, - where P'=\], simp) - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac P="targetDom = curDom" in monadic_rewrite_gen_asm) - apply simp - apply (rule_tac P="action = ResumeCurrentThread" in monadic_rewrite_gen_asm) - apply simp - apply (rule monadic_rewrite_refl) - apply (wp threadGet_wp cd_wp |simp add: bitmap_fun_defs)+ - apply (simp add: getCurThread_def curDomain_def gets_bind_ign getSchedulerAction_def) - apply (rule monadic_rewrite_refl) - apply clarsimp - apply (auto simp: obj_at'_def) - done - -lemma scheduleSwitchThreadFastfail_False_wp: - "\\s. ct \ it \ cprio \ tprio \ - scheduleSwitchThreadFastfail ct it cprio tprio - \\rv s. \ rv \" - unfolding scheduleSwitchThreadFastfail_def - by (wp threadGet_wp) - (auto dest!: obj_at_ko_at' simp: le_def obj_at'_def) - -lemma lookupBitmapPriority_lift: - assumes prqL1: "\P. \\s. P (ksReadyQueuesL1Bitmap s)\ f \\_ s. P (ksReadyQueuesL1Bitmap s)\" - and prqL2: "\P. \\s. P (ksReadyQueuesL2Bitmap s)\ f \\_ s. P (ksReadyQueuesL2Bitmap s)\" - shows "\\s. P (lookupBitmapPriority d s) \ f \\_ s. P (lookupBitmapPriority d s) \" - unfolding lookupBitmapPriority_def - apply (rule hoare_pre) - apply (wps prqL1 prqL2) - apply wpsimp+ - done - -(* slow path additionally requires current thread not idle *) -definition - "fastpathBestSwitchCandidate t \ \s. - ksReadyQueuesL1Bitmap s (ksCurDomain s) = 0 - \ (\tprio. obj_at' (\tcb. tcbPriority tcb = tprio) t s - \ (obj_at' (\tcb. tcbPriority tcb \ tprio) (ksCurThread s) s - \ lookupBitmapPriority (ksCurDomain s) s \ tprio))" - -lemma fastpathBestSwitchCandidateI: - "\ ksReadyQueuesL1Bitmap s (ksCurDomain s) = 0 - \ tcbPriority ctcb \ tcbPriority ttcb - \ lookupBitmapPriority (ksCurDomain s) s \ tcbPriority ttcb; - ko_at' ttcb t s; ko_at' ctcb (ksCurThread s) s\ - \ fastpathBestSwitchCandidate t s" - unfolding fastpathBestSwitchCandidate_def - by normalise_obj_at' - -lemma fastpathBestSwitchCandidate_lift: - assumes ct[wp]: "\P. \\s. P (ksCurThread s) \ f \ \_ s. P (ksCurThread s) \" - assumes cd[wp]: "\P. \\s. P (ksCurDomain s) \ f \ \_ s. P (ksCurDomain s) \" - assumes l1[wp]: "\P. \\s. P (ksReadyQueuesL1Bitmap s) \ f \ \_ s. P (ksReadyQueuesL1Bitmap s) \" - assumes l2[wp]: "\P. \\s. P (ksReadyQueuesL2Bitmap s) \ f \ \_ s. P (ksReadyQueuesL2Bitmap s) \" - assumes p[wp]: "\P t. \ obj_at' (\tcb. P (tcbPriority tcb)) t \ f \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t \" - shows "\ tcb_at' t and fastpathBestSwitchCandidate t \ f \\rv. fastpathBestSwitchCandidate t \" - unfolding fastpathBestSwitchCandidate_def lookupBitmapPriority_def l1IndexToPrio_def - apply (rule hoare_pre) - apply (rule hoare_lift_Pf2[where f=ksCurDomain]) - apply (wp hoare_vcg_disj_lift hoare_vcg_all_lift) - apply (rule hoare_lift_Pf2[where f=ksCurThread]) - apply (rule hoare_lift_Pf2[where f=ksReadyQueuesL1Bitmap]) - apply (rule hoare_lift_Pf2[where f=ksReadyQueuesL2Bitmap]) - apply (wp hoare_vcg_imp_lift') - apply (strengthen not_obj_at'_strengthen) - apply (wpsimp simp: comp_def wp: l1 l2 hoare_vcg_disj_lift)+ - apply (drule (1) tcb_at_not_obj_at_elim'[rotated]) - apply (rename_tac tprio, erule_tac x=tprio in allE) - apply clarsimp - apply (drule (1) tcb_at_not_obj_at_elim'[rotated]) - apply (clarsimp simp: obj_at'_def) - done - -lemma fastpathBestSwitchCandidate_ksSchedulerAction_simp[simp]: - "fastpathBestSwitchCandidate t (s\ksSchedulerAction := a\) - = fastpathBestSwitchCandidate t s" - unfolding fastpathBestSwitchCandidate_def lookupBitmapPriority_def - by simp - -lemma schedule_rewrite_ct_not_runnable': - "monadic_rewrite True True - (\s. ksSchedulerAction s = SwitchToThread t \ ct_in_state' (Not \ runnable') s - \ (ksCurThread s \ ksIdleThread s) - \ fastpathBestSwitchCandidate t s) - (schedule) - (do setSchedulerAction ResumeCurrentThread; switchToThread t od)" - supply subst_all [simp del] - apply (simp add: schedule_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac P="action = SwitchToThread t" in monadic_rewrite_gen_asm, simp) - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac P="\ wasRunnable \ action = SwitchToThread t" - in monadic_rewrite_gen_asm,simp) - apply (rule monadic_rewrite_bind_tail, rename_tac idleThread) - apply (rule monadic_rewrite_bind_tail, rename_tac targetPrio) - apply (rule monadic_rewrite_bind_tail, rename_tac curPrio) - apply (rule monadic_rewrite_bind_tail, rename_tac fastfail) - apply (rule monadic_rewrite_bind_tail, rename_tac curDom) - apply (rule monadic_rewrite_bind_tail, rename_tac highest) - apply (rule_tac P="\ (fastfail \ \ highest)" in monadic_rewrite_gen_asm, simp only:) - apply simp - apply (rule monadic_rewrite_refl) - apply (wpsimp wp: hoare_vcg_imp_lift) - apply (simp add: isHighestPrio_def') - apply wp+ - apply (wp hoare_vcg_disj_lift) - apply (wp scheduleSwitchThreadFastfail_False_wp) - apply (wp hoare_vcg_disj_lift threadGet_wp'' | simp add: comp_def)+ - (* remove no-ops, somewhat by magic *) - apply (rule monadic_rewrite_symb_exec_l'_TT, solves wp, - wpsimp wp: empty_fail_isRunnable simp: isHighestPrio_def')+ - apply (simp add: setSchedulerAction_def) - apply (subst oblivious_modify_swap[symmetric], rule oblivious_switchToThread_schact) - apply (rule monadic_rewrite_refl) - apply wp+ - apply (clarsimp simp: ct_in_state'_def) - apply (strengthen not_pred_tcb_at'_strengthen, simp) - apply normalise_obj_at' - apply (simp add: fastpathBestSwitchCandidate_def) - apply (erule_tac x="tcbPriority ko" in allE) - apply (erule impE, normalise_obj_at'+) - done - -crunch tcb2[wp]: "Arch.switchToThread" "tcb_at' t" - (ignore: ARM.clearExMonitor) - -lemma resolveAddressBits_points_somewhere: - "\\s. \slot. Q slot s\ resolveAddressBits cp cptr bits \Q\,-" - apply (rule_tac Q'="\rv s. \rv. Q rv s" in hoare_post_imp_R) - apply wp - apply clarsimp - done - -lemma foldr_copy_register_tsrs: - "foldr (\r . copy_register_tsrs x y r r (\x. x)) rs s - = (s (y := TCBStateRegs (tsrState (s y)) - (\r. if r \ set rs then tsrContext (s x) r - else tsrContext (s y) r)))" - apply (induct rs) - apply simp - apply (simp add: copy_register_tsrs_def fun_eq_iff - split: if_split) - done - -lemmas cteInsert_obj_at'_not_queued = cteInsert_obj_at'_queued[of "\a. \ a"] - -lemma monadic_rewrite_exists_v: - "[| !! v. monadic_rewrite E F (Q v) f g |] - ==> monadic_rewrite E F (%x. (EX v. P v x) & (ALL v. P v x --> Q v x)) f g" - apply (rule monadic_rewrite_name_pre) - apply clarsimp - apply (erule_tac x=v in meta_allE) - apply (erule monadic_rewrite_imp) - apply clarsimp - done - -lemma monadic_rewrite_threadGet: - "monadic_rewrite E F (obj_at' (\tcb. f tcb = v) t) - (threadGet f t) (return v)" - unfolding getThreadState_def - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans[rotated]) - apply (rule monadic_rewrite_gets_known) - apply (unfold threadGet_def liftM_def fun_app_def) - apply (rule monadic_rewrite_symb_exec_l' | wp | rule empty_fail_getObject getObject_inv)+ - apply (clarsimp; rule no_fail_getObject_tcb) - apply (simp only: exec_gets) - apply (rule_tac P = "(\s. (f x)=v) and tcb_at' t" in monadic_rewrite_refl3) - apply (simp add:) - apply (wp OMG_getObject_tcb | wpc)+ - apply (auto intro: obj_tcb_at') - done - -lemma monadic_rewrite_getThreadState: - "monadic_rewrite E F (obj_at' (\tcb. tcbState tcb = v) t) - (getThreadState t) (return v)" - unfolding getThreadState_def - by (rule monadic_rewrite_threadGet) - -lemma setCTE_obj_at'_tcbIPCBuffer: - "\obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\ setCTE p v \\rv. obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\" - unfolding setCTE_def - by (rule setObject_cte_obj_at_tcb', simp+) - -context -notes if_cong[cong] -begin -crunches cteInsert, asUser - for obj_at'_tcbIPCBuffer[wp]: "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" - (wp: setCTE_obj_at'_queued crunch_wps threadSet_obj_at'_really_strongest) -end - -crunch ksReadyQueues_inv[wp]: cteInsert "\s. P (ksReadyQueues s)" - (wp: hoare_drop_imps) - -crunches cteInsert, threadSet, asUser, emptySlot - for ksReadyQueuesL1Bitmap_inv[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" - and ksReadyQueuesL2Bitmap_inv[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" - (wp: hoare_drop_imps) - -crunch ksReadyQueuesL1Bitmap_inv[wp]: setEndpoint "\s. P (ksReadyQueuesL1Bitmap s)" - (wp: setObject_ksPSpace_only updateObject_default_inv) -crunch ksReadyQueuesL2Bitmap_inv[wp]: setEndpoint "\s. P (ksReadyQueuesL2Bitmap s)" - (wp: setObject_ksPSpace_only updateObject_default_inv) - -lemma setThreadState_runnable_bitmap_inv: - "runnable' ts \ - \ \s. P (ksReadyQueuesL1Bitmap s) \ setThreadState ts t \\rv s. P (ksReadyQueuesL1Bitmap s) \" - "runnable' ts \ - \ \s. Q (ksReadyQueuesL2Bitmap s) \ setThreadState ts t \\rv s. Q (ksReadyQueuesL2Bitmap s) \" - by (simp_all add: setThreadState_runnable_simp, wp+) - -lemma fastpath_callKernel_SysCall_corres: - "monadic_rewrite True False - (invs' and ct_in_state' ((=) Running) - and (\s. ksSchedulerAction s = ResumeCurrentThread) - and (\s. ksDomainTime s \ 0)) - (callKernel (SyscallEvent SysCall)) (fastpaths SysCall)" - supply if_cong[cong] - apply (rule monadic_rewrite_introduce_alternative) - apply (simp add: callKernel_def) - apply (rule monadic_rewrite_imp) - apply (simp add: handleEvent_def handleCall_def - handleInvocation_def liftE_bindE_handle - bind_assoc getMessageInfo_def) - apply (simp add: catch_liftE_bindE unlessE_throw_catch_If - unifyFailure_catch_If catch_liftE - getMessageInfo_def alternative_bind - fastpaths_def - cong: if_cong) - apply (rule monadic_rewrite_rdonly_bind_l, wp) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_rdonly_bind_l, wp) - apply (rule monadic_rewrite_bind_tail) - apply (rename_tac msgInfo) - apply (rule monadic_rewrite_rdonly_bind_l, wp) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_symb_exec_r - [OF threadGet_inv no_fail_threadGet]) - apply (rename_tac thread msgInfo ptr tcbFault) - apply (rule monadic_rewrite_alternative_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (simp add: split_def Syscall_H.syscall_def - liftE_bindE_handle bind_assoc - capFaultOnFailure_def) - apply (simp only: bindE_bind_linearise[where f="rethrowFailure fn f'" for fn f'] - bind_case_sum_rethrow) - apply (simp add: lookupCapAndSlot_def lookupSlotForThread_def - lookupSlotForThread_def bindE_assoc - liftE_bind_return_bindE_returnOk split_def - getThreadCSpaceRoot_def locateSlot_conv - returnOk_liftE[symmetric] const_def - getSlotCap_def) - apply (simp only: liftE_bindE_assoc) - apply (rule monadic_rewrite_rdonly_bind_l, wp) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_rdonly_bind_l) - apply (wp | simp)+ - apply (rule_tac fn="case_sum Inl (Inr \ fst)" in monadic_rewrite_split_fn) - apply (simp add: liftME_liftM[symmetric] liftME_def bindE_assoc) - apply (rule monadic_rewrite_refl) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (simp add: isRight_right_map isRight_case_sum) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_rdonly_bind_l[OF lookupIPC_inv]) - apply (rule monadic_rewrite_symb_exec_l[OF lookupIPC_inv empty_fail_lookupIPCBuffer]) - apply (simp add: lookupExtraCaps_null returnOk_bind liftE_bindE_handle - bind_assoc liftE_bindE_assoc - decodeInvocation_def Let_def from_bool_0 - performInvocation_def liftE_handle - liftE_bind) - apply (rule monadic_rewrite_symb_exec_r [OF getEndpoint_inv no_fail_getEndpoint]) - apply (rename_tac "send_ep") - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (simp add: getThreadVSpaceRoot_def locateSlot_conv) - apply (rule monadic_rewrite_symb_exec_r [OF getCTE_inv no_fail_getCTE]) - apply (rename_tac "pdCapCTE") - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_symb_exec_r[OF curDomain_inv], - simp only: curDomain_def, rule non_fail_gets) - apply (rename_tac "curDom") - apply (rule monadic_rewrite_symb_exec_r [OF threadGet_inv no_fail_threadGet])+ - apply (rename_tac curPrio destPrio) - apply (simp add: isHighestPrio_def') - apply (rule monadic_rewrite_symb_exec_r [OF gets_inv non_fail_gets]) - apply (rename_tac highest) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_symb_exec_r [OF gets_inv non_fail_gets]) - apply (rename_tac asidMap) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - - apply (rule monadic_rewrite_symb_exec_r[OF threadGet_inv no_fail_threadGet]) - apply (rename_tac "destDom") - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_trans, - rule monadic_rewrite_pick_alternative_1) - apply (rule monadic_rewrite_symb_exec_l[OF get_mrs_inv' empty_fail_getMRs]) - (* now committed to fastpath *) - apply (rule monadic_rewrite_trans) - apply (rule_tac F=True and E=True in monadic_rewrite_weaken) - apply simp - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac x=thread in monadic_rewrite_symb_exec, - (wp empty_fail_getCurThread)+) - apply (simp add: sendIPC_def bind_assoc) - apply (rule_tac x=send_ep in monadic_rewrite_symb_exec, - (wp empty_fail_getEndpoint getEndpoint_obj_at')+) - apply (rule_tac P="epQueue send_ep \ []" in monadic_rewrite_gen_asm) - apply (simp add: isRecvEP_endpoint_case list_case_helper bind_assoc) - apply (rule monadic_rewrite_bind_tail) - apply (elim conjE) - apply (rule monadic_rewrite_bind_tail, rename_tac dest_st) - apply (rule_tac P="\gr. dest_st = BlockedOnReceive (capEPPtr (fst (theRight rv))) gr" - in monadic_rewrite_gen_asm) - apply (rule monadic_rewrite_symb_exec2, (wp | simp)+) - apply (rule monadic_rewrite_bind) - apply clarsimp - apply (rule_tac msgInfo=msgInfo in doIPCTransfer_simple_rewrite) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_bind) - apply (rule_tac destPrio=destPrio - and curDom=curDom and destDom=destDom and thread=thread - in possibleSwitchTo_rewrite) - apply (rule monadic_rewrite_bind) - apply (rule monadic_rewrite_trans) - apply (rule setupCallerCap_rewrite) - apply (rule monadic_rewrite_bind_head) - apply (rule setThreadState_rewrite_simple, simp) - apply (rule monadic_rewrite_trans) - apply (rule_tac x=BlockedOnReply in monadic_rewrite_symb_exec, - (wp empty_fail_getThreadState)+) - apply simp - apply (rule monadic_rewrite_refl) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_head) - apply (rule_tac t="hd (epQueue send_ep)" - in schedule_rewrite_ct_not_runnable') - apply (simp add: bind_assoc) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_bind) - apply (rule switchToThread_rewrite) - apply (rule monadic_rewrite_bind) - apply (rule activateThread_simple_rewrite) - apply (rule monadic_rewrite_refl) - apply wp - apply (wp setCurThread_ct_in_state) - apply (simp only: st_tcb_at'_def[symmetric]) - apply (wp, clarsimp simp: cur_tcb'_def ct_in_state'_def) - apply (simp add: getThreadCallerSlot_def getThreadReplySlot_def - locateSlot_conv ct_in_state'_def cur_tcb'_def) - - apply ((wp assert_inv threadSet_pred_tcb_at_state - cteInsert_obj_at'_not_queued - | wps)+)[1] - - apply (wp fastpathBestSwitchCandidate_lift[where f="cteInsert c w w'" for c w w']) - apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] - apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] - apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] - apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] - apply (wp fastpathBestSwitchCandidate_lift[where f="threadSet f t" for f t]) - apply simp - apply ((wp assert_inv threadSet_pred_tcb_at_state - cteInsert_obj_at'_not_queued - | wps)+)[1] - apply (simp add: setSchedulerAction_def) - apply wp[1] - apply (simp cong: if_cong conj_cong add: if_bool_simps) - apply (simp_all only:)[5] - apply ((wp setThreadState_oa_queued[of _ "\a _ _. \ a"] - setThreadState_obj_at_unchanged - asUser_obj_at_unchanged mapM_x_wp' - sts_st_tcb_at'_cases - setThreadState_no_sch_change - setEndpoint_obj_at_tcb' - fastpathBestSwitchCandidate_lift[where f="setThreadState f t" for f t] - setThreadState_oa_queued - fastpathBestSwitchCandidate_lift[where f="asUser t f" for f t] - fastpathBestSwitchCandidate_lift[where f="setEndpoint a b" for a b] - lookupBitmapPriority_lift - setThreadState_runnable_bitmap_inv - | simp add: setMessageInfo_def - | wp (once) hoare_vcg_disj_lift)+) - - apply (simp add: setThreadState_runnable_simp - getThreadCallerSlot_def getThreadReplySlot_def - locateSlot_conv bind_assoc) - apply (rule_tac P="\v. obj_at' (%tcb. tcbIPCBuffer tcb = v) (hd (epQueue send_ep))" - in monadic_rewrite_exists_v) - apply (rename_tac ipcBuffer) - apply (rule_tac P="\v. obj_at' (\tcb. tcbState tcb = v) (hd (epQueue send_ep))" - in monadic_rewrite_exists_v) - apply (rename_tac destState) - - apply (simp add: ARM_H.switchToThread_def bind_assoc) - (* retrieving state or thread registers is not thread_action_isolatable, - translate into return with suitable precondition *) - apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) - apply (rule_tac v=destState in monadic_rewrite_getThreadState - | rule monadic_rewrite_bind monadic_rewrite_refl)+ - apply (wp mapM_x_wp' getObject_inv | wpc | simp | wp (once) hoare_drop_imps)+ - apply (rule_tac v=destState in monadic_rewrite_getThreadState - | rule monadic_rewrite_bind monadic_rewrite_refl)+ - apply (wp mapM_x_wp' getObject_inv | wpc | simp | wp (once) hoare_drop_imps)+ - - apply (rule_tac P="inj (case_bool thread (hd (epQueue send_ep)))" - in monadic_rewrite_gen_asm) - apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) - apply (rule monadic_rewrite_weaken[where F=False and E=True], simp) - apply (rule isolate_thread_actions_rewrite_bind - fastpath_isolate_rewrites fastpath_isolatables - bool.simps setRegister_simple - setVMRoot_isolatable[THEN thread_actions_isolatableD] setVMRoot_isolatable - doMachineOp_isolatable[THEN thread_actions_isolatableD] doMachineOp_isolatable - kernelExitAssertions_isolatable[THEN thread_actions_isolatableD] - kernelExitAssertions_isolatable - zipWithM_setRegister_simple - thread_actions_isolatable_bind - | assumption - | wp assert_inv)+ - apply (rule_tac P="\s. ksSchedulerAction s = ResumeCurrentThread - \ tcb_at' thread s" - and F=True and E=False in monadic_rewrite_weaken) - apply simp - apply (rule monadic_rewrite_isolate_final) - apply (simp add: isRight_case_sum cong: list.case_cong) - apply (clarsimp simp: fun_eq_iff if_flip - cong: if_cong) - apply (drule obj_at_ko_at', clarsimp) - apply (frule get_tcb_state_regs_ko_at') - apply (clarsimp simp: zip_map2 zip_same_conv_map foldl_map - foldl_fun_upd - foldr_copy_register_tsrs - isRight_case_sum - cong: if_cong) - apply (simp add: upto_enum_def fromEnum_def - enum_register toEnum_def - msgRegisters_unfold - cong: if_cong) - apply (clarsimp split: if_split) - apply (rule ext) - apply (simp add: badgeRegister_def msgInfoRegister_def - ARM.badgeRegister_def - ARM.msgInfoRegister_def - split: if_split) - apply simp - apply (wp | simp cong: if_cong bool.case_cong - | rule getCTE_wp' gts_wp' threadGet_wp - getEndpoint_wp)+ - apply (rule validE_cases_valid) - apply (simp add: isRight_def getSlotCap_def) - apply (wp getCTE_wp') - apply (rule resolveAddressBits_points_somewhere) - apply (simp cong: if_cong bool.case_cong) - apply wp - apply simp - apply (wp user_getreg_wp threadGet_wp)+ - - apply clarsimp - apply (subgoal_tac "ksCurThread s \ ksIdleThread s") - prefer 2 - apply (fastforce simp: ct_in_state'_def dest: ct_running_not_idle' elim: pred_tcb'_weakenE) - - apply (clarsimp simp: ct_in_state'_def pred_tcb_at') - apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp+) - apply (clarsimp simp: isCap_simps valid_cap'_def maskCapRights_def) - apply (frule ko_at_valid_ep', clarsimp) - apply (frule sym_refs_ko_atD'[where 'a=endpoint], clarsimp) - apply (clarsimp simp: valid_ep'_def isRecvEP_endpoint_case neq_Nil_conv - tcbVTableSlot_def cte_level_bits_def - cte_at_tcb_at_16' length_msgRegisters - n_msgRegisters_def order_less_imp_le - ep_q_refs_of'_def st_tcb_at_refs_of_rev' - cong: if_cong) - apply (rename_tac blockedThread ys tcba tcbb) - apply (frule invs_mdb') - apply (thin_tac "Ball S P" for S P)+ - supply imp_disjL[simp del] - apply (subst imp_disjL[symmetric]) - - (* clean up broken up disj implication and excessive references to same tcbs *) - apply normalise_obj_at' - apply (clarsimp simp: invs'_def valid_state'_def) - apply (fold imp_disjL, intro allI impI) - - apply (subgoal_tac "ksCurThread s \ blockedThread") - prefer 2 - apply normalise_obj_at' - apply clarsimp - apply (frule_tac t="blockedThread" in valid_queues_not_runnable_not_queued, assumption) - subgoal by (fastforce simp: st_tcb_at'_def elim: obj_at'_weakenE) - apply (subgoal_tac "fastpathBestSwitchCandidate blockedThread s") - prefer 2 - apply (rule_tac ttcb=tcbb and ctcb=tcb in fastpathBestSwitchCandidateI) - apply (solves \simp only: disj_ac\) - apply simp+ - apply (clarsimp simp: st_tcb_at'_def obj_at'_def objBits_simps projectKOs - valid_mdb'_def valid_mdb_ctes_def inj_case_bool - split: bool.split)+ - done - -lemmas fastpath_call_ccorres_callKernel - = monadic_rewrite_ccorres_assemble[OF fastpath_call_ccorres fastpath_callKernel_SysCall_corres] - -lemma capability_case_Null_ReplyCap: - "(case cap of NullCap \ f | ReplyCap t b cg \ g t b cg | _ \ h) - = (if isReplyCap cap then g (capTCBPtr cap) (capReplyMaster cap) (capReplyCanGrant cap) - else if isNullCap cap then f else h)" - by (simp add: isCap_simps split: capability.split) - -end - -context begin interpretation Arch . (*FIXME: arch_split*) - -lemma injection_handler_catch: - "catch (injection_handler f x) y - = catch x (y o f)" - apply (simp add: injection_handler_def catch_def handleE'_def - bind_assoc) - apply (rule bind_cong[OF refl]) - apply (simp add: throwError_bind split: sum.split) - done - -lemma doReplyTransfer_simple: - "monadic_rewrite True False - (obj_at' (\tcb. tcbFault tcb = None) receiver) - (doReplyTransfer sender receiver slot grant) - (do state \ getThreadState receiver; - assert (isReply state); - cte \ getCTE slot; - mdbnode \ return $ cteMDBNode cte; - assert (mdbPrev mdbnode \ 0 \ mdbNext mdbnode = 0); - parentCTE \ getCTE (mdbPrev mdbnode); - assert (isReplyCap (cteCap parentCTE) \ capReplyMaster (cteCap parentCTE)); - doIPCTransfer sender Nothing 0 grant receiver; - cteDeleteOne slot; - setThreadState Running receiver; - possibleSwitchTo receiver - od)" - apply (simp add: doReplyTransfer_def liftM_def nullPointer_def getSlotCap_def) - apply (rule monadic_rewrite_bind_tail)+ - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_threadGet)+) - apply (rule_tac P="rv = None" in monadic_rewrite_gen_asm, simp) - apply (rule monadic_rewrite_refl) - apply (wp threadGet_const gts_wp' getCTE_wp')+ - apply (simp add: o_def) - done - -lemma monadic_rewrite_if_known: - "monadic_rewrite F E ((\s. C = X) and \) (if C then f else g) (if X then f else g)" - apply (rule monadic_rewrite_gen_asm) - apply (simp split del: if_split) - apply (rule monadic_rewrite_refl) - done - -end - -context kernel_m begin - -lemma receiveIPC_simple_rewrite: - "monadic_rewrite True False - ((\_. isEndpointCap ep_cap \ \ isSendEP ep) and (ko_at' ep (capEPPtr ep_cap) and - (\s. \ntfnptr. bound_tcb_at' ((=) (Some ntfnptr)) thread s \ obj_at' (Not \ isActive) ntfnptr s))) - (receiveIPC thread ep_cap True) - (do - setThreadState (BlockedOnReceive (capEPPtr ep_cap) (capEPCanGrant ep_cap)) thread; - setEndpoint (capEPPtr ep_cap) (RecvEP (case ep of RecvEP q \ (q @ [thread]) | _ \ [thread])) - od)" - apply (rule monadic_rewrite_gen_asm) - apply (simp add: receiveIPC_def) - apply (rule monadic_rewrite_imp) - apply (rule_tac rv=ep in monadic_rewrite_symb_exec_l_known, - (wp empty_fail_getEndpoint)+) - apply (rule monadic_rewrite_symb_exec_l, (wp | simp add: getBoundNotification_def)+) - apply (rule monadic_rewrite_symb_exec_l) - apply (rule hoare_pre, wpc, wp+, simp) - apply (simp split: option.split) - apply (rule monadic_rewrite_trans, rule monadic_rewrite_if_known[where X=False], simp) - apply (rule monadic_rewrite_refl3[where P=\]) - apply (cases ep, simp_all add: isSendEP_def)[1] - apply (wp getNotification_wp gbn_wp' getEndpoint_wp | wpc)+ - apply (clarsimp simp: obj_at'_def projectKOs pred_tcb_at'_def) - done - -lemma empty_fail_isFinalCapability: - "empty_fail (isFinalCapability cte)" - by (simp add: isFinalCapability_def Let_def split: if_split) - -lemma cteDeleteOne_replycap_rewrite: - "monadic_rewrite True False - (cte_wp_at' (\cte. isReplyCap (cteCap cte)) slot) - (cteDeleteOne slot) - (emptySlot slot NullCap)" - apply (simp add: cteDeleteOne_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rule_tac P="cteCap rv \ NullCap \ isReplyCap (cteCap rv) - \ \ isEndpointCap (cteCap rv) - \ \ isNotificationCap (cteCap rv)" - in monadic_rewrite_gen_asm) - apply (simp add: finaliseCapTrue_standin_def - capRemovable_def) - apply (rule monadic_rewrite_symb_exec_l, - (wp isFinalCapability_inv empty_fail_isFinalCapability)+) - apply (rule monadic_rewrite_refl) - apply (wp getCTE_wp')+ - apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) - done - -lemma cteDeleteOne_nullcap_rewrite: - "monadic_rewrite True False - (cte_wp_at' (\cte. cteCap cte = NullCap) slot) - (cteDeleteOne slot) - (return ())" - apply (simp add: cteDeleteOne_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rule_tac P="cteCap rv = NullCap" in monadic_rewrite_gen_asm) - apply simp - apply (rule monadic_rewrite_refl) - apply (wp getCTE_wp') - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -lemma deleteCallerCap_nullcap_rewrite: - "monadic_rewrite True False - (cte_wp_at' (\cte. cteCap cte = NullCap) (thread + 2 ^ cte_level_bits * tcbCallerSlot)) - (deleteCallerCap thread) - (return ())" - apply (simp add: deleteCallerCap_def getThreadCallerSlot_def locateSlot_conv - getSlotCap_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rule monadic_rewrite_assert) - apply (rule cteDeleteOne_nullcap_rewrite) - apply (wp getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -end - -lemma emptySlot_cnode_caps: - "\\s. P (only_cnode_caps (ctes_of s)) \ cte_wp_at' (\cte. \ isCNodeCap (cteCap cte)) slot s\ - emptySlot slot NullCap - \\rv s. P (only_cnode_caps (ctes_of s))\" - apply (simp add: only_cnode_caps_def map_option_comp2 - o_assoc[symmetric] cteCaps_of_def[symmetric]) - apply (wp emptySlot_cteCaps_of) - apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of - elim!: rsubst[where P=P] intro!: ext - split: if_split) - done - -lemma asUser_obj_at_ep[wp]: - "\obj_at' P p\ asUser t m \\rv. obj_at' (P :: endpoint \ bool) p\" - apply (simp add: asUser_def split_def) - apply (wp hoare_drop_imps | simp)+ - done - -lemma setCTE_obj_at_ep[wp]: - "\obj_at' (P :: endpoint \ bool) p\ setCTE ptr cte \\rv. obj_at' P p\" - unfolding setCTE_def - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_cte typeError_def in_monad - split: Structures_H.kernel_object.split_asm - if_split_asm) - done - -lemma setCTE_obj_at_ntfn[wp]: - "\obj_at' (P :: Structures_H.notification \ bool) p\ setCTE ptr cte \\rv. obj_at' P p\" - unfolding setCTE_def - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_cte typeError_def in_monad - split: Structures_H.kernel_object.split_asm - if_split_asm) - done - -crunch obj_at_ep[wp]: emptySlot "obj_at' (P :: endpoint \ bool) p" - -crunch nosch[wp]: emptySlot "\s. P (ksSchedulerAction s)" - -context begin interpretation Arch . -crunches emptySlot, asUser - for gsCNodes[wp]: "\s. P (gsCNodes s)" - (wp: crunch_wps) -end - -crunch cte_wp_at'[wp]: possibleSwitchTo "cte_wp_at' P p" - (wp: hoare_drop_imps) - -crunch tcbContext[wp]: possibleSwitchTo "obj_at' (\tcb. P ( (atcbContextGet o tcbArch) tcb)) t" - (wp: crunch_wps simp_del: comp_apply) - -crunch only_cnode_caps[wp]: doFaultTransfer "\s. P (only_cnode_caps (ctes_of s))" - (wp: crunch_wps simp: crunch_simps) - -context kernel_m begin - -lemma tcbSchedDequeue_rewrite_not_queued: "monadic_rewrite True False (tcb_at' t and obj_at' (Not \ tcbQueued) t) (tcbSchedDequeue t) (return ())" - apply (simp add: tcbSchedDequeue_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac P="\ queued" in monadic_rewrite_gen_asm) - apply (simp add: when_def) - apply (rule monadic_rewrite_refl) - apply (wp threadGet_const) - - apply (rule monadic_rewrite_symb_exec_l) - apply wp+ - apply (rule monadic_rewrite_refl) - apply (wp) - apply (clarsimp simp: o_def obj_at'_def) - done - -lemma schedule_known_rewrite: - "monadic_rewrite True False - (\s. ksSchedulerAction s = SwitchToThread t - \ tcb_at' t s - \ obj_at' (Not \ tcbQueued) t s - \ ksCurThread s = t' - \ st_tcb_at' (Not \ runnable') t' s - \ (ksCurThread s \ ksIdleThread s) - \ fastpathBestSwitchCandidate t s) - (schedule) - (do Arch.switchToThread t; - setCurThread t; - setSchedulerAction ResumeCurrentThread od)" - supply subst_all [simp del] - apply (simp add: schedule_def) - apply (simp only: switchToThread_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac P="action = SwitchToThread t" in monadic_rewrite_gen_asm, simp) - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac P="\ wasRunnable \ action = SwitchToThread t" in monadic_rewrite_gen_asm,simp) - apply (rule monadic_rewrite_bind_tail, rename_tac idleThread) - apply (rule monadic_rewrite_bind_tail, rename_tac targetPrio) - apply (rule monadic_rewrite_bind_tail, rename_tac curPrio) - apply (rule monadic_rewrite_bind_tail, rename_tac fastfail) - apply (rule monadic_rewrite_bind_tail, rename_tac curDom) - apply (rule monadic_rewrite_bind_tail, rename_tac highest) - apply (rule_tac P="\ (fastfail \ \ highest)" in monadic_rewrite_gen_asm, simp only:) - apply simp - apply (simp add: bind_assoc) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_bind) - apply (rule monadic_rewrite_trans) - apply (rule tcbSchedDequeue_rewrite_not_queued) - apply (rule monadic_rewrite_refl) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_refl) - apply (wpsimp wp: Arch_switchToThread_obj_at_pre)+ - apply (wp hoare_vcg_imp_lift)+ - apply (simp add: isHighestPrio_def') - apply wp+ - apply (wp hoare_vcg_disj_lift) - apply (wp scheduleSwitchThreadFastfail_False_wp) - apply wp+ - apply (wp hoare_vcg_disj_lift threadGet_wp'') - apply (wp hoare_vcg_disj_lift threadGet_wp'') - apply clarsimp - apply wp - apply (simp add: comp_def) - apply wp - apply wp - apply wp - (* remove no-ops, somewhat by magic *) - apply (rule monadic_rewrite_symb_exec_l'_TT, solves wp, - wpsimp wp: empty_fail_isRunnable simp: isHighestPrio_def')+ - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_symb_exec_l) - apply simp+ - apply (rule monadic_rewrite_refl) - apply wp+ - apply (rule monadic_rewrite_refl) - apply wp+ - apply (clarsimp simp: ct_in_state'_def) - apply (rule conjI) - apply (rule not_pred_tcb_at'_strengthen, assumption) - apply normalise_obj_at' - apply (simp add: fastpathBestSwitchCandidate_def) - apply normalise_obj_at' - done - -lemma tcb_at_cte_at_offset: - "\ tcb_at' t s; 2 ^ cte_level_bits * off \ dom tcb_cte_cases \ - \ cte_at' (t + 2 ^ cte_level_bits * off) s" - apply (clarsimp simp: obj_at'_def projectKOs objBits_simps) - apply (erule(2) cte_wp_at_tcbI') - apply fastforce - apply simp - done - -lemma emptySlot_cte_wp_at_cteCap: - "\\s. (p = p' \ P NullCap) \ (p \ p' \ cte_wp_at' (\cte. P (cteCap cte)) p s)\ - emptySlot p' irqopt - \\rv s. cte_wp_at' (\cte. P (cteCap cte)) p s\" - apply (simp add: tree_cte_cteCap_eq[unfolded o_def]) - apply (wp emptySlot_cteCaps_of) - apply (clarsimp split: if_split) - done - -lemma setEndpoint_getCTE_pivot[unfolded K_bind_def]: - "do setEndpoint p val; v <- getCTE slot; f v od - = do v <- getCTE slot; setEndpoint p val; f v od" - apply (simp add: getCTE_assert_opt setEndpoint_def - setObject_modify_assert - fun_eq_iff bind_assoc) - apply (simp add: exec_gets assert_def assert_opt_def - exec_modify update_ep_map_tos - split: if_split option.split) - done - -lemma setEndpoint_setCTE_pivot[unfolded K_bind_def]: - "do setEndpoint p val; setCTE slot cte; f od = - do setCTE slot cte; setEndpoint p val; f od" - apply (rule monadic_rewrite_to_eq) - apply simp - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans, - rule_tac f="ep_at' p" in monadic_rewrite_add_gets) - apply (rule monadic_rewrite_transverse, rule monadic_rewrite_add_gets, - rule monadic_rewrite_bind_tail) - apply (rename_tac epat) - apply (rule monadic_rewrite_transverse) - apply (rule monadic_rewrite_bind_tail) - apply (simp add: setEndpoint_def setObject_modify_assert bind_assoc) - apply (rule_tac rv=epat in monadic_rewrite_gets_known) - apply (wp setCTE_typ_at'[where T="koType TYPE(endpoint)", unfolded typ_at_to_obj_at'] - | simp)+ - apply (simp add: setCTE_assert_modify bind_assoc) - apply (rule monadic_rewrite_trans, rule monadic_rewrite_add_gets, - rule monadic_rewrite_bind_tail)+ - apply (rename_tac cteat tcbat) - apply (rule monadic_rewrite_trans, rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_trans) - apply (rule_tac rv=cteat in monadic_rewrite_gets_known) - apply (rule_tac rv=tcbat in monadic_rewrite_gets_known) - apply (wp setEndpoint_typ_at'[where T="koType TYPE(tcb)", unfolded typ_at_to_obj_at'] - setEndpoint_typ_at'[where T="koType TYPE(cte)", unfolded typ_at_to_obj_at'] - | simp)+ - apply (rule_tac P="\s. epat = ep_at' p s \ cteat = real_cte_at' slot s - \ tcbat = (tcb_at' (slot && ~~ mask 9) and (%y. slot && mask 9 : dom tcb_cte_cases)) s" - in monadic_rewrite_refl3) - apply (simp add: setEndpoint_def setObject_modify_assert bind_assoc - exec_gets assert_def exec_modify - split: if_split) - apply (auto split: if_split simp: obj_at'_def projectKOs objBits_defs - intro!: arg_cong[where f=f] ext kernel_state.fold_congs)[1] - apply wp+ - apply (simp add: objBits_defs) - done - -lemma setEndpoint_updateMDB_pivot[unfolded K_bind_def]: - "do setEndpoint p val; updateMDB slot mf; f od = - do updateMDB slot mf; setEndpoint p val; f od" - by (clarsimp simp: updateMDB_def bind_assoc - setEndpoint_getCTE_pivot - setEndpoint_setCTE_pivot - split: if_split) - -lemma setEndpoint_updateCap_pivot[unfolded K_bind_def]: - "do setEndpoint p val; updateCap slot mf; f od = - do updateCap slot mf; setEndpoint p val; f od" - by (clarsimp simp: updateCap_def bind_assoc - setEndpoint_getCTE_pivot - setEndpoint_setCTE_pivot) - -lemma modify_setEndpoint_pivot[unfolded K_bind_def]: - "\ \ksf s. ksPSpace_update ksf (sf s) = sf (ksPSpace_update ksf s) \ - \ (do modify sf; setEndpoint p val; f od) = - (do setEndpoint p val; modify sf; f od)" - apply (subgoal_tac "\s. ep_at' p (sf s) = ep_at' p s") - apply (simp add: setEndpoint_def setObject_modify_assert - bind_assoc fun_eq_iff - exec_gets exec_modify assert_def - split: if_split) - apply atomize - apply clarsimp - apply (drule_tac x="\_. ksPSpace s" in spec) - apply (drule_tac x="s" in spec) - apply (drule_tac f="ksPSpace" in arg_cong) - apply simp - apply (metis obj_at'_pspaceI) - done - -lemma setEndpoint_clearUntypedFreeIndex_pivot[unfolded K_bind_def]: - "do setEndpoint p val; v <- clearUntypedFreeIndex slot; f od - = do v <- clearUntypedFreeIndex slot; setEndpoint p val; f od" - supply option.case_cong_weak[cong del] - by (simp add: clearUntypedFreeIndex_def bind_assoc getSlotCap_def setEndpoint_getCTE_pivot - updateTrackedFreeIndex_def modify_setEndpoint_pivot - split: capability.split - | rule bind_cong[OF refl] allI impI bind_apply_cong[OF refl])+ - -lemma emptySlot_setEndpoint_pivot[unfolded K_bind_def]: - "(do emptySlot slot NullCap; setEndpoint p val; f od) = - (do setEndpoint p val; emptySlot slot NullCap; f od)" - apply (rule ext) - apply (simp add: emptySlot_def bind_assoc - setEndpoint_getCTE_pivot - setEndpoint_updateCap_pivot - setEndpoint_updateMDB_pivot - case_Null_If Retype_H.postCapDeletion_def - setEndpoint_clearUntypedFreeIndex_pivot - split: if_split - | rule bind_apply_cong[OF refl])+ - done - -lemma set_getCTE[unfolded K_bind_def]: - "do setCTE p cte; v <- getCTE p; f v od - = do setCTE p cte; f cte od" - apply simp - apply (rule monadic_rewrite_to_eq) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_bind_tail) - apply (simp add: getCTE_assert_opt bind_assoc) - apply (rule monadic_rewrite_trans, - rule_tac rv="Some cte" in monadic_rewrite_gets_known) - apply (simp add: assert_opt_def) - apply (rule monadic_rewrite_refl) - apply wp - apply simp - done - -lemma set_setCTE[unfolded K_bind_def]: - "do setCTE p val; setCTE p val' od = setCTE p val'" - apply simp - apply (rule monadic_rewrite_to_eq) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans, - rule_tac f="real_cte_at' p" in monadic_rewrite_add_gets) - apply (rule monadic_rewrite_transverse, rule monadic_rewrite_add_gets, - rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_trans, - rule_tac f="tcb_at' (p && ~~ mask 9) and K (p && mask 9 \ dom tcb_cte_cases)" - in monadic_rewrite_add_gets) - apply (rule monadic_rewrite_transverse, rule monadic_rewrite_add_gets, - rule monadic_rewrite_bind_tail) - apply (rename_tac cteat tcbat) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_tail) - apply (simp add: setCTE_assert_modify) - apply (rule monadic_rewrite_trans, rule_tac rv=cteat in monadic_rewrite_gets_known) - apply (rule_tac rv=tcbat in monadic_rewrite_gets_known) - apply (wp setCTE_typ_at'[where T="koType TYPE(tcb)", unfolded typ_at_to_obj_at'] - setCTE_typ_at'[where T="koType TYPE(cte)", unfolded typ_at_to_obj_at'] - | simp)+ - apply (simp add: setCTE_assert_modify bind_assoc) - apply (rule monadic_rewrite_bind_tail)+ - apply (rule_tac P="c = cteat \ t = tcbat - \ (tcbat \ - (\ getF setF. tcb_cte_cases (p && mask 9) = Some (getF, setF) - \ (\ f g tcb. setF f (setF g tcb) = setF (f o g) tcb)))" - in monadic_rewrite_gen_asm) - apply (rule monadic_rewrite_refl2) - apply (simp add: exec_modify split: if_split) - apply (auto simp: simpler_modify_def projectKO_opt_tcb objBits_defs - intro!: kernel_state.fold_congs ext - split: if_split)[1] - apply wp+ - apply (clarsimp simp: objBits_defs intro!: all_tcbI) - apply (auto simp: tcb_cte_cases_def split: if_split_asm) - done - -lemma setCTE_updateCapMDB: - "p \ 0 \ - setCTE p cte = do updateCap p (cteCap cte); updateMDB p (const (cteMDBNode cte)) od" - apply (simp add: updateCap_def updateMDB_def bind_assoc set_getCTE - cte_overwrite set_setCTE) - apply (simp add: getCTE_assert_opt setCTE_assert_modify bind_assoc) - apply (rule ext, simp add: exec_gets assert_opt_def exec_modify - split: if_split option.split) - apply (cut_tac P=\ and p=p and s=x in cte_wp_at_ctes_of) - apply (cases cte) - apply (simp add: cte_wp_at_obj_cases') - apply (auto simp: mask_out_sub_mask) - done - -lemma clearUntypedFreeIndex_simple_rewrite: - "monadic_rewrite True False - (cte_wp_at' (Not o isUntypedCap o cteCap) slot) - (clearUntypedFreeIndex slot) (return ())" - apply (simp add: clearUntypedFreeIndex_def getSlotCap_def) - apply (rule monadic_rewrite_name_pre) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (rule monadic_rewrite_imp) - apply (rule_tac rv=cte in monadic_rewrite_symb_exec_l_known, wp+) - apply (simp split: capability.split, - strengthen monadic_rewrite_refl, simp) - apply clarsimp - apply (wp getCTE_wp') - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -lemma emptySlot_replymaster_rewrite[OF refl]: - "mdbn = cteMDBNode cte \ - monadic_rewrite True False - ((\_. mdbNext mdbn = 0 \ mdbPrev mdbn \ 0) - and ((\_. cteCap cte \ NullCap) - and (cte_wp_at' ((=) cte) slot - and cte_wp_at' (\cte. isReplyCap (cteCap cte)) slot - and cte_wp_at' (\cte. isReplyCap (cteCap cte) \ capReplyMaster (cteCap cte)) - (mdbPrev mdbn) - and (\s. reply_masters_rvk_fb (ctes_of s)) - and (\s. no_0 (ctes_of s))))) - (emptySlot slot NullCap) - (do updateMDB (mdbPrev mdbn) (mdbNext_update (K 0) o mdbFirstBadged_update (K True) - o mdbRevocable_update (K True)); - setCTE slot makeObject - od)" - apply (rule monadic_rewrite_gen_asm)+ - apply (rule monadic_rewrite_imp) - apply (rule_tac P="slot \ 0" in monadic_rewrite_gen_asm) - apply (clarsimp simp: emptySlot_def setCTE_updateCapMDB) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_head) - apply (rule clearUntypedFreeIndex_simple_rewrite) - apply simp - apply (rule_tac rv=cte in monadic_rewrite_symb_exec_l_known, (wp empty_fail_getCTE)+) - apply (simp add: updateMDB_def Let_def bind_assoc makeObject_cte case_Null_If) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_bind) - apply (rule_tac P="mdbFirstBadged (cteMDBNode ctea) \ mdbRevocable (cteMDBNode ctea)" - in monadic_rewrite_gen_asm) - apply (rule monadic_rewrite_refl2) - apply (case_tac ctea, rename_tac mdbnode, case_tac mdbnode) - apply simp - apply (simp add: Retype_H.postCapDeletion_def) - apply (rule monadic_rewrite_refl) - apply (wp getCTE_wp')+ - apply (clarsimp simp: cte_wp_at_ctes_of reply_masters_rvk_fb_def) - apply (fastforce simp: isCap_simps) - done - -lemma all_prio_not_inQ_not_tcbQueued: "\ obj_at' (\a. (\d p. \ inQ d p a)) t s \ \ obj_at' (\a. \ tcbQueued a) t s" - apply (clarsimp simp: obj_at'_def inQ_def) -done - -crunches setThreadState, emptySlot, asUser - for ntfn_obj_at[wp]: "obj_at' (P::(Structures_H.notification \ bool)) ntfnptr" - (wp: obj_at_setObject2 crunch_wps - simp: crunch_simps updateObject_default_def in_monad) - -lemma st_tcb_at_is_Reply_imp_not_tcbQueued: "\s t.\ invs' s; st_tcb_at' isReply t s\ \ obj_at' (\a. \ tcbQueued a) t s" - apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def st_tcb_at'_def valid_queues_no_bitmap_def) - apply (rule all_prio_not_inQ_not_tcbQueued) - apply (clarsimp simp: obj_at'_def) - apply (erule_tac x="d" in allE) - apply (erule_tac x="p" in allE) - apply (erule conjE) - apply (erule_tac x="t" in ballE) - apply (clarsimp simp: obj_at'_def runnable'_def isReply_def) - apply (case_tac "tcbState obj") - apply ((clarsimp simp: inQ_def)+)[8] - apply (clarsimp simp: valid_queues'_def obj_at'_def) -done - -lemma valid_objs_ntfn_at_tcbBoundNotification: - "ko_at' tcb t s \ valid_objs' s \ tcbBoundNotification tcb \ None - \ ntfn_at' (the (tcbBoundNotification tcb)) s" - apply (drule(1) ko_at_valid_objs', simp add: projectKOs) - apply (simp add: valid_obj'_def valid_tcb'_def valid_bound_ntfn'_def) - apply clarsimp - done - -crunch bound_tcb_at'_Q[wp]: setThreadState "\s. Q (bound_tcb_at' P t s)" - (wp: threadSet_pred_tcb_no_state crunch_wps simp: unless_def) - -lemmas emptySlot_pred_tcb_at'_Q[wp] = lift_neg_pred_tcb_at'[OF emptySlot_typ_at' emptySlot_pred_tcb_at'] - -lemma emptySlot_tcb_at'[wp]: - "\\s. Q (tcb_at' t s)\ emptySlot a b \\_ s. Q (tcb_at' t s)\" - by (simp add: tcb_at_typ_at', wp) - -lemmas cnode_caps_gsCNodes_lift - = hoare_lift_Pf2[where P="\gs s. cnode_caps_gsCNodes (f s) gs" and f=gsCNodes for f] - hoare_lift_Pf2[where P="\gs s. Q s \ cnode_caps_gsCNodes (f s) gs" and f=gsCNodes for f Q] - -lemma resolveAddressBitsFn_eq_name_slot: - "monadic_rewrite F E (\s. (isCNodeCap cap \ cte_wp_at' (\cte. cteCap cte = cap) (slot s) s) - \ valid_objs' s \ cnode_caps_gsCNodes' s) - (resolveAddressBits cap capptr bits) - (gets (resolveAddressBitsFn cap capptr bits o only_cnode_caps o ctes_of))" - apply (rule monadic_rewrite_imp, rule resolveAddressBitsFn_eq) - apply auto - done - -crunch bound_tcb_at'_Q[wp]: asUser "\s. Q (bound_tcb_at' P t s)" - (simp: crunch_simps wp: threadSet_pred_tcb_no_state crunch_wps) - - -lemma asUser_tcb_at'_Q[wp]: - "\\s. Q (tcb_at' t s)\ asUser a b \\_ s. Q (tcb_at' t s)\" - by (simp add: tcb_at_typ_at', wp) - -lemma active_ntfn_check_wp: - "\\s. Q (\ntfnptr. bound_tcb_at' ((=) (Some ntfnptr)) thread s - \ \ obj_at' (Not o isActive) ntfnptr s) s \ do bound_ntfn \ getBoundNotification thread; - case bound_ntfn of None \ return False - | Some ntfnptr \ liftM EndpointDecls_H.isActive $ getNotification ntfnptr - od \Q\" - apply (rule hoare_pre) - apply (wp getNotification_wp gbn_wp' | wpc)+ - apply (auto simp: pred_tcb_at'_def obj_at'_def projectKOs) - done - -lemma tcbSchedEnqueue_tcbIPCBuffer: - "\obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\ - tcbSchedEnqueue t' - \\_. obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\" - apply (simp add: tcbSchedEnqueue_def unless_when) - apply (wp threadSet_obj_at' hoare_drop_imps threadGet_wp - |simp split: if_split)+ - done - -crunch obj_at'_tcbIPCBuffer[wp]: rescheduleRequired "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" - (wp: crunch_wps tcbSchedEnqueue_tcbIPCBuffer simp: rescheduleRequired_def) - -context -notes if_cong[cong] -begin -crunch obj_at'_tcbIPCBuffer[wp]: setThreadState "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" - (wp: crunch_wps threadSet_obj_at'_really_strongest) - -crunch obj_at'_tcbIPCBuffer[wp]: handleFault "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" - (wp: crunch_wps constOnFailure_wp tcbSchedEnqueue_tcbIPCBuffer threadSet_obj_at'_really_strongest - simp: zipWithM_x_mapM) -end - -crunch obj_at'_tcbIPCBuffer[wp]: emptySlot "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" - (wp: crunch_wps) - -lemma fastpath_callKernel_SysReplyRecv_corres: - "monadic_rewrite True False - (invs' and ct_in_state' ((=) Running) and (\s. ksSchedulerAction s = ResumeCurrentThread) - and cnode_caps_gsCNodes') - (callKernel (SyscallEvent SysReplyRecv)) (fastpaths SysReplyRecv)" - including no_pre - supply option.case_cong_weak[cong del] - supply if_cong[cong] - apply (rule monadic_rewrite_introduce_alternative) - apply (simp add: callKernel_def) - apply (rule monadic_rewrite_imp) - apply (simp add: handleEvent_def handleReply_def - handleRecv_def liftE_bindE_handle liftE_handle - bind_assoc getMessageInfo_def liftE_bind) - apply (simp add: catch_liftE_bindE unlessE_throw_catch_If - unifyFailure_catch_If catch_liftE - getMessageInfo_def alternative_bind - fastpaths_def getThreadCallerSlot_def - locateSlot_conv capability_case_Null_ReplyCap - getThreadCSpaceRoot_def - cong: if_cong) - apply (rule monadic_rewrite_rdonly_bind_l, wp) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac thread msgInfo) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac cptr) - apply (rule monadic_rewrite_symb_exec_r[OF threadGet_inv no_fail_threadGet]) - apply (rename_tac tcbFault) - apply (rule monadic_rewrite_alternative_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (simp add: lookupCap_def liftME_def lookupCapAndSlot_def - lookupSlotForThread_def bindE_assoc - split_def getThreadCSpaceRoot_def - locateSlot_conv liftE_bindE bindE_bind_linearise - capFaultOnFailure_def rethrowFailure_injection - injection_handler_catch bind_bindE_assoc - getThreadCallerSlot_def bind_assoc - getSlotCap_def - case_bool_If o_def - isRight_def[where x="Inr v" for v] - isRight_def[where x="Inl v" for v] - cong: if_cong) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac "cTableCTE") - - apply (rule monadic_rewrite_transverse, - rule monadic_rewrite_bind_head, - rule resolveAddressBitsFn_eq) - apply (rule monadic_rewrite_symb_exec_r, (wp | simp)+) - apply (rename_tac "rab_ret") - - apply (rule_tac P="isRight rab_ret" in monadic_rewrite_cases[rotated]) - apply (case_tac rab_ret, simp_all add: isRight_def)[1] - apply (rule monadic_rewrite_alternative_l) - apply clarsimp - apply (simp add: isRight_case_sum liftE_bind - isRight_def[where x="Inr v" for v]) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac ep_cap) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_symb_exec_r[OF _ _ _ active_ntfn_check_wp, unfolded bind_assoc fun_app_def]) - apply (rule hoare_pre, (wp | wpc | simp)+)[1] - apply (unfold getBoundNotification_def)[1] - apply (wp threadGet_wp) - apply (rename_tac ep) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac ep) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_rdonly_bind_l, wp) - apply (rule monadic_rewrite_bind_tail) - apply (rename_tac replyCTE) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (simp add: bind_assoc) - apply (rule monadic_rewrite_rdonly_bind_l, wp assert_inv) - apply (rule monadic_rewrite_assert) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac callerFault) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (simp add: getThreadVSpaceRoot_def locateSlot_conv) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac vTableCTE) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - - apply (rule monadic_rewrite_symb_exec_r[OF curDomain_inv], - simp only: curDomain_def, rule non_fail_gets) - apply (rename_tac "curDom") - apply (rule monadic_rewrite_symb_exec_r - [OF threadGet_inv no_fail_threadGet]) - apply (rename_tac callerPrio) - apply (simp add: isHighestPrio_def') - apply (rule monadic_rewrite_symb_exec_r [OF gets_inv non_fail_gets]) - apply (rename_tac highest) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac asidMap) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_symb_exec_r[OF threadGet_inv no_fail_threadGet]) - apply (rename_tac "callerDom") - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_trans, - rule monadic_rewrite_pick_alternative_1) - apply (rule_tac P="\v. obj_at' (%tcb. tcbIPCBuffer tcb = v) (capTCBPtr (cteCap replyCTE))" - in monadic_rewrite_exists_v) - apply (rename_tac ipcBuffer) - - apply (simp add: ARM_H.switchToThread_def bind_assoc) - apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) - - apply (rule monadic_rewrite_bind monadic_rewrite_refl)+ - apply (wp mapM_x_wp' getObject_inv | wpc | simp add: - | wp (once) hoare_drop_imps )+ - - apply (rule monadic_rewrite_bind monadic_rewrite_refl)+ - apply (wp setCTE_obj_at'_tcbIPCBuffer assert_inv mapM_x_wp' getObject_inv | wpc | simp - | wp (once) hoare_drop_imps )+ - - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_head) - apply (rule monadic_rewrite_trans) - apply (rule doReplyTransfer_simple) - apply simp - apply (((rule monadic_rewrite_weaken2, - (rule_tac msgInfo=msgInfo in doIPCTransfer_simple_rewrite - | rule_tac destPrio=callerPrio - and curDom=curDom and destDom=callerDom - and thread=thread in possibleSwitchTo_rewrite)) - | rule cteDeleteOne_replycap_rewrite - | rule monadic_rewrite_bind monadic_rewrite_refl - | wp assert_inv mapM_x_wp' - setThreadState_obj_at_unchanged - asUser_obj_at_unchanged - hoare_strengthen_post[OF _ obj_at_conj'[simplified atomize_conjL], rotated] - lookupBitmapPriority_lift - setThreadState_runnable_bitmap_inv - | simp add: setMessageInfo_def setThreadState_runnable_simp - | wp (once) hoare_vcg_disj_lift)+)[1] - apply (simp add: setMessageInfo_def) - apply (rule monadic_rewrite_bind_tail) - apply (rename_tac unblocked) - apply (rule_tac rv=thread in monadic_rewrite_symb_exec_l_known, - (wp empty_fail_getCurThread)+) - apply (rule_tac rv=cptr in monadic_rewrite_symb_exec_l_known, - (wp empty_fail_asUser empty_fail_getRegister)+) - apply (rule monadic_rewrite_bind) - apply (rule monadic_rewrite_catch[OF _ monadic_rewrite_refl True_E_E]) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rename_tac cTableCTE2, - rule_tac P="cteCap cTableCTE2 = cteCap cTableCTE" - in monadic_rewrite_gen_asm) - apply simp - apply (rule monadic_rewrite_trans, - rule monadic_rewrite_bindE[OF _ monadic_rewrite_refl]) - apply (rule_tac slot="\s. ksCurThread s + 2 ^ cte_level_bits * tcbCTableSlot" - in resolveAddressBitsFn_eq_name_slot) - apply wp - apply (rule monadic_rewrite_trans) - apply (rule_tac rv=rab_ret - in monadic_rewrite_gets_known[where m="NonDetMonad.lift f" - for f, folded bindE_def]) - apply (simp add: NonDetMonad.lift_def isRight_case_sum) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rename_tac ep_cap2) - apply (rule_tac P="cteCap ep_cap2 = cteCap ep_cap" in monadic_rewrite_gen_asm) - apply (simp add: cap_case_EndpointCap_NotificationCap) - apply (rule monadic_rewrite_liftE) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind) - apply (rule deleteCallerCap_nullcap_rewrite) - apply (rule_tac ep=ep in receiveIPC_simple_rewrite) - apply (wp, simp) - apply (rule monadic_rewrite_bind_head) - - apply (rule monadic_rewrite_weaken[where E=True and F=True], simp) - apply (rule setThreadState_rewrite_simple) - apply clarsimp - apply (wp getCTE_known_cap)+ - apply (rule monadic_rewrite_bind) - apply (rule_tac t="capTCBPtr (cteCap replyCTE)" - and t'=thread - in schedule_known_rewrite) - apply (rule monadic_rewrite_weaken[where E=True and F=True], simp) - apply (rule monadic_rewrite_bind) - apply (rule activateThread_simple_rewrite) - apply (rule monadic_rewrite_refl) - apply wp - apply wp - apply (simp add: ct_in_state'_def, simp add: ct_in_state'_def[symmetric]) - apply ((wp setCurThread_ct_in_state[folded st_tcb_at'_def] - Arch_switchToThread_pred_tcb')+)[2] - apply (simp add: catch_liftE) - apply (wp setEndpoint_obj_at_tcb' threadSet_pred_tcb_at_state[unfolded if_bool_eq_conj]) - - apply (wp setEndpoint_obj_at_tcb' - threadSet_pred_tcb_at_state[unfolded if_bool_eq_conj] - fastpathBestSwitchCandidate_lift[where f="setEndpoint a b" for a b] - fastpathBestSwitchCandidate_lift[where f="threadSet f t" for f t] - | simp - | rule hoare_lift_Pf2[where f=ksCurThread, OF _ setEndpoint_ct'] - hoare_lift_Pf2[where f=ksCurThread, OF _ threadSet_ct])+ - - apply (simp cong: rev_conj_cong) - apply (strengthen imp_consequent[where Q="tcb_at' t s" for t s]) - apply (unfold setSchedulerAction_def)[3] - apply ((wp setThreadState_oa_queued user_getreg_rv setThreadState_no_sch_change - setThreadState_obj_at_unchanged - sts_st_tcb_at'_cases sts_bound_tcb_at' - emptySlot_obj_at'_not_queued - emptySlot_cte_wp_at_cteCap - emptySlot_cnode_caps - user_getreg_inv asUser_typ_ats - asUser_obj_at_not_queued asUser_obj_at' mapM_x_wp' - static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift - static_imp_wp cnode_caps_gsCNodes_lift - hoare_vcg_ex_lift - | simp del: comp_apply - | clarsimp simp: obj_at'_weakenE[OF _ TrueI])+) - - apply (rule hoare_lift_Pf2[where f=ksCurThread, OF _ setThreadState_ct']) - apply (wp setThreadState_oa_queued - fastpathBestSwitchCandidate_lift[where f="setThreadState f t" for f t]) - apply (simp add: setThreadState_runnable_simp) - apply (wp threadSet_tcbState_st_tcb_at') - apply (clarsimp simp del: comp_apply) - apply (wp emptySlot_obj_at_ep)+ - - apply ((wp setThreadState_oa_queued user_getreg_rv - setThreadState_no_sch_change - setThreadState_obj_at_unchanged - sts_st_tcb_at'_cases sts_bound_tcb_at' - emptySlot_obj_at'_not_queued - emptySlot_cte_wp_at_cteCap - emptySlot_cnode_caps - user_getreg_inv asUser_typ_ats - asUser_obj_at_not_queued asUser_obj_at' mapM_x_wp' - static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift - static_imp_wp cnode_caps_gsCNodes_lift - hoare_vcg_ex_lift - | simp del: comp_apply - | clarsimp simp: obj_at'_weakenE[OF _ TrueI] - | solves \ - rule hoare_lift_Pf2[where f=ksCurThread, OF _ emptySlot_ct] - hoare_lift_Pf2[where f=ksCurThread, OF _ asUser_ct], - wp fastpathBestSwitchCandidate_lift[where f="emptySlot a b" for a b] - fastpathBestSwitchCandidate_lift[where f="asUser a b" for a b] - user_getreg_inv asUser_typ_ats\)+) - - apply (clarsimp | wp getCTE_wp' gts_imp')+ - - apply (simp add: ARM_H.switchToThread_def bind_assoc) - apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) - - apply (rule monadic_rewrite_bind monadic_rewrite_refl)+ - apply (wp mapM_x_wp' handleFault_obj_at'_tcbIPCBuffer getObject_inv | wpc | simp - | wp (once) hoare_drop_imps )+ - apply (rule monadic_rewrite_bind monadic_rewrite_refl)+ - apply (wp setCTE_obj_at'_tcbIPCBuffer assert_inv mapM_x_wp' getObject_inv | wpc | simp - | wp (once) hoare_drop_imps )+ - - apply (simp add: bind_assoc catch_liftE - receiveIPC_def Let_def liftM_def - setThreadState_runnable_simp) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getThreadState)+) - apply (rule monadic_rewrite_assert) - - apply (rule_tac P="inj (case_bool thread (capTCBPtr (cteCap replyCTE)))" - in monadic_rewrite_gen_asm) - apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) - apply (rule monadic_rewrite_weaken[where F=False and E=True], simp) - apply (rule isolate_thread_actions_rewrite_bind - fastpath_isolate_rewrites fastpath_isolatables - bool.simps setRegister_simple - zipWithM_setRegister_simple - thread_actions_isolatable_bind - thread_actions_isolatableD[OF setCTE_isolatable] - setCTE_isolatable - setVMRoot_isolatable[THEN thread_actions_isolatableD] setVMRoot_isolatable - doMachineOp_isolatable[THEN thread_actions_isolatableD] doMachineOp_isolatable - kernelExitAssertions_isolatable[THEN thread_actions_isolatableD] - kernelExitAssertions_isolatable - | assumption - | wp assert_inv)+ - apply (simp only: ) - apply (rule_tac P="(\s. ksSchedulerAction s = ResumeCurrentThread) - and tcb_at' thread - and (cte_wp_at' (\cte. isReplyCap (cteCap cte)) - (thread + 2 ^ cte_level_bits * tcbCallerSlot) - and (\s. \x. tcb_at' (case_bool thread (capTCBPtr (cteCap replyCTE)) x) s) - and valid_mdb')" - and F=True and E=False in monadic_rewrite_weaken) - apply (rule monadic_rewrite_isolate_final2) - apply simp - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rename_tac callerCTE) - apply (rule monadic_rewrite_assert) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rule monadic_rewrite_assert) - apply (simp add: emptySlot_setEndpoint_pivot) - apply (rule monadic_rewrite_bind) - apply (rule monadic_rewrite_refl2) - apply (clarsimp simp: isSendEP_def split: Structures_H.endpoint.split) - apply (rule_tac Q="\rv. (\_. rv = callerCTE) and Q'" for Q' - in monadic_rewrite_symb_exec_r, wp+) - apply (rule monadic_rewrite_gen_asm, simp) - apply (rule monadic_rewrite_trans, rule monadic_rewrite_bind_head, - rule_tac cte=callerCTE in emptySlot_replymaster_rewrite) - apply (simp add: bind_assoc o_def) - apply (rule monadic_rewrite_refl) - apply (simp add: cte_wp_at_ctes_of pred_conj_def) - apply (clarsimp | wp getCTE_ctes_wp)+ - apply (clarsimp simp: zip_map2 zip_same_conv_map foldl_map - foldl_fun_upd - foldr_copy_register_tsrs - isRight_case_sum - cong: if_cong) - apply (clarsimp simp: fun_eq_iff if_flip - cong: if_cong) - apply (drule obj_at_ko_at', clarsimp) - apply (frule get_tcb_state_regs_ko_at') - apply (clarsimp simp: zip_map2 zip_same_conv_map foldl_map - foldl_fun_upd - foldr_copy_register_tsrs - isRight_case_sum - cong: if_cong) - apply (simp add: upto_enum_def fromEnum_def - enum_register toEnum_def - msgRegisters_unfold - cong: if_cong) - apply (clarsimp split: if_split) - apply (rule ext) - apply (simp add: badgeRegister_def msgInfoRegister_def - ARM.msgInfoRegister_def - ARM.badgeRegister_def - cong: if_cong - split: if_split) - apply simp - apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps - map_to_ctes_partial_overwrite) - apply (simp add: valid_mdb'_def valid_mdb_ctes_def) - apply simp - apply (simp cong: if_cong bool.case_cong - | rule getCTE_wp' gts_wp' threadGet_wp - getEndpoint_wp gets_wp - user_getreg_wp - gets_the_wp gct_wp getNotification_wp - return_wp liftM_wp gbn_wp' - | (simp only: curDomain_def, wp)[1])+ - - apply clarsimp - apply (subgoal_tac "ksCurThread s \ ksIdleThread s") - prefer 2 - apply (fastforce simp: ct_in_state'_def dest: ct_running_not_idle' elim: pred_tcb'_weakenE) - - apply (clarsimp simp: ct_in_state'_def pred_tcb_at') - apply (subst tcb_at_cte_at_offset, - erule obj_at'_weakenE[OF _ TrueI], - simp add: tcb_cte_cases_def cte_level_bits_def tcbSlots) - apply (clarsimp simp: valid_objs_ntfn_at_tcbBoundNotification - invs_valid_objs' if_apply_def2) - apply (rule conjI[rotated]) - apply (fastforce elim: cte_wp_at_weakenE') - apply (clarsimp simp: isRight_def) - apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp+) - apply (frule resolveAddressBitsFn_real_cte_at', - (clarsimp | erule cte_wp_at_weakenE')+) - apply (frule real_cte_at', clarsimp) - apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp, - clarsimp simp: isCap_simps, simp add: valid_cap_simps') - apply (clarsimp simp: maskCapRights_def isCap_simps) - apply (frule_tac p="p' + 2 ^ cte_level_bits * tcbCallerSlot" for p' - in cte_wp_at_valid_objs_valid_cap', clarsimp+) - apply (clarsimp simp: valid_cap_simps') - apply (subst tcb_at_cte_at_offset, - assumption, simp add: tcb_cte_cases_def cte_level_bits_def tcbSlots) - apply (clarsimp simp: inj_case_bool cte_wp_at_ctes_of - length_msgRegisters - n_msgRegisters_def order_less_imp_le - tcb_at_invs' invs_mdb' - split: bool.split) - apply (subst imp_disjL[symmetric], intro allI impI) - apply (clarsimp simp: inj_case_bool cte_wp_at_ctes_of - length_msgRegisters - n_msgRegisters_def order_less_imp_le - tcb_at_invs' invs_mdb' - split: bool.split) - - apply (subgoal_tac "fastpathBestSwitchCandidate v0a s") - prefer 2 - apply normalise_obj_at' - apply (rule_tac ttcb=tcba and ctcb=tcb in fastpathBestSwitchCandidateI) - apply (erule disjE, blast, blast) - apply simp+ - - apply (clarsimp simp: obj_at_tcbs_of tcbSlots - cte_level_bits_def) - apply (frule(1) st_tcb_at_is_Reply_imp_not_tcbQueued) - apply (auto simp: obj_at_tcbs_of tcbSlots - cte_level_bits_def) - done - -lemmas fastpath_reply_recv_ccorres_callKernel - = monadic_rewrite_ccorres_assemble[OF fastpath_reply_recv_ccorres fastpath_callKernel_SysReplyRecv_corres] - -lemma cnode_caps_gsCNodes_from_sr: - "valid_objs s \ (s, s') \ state_relation - \ cnode_caps_gsCNodes' s'" - apply (clarsimp simp: cnode_caps_gsCNodes_def only_cnode_caps_def - o_def ran_map_option) - apply (safe, simp_all) - apply (clarsimp elim!: ranE) - apply (frule(1) pspace_relation_cte_wp_atI[rotated]) - apply clarsimp - apply (clarsimp simp: is_cap_simps) - apply (frule(1) cte_wp_at_valid_objs_valid_cap) - apply (clarsimp simp: valid_cap_simps cap_table_at_gsCNodes_eq) - done - end end diff --git a/proof/crefine/ARM/Fastpath_Defs.thy b/proof/crefine/ARM/Fastpath_Defs.thy new file mode 100644 index 000000000..b60b99b41 --- /dev/null +++ b/proof/crefine/ARM/Fastpath_Defs.thy @@ -0,0 +1,167 @@ +(* + * Copyright 2014, General Dynamics C4 Systems + * Copyright 2022, Proofcraft Pty Ltd + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +(* Contains the design specification of optimised fast paths though the kernel. + These paths check for specific circumstances before engaging, otherwise + falling back to the full kernel design specification (callKernel). + For this reason, fastpath + callKernel is expected to be semantically + identical to callKernel. *) + +theory Fastpath_Defs +imports ArchMove_C +begin + +context begin interpretation Arch . (*FIXME: arch_split*) + +definition + "fastpaths sysc \ case sysc of + SysCall \ doE + curThread \ liftE $ getCurThread; + mi \ liftE $ getMessageInfo curThread; + cptr \ liftE $ asUser curThread $ getRegister capRegister; + + fault \ liftE $ threadGet tcbFault curThread; + pickFastpath \ liftE $ alternative (return True) (return False); + unlessE (fault = None \ msgExtraCaps mi = 0 + \ msgLength mi \ of_nat size_msgRegisters \ pickFastpath) + $ throwError (); + + ctab \ liftE $ getThreadCSpaceRoot curThread >>= getCTE; + epCap \ unifyFailure (doE t \ resolveAddressBits (cteCap ctab) cptr (size cptr); + liftE (getSlotCap (fst t)) odE); + unlessE (isEndpointCap epCap \ capEPCanSend epCap) + $ throwError (); + ep \ liftE $ getEndpoint (capEPPtr epCap); + unlessE (isRecvEP ep) $ throwError (); + dest \ returnOk $ hd $ epQueue ep; + newVTable \ liftE $ getThreadVSpaceRoot dest >>= getCTE; + unlessE (isValidVTableRoot $ cteCap newVTable) $ throwError (); + pd \ returnOk $ capPDBasePtr $ capCap $ cteCap newVTable; + curDom \ liftE $ curDomain; + curPrio \ liftE $ threadGet tcbPriority curThread; + destPrio \ liftE $ threadGet tcbPriority dest; + highest \ liftE $ isHighestPrio curDom destPrio; + unlessE (destPrio \ curPrio \ highest) $ throwError (); + unlessE (capEPCanGrant epCap \ capEPCanGrantReply epCap) $ throwError (); + asidMap \ liftE $ gets $ armKSASIDMap o ksArchState; + unlessE (\v. {hwasid. (hwasid, pd) \ ran asidMap} = {v}) + $ throwError (); + destDom \ liftE $ threadGet tcbDomain dest; + unlessE (destDom = curDom) $ throwError (); + + liftE $ do + setEndpoint (capEPPtr epCap) + (case tl (epQueue ep) of [] \ IdleEP | _ \ RecvEP (tl (epQueue ep))); + threadSet (tcbState_update (\_. BlockedOnReply)) curThread; + replySlot \ getThreadReplySlot curThread; + callerSlot \ getThreadCallerSlot dest; + replySlotCTE \ getCTE replySlot; + assert (mdbNext (cteMDBNode replySlotCTE) = 0 + \ isReplyCap (cteCap replySlotCTE) + \ capReplyMaster (cteCap replySlotCTE) + \ mdbFirstBadged (cteMDBNode replySlotCTE) + \ mdbRevocable (cteMDBNode replySlotCTE)); + destState \ getThreadState dest; + cteInsert (ReplyCap curThread False (blockingIPCCanGrant destState)) replySlot callerSlot; + + forM_x (take (unat (msgLength mi)) msgRegisters) + (\r. do v \ asUser curThread (getRegister r); + asUser dest (setRegister r v) od); + setThreadState Running dest; + Arch.switchToThread dest; + setCurThread dest; + + asUser dest $ zipWithM_x setRegister + [badgeRegister, msgInfoRegister] + [capEPBadge epCap, wordFromMessageInfo (mi\ msgCapsUnwrapped := 0 \)]; + + stateAssert kernelExitAssertions [] + od + + odE (\_. callKernel (SyscallEvent sysc)) + | SysReplyRecv \ doE + curThread \ liftE $ getCurThread; + mi \ liftE $ getMessageInfo curThread; + cptr \ liftE $ asUser curThread $ getRegister capRegister; + + fault \ liftE $ threadGet tcbFault curThread; + pickFastpath \ liftE $ alternative (return True) (return False); + unlessE (fault = None \ msgExtraCaps mi = 0 + \ msgLength mi \ of_nat size_msgRegisters \ pickFastpath) + $ throwError (); + + ctab \ liftE $ getThreadCSpaceRoot curThread >>= getCTE; + epCap \ unifyFailure (doE t \ resolveAddressBits (cteCap ctab) cptr (size cptr); + liftE (getSlotCap (fst t)) odE); + + unlessE (isEndpointCap epCap \ capEPCanReceive epCap) + $ throwError (); + + bound_ntfn \ liftE $ getBoundNotification curThread; + active_ntfn \ liftE $ case bound_ntfn of None \ return False + | Some ntfnptr \ liftM isActive $ getNotification ntfnptr; + unlessE (\ active_ntfn) $ throwError (); + + ep \ liftE $ getEndpoint (capEPPtr epCap); + unlessE (\ isSendEP ep) $ throwError (); + + callerSlot \ liftE $ getThreadCallerSlot curThread; + callerCTE \ liftE $ getCTE callerSlot; + callerCap \ returnOk $ cteCap callerCTE; + unlessE (isReplyCap callerCap \ \ capReplyMaster callerCap) + $ throwError (); + + caller \ returnOk $ capTCBPtr callerCap; + callerFault \ liftE $ threadGet tcbFault caller; + unlessE (callerFault = None) $ throwError (); + newVTable \ liftE $ getThreadVSpaceRoot caller >>= getCTE; + unlessE (isValidVTableRoot $ cteCap newVTable) $ throwError (); + + curDom \ liftE $ curDomain; + callerPrio \ liftE $ threadGet tcbPriority caller; + highest \ liftE $ isHighestPrio curDom callerPrio; + unlessE highest $ throwError (); + + pd \ returnOk $ capPDBasePtr $ capCap $ cteCap newVTable; + asidMap \ liftE $ gets $ armKSASIDMap o ksArchState; + unlessE (\v. {hwasid. (hwasid, pd) \ ran asidMap} = {v}) + $ throwError (); + callerDom \ liftE $ threadGet tcbDomain caller; + unlessE (callerDom = curDom) $ throwError (); + + liftE $ do + epCanGrant \ return $ capEPCanGrant epCap; + threadSet (tcbState_update (\_. BlockedOnReceive (capEPPtr epCap) epCanGrant)) curThread; + setEndpoint (capEPPtr epCap) + (case ep of IdleEP \ RecvEP [curThread] | RecvEP ts \ RecvEP (ts @ [curThread])); + mdbPrev \ liftM (mdbPrev o cteMDBNode) $ getCTE callerSlot; + assert (mdbPrev \ 0); + updateMDB mdbPrev (mdbNext_update (K 0) o mdbFirstBadged_update (K True) + o mdbRevocable_update (K True)); + setCTE callerSlot makeObject; + + forM_x (take (unat (msgLength mi)) msgRegisters) + (\r. do v \ asUser curThread (getRegister r); + asUser caller (setRegister r v) od); + setThreadState Running caller; + Arch.switchToThread caller; + setCurThread caller; + + asUser caller $ zipWithM_x setRegister + [badgeRegister, msgInfoRegister] + [0, wordFromMessageInfo (mi\ msgCapsUnwrapped := 0 \)]; + + stateAssert kernelExitAssertions [] + od + + odE (\_. callKernel (SyscallEvent sysc)) + + | _ \ callKernel (SyscallEvent sysc)" + +end + +end diff --git a/proof/crefine/ARM/Fastpath_Equiv.thy b/proof/crefine/ARM/Fastpath_Equiv.thy new file mode 100644 index 000000000..8da282ec9 --- /dev/null +++ b/proof/crefine/ARM/Fastpath_Equiv.thy @@ -0,0 +1,1901 @@ +(* + * Copyright 2014, General Dynamics C4 Systems + * Copyright 2020, Proofcraft Pty Ltd + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +(* Contains proofs that fastpath + callKernel is semantically identical to + callKernel. *) + +theory Fastpath_Equiv +imports Fastpath_Defs IsolatedThreadAction Refine.RAB_FN +begin + +lemma setCTE_obj_at'_queued: + "\obj_at' (\tcb. P (tcbQueued tcb)) t\ setCTE p v \\rv. obj_at' (\tcb. P (tcbQueued tcb)) t\" + unfolding setCTE_def + by (rule setObject_cte_obj_at_tcb', simp+) + +crunch obj_at'_queued: cteInsert "obj_at' (\tcb. P (tcbQueued tcb)) t" + (wp: setCTE_obj_at'_queued crunch_wps) + +crunch obj_at'_not_queued: emptySlot "obj_at' (\a. \ tcbQueued a) p" + (wp: setCTE_obj_at'_queued) + +lemma getEndpoint_obj_at': + "\obj_at' P ptr\ getEndpoint ptr \\rv s. P rv\" + apply (wp getEndpoint_wp) + apply (clarsimp simp: obj_at'_def projectKOs) + done + +lemmas setEndpoint_obj_at_tcb' = setEndpoint_obj_at'_tcb + +lemma tcbSchedEnqueue_tcbContext[wp]: + "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ + tcbSchedEnqueue t' + \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + apply (rule tcbSchedEnqueue_obj_at_unchangedT[OF all_tcbI]) + apply simp + done + +lemma setCTE_tcbContext: + "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ + setCTE slot cte + \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + apply (simp add: setCTE_def) + apply (rule setObject_cte_obj_at_tcb', simp_all) + done + +context begin interpretation Arch . (*FIXME: arch_split*) + +lemma seThreadState_tcbContext: + "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ + setThreadState a b + \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + apply (rule setThreadState_obj_at_unchanged) + apply (clarsimp simp: atcbContext_def)+ + done + +lemma setBoundNotification_tcbContext: + "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ + setBoundNotification a b + \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + apply (rule setBoundNotification_obj_at_unchanged) + apply (clarsimp simp: atcbContext_def)+ + done + +declare comp_apply [simp del] +crunch tcbContext[wp]: deleteCallerCap "obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t" + (wp: setEndpoint_obj_at_tcb' setBoundNotification_tcbContext + setNotification_tcb crunch_wps seThreadState_tcbContext + simp: crunch_simps unless_def) +declare comp_apply [simp] + + +crunch ksArch[wp]: asUser "\s. P (ksArchState s)" + (wp: crunch_wps) + +definition + tcbs_of :: "kernel_state => word32 => tcb option" +where + "tcbs_of s = (%x. if tcb_at' x s then projectKO_opt (the (ksPSpace s x)) else None)" + +lemma obj_at_tcbs_of: + "obj_at' P t s = (EX tcb. tcbs_of s t = Some tcb & P tcb)" + apply (simp add: tcbs_of_def split: if_split) + apply (intro conjI impI) + apply (clarsimp simp: obj_at'_def projectKOs) + apply (clarsimp simp: obj_at'_weakenE[OF _ TrueI]) + done + +lemma st_tcb_at_tcbs_of: + "st_tcb_at' P t s = (EX tcb. tcbs_of s t = Some tcb & P (tcbState tcb))" + by (simp add: st_tcb_at'_def obj_at_tcbs_of) + +lemma tcbs_of_ko_at': + "\ tcbs_of s p = Some tcb \ \ ko_at' tcb p s" + by (simp add: obj_at_tcbs_of) + +lemma tcbs_of_valid_tcb': + "\ valid_objs' s; tcbs_of s p = Some tcb \ \ valid_tcb' tcb s" + by (frule tcbs_of_ko_at') + (drule (1) ko_at_valid_objs', auto simp: projectKOs valid_obj'_def) + +lemma acc_CNodeCap_repr: + "isCNodeCap cap + \ cap = CNodeCap (capCNodePtr cap) (capCNodeBits cap) + (capCNodeGuard cap) (capCNodeGuardSize cap)" + by (clarsimp simp: isCap_simps) + +lemma valid_cnode_cap_cte_at': + "\ s \' c; isCNodeCap c; ptr = capCNodePtr c; v < 2 ^ capCNodeBits c \ + \ cte_at' (ptr + v * 2^cteSizeBits) s" + apply (drule less_mask_eq) + apply (drule(1) valid_cap_cte_at'[where addr=v]) + apply (simp add: mult.commute mult.left_commute) + done + +lemmas valid_cnode_cap_cte_at'' + = valid_cnode_cap_cte_at'[simplified objBits_defs, simplified] + +declare of_int_sint_scast[simp] + +lemma isCNodeCap_capUntypedPtr_capCNodePtr: + "isCNodeCap c \ capUntypedPtr c = capCNodePtr c" + by (clarsimp simp: isCap_simps) + +lemma of_bl_from_bool: + "of_bl [x] = from_bool x" + by (cases x, simp_all add: from_bool_def) + +lemma dmo_clearExMonitor_setCurThread_swap: + "(do _ \ doMachineOp ARM.clearExMonitor; + setCurThread thread + od) + = (do _ \ setCurThread thread; + doMachineOp ARM.clearExMonitor od)" + apply (simp add: setCurThread_def doMachineOp_def split_def) + apply (rule oblivious_modify_swap[symmetric]) + apply (intro oblivious_bind, + simp_all add: select_f_oblivious) + done + +lemma pd_at_asid_inj': + "pd_at_asid' pd asid s \ pd_at_asid' pd' asid s \ pd' = pd" + by (clarsimp simp: pd_at_asid'_def obj_at'_def) + +lemma bind_case_sum_rethrow: + "rethrowFailure fl f >>= case_sum e g + = f >>= case_sum (e \ fl) g" + apply (simp add: rethrowFailure_def handleE'_def + bind_assoc) + apply (rule bind_cong[OF refl]) + apply (simp add: throwError_bind split: sum.split) + done + +declare empty_fail_assertE[iff] + +declare empty_fail_resolveAddressBits[iff] + +lemma lookupExtraCaps_null: + "msgExtraCaps info = 0 \ + lookupExtraCaps thread buffer info = returnOk []" + by (clarsimp simp: lookupExtraCaps_def + getExtraCPtrs_def liftE_bindE + upto_enum_step_def mapM_Nil + split: Types_H.message_info.split option.split) + +lemma isRecvEP_endpoint_case: + "isRecvEP ep \ case_endpoint f g h ep = f (epQueue ep)" + by (clarsimp simp: isRecvEP_def split: endpoint.split_asm) + +lemma unifyFailure_catch_If: + "catch (unifyFailure f >>=E g) h + = f >>= (\rv. if isRight rv then catch (g (theRight rv)) h else h ())" + apply (simp add: unifyFailure_def rethrowFailure_def + handleE'_def catch_def bind_assoc + bind_bindE_assoc cong: if_cong) + apply (rule bind_cong[OF refl]) + apply (simp add: throwError_bind isRight_def return_returnOk + split: sum.split) + done + +lemma st_tcb_at_not_in_ep_queue: + "\ st_tcb_at' P t s; ko_at' ep epptr s; sym_refs (state_refs_of' s); + ep \ IdleEP; \ts. P ts \ tcb_st_refs_of' ts = {} \ + \ t \ set (epQueue ep)" + apply clarsimp + apply (drule(1) sym_refs_ko_atD') + apply (cases ep, simp_all add: st_tcb_at_refs_of_rev') + apply (fastforce simp: st_tcb_at'_def obj_at'_def projectKOs)+ + done + +lemma st_tcb_at_not_in_ntfn_queue: + "\ st_tcb_at' P t s; ko_at' ntfn ntfnptr s; sym_refs (state_refs_of' s); ntfnObj ntfn = WaitingNtfn xs; + \ts. P ts \ (ntfnptr, TCBSignal) \ tcb_st_refs_of' ts \ + \ t \ set xs" + apply (drule(1) sym_refs_ko_atD') + apply (clarsimp simp: st_tcb_at_refs_of_rev') + apply (drule_tac x="(t, NTFNSignal)" in bspec, simp) + apply (fastforce simp: st_tcb_at'_def obj_at'_def projectKOs ko_wp_at'_def tcb_bound_refs'_def) + done + +lemma sym_refs_upd_sD: + "\ sym_refs ((state_refs_of' s) (p := S)); valid_pspace' s; + ko_at' ko p s; refs_of' (injectKO koEx) = S; + objBits koEx = objBits ko \ + \ \s'. sym_refs (state_refs_of' s') + \ (\p' (ko' :: endpoint). ko_at' ko' p' s \ injectKO ko' \ injectKO ko + \ ko_at' ko' p' s') + \ (\p' (ko' :: Structures_H.notification). ko_at' ko' p' s \ injectKO ko' \ injectKO ko + \ ko_at' ko' p' s') + \ (ko_at' koEx p s')" + apply (rule exI, rule conjI) + apply (rule state_refs_of'_upd[where ko'="injectKO koEx" and ptr=p and s=s, + THEN ssubst[where P=sym_refs], rotated 2]) + apply simp+ + apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs) + apply (clarsimp simp: project_inject objBits_def) + apply (clarsimp simp: obj_at'_def ps_clear_upd projectKOs + split: if_split) + apply (clarsimp simp: project_inject objBits_def) + apply auto + done + +lemma sym_refs_upd_tcb_sD: + "\ sym_refs ((state_refs_of' s) (p := {r \ state_refs_of' s p. snd r = TCBBound})); valid_pspace' s; + ko_at' (tcb :: tcb) p s \ + \ \s'. sym_refs (state_refs_of' s') + \ (\p' (ko' :: endpoint). + ko_at' ko' p' s \ ko_at' ko' p' s') + \ (\p' (ko' :: Structures_H.notification). + ko_at' ko' p' s \ ko_at' ko' p' s') + \ (st_tcb_at' ((=) Running) p s')" + apply (drule(2) sym_refs_upd_sD[where koEx="makeObject\tcbState := Running, tcbBoundNotification := tcbBoundNotification tcb\"]) + apply (clarsimp dest!: ko_at_state_refs_ofD') + apply (simp add: objBits_simps) + apply (erule exEI) + apply clarsimp + apply (auto simp: st_tcb_at'_def elim!: obj_at'_weakenE) + done + +lemma updateCap_cte_wp_at_cteMDBNode: + "\cte_wp_at' (\cte. P (cteMDBNode cte)) p\ + updateCap ptr cap + \\rv. cte_wp_at' (\cte. P (cteMDBNode cte)) p\" + apply (wp updateCap_cte_wp_at_cases) + apply (simp add: o_def) + done + +lemma ctes_of_Some_cte_wp_at: + "ctes_of s p = Some cte \ cte_wp_at' P p s = P cte" + by (clarsimp simp: cte_wp_at_ctes_of) + +lemma user_getreg_wp: + "\\s. tcb_at' t s \ (\rv. obj_at' (\tcb. (atcbContextGet o tcbArch) tcb r = rv) t s \ Q rv s)\ + asUser t (getRegister r) \Q\" + apply (rule_tac Q="\rv s. \rv'. rv' = rv \ Q rv' s" in hoare_post_imp) + apply simp + apply (rule hoare_pre, wp hoare_vcg_ex_lift user_getreg_rv) + apply (clarsimp simp: obj_at'_def) + done + +lemma setUntypedCapAsFull_replyCap[simp]: + "setUntypedCapAsFull cap (ReplyCap curThread False cg) slot = return ()" + by (clarsimp simp:setUntypedCapAsFull_def isCap_simps) + +lemma option_case_liftM_getNotification_wp: + "\\s. \rv. (case x of None \ rv = v | Some p \ obj_at' (\ntfn. f ntfn = rv) p s) + \ Q rv s\ case x of None \ return v | Some ptr \ liftM f $ getNotification ptr \ Q \" + apply (rule hoare_pre, (wpc; wp getNotification_wp)) + apply (auto simp: obj_at'_def) + done + +lemma threadSet_st_tcb_at_state: + "\\s. tcb_at' t s \ (if p = t + then obj_at' (\tcb. P (tcbState (f tcb))) t s + else st_tcb_at' P p s)\ + threadSet f t \\_. st_tcb_at' P p\" + apply (rule hoare_chain) + apply (rule threadSet_obj_at'_really_strongest) + prefer 2 + apply (simp add: st_tcb_at'_def) + apply (clarsimp split: if_splits simp: st_tcb_at'_def o_def) + done + +lemma recv_ep_queued_st_tcb_at': + "\ ko_at' (Structures_H.endpoint.RecvEP ts) epptr s ; + t \ set ts; + sym_refs (state_refs_of' s) \ + \ st_tcb_at' isBlockedOnReceive t s" + apply (drule obj_at_ko_at') + apply clarsimp + apply (drule (1) sym_refs_ko_atD') + apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def refs_of_rev') + apply (erule_tac x=t in ballE; clarsimp?) + apply (erule ko_wp_at'_weakenE) + apply (clarsimp simp: isBlockedOnReceive_def projectKOs) + done + +lemma valid_ep_typ_at_lift': + "\ \p. \typ_at' TCBT p\ f \\rv. typ_at' TCBT p\ \ + \ \\s. valid_ep' ep s\ f \\rv s. valid_ep' ep s\" + apply (cases ep, simp_all add: valid_ep'_def) + apply (wp hoare_vcg_const_Ball_lift typ_at_lifts | assumption)+ + done + +lemma threadSet_tcbState_valid_objs: + "\valid_tcb_state' st and valid_objs'\ + threadSet (tcbState_update (\_. st)) t + \\rv. valid_objs'\" + apply (wp threadSet_valid_objs') + apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def) + done + +lemmas monadic_rewrite_symb_exec_l' = monadic_rewrite_symb_exec_l'_preserve_names + +lemma possibleSwitchTo_rewrite: + "monadic_rewrite True True + (\s. obj_at' (\tcb. tcbPriority tcb = destPrio \ tcbDomain tcb = destDom) t s + \ ksSchedulerAction s = ResumeCurrentThread + \ ksCurThread s = thread + \ ksCurDomain s = curDom + \ destDom = curDom) + (possibleSwitchTo t) (setSchedulerAction (SwitchToThread t))" + supply if_split[split del] + apply (simp add: possibleSwitchTo_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_symb_exec_l'[OF threadGet_inv empty_fail_threadGet, + where P'=\], simp) + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac P="targetDom = curDom" in monadic_rewrite_gen_asm) + apply simp + apply (rule_tac P="action = ResumeCurrentThread" in monadic_rewrite_gen_asm) + apply simp + apply (rule monadic_rewrite_refl) + apply (wp threadGet_wp cd_wp |simp add: bitmap_fun_defs)+ + apply (simp add: getCurThread_def curDomain_def gets_bind_ign getSchedulerAction_def) + apply (rule monadic_rewrite_refl) + apply clarsimp + apply (auto simp: obj_at'_def) + done + +lemma scheduleSwitchThreadFastfail_False_wp: + "\\s. ct \ it \ cprio \ tprio \ + scheduleSwitchThreadFastfail ct it cprio tprio + \\rv s. \ rv \" + unfolding scheduleSwitchThreadFastfail_def + by (wp threadGet_wp) + (auto dest!: obj_at_ko_at' simp: le_def obj_at'_def) + +lemma lookupBitmapPriority_lift: + assumes prqL1: "\P. \\s. P (ksReadyQueuesL1Bitmap s)\ f \\_ s. P (ksReadyQueuesL1Bitmap s)\" + and prqL2: "\P. \\s. P (ksReadyQueuesL2Bitmap s)\ f \\_ s. P (ksReadyQueuesL2Bitmap s)\" + shows "\\s. P (lookupBitmapPriority d s) \ f \\_ s. P (lookupBitmapPriority d s) \" + unfolding lookupBitmapPriority_def + apply (rule hoare_pre) + apply (wps prqL1 prqL2) + apply wpsimp+ + done + +(* slow path additionally requires current thread not idle *) +definition + "fastpathBestSwitchCandidate t \ \s. + ksReadyQueuesL1Bitmap s (ksCurDomain s) = 0 + \ (\tprio. obj_at' (\tcb. tcbPriority tcb = tprio) t s + \ (obj_at' (\tcb. tcbPriority tcb \ tprio) (ksCurThread s) s + \ lookupBitmapPriority (ksCurDomain s) s \ tprio))" + +lemma fastpathBestSwitchCandidateI: + "\ ksReadyQueuesL1Bitmap s (ksCurDomain s) = 0 + \ tcbPriority ctcb \ tcbPriority ttcb + \ lookupBitmapPriority (ksCurDomain s) s \ tcbPriority ttcb; + ko_at' ttcb t s; ko_at' ctcb (ksCurThread s) s\ + \ fastpathBestSwitchCandidate t s" + unfolding fastpathBestSwitchCandidate_def + by normalise_obj_at' + +lemma fastpathBestSwitchCandidate_lift: + assumes ct[wp]: "\P. \\s. P (ksCurThread s) \ f \ \_ s. P (ksCurThread s) \" + assumes cd[wp]: "\P. \\s. P (ksCurDomain s) \ f \ \_ s. P (ksCurDomain s) \" + assumes l1[wp]: "\P. \\s. P (ksReadyQueuesL1Bitmap s) \ f \ \_ s. P (ksReadyQueuesL1Bitmap s) \" + assumes l2[wp]: "\P. \\s. P (ksReadyQueuesL2Bitmap s) \ f \ \_ s. P (ksReadyQueuesL2Bitmap s) \" + assumes p[wp]: "\P t. \ obj_at' (\tcb. P (tcbPriority tcb)) t \ f \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t \" + shows "\ tcb_at' t and fastpathBestSwitchCandidate t \ f \\rv. fastpathBestSwitchCandidate t \" + unfolding fastpathBestSwitchCandidate_def lookupBitmapPriority_def l1IndexToPrio_def + apply (rule hoare_pre) + apply (rule hoare_lift_Pf2[where f=ksCurDomain]) + apply (wp hoare_vcg_disj_lift hoare_vcg_all_lift) + apply (rule hoare_lift_Pf2[where f=ksCurThread]) + apply (rule hoare_lift_Pf2[where f=ksReadyQueuesL1Bitmap]) + apply (rule hoare_lift_Pf2[where f=ksReadyQueuesL2Bitmap]) + apply (wp hoare_vcg_imp_lift') + apply (strengthen not_obj_at'_strengthen) + apply (wpsimp simp: comp_def wp: l1 l2 hoare_vcg_disj_lift)+ + apply (drule (1) tcb_at_not_obj_at_elim'[rotated]) + apply (rename_tac tprio, erule_tac x=tprio in allE) + apply clarsimp + apply (drule (1) tcb_at_not_obj_at_elim'[rotated]) + apply (clarsimp simp: obj_at'_def) + done + +lemma fastpathBestSwitchCandidate_ksSchedulerAction_simp[simp]: + "fastpathBestSwitchCandidate t (s\ksSchedulerAction := a\) + = fastpathBestSwitchCandidate t s" + unfolding fastpathBestSwitchCandidate_def lookupBitmapPriority_def + by simp + +lemma schedule_rewrite_ct_not_runnable': + "monadic_rewrite True True + (\s. ksSchedulerAction s = SwitchToThread t \ ct_in_state' (Not \ runnable') s + \ (ksCurThread s \ ksIdleThread s) + \ fastpathBestSwitchCandidate t s) + (schedule) + (do setSchedulerAction ResumeCurrentThread; switchToThread t od)" + supply subst_all [simp del] + apply (simp add: schedule_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac P="action = SwitchToThread t" in monadic_rewrite_gen_asm, simp) + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac P="\ wasRunnable \ action = SwitchToThread t" + in monadic_rewrite_gen_asm,simp) + apply (rule monadic_rewrite_bind_tail, rename_tac idleThread) + apply (rule monadic_rewrite_bind_tail, rename_tac targetPrio) + apply (rule monadic_rewrite_bind_tail, rename_tac curPrio) + apply (rule monadic_rewrite_bind_tail, rename_tac fastfail) + apply (rule monadic_rewrite_bind_tail, rename_tac curDom) + apply (rule monadic_rewrite_bind_tail, rename_tac highest) + apply (rule_tac P="\ (fastfail \ \ highest)" in monadic_rewrite_gen_asm, simp only:) + apply simp + apply (rule monadic_rewrite_refl) + apply (wpsimp wp: hoare_vcg_imp_lift) + apply (simp add: isHighestPrio_def') + apply wp+ + apply (wp hoare_vcg_disj_lift) + apply (wp scheduleSwitchThreadFastfail_False_wp) + apply (wp hoare_vcg_disj_lift threadGet_wp'' | simp add: comp_def)+ + (* remove no-ops, somewhat by magic *) + apply (rule monadic_rewrite_symb_exec_l'_TT, solves wp, + wpsimp wp: empty_fail_isRunnable simp: isHighestPrio_def')+ + apply (simp add: setSchedulerAction_def) + apply (subst oblivious_modify_swap[symmetric], rule oblivious_switchToThread_schact) + apply (rule monadic_rewrite_refl) + apply wp+ + apply (clarsimp simp: ct_in_state'_def) + apply (strengthen not_pred_tcb_at'_strengthen, simp) + supply word_neq_0_conv[simp del] + apply normalise_obj_at' + apply (simp add: fastpathBestSwitchCandidate_def) + apply (erule_tac x="tcbPriority ko" in allE) + apply (erule impE, normalise_obj_at'+) + done + +crunch tcb2[wp]: "Arch.switchToThread" "tcb_at' t" + (ignore: ARM.clearExMonitor) + +lemma resolveAddressBits_points_somewhere: + "\\s. \slot. Q slot s\ resolveAddressBits cp cptr bits \Q\,-" + apply (rule_tac Q'="\rv s. \rv. Q rv s" in hoare_post_imp_R) + apply wp + apply clarsimp + done + +lemma foldr_copy_register_tsrs: + "foldr (\r . copy_register_tsrs x y r r (\x. x)) rs s + = (s (y := TCBStateRegs (tsrState (s y)) + (\r. if r \ set rs then tsrContext (s x) r + else tsrContext (s y) r)))" + apply (induct rs) + apply simp + apply (simp add: copy_register_tsrs_def fun_eq_iff + split: if_split) + done + +lemmas cteInsert_obj_at'_not_queued = cteInsert_obj_at'_queued[of "\a. \ a"] + +lemma monadic_rewrite_exists_v: + "[| !! v. monadic_rewrite E F (Q v) f g |] + ==> monadic_rewrite E F (%x. (EX v. P v x) & (ALL v. P v x --> Q v x)) f g" + apply (rule monadic_rewrite_name_pre) + apply clarsimp + apply (erule_tac x=v in meta_allE) + apply (erule monadic_rewrite_imp) + apply clarsimp + done + +lemma monadic_rewrite_threadGet: + "monadic_rewrite E F (obj_at' (\tcb. f tcb = v) t) + (threadGet f t) (return v)" + unfolding getThreadState_def + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans[rotated]) + apply (rule monadic_rewrite_gets_known) + apply (unfold threadGet_def liftM_def fun_app_def) + apply (rule monadic_rewrite_symb_exec_l' | wp | rule empty_fail_getObject getObject_inv)+ + apply (clarsimp; rule no_fail_getObject_tcb) + apply (simp only: exec_gets) + apply (rule_tac P = "(\s. (f x)=v) and tcb_at' t" in monadic_rewrite_refl3) + apply (simp add:) + apply (wp OMG_getObject_tcb | wpc)+ + apply (auto intro: obj_tcb_at') + done + +lemma monadic_rewrite_getThreadState: + "monadic_rewrite E F (obj_at' (\tcb. tcbState tcb = v) t) + (getThreadState t) (return v)" + unfolding getThreadState_def + by (rule monadic_rewrite_threadGet) + +lemma setCTE_obj_at'_tcbIPCBuffer: + "\obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\ setCTE p v \\rv. obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\" + unfolding setCTE_def + by (rule setObject_cte_obj_at_tcb', simp+) + +context +notes if_cong[cong] +begin +crunches cteInsert, asUser + for obj_at'_tcbIPCBuffer[wp]: "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" + (wp: setCTE_obj_at'_queued crunch_wps threadSet_obj_at'_really_strongest) +end + +crunch ksReadyQueues_inv[wp]: cteInsert "\s. P (ksReadyQueues s)" + (wp: hoare_drop_imps) + +crunches cteInsert, threadSet, asUser, emptySlot + for ksReadyQueuesL1Bitmap_inv[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and ksReadyQueuesL2Bitmap_inv[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + (wp: hoare_drop_imps) + +crunch ksReadyQueuesL1Bitmap_inv[wp]: setEndpoint "\s. P (ksReadyQueuesL1Bitmap s)" + (wp: setObject_ksPSpace_only updateObject_default_inv) +crunch ksReadyQueuesL2Bitmap_inv[wp]: setEndpoint "\s. P (ksReadyQueuesL2Bitmap s)" + (wp: setObject_ksPSpace_only updateObject_default_inv) + +lemma setThreadState_runnable_bitmap_inv: + "runnable' ts \ + \ \s. P (ksReadyQueuesL1Bitmap s) \ setThreadState ts t \\rv s. P (ksReadyQueuesL1Bitmap s) \" + "runnable' ts \ + \ \s. Q (ksReadyQueuesL2Bitmap s) \ setThreadState ts t \\rv s. Q (ksReadyQueuesL2Bitmap s) \" + by (simp_all add: setThreadState_runnable_simp, wp+) + +lemma fastpath_callKernel_SysCall_corres: + "monadic_rewrite True False + (invs' and ct_in_state' ((=) Running) + and (\s. ksSchedulerAction s = ResumeCurrentThread) + and (\s. ksDomainTime s \ 0)) + (callKernel (SyscallEvent SysCall)) (fastpaths SysCall)" + supply if_split[split del] if_cong[cong] + apply (rule monadic_rewrite_introduce_alternative) + apply (simp add: callKernel_def) + apply (rule monadic_rewrite_imp) + apply (simp add: handleEvent_def handleCall_def + handleInvocation_def liftE_bindE_handle + bind_assoc getMessageInfo_def) + apply (simp add: catch_liftE_bindE unlessE_throw_catch_If + unifyFailure_catch_If catch_liftE + getMessageInfo_def alternative_bind + fastpaths_def + cong: if_cong) + apply (rule monadic_rewrite_rdonly_bind_l, wp) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_rdonly_bind_l, wp) + apply (rule monadic_rewrite_bind_tail) + apply (rename_tac msgInfo) + apply (rule monadic_rewrite_rdonly_bind_l, wp) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_symb_exec_r + [OF threadGet_inv no_fail_threadGet]) + apply (rename_tac thread msgInfo ptr tcbFault) + apply (rule monadic_rewrite_alternative_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (simp add: split_def Syscall_H.syscall_def + liftE_bindE_handle bind_assoc + capFaultOnFailure_def) + apply (simp only: bindE_bind_linearise[where f="rethrowFailure fn f'" for fn f'] + bind_case_sum_rethrow) + apply (simp add: lookupCapAndSlot_def lookupSlotForThread_def + lookupSlotForThread_def bindE_assoc + liftE_bind_return_bindE_returnOk split_def + getThreadCSpaceRoot_def locateSlot_conv + returnOk_liftE[symmetric] const_def + getSlotCap_def) + apply (simp only: liftE_bindE_assoc) + apply (rule monadic_rewrite_rdonly_bind_l, wp) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_rdonly_bind_l) + apply (wp | simp)+ + apply (rule_tac fn="case_sum Inl (Inr \ fst)" in monadic_rewrite_split_fn) + apply (simp add: liftME_liftM[symmetric] liftME_def bindE_assoc) + apply (rule monadic_rewrite_refl) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (simp add: isRight_right_map isRight_case_sum) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_rdonly_bind_l[OF lookupIPC_inv]) + apply (rule monadic_rewrite_symb_exec_l[OF lookupIPC_inv empty_fail_lookupIPCBuffer]) + apply (simp add: lookupExtraCaps_null returnOk_bind liftE_bindE_handle + bind_assoc liftE_bindE_assoc + decodeInvocation_def Let_def from_bool_0 + performInvocation_def liftE_handle + liftE_bind) + apply (rule monadic_rewrite_symb_exec_r [OF getEndpoint_inv no_fail_getEndpoint]) + apply (rename_tac "send_ep") + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (simp add: getThreadVSpaceRoot_def locateSlot_conv) + apply (rule monadic_rewrite_symb_exec_r [OF getCTE_inv no_fail_getCTE]) + apply (rename_tac "pdCapCTE") + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_symb_exec_r[OF curDomain_inv], + simp only: curDomain_def, rule non_fail_gets) + apply (rename_tac "curDom") + apply (rule monadic_rewrite_symb_exec_r [OF threadGet_inv no_fail_threadGet])+ + apply (rename_tac curPrio destPrio) + apply (simp add: isHighestPrio_def') + apply (rule monadic_rewrite_symb_exec_r [OF gets_inv non_fail_gets]) + apply (rename_tac highest) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_symb_exec_r [OF gets_inv non_fail_gets]) + apply (rename_tac asidMap) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + + apply (rule monadic_rewrite_symb_exec_r[OF threadGet_inv no_fail_threadGet]) + apply (rename_tac "destDom") + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_trans, + rule monadic_rewrite_pick_alternative_1) + apply (rule monadic_rewrite_symb_exec_l[OF get_mrs_inv' empty_fail_getMRs]) + (* now committed to fastpath *) + apply (rule monadic_rewrite_trans) + apply (rule_tac F=True and E=True in monadic_rewrite_weaken) + apply simp + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac x=thread in monadic_rewrite_symb_exec, + (wp empty_fail_getCurThread)+) + apply (simp add: sendIPC_def bind_assoc) + apply (rule_tac x=send_ep in monadic_rewrite_symb_exec, + (wp empty_fail_getEndpoint getEndpoint_obj_at')+) + apply (rule_tac P="epQueue send_ep \ []" in monadic_rewrite_gen_asm) + apply (simp add: isRecvEP_endpoint_case list_case_helper bind_assoc) + apply (rule monadic_rewrite_bind_tail) + apply (elim conjE) + apply (rule monadic_rewrite_bind_tail, rename_tac dest_st) + apply (rule_tac P="\gr. dest_st = BlockedOnReceive (capEPPtr (fst (theRight rv))) gr" + in monadic_rewrite_gen_asm) + apply (rule monadic_rewrite_symb_exec2, (wp | simp)+) + apply (rule monadic_rewrite_bind) + apply clarsimp + apply (rule_tac msgInfo=msgInfo in doIPCTransfer_simple_rewrite) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_bind) + apply (rule_tac destPrio=destPrio + and curDom=curDom and destDom=destDom and thread=thread + in possibleSwitchTo_rewrite) + apply (rule monadic_rewrite_bind) + apply (rule monadic_rewrite_trans) + apply (rule setupCallerCap_rewrite) + apply (rule monadic_rewrite_bind_head) + apply (rule setThreadState_rewrite_simple, simp) + apply (rule monadic_rewrite_trans) + apply (rule_tac x=BlockedOnReply in monadic_rewrite_symb_exec, + (wp empty_fail_getThreadState)+) + apply simp + apply (rule monadic_rewrite_refl) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_head) + apply (rule_tac t="hd (epQueue send_ep)" + in schedule_rewrite_ct_not_runnable') + apply (simp add: bind_assoc) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_bind) + apply (rule switchToThread_rewrite) + apply (rule monadic_rewrite_bind) + apply (rule activateThread_simple_rewrite) + apply (rule monadic_rewrite_refl) + apply wp + apply (wp setCurThread_ct_in_state) + apply (simp only: st_tcb_at'_def[symmetric]) + apply (wp, clarsimp simp: cur_tcb'_def ct_in_state'_def) + apply (simp add: getThreadCallerSlot_def getThreadReplySlot_def + locateSlot_conv ct_in_state'_def cur_tcb'_def) + + apply ((wp assert_inv threadSet_pred_tcb_at_state + cteInsert_obj_at'_not_queued + | wps)+)[1] + + apply (wp fastpathBestSwitchCandidate_lift[where f="cteInsert c w w'" for c w w']) + apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] + apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] + apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] + apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] + apply (wp fastpathBestSwitchCandidate_lift[where f="threadSet f t" for f t]) + apply simp + apply ((wp assert_inv threadSet_pred_tcb_at_state + cteInsert_obj_at'_not_queued + | wps)+)[1] + apply (simp add: setSchedulerAction_def) + apply wp[1] + apply (simp cong: if_cong HOL.conj_cong add: if_bool_simps) + apply (simp_all only:)[5] + apply ((wp setThreadState_oa_queued[of _ "\a _ _. \ a"] + setThreadState_obj_at_unchanged + asUser_obj_at_unchanged mapM_x_wp' + sts_st_tcb_at'_cases + setThreadState_no_sch_change + setEndpoint_obj_at_tcb' + fastpathBestSwitchCandidate_lift[where f="setThreadState f t" for f t] + setThreadState_oa_queued + fastpathBestSwitchCandidate_lift[where f="asUser t f" for f t] + fastpathBestSwitchCandidate_lift[where f="setEndpoint a b" for a b] + lookupBitmapPriority_lift + setThreadState_runnable_bitmap_inv + | simp add: setMessageInfo_def + | wp (once) hoare_vcg_disj_lift)+) + + apply (simp add: setThreadState_runnable_simp + getThreadCallerSlot_def getThreadReplySlot_def + locateSlot_conv bind_assoc) + apply (rule_tac P="\v. obj_at' (%tcb. tcbIPCBuffer tcb = v) (hd (epQueue send_ep))" + in monadic_rewrite_exists_v) + apply (rename_tac ipcBuffer) + apply (rule_tac P="\v. obj_at' (\tcb. tcbState tcb = v) (hd (epQueue send_ep))" + in monadic_rewrite_exists_v) + apply (rename_tac destState) + + apply (simp add: switchToThread_def bind_assoc) + (* retrieving state or thread registers is not thread_action_isolatable, + translate into return with suitable precondition *) + apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) + apply (rule_tac v=destState in monadic_rewrite_getThreadState + | rule monadic_rewrite_bind monadic_rewrite_refl)+ + apply (wp mapM_x_wp' getObject_inv | wpc | simp | wp (once) hoare_drop_imps)+ + apply (rule_tac v=destState in monadic_rewrite_getThreadState + | rule monadic_rewrite_bind monadic_rewrite_refl)+ + apply (wp mapM_x_wp' getObject_inv | wpc | simp | wp (once) hoare_drop_imps)+ + + apply (rule_tac P="inj (case_bool thread (hd (epQueue send_ep)))" + in monadic_rewrite_gen_asm) + apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) + apply (rule monadic_rewrite_weaken[where F=False and E=True], simp) + apply (rule isolate_thread_actions_rewrite_bind + fastpath_isolate_rewrites fastpath_isolatables + bool.simps setRegister_simple + setVMRoot_isolatable[THEN thread_actions_isolatableD] setVMRoot_isolatable + doMachineOp_isolatable[THEN thread_actions_isolatableD] doMachineOp_isolatable + kernelExitAssertions_isolatable[THEN thread_actions_isolatableD] + kernelExitAssertions_isolatable + zipWithM_setRegister_simple + thread_actions_isolatable_bind + | assumption + | wp assert_inv)+ + apply (rule_tac P="\s. ksSchedulerAction s = ResumeCurrentThread + \ tcb_at' thread s" + and F=True and E=False in monadic_rewrite_weaken) + apply simp + apply (rule monadic_rewrite_isolate_final) + apply (simp add: isRight_case_sum cong: list.case_cong) + apply (clarsimp simp: fun_eq_iff if_flip + cong: if_cong) + apply (drule obj_at_ko_at', clarsimp) + apply (frule get_tcb_state_regs_ko_at') + apply (clarsimp simp: zip_map2 zip_same_conv_map foldl_map + foldl_fun_upd + foldr_copy_register_tsrs + isRight_case_sum + cong: if_cong) + apply (simp add: upto_enum_def fromEnum_def + enum_register toEnum_def + msgRegisters_unfold + cong: if_cong) + apply (clarsimp split: if_split) + apply (rule ext) + apply (simp add: badgeRegister_def msgInfoRegister_def + ARM.badgeRegister_def + ARM.msgInfoRegister_def + split: if_split) + apply simp + apply (wp | simp cong: if_cong bool.case_cong + | rule getCTE_wp' gts_wp' threadGet_wp + getEndpoint_wp)+ + apply (rule validE_cases_valid) + apply (simp add: isRight_def getSlotCap_def) + apply (wp getCTE_wp') + apply (rule resolveAddressBits_points_somewhere) + apply (simp cong: if_cong bool.case_cong) + apply wp + apply simp + apply (wp user_getreg_wp threadGet_wp)+ + + apply clarsimp + apply (subgoal_tac "ksCurThread s \ ksIdleThread s") + prefer 2 + apply (fastforce simp: ct_in_state'_def dest: ct_running_not_idle' elim: pred_tcb'_weakenE) + + apply (clarsimp simp: ct_in_state'_def pred_tcb_at') + apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp+) + apply (clarsimp simp: isCap_simps valid_cap'_def maskCapRights_def) + apply (frule ko_at_valid_ep', clarsimp) + apply (frule sym_refs_ko_atD'[where 'a=endpoint], clarsimp) + apply (clarsimp simp: valid_ep'_def isRecvEP_endpoint_case neq_Nil_conv + tcbVTableSlot_def cte_level_bits_def + cte_at_tcb_at_16' length_msgRegisters + size_msgRegisters_def order_less_imp_le + ep_q_refs_of'_def st_tcb_at_refs_of_rev' + cong: if_cong) + apply (rename_tac blockedThread ys tcba tcbb) + apply (frule invs_mdb') + apply (thin_tac "Ball S P" for S P)+ + supply imp_disjL[simp del] + apply (subst imp_disjL[symmetric]) + + (* clean up broken up disj implication and excessive references to same tcbs *) + apply normalise_obj_at' + apply (clarsimp simp: invs'_def valid_state'_def) + apply (fold imp_disjL, intro allI impI) + + apply (subgoal_tac "ksCurThread s \ blockedThread") + prefer 2 + apply normalise_obj_at' + apply clarsimp + apply (frule_tac t="blockedThread" in valid_queues_not_runnable_not_queued, assumption) + subgoal by (fastforce simp: st_tcb_at'_def elim: obj_at'_weakenE) + apply (subgoal_tac "fastpathBestSwitchCandidate blockedThread s") + prefer 2 + apply (rule_tac ttcb=tcbb and ctcb=tcb in fastpathBestSwitchCandidateI) + apply (solves \simp only: disj_ac\) + apply simp+ + apply (clarsimp simp: st_tcb_at'_def obj_at'_def objBits_simps projectKOs + valid_mdb'_def valid_mdb_ctes_def inj_case_bool + split: bool.split)+ + done + +lemma capability_case_Null_ReplyCap: + "(case cap of NullCap \ f | ReplyCap t b cg \ g t b cg | _ \ h) + = (if isReplyCap cap then g (capTCBPtr cap) (capReplyMaster cap) (capReplyCanGrant cap) + else if isNullCap cap then f else h)" + by (simp add: isCap_simps split: capability.split split del: if_split) + +lemma injection_handler_catch: + "catch (injection_handler f x) y + = catch x (y o f)" + apply (simp add: injection_handler_def catch_def handleE'_def + bind_assoc) + apply (rule bind_cong[OF refl]) + apply (simp add: throwError_bind split: sum.split) + done + +lemma doReplyTransfer_simple: + "monadic_rewrite True False + (obj_at' (\tcb. tcbFault tcb = None) receiver) + (doReplyTransfer sender receiver slot grant) + (do state \ getThreadState receiver; + assert (isReply state); + cte \ getCTE slot; + mdbnode \ return $ cteMDBNode cte; + assert (mdbPrev mdbnode \ 0 \ mdbNext mdbnode = 0); + parentCTE \ getCTE (mdbPrev mdbnode); + assert (isReplyCap (cteCap parentCTE) \ capReplyMaster (cteCap parentCTE)); + doIPCTransfer sender Nothing 0 grant receiver; + cteDeleteOne slot; + setThreadState Running receiver; + possibleSwitchTo receiver + od)" + apply (simp add: doReplyTransfer_def liftM_def nullPointer_def getSlotCap_def) + apply (rule monadic_rewrite_bind_tail)+ + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_threadGet)+) + apply (rule_tac P="rv = None" in monadic_rewrite_gen_asm, simp) + apply (rule monadic_rewrite_refl) + apply (wp threadGet_const gts_wp' getCTE_wp')+ + apply (simp add: o_def) + done + +lemma monadic_rewrite_if_known: + "monadic_rewrite F E ((\s. C = X) and \) (if C then f else g) (if X then f else g)" + apply (rule monadic_rewrite_gen_asm) + apply (simp split del: if_split) + apply (rule monadic_rewrite_refl) + done + +lemma receiveIPC_simple_rewrite: + "monadic_rewrite True False + ((\_. isEndpointCap ep_cap \ \ isSendEP ep) and (ko_at' ep (capEPPtr ep_cap) and + (\s. \ntfnptr. bound_tcb_at' ((=) (Some ntfnptr)) thread s \ obj_at' (Not \ isActive) ntfnptr s))) + (receiveIPC thread ep_cap True) + (do + setThreadState (BlockedOnReceive (capEPPtr ep_cap) (capEPCanGrant ep_cap)) thread; + setEndpoint (capEPPtr ep_cap) (RecvEP (case ep of RecvEP q \ (q @ [thread]) | _ \ [thread])) + od)" + apply (rule monadic_rewrite_gen_asm) + apply (simp add: receiveIPC_def) + apply (rule monadic_rewrite_imp) + apply (rule_tac rv=ep in monadic_rewrite_symb_exec_l_known, + (wp empty_fail_getEndpoint)+) + apply (rule monadic_rewrite_symb_exec_l, (wp | simp add: getBoundNotification_def)+) + apply (rule monadic_rewrite_symb_exec_l) + apply (rule hoare_pre, wpc, wp+, simp) + apply (simp split: option.split) + apply (rule monadic_rewrite_trans, rule monadic_rewrite_if_known[where X=False], simp) + apply (rule monadic_rewrite_refl3[where P=\]) + apply (cases ep, simp_all add: isSendEP_def)[1] + apply (wp getNotification_wp gbn_wp' getEndpoint_wp | wpc)+ + apply (clarsimp simp: obj_at'_def projectKOs pred_tcb_at'_def) + done + +lemma empty_fail_isFinalCapability: + "empty_fail (isFinalCapability cte)" + by (simp add: isFinalCapability_def Let_def split: if_split) + +lemma cteDeleteOne_replycap_rewrite: + "monadic_rewrite True False + (cte_wp_at' (\cte. isReplyCap (cteCap cte)) slot) + (cteDeleteOne slot) + (emptySlot slot NullCap)" + apply (simp add: cteDeleteOne_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rule_tac P="cteCap rv \ NullCap \ isReplyCap (cteCap rv) + \ \ isEndpointCap (cteCap rv) + \ \ isNotificationCap (cteCap rv)" + in monadic_rewrite_gen_asm) + apply (simp add: finaliseCapTrue_standin_def + capRemovable_def) + apply (rule monadic_rewrite_symb_exec_l, + (wp isFinalCapability_inv empty_fail_isFinalCapability)+) + apply (rule monadic_rewrite_refl) + apply (wp getCTE_wp')+ + apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) + done + +lemma cteDeleteOne_nullcap_rewrite: + "monadic_rewrite True False + (cte_wp_at' (\cte. cteCap cte = NullCap) slot) + (cteDeleteOne slot) + (return ())" + apply (simp add: cteDeleteOne_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rule_tac P="cteCap rv = NullCap" in monadic_rewrite_gen_asm) + apply simp + apply (rule monadic_rewrite_refl) + apply (wp getCTE_wp') + apply (clarsimp simp: cte_wp_at_ctes_of) + done + +lemma deleteCallerCap_nullcap_rewrite: + "monadic_rewrite True False + (cte_wp_at' (\cte. cteCap cte = NullCap) (thread + 2 ^ cte_level_bits * tcbCallerSlot)) + (deleteCallerCap thread) + (return ())" + apply (simp add: deleteCallerCap_def getThreadCallerSlot_def locateSlot_conv + getSlotCap_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rule monadic_rewrite_assert) + apply (rule cteDeleteOne_nullcap_rewrite) + apply (wp getCTE_wp) + apply (clarsimp simp: cte_wp_at_ctes_of) + done + +lemma emptySlot_cnode_caps: + "\\s. P (only_cnode_caps (ctes_of s)) \ cte_wp_at' (\cte. \ isCNodeCap (cteCap cte)) slot s\ + emptySlot slot NullCap + \\rv s. P (only_cnode_caps (ctes_of s))\" + apply (simp add: only_cnode_caps_def map_option_comp2 + o_assoc[symmetric] cteCaps_of_def[symmetric]) + apply (wp emptySlot_cteCaps_of) + apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of + elim!: rsubst[where P=P] intro!: ext + split: if_split) + done + +lemma asUser_obj_at_ep[wp]: + "\obj_at' P p\ asUser t m \\rv. obj_at' (P :: endpoint \ bool) p\" + apply (simp add: asUser_def split_def) + apply (wp hoare_drop_imps | simp)+ + done + +lemma setCTE_obj_at_ep[wp]: + "\obj_at' (P :: endpoint \ bool) p\ setCTE ptr cte \\rv. obj_at' P p\" + unfolding setCTE_def + apply (rule obj_at_setObject2) + apply (clarsimp simp: updateObject_cte typeError_def in_monad + split: Structures_H.kernel_object.split_asm + if_split_asm) + done + +lemma setCTE_obj_at_ntfn[wp]: + "\obj_at' (P :: Structures_H.notification \ bool) p\ setCTE ptr cte \\rv. obj_at' P p\" + unfolding setCTE_def + apply (rule obj_at_setObject2) + apply (clarsimp simp: updateObject_cte typeError_def in_monad + split: Structures_H.kernel_object.split_asm + if_split_asm) + done + +crunch obj_at_ep[wp]: emptySlot "obj_at' (P :: endpoint \ bool) p" + +crunch nosch[wp]: emptySlot "\s. P (ksSchedulerAction s)" + +crunches emptySlot, asUser + for gsCNodes[wp]: "\s. P (gsCNodes s)" + (wp: crunch_wps) + +crunch cte_wp_at'[wp]: possibleSwitchTo "cte_wp_at' P p" + (wp: hoare_drop_imps) + +crunch tcbContext[wp]: possibleSwitchTo "obj_at' (\tcb. P ( (atcbContextGet o tcbArch) tcb)) t" + (wp: crunch_wps simp_del: comp_apply) + +crunch only_cnode_caps[wp]: doFaultTransfer "\s. P (only_cnode_caps (ctes_of s))" + (wp: crunch_wps simp: crunch_simps) + +lemma tcbSchedDequeue_rewrite_not_queued: "monadic_rewrite True False (tcb_at' t and obj_at' (Not \ tcbQueued) t) (tcbSchedDequeue t) (return ())" + apply (simp add: tcbSchedDequeue_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac P="\ queued" in monadic_rewrite_gen_asm) + apply (simp add: when_def) + apply (rule monadic_rewrite_refl) + apply (wp threadGet_const) + + apply (rule monadic_rewrite_symb_exec_l) + apply wp+ + apply (rule monadic_rewrite_refl) + apply (wp) + apply (clarsimp simp: o_def obj_at'_def) + done + +lemma schedule_known_rewrite: + "monadic_rewrite True False + (\s. ksSchedulerAction s = SwitchToThread t + \ tcb_at' t s + \ obj_at' (Not \ tcbQueued) t s + \ ksCurThread s = t' + \ st_tcb_at' (Not \ runnable') t' s + \ (ksCurThread s \ ksIdleThread s) + \ fastpathBestSwitchCandidate t s) + (schedule) + (do Arch.switchToThread t; + setCurThread t; + setSchedulerAction ResumeCurrentThread od)" + supply subst_all[simp del] if_split[split del] + apply (simp add: schedule_def) + apply (simp only: Thread_H.switchToThread_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac P="action = SwitchToThread t" in monadic_rewrite_gen_asm, simp) + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac P="\ wasRunnable \ action = SwitchToThread t" in monadic_rewrite_gen_asm,simp) + apply (rule monadic_rewrite_bind_tail, rename_tac idleThread) + apply (rule monadic_rewrite_bind_tail, rename_tac targetPrio) + apply (rule monadic_rewrite_bind_tail, rename_tac curPrio) + apply (rule monadic_rewrite_bind_tail, rename_tac fastfail) + apply (rule monadic_rewrite_bind_tail, rename_tac curDom) + apply (rule monadic_rewrite_bind_tail, rename_tac highest) + apply (rule_tac P="\ (fastfail \ \ highest)" in monadic_rewrite_gen_asm, simp only:) + apply simp + apply (simp add: bind_assoc) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_bind) + apply (rule monadic_rewrite_trans) + apply (rule tcbSchedDequeue_rewrite_not_queued) + apply (rule monadic_rewrite_refl) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_refl) + apply (wpsimp wp: Arch_switchToThread_obj_at_pre)+ + apply (wp hoare_vcg_imp_lift)+ + apply (simp add: isHighestPrio_def') + apply wp+ + apply (wp hoare_vcg_disj_lift) + apply (wp scheduleSwitchThreadFastfail_False_wp) + apply wp+ + apply (wp hoare_vcg_disj_lift threadGet_wp'') + apply (wp hoare_vcg_disj_lift threadGet_wp'') + apply clarsimp + apply wp + apply (simp add: comp_def) + apply wp + apply wp + apply wp + (* remove no-ops, somewhat by magic *) + apply (rule monadic_rewrite_symb_exec_l'_TT, solves wp, + wpsimp wp: empty_fail_isRunnable simp: isHighestPrio_def')+ + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_symb_exec_l) + apply simp+ + apply (rule monadic_rewrite_refl) + apply wp+ + apply (rule monadic_rewrite_refl) + apply wp+ + apply (clarsimp simp: ct_in_state'_def) + apply (rule conjI) + apply (rule not_pred_tcb_at'_strengthen, assumption) + apply normalise_obj_at' + apply (simp add: fastpathBestSwitchCandidate_def) + apply normalise_obj_at' + done + +lemma tcb_at_cte_at_offset: + "\ tcb_at' t s; 2 ^ cte_level_bits * off \ dom tcb_cte_cases \ + \ cte_at' (t + 2 ^ cte_level_bits * off) s" + apply (clarsimp simp: obj_at'_def projectKOs objBits_simps) + apply (erule(2) cte_wp_at_tcbI') + apply fastforce + apply simp + done + +lemma emptySlot_cte_wp_at_cteCap: + "\\s. (p = p' \ P NullCap) \ (p \ p' \ cte_wp_at' (\cte. P (cteCap cte)) p s)\ + emptySlot p' irqopt + \\rv s. cte_wp_at' (\cte. P (cteCap cte)) p s\" + apply (simp add: tree_cte_cteCap_eq[unfolded o_def]) + apply (wp emptySlot_cteCaps_of) + apply (clarsimp split: if_split) + done + +lemma setEndpoint_getCTE_pivot[unfolded K_bind_def]: + "do setEndpoint p val; v <- getCTE slot; f v od + = do v <- getCTE slot; setEndpoint p val; f v od" + supply word_neq_0_conv[simp del] + apply (simp add: getCTE_assert_opt setEndpoint_def + setObject_modify_assert + fun_eq_iff bind_assoc) + apply (simp add: exec_gets assert_def assert_opt_def + exec_modify update_ep_map_to_ctes + split: if_split option.split) + done + +lemma setEndpoint_setCTE_pivot[unfolded K_bind_def]: + "do setEndpoint p val; setCTE slot cte; f od = + do setCTE slot cte; setEndpoint p val; f od" + supply if_split[split del] + apply (rule monadic_rewrite_to_eq) + apply simp + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans, + rule_tac f="ep_at' p" in monadic_rewrite_add_gets) + apply (rule monadic_rewrite_transverse, rule monadic_rewrite_add_gets, + rule monadic_rewrite_bind_tail) + apply (rename_tac epat) + apply (rule monadic_rewrite_transverse) + apply (rule monadic_rewrite_bind_tail) + apply (simp add: setEndpoint_def setObject_modify_assert bind_assoc) + apply (rule_tac rv=epat in monadic_rewrite_gets_known) + apply (wp setCTE_typ_at'[where T="koType TYPE(endpoint)", unfolded typ_at_to_obj_at'] + | simp)+ + apply (simp add: setCTE_assert_modify bind_assoc) + apply (rule monadic_rewrite_trans, rule monadic_rewrite_add_gets, + rule monadic_rewrite_bind_tail)+ + apply (rename_tac cteat tcbat) + apply (rule monadic_rewrite_trans, rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_trans) + apply (rule_tac rv=cteat in monadic_rewrite_gets_known) + apply (rule_tac rv=tcbat in monadic_rewrite_gets_known) + apply (wp setEndpoint_typ_at'[where T="koType TYPE(tcb)", unfolded typ_at_to_obj_at'] + setEndpoint_typ_at'[where T="koType TYPE(cte)", unfolded typ_at_to_obj_at'] + | simp)+ + apply (rule_tac P="\s. epat = ep_at' p s \ cteat = real_cte_at' slot s + \ tcbat = (tcb_at' (slot && ~~ mask 9) and (%y. slot && mask 9 : dom tcb_cte_cases)) s" + in monadic_rewrite_refl3) + apply (simp add: setEndpoint_def setObject_modify_assert bind_assoc + exec_gets assert_def exec_modify + split: if_split) + apply (auto split: if_split simp: obj_at'_def projectKOs objBits_defs + intro!: arg_cong[where f=f] ext kernel_state.fold_congs)[1] + apply wp+ + apply (simp add: objBits_defs) + done + +lemma setEndpoint_updateMDB_pivot[unfolded K_bind_def]: + "do setEndpoint p val; updateMDB slot mf; f od = + do updateMDB slot mf; setEndpoint p val; f od" + by (clarsimp simp: updateMDB_def bind_assoc + setEndpoint_getCTE_pivot + setEndpoint_setCTE_pivot + split: if_split) + +lemma setEndpoint_updateCap_pivot[unfolded K_bind_def]: + "do setEndpoint p val; updateCap slot mf; f od = + do updateCap slot mf; setEndpoint p val; f od" + by (clarsimp simp: updateCap_def bind_assoc + setEndpoint_getCTE_pivot + setEndpoint_setCTE_pivot) + +lemma modify_setEndpoint_pivot[unfolded K_bind_def]: + "\ \ksf s. ksPSpace_update ksf (sf s) = sf (ksPSpace_update ksf s) \ + \ (do modify sf; setEndpoint p val; f od) = + (do setEndpoint p val; modify sf; f od)" + apply (subgoal_tac "\s. ep_at' p (sf s) = ep_at' p s") + apply (simp add: setEndpoint_def setObject_modify_assert + bind_assoc fun_eq_iff + exec_gets exec_modify assert_def + split: if_split) + apply atomize + apply clarsimp + apply (drule_tac x="\_. ksPSpace s" in spec) + apply (drule_tac x="s" in spec) + apply (drule_tac f="ksPSpace" in arg_cong) + apply simp + apply (metis obj_at'_pspaceI) + done + +lemma setEndpoint_clearUntypedFreeIndex_pivot[unfolded K_bind_def]: + "do setEndpoint p val; v <- clearUntypedFreeIndex slot; f od + = do v <- clearUntypedFreeIndex slot; setEndpoint p val; f od" + supply option.case_cong_weak[cong del] + by (simp add: clearUntypedFreeIndex_def bind_assoc getSlotCap_def setEndpoint_getCTE_pivot + updateTrackedFreeIndex_def modify_setEndpoint_pivot + split: capability.split + | rule bind_cong[OF refl] allI impI bind_apply_cong[OF refl])+ + +lemma emptySlot_setEndpoint_pivot[unfolded K_bind_def]: + "(do emptySlot slot NullCap; setEndpoint p val; f od) = + (do setEndpoint p val; emptySlot slot NullCap; f od)" + apply (rule ext) + apply (simp add: emptySlot_def bind_assoc + setEndpoint_getCTE_pivot + setEndpoint_updateCap_pivot + setEndpoint_updateMDB_pivot + case_Null_If Retype_H.postCapDeletion_def + setEndpoint_clearUntypedFreeIndex_pivot + split: if_split + | rule bind_apply_cong[OF refl])+ + done + +lemma set_getCTE[unfolded K_bind_def]: + "do setCTE p cte; v <- getCTE p; f v od + = do setCTE p cte; f cte od" + apply simp + apply (rule monadic_rewrite_to_eq) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_bind_tail) + apply (simp add: getCTE_assert_opt bind_assoc) + apply (rule monadic_rewrite_trans, + rule_tac rv="Some cte" in monadic_rewrite_gets_known) + apply (simp add: assert_opt_def) + apply (rule monadic_rewrite_refl) + apply wp + apply simp + done + +lemma set_setCTE[unfolded K_bind_def]: + "do setCTE p val; setCTE p val' od = setCTE p val'" + supply if_split[split del] + apply simp + apply (rule monadic_rewrite_to_eq) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans, + rule_tac f="real_cte_at' p" in monadic_rewrite_add_gets) + apply (rule monadic_rewrite_transverse, rule monadic_rewrite_add_gets, + rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_trans, + rule_tac f="tcb_at' (p && ~~ mask 9) and K (p && mask 9 \ dom tcb_cte_cases)" + in monadic_rewrite_add_gets) + apply (rule monadic_rewrite_transverse, rule monadic_rewrite_add_gets, + rule monadic_rewrite_bind_tail) + apply (rename_tac cteat tcbat) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_tail) + apply (simp add: setCTE_assert_modify) + apply (rule monadic_rewrite_trans, rule_tac rv=cteat in monadic_rewrite_gets_known) + apply (rule_tac rv=tcbat in monadic_rewrite_gets_known) + apply (wp setCTE_typ_at'[where T="koType TYPE(tcb)", unfolded typ_at_to_obj_at'] + setCTE_typ_at'[where T="koType TYPE(cte)", unfolded typ_at_to_obj_at'] + | simp)+ + apply (simp add: setCTE_assert_modify bind_assoc) + apply (rule monadic_rewrite_bind_tail)+ + apply (rule_tac P="c = cteat \ t = tcbat + \ (tcbat \ + (\ getF setF. tcb_cte_cases (p && mask 9) = Some (getF, setF) + \ (\ f g tcb. setF f (setF g tcb) = setF (f o g) tcb)))" + in monadic_rewrite_gen_asm) + apply (rule monadic_rewrite_refl2) + apply (simp add: exec_modify split: if_split) + apply (auto simp: simpler_modify_def projectKO_opt_tcb objBits_defs + intro!: kernel_state.fold_congs ext + split: if_split)[1] + apply wp+ + apply (clarsimp simp: objBits_defs intro!: all_tcbI) + apply (auto simp: tcb_cte_cases_def split: if_split_asm) + done + +lemma setCTE_updateCapMDB: + "p \ 0 \ + setCTE p cte = do updateCap p (cteCap cte); updateMDB p (const (cteMDBNode cte)) od" + supply if_split[split del] word_neq_0_conv[simp del] + apply (simp add: updateCap_def updateMDB_def bind_assoc set_getCTE + cte_overwrite set_setCTE) + apply (simp add: getCTE_assert_opt setCTE_assert_modify bind_assoc) + apply (rule ext, simp add: exec_gets assert_opt_def exec_modify + split: if_split option.split) + apply (cut_tac P=\ and p=p and s=x in cte_wp_at_ctes_of) + apply (cases cte) + apply (simp add: cte_wp_at_obj_cases') + apply (auto simp: mask_out_sub_mask) + done + +lemma clearUntypedFreeIndex_simple_rewrite: + "monadic_rewrite True False + (cte_wp_at' (Not o isUntypedCap o cteCap) slot) + (clearUntypedFreeIndex slot) (return ())" + apply (simp add: clearUntypedFreeIndex_def getSlotCap_def) + apply (rule monadic_rewrite_name_pre) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (rule monadic_rewrite_imp) + apply (rule_tac rv=cte in monadic_rewrite_symb_exec_l_known, wp+) + apply (simp split: capability.split, + strengthen monadic_rewrite_refl, simp) + apply clarsimp + apply (wp getCTE_wp') + apply (clarsimp simp: cte_wp_at_ctes_of) + done + +lemma emptySlot_replymaster_rewrite[OF refl]: + "mdbn = cteMDBNode cte \ + monadic_rewrite True False + ((\_. mdbNext mdbn = 0 \ mdbPrev mdbn \ 0) + and ((\_. cteCap cte \ NullCap) + and (cte_wp_at' ((=) cte) slot + and cte_wp_at' (\cte. isReplyCap (cteCap cte)) slot + and cte_wp_at' (\cte. isReplyCap (cteCap cte) \ capReplyMaster (cteCap cte)) + (mdbPrev mdbn) + and (\s. reply_masters_rvk_fb (ctes_of s)) + and (\s. no_0 (ctes_of s))))) + (emptySlot slot NullCap) + (do updateMDB (mdbPrev mdbn) (mdbNext_update (K 0) o mdbFirstBadged_update (K True) + o mdbRevocable_update (K True)); + setCTE slot makeObject + od)" + supply if_split[split del] word_neq_0_conv[simp del] + apply (rule monadic_rewrite_gen_asm)+ + apply (rule monadic_rewrite_imp) + apply (rule_tac P="slot \ 0" in monadic_rewrite_gen_asm) + apply (clarsimp simp: emptySlot_def setCTE_updateCapMDB) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_head) + apply (rule clearUntypedFreeIndex_simple_rewrite) + apply simp + apply (rule_tac rv=cte in monadic_rewrite_symb_exec_l_known, (wp empty_fail_getCTE)+) + apply (simp add: updateMDB_def Let_def bind_assoc makeObject_cte case_Null_If) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_bind) + apply (rule_tac P="mdbFirstBadged (cteMDBNode ctea) \ mdbRevocable (cteMDBNode ctea)" + in monadic_rewrite_gen_asm) + apply (rule monadic_rewrite_refl2) + apply (case_tac ctea, rename_tac mdbnode, case_tac mdbnode) + apply simp + apply (simp add: Retype_H.postCapDeletion_def) + apply (rule monadic_rewrite_refl) + apply (wp getCTE_wp')+ + apply (clarsimp simp: cte_wp_at_ctes_of reply_masters_rvk_fb_def) + apply (fastforce simp: isCap_simps) + done + +lemma all_prio_not_inQ_not_tcbQueued: "\ obj_at' (\a. (\d p. \ inQ d p a)) t s \ \ obj_at' (\a. \ tcbQueued a) t s" + apply (clarsimp simp: obj_at'_def inQ_def) +done + +crunches setThreadState, emptySlot, asUser + for ntfn_obj_at[wp]: "obj_at' (P::(Structures_H.notification \ bool)) ntfnptr" + (wp: obj_at_setObject2 crunch_wps + simp: crunch_simps updateObject_default_def in_monad) + +lemma st_tcb_at_is_Reply_imp_not_tcbQueued: "\s t.\ invs' s; st_tcb_at' isReply t s\ \ obj_at' (\a. \ tcbQueued a) t s" + apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def st_tcb_at'_def valid_queues_no_bitmap_def) + apply (rule all_prio_not_inQ_not_tcbQueued) + apply (clarsimp simp: obj_at'_def) + apply (erule_tac x="d" in allE) + apply (erule_tac x="p" in allE) + apply (erule conjE) + apply (erule_tac x="t" in ballE) + apply (clarsimp simp: obj_at'_def runnable'_def isReply_def) + apply (case_tac "tcbState obj") + apply ((clarsimp simp: inQ_def)+)[8] + apply (clarsimp simp: valid_queues'_def obj_at'_def) +done + +lemma valid_objs_ntfn_at_tcbBoundNotification: + "ko_at' tcb t s \ valid_objs' s \ tcbBoundNotification tcb \ None + \ ntfn_at' (the (tcbBoundNotification tcb)) s" + apply (drule(1) ko_at_valid_objs', simp add: projectKOs) + apply (simp add: valid_obj'_def valid_tcb'_def valid_bound_ntfn'_def) + apply clarsimp + done + +crunch bound_tcb_at'_Q[wp]: setThreadState "\s. Q (bound_tcb_at' P t s)" + (wp: threadSet_pred_tcb_no_state crunch_wps simp: unless_def) + +lemmas emptySlot_pred_tcb_at'_Q[wp] = lift_neg_pred_tcb_at'[OF emptySlot_typ_at' emptySlot_pred_tcb_at'] + +lemma emptySlot_tcb_at'[wp]: + "\\s. Q (tcb_at' t s)\ emptySlot a b \\_ s. Q (tcb_at' t s)\" + by (simp add: tcb_at_typ_at', wp) + +lemmas cnode_caps_gsCNodes_lift + = hoare_lift_Pf2[where P="\gs s. cnode_caps_gsCNodes (f s) gs" and f=gsCNodes for f] + hoare_lift_Pf2[where P="\gs s. Q s \ cnode_caps_gsCNodes (f s) gs" and f=gsCNodes for f Q] + +lemma resolveAddressBitsFn_eq_name_slot: + "monadic_rewrite F E (\s. (isCNodeCap cap \ cte_wp_at' (\cte. cteCap cte = cap) (slot s) s) + \ valid_objs' s \ cnode_caps_gsCNodes' s) + (resolveAddressBits cap capptr bits) + (gets (resolveAddressBitsFn cap capptr bits o only_cnode_caps o ctes_of))" + apply (rule monadic_rewrite_imp, rule resolveAddressBitsFn_eq) + apply auto + done + +crunch bound_tcb_at'_Q[wp]: asUser "\s. Q (bound_tcb_at' P t s)" + (simp: crunch_simps wp: threadSet_pred_tcb_no_state crunch_wps) + + +lemma asUser_tcb_at'_Q[wp]: + "\\s. Q (tcb_at' t s)\ asUser a b \\_ s. Q (tcb_at' t s)\" + by (simp add: tcb_at_typ_at', wp) + +lemma active_ntfn_check_wp: + "\\s. Q (\ntfnptr. bound_tcb_at' ((=) (Some ntfnptr)) thread s + \ \ obj_at' (Not o isActive) ntfnptr s) s \ do bound_ntfn \ getBoundNotification thread; + case bound_ntfn of None \ return False + | Some ntfnptr \ liftM EndpointDecls_H.isActive $ getNotification ntfnptr + od \Q\" + apply (rule hoare_pre) + apply (wp getNotification_wp gbn_wp' | wpc)+ + apply (auto simp: pred_tcb_at'_def obj_at'_def projectKOs) + done + +lemma tcbSchedEnqueue_tcbIPCBuffer: + "\obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\ + tcbSchedEnqueue t' + \\_. obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\" + apply (simp add: tcbSchedEnqueue_def unless_when) + apply (wp threadSet_obj_at' hoare_drop_imps threadGet_wp + |simp split: if_split)+ + done + +crunch obj_at'_tcbIPCBuffer[wp]: rescheduleRequired "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" + (wp: crunch_wps tcbSchedEnqueue_tcbIPCBuffer simp: rescheduleRequired_def) + +context +notes if_cong[cong] +begin +crunch obj_at'_tcbIPCBuffer[wp]: setThreadState "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" + (wp: crunch_wps threadSet_obj_at'_really_strongest) + +crunch obj_at'_tcbIPCBuffer[wp]: handleFault "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" + (wp: crunch_wps constOnFailure_wp tcbSchedEnqueue_tcbIPCBuffer threadSet_obj_at'_really_strongest + simp: zipWithM_x_mapM) +end + +crunch obj_at'_tcbIPCBuffer[wp]: emptySlot "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" + (wp: crunch_wps) + +lemma fastpath_callKernel_SysReplyRecv_corres: + "monadic_rewrite True False + (invs' and ct_in_state' ((=) Running) and (\s. ksSchedulerAction s = ResumeCurrentThread) + and cnode_caps_gsCNodes') + (callKernel (SyscallEvent SysReplyRecv)) (fastpaths SysReplyRecv)" + including no_pre + supply option.case_cong_weak[cong del] + supply if_cong[cong] + supply word_neq_0_conv[simp del] + supply if_split[split del] + apply (rule monadic_rewrite_introduce_alternative) + apply (simp add: callKernel_def) + apply (rule monadic_rewrite_imp) + apply (simp add: handleEvent_def handleReply_def + handleRecv_def liftE_bindE_handle liftE_handle + bind_assoc getMessageInfo_def liftE_bind) + apply (simp add: catch_liftE_bindE unlessE_throw_catch_If + unifyFailure_catch_If catch_liftE + getMessageInfo_def alternative_bind + fastpaths_def getThreadCallerSlot_def + locateSlot_conv capability_case_Null_ReplyCap + getThreadCSpaceRoot_def + cong: if_cong) + apply (rule monadic_rewrite_rdonly_bind_l, wp) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac thread msgInfo) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac cptr) + apply (rule monadic_rewrite_symb_exec_r[OF threadGet_inv no_fail_threadGet]) + apply (rename_tac tcbFault) + apply (rule monadic_rewrite_alternative_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (simp add: lookupCap_def liftME_def lookupCapAndSlot_def + lookupSlotForThread_def bindE_assoc + split_def getThreadCSpaceRoot_def + locateSlot_conv liftE_bindE bindE_bind_linearise + capFaultOnFailure_def rethrowFailure_injection + injection_handler_catch bind_bindE_assoc + getThreadCallerSlot_def bind_assoc + getSlotCap_def + case_bool_If o_def + isRight_def[where x="Inr v" for v] + isRight_def[where x="Inl v" for v] + cong: if_cong) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac "cTableCTE") + + apply (rule monadic_rewrite_transverse, + rule monadic_rewrite_bind_head, + rule resolveAddressBitsFn_eq) + apply (rule monadic_rewrite_symb_exec_r, (wp | simp)+) + apply (rename_tac "rab_ret") + + apply (rule_tac P="isRight rab_ret" in monadic_rewrite_cases[rotated]) + apply (case_tac rab_ret, simp_all add: isRight_def)[1] + apply (rule monadic_rewrite_alternative_l) + apply clarsimp + apply (simp add: isRight_case_sum liftE_bind + isRight_def[where x="Inr v" for v]) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac ep_cap) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_symb_exec_r[OF _ _ _ active_ntfn_check_wp, unfolded bind_assoc fun_app_def]) + apply (rule hoare_pre, (wp | wpc | simp)+)[1] + apply (unfold getBoundNotification_def)[1] + apply (wp threadGet_wp) + apply (rename_tac ep) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac ep) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_rdonly_bind_l, wp) + apply (rule monadic_rewrite_bind_tail) + apply (rename_tac replyCTE) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (simp add: bind_assoc) + apply (rule monadic_rewrite_rdonly_bind_l, wp assert_inv) + apply (rule monadic_rewrite_assert) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac callerFault) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (simp add: getThreadVSpaceRoot_def locateSlot_conv) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac vTableCTE) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + + apply (rule monadic_rewrite_symb_exec_r[OF curDomain_inv], + simp only: curDomain_def, rule non_fail_gets) + apply (rename_tac "curDom") + apply (rule monadic_rewrite_symb_exec_r + [OF threadGet_inv no_fail_threadGet]) + apply (rename_tac callerPrio) + apply (simp add: isHighestPrio_def') + apply (rule monadic_rewrite_symb_exec_r [OF gets_inv non_fail_gets]) + apply (rename_tac highest) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac asidMap) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_symb_exec_r[OF threadGet_inv no_fail_threadGet]) + apply (rename_tac "callerDom") + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_trans, + rule monadic_rewrite_pick_alternative_1) + apply (rule_tac P="\v. obj_at' (%tcb. tcbIPCBuffer tcb = v) (capTCBPtr (cteCap replyCTE))" + in monadic_rewrite_exists_v) + apply (rename_tac ipcBuffer) + + apply (simp add: switchToThread_def bind_assoc) + apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) + + apply (rule monadic_rewrite_bind monadic_rewrite_refl)+ + apply (wp mapM_x_wp' getObject_inv | wpc | simp add: + | wp (once) hoare_drop_imps )+ + + apply (rule monadic_rewrite_bind monadic_rewrite_refl)+ + apply (wp setCTE_obj_at'_tcbIPCBuffer assert_inv mapM_x_wp' getObject_inv | wpc | simp + | wp (once) hoare_drop_imps )+ + + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_head) + apply (rule monadic_rewrite_trans) + apply (rule doReplyTransfer_simple) + apply simp + apply (((rule monadic_rewrite_weaken2, + (rule_tac msgInfo=msgInfo in doIPCTransfer_simple_rewrite + | rule_tac destPrio=callerPrio + and curDom=curDom and destDom=callerDom + and thread=thread in possibleSwitchTo_rewrite)) + | rule cteDeleteOne_replycap_rewrite + | rule monadic_rewrite_bind monadic_rewrite_refl + | wp assert_inv mapM_x_wp' + setThreadState_obj_at_unchanged + asUser_obj_at_unchanged + hoare_strengthen_post[OF _ obj_at_conj'[simplified atomize_conjL], rotated] + lookupBitmapPriority_lift + setThreadState_runnable_bitmap_inv + | simp add: setMessageInfo_def setThreadState_runnable_simp + | wp (once) hoare_vcg_disj_lift)+)[1] + apply (simp add: setMessageInfo_def) + apply (rule monadic_rewrite_bind_tail) + apply (rename_tac unblocked) + apply (rule_tac rv=thread in monadic_rewrite_symb_exec_l_known, + (wp empty_fail_getCurThread)+) + apply (rule_tac rv=cptr in monadic_rewrite_symb_exec_l_known, + (wp empty_fail_asUser empty_fail_getRegister)+) + apply (rule monadic_rewrite_bind) + apply (rule monadic_rewrite_catch[OF _ monadic_rewrite_refl True_E_E]) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rename_tac cTableCTE2, + rule_tac P="cteCap cTableCTE2 = cteCap cTableCTE" + in monadic_rewrite_gen_asm) + apply simp + apply (rule monadic_rewrite_trans, + rule monadic_rewrite_bindE[OF _ monadic_rewrite_refl]) + apply (rule_tac slot="\s. ksCurThread s + 2 ^ cte_level_bits * tcbCTableSlot" + in resolveAddressBitsFn_eq_name_slot) + apply wp + apply (rule monadic_rewrite_trans) + apply (rule_tac rv=rab_ret + in monadic_rewrite_gets_known[where m="NonDetMonad.lift f" + for f, folded bindE_def]) + apply (simp add: NonDetMonad.lift_def isRight_case_sum) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rename_tac ep_cap2) + apply (rule_tac P="cteCap ep_cap2 = cteCap ep_cap" in monadic_rewrite_gen_asm) + apply (simp add: cap_case_EndpointCap_NotificationCap) + apply (rule monadic_rewrite_liftE) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind) + apply (rule deleteCallerCap_nullcap_rewrite) + apply (rule_tac ep=ep in receiveIPC_simple_rewrite) + apply (wp, simp) + apply (rule monadic_rewrite_bind_head) + + apply (rule monadic_rewrite_weaken[where E=True and F=True], simp) + apply (rule setThreadState_rewrite_simple) + apply clarsimp + apply (wp getCTE_known_cap)+ + apply (rule monadic_rewrite_bind) + apply (rule_tac t="capTCBPtr (cteCap replyCTE)" + and t'=thread + in schedule_known_rewrite) + apply (rule monadic_rewrite_weaken[where E=True and F=True], simp) + apply (rule monadic_rewrite_bind) + apply (rule activateThread_simple_rewrite) + apply (rule monadic_rewrite_refl) + apply wp + apply wp + apply (simp add: ct_in_state'_def, simp add: ct_in_state'_def[symmetric]) + apply ((wp setCurThread_ct_in_state[folded st_tcb_at'_def] + Arch_switchToThread_pred_tcb')+)[2] + apply (simp add: catch_liftE) + apply (wp setEndpoint_obj_at_tcb' threadSet_pred_tcb_at_state[unfolded if_bool_eq_conj]) + + apply (wp setEndpoint_obj_at_tcb' + threadSet_pred_tcb_at_state[unfolded if_bool_eq_conj] + fastpathBestSwitchCandidate_lift[where f="setEndpoint a b" for a b] + fastpathBestSwitchCandidate_lift[where f="threadSet f t" for f t] + | simp + | rule hoare_lift_Pf2[where f=ksCurThread, OF _ setEndpoint_ct'] + hoare_lift_Pf2[where f=ksCurThread, OF _ threadSet_ct])+ + + apply (simp cong: rev_conj_cong) + apply (strengthen imp_consequent[where Q="tcb_at' t s" for t s]) + apply (unfold setSchedulerAction_def)[3] + apply ((wp setThreadState_oa_queued user_getreg_rv setThreadState_no_sch_change + setThreadState_obj_at_unchanged + sts_st_tcb_at'_cases sts_bound_tcb_at' + emptySlot_obj_at'_not_queued + emptySlot_cte_wp_at_cteCap + emptySlot_cnode_caps + user_getreg_inv asUser_typ_ats + asUser_obj_at_not_queued asUser_obj_at' mapM_x_wp' + static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift + static_imp_wp cnode_caps_gsCNodes_lift + hoare_vcg_ex_lift + | simp del: comp_apply + | clarsimp simp: obj_at'_weakenE[OF _ TrueI])+) + + apply (rule hoare_lift_Pf2[where f=ksCurThread, OF _ setThreadState_ct']) + apply (wp setThreadState_oa_queued + fastpathBestSwitchCandidate_lift[where f="setThreadState f t" for f t]) + apply (simp add: setThreadState_runnable_simp) + apply (wp threadSet_tcbState_st_tcb_at') + apply (clarsimp simp del: comp_apply) + apply (wp emptySlot_obj_at_ep)+ + + apply ((wp setThreadState_oa_queued user_getreg_rv + setThreadState_no_sch_change + setThreadState_obj_at_unchanged + sts_st_tcb_at'_cases sts_bound_tcb_at' + emptySlot_obj_at'_not_queued + emptySlot_cte_wp_at_cteCap + emptySlot_cnode_caps + user_getreg_inv asUser_typ_ats + asUser_obj_at_not_queued asUser_obj_at' mapM_x_wp' + static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift + static_imp_wp cnode_caps_gsCNodes_lift + hoare_vcg_ex_lift + | simp del: comp_apply + | clarsimp simp: obj_at'_weakenE[OF _ TrueI] + | solves \ + rule hoare_lift_Pf2[where f=ksCurThread, OF _ emptySlot_ct] + hoare_lift_Pf2[where f=ksCurThread, OF _ asUser_ct], + wp fastpathBestSwitchCandidate_lift[where f="emptySlot a b" for a b] + fastpathBestSwitchCandidate_lift[where f="asUser a b" for a b] + user_getreg_inv asUser_typ_ats\)+) + + apply (clarsimp | wp getCTE_wp' gts_imp')+ + + apply (simp add: switchToThread_def bind_assoc) + apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) + + apply (rule monadic_rewrite_bind monadic_rewrite_refl)+ + apply (wp mapM_x_wp' handleFault_obj_at'_tcbIPCBuffer getObject_inv | wpc | simp + | wp (once) hoare_drop_imps )+ + apply (rule monadic_rewrite_bind monadic_rewrite_refl)+ + apply (wp setCTE_obj_at'_tcbIPCBuffer assert_inv mapM_x_wp' getObject_inv | wpc | simp + | wp (once) hoare_drop_imps )+ + + apply (simp add: bind_assoc catch_liftE + receiveIPC_def Let_def liftM_def + setThreadState_runnable_simp) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getThreadState)+) + apply (rule monadic_rewrite_assert) + + apply (rule_tac P="inj (case_bool thread (capTCBPtr (cteCap replyCTE)))" + in monadic_rewrite_gen_asm) + apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) + apply (rule monadic_rewrite_weaken[where F=False and E=True], simp) + apply (rule isolate_thread_actions_rewrite_bind + fastpath_isolate_rewrites fastpath_isolatables + bool.simps setRegister_simple + zipWithM_setRegister_simple + thread_actions_isolatable_bind + thread_actions_isolatableD[OF setCTE_isolatable] + setCTE_isolatable + setVMRoot_isolatable[THEN thread_actions_isolatableD] setVMRoot_isolatable + doMachineOp_isolatable[THEN thread_actions_isolatableD] doMachineOp_isolatable + kernelExitAssertions_isolatable[THEN thread_actions_isolatableD] + kernelExitAssertions_isolatable + | assumption + | wp assert_inv)+ + apply (simp only: ) + apply (rule_tac P="(\s. ksSchedulerAction s = ResumeCurrentThread) + and tcb_at' thread + and (cte_wp_at' (\cte. isReplyCap (cteCap cte)) + (thread + 2 ^ cte_level_bits * tcbCallerSlot) + and (\s. \x. tcb_at' (case_bool thread (capTCBPtr (cteCap replyCTE)) x) s) + and valid_mdb')" + and F=True and E=False in monadic_rewrite_weaken) + apply (rule monadic_rewrite_isolate_final2) + apply simp + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rename_tac callerCTE) + apply (rule monadic_rewrite_assert) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rule monadic_rewrite_assert) + apply (simp add: emptySlot_setEndpoint_pivot) + apply (rule monadic_rewrite_bind) + apply (rule monadic_rewrite_refl2) + apply (clarsimp simp: isSendEP_def split: Structures_H.endpoint.split) + apply (rule_tac Q="\rv. (\_. rv = callerCTE) and Q'" for Q' + in monadic_rewrite_symb_exec_r, wp+) + apply (rule monadic_rewrite_gen_asm, simp) + apply (rule monadic_rewrite_trans, rule monadic_rewrite_bind_head, + rule_tac cte=callerCTE in emptySlot_replymaster_rewrite) + apply (simp add: bind_assoc o_def) + apply (rule monadic_rewrite_refl) + apply (simp add: cte_wp_at_ctes_of pred_conj_def) + apply (clarsimp | wp getCTE_ctes_wp)+ + apply (clarsimp simp: zip_map2 zip_same_conv_map foldl_map + foldl_fun_upd + foldr_copy_register_tsrs + isRight_case_sum + cong: if_cong) + apply (clarsimp simp: fun_eq_iff if_flip + cong: if_cong) + apply (drule obj_at_ko_at', clarsimp) + apply (frule get_tcb_state_regs_ko_at') + apply (clarsimp simp: zip_map2 zip_same_conv_map foldl_map + foldl_fun_upd + foldr_copy_register_tsrs + isRight_case_sum + cong: if_cong) + apply (simp add: upto_enum_def fromEnum_def + enum_register toEnum_def + msgRegisters_unfold + cong: if_cong) + apply (clarsimp split: if_split) + apply (rule ext) + apply (simp add: badgeRegister_def msgInfoRegister_def + ARM.msgInfoRegister_def + ARM.badgeRegister_def + cong: if_cong + split: if_split) + apply simp + apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps + map_to_ctes_partial_overwrite) + apply (simp add: valid_mdb'_def valid_mdb_ctes_def) + apply simp + apply (simp cong: if_cong bool.case_cong + | rule getCTE_wp' gts_wp' threadGet_wp + getEndpoint_wp gets_wp + user_getreg_wp + gets_the_wp gct_wp getNotification_wp + return_wp liftM_wp gbn_wp' + | (simp only: curDomain_def, wp)[1])+ + + apply clarsimp + apply (subgoal_tac "ksCurThread s \ ksIdleThread s") + prefer 2 + apply (fastforce simp: ct_in_state'_def dest: ct_running_not_idle' elim: pred_tcb'_weakenE) + + apply (clarsimp simp: ct_in_state'_def pred_tcb_at') + apply (subst tcb_at_cte_at_offset, + erule obj_at'_weakenE[OF _ TrueI], + simp add: tcb_cte_cases_def cte_level_bits_def tcbSlots) + apply (clarsimp simp: valid_objs_ntfn_at_tcbBoundNotification + invs_valid_objs' if_apply_def2) + apply (rule conjI[rotated]) + apply (fastforce elim: cte_wp_at_weakenE') + apply (clarsimp simp: isRight_def) + apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp+) + apply (frule resolveAddressBitsFn_real_cte_at', + (clarsimp | erule cte_wp_at_weakenE')+) + apply (frule real_cte_at', clarsimp) + apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp, + clarsimp simp: isCap_simps, simp add: valid_cap_simps') + apply (clarsimp simp: maskCapRights_def isCap_simps) + apply (frule_tac p="p' + 2 ^ cte_level_bits * tcbCallerSlot" for p' + in cte_wp_at_valid_objs_valid_cap', clarsimp+) + apply (clarsimp simp: valid_cap_simps') + apply (subst tcb_at_cte_at_offset, + assumption, simp add: tcb_cte_cases_def cte_level_bits_def tcbSlots) + apply (clarsimp simp: inj_case_bool cte_wp_at_ctes_of + order_less_imp_le + tcb_at_invs' invs_mdb' + split: bool.split) + apply (subst imp_disjL[symmetric], intro allI impI) + apply (clarsimp simp: inj_case_bool cte_wp_at_ctes_of + length_msgRegisters size_msgRegisters_def order_less_imp_le + tcb_at_invs' invs_mdb' + split: bool.split) + + apply (subgoal_tac "fastpathBestSwitchCandidate v0a s") + prefer 2 + apply normalise_obj_at' + apply (rule_tac ttcb=tcba and ctcb=tcb in fastpathBestSwitchCandidateI) + apply (erule disjE, blast, blast) + apply simp+ + + apply (clarsimp simp: obj_at_tcbs_of tcbSlots + cte_level_bits_def) + apply (frule(1) st_tcb_at_is_Reply_imp_not_tcbQueued) + apply (auto simp: obj_at_tcbs_of tcbSlots + cte_level_bits_def) + done + +end + +lemma cnode_caps_gsCNodes_from_sr: + "\ valid_objs s; (s, s') \ state_relation \ \ cnode_caps_gsCNodes' s'" + apply (clarsimp simp: cnode_caps_gsCNodes_def only_cnode_caps_def + o_def ran_map_option) + apply (safe, simp_all) + apply (clarsimp elim!: ranE) + apply (frule(1) pspace_relation_cte_wp_atI[rotated]) + apply clarsimp + apply (clarsimp simp: is_cap_simps) + apply (frule(1) cte_wp_at_valid_objs_valid_cap) + apply (clarsimp simp: valid_cap_simps cap_table_at_gsCNodes_eq) + done + +end diff --git a/proof/crefine/ARM/Finalise_C.thy b/proof/crefine/ARM/Finalise_C.thy index 683c2893b..d81e57dd8 100644 --- a/proof/crefine/ARM/Finalise_C.thy +++ b/proof/crefine/ARM/Finalise_C.thy @@ -13,11 +13,6 @@ begin declare if_split [split del] -lemma empty_fail_getEndpoint: - "empty_fail (getEndpoint ep)" - unfolding getEndpoint_def - by (auto intro: empty_fail_getObject) - definition "option_map2 f m = option_map f \ m" diff --git a/proof/crefine/ARM/Invoke_C.thy b/proof/crefine/ARM/Invoke_C.thy index 1356ee913..8b4173468 100644 --- a/proof/crefine/ARM/Invoke_C.thy +++ b/proof/crefine/ARM/Invoke_C.thy @@ -1412,10 +1412,6 @@ lemma deleteObjects_gsCNodes_at_pt: | wp (once) hoare_drop_imps)+ done -crunches setThreadState, updateFreeIndex, preemptionPoint - for gsCNodes[wp]: "\s. P (gsCNodes s)" - (simp: unless_def whenE_def ignore_del: preemptionPoint) - lemma resetUntypedCap_gsCNodes_at_pt: "\(\s. P (gsCNodes s ptr)) and cte_wp_at' (\cte. isUntypedCap (cteCap cte) \ ptr \ untypedRange (cteCap cte)) slot diff --git a/proof/crefine/ARM/IpcCancel_C.thy b/proof/crefine/ARM/IpcCancel_C.thy index ae4b3cb5a..aed779b54 100644 --- a/proof/crefine/ARM/IpcCancel_C.thy +++ b/proof/crefine/ARM/IpcCancel_C.thy @@ -2505,13 +2505,6 @@ lemma cancelSignal_ccorres [corres]: | clarsimp simp: eq_commute | drule_tac x=thread in bspec)+ -lemma ko_at_valid_ep': - "\ko_at' ep p s; valid_objs' s\ \ valid_ep' ep s" - apply (erule obj_atE') - apply (erule (1) valid_objsE') - apply (simp add: projectKOs valid_obj'_def) - done - lemma cmap_relation_ep: "(s, s') \ rf_sr \ cmap_relation (map_to_eps (ksPSpace s)) (cslift s') Ptr (cendpoint_relation (cslift s'))" diff --git a/proof/crefine/ARM/Ipc_C.thy b/proof/crefine/ARM/Ipc_C.thy index f7df4f894..b017fd0b4 100644 --- a/proof/crefine/ARM/Ipc_C.thy +++ b/proof/crefine/ARM/Ipc_C.thy @@ -1279,13 +1279,6 @@ lemma ccorres_add_getRegister: apply fastforce done -lemma user_getreg_rv: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb r)) t\ asUser t (getRegister r) \\rv s. P rv\" - apply (simp add: asUser_def split_def) - apply (wp threadGet_wp) - apply (clarsimp simp: obj_at'_def projectKOs getRegister_def in_monad atcbContextGet_def) - done - lemma exceptionMessage_ccorres: "n < unat n_exceptionMessage \ register_from_H (ARM_H.exceptionMessage ! n) diff --git a/proof/crefine/ARM/IsolatedThreadAction.thy b/proof/crefine/ARM/IsolatedThreadAction.thy index 7e438c4b4..12001da3a 100644 --- a/proof/crefine/ARM/IsolatedThreadAction.thy +++ b/proof/crefine/ARM/IsolatedThreadAction.thy @@ -5,7 +5,7 @@ *) theory IsolatedThreadAction -imports "CLib.MonadicRewrite_C" Finalise_C CSpace_All SyscallArgs_C +imports ArchMove_C begin datatype tcb_state_regs = TCBStateRegs "thread_state" "MachineTypes.register \ machine_word" @@ -119,7 +119,8 @@ lemmas setEndpoint_obj_at_tcb' = setEndpoint_obj_at'_tcb lemmas setNotification_tcb = set_ntfn_tcb_obj_at' -context kernel_m begin +context begin interpretation Arch . (*FIXME: arch_split*) + lemma setObject_modify: fixes v :: "'a :: pspace_storable" shows "\ obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; @@ -138,8 +139,6 @@ lemma setObject_modify: apply (simp add: simpler_modify_def) done -context begin interpretation Arch . (*FIXME: arch_split*) - lemma getObject_return: fixes v :: "'a :: pspace_storable" shows "\ \a b c d. (loadObject a b c d :: 'a kernel) = loadObject_default a b c d; @@ -233,6 +232,8 @@ lemma isolate_thread_actions_asUser: apply (case_tac ko, simp) done +context begin interpretation Arch . (*FIXME: arch_split*) + lemma setRegister_simple: "setRegister r v = (\con. ({((), con (r := v))}, False))" by (simp add: setRegister_def simpler_modify_def) @@ -240,6 +241,7 @@ lemma setRegister_simple: lemma zipWithM_setRegister_simple: "zipWithM_x setRegister rs vs = (\con. ({((), foldl (\con (r, v). con (r := v)) con (zip rs vs))}, False))" + supply if_split[split del] apply (simp add: zipWithM_x_mapM_x) apply (induct ("zip rs vs")) apply (simp add: mapM_x_Nil return_def) @@ -260,6 +262,7 @@ lemma map_to_ctes_partial_overwrite: "\x. tcb_at' (idx x) s \ map_to_ctes (partial_overwrite idx tsrs (ksPSpace s)) = ctes_of s" + supply if_split[split del] apply (rule ext) apply (frule dom_partial_overwrite[where tsrs=tsrs]) apply (simp add: map_to_ctes_def partial_overwrite_def @@ -609,6 +612,7 @@ lemma page_directory_at_partial_overwrite: lemma findPDForASID_isolatable: "thread_actions_isolatable idx (findPDForASID asid)" + supply if_split[split del] apply (simp add: findPDForASID_def liftE_bindE liftME_def bindE_assoc case_option_If2 assertE_def liftE_def checkPDAt_def stateAssert_def2 @@ -648,6 +652,7 @@ lemma getHWASID_isolatable: lemma setVMRoot_isolatable: "thread_actions_isolatable idx (setVMRoot t)" + supply if_split[split del] apply (simp add: setVMRoot_def getThreadVSpaceRoot_def locateSlot_conv getSlotCap_def cap_case_isPageDirectoryCap if_bool_simps @@ -706,24 +711,17 @@ lemma lookupIPC_inv: "\P\ lookupIPCBuffer f t \\ lemmas empty_fail_user_getreg = empty_fail_asUser[OF empty_fail_getRegister] -lemma user_getreg_rv: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb r)) t\ asUser t (getRegister r) \\rv s. P rv\" - apply (simp add: asUser_def split_def) - apply (wp threadGet_wp) - apply (clarsimp simp: obj_at'_def projectKOs getRegister_def in_monad atcbContextGet_def) - done - lemma copyMRs_simple: - "msglen \ of_nat (length ARM_H.msgRegisters) \ + "msglen \ of_nat (length msgRegisters) \ copyMRs sender sbuf receiver rbuf msglen - = forM_x (take (unat msglen) ARM_H.msgRegisters) + = forM_x (take (unat msglen) msgRegisters) (\r. do v \ asUser sender (getRegister r); asUser receiver (setRegister r v) od) >>= (\rv. return msglen)" apply (clarsimp simp: copyMRs_def mapM_discarded) apply (rule bind_cong[OF refl]) - apply (simp add: length_msgRegisters n_msgRegisters_def min_def - word_le_nat_alt + apply (simp add: min_def word_le_nat_alt length_msgRegisters + upto_enum_red fromEnum_def enum_register split: option.split) apply (simp add: upto_enum_def mapM_Nil) done @@ -732,16 +730,16 @@ lemma doIPCTransfer_simple_rewrite: "monadic_rewrite True True ((\_. msgExtraCaps (messageInfoFromWord msgInfo) = 0 \ msgLength (messageInfoFromWord msgInfo) - \ of_nat (length ARM_H.msgRegisters)) + \ of_nat (length msgRegisters)) and obj_at' (\tcb. tcbFault tcb = None \ (atcbContextGet o tcbArch) tcb msgInfoRegister = msgInfo) sender) (doIPCTransfer sender ep badge grant rcvr) (do rv \ mapM_x (\r. do v \ asUser sender (getRegister r); asUser rcvr (setRegister r v) od) - (take (unat (msgLength (messageInfoFromWord msgInfo))) ARM_H.msgRegisters); + (take (unat (msgLength (messageInfoFromWord msgInfo))) msgRegisters); y \ setMessageInfo rcvr ((messageInfoFromWord msgInfo) \msgCapsUnwrapped := 0\); - asUser rcvr (setRegister ARM_H.badgeRegister badge) + asUser rcvr (setRegister badgeRegister badge) od)" supply if_cong[cong] apply (rule monadic_rewrite_gen_asm) @@ -875,7 +873,7 @@ lemma oblivious_setVMRoot_schact: lemma oblivious_switchToThread_schact: "oblivious (ksSchedulerAction_update f) (ThreadDecls_H.switchToThread t)" - apply (simp add: Thread_H.switchToThread_def ARM_H.switchToThread_def bind_assoc + apply (simp add: Thread_H.switchToThread_def switchToThread_def bind_assoc getCurThread_def setCurThread_def threadGet_def liftM_def threadSet_def tcbSchedEnqueue_def unless_when asUser_def getQueue_def setQueue_def storeWordUser_def setRegister_def @@ -937,8 +935,6 @@ begin crunch obj_at_dom[wp]: rescheduleRequired "obj_at' (\tcb. P (tcbDomain tcb)) t" end -context kernel_m begin - lemma setThreadState_no_sch_change: "\\s. P (ksSchedulerAction s) \ (runnable' st \ t \ ksCurThread s)\ setThreadState st t @@ -970,6 +966,8 @@ lemma bind_assoc: = do x \ m; y \ f x; g y od" by (rule bind_assoc) +context begin interpretation Arch . (*FIXME: arch_split*) + lemma setObject_modify_assert: "\ updateObject v = updateObject_default v \ \ setObject p v = do f \ gets (obj_at' (\v'. v = v' \ True) p); @@ -994,6 +992,7 @@ lemma setObject_modify_assert: lemma setEndpoint_isolatable: "thread_actions_isolatable idx (setEndpoint p e)" + supply if_split[split del] apply (simp add: setEndpoint_def setObject_modify_assert assert_def) apply (case_tac "p \ range idx") @@ -1087,6 +1086,7 @@ lemma partial_overwrite_fun_upd2: lemma setCTE_isolatable: "thread_actions_isolatable idx (setCTE p v)" + supply if_split[split del] apply (simp add: setCTE_assert_modify) apply (clarsimp simp: thread_actions_isolatable_def monadic_rewrite_def fun_eq_iff @@ -1149,7 +1149,7 @@ lemma assert_isolatable: lemma cteInsert_isolatable: "thread_actions_isolatable idx (cteInsert cap src dest)" - supply if_cong[cong] + supply if_split[split del] if_cong[cong] apply (simp add: cteInsert_def updateCap_def updateMDB_def Let_def setUntypedCapAsFull_def) apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] @@ -1249,7 +1249,7 @@ lemma threadGet_isolatable: lemma switchToThread_isolatable: "thread_actions_isolatable idx (Arch.switchToThread t)" - apply (simp add: ARM_H.switchToThread_def + apply (simp add: switchToThread_def storeWordUser_def stateAssert_def2) apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] gets_isolatable setVMRoot_isolatable @@ -1319,7 +1319,7 @@ lemma tcb_at_KOTCB_upd: = tcb_at' p s" apply (clarsimp simp: obj_at'_def projectKOs objBits_simps split: if_split) - apply (simp add: ps_clear_def) + apply (fastforce simp add: ps_clear_def) done definition @@ -1335,6 +1335,7 @@ lemma copy_register_isolate: asUser dest (setRegister r' (rf v)) od) (isolate_thread_actions idx (return ()) (copy_register_tsrs x y r r' rf) id)" + supply if_split[split del] apply (simp add: asUser_def split_def bind_assoc getRegister_def setRegister_def select_f_returns isolate_thread_actions_def @@ -1479,7 +1480,7 @@ lemmas fastpath_isolate_rewrites lemma lookupIPCBuffer_isolatable: "thread_actions_isolatable idx (lookupIPCBuffer w t)" - supply if_cong[cong] + supply if_split[split del] if_cong[cong] apply (simp add: lookupIPCBuffer_def) apply (rule thread_actions_isolatable_bind) apply (clarsimp simp: put_tcb_state_regs_tcb_def threadGet_isolatable @@ -1500,6 +1501,7 @@ lemma setThreadState_rewrite_simple: (\s. (runnable' st \ ksSchedulerAction s \ ResumeCurrentThread \ t \ ksCurThread s) \ tcb_at' t s) (setThreadState st t) (threadSet (tcbState_update (\_. st)) t)" + supply if_split[split del] apply (simp add: setThreadState_def) apply (rule monadic_rewrite_imp) apply (rule monadic_rewrite_trans) diff --git a/proof/crefine/ARM/PSpace_C.thy b/proof/crefine/ARM/PSpace_C.thy index 2df17273b..b08ffdecc 100644 --- a/proof/crefine/ARM/PSpace_C.thy +++ b/proof/crefine/ARM/PSpace_C.thy @@ -8,14 +8,7 @@ theory PSpace_C imports Ctac_lemmas_C begin -context kernel begin - -lemma koTypeOf_injectKO: - fixes v :: "'a :: pspace_storable" shows - "koTypeOf (injectKO v) = koType TYPE('a)" - apply (cut_tac v1=v in iffD2 [OF project_inject, OF refl]) - apply (simp add: project_koType[symmetric]) - done +context begin interpretation Arch . (*FIXME: arch_split*) lemma setObject_obj_at_pre: "\ updateObject ko = updateObject_default ko; @@ -48,7 +41,9 @@ lemma setObject_obj_at_pre: apply clarsimp done +end +context kernel begin lemma setObject_ccorres_helper: fixes ko :: "'a :: pspace_storable" diff --git a/proof/crefine/ARM/Refine_C.thy b/proof/crefine/ARM/Refine_C.thy index eba2eb360..927b8b83a 100644 --- a/proof/crefine/ARM/Refine_C.thy +++ b/proof/crefine/ARM/Refine_C.thy @@ -7,7 +7,7 @@ chapter "Toplevel Refinement Statement" theory Refine_C -imports Init_C Fastpath_C CToCRefine +imports Init_C Fastpath_Equiv Fastpath_C CToCRefine begin context begin interpretation Arch . (*FIXME: arch_split*) @@ -18,6 +18,14 @@ end context kernel_m begin +text \Assemble fastpaths\ + +lemmas fastpath_call_ccorres_callKernel + = monadic_rewrite_ccorres_assemble[OF fastpath_call_ccorres fastpath_callKernel_SysCall_corres] + +lemmas fastpath_reply_recv_ccorres_callKernel + = monadic_rewrite_ccorres_assemble[OF fastpath_reply_recv_ccorres fastpath_callKernel_SysReplyRecv_corres] + declare liftE_handle [simp] lemma schedule_sch_act_wf: @@ -609,13 +617,13 @@ lemma ccorres_get_registers: "StrictC'_register_defs") done - lemma callKernel_withFastpath_corres_C: "corres_underlying rf_sr False True dc (all_invs' e) \ (callKernel e) (callKernel_withFastpath_C e)" using no_fail_callKernel [of e] callKernel_corres_C [of e] + supply if_split[split del] apply (cases "e = SyscallEvent syscall.SysCall \ e = SyscallEvent syscall.SysReplyRecv") apply (simp_all add: callKernel_withFastpath_C_def diff --git a/proof/crefine/ARM/Retype_C.thy b/proof/crefine/ARM/Retype_C.thy index 379fe0e55..55d50220d 100644 --- a/proof/crefine/ARM/Retype_C.thy +++ b/proof/crefine/ARM/Retype_C.thy @@ -6444,11 +6444,6 @@ end context begin interpretation Arch . (*FIXME: arch_split*) -crunches insertNewCap, Arch_createNewCaps, threadSet, "Arch.createObject" - for gsCNodes[wp]: "\s. P (gsCNodes s)" - (wp: crunch_wps setObject_ksPSpace_only - simp: unless_def updateObject_default_def crunch_simps) - lemma createNewCaps_1_gsCNodes_p: "\\s. P (gsCNodes s p) \ p \ ptr\ createNewCaps newType ptr 1 n dev\\rv s. P (gsCNodes s p)\" apply (simp add: createNewCaps_def) diff --git a/proof/crefine/ARM/SR_lemmas_C.thy b/proof/crefine/ARM/SR_lemmas_C.thy index 66e76e5f0..0abe85095 100644 --- a/proof/crefine/ARM/SR_lemmas_C.thy +++ b/proof/crefine/ARM/SR_lemmas_C.thy @@ -296,67 +296,6 @@ lemma cmdbnode_relation_mdb_node_to_H [simp]: unfolding cmdbnode_relation_def mdb_node_to_H_def mdb_node_lift_def cte_lift_def by (fastforce split: option.splits) -(* MOVE --- here down doesn't really belong here, maybe in a haskell specific file?*) -lemma tcb_cte_cases_in_range1: - assumes tc:"tcb_cte_cases (y - x) = Some v" - and al: "is_aligned x tcbBlockSizeBits" - shows "x \ y" -proof - - note objBits_defs [simp] - - from tc obtain q where yq: "y = x + q" and qv: "q < 2 ^ tcbBlockSizeBits" - unfolding tcb_cte_cases_def - by (simp add: diff_eq_eq split: if_split_asm) - - have "x \ x + 2 ^ tcbBlockSizeBits - 1" using al - by (rule is_aligned_no_overflow) - - hence "x \ x + q" using qv - apply simp - apply unat_arith - apply simp - done - - thus ?thesis using yq by simp -qed - -lemma tcb_cte_cases_in_range2: - assumes tc: "tcb_cte_cases (y - x) = Some v" - and al: "is_aligned x tcbBlockSizeBits" - shows "y \ x + 2 ^ tcbBlockSizeBits - 1" -proof - - note objBits_defs [simp] - - from tc obtain q where yq: "y = x + q" and qv: "q \ 2 ^ tcbBlockSizeBits - 1" - unfolding tcb_cte_cases_def - by (simp add: diff_eq_eq split: if_split_asm) - - have "x + q \ x + (2 ^ tcbBlockSizeBits - 1)" using qv - apply (rule word_plus_mono_right) - apply (rule is_aligned_no_overflow' [OF al]) - done - - thus ?thesis using yq by (simp add: field_simps) -qed - -lemmas tcbSlots = - tcbCTableSlot_def tcbVTableSlot_def - tcbReplySlot_def tcbCallerSlot_def tcbIPCBufferSlot_def - -lemma updateObject_cte_tcb: - assumes tc: "tcb_cte_cases (ptr - ptr') = Some (accF, updF)" - shows "updateObject ctea (KOTCB tcb) ptr ptr' next = - (do alignCheck ptr' (objBits tcb); - magnitudeCheck ptr' next (objBits tcb); - return (KOTCB (updF (\_. ctea) tcb)) - od)" - using tc unfolding tcb_cte_cases_def - apply - - apply (clarsimp simp add: updateObject_cte Let_def - tcb_cte_cases_def objBits_simps' tcbSlots shiftl_t2n - split: if_split_asm cong: if_cong) - done - definition tcb_no_ctes_proj :: "tcb \ Structures_H.thread_state \ word32 \ word32 \ arch_tcb \ bool \ word8 \ word8 \ word8 \ nat \ fault option \ word32 option" where @@ -665,10 +604,6 @@ proof - qed fact+ qed -lemma ctes_of_cte_at: - "ctes_of s p = Some x \ cte_at' p s" - by (simp add: cte_wp_at_ctes_of) - lemma cor_map_relI: assumes dm: "dom am = dom am'" and rl: "\x y y' z. \ am x = Some y; am' x = Some y'; @@ -953,6 +888,7 @@ abbreviation lemma valid_mdb_ctes_of_next: "\ valid_mdb' s; ctes_of s p = Some cte; mdbNext (cteMDBNode cte) \ 0 \ \ cte_at' (mdbNext (cteMDBNode cte)) s" unfolding valid_mdb'_def valid_mdb_ctes_def + supply word_neq_0_conv[simp del] apply clarsimp apply (erule (2) valid_dlistE) apply (simp add: cte_wp_at_ctes_of) @@ -961,6 +897,7 @@ lemma valid_mdb_ctes_of_next: lemma valid_mdb_ctes_of_prev: "\ valid_mdb' s; ctes_of s p = Some cte; mdbPrev (cteMDBNode cte) \ 0 \ \ cte_at' (mdbPrev (cteMDBNode cte)) s" unfolding valid_mdb'_def valid_mdb_ctes_def + supply word_neq_0_conv[simp del] apply clarsimp apply (erule (2) valid_dlistE) apply (simp add: cte_wp_at_ctes_of) @@ -2196,6 +2133,9 @@ lemma unat_scast_numDomains: "unat (SCAST(32 signed \ machine_word_len) Kernel_C.numDomains) = unat Kernel_C.numDomains" by (simp add: scast_eq sint_numDomains_to_H unat_numDomains_to_H numDomains_machine_word_safe) -end -end +lemma msgRegisters_size_sanity: + "size_msgRegisters = unat (n_msgRegisters)" + by (simp add: n_msgRegisters_def size_msgRegisters_def) +end +end diff --git a/proof/crefine/ARM/Syscall_C.thy b/proof/crefine/ARM/Syscall_C.thy index a36e69f84..79bd843bb 100644 --- a/proof/crefine/ARM/Syscall_C.thy +++ b/proof/crefine/ARM/Syscall_C.thy @@ -1131,22 +1131,6 @@ lemma deleteCallerCap_ccorres [corres]: tcb_aligned') done - -(* FIXME: MOVE *) -lemma cap_case_EndpointCap_NotificationCap: - "(case cap of EndpointCap v0 v1 v2 v3 v4 v5 \ f v0 v1 v2 v3 v4 v5 - | 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) (capEPCanGrantReply 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) - - lemma invs_valid_objs_strengthen: "invs' s \ valid_objs' s" by fastforce diff --git a/proof/crefine/ARM/Tcb_C.thy b/proof/crefine/ARM/Tcb_C.thy index 0c99f5426..0653a4d08 100644 --- a/proof/crefine/ARM/Tcb_C.thy +++ b/proof/crefine/ARM/Tcb_C.thy @@ -8,17 +8,6 @@ theory Tcb_C imports Delete_C Ipc_C begin -lemma asUser_obj_at' : - "\ K(t\t') and obj_at' P t' \ asUser t f \ \_. obj_at' (P::Structures_H.tcb \ bool) t' \" - including no_pre - apply (simp add: asUser_def) - apply wp - apply (case_tac "t=t'"; clarsimp) - apply (rule hoare_drop_imps) - apply wp - done - - lemma getObject_sched: "(x::tcb, s') \ fst (getObject t s) \ (x,s'\ksSchedulerAction := ChooseNewThread\) \ fst (getObject t (s\ksSchedulerAction := ChooseNewThread\))" diff --git a/proof/crefine/ARM/VSpace_C.thy b/proof/crefine/ARM/VSpace_C.thy index 2f471ea41..6059a527a 100644 --- a/proof/crefine/ARM/VSpace_C.thy +++ b/proof/crefine/ARM/VSpace_C.thy @@ -786,18 +786,6 @@ lemma lookupPTSlot_ccorres: split: ARM_H.pde.split_asm) done -lemma cap_case_isPageDirectoryCap: - "(case cap of capability.ArchObjectCap (arch_capability.PageDirectoryCap pd ( Some asid)) \ fn pd asid - | _ => g) - = (if ( if (isArchObjectCap cap) then if (isPageDirectoryCap (capCap cap)) then capPDMappedASID (capCap cap) \ None else False else False) - then fn (capPDBasePtr (capCap cap)) (the ( capPDMappedASID (capCap cap))) else g)" - apply (cases cap; simp add: isArchObjectCap_def) - apply (rename_tac arch_capability) - apply (case_tac arch_capability, simp_all add: isPageDirectoryCap_def) - apply (rename_tac option) - apply (case_tac option; simp) - done - (* FIXME: MOVE to CSpaceAcc_C *) lemma ccorres_pre_gets_armKSASIDTable_ksArchState: assumes cc: "\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c" diff --git a/proof/crefine/ARM_HYP/ArchMove_C.thy b/proof/crefine/ARM_HYP/ArchMove_C.thy index 6639658be..b690e7d5b 100644 --- a/proof/crefine/ARM_HYP/ArchMove_C.thy +++ b/proof/crefine/ARM_HYP/ArchMove_C.thy @@ -231,18 +231,6 @@ lemma empty_fail_archThreadGet [intro!, wp, simp]: "empty_fail (archThreadGet f p)" by (simp add: archThreadGet_def getObject_def split_def) -lemma cap_case_EndpointCap_NotificationCap: - "(case cap of EndpointCap v0 v1 v2 v3 v4 v5 \ f v0 v1 v2 v3 v4 v5 - | 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) (capEPCanGrantReply 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, blast) - lemma mab_gt_2 [simp]: "2 \ msg_align_bits" by (simp add: msg_align_bits) @@ -583,6 +571,83 @@ lemma valid_untyped': nat_le_linear power_overflow sub_wrap add_0 add_0_right word_add_increasing word_less_1 word_less_sub_1) +(* We don't have access to n_msgRegisters from C here, but the number of msg registers in C should + be equivalent to what we have in the abstract/design specs. We want a number for this definition + that automatically updates if the number of registers changes, and we sanity check it later + in msgRegisters_size_sanity *) +definition size_msgRegisters :: nat where + size_msgRegisters_pre_def: "size_msgRegisters \ size (ARM_HYP.msgRegisters)" + +schematic_goal size_msgRegisters_def: + "size_msgRegisters = numeral ?x" + unfolding size_msgRegisters_pre_def ARM_HYP.msgRegisters_def + by (simp add: upto_enum_red fromEnum_def enum_register del: Suc_eq_numeral) + (simp only: Suc_eq_plus1_left, simp del: One_nat_def) + +lemma length_msgRegisters[simplified size_msgRegisters_def]: + "length ARM_HYP_H.msgRegisters = size_msgRegisters" + by (simp add: size_msgRegisters_pre_def ARM_HYP_H.msgRegisters_def) + +lemma cap_case_isPageDirectoryCap: + "(case cap of capability.ArchObjectCap (arch_capability.PageDirectoryCap pd ( Some asid)) \ fn pd asid + | _ => g) + = (if ( if (isArchObjectCap cap) then if (isPageDirectoryCap (capCap cap)) then capPDMappedASID (capCap cap) \ None else False else False) + then fn (capPDBasePtr (capCap cap)) (the ( capPDMappedASID (capCap cap))) else g)" + apply (cases cap; simp add: isArchObjectCap_def) + apply (rename_tac arch_capability) + apply (case_tac arch_capability, simp_all add: isPageDirectoryCap_def) + apply (rename_tac option) + apply (case_tac option; simp) + done + +lemma empty_fail_loadWordUser[intro!, simp]: + "empty_fail (loadWordUser x)" + by (simp add: loadWordUser_def ef_loadWord ef_dmo') + +lemma empty_fail_getMRs[iff]: + "empty_fail (getMRs t buf mi)" + by (auto simp add: getMRs_def split: option.split) + +lemma empty_fail_getReceiveSlots: + "empty_fail (getReceiveSlots r rbuf)" +proof - + note + empty_fail_assertE[iff] + empty_fail_resolveAddressBits[iff] + show ?thesis + apply (clarsimp simp: getReceiveSlots_def loadCapTransfer_def split_def + split: option.split) + apply (rule empty_fail_bind) + apply (simp add: capTransferFromWords_def) + apply (simp add: emptyOnFailure_def unifyFailure_def) + apply (intro empty_fail_catch empty_fail_bindE empty_fail_rethrowFailure, + simp_all add: empty_fail_whenEs) + apply (simp_all add: lookupCap_def split_def lookupCapAndSlot_def + lookupSlotForThread_def liftME_def + getThreadCSpaceRoot_def locateSlot_conv bindE_assoc + lookupSlotForCNodeOp_def lookupErrorOnFailure_def + cong: if_cong) + apply (intro empty_fail_bindE, + simp_all add: getSlotCap_def) + apply (intro empty_fail_If empty_fail_bindE empty_fail_rethrowFailure impI, + simp_all add: empty_fail_whenEs rangeCheck_def) + done +qed + +lemma user_getreg_rv: + "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb r)) t\ asUser t (getRegister r) \\rv s. P rv\" + apply (simp add: asUser_def split_def) + apply (wp threadGet_wp) + apply (clarsimp simp: obj_at'_def projectKOs getRegister_def in_monad atcbContextGet_def) + done + +crunches insertNewCap, Arch_createNewCaps, threadSet, Arch.createObject, setThreadState, + updateFreeIndex, preemptionPoint + for gsCNodes[wp]: "\s. P (gsCNodes s)" + (wp: crunch_wps setObject_ksPSpace_only + simp: unless_def updateObject_default_def crunch_simps + ignore_del: preemptionPoint) + end end diff --git a/proof/crefine/ARM_HYP/CLevityCatch.thy b/proof/crefine/ARM_HYP/CLevityCatch.thy index 741c748dd..37a25da20 100644 --- a/proof/crefine/ARM_HYP/CLevityCatch.thy +++ b/proof/crefine/ARM_HYP/CLevityCatch.thy @@ -60,14 +60,6 @@ lemma no_overlap_new_cap_addrs_disjoint: declare empty_fail_doMachineOp [simp] -lemma empty_fail_loadWordUser[intro!, simp]: - "empty_fail (loadWordUser x)" - by (simp add: loadWordUser_def ef_loadWord) - -lemma empty_fail_getMRs[iff]: - "empty_fail (getMRs t buf mi)" - by (auto simp add: getMRs_def split: option.split) - lemma empty_fail_getExtraCPtrs [intro!, simp]: "empty_fail (getExtraCPtrs sendBuffer info)" apply (simp add: getExtraCPtrs_def) @@ -114,32 +106,6 @@ lemma asUser_get_registers: obj_at'_def) done -lemma empty_fail_getReceiveSlots: - "empty_fail (getReceiveSlots r rbuf)" -proof - - note - empty_fail_assertE[iff] - empty_fail_resolveAddressBits[iff] - show ?thesis - apply (clarsimp simp: getReceiveSlots_def loadCapTransfer_def split_def - split: option.split) - apply (rule empty_fail_bind) - apply (simp add: capTransferFromWords_def) - apply (simp add: emptyOnFailure_def unifyFailure_def) - apply (intro empty_fail_catch empty_fail_bindE empty_fail_rethrowFailure, - simp_all add: empty_fail_whenEs) - apply (simp_all add: lookupCap_def split_def lookupCapAndSlot_def - lookupSlotForThread_def liftME_def - getThreadCSpaceRoot_def locateSlot_conv bindE_assoc - lookupSlotForCNodeOp_def lookupErrorOnFailure_def - cong: if_cong) - apply (intro empty_fail_bindE, - simp_all add: getSlotCap_def) - apply (intro empty_fail_If empty_fail_bindE empty_fail_rethrowFailure impI, - simp_all add: empty_fail_whenEs rangeCheck_def) - done -qed - lemma exec_Basic_Guard_UNIV: "Semantic.exec \ (Basic f;; Guard F UNIV (Basic g)) x y = Semantic.exec \ (Basic (g o f)) x y" @@ -171,4 +137,12 @@ lemma option_to_ptr_not_0: "\ p \ 0 ; option_to_ptr v = Ptr p \ \ v = Some p" by (clarsimp simp: option_to_ptr_def option_to_0_def split: option.splits) +schematic_goal sz8_helper: + "((-1) << 8 :: addr) = ?v" + by (simp add: shiftl_t2n) + +lemmas reset_name_seq_bound_helper2 + = reset_name_seq_bound_helper[where sz=8 and v="v :: addr" for v, + simplified sz8_helper word_bits_def[symmetric], + THEN name_seq_bound_helper] end diff --git a/proof/crefine/ARM_HYP/CSpaceAcc_C.thy b/proof/crefine/ARM_HYP/CSpaceAcc_C.thy index bf8166ed8..2c9271b7f 100644 --- a/proof/crefine/ARM_HYP/CSpaceAcc_C.thy +++ b/proof/crefine/ARM_HYP/CSpaceAcc_C.thy @@ -188,9 +188,6 @@ lemma ccorres_pre_getIdleThread: done -lemma cd_wp [wp]: "\\s. P (ksCurDomain s) s\ curDomain \P\" - by (unfold curDomain_def, wp) - lemma curDomain_sp: "\P\ curDomain \\rv s. ksCurDomain s = rv \ P s\" apply wp diff --git a/proof/crefine/ARM_HYP/CSpace_RAB_C.thy b/proof/crefine/ARM_HYP/CSpace_RAB_C.thy index 1df1e94e6..08d01c0af 100644 --- a/proof/crefine/ARM_HYP/CSpace_RAB_C.thy +++ b/proof/crefine/ARM_HYP/CSpace_RAB_C.thy @@ -92,14 +92,6 @@ lemma ccorres_req: apply (clarsimp elim!: bexI [rotated]) done -lemma valid_cap_cte_at': - "\isCNodeCap cap; valid_cap' cap s'\ \ cte_at' (capCNodePtr cap + 2^cteSizeBits * (addr && mask (capCNodeBits cap))) s'" - apply (clarsimp simp: isCap_simps valid_cap'_def) - apply (rule real_cte_at') - apply (erule spec) - done - - lemma rightsFromWord_wordFromRights: "rightsFromWord (wordFromRights rghts) = rghts" apply (cases rghts) diff --git a/proof/crefine/ARM_HYP/Fastpath_C.thy b/proof/crefine/ARM_HYP/Fastpath_C.thy index 6d4f2cb78..8f25ce055 100644 --- a/proof/crefine/ARM_HYP/Fastpath_C.thy +++ b/proof/crefine/ARM_HYP/Fastpath_C.thy @@ -4,163 +4,20 @@ * SPDX-License-Identifier: GPL-2.0-only *) +(* Proof that the C fast path functions are refinements of their design + specifications in Fastpath_Defs. *) + theory Fastpath_C imports SyscallArgs_C Delete_C Syscall_C - "Refine.RAB_FN" + Fastpath_Defs "CLib.MonadicRewrite_C" begin context begin interpretation Arch . (*FIXME: arch_split*) -definition - "fastpaths sysc \ case sysc of - SysCall \ doE - curThread \ liftE $ getCurThread; - mi \ liftE $ getMessageInfo curThread; - cptr \ liftE $ asUser curThread $ getRegister capRegister; - - fault \ liftE $ threadGet tcbFault curThread; - pickFastpath \ liftE $ alternative (return True) (return False); - unlessE (fault = None \ msgExtraCaps mi = 0 - \ msgLength mi \ scast n_msgRegisters \ pickFastpath) - $ throwError (); - - ctab \ liftE $ getThreadCSpaceRoot curThread >>= getCTE; - epCap \ unifyFailure (doE t \ resolveAddressBits (cteCap ctab) cptr (size cptr); - liftE (getSlotCap (fst t)) odE); - unlessE (isEndpointCap epCap \ capEPCanSend epCap) - $ throwError (); - ep \ liftE $ getEndpoint (capEPPtr epCap); - unlessE (isRecvEP ep) $ throwError (); - dest \ returnOk $ hd $ epQueue ep; - newVTable \ liftE $ getThreadVSpaceRoot dest >>= getCTE; - unlessE (isValidVTableRoot $ cteCap newVTable) $ throwError (); - pd \ returnOk $ capPDBasePtr $ capCap $ cteCap newVTable; - curDom \ liftE $ curDomain; - curPrio \ liftE $ threadGet tcbPriority curThread; - destPrio \ liftE $ threadGet tcbPriority dest; - highest \ liftE $ isHighestPrio curDom destPrio; - unlessE (destPrio \ curPrio \ highest) $ throwError (); - unlessE (capEPCanGrant epCap \ capEPCanGrantReply epCap) $ throwError (); - asidMap \ liftE $ gets $ armKSASIDMap o ksArchState; - unlessE (\v. {hwasid. (hwasid, pd) \ ran asidMap} = {v}) - $ throwError (); - destDom \ liftE $ threadGet tcbDomain dest; - unlessE (destDom = curDom) $ throwError (); - - liftE $ do - setEndpoint (capEPPtr epCap) - (case tl (epQueue ep) of [] \ IdleEP | _ \ RecvEP (tl (epQueue ep))); - threadSet (tcbState_update (\_. BlockedOnReply)) curThread; - replySlot \ getThreadReplySlot curThread; - callerSlot \ getThreadCallerSlot dest; - replySlotCTE \ getCTE replySlot; - assert (mdbNext (cteMDBNode replySlotCTE) = 0 - \ isReplyCap (cteCap replySlotCTE) - \ capReplyMaster (cteCap replySlotCTE) - \ mdbFirstBadged (cteMDBNode replySlotCTE) - \ mdbRevocable (cteMDBNode replySlotCTE)); - destState \ getThreadState dest; - cteInsert (ReplyCap curThread False (blockingIPCCanGrant destState)) replySlot callerSlot; - - forM_x (take (unat (msgLength mi)) ARM_HYP_H.msgRegisters) - (\r. do v \ asUser curThread (getRegister r); - asUser dest (setRegister r v) od); - setThreadState Running dest; - Arch.switchToThread dest; - setCurThread dest; - - asUser dest $ zipWithM_x setRegister - [ARM_HYP_H.badgeRegister, ARM_HYP_H.msgInfoRegister] - [capEPBadge epCap, wordFromMessageInfo (mi\ msgCapsUnwrapped := 0 \)]; - - stateAssert kernelExitAssertions [] - od - - odE (\_. callKernel (SyscallEvent sysc)) - | SysReplyRecv \ doE - curThread \ liftE $ getCurThread; - mi \ liftE $ getMessageInfo curThread; - cptr \ liftE $ asUser curThread $ getRegister capRegister; - - fault \ liftE $ threadGet tcbFault curThread; - pickFastpath \ liftE $ alternative (return True) (return False); - unlessE (fault = None \ msgExtraCaps mi = 0 - \ msgLength mi \ scast n_msgRegisters \ pickFastpath) - $ throwError (); - - ctab \ liftE $ getThreadCSpaceRoot curThread >>= getCTE; - epCap \ unifyFailure (doE t \ resolveAddressBits (cteCap ctab) cptr (size cptr); - liftE (getSlotCap (fst t)) odE); - - unlessE (isEndpointCap epCap \ capEPCanReceive epCap) - $ throwError (); - - bound_ntfn \ liftE $ getBoundNotification curThread; - active_ntfn \ liftE $ case bound_ntfn of None \ return False - | Some ntfnptr \ liftM isActive $ getNotification ntfnptr; - unlessE (\ active_ntfn) $ throwError (); - - ep \ liftE $ getEndpoint (capEPPtr epCap); - unlessE (\ isSendEP ep) $ throwError (); - - callerSlot \ liftE $ getThreadCallerSlot curThread; - callerCTE \ liftE $ getCTE callerSlot; - callerCap \ returnOk $ cteCap callerCTE; - unlessE (isReplyCap callerCap \ \ capReplyMaster callerCap) - $ throwError (); - - caller \ returnOk $ capTCBPtr callerCap; - callerFault \ liftE $ threadGet tcbFault caller; - unlessE (callerFault = None) $ throwError (); - newVTable \ liftE $ getThreadVSpaceRoot caller >>= getCTE; - unlessE (isValidVTableRoot $ cteCap newVTable) $ throwError (); - - curDom \ liftE $ curDomain; - callerPrio \ liftE $ threadGet tcbPriority caller; - highest \ liftE $ isHighestPrio curDom callerPrio; - unlessE highest $ throwError (); - - pd \ returnOk $ capPDBasePtr $ capCap $ cteCap newVTable; - asidMap \ liftE $ gets $ armKSASIDMap o ksArchState; - unlessE (\v. {hwasid. (hwasid, pd) \ ran asidMap} = {v}) - $ throwError (); - callerDom \ liftE $ threadGet tcbDomain caller; - unlessE (callerDom = curDom) $ throwError (); - - liftE $ do - epCanGrant \ return $ capEPCanGrant epCap; - threadSet (tcbState_update (\_. BlockedOnReceive (capEPPtr epCap) epCanGrant)) curThread; - setEndpoint (capEPPtr epCap) - (case ep of IdleEP \ RecvEP [curThread] | RecvEP ts \ RecvEP (ts @ [curThread])); - mdbPrev \ liftM (mdbPrev o cteMDBNode) $ getCTE callerSlot; - assert (mdbPrev \ 0); - updateMDB mdbPrev (mdbNext_update (K 0) o mdbFirstBadged_update (K True) - o mdbRevocable_update (K True)); - setCTE callerSlot makeObject; - - forM_x (take (unat (msgLength mi)) ARM_HYP_H.msgRegisters) - (\r. do v \ asUser curThread (getRegister r); - asUser caller (setRegister r v) od); - setThreadState Running caller; - Arch.switchToThread caller; - setCurThread caller; - - asUser caller $ zipWithM_x setRegister - [ARM_HYP_H.badgeRegister, ARM_HYP_H.msgInfoRegister] - [0, wordFromMessageInfo (mi\ msgCapsUnwrapped := 0 \)]; - - stateAssert kernelExitAssertions [] - od - - odE (\_. callKernel (SyscallEvent sysc)) - - | _ \ callKernel (SyscallEvent sysc)" - - lemma setCTE_obj_at'_queued: "\obj_at' (\tcb. P (tcbQueued tcb)) t\ setCTE p v \\rv. obj_at' (\tcb. P (tcbQueued tcb)) t\" unfolding setCTE_def @@ -253,10 +110,6 @@ end context kernel_m begin -lemma capMasterCap_NullCap_eq: - "(capMasterCap c = NullCap) = (c = NullCap)" - by (auto dest!: capMasterCap_eqDs) - lemma getCTE_h_val_ccorres_split: assumes var: "\s f s'. var (var_update f s) = f (var s) \ ((s', var_update f s) \ rf_sr) = ((s', s) \ rf_sr)" @@ -346,11 +199,6 @@ lemma ccorres_abstract_all: declare of_int_sint_scast[simp] -lemma stateAssert_bind_out_of_if: - "If P f (stateAssert Q xs >>= g) = stateAssert (\s. \ P \ Q s) [] >>= (\_. If P f (g ()))" - "If P (stateAssert Q xs >>= g) f = stateAssert (\s. P \ Q s) [] >>= (\_. If P (g ()) f)" - by (simp_all add: fun_eq_iff stateAssert_def exec_get split: if_split) - lemma isCNodeCap_capUntypedPtr_capCNodePtr: "isCNodeCap c \ capUntypedPtr c = capCNodePtr c" by (clarsimp simp: isCap_simps) @@ -404,10 +252,10 @@ lemma lookup_fp_ccorres': have sub_mask_neq_0_eq: "\v :: word32. v && 0x1F \ 0 \ 0x20 - (0x20 - (v && 0x1F) && mask 5) = v && 0x1F" apply (subst word_le_mask_eq) - apply (simp only: mask_def) - apply (rule word_le_minus_mono, simp_all add: word_le_sub1 word_sub_le_iff)[1] - apply (rule order_trans, rule word_and_le1, simp) - apply simp + apply (simp only: mask_def) + apply (rule word_le_minus_mono, simp_all add: word_le_sub1 word_sub_le_iff)[1] + apply (rule order_trans, rule word_and_le1, simp) + apply (simp add: word_bits_def) done have valid_cnode_bits_0: @@ -419,7 +267,7 @@ lemma lookup_fp_ccorres': by (simp add: cap_get_tag_def cong: if_cong) show ?case - supply if_cong[cong] + supply if_cong[cong] option.case_cong[cong] apply (cinitlift cap_' bits_') apply (rename_tac cbits ccap) apply (elim conjE) @@ -512,7 +360,7 @@ lemma lookup_fp_ccorres': apply (rule ccorres_cutMon) apply (simp add: cutMon_walk_bindE unlessE_whenE del: Collect_const - cong: call_ignore_cong) + split del: if_split cong: call_ignore_cong) apply (rule ccorres_drop_cutMon_bindE) apply csymbr+ apply (rule ccorres_rhs_assoc2) @@ -653,14 +501,14 @@ lemma lookup_fp_ccorres': apply (simp add: word_bw_assocs mask_and_mask min.absorb2) apply (simp_all add: unat_sub word_le_nat_alt unat_eq_0[symmetric]) apply (simp_all add: unat_plus_if' if_P) - apply (clarsimp simp: rightsFromWord_and shiftr_over_and_dist + apply (clarsimp simp: shiftr_over_and_dist size_of_def cte_level_bits_def field_simps shiftl_shiftl shiftl_shiftr3 word_size)+ apply (clarsimp simp: unat_gt_0 from_bool_0 trans [OF eq_commute from_bool_eq_if]) apply (intro conjI impI, simp_all)[1] apply (rule word_unat.Rep_inject[THEN iffD1], subst unat_plus_if') apply (simp add: unat_plus_if' unat_of_nat32 word_bits_def) - apply (clarsimp simp: rightsFromWord_and shiftr_over_and_dist + apply (clarsimp simp: shiftr_over_and_dist size_of_def cte_level_bits_def field_simps shiftl_shiftl shiftl_shiftr3 word_size)+ apply (clarsimp simp: unat_gt_0 from_bool_0 trans [OF eq_commute from_bool_eq_if]) @@ -680,31 +528,6 @@ lemma ccap_relation_case_sum_Null_endpoint: by (clarsimp simp: cap_get_tag_isCap isRight_def isCap_simps split: sum.split_asm) -lemma findPDForASID_pd_at_asid_noex: - "\pd_at_asid' pd asid\ findPDForASID asid \\rv s. rv = pd\,\\\\" - apply (simp add: findPDForASID_def - liftME_def bindE_assoc - cong: option.case_cong) - apply (rule seqE, rule assertE_sp)+ - apply (rule seqE, rule liftE_wp, rule gets_sp) - apply (rule hoare_pre) - apply (rule seqE[rotated]) - apply wpc - apply wp - apply (rule seqE[rotated]) - apply (rule seqE[rotated]) - apply (rule returnOk_wp) - apply (simp add:checkPDAt_def) - apply wp - apply (rule assertE_wp) - apply wpc - apply wp - apply (rule liftE_wp) - apply (rule getASID_wp) - apply (clarsimp simp: pd_at_asid'_def obj_at'_def projectKOs - inv_ASIDPool) - done - lemma ccorres_catch_bindE_symb_exec_l: "\ \s. \(=) s\ f \\rv. (=) s\; empty_fail f; \rv. ccorres_underlying sr G r xf ar axf (Q rv) (Q' rv) hs (catch (g rv) h >>= j) c; @@ -724,32 +547,6 @@ lemma ccorres_catch_bindE_symb_exec_l: apply clarsimp done -lemmas ccorres_catch_symb_exec_l - = ccorres_catch_bindE_symb_exec_l[where g=returnOk, - simplified bindE_returnOk returnOk_catch_bind] - - -lemma ccorres_alt_rdonly_bind: - "\ ccorres_underlying sr Gamm r xf arrel axf A A' hs - (f >>= (\x. alternative (g x) h)) c; - \s. \(=) s\ f \\rv. (=) s\; empty_fail f \ - \ ccorres_underlying sr Gamm r xf arrel axf A A' hs - (alternative (f >>= (\x. g x)) h) c" - apply (rule ccorresI') - apply (erule(3) ccorresE) - defer - apply assumption - apply (subst alternative_left_readonly_bind, assumption) - apply (rule notI, drule(1) empty_failD) - apply (simp add: alternative_def bind_def) - apply fastforce - apply (subgoal_tac "\x \ fst (f s). snd x = s") - apply (simp add: bind_def alternative_def image_image split_def - cong: image_cong) - apply clarsimp - apply (drule use_valid, assumption, simp+) - done - definition "pd_has_hwasid pd = (\s. \v. asid_map_pd_to_hwasids (armKSASIDMap (ksArchState s)) pd = {v})" @@ -826,113 +623,6 @@ lemmas stored_hw_asid_get_ccorres_split = stored_hw_asid_get_ccorres_split'[OF refl] stored_hw_asid_get_ccorres_split'[OF ptr_add_0x7F8] -lemma doMachineOp_pd_at_asid': - "\\s. P (pd_at_asid' pd asid s)\ doMachineOp oper \\rv s. P (pd_at_asid' pd asid s)\" - apply (simp add: doMachineOp_def split_def) - apply wp - apply (clarsimp simp: pd_at_asid'_def) - done - -lemma doMachineOp_page_directory_at_P': - "\\s. P (page_directory_at' pd s)\ doMachineOp oper \\rv s. P (page_directory_at' pd s)\" - apply (simp add: doMachineOp_def split_def) - apply wp - apply (clarsimp simp: pd_at_asid'_def) - done - -lemma pde_stored_asid_Some: - "(pde_stored_asid pde = Some v) - = (pde_get_tag pde = scast pde_pde_invalid - \ to_bool (stored_asid_valid_CL (pde_pde_invalid_lift pde)) - \ v = ucast (stored_hw_asid_CL (pde_pde_invalid_lift pde)))" - by (auto simp add: pde_stored_asid_def split: if_split) - -lemma pointerInUserData_c_guard': - "\ pointerInUserData ptr s; no_0_obj' s; is_aligned ptr 2 \ - \ c_guard (Ptr ptr :: word32 ptr)" - apply (simp add: pointerInUserData_def) - apply (simp add: c_guard_def ptr_aligned_def) - apply (rule conjI) - apply (simp add: is_aligned_def) - apply (simp add: c_null_guard_def) - apply (subst intvl_aligned_bottom_eq[where n=2 and bits=2], simp_all) - apply clarsimp - done - -lemma heap_relation_user_word_at_cross_over: - "\ user_word_at x p s; cmap_relation (heap_to_user_data (ksPSpace s) - (underlying_memory (ksMachineState s))) (cslift s') Ptr cuser_user_data_relation; - p' = Ptr p \ - \ c_guard p' \ hrs_htd (t_hrs_' (globals s')) \\<^sub>t p' - \ h_val (hrs_mem (t_hrs_' (globals s'))) p' = x" - apply (erule cmap_relationE1) - apply (clarsimp simp: heap_to_user_data_def Let_def - user_word_at_def pointerInUserData_def - typ_at_to_obj_at'[where 'a=user_data, simplified]) - apply (drule obj_at_ko_at', clarsimp) - apply (rule conjI, rule exI, erule ko_at_projectKO_opt) - apply (rule refl) - apply (thin_tac "heap_to_user_data a b c = d" for a b c d) - apply (cut_tac x=p and w="~~ mask pageBits" in word_plus_and_or_coroll2) - apply (rule conjI) - apply (clarsimp simp: user_word_at_def pointerInUserData_def) - apply (simp add: c_guard_def c_null_guard_def ptr_aligned_def) - apply (drule lift_t_g) - apply (clarsimp simp: ) - apply (simp add: align_of_def user_data_C_size_of user_data_C_align_of - size_of_def user_data_C_typ_name) - apply (fold is_aligned_def[where n=2, simplified], simp) - apply (erule contra_subsetD[rotated]) - apply (rule order_trans[rotated]) - apply (rule_tac x="p && mask pageBits" and y=4 in intvl_sub_offset) - apply (cut_tac y=p and a="mask pageBits && (~~ mask 2)" in word_and_le1) - apply (subst(asm) word_bw_assocs[symmetric], subst(asm) is_aligned_neg_mask_eq, - erule is_aligned_andI1) - apply (simp add: word_le_nat_alt mask_def pageBits_def) - apply simp - apply (clarsimp simp: cuser_user_data_relation_def user_word_at_def) - apply (frule_tac f="[''words_C'']" in h_t_valid_field[OF h_t_valid_clift], - simp+) - apply (drule_tac n="uint (p && mask pageBits >> 2)" in h_t_valid_Array_element) - apply simp - apply (simp add: shiftr_over_and_dist mask_def pageBits_def uint_and) - apply (insert int_and_leR [where a="uint (p >> 2)" and b=1023], clarsimp)[1] - apply (simp add: field_lvalue_def - field_lookup_offset_eq[OF trans, OF _ arg_cong[where f=Some, symmetric], OF _ prod.collapse] - word_shift_by_2 shiftr_shiftl1 is_aligned_neg_mask_eq is_aligned_andI1) - apply (drule_tac x="ucast (p >> 2)" in spec) - apply (simp add: byte_to_word_heap_def Let_def ucast_ucast_mask) - apply (fold shiftl_t2n[where n=2, simplified, simplified mult.commute mult.left_commute]) - apply (simp add: aligned_shiftr_mask_shiftl pageBits_def) - apply (rule trans[rotated], rule_tac hp="hrs_mem (t_hrs_' (globals s'))" - and x="Ptr &(Ptr (p && ~~ mask 12) \ [''words_C''])" - in access_in_array) - apply (rule trans) - apply (erule typ_heap_simps) - apply simp+ - apply (rule order_less_le_trans, rule unat_lt2p) - apply simp - apply (fastforce simp add: typ_info_word) - apply simp - apply (rule_tac f="h_val hp" for hp in arg_cong) - apply simp - apply (simp add: field_lvalue_def) - apply (simp add: ucast_nat_def ucast_ucast_mask) - apply (fold shiftl_t2n[where n=2, simplified, simplified mult.commute mult.left_commute]) - apply (simp add: aligned_shiftr_mask_shiftl) - done - -lemma pointerInUserData_h_t_valid2: - "\ pointerInUserData ptr s; cmap_relation (heap_to_user_data (ksPSpace s) - (underlying_memory (ksMachineState s))) (cslift s') Ptr cuser_user_data_relation; - is_aligned ptr 2 \ - \ hrs_htd (t_hrs_' (globals s')) \\<^sub>t (Ptr ptr :: word32 ptr)" - apply (frule_tac p=ptr in - heap_relation_user_word_at_cross_over[rotated, OF _ refl]) - apply (simp add: user_word_at_def) - apply simp - done - lemma dmo_clearExMonitor_setCurThread_swap: "(do _ \ doMachineOp ARM_HYP.clearExMonitor; setCurThread thread @@ -945,17 +635,6 @@ lemma dmo_clearExMonitor_setCurThread_swap: simp_all add: select_f_oblivious) done -lemma ccorres_bind_assoc_rev: - "ccorres_underlying sr E r xf arrel axf G G' hs ((a1 >>= a2) >>= a3) c - \ ccorres_underlying sr E r xf arrel axf G G' hs - (do x \ a1; y \ a2 x; a3 y od) c" - by (simp add: bind_assoc) - -lemma monadic_rewrite_gets_l: - "(\x. monadic_rewrite F E (P x) (g x) m) - \ monadic_rewrite F E (\s. P (f s) s) (gets f >>= (\x. g x)) m" - by (auto simp add: monadic_rewrite_def exec_gets) - lemma pd_at_asid_inj': "pd_at_asid' pd asid s \ pd_at_asid' pd' asid s \ pd' = pd" by (clarsimp simp: pd_at_asid'_def obj_at'_def) @@ -1034,6 +713,13 @@ lemma pd_has_hwasid_ksMachineState_update[iff]: "pd_has_hwasid pd (ksMachineState_update f s) = pd_has_hwasid pd s" by (simp add: pd_has_hwasid_def) +lemma doMachineOp_pd_at_asid': + "\\s. P (pd_at_asid' pd asid s)\ doMachineOp oper \\rv s. P (pd_at_asid' pd asid s)\" + apply (simp add: doMachineOp_def split_def) + apply wp + apply (clarsimp simp: pd_at_asid'_def) + done + crunches vcpuSwitch for pd_at_asid'[wp]: "pd_at_asid' pd asid" and pd_has_hwasid[wp]: "pd_has_hwasid pd" @@ -1363,14 +1049,6 @@ lemma bind_case_sum_rethrow: apply (simp add: throwError_bind split: sum.split) done -lemma ccorres_alt_rdonly_liftE_bindE: - "\ ccorres_underlying sr Gamm r xf arrel axf A A' hs - (f >>= (\x. alternative (g x) h)) c; - \s. \(=) s\ f \\rv. (=) s\; empty_fail f \ - \ ccorres_underlying sr Gamm r xf arrel axf A A' hs - (alternative (liftE f >>=E (\x. g x)) h) c" - by (simp add: liftE_bindE ccorres_alt_rdonly_bind) - lemma ccorres_pre_getCTE2: "(\rv. ccorresG rf_sr \ r xf (P rv) (P' rv) hs (f rv) c) \ ccorresG rf_sr \ r xf (\s. \cte. ctes_of s p = Some cte \ P cte s) @@ -1494,20 +1172,6 @@ lemma isRecvEP_endpoint_case: "isRecvEP ep \ case_endpoint f g h ep = f (epQueue ep)" by (clarsimp simp: isRecvEP_def split: endpoint.split_asm) -lemma ccorres_cond_both_seq: - "\ \s s'. (s, s') \ sr \ R s \ P s = (s' \ P'); - ccorres_underlying sr \ r xf arrel axf Pt Rt hs a (c ;; d); - ccorres_underlying sr \ r xf arrel axf Pf Rf hs a (c' ;; d) \ - \ ccorres_underlying sr \ r xf arrel axf - (R and (\s. P s \ Pt s) and (\s. \ P s \ Pf s)) - {s. (s \ P' \ s \ Rt) \ (s \ P' \ s \ Rf)} - hs a (Cond P' c c' ;; d)" - apply (subst ccorres_seq_cond_raise) - apply (rule ccorres_guard_imp2, rule ccorres_cond_both, assumption+) - apply auto - done - - lemma unifyFailure_catch_If: "catch (unifyFailure f >>=E g) h = f >>= (\rv. if isRight rv then catch (g (theRight rv)) h else h ())" @@ -1610,11 +1274,6 @@ lemma fastpath_dequeue_ccorres: apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) done -lemma tcb_NextPrev_C_update_swap: - "tcbEPPrev_C_update f (tcbEPNext_C_update g tcb) - = tcbEPNext_C_update g (tcbEPPrev_C_update f tcb)" - by simp - lemma st_tcb_at_not_in_ep_queue: "\ st_tcb_at' P t s; ko_at' ep epptr s; sym_refs (state_refs_of' s); ep \ IdleEP; \ts. P ts \ tcb_st_refs_of' ts = {} \ @@ -1644,20 +1303,6 @@ lemma cntfn_relation_double_fun_upd: = cnotification_relation (mp(a := b, c := d)) ntfn ntfn'" by simp -lemma sym_refs_upd_ko_atD': - "\ ko_at' ko p s; sym_refs ((state_refs_of' s) (p' := S)); p \ p' \ - \ \(x, tp) \ refs_of' (injectKO ko). (x = p' \ (p, symreftype tp) \ S) - \ (x \ p' \ ko_wp_at' (\ko. (p, symreftype tp) \ refs_of' ko)x s)" - apply (clarsimp del: disjCI) - apply (drule ko_at_state_refs_ofD') - apply (drule_tac y=a and tp=b and x=p in sym_refsD[rotated]) - apply simp - apply (case_tac "a = p'") - apply simp - apply simp - apply (erule state_refs_of'_elemD) - done - lemma sym_refs_upd_sD: "\ sym_refs ((state_refs_of' s) (p := S)); valid_pspace' s; ko_at' ko p s; refs_of' (injectKO koEx) = S; @@ -1838,44 +1483,6 @@ lemma fastpath_enqueue_ccorres: apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) done - -lemma ccorres_updateCap [corres]: - fixes ptr :: "cstate \ cte_C ptr" and val :: "cstate \ cap_C" - shows "ccorres dc xfdc \ - ({s. ccap_relation cap (val s)} \ {s. ptr s = Ptr dest}) hs - (updateCap dest cap) - (Basic - (\s. globals_update - (t_hrs_'_update - (hrs_mem_update (heap_update (Ptr &(ptr s\[''cap_C''])) (val s)))) s))" - unfolding updateCap_def - apply (cinitlift ptr) - apply (erule ssubst) - apply (rule ccorres_guard_imp2) - apply (rule ccorres_pre_getCTE) - apply (rule_tac P = "\s. ctes_of s dest = Some rva" in ccorres_from_vcg [where P' = "{s. ccap_relation cap (val s)}"]) - apply (rule allI) - apply (rule conseqPre) - apply vcg - apply clarsimp - apply (rule fst_setCTE [OF ctes_of_cte_at], assumption) - apply (erule bexI [rotated]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (frule (1) rf_sr_ctes_of_clift) - apply (clarsimp simp add: rf_sr_def cstate_relation_def typ_heap_simps - Let_def cpspace_relation_def) - apply (rule conjI) - apply (erule (3) cpspace_cte_relation_upd_capI) - apply (erule_tac t = s' in ssubst) - apply (simp add: heap_to_user_data_def) - apply (rule conjI) - apply (erule (1) setCTE_tcb_case) - apply (simp add: carch_state_relation_def cmachine_state_relation_def - cvariable_array_map_const_add_map_option[where f="tcb_no_ctes_proj"] - typ_heap_simps h_t_valid_clift_Some_iff) - apply clarsimp - done - lemma setCTE_rf_sr: "\ (\, s) \ rf_sr; ctes_of \ ptr = Some cte''; t_hrs_' (globals s') = hrs_mem_update @@ -2007,12 +1614,6 @@ shows apply (simp add: length_msgRegisters n_msgRegisters_def word_bits_def hoare_TrueI)+ done -lemma switchToThread_ksCurThread: - "\\s. P t\ switchToThread t \\rv s. P (ksCurThread s)\" - apply (simp add: switchToThread_def setCurThread_def) - apply (wp | simp)+ - done - lemma updateCap_cte_wp_at_cteMDBNode: "\cte_wp_at' (\cte. P (cteMDBNode cte)) p\ updateCap ptr cap @@ -2142,6 +1743,10 @@ lemma recv_ep_queued_st_tcb_at': apply (clarsimp simp: isBlockedOnReceive_def projectKOs) done +lemma signed_n_msgRegisters_to_H: + "(signed n_msgRegisters :: machine_word) = of_nat size_msgRegisters" + by (simp add: n_msgRegisters_def size_msgRegisters_def) + lemma fastpath_call_ccorres: notes hoare_TrueI[simp] if_cong[cong] option.case_cong[cong] shows "ccorres dc xfdc @@ -2189,6 +1794,7 @@ proof - (* FIXME indentation is wonky in this proof, fix will come in a future patch, hopefully when automatic indentation is improved *) show ?thesis + supply if_cong[cong] option.case_cong[cong] apply (cinit lift: cptr_' msgInfo_') apply (simp add: catch_liftE_bindE unlessE_throw_catch_If unifyFailure_catch_If catch_liftE @@ -2229,7 +1835,7 @@ proof - apply (rule ccorres_alternative1) apply (rule ccorres_if_lhs[rotated]) apply (rule ccorres_inst[where P=\ and P'=UNIV]) - apply simp + apply (solves \simp add: signed_n_msgRegisters_to_H\) apply (simp del: Collect_const cong: call_ignore_cong) apply (elim conjE) apply (rule ccorres_abstract_ksCurThread, ceqv) @@ -2968,7 +2574,7 @@ lemma fastpath_reply_cap_check_ccorres: done lemma fastpath_reply_recv_ccorres: - notes hoare_TrueI[simp] if_cong[cong] option.case_cong[cong] + notes hoare_TrueI[simp] shows "ccorres dc xfdc (\s. invs' s \ ct_in_state' ((=) Running) s \ obj_at' (\tcb. (atcbContextGet o tcbArch) tcb capRegister = cptr @@ -3015,6 +2621,8 @@ lemma fastpath_reply_recv_ccorres: automatic indentation is improved *) show ?thesis using [[goals_limit = 1]] + supply option.case_cong_weak[cong del] + supply if_cong[cong] apply (cinit lift: cptr_' msgInfo_') apply (simp add: catch_liftE_bindE unlessE_throw_catch_If unifyFailure_catch_If catch_liftE @@ -3055,7 +2663,7 @@ lemma fastpath_reply_recv_ccorres: apply (rule ccorres_alternative1) apply (rule ccorres_if_lhs[rotated]) apply (rule ccorres_inst[where P=\ and P'=UNIV]) - apply simp + apply (solves \simp add: signed_n_msgRegisters_to_H\) apply (simp del: Collect_const cong: call_ignore_cong) apply (elim conjE) apply (simp add: getThreadCSpaceRoot_def locateSlot_conv @@ -3361,7 +2969,7 @@ lemma fastpath_reply_recv_ccorres: apply (rule conseqPre, vcg) apply (clarsimp simp: typ_heap_simps' cte_level_bits_def tcbCallerSlot_def size_of_def - tcb_cnode_index_defs tcb_ptr_to_ctcb_ptr_mask) + tcb_cnode_index_defs) apply (clarsimp simp: ccte_relation_def map_option_Some_eq2) apply ceqv apply (rule ccorres_assert) @@ -3394,7 +3002,7 @@ lemma fastpath_reply_recv_ccorres: apply (clarsimp simp: cte_wp_at_ctes_of) apply (rule cmap_relationE1[OF cmap_relation_cte], assumption+) apply (clarsimp simp: typ_heap_simps' split_def tcbCallerSlot_def - tcb_cnode_index_defs tcb_ptr_to_ctcb_ptr_mask + tcb_cnode_index_defs cte_level_bits_def size_of_def packed_heap_update_collapse_hrs) apply (rule setCTE_rf_sr, simp_all add: typ_heap_simps')[1] @@ -3612,1775 +3220,14 @@ lemma fastpath_reply_recv_ccorres: cap_get_tag_isCap mi_from_H_def) apply (intro conjI impI allI ; clarsimp simp: isCap_simps capAligned_def objBits_simps' ccap_relation_pd_helper - cap_get_tag_isCap_ArchObject2 table_bits_defs typ_heap_simps isRight_def + cap_get_tag_isCap_ArchObject2 pdeBits_def typ_heap_simps isRight_def dest!: ptr_val_tcb_ptr_mask2[unfolded objBits_def mask_def, simplified] isValidVTableRootD split: sum.splits) - apply (clarsimp simp: ctcb_relation_def)+ + apply (clarsimp simp: ctcb_relation_def pd_bits_def pde_bits_def)+ done qed -lemmas monadic_rewrite_symb_exec_l' = monadic_rewrite_symb_exec_l'_preserve_names - -lemma possibleSwitchTo_rewrite: - "monadic_rewrite True True - (\s. obj_at' (\tcb. tcbPriority tcb = destPrio \ tcbDomain tcb = destDom) t s - \ ksSchedulerAction s = ResumeCurrentThread - \ ksCurThread s = thread - \ ksCurDomain s = curDom - \ destDom = curDom) - (possibleSwitchTo t) (setSchedulerAction (SwitchToThread t))" - apply (simp add: possibleSwitchTo_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_symb_exec_l'[OF threadGet_inv empty_fail_threadGet, - where P'=\], simp) - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac P="targetDom = curDom" in monadic_rewrite_gen_asm) - apply simp - apply (rule_tac P="action = ResumeCurrentThread" in monadic_rewrite_gen_asm) - apply simp - apply (rule monadic_rewrite_refl) - apply (wp threadGet_wp cd_wp |simp add: bitmap_fun_defs)+ - apply (simp add: getCurThread_def curDomain_def gets_bind_ign getSchedulerAction_def) - apply (rule monadic_rewrite_refl) - apply clarsimp - apply (auto simp: obj_at'_def) - done - -lemma scheduleSwitchThreadFastfail_False_wp: - "\\s. ct \ it \ cprio \ tprio \ - scheduleSwitchThreadFastfail ct it cprio tprio - \\rv s. \ rv \" - unfolding scheduleSwitchThreadFastfail_def - by (wp threadGet_wp) - (auto dest!: obj_at_ko_at' simp: le_def obj_at'_def) - -lemma lookupBitmapPriority_lift: - assumes prqL1: "\P. \\s. P (ksReadyQueuesL1Bitmap s)\ f \\_ s. P (ksReadyQueuesL1Bitmap s)\" - and prqL2: "\P. \\s. P (ksReadyQueuesL2Bitmap s)\ f \\_ s. P (ksReadyQueuesL2Bitmap s)\" - shows "\\s. P (lookupBitmapPriority d s) \ f \\_ s. P (lookupBitmapPriority d s) \" - unfolding lookupBitmapPriority_def - apply (rule hoare_pre) - apply (wps prqL1 prqL2) - apply wpsimp+ - done - -lemma lookupBitmapPriority_Max_strengthen: - "\ valid_bitmapQ s ; bitmapQ_no_L1_orphans s ; ksReadyQueuesL1Bitmap s d \ 0 ; - P (Max {prio. ksReadyQueues s (d, prio) \ []})\ - \ P (lookupBitmapPriority d s)" - by (clarsimp simp: lookupBitmapPriority_Max_eqI) - -(* slow path additionally requires current thread not idle *) -definition - "fastpathBestSwitchCandidate t \ \s. - ksReadyQueuesL1Bitmap s (ksCurDomain s) = 0 - \ (\tprio. obj_at' (\tcb. tcbPriority tcb = tprio) t s - \ (obj_at' (\tcb. tcbPriority tcb \ tprio) (ksCurThread s) s - \ lookupBitmapPriority (ksCurDomain s) s \ tprio))" - -lemma fastpathBestSwitchCandidateI: - "\ ksReadyQueuesL1Bitmap s (ksCurDomain s) = 0 - \ tcbPriority ctcb \ tcbPriority ttcb - \ lookupBitmapPriority (ksCurDomain s) s \ tcbPriority ttcb; - ko_at' ttcb t s; ko_at' ctcb (ksCurThread s) s\ - \ fastpathBestSwitchCandidate t s" - unfolding fastpathBestSwitchCandidate_def - by normalise_obj_at' - -lemma fastpathBestSwitchCandidate_lift: - assumes ct[wp]: "\P. \\s. P (ksCurThread s) \ f \ \_ s. P (ksCurThread s) \" - assumes cd[wp]: "\P. \\s. P (ksCurDomain s) \ f \ \_ s. P (ksCurDomain s) \" - assumes l1[wp]: "\P. \\s. P (ksReadyQueuesL1Bitmap s) \ f \ \_ s. P (ksReadyQueuesL1Bitmap s) \" - assumes l2[wp]: "\P. \\s. P (ksReadyQueuesL2Bitmap s) \ f \ \_ s. P (ksReadyQueuesL2Bitmap s) \" - assumes p[wp]: "\P t. \ obj_at' (\tcb. P (tcbPriority tcb)) t \ f \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t \" - shows "\ tcb_at' t and fastpathBestSwitchCandidate t \ f \\rv. fastpathBestSwitchCandidate t \" - unfolding fastpathBestSwitchCandidate_def lookupBitmapPriority_def l1IndexToPrio_def - apply (rule hoare_pre) - apply (rule hoare_lift_Pf2[where f=ksCurDomain]) - apply (wp hoare_vcg_disj_lift hoare_vcg_all_lift) - apply (rule hoare_lift_Pf2[where f=ksCurThread]) - apply (rule hoare_lift_Pf2[where f=ksReadyQueuesL1Bitmap]) - apply (rule hoare_lift_Pf2[where f=ksReadyQueuesL2Bitmap]) - apply (wp hoare_vcg_imp_lift') - apply (strengthen not_obj_at'_strengthen) - apply (wpsimp simp: comp_def wp: l1 l2 hoare_vcg_disj_lift)+ - apply (drule (1) tcb_at_not_obj_at_elim'[rotated]) - apply (rename_tac tprio, erule_tac x=tprio in allE) - apply clarsimp - apply (drule (1) tcb_at_not_obj_at_elim'[rotated]) - apply (clarsimp simp: obj_at'_def) - done - -lemma fastpathBestSwitchCandidate_ksSchedulerAction_simp[simp]: - "fastpathBestSwitchCandidate t (s\ksSchedulerAction := a\) - = fastpathBestSwitchCandidate t s" - unfolding fastpathBestSwitchCandidate_def lookupBitmapPriority_def - by simp - -lemma schedule_rewrite_ct_not_runnable': - "monadic_rewrite True True - (\s. ksSchedulerAction s = SwitchToThread t \ ct_in_state' (Not \ runnable') s - \ (ksCurThread s \ ksIdleThread s) - \ fastpathBestSwitchCandidate t s) - (schedule) - (do setSchedulerAction ResumeCurrentThread; switchToThread t od)" - supply subst_all [simp del] - apply (simp add: schedule_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac P="action = SwitchToThread t" in monadic_rewrite_gen_asm, simp) - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac P="\ wasRunnable \ action = SwitchToThread t" - in monadic_rewrite_gen_asm,simp) - apply (rule monadic_rewrite_bind_tail, rename_tac idleThread) - apply (rule monadic_rewrite_bind_tail, rename_tac targetPrio) - apply (rule monadic_rewrite_bind_tail, rename_tac curPrio) - apply (rule monadic_rewrite_bind_tail, rename_tac fastfail) - apply (rule monadic_rewrite_bind_tail, rename_tac curDom) - apply (rule monadic_rewrite_bind_tail, rename_tac highest) - apply (rule_tac P="\ (fastfail \ \ highest)" in monadic_rewrite_gen_asm, simp only:) - apply simp - apply (rule monadic_rewrite_refl) - apply (wpsimp wp: hoare_vcg_imp_lift) - apply (simp add: isHighestPrio_def') - apply wp+ - apply (wp hoare_vcg_disj_lift) - apply (wp scheduleSwitchThreadFastfail_False_wp) - apply (wp hoare_vcg_disj_lift threadGet_wp'' | simp add: comp_def)+ - (* remove no-ops, somewhat by magic *) - apply (rule monadic_rewrite_symb_exec_l'_TT, solves wp, - wpsimp wp: empty_fail_isRunnable simp: isHighestPrio_def')+ - apply (simp add: setSchedulerAction_def) - apply (subst oblivious_modify_swap[symmetric], rule oblivious_switchToThread_schact) - apply (rule monadic_rewrite_refl) - apply wp+ - apply (clarsimp simp: ct_in_state'_def) - apply (strengthen not_pred_tcb_at'_strengthen, simp) - apply normalise_obj_at' - apply (simp add: fastpathBestSwitchCandidate_def) - apply (erule_tac x="tcbPriority ko" in allE) - apply (erule impE, normalise_obj_at'+) - done - -crunch tcb2[wp]: "Arch.switchToThread" "tcb_at' t" - (ignore: ARM_HYP.clearExMonitor) - -lemma resolveAddressBits_points_somewhere: - "\\s. \slot. Q slot s\ resolveAddressBits cp cptr bits \Q\,-" - apply (rule_tac Q'="\rv s. \rv. Q rv s" in hoare_post_imp_R) - apply wp - apply clarsimp - done - -lemma user_getregs_wp: - "\\s. tcb_at' t s \ (\tcb. ko_at' tcb t s \ Q (map ((atcbContextGet o tcbArch) tcb) regs) s)\ - asUser t (mapM getRegister regs) \Q\" - apply (rule hoare_strengthen_post) - apply (rule hoare_vcg_conj_lift) - apply (rule asUser_get_registers) - apply (rule asUser_inv) - apply (wp mapM_wp' getRegister_inv) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - done - -lemma foldr_copy_register_tsrs: - "foldr (\r . copy_register_tsrs x y r r (\x. x)) rs s - = (s (y := TCBStateRegs (tsrState (s y)) - (\r. if r \ set rs then tsrContext (s x) r - else tsrContext (s y) r)))" - apply (induct rs) - apply simp - apply (simp add: copy_register_tsrs_def fun_eq_iff - split: if_split) - done - -lemma monadic_rewrite_add_lookup_both_sides: - assumes inv: "\P. \P\ lu \\r. P\" - and ef: "empty_fail lu" - and nf: "no_fail Q lu" - shows - "monadic_rewrite E F P (do lu; f od) (do lu; g od) - \ monadic_rewrite E F (P and Q) f g" - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans[rotated]) - apply (rule monadic_rewrite_symb_exec_l'[where m=lu], (wp inv ef nf impI)+) - apply (rule monadic_rewrite_refl, wp) - apply (simp; erule monadic_rewrite_trans[rotated]) - - apply (rule monadic_rewrite_transverse[OF _ monadic_rewrite_refl]) - apply (rule monadic_rewrite_symb_exec_l'[where m=lu], (wp inv ef nf impI)+) - apply (rule monadic_rewrite_refl, wp) - apply simp - done - -lemmas cteInsert_obj_at'_not_queued = cteInsert_obj_at'_queued[of "\a. \ a"] - -lemma monadic_rewrite_exists_v: - "[| !! v. monadic_rewrite E F (Q v) f g |] - ==> monadic_rewrite E F (%x. (EX v. P v x) & (ALL v. P v x --> Q v x)) f g" - apply (rule monadic_rewrite_name_pre) - apply clarsimp - apply (erule_tac x=v in meta_allE) - apply (erule monadic_rewrite_imp) - apply clarsimp - done - -lemma monadic_rewrite_threadGet_tcbIPCBuffer: - "monadic_rewrite E F (obj_at' (%tcb. tcbIPCBuffer tcb = v) t) - (threadGet tcbIPCBuffer t) (return v)" - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans[rotated]) - apply (rule monadic_rewrite_gets_known) - apply (unfold threadGet_def liftM_def fun_app_def) - apply (rule monadic_rewrite_symb_exec_l' | wp | rule empty_fail_getObject getObject_inv)+ - apply (clarsimp; rule no_fail_getObject_tcb) - apply (simp only: exec_gets) - apply (rule_tac P = "(\s. (tcbIPCBuffer x)=v) and tcb_at' t" in monadic_rewrite_refl3) - apply (simp add:) - apply (wp OMG_getObject_tcb | wpc)+ - apply (auto intro: obj_tcb_at') -done - -lemma monadic_rewrite_threadGet: - "monadic_rewrite E F (obj_at' (\tcb. f tcb = v) t) - (threadGet f t) (return v)" - unfolding getThreadState_def - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans[rotated]) - apply (rule monadic_rewrite_gets_known) - apply (unfold threadGet_def liftM_def fun_app_def) - apply (rule monadic_rewrite_symb_exec_l' | wp | rule empty_fail_getObject getObject_inv)+ - apply (clarsimp; rule no_fail_getObject_tcb) - apply (simp only: exec_gets) - apply (rule_tac P = "(\s. (f x)=v) and tcb_at' t" in monadic_rewrite_refl3) - apply (simp add:) - apply (wp OMG_getObject_tcb | wpc)+ - apply (auto intro: obj_tcb_at') - done - -lemma monadic_rewrite_getThreadState: - "monadic_rewrite E F (obj_at' (\tcb. tcbState tcb = v) t) - (getThreadState t) (return v)" - unfolding getThreadState_def - by (rule monadic_rewrite_threadGet) - -lemma setCTE_obj_at'_tcbIPCBuffer: - "\obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\ setCTE p v \\rv. obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\" - unfolding setCTE_def - by (rule setObject_cte_obj_at_tcb', simp+) - -context -notes if_cong[cong] -begin -crunches cteInsert, asUser - for obj_at'_tcbIPCBuffer[wp]: "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" - (wp: setCTE_obj_at'_queued crunch_wps threadSet_obj_at'_really_strongest) -end - -crunch ksReadyQueues_inv[wp]: cteInsert "\s. P (ksReadyQueues s)" - (wp: hoare_drop_imps) - -crunches cteInsert,threadSet,asUser,emptySlot - for ksReadyQueuesL1Bitmap_inv[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" - and ksReadyQueuesL2Bitmap_inv[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" - (wp: hoare_drop_imps) - -crunch ksReadyQueuesL1Bitmap_inv[wp]: setEndpoint "\s. P (ksReadyQueuesL1Bitmap s)" - (wp: setObject_ksPSpace_only updateObject_default_inv) -crunch ksReadyQueuesL2Bitmap_inv[wp]: setEndpoint "\s. P (ksReadyQueuesL2Bitmap s)" - (wp: setObject_ksPSpace_only updateObject_default_inv) - -lemma cteInsert_lookupBitmapPriority_inv: - "\ \s. P (lookupBitmapPriority t s) \ cteInsert x y z \\_ s. P (lookupBitmapPriority t s)\" - unfolding lookupBitmapPriority_def - apply (rule hoare_pre, wps) - apply (wp) - apply simp - done (* CLEANUP *) - -lemma threadSet_lookupBitmapPriority_inv: - "\ \s. P (lookupBitmapPriority d s) \ threadSet F t - \\rv s. P (lookupBitmapPriority d s) \" - apply (simp add: lookupBitmapPriority_def) - apply (rule hoare_pre, wps) - apply (wp) - apply simp - done - -lemma setThreadState_runnable_bitmap_inv: - "runnable' ts \ - \ \s. P (ksReadyQueuesL1Bitmap s) \ setThreadState ts t \\rv s. P (ksReadyQueuesL1Bitmap s) \" - "runnable' ts \ - \ \s. Q (ksReadyQueuesL2Bitmap s) \ setThreadState ts t \\rv s. Q (ksReadyQueuesL2Bitmap s) \" - by (simp_all add: setThreadState_runnable_simp, wp+) - -lemma fastpath_callKernel_SysCall_corres: - "monadic_rewrite True False - (invs' and ct_in_state' ((=) Running) - and (\s. ksSchedulerAction s = ResumeCurrentThread) - and (\s. ksDomainTime s \ 0)) - (callKernel (SyscallEvent SysCall)) (fastpaths SysCall)" - supply if_cong[cong] option.case_cong[cong] - apply (rule monadic_rewrite_introduce_alternative) - apply (simp add: callKernel_def) - apply (rule monadic_rewrite_imp) - apply (simp add: handleEvent_def handleCall_def - handleInvocation_def liftE_bindE_handle - bind_assoc getMessageInfo_def) - apply (simp add: catch_liftE_bindE unlessE_throw_catch_If - unifyFailure_catch_If catch_liftE - getMessageInfo_def alternative_bind - fastpaths_def - cong: if_cong) - apply (rule monadic_rewrite_rdonly_bind_l, wp) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_rdonly_bind_l, wp) - apply (rule monadic_rewrite_bind_tail) - apply (rename_tac msgInfo) - apply (rule monadic_rewrite_rdonly_bind_l, wp) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_symb_exec_r - [OF threadGet_inv no_fail_threadGet]) - apply (rename_tac thread msgInfo ptr tcbFault) - apply (rule monadic_rewrite_alternative_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (simp add: split_def Syscall_H.syscall_def - liftE_bindE_handle bind_assoc - capFaultOnFailure_def) - apply (simp only: bindE_bind_linearise[where f="rethrowFailure fn f'" for fn f'] - bind_case_sum_rethrow) - apply (simp add: lookupCapAndSlot_def lookupSlotForThread_def - lookupSlotForThread_def bindE_assoc - liftE_bind_return_bindE_returnOk split_def - getThreadCSpaceRoot_def locateSlot_conv - returnOk_liftE[symmetric] const_def - getSlotCap_def) - apply (simp only: liftE_bindE_assoc) - apply (rule monadic_rewrite_rdonly_bind_l, wp) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_rdonly_bind_l) - apply (wp | simp)+ - apply (rule_tac fn="case_sum Inl (Inr \ fst)" in monadic_rewrite_split_fn) - apply (simp add: liftME_liftM[symmetric] liftME_def bindE_assoc) - apply (rule monadic_rewrite_refl) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (simp add: isRight_right_map isRight_case_sum) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_rdonly_bind_l[OF lookupIPC_inv]) - apply (rule monadic_rewrite_symb_exec_l[OF lookupIPC_inv empty_fail_lookupIPCBuffer]) - apply (simp add: lookupExtraCaps_null returnOk_bind liftE_bindE_handle - bind_assoc liftE_bindE_assoc - decodeInvocation_def Let_def from_bool_0 - performInvocation_def liftE_handle - liftE_bind) - apply (rule monadic_rewrite_symb_exec_r [OF getEndpoint_inv no_fail_getEndpoint]) - apply (rename_tac "send_ep") - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (simp add: getThreadVSpaceRoot_def locateSlot_conv) - apply (rule monadic_rewrite_symb_exec_r [OF getCTE_inv no_fail_getCTE]) - apply (rename_tac "pdCapCTE") - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_symb_exec_r[OF curDomain_inv], - simp only: curDomain_def, rule non_fail_gets) - apply (rename_tac "curDom") - apply (rule monadic_rewrite_symb_exec_r [OF threadGet_inv no_fail_threadGet])+ - apply (rename_tac curPrio destPrio) - apply (simp add: isHighestPrio_def') - apply (rule monadic_rewrite_symb_exec_r [OF gets_inv non_fail_gets]) - apply (rename_tac highest) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_symb_exec_r [OF gets_inv non_fail_gets]) - apply (rename_tac asidMap) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - - apply (rule monadic_rewrite_symb_exec_r[OF threadGet_inv no_fail_threadGet]) - apply (rename_tac "destDom") - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_trans, - rule monadic_rewrite_pick_alternative_1) - apply (rule monadic_rewrite_symb_exec_l[OF get_mrs_inv' empty_fail_getMRs]) - (* now committed to fastpath *) - apply (rule monadic_rewrite_trans) - apply (rule_tac F=True and E=True in monadic_rewrite_weaken) - apply simp - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac x=thread in monadic_rewrite_symb_exec, - (wp empty_fail_getCurThread)+) - apply (simp add: sendIPC_def bind_assoc) - apply (rule_tac x=send_ep in monadic_rewrite_symb_exec, - (wp empty_fail_getEndpoint getEndpoint_obj_at')+) - apply (rule_tac P="epQueue send_ep \ []" in monadic_rewrite_gen_asm) - apply (simp add: isRecvEP_endpoint_case list_case_helper bind_assoc) - apply (rule monadic_rewrite_bind_tail) - apply (elim conjE) - apply (rule monadic_rewrite_bind_tail, rename_tac dest_st) - apply (rule_tac P="\gr. dest_st = BlockedOnReceive (capEPPtr (fst (theRight rv))) gr" - in monadic_rewrite_gen_asm) - apply (rule monadic_rewrite_symb_exec2, (wp | simp)+) - apply (rule monadic_rewrite_bind) - apply clarsimp - apply (rule_tac msgInfo=msgInfo in doIPCTransfer_simple_rewrite) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_bind) - apply (rule_tac destPrio=destPrio - and curDom=curDom and destDom=destDom and thread=thread - in possibleSwitchTo_rewrite) - apply (rule monadic_rewrite_bind) - apply (rule monadic_rewrite_trans) - apply (rule setupCallerCap_rewrite) - apply (rule monadic_rewrite_bind_head) - apply (rule setThreadState_rewrite_simple, simp) - apply (rule monadic_rewrite_trans) - apply (rule_tac x=BlockedOnReply in monadic_rewrite_symb_exec, - (wp empty_fail_getThreadState)+) - apply simp - apply (rule monadic_rewrite_refl) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_head) - apply (rule_tac t="hd (epQueue send_ep)" - in schedule_rewrite_ct_not_runnable') - apply (simp add: bind_assoc) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_bind) - apply (rule switchToThread_rewrite) - apply (rule monadic_rewrite_bind) - apply (rule activateThread_simple_rewrite) - apply (rule monadic_rewrite_refl) - apply wp - apply (wp setCurThread_ct_in_state) - apply (simp only: st_tcb_at'_def[symmetric]) - apply (wp, clarsimp simp: cur_tcb'_def ct_in_state'_def) - apply (simp add: getThreadCallerSlot_def getThreadReplySlot_def - locateSlot_conv ct_in_state'_def cur_tcb'_def) - - apply ((wp assert_inv threadSet_pred_tcb_at_state - cteInsert_obj_at'_not_queued - | wps)+)[1] - - apply (wp fastpathBestSwitchCandidate_lift[where f="cteInsert c w w'" for c w w']) - apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] - apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] - apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] - apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] - apply (wp fastpathBestSwitchCandidate_lift[where f="threadSet f t" for f t]) - apply simp - apply ((wp assert_inv threadSet_pred_tcb_at_state - cteInsert_obj_at'_not_queued - | wps)+)[1] - apply (simp add: setSchedulerAction_def) - apply wp[1] - apply (simp cong: if_cong conj_cong add: if_bool_simps) - apply (simp_all only:)[5] - apply ((wp setThreadState_oa_queued[of _ "\a _ _. \ a"] - setThreadState_obj_at_unchanged - asUser_obj_at_unchanged mapM_x_wp' - sts_st_tcb_at'_cases - setThreadState_no_sch_change - setEndpoint_obj_at_tcb' - fastpathBestSwitchCandidate_lift[where f="setThreadState f t" for f t] - setThreadState_oa_queued - fastpathBestSwitchCandidate_lift[where f="asUser t f" for f t] - fastpathBestSwitchCandidate_lift[where f="setEndpoint a b" for a b] - lookupBitmapPriority_lift - setThreadState_runnable_bitmap_inv - threadSet_lookupBitmapPriority_inv - | simp add: setMessageInfo_def - | wp (once) hoare_vcg_disj_lift)+) - - apply (simp add: setThreadState_runnable_simp - getThreadCallerSlot_def getThreadReplySlot_def - locateSlot_conv bind_assoc) - apply (rule_tac P="\v. obj_at' (%tcb. tcbIPCBuffer tcb = v) (hd (epQueue send_ep))" - in monadic_rewrite_exists_v) - apply (rename_tac ipcBuffer) - - apply (rule_tac P="\v. obj_at' (\tcb. tcbState tcb = v) (hd (epQueue send_ep))" - in monadic_rewrite_exists_v) - apply (rename_tac destState) - - apply (simp add: ARM_HYP_H.switchToThread_def getTCB_threadGet bind_assoc) - (* retrieving state or thread registers is not thread_action_isolatable, - translate into return with suitable precondition *) - apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) - apply (rule_tac v=destState in monadic_rewrite_getThreadState - | rule monadic_rewrite_bind monadic_rewrite_refl)+ - apply (wp mapM_x_wp' getObject_inv | wpc | simp | wp (once) hoare_drop_imps)+ - apply (rule_tac v=destState in monadic_rewrite_getThreadState - | rule monadic_rewrite_bind monadic_rewrite_refl)+ - apply (wp mapM_x_wp' getObject_inv | wpc | simp | wp (once) hoare_drop_imps)+ - - apply (rule_tac P="inj (case_bool thread (hd (epQueue send_ep)))" - in monadic_rewrite_gen_asm) - apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) - apply (rule monadic_rewrite_weaken[where F=False and E=True], simp) - apply (rule isolate_thread_actions_rewrite_bind - fastpath_isolate_rewrites fastpath_isolatables - bool.simps setRegister_simple - threadGet_vcpu_isolatable[THEN thread_actions_isolatableD, simplified o_def] - threadGet_vcpu_isolatable[simplified o_def] - vcpuSwitch_isolatable[THEN thread_actions_isolatableD] vcpuSwitch_isolatable - setVMRoot_isolatable[THEN thread_actions_isolatableD] setVMRoot_isolatable - doMachineOp_isolatable[THEN thread_actions_isolatableD] doMachineOp_isolatable - kernelExitAssertions_isolatable[THEN thread_actions_isolatableD] - kernelExitAssertions_isolatable - zipWithM_setRegister_simple - thread_actions_isolatable_bind - | assumption - | wp assert_inv)+ - apply (rule_tac P="\s. ksSchedulerAction s = ResumeCurrentThread - \ tcb_at' thread s" - and F=True and E=False in monadic_rewrite_weaken) - apply simp - apply (rule monadic_rewrite_isolate_final) - apply (simp add: isRight_case_sum cong: list.case_cong) - apply (clarsimp simp: fun_eq_iff if_flip - cong: if_cong) - apply (drule obj_at_ko_at', clarsimp) - apply (frule get_tcb_state_regs_ko_at') - apply (clarsimp simp: zip_map2 zip_same_conv_map foldl_map - foldl_fun_upd - foldr_copy_register_tsrs - isRight_case_sum - cong: if_cong) - apply (simp add: upto_enum_def fromEnum_def - enum_register toEnum_def - msgRegisters_unfold - cong: if_cong) - apply (clarsimp split: if_split) - apply (rule ext) - apply (simp add: badgeRegister_def msgInfoRegister_def - ARM_HYP.badgeRegister_def - ARM_HYP.msgInfoRegister_def - split: if_split) - apply simp - apply (wp | simp cong: if_cong bool.case_cong - | rule getCTE_wp' gts_wp' threadGet_wp - getEndpoint_wp)+ - apply (rule validE_cases_valid) - apply (simp add: isRight_def getSlotCap_def) - apply (wp getCTE_wp') - apply (rule resolveAddressBits_points_somewhere) - apply (simp cong: if_cong bool.case_cong) - apply wp - apply simp - apply (wp user_getreg_wp user_getregs_wp threadGet_wp)+ - - apply clarsimp - apply (subgoal_tac "ksCurThread s \ ksIdleThread s") - prefer 2 - apply (fastforce simp: ct_in_state'_def dest: ct_running_not_idle' elim: pred_tcb'_weakenE) - - apply (clarsimp simp: ct_in_state'_def pred_tcb_at') - apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp+) - apply (clarsimp simp: isCap_simps valid_cap'_def maskCapRights_def) - apply (frule ko_at_valid_ep', clarsimp) - apply (frule sym_refs_ko_atD'[where 'a=endpoint], clarsimp) - apply (clarsimp simp: valid_ep'_def isRecvEP_endpoint_case neq_Nil_conv - tcbVTableSlot_def cte_level_bits_def - cte_at_tcb_at_16' length_msgRegisters - n_msgRegisters_def order_less_imp_le - ep_q_refs_of'_def st_tcb_at_refs_of_rev' - cong: if_cong) - apply (rename_tac blockedThread ys tcba tcbb) - apply (frule invs_mdb') - apply (thin_tac "Ball S P" for S P)+ - supply imp_disjL[simp del] - apply (subst imp_disjL[symmetric]) - - (* clean up broken up disj implication and excessive references to same tcbs *) - apply normalise_obj_at' - apply (clarsimp simp: invs'_def valid_state'_def) - apply (fold imp_disjL, intro allI impI) - - apply (subgoal_tac "ksCurThread s \ blockedThread") - prefer 2 - apply normalise_obj_at' - apply clarsimp - apply (frule_tac t="blockedThread" in valid_queues_not_runnable_not_queued, assumption) - subgoal by (fastforce simp: st_tcb_at'_def elim: obj_at'_weakenE) - apply (subgoal_tac "fastpathBestSwitchCandidate blockedThread s") - prefer 2 - apply (rule_tac ttcb=tcbb and ctcb=tcb in fastpathBestSwitchCandidateI) - apply (solves \simp only: disj_ac\) - apply simp+ - apply (clarsimp simp: st_tcb_at'_def obj_at'_def objBits_simps projectKOs valid_mdb'_def - valid_mdb_ctes_def inj_case_bool - split: bool.split)+ - done - -lemmas fastpath_call_ccorres_callKernel - = monadic_rewrite_ccorres_assemble[OF fastpath_call_ccorres fastpath_callKernel_SysCall_corres] - -lemma capability_case_Null_ReplyCap: - "(case cap of NullCap \ f | ReplyCap t b cg \ g t b cg | _ \ h) - = (if isReplyCap cap then g (capTCBPtr cap) (capReplyMaster cap) (capReplyCanGrant cap) - else if isNullCap cap then f else h)" - by (simp add: isCap_simps split: capability.split) - -lemma in_getCTE_slot: - "(\s. (rv, s) \ fst (getCTE slot s)) = (is_aligned slot cte_level_bits)" - apply (simp add: getCTE_assert_opt exec_gets assert_opt_member) - apply (rule iffI) - apply clarsimp - apply (subgoal_tac "cte_wp_at' ((=) rv) slot s") - apply (simp add: cte_wp_at_cases') - apply (erule disjE) - apply simp - apply clarsimp - apply (drule(1) tcb_cte_cases_aligned[where cte=rv]) - apply (simp add: objBits_simps' cte_level_bits_def) - apply (simp add: cte_wp_at_ctes_of) - apply (rule_tac x="undefined \ ksPSpace := [slot \ KOCTE rv] \" in exI) - apply (simp add: map_to_ctes_def Let_def objBits_simps' cte_level_bits_def) - done - -end - -context begin interpretation Arch . (*FIXME: arch_split*) - -lemma inj2_assert_opt: - "(assert_opt v s = assert_opt v' s') = (v = v' \ (v' = None \ s = s'))" - by (simp add: assert_opt_def return_def fail_def split: option.split) - -lemma gets_the_inj: - "inj gets_the" - apply (rule injI) - apply (clarsimp simp: gets_the_def fun_eq_iff exec_gets inj2_assert_opt) - done - -lemmas gets_the_eq = inj_eq[OF gets_the_inj] - -lemma gets_the_eq2: - "(gets_the f s = gets_the g s') = (f s = g s' \ (g s' = None \ s = s'))" - by (simp add: gets_the_def exec_gets inj2_assert_opt) - -lemma return_gets_the: - "return x = gets_the (\_. Some x)" - by (simp add: gets_the_def assert_opt_def) - -lemma injection_handler_catch: - "catch (injection_handler f x) y - = catch x (y o f)" - apply (simp add: injection_handler_def catch_def handleE'_def - bind_assoc) - apply (rule bind_cong[OF refl]) - apply (simp add: throwError_bind split: sum.split) - done - -lemma doReplyTransfer_simple: - "monadic_rewrite True False - (obj_at' (\tcb. tcbFault tcb = None) receiver) - (doReplyTransfer sender receiver slot grant) - (do state \ getThreadState receiver; - assert (isReply state); - cte \ getCTE slot; - mdbnode \ return $ cteMDBNode cte; - assert (mdbPrev mdbnode \ 0 \ mdbNext mdbnode = 0); - parentCTE \ getCTE (mdbPrev mdbnode); - assert (isReplyCap (cteCap parentCTE) \ capReplyMaster (cteCap parentCTE)); - doIPCTransfer sender Nothing 0 grant receiver; - cteDeleteOne slot; - setThreadState Running receiver; - possibleSwitchTo receiver - od)" - apply (simp add: doReplyTransfer_def liftM_def nullPointer_def getSlotCap_def) - apply (rule monadic_rewrite_bind_tail)+ - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_threadGet)+) - apply (rule_tac P="rv = None" in monadic_rewrite_gen_asm, simp) - apply (rule monadic_rewrite_refl) - apply (wp threadGet_const gts_wp' getCTE_wp')+ - apply (simp add: o_def) - done - -lemma monadic_rewrite_if_known: - "monadic_rewrite F E ((\s. C = X) and \) (if C then f else g) (if X then f else g)" - apply (rule monadic_rewrite_gen_asm) - apply (simp split del: if_split) - apply (rule monadic_rewrite_refl) - done - -end - -context kernel_m begin - -lemma receiveIPC_simple_rewrite: - "monadic_rewrite True False - ((\_. isEndpointCap ep_cap \ \ isSendEP ep) and (ko_at' ep (capEPPtr ep_cap) and - (\s. \ntfnptr. bound_tcb_at' ((=) (Some ntfnptr)) thread s \ obj_at' (Not \ isActive) ntfnptr s))) - (receiveIPC thread ep_cap True) - (do - setThreadState (BlockedOnReceive (capEPPtr ep_cap) (capEPCanGrant ep_cap)) thread; - setEndpoint (capEPPtr ep_cap) (RecvEP (case ep of RecvEP q \ (q @ [thread]) | _ \ [thread])) - od)" - apply (rule monadic_rewrite_gen_asm) - apply (simp add: receiveIPC_def) - apply (rule monadic_rewrite_imp) - apply (rule_tac rv=ep in monadic_rewrite_symb_exec_l_known, - (wp empty_fail_getEndpoint)+) - apply (rule monadic_rewrite_symb_exec_l, (wp | simp add: getBoundNotification_def)+) - apply (rule monadic_rewrite_symb_exec_l) - apply (rule hoare_pre, wpc, wp+, simp) - apply (simp split: option.split) - apply (rule monadic_rewrite_trans, rule monadic_rewrite_if_known[where X=False], simp) - apply (rule monadic_rewrite_refl3[where P=\]) - apply (cases ep, simp_all add: isSendEP_def)[1] - apply (wp getNotification_wp gbn_wp' getEndpoint_wp | wpc)+ - apply (clarsimp simp: obj_at'_def projectKOs pred_tcb_at'_def) - done - -lemma empty_fail_isFinalCapability: - "empty_fail (isFinalCapability cte)" - by (simp add: isFinalCapability_def Let_def split: if_split) - -lemma cteDeleteOne_replycap_rewrite: - "monadic_rewrite True False - (cte_wp_at' (\cte. isReplyCap (cteCap cte)) slot) - (cteDeleteOne slot) - (emptySlot slot NullCap)" - apply (simp add: cteDeleteOne_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rule_tac P="cteCap rv \ NullCap \ isReplyCap (cteCap rv) - \ \ isEndpointCap (cteCap rv) - \ \ isNotificationCap (cteCap rv)" - in monadic_rewrite_gen_asm) - apply (simp add: finaliseCapTrue_standin_def - capRemovable_def) - apply (rule monadic_rewrite_symb_exec_l, - (wp isFinalCapability_inv empty_fail_isFinalCapability)+) - apply (rule monadic_rewrite_refl) - apply (wp getCTE_wp')+ - apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) - done - -lemma cteDeleteOne_nullcap_rewrite: - "monadic_rewrite True False - (cte_wp_at' (\cte. cteCap cte = NullCap) slot) - (cteDeleteOne slot) - (return ())" - apply (simp add: cteDeleteOne_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rule_tac P="cteCap rv = NullCap" in monadic_rewrite_gen_asm) - apply simp - apply (rule monadic_rewrite_refl) - apply (wp getCTE_wp') - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -lemma deleteCallerCap_nullcap_rewrite: - "monadic_rewrite True False - (cte_wp_at' (\cte. cteCap cte = NullCap) (thread + 2 ^ cte_level_bits * tcbCallerSlot)) - (deleteCallerCap thread) - (return ())" - apply (simp add: deleteCallerCap_def getThreadCallerSlot_def locateSlot_conv - getSlotCap_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rule monadic_rewrite_assert) - apply (rule cteDeleteOne_nullcap_rewrite) - apply (wp getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -end - -lemma emptySlot_cnode_caps: - "\\s. P (only_cnode_caps (ctes_of s)) \ cte_wp_at' (\cte. \ isCNodeCap (cteCap cte)) slot s\ - emptySlot slot NullCap - \\rv s. P (only_cnode_caps (ctes_of s))\" - apply (simp add: only_cnode_caps_def map_option_comp2 - o_assoc[symmetric] cteCaps_of_def[symmetric]) - apply (wp emptySlot_cteCaps_of) - apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of - elim!: rsubst[where P=P] intro!: ext - split: if_split) - done - -lemma cteDeleteOne_cnode_caps: - "\\s. P (only_cnode_caps (ctes_of s))\ - cteDeleteOne slot - \\rv s. P (only_cnode_caps (ctes_of s))\" - apply (simp add: only_cnode_caps_def map_option_comp2 - o_assoc[symmetric] cteCaps_of_def[symmetric]) - apply (wp cteDeleteOne_cteCaps_of) - apply clarsimp - apply (erule rsubst[where P=P], rule ext) - apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of isCap_simps) - apply (rule_tac x="cteCap cte" in exI) - apply (clarsimp simp: finaliseCap_def finaliseCapTrue_standin_def isCap_simps) - done - -lemma asUser_obj_at_ep[wp]: - "\obj_at' P p\ asUser t m \\rv. obj_at' (P :: endpoint \ bool) p\" - apply (simp add: asUser_def split_def) - apply (wp hoare_drop_imps | simp)+ - done - -lemma setCTE_obj_at_ep[wp]: - "\obj_at' (P :: endpoint \ bool) p\ setCTE ptr cte \\rv. obj_at' P p\" - unfolding setCTE_def - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_cte typeError_def in_monad - split: Structures_H.kernel_object.split_asm - if_split_asm) - done - -lemma setCTE_obj_at_ntfn[wp]: - "\obj_at' (P :: Structures_H.notification \ bool) p\ setCTE ptr cte \\rv. obj_at' P p\" - unfolding setCTE_def - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_cte typeError_def in_monad - split: Structures_H.kernel_object.split_asm - if_split_asm) - done - -crunch obj_at_ep[wp]: emptySlot "obj_at' (P :: endpoint \ bool) p" - -crunch nosch[wp]: emptySlot "\s. P (ksSchedulerAction s)" - -context begin interpretation Arch . -crunches emptySlot, asUser - for gsCNodes[wp]: "\s. P (gsCNodes s)" - (wp: crunch_wps) -end - -crunch cte_wp_at'[wp]: possibleSwitchTo "cte_wp_at' P p" - (wp: hoare_drop_imps) - -crunch tcbContext[wp]: possibleSwitchTo "obj_at' (\tcb. P ( (atcbContextGet o tcbArch) tcb)) t" - (wp: crunch_wps simp_del: comp_apply) - -context begin interpretation Arch . - -crunch only_cnode_caps[wp]: doFaultTransfer "\s. P (only_cnode_caps (ctes_of s))" - (wp: crunch_wps ignore: asUser simp: crunch_simps) - -end - -context kernel_m begin - -lemma tcbSchedDequeue_rewrite_not_queued: "monadic_rewrite True False (tcb_at' t and obj_at' (Not \ tcbQueued) t) (tcbSchedDequeue t) (return ())" - apply (simp add: tcbSchedDequeue_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac P="\ queued" in monadic_rewrite_gen_asm) - apply (simp add: when_def) - apply (rule monadic_rewrite_refl) - apply (wp threadGet_const) - - apply (rule monadic_rewrite_symb_exec_l) - apply wp+ - apply (rule monadic_rewrite_refl) - apply (wp) - apply (clarsimp simp: o_def obj_at'_def) - done - -lemma schedule_known_rewrite: - "monadic_rewrite True False - (\s. ksSchedulerAction s = SwitchToThread t - \ tcb_at' t s - \ obj_at' (Not \ tcbQueued) t s - \ ksCurThread s = t' - \ st_tcb_at' (Not \ runnable') t' s - \ (ksCurThread s \ ksIdleThread s) - \ fastpathBestSwitchCandidate t s) - (schedule) - (do Arch.switchToThread t; - setCurThread t; - setSchedulerAction ResumeCurrentThread od)" - supply subst_all [simp del] - apply (simp add: schedule_def) - apply (simp only: switchToThread_def) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac P="action = SwitchToThread t" in monadic_rewrite_gen_asm, simp) - apply (rule monadic_rewrite_bind_tail) - apply (rule_tac P="\ wasRunnable \ action = SwitchToThread t" in monadic_rewrite_gen_asm,simp) - apply (rule monadic_rewrite_bind_tail, rename_tac idleThread) - apply (rule monadic_rewrite_bind_tail, rename_tac targetPrio) - apply (rule monadic_rewrite_bind_tail, rename_tac curPrio) - apply (rule monadic_rewrite_bind_tail, rename_tac fastfail) - apply (rule monadic_rewrite_bind_tail, rename_tac curDom) - apply (rule monadic_rewrite_bind_tail, rename_tac highest) - apply (rule_tac P="\ (fastfail \ \ highest)" in monadic_rewrite_gen_asm, simp only:) - apply simp - apply (simp add: bind_assoc) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_bind) - apply (rule monadic_rewrite_trans) - apply (rule tcbSchedDequeue_rewrite_not_queued) - apply (rule monadic_rewrite_refl) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_refl) - apply (wpsimp wp: Arch_switchToThread_obj_at_pre)+ - apply (wp hoare_vcg_imp_lift)+ - apply (simp add: isHighestPrio_def') - apply wp+ - apply (wp hoare_vcg_disj_lift) - apply (wp scheduleSwitchThreadFastfail_False_wp) - apply wp+ - apply (wp hoare_vcg_disj_lift threadGet_wp'') - apply (wp hoare_vcg_disj_lift threadGet_wp'') - apply clarsimp - apply wp - apply (simp add: comp_def) - apply wp - apply wp - apply wp - (* remove no-ops, somewhat by magic *) - apply (rule monadic_rewrite_symb_exec_l'_TT, solves wp, - wpsimp wp: empty_fail_isRunnable simp: isHighestPrio_def')+ - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_symb_exec_l) - apply simp+ - apply (rule monadic_rewrite_refl) - apply wp+ - apply (rule monadic_rewrite_refl) - apply wp+ - apply (clarsimp simp: ct_in_state'_def) - apply (rule conjI) - apply (rule not_pred_tcb_at'_strengthen, assumption) - apply normalise_obj_at' - apply (simp add: fastpathBestSwitchCandidate_def) - apply normalise_obj_at' - done - -lemma tcb_at_cte_at_offset: - "\ tcb_at' t s; 2 ^ cte_level_bits * off \ dom tcb_cte_cases \ - \ cte_at' (t + 2 ^ cte_level_bits * off) s" - apply (clarsimp simp: obj_at'_def projectKOs objBits_simps) - apply (erule(2) cte_wp_at_tcbI') - apply fastforce - apply simp - done - -lemma emptySlot_cte_wp_at_cteCap: - "\\s. (p = p' \ P NullCap) \ (p \ p' \ cte_wp_at' (\cte. P (cteCap cte)) p s)\ - emptySlot p' irqopt - \\rv s. cte_wp_at' (\cte. P (cteCap cte)) p s\" - apply (simp add: tree_cte_cteCap_eq[unfolded o_def]) - apply (wp emptySlot_cteCaps_of) - apply (clarsimp split: if_split) - done - -lemma real_cte_at_tcbs_of_neq: - "[| real_cte_at' p s; tcbs_of s t = Some tcb; - 2 ^ cte_level_bits * offs : dom tcb_cte_cases |] - ==> p ~= t + 2 ^ cte_level_bits * offs" - apply (clarsimp simp: tcbs_of_def obj_at'_def projectKOs objBits_simps - split: if_split_asm) - apply (erule notE[rotated], erule(2) tcb_ctes_clear[rotated]) - apply fastforce - done - -lemma setEndpoint_getCTE_pivot[unfolded K_bind_def]: - "do setEndpoint p val; v <- getCTE slot; f v od - = do v <- getCTE slot; setEndpoint p val; f v od" - apply (simp add: getCTE_assert_opt setEndpoint_def - setObject_modify_assert - fun_eq_iff bind_assoc) - apply (simp add: exec_gets assert_def assert_opt_def - exec_modify update_ep_map_tos - split: if_split option.split) - done - -lemma setEndpoint_setCTE_pivot[unfolded K_bind_def]: - "do setEndpoint p val; setCTE slot cte; f od = - do setCTE slot cte; setEndpoint p val; f od" - apply (rule monadic_rewrite_to_eq) - apply simp - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans, - rule_tac f="ep_at' p" in monadic_rewrite_add_gets) - apply (rule monadic_rewrite_transverse, rule monadic_rewrite_add_gets, - rule monadic_rewrite_bind_tail) - apply (rename_tac epat) - apply (rule monadic_rewrite_transverse) - apply (rule monadic_rewrite_bind_tail) - apply (simp add: setEndpoint_def setObject_modify_assert bind_assoc) - apply (rule_tac rv=epat in monadic_rewrite_gets_known) - apply (wp setCTE_typ_at'[where T="koType TYPE(endpoint)", unfolded typ_at_to_obj_at'] - | simp)+ - apply (simp add: setCTE_assert_modify bind_assoc) - apply (rule monadic_rewrite_trans, rule monadic_rewrite_add_gets, - rule monadic_rewrite_bind_tail)+ - apply (rename_tac cteat tcbat) - apply (rule monadic_rewrite_trans, rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_trans) - apply (rule_tac rv=cteat in monadic_rewrite_gets_known) - apply (rule_tac rv=tcbat in monadic_rewrite_gets_known) - apply (wp setEndpoint_typ_at'[where T="koType TYPE(tcb)", unfolded typ_at_to_obj_at'] - setEndpoint_typ_at'[where T="koType TYPE(cte)", unfolded typ_at_to_obj_at'] - | simp)+ - apply (rule_tac P="\s. epat = ep_at' p s \ cteat = real_cte_at' slot s - \ tcbat = (tcb_at' (slot && ~~ mask 9) and (%y. slot && mask 9 : dom tcb_cte_cases)) s" - in monadic_rewrite_refl3) - apply (simp add: setEndpoint_def setObject_modify_assert bind_assoc - exec_gets assert_def exec_modify - split: if_split) - apply (auto split: if_split simp: obj_at'_def projectKOs objBits_defs - intro!: arg_cong[where f=f] ext kernel_state.fold_congs)[1] - apply wp+ - apply (simp add: objBits_defs) - done - -lemma setEndpoint_updateMDB_pivot[unfolded K_bind_def]: - "do setEndpoint p val; updateMDB slot mf; f od = - do updateMDB slot mf; setEndpoint p val; f od" - by (clarsimp simp: updateMDB_def bind_assoc - setEndpoint_getCTE_pivot - setEndpoint_setCTE_pivot - split: if_split) - -lemma setEndpoint_updateCap_pivot[unfolded K_bind_def]: - "do setEndpoint p val; updateCap slot mf; f od = - do updateCap slot mf; setEndpoint p val; f od" - by (clarsimp simp: updateCap_def bind_assoc - setEndpoint_getCTE_pivot - setEndpoint_setCTE_pivot) - -lemma modify_setEndpoint_pivot[unfolded K_bind_def]: - "\ \ksf s. ksPSpace_update ksf (sf s) = sf (ksPSpace_update ksf s) \ - \ (do modify sf; setEndpoint p val; f od) = - (do setEndpoint p val; modify sf; f od)" - apply (subgoal_tac "\s. ep_at' p (sf s) = ep_at' p s") - apply (simp add: setEndpoint_def setObject_modify_assert - bind_assoc fun_eq_iff - exec_gets exec_modify assert_def - split: if_split) - apply atomize - apply clarsimp - apply (drule_tac x="\_. ksPSpace s" in spec) - apply (drule_tac x="s" in spec) - apply (drule_tac f="ksPSpace" in arg_cong) - apply simp - apply (metis obj_at'_pspaceI) - done - -lemma setEndpoint_clearUntypedFreeIndex_pivot[unfolded K_bind_def]: - "do setEndpoint p val; v <- clearUntypedFreeIndex slot; f od - = do v <- clearUntypedFreeIndex slot; setEndpoint p val; f od" - by (simp add: clearUntypedFreeIndex_def bind_assoc - getSlotCap_def - setEndpoint_getCTE_pivot - updateTrackedFreeIndex_def - modify_setEndpoint_pivot - split: capability.split cong: option.case_cong - | rule bind_cong[OF refl] allI impI - bind_apply_cong[OF refl])+ - -lemma emptySlot_setEndpoint_pivot[unfolded K_bind_def]: - "(do emptySlot slot NullCap; setEndpoint p val; f od) = - (do setEndpoint p val; emptySlot slot NullCap; f od)" - apply (rule ext) - apply (simp add: emptySlot_def bind_assoc - setEndpoint_getCTE_pivot - setEndpoint_updateCap_pivot - setEndpoint_updateMDB_pivot - case_Null_If Retype_H.postCapDeletion_def - setEndpoint_clearUntypedFreeIndex_pivot - split: if_split - | rule bind_apply_cong[OF refl])+ - done - -lemma set_getCTE[unfolded K_bind_def]: - "do setCTE p cte; v <- getCTE p; f v od - = do setCTE p cte; f cte od" - apply simp - apply (rule monadic_rewrite_to_eq) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_bind_tail) - apply (simp add: getCTE_assert_opt bind_assoc) - apply (rule monadic_rewrite_trans, - rule_tac rv="Some cte" in monadic_rewrite_gets_known) - apply (simp add: assert_opt_def) - apply (rule monadic_rewrite_refl) - apply wp - apply simp - done - -lemma set_setCTE[unfolded K_bind_def]: - "do setCTE p val; setCTE p val' od = setCTE p val'" - apply simp - apply (rule monadic_rewrite_to_eq) - apply (rule monadic_rewrite_imp) - apply (rule monadic_rewrite_trans, - rule_tac f="real_cte_at' p" in monadic_rewrite_add_gets) - apply (rule monadic_rewrite_transverse, rule monadic_rewrite_add_gets, - rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_trans, - rule_tac f="tcb_at' (p && ~~ mask 9) and K (p && mask 9 \ dom tcb_cte_cases)" - in monadic_rewrite_add_gets) - apply (rule monadic_rewrite_transverse, rule monadic_rewrite_add_gets, - rule monadic_rewrite_bind_tail) - apply (rename_tac cteat tcbat) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_tail) - apply (simp add: setCTE_assert_modify) - apply (rule monadic_rewrite_trans, rule_tac rv=cteat in monadic_rewrite_gets_known) - apply (rule_tac rv=tcbat in monadic_rewrite_gets_known) - apply (wp setCTE_typ_at'[where T="koType TYPE(tcb)", unfolded typ_at_to_obj_at'] - setCTE_typ_at'[where T="koType TYPE(cte)", unfolded typ_at_to_obj_at'] - | simp)+ - apply (simp add: setCTE_assert_modify bind_assoc) - apply (rule monadic_rewrite_bind_tail)+ - apply (rule_tac P="c = cteat \ t = tcbat - \ (tcbat \ - (\ getF setF. tcb_cte_cases (p && mask 9) = Some (getF, setF) - \ (\ f g tcb. setF f (setF g tcb) = setF (f o g) tcb)))" - in monadic_rewrite_gen_asm) - apply (rule monadic_rewrite_refl2) - apply (simp add: exec_modify split: if_split) - apply (auto simp: simpler_modify_def projectKO_opt_tcb objBits_defs - intro!: kernel_state.fold_congs ext - split: if_split)[1] - apply wp+ - apply (clarsimp simp: objBits_defs intro!: all_tcbI) - apply (auto simp: tcb_cte_cases_def split: if_split_asm) - done - -lemma setCTE_updateCapMDB: - "p \ 0 \ - setCTE p cte = do updateCap p (cteCap cte); updateMDB p (const (cteMDBNode cte)) od" - apply (simp add: updateCap_def updateMDB_def bind_assoc set_getCTE - cte_overwrite set_setCTE) - apply (simp add: getCTE_assert_opt setCTE_assert_modify bind_assoc) - apply (rule ext, simp add: exec_gets assert_opt_def exec_modify - split: if_split option.split) - apply (cut_tac P=\ and p=p and s=x in cte_wp_at_ctes_of) - apply (cases cte) - apply (simp add: cte_wp_at_obj_cases') - apply (auto simp: mask_out_sub_mask) - done - -lemma clearUntypedFreeIndex_simple_rewrite: - "monadic_rewrite True False - (cte_wp_at' (Not o isUntypedCap o cteCap) slot) - (clearUntypedFreeIndex slot) (return ())" - apply (simp add: clearUntypedFreeIndex_def getSlotCap_def) - apply (rule monadic_rewrite_name_pre) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (rule monadic_rewrite_imp) - apply (rule_tac rv=cte in monadic_rewrite_symb_exec_l_known, wp+) - apply (simp split: capability.split, - strengthen monadic_rewrite_refl, simp) - apply clarsimp - apply (wp getCTE_wp') - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -lemma emptySlot_replymaster_rewrite[OF refl]: - "mdbn = cteMDBNode cte \ - monadic_rewrite True False - ((\_. mdbNext mdbn = 0 \ mdbPrev mdbn \ 0) - and ((\_. cteCap cte \ NullCap) - and (cte_wp_at' ((=) cte) slot - and cte_wp_at' (\cte. isReplyCap (cteCap cte)) slot - and cte_wp_at' (\cte. isReplyCap (cteCap cte) \ capReplyMaster (cteCap cte)) - (mdbPrev mdbn) - and (\s. reply_masters_rvk_fb (ctes_of s)) - and (\s. no_0 (ctes_of s))))) - (emptySlot slot NullCap) - (do updateMDB (mdbPrev mdbn) (mdbNext_update (K 0) o mdbFirstBadged_update (K True) - o mdbRevocable_update (K True)); - setCTE slot makeObject - od)" - apply (rule monadic_rewrite_gen_asm)+ - apply (rule monadic_rewrite_imp) - apply (rule_tac P="slot \ 0" in monadic_rewrite_gen_asm) - apply (clarsimp simp: emptySlot_def setCTE_updateCapMDB) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_head) - apply (rule clearUntypedFreeIndex_simple_rewrite) - apply simp - apply (rule_tac rv=cte in monadic_rewrite_symb_exec_l_known, (wp empty_fail_getCTE)+) - apply (simp add: updateMDB_def Let_def bind_assoc makeObject_cte case_Null_If) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_bind) - apply (rule_tac P="mdbFirstBadged (cteMDBNode ctea) \ mdbRevocable (cteMDBNode ctea)" - in monadic_rewrite_gen_asm) - apply (rule monadic_rewrite_refl2) - apply (case_tac ctea, rename_tac mdbnode, case_tac mdbnode) - apply simp - apply (simp add: Retype_H.postCapDeletion_def) - apply (rule monadic_rewrite_refl) - apply (wp getCTE_wp')+ - apply (clarsimp simp: cte_wp_at_ctes_of reply_masters_rvk_fb_def) - apply (fastforce simp: isCap_simps) - done - -lemma all_prio_not_inQ_not_tcbQueued: "\ obj_at' (\a. (\d p. \ inQ d p a)) t s \ \ obj_at' (\a. \ tcbQueued a) t s" - apply (clarsimp simp: obj_at'_def inQ_def) -done - -crunches setThreadState, emptySlot, asUser - for ntfn_obj_at[wp]: "obj_at' (P::(Structures_H.notification \ bool)) ntfnptr" - (wp: obj_at_setObject2 crunch_wps - simp: crunch_simps updateObject_default_def in_monad) - -lemma st_tcb_at_is_Reply_imp_not_tcbQueued: "\s t.\ invs' s; st_tcb_at' isReply t s\ \ obj_at' (\a. \ tcbQueued a) t s" - apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def st_tcb_at'_def valid_queues_no_bitmap_def) - apply (rule all_prio_not_inQ_not_tcbQueued) - apply (clarsimp simp: obj_at'_def) - apply (erule_tac x="d" in allE) - apply (erule_tac x="p" in allE) - apply (erule conjE) - apply (erule_tac x="t" in ballE) - apply (clarsimp simp: obj_at'_def runnable'_def isReply_def) - apply (case_tac "tcbState obj") - apply ((clarsimp simp: inQ_def)+)[8] - apply (clarsimp simp: valid_queues'_def obj_at'_def) -done - -lemma valid_objs_ntfn_at_tcbBoundNotification: - "ko_at' tcb t s \ valid_objs' s \ tcbBoundNotification tcb \ None - \ ntfn_at' (the (tcbBoundNotification tcb)) s" - apply (drule(1) ko_at_valid_objs', simp add: projectKOs) - apply (simp add: valid_obj'_def valid_tcb'_def valid_bound_ntfn'_def) - apply clarsimp - done - -crunch bound_tcb_at'_Q[wp]: setThreadState "\s. Q (bound_tcb_at' P t s)" - (wp: threadSet_pred_tcb_no_state crunch_wps simp: unless_def) - -lemmas emptySlot_pred_tcb_at'_Q[wp] = lift_neg_pred_tcb_at'[OF emptySlot_typ_at' emptySlot_pred_tcb_at'] - -lemma emptySlot_tcb_at'[wp]: - "\\s. Q (tcb_at' t s)\ emptySlot a b \\_ s. Q (tcb_at' t s)\" - by (simp add: tcb_at_typ_at', wp) - -lemmas cnode_caps_gsCNodes_lift - = hoare_lift_Pf2[where P="\gs s. cnode_caps_gsCNodes (f s) gs" and f=gsCNodes for f] - hoare_lift_Pf2[where P="\gs s. Q s \ cnode_caps_gsCNodes (f s) gs" and f=gsCNodes for f Q] - -lemma monadic_rewrite_option_cases: - "\ v = None \ monadic_rewrite F E Q a b; \x. v = Some x \ monadic_rewrite F E (R x) a b \ - \ monadic_rewrite F E (\s. (v = None \ Q s) \ (\x. v = Some x \ R x s)) a b" - by (cases v, simp_all) - -lemma resolveAddressBitsFn_eq_name_slot: - "monadic_rewrite F E (\s. (isCNodeCap cap \ cte_wp_at' (\cte. cteCap cte = cap) (slot s) s) - \ valid_objs' s \ cnode_caps_gsCNodes' s) - (resolveAddressBits cap capptr bits) - (gets (resolveAddressBitsFn cap capptr bits o only_cnode_caps o ctes_of))" - apply (rule monadic_rewrite_imp, rule resolveAddressBitsFn_eq) - apply auto - done - -crunch bound_tcb_at'_Q[wp]: asUser "\s. Q (bound_tcb_at' P t s)" - (simp: crunch_simps wp: threadSet_pred_tcb_no_state crunch_wps) - - -lemma asUser_tcb_at'_Q[wp]: - "\\s. Q (tcb_at' t s)\ asUser a b \\_ s. Q (tcb_at' t s)\" - by (simp add: tcb_at_typ_at', wp) - -lemma active_ntfn_check_wp: - "\\s. Q (\ntfnptr. bound_tcb_at' ((=) (Some ntfnptr)) thread s - \ \ obj_at' (Not o isActive) ntfnptr s) s \ do bound_ntfn \ getBoundNotification thread; - case bound_ntfn of None \ return False - | Some ntfnptr \ liftM EndpointDecls_H.isActive $ getNotification ntfnptr - od \Q\" - apply (rule hoare_pre) - apply (wp getNotification_wp gbn_wp' | wpc)+ - apply (auto simp: pred_tcb_at'_def obj_at'_def projectKOs) - done - -lemma tcbSchedEnqueue_tcbIPCBuffer: - "\obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\ - tcbSchedEnqueue t' - \\_. obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\" - apply (simp add: tcbSchedEnqueue_def unless_when) - apply (wp threadSet_obj_at' hoare_drop_imps threadGet_wp - |simp split: if_split)+ - done - -crunch obj_at'_tcbIPCBuffer[wp]: rescheduleRequired "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" - (wp: crunch_wps tcbSchedEnqueue_tcbIPCBuffer simp: rescheduleRequired_def) - -context -notes if_cong[cong] -begin -crunch obj_at'_tcbIPCBuffer[wp]: setThreadState "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" - (wp: crunch_wps threadSet_obj_at'_really_strongest) -end - -crunch obj_at'_tcbIPCBuffer[wp]: getCTE "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" - (wp: setCTE_obj_at'_queued crunch_wps threadSet_obj_at'_really_strongest) - -crunch obj_at'_tcbIPCBuffer[wp]: emptySlot "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" - (wp: crunch_wps) - -crunch obj_at'_tcbIPCBuffer[wp]: transferCapsToSlots "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" - (wp: crunch_wps transferCapsToSlots_pres1 simp: crunch_simps ignore: constOnFailure) - -crunch obj_at'_tcbIPCBuffer[wp]: asUser "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" - (wp: crunch_wps) - -context -notes if_cong[cong] -begin -crunch obj_at'_tcbIPCBuffer[wp]: handleFault "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" - (wp: crunch_wps constOnFailure_wp tcbSchedEnqueue_tcbIPCBuffer threadSet_obj_at'_really_strongest - simp: zipWithM_x_mapM) -end - -lemma fastpath_callKernel_SysReplyRecv_corres: - "monadic_rewrite True False - (invs' and ct_in_state' ((=) Running) and (\s. ksSchedulerAction s = ResumeCurrentThread) - and cnode_caps_gsCNodes') - (callKernel (SyscallEvent SysReplyRecv)) (fastpaths SysReplyRecv)" - including no_pre - supply if_cong[cong] option.case_cong[cong] - apply (rule monadic_rewrite_introduce_alternative) - apply ( simp add: callKernel_def) - apply (rule monadic_rewrite_imp) - apply (simp add: handleEvent_def handleReply_def - handleRecv_def liftE_bindE_handle liftE_handle - bind_assoc getMessageInfo_def liftE_bind) - apply (simp add: catch_liftE_bindE unlessE_throw_catch_If - unifyFailure_catch_If catch_liftE - getMessageInfo_def alternative_bind - fastpaths_def getThreadCallerSlot_def - locateSlot_conv capability_case_Null_ReplyCap - getThreadCSpaceRoot_def - cong: if_cong) - apply (rule monadic_rewrite_rdonly_bind_l, wp) - apply (rule monadic_rewrite_bind_tail) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac thread msgInfo) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac cptr) - apply (rule monadic_rewrite_symb_exec_r[OF threadGet_inv no_fail_threadGet]) - apply (rename_tac tcbFault) - apply (rule monadic_rewrite_alternative_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (simp add: lookupCap_def liftME_def lookupCapAndSlot_def - lookupSlotForThread_def bindE_assoc - split_def getThreadCSpaceRoot_def - locateSlot_conv liftE_bindE bindE_bind_linearise - capFaultOnFailure_def rethrowFailure_injection - injection_handler_catch bind_bindE_assoc - getThreadCallerSlot_def bind_assoc - getSlotCap_def - case_bool_If o_def - isRight_def[where x="Inr v" for v] - isRight_def[where x="Inl v" for v] - cong: if_cong) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac "cTableCTE") - - apply (rule monadic_rewrite_transverse, - rule monadic_rewrite_bind_head, - rule resolveAddressBitsFn_eq) - apply (rule monadic_rewrite_symb_exec_r, (wp | simp)+) - apply (rename_tac "rab_ret") - - apply (rule_tac P="isRight rab_ret" in monadic_rewrite_cases[rotated]) - apply (case_tac rab_ret, simp_all add: isRight_def)[1] - apply (rule monadic_rewrite_alternative_l) - apply clarsimp - apply (simp add: isRight_case_sum liftE_bind - isRight_def[where x="Inr v" for v]) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac ep_cap) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_symb_exec_r[OF _ _ _ active_ntfn_check_wp, unfolded bind_assoc fun_app_def]) - apply (rule hoare_pre, (wp | wpc | simp)+)[1] - apply (unfold getBoundNotification_def)[1] - apply (wp threadGet_wp) - apply (rename_tac ep) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac ep) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_rdonly_bind_l, wp) - apply (rule monadic_rewrite_bind_tail) - apply (rename_tac replyCTE) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (simp add: bind_assoc) - apply (rule monadic_rewrite_rdonly_bind_l, wp assert_inv) - apply (rule monadic_rewrite_assert) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac callerFault) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (simp add: getThreadVSpaceRoot_def locateSlot_conv) - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac vTableCTE) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - - apply (rule monadic_rewrite_symb_exec_r[OF curDomain_inv], - simp only: curDomain_def, rule non_fail_gets) - apply (rename_tac "curDom") - apply (rule monadic_rewrite_symb_exec_r - [OF threadGet_inv no_fail_threadGet]) - apply (rename_tac callerPrio) - apply (simp add: isHighestPrio_def') - apply (rule monadic_rewrite_symb_exec_r [OF gets_inv non_fail_gets]) - apply (rename_tac highest) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - - apply (rule monadic_rewrite_symb_exec_r, wp+) - apply (rename_tac asidMap) - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_symb_exec_r[OF threadGet_inv no_fail_threadGet]) - apply (rename_tac "callerDom") - apply (rule monadic_rewrite_if_rhs[rotated]) - apply (rule monadic_rewrite_alternative_l) - apply (rule monadic_rewrite_trans, - rule monadic_rewrite_pick_alternative_1) - apply (rule_tac P="\v. obj_at' (%tcb. tcbIPCBuffer tcb = v) (capTCBPtr (cteCap replyCTE))" - in monadic_rewrite_exists_v) - apply (rename_tac ipcBuffer) - - apply (simp add: ARM_HYP_H.switchToThread_def bind_assoc) - apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) - - apply (rule_tac v=ipcBuffer in monadic_rewrite_threadGet_tcbIPCBuffer - | rule monadic_rewrite_bind monadic_rewrite_refl)+ - apply (wp mapM_x_wp' getObject_inv | wpc | simp | wp (once) hoare_drop_imps)+ - apply (rule_tac v=ipcBuffer in monadic_rewrite_threadGet_tcbIPCBuffer - | rule monadic_rewrite_bind monadic_rewrite_refl)+ - apply (wp setCTE_obj_at'_tcbIPCBuffer assert_inv mapM_x_wp' getObject_inv - | wpc | simp | wp (once) hoare_drop_imps )+ - - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_head) - apply (rule monadic_rewrite_trans) - apply (rule doReplyTransfer_simple) - apply simp - apply (((rule monadic_rewrite_weaken2, - (rule_tac msgInfo=msgInfo in doIPCTransfer_simple_rewrite - | rule_tac destPrio=callerPrio - and curDom=curDom and destDom=callerDom - and thread=thread in possibleSwitchTo_rewrite)) - | rule cteDeleteOne_replycap_rewrite - | rule monadic_rewrite_bind monadic_rewrite_refl - | wp assert_inv mapM_x_wp' - setThreadState_obj_at_unchanged - asUser_obj_at_unchanged - hoare_strengthen_post[OF _ obj_at_conj'[simplified atomize_conjL], rotated] - lookupBitmapPriority_lift - setThreadState_runnable_bitmap_inv - threadSet_lookupBitmapPriority_inv - | simp add: setMessageInfo_def setThreadState_runnable_simp - | wp (once) hoare_vcg_disj_lift)+)[1] - apply (simp add: setMessageInfo_def) - apply (rule monadic_rewrite_bind_tail) - apply (rename_tac unblocked) - apply (rule_tac rv=thread in monadic_rewrite_symb_exec_l_known, - (wp empty_fail_getCurThread)+) - apply (rule_tac rv=cptr in monadic_rewrite_symb_exec_l_known, - (wp empty_fail_asUser empty_fail_getRegister)+) - apply (rule monadic_rewrite_bind) - apply (rule monadic_rewrite_catch[OF _ monadic_rewrite_refl True_E_E]) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rename_tac cTableCTE2, - rule_tac P="cteCap cTableCTE2 = cteCap cTableCTE" - in monadic_rewrite_gen_asm) - apply simp - apply (rule monadic_rewrite_trans, - rule monadic_rewrite_bindE[OF _ monadic_rewrite_refl]) - apply (rule_tac slot="\s. ksCurThread s + 2 ^ cte_level_bits * tcbCTableSlot" - in resolveAddressBitsFn_eq_name_slot) - apply wp - apply (rule monadic_rewrite_trans) - apply (rule_tac rv=rab_ret - in monadic_rewrite_gets_known[where m="NonDetMonad.lift f" - for f, folded bindE_def]) - apply (simp add: NonDetMonad.lift_def isRight_case_sum) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rename_tac ep_cap2) - apply (rule_tac P="cteCap ep_cap2 = cteCap ep_cap" in monadic_rewrite_gen_asm) - apply (simp add: cap_case_EndpointCap_NotificationCap) - apply (rule monadic_rewrite_liftE) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind) - apply (rule deleteCallerCap_nullcap_rewrite) - apply (rule_tac ep=ep in receiveIPC_simple_rewrite) - apply (wp, simp) - apply (rule monadic_rewrite_bind_head) - - apply (rule monadic_rewrite_weaken[where E=True and F=True], simp) - apply (rule setThreadState_rewrite_simple) - apply clarsimp - apply (wp getCTE_known_cap)+ - apply (rule monadic_rewrite_bind) - apply (rule_tac t="capTCBPtr (cteCap replyCTE)" - and t'=thread - in schedule_known_rewrite) - apply (rule monadic_rewrite_weaken[where E=True and F=True], simp) - apply (rule monadic_rewrite_bind) - apply (rule activateThread_simple_rewrite) - apply (rule monadic_rewrite_refl) - apply wp - apply wp - apply (simp add: ct_in_state'_def, simp add: ct_in_state'_def[symmetric]) - apply ((wp setCurThread_ct_in_state[folded st_tcb_at'_def] - Arch_switchToThread_pred_tcb')+)[2] - apply (simp add: catch_liftE) - apply (wp setEndpoint_obj_at_tcb' threadSet_pred_tcb_at_state[unfolded if_bool_eq_conj]) - - apply (wp setEndpoint_obj_at_tcb' - threadSet_pred_tcb_at_state[unfolded if_bool_eq_conj] - fastpathBestSwitchCandidate_lift[where f="setEndpoint a b" for a b] - fastpathBestSwitchCandidate_lift[where f="threadSet f t" for f t] - | simp - | rule hoare_lift_Pf2[where f=ksCurThread, OF _ setEndpoint_ct'] - hoare_lift_Pf2[where f=ksCurThread, OF _ threadSet_ct])+ - - apply (simp cong: rev_conj_cong) - apply (strengthen imp_consequent[where Q="tcb_at' t s" for t s]) - apply (unfold setSchedulerAction_def)[3] - apply ((wp setThreadState_oa_queued user_getreg_rv setThreadState_no_sch_change - setThreadState_obj_at_unchanged - sts_st_tcb_at'_cases sts_bound_tcb_at' - emptySlot_obj_at'_not_queued - emptySlot_cte_wp_at_cteCap - emptySlot_cnode_caps - user_getreg_inv asUser_typ_ats - asUser_obj_at_not_queued asUser_obj_at' mapM_x_wp' - static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift - static_imp_wp cnode_caps_gsCNodes_lift - hoare_vcg_ex_lift - | simp del: comp_apply - | clarsimp simp: obj_at'_weakenE[OF _ TrueI])+) - - apply (rule hoare_lift_Pf2[where f=ksCurThread, OF _ setThreadState_ct']) - apply (wp setThreadState_oa_queued - fastpathBestSwitchCandidate_lift[where f="setThreadState f t" for f t]) - apply (simp add: setThreadState_runnable_simp) - apply (wp threadSet_tcbState_st_tcb_at') - apply (clarsimp simp del: comp_apply) - apply (wp emptySlot_obj_at_ep)+ - - apply ((wp setThreadState_oa_queued user_getreg_rv - setThreadState_no_sch_change - setThreadState_obj_at_unchanged - sts_st_tcb_at'_cases sts_bound_tcb_at' - emptySlot_obj_at'_not_queued - emptySlot_cte_wp_at_cteCap - emptySlot_cnode_caps - user_getreg_inv asUser_typ_ats - asUser_obj_at_not_queued asUser_obj_at' mapM_x_wp' - static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift - static_imp_wp cnode_caps_gsCNodes_lift - hoare_vcg_ex_lift - | simp del: comp_apply - | clarsimp simp: obj_at'_weakenE[OF _ TrueI] - | solves \ - rule hoare_lift_Pf2[where f=ksCurThread, OF _ emptySlot_ct] - hoare_lift_Pf2[where f=ksCurThread, OF _ asUser_ct], - wp fastpathBestSwitchCandidate_lift[where f="emptySlot a b" for a b] - fastpathBestSwitchCandidate_lift[where f="asUser a b" for a b] - user_getreg_inv asUser_typ_ats\)+) - - apply (clarsimp | wp getCTE_wp' gts_imp')+ - - apply (simp add: ARM_HYP_H.switchToThread_def getTCB_threadGet bind_assoc) - apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) - - apply (rule_tac v=ipcBuffer in monadic_rewrite_threadGet_tcbIPCBuffer | rule monadic_rewrite_bind monadic_rewrite_refl)+ - apply (wp mapM_x_wp' handleFault_obj_at'_tcbIPCBuffer getObject_inv | wpc | simp - | wp (once) hoare_drop_imps )+ - apply (rule_tac v=ipcBuffer in monadic_rewrite_threadGet_tcbIPCBuffer | rule monadic_rewrite_bind monadic_rewrite_refl)+ - apply (wp setCTE_obj_at'_tcbIPCBuffer assert_inv mapM_x_wp' getObject_inv | wpc | simp - | wp (once) hoare_drop_imps )+ - - apply (simp add: bind_assoc catch_liftE - receiveIPC_def Let_def liftM_def - setThreadState_runnable_simp) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getThreadState)+) - apply (rule monadic_rewrite_assert) - - apply (rule_tac P="inj (case_bool thread (capTCBPtr (cteCap replyCTE)))" - in monadic_rewrite_gen_asm) - apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) - apply (rule monadic_rewrite_weaken[where F=False and E=True], simp) - apply (rule isolate_thread_actions_rewrite_bind - fastpath_isolate_rewrites fastpath_isolatables - bool.simps setRegister_simple - zipWithM_setRegister_simple - thread_actions_isolatable_bind - thread_actions_isolatableD[OF setCTE_isolatable] - setCTE_isolatable - threadGet_vcpu_isolatable[THEN thread_actions_isolatableD, simplified o_def] - threadGet_vcpu_isolatable[simplified o_def] - vcpuSwitch_isolatable[THEN thread_actions_isolatableD] vcpuSwitch_isolatable - setVMRoot_isolatable[THEN thread_actions_isolatableD] setVMRoot_isolatable - doMachineOp_isolatable[THEN thread_actions_isolatableD] doMachineOp_isolatable - kernelExitAssertions_isolatable[THEN thread_actions_isolatableD] - kernelExitAssertions_isolatable - | assumption - | wp assert_inv)+ - apply (simp only: ) - apply (rule_tac P="(\s. ksSchedulerAction s = ResumeCurrentThread) - and tcb_at' thread - and (cte_wp_at' (\cte. isReplyCap (cteCap cte)) - (thread + 2 ^ cte_level_bits * tcbCallerSlot) - and (\s. \x. tcb_at' (case_bool thread (capTCBPtr (cteCap replyCTE)) x) s) - and valid_mdb')" - and F=True and E=False in monadic_rewrite_weaken) - apply (rule monadic_rewrite_isolate_final2) - apply simp - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rename_tac callerCTE) - apply (rule monadic_rewrite_assert) - apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) - apply (rule monadic_rewrite_assert) - apply (simp add: emptySlot_setEndpoint_pivot) - apply (rule monadic_rewrite_bind) - apply (rule monadic_rewrite_refl2) - apply (clarsimp simp: isSendEP_def split: Structures_H.endpoint.split) - apply (rule_tac Q="\rv. (\_. rv = callerCTE) and Q'" for Q' - in monadic_rewrite_symb_exec_r, wp+) - apply (rule monadic_rewrite_gen_asm, simp) - apply (rule monadic_rewrite_trans, rule monadic_rewrite_bind_head, - rule_tac cte=callerCTE in emptySlot_replymaster_rewrite) - apply (simp add: bind_assoc o_def) - apply (rule monadic_rewrite_refl) - apply (simp add: cte_wp_at_ctes_of pred_conj_def) - apply (clarsimp | wp getCTE_ctes_wp)+ - apply (clarsimp simp: zip_map2 zip_same_conv_map foldl_map - foldl_fun_upd - foldr_copy_register_tsrs - isRight_case_sum - cong: if_cong) - apply (clarsimp simp: fun_eq_iff if_flip - cong: if_cong) - apply (drule obj_at_ko_at', clarsimp) - apply (frule get_tcb_state_regs_ko_at') - apply (clarsimp simp: zip_map2 zip_same_conv_map foldl_map - foldl_fun_upd - foldr_copy_register_tsrs - isRight_case_sum - cong: if_cong) - apply (simp add: upto_enum_def fromEnum_def - enum_register toEnum_def - msgRegisters_unfold - cong: if_cong) - apply (clarsimp split: if_split) - apply (rule ext) - apply (simp add: badgeRegister_def msgInfoRegister_def - ARM_HYP.msgInfoRegister_def - ARM_HYP.badgeRegister_def - cong: if_cong - split: if_split) - apply simp - apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps - map_to_ctes_partial_overwrite) - apply (simp add: valid_mdb'_def valid_mdb_ctes_def) - apply simp - apply (simp cong: if_cong bool.case_cong - | rule getCTE_wp' gts_wp' threadGet_wp - getEndpoint_wp gets_wp - user_getreg_wp user_getregs_wp - gets_the_wp gct_wp getNotification_wp - return_wp liftM_wp gbn_wp' - | (simp only: curDomain_def, wp)[1])+ - - apply clarsimp - apply (subgoal_tac "ksCurThread s \ ksIdleThread s") - prefer 2 - apply (fastforce simp: ct_in_state'_def dest: ct_running_not_idle' elim: pred_tcb'_weakenE) - - apply (clarsimp simp: ct_in_state'_def pred_tcb_at') - apply (subst tcb_at_cte_at_offset, - erule obj_at'_weakenE[OF _ TrueI], - simp add: tcb_cte_cases_def cte_level_bits_def tcbSlots) - apply (clarsimp simp: valid_objs_ntfn_at_tcbBoundNotification - invs_valid_objs' if_apply_def2) - apply (rule conjI[rotated]) - apply (fastforce elim: cte_wp_at_weakenE') - apply (clarsimp simp: isRight_def) - apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp+) - apply (frule resolveAddressBitsFn_real_cte_at', - (clarsimp | erule cte_wp_at_weakenE')+) - apply (frule real_cte_at', clarsimp) - apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp, - clarsimp simp: isCap_simps, simp add: valid_cap_simps') - apply (clarsimp simp: maskCapRights_def isCap_simps) - apply (frule_tac p="p' + 2 ^ cte_level_bits * tcbCallerSlot" for p' - in cte_wp_at_valid_objs_valid_cap', clarsimp+) - apply (clarsimp simp: valid_cap_simps') - apply (subst tcb_at_cte_at_offset, - assumption, simp add: tcb_cte_cases_def cte_level_bits_def tcbSlots) - apply (clarsimp simp: inj_case_bool cte_wp_at_ctes_of - length_msgRegisters - n_msgRegisters_def order_less_imp_le - tcb_at_invs' invs_mdb' - split: bool.split) - apply (subst imp_disjL[symmetric], intro allI impI) - apply (clarsimp simp: inj_case_bool cte_wp_at_ctes_of - length_msgRegisters - n_msgRegisters_def order_less_imp_le - tcb_at_invs' invs_mdb' - split: bool.split) - - apply (subgoal_tac "fastpathBestSwitchCandidate v0a s") - prefer 2 - apply normalise_obj_at' - apply (rule_tac ttcb=tcba and ctcb=tcb in fastpathBestSwitchCandidateI) - apply (erule disjE, blast, blast) - apply simp+ - - apply (clarsimp simp: obj_at_tcbs_of tcbSlots - cte_level_bits_def) - apply (frule(1) st_tcb_at_is_Reply_imp_not_tcbQueued) - apply (auto simp: obj_at_tcbs_of tcbSlots - cte_level_bits_def) - done - -lemmas fastpath_reply_recv_ccorres_callKernel - = monadic_rewrite_ccorres_assemble[OF fastpath_reply_recv_ccorres fastpath_callKernel_SysReplyRecv_corres] - -lemma cnode_caps_gsCNodes_from_sr: - "valid_objs s \ (s, s') \ state_relation - \ cnode_caps_gsCNodes' s'" - apply (clarsimp simp: cnode_caps_gsCNodes_def only_cnode_caps_def - o_def ran_map_option) - apply (safe, simp_all) - apply (clarsimp elim!: ranE) - apply (frule(1) pspace_relation_cte_wp_atI[rotated]) - apply clarsimp - apply (clarsimp simp: is_cap_simps) - apply (frule(1) cte_wp_at_valid_objs_valid_cap) - apply (clarsimp simp: valid_cap_simps cap_table_at_gsCNodes_eq) - done - end end diff --git a/proof/crefine/ARM_HYP/Fastpath_Defs.thy b/proof/crefine/ARM_HYP/Fastpath_Defs.thy new file mode 100644 index 000000000..b60b99b41 --- /dev/null +++ b/proof/crefine/ARM_HYP/Fastpath_Defs.thy @@ -0,0 +1,167 @@ +(* + * Copyright 2014, General Dynamics C4 Systems + * Copyright 2022, Proofcraft Pty Ltd + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +(* Contains the design specification of optimised fast paths though the kernel. + These paths check for specific circumstances before engaging, otherwise + falling back to the full kernel design specification (callKernel). + For this reason, fastpath + callKernel is expected to be semantically + identical to callKernel. *) + +theory Fastpath_Defs +imports ArchMove_C +begin + +context begin interpretation Arch . (*FIXME: arch_split*) + +definition + "fastpaths sysc \ case sysc of + SysCall \ doE + curThread \ liftE $ getCurThread; + mi \ liftE $ getMessageInfo curThread; + cptr \ liftE $ asUser curThread $ getRegister capRegister; + + fault \ liftE $ threadGet tcbFault curThread; + pickFastpath \ liftE $ alternative (return True) (return False); + unlessE (fault = None \ msgExtraCaps mi = 0 + \ msgLength mi \ of_nat size_msgRegisters \ pickFastpath) + $ throwError (); + + ctab \ liftE $ getThreadCSpaceRoot curThread >>= getCTE; + epCap \ unifyFailure (doE t \ resolveAddressBits (cteCap ctab) cptr (size cptr); + liftE (getSlotCap (fst t)) odE); + unlessE (isEndpointCap epCap \ capEPCanSend epCap) + $ throwError (); + ep \ liftE $ getEndpoint (capEPPtr epCap); + unlessE (isRecvEP ep) $ throwError (); + dest \ returnOk $ hd $ epQueue ep; + newVTable \ liftE $ getThreadVSpaceRoot dest >>= getCTE; + unlessE (isValidVTableRoot $ cteCap newVTable) $ throwError (); + pd \ returnOk $ capPDBasePtr $ capCap $ cteCap newVTable; + curDom \ liftE $ curDomain; + curPrio \ liftE $ threadGet tcbPriority curThread; + destPrio \ liftE $ threadGet tcbPriority dest; + highest \ liftE $ isHighestPrio curDom destPrio; + unlessE (destPrio \ curPrio \ highest) $ throwError (); + unlessE (capEPCanGrant epCap \ capEPCanGrantReply epCap) $ throwError (); + asidMap \ liftE $ gets $ armKSASIDMap o ksArchState; + unlessE (\v. {hwasid. (hwasid, pd) \ ran asidMap} = {v}) + $ throwError (); + destDom \ liftE $ threadGet tcbDomain dest; + unlessE (destDom = curDom) $ throwError (); + + liftE $ do + setEndpoint (capEPPtr epCap) + (case tl (epQueue ep) of [] \ IdleEP | _ \ RecvEP (tl (epQueue ep))); + threadSet (tcbState_update (\_. BlockedOnReply)) curThread; + replySlot \ getThreadReplySlot curThread; + callerSlot \ getThreadCallerSlot dest; + replySlotCTE \ getCTE replySlot; + assert (mdbNext (cteMDBNode replySlotCTE) = 0 + \ isReplyCap (cteCap replySlotCTE) + \ capReplyMaster (cteCap replySlotCTE) + \ mdbFirstBadged (cteMDBNode replySlotCTE) + \ mdbRevocable (cteMDBNode replySlotCTE)); + destState \ getThreadState dest; + cteInsert (ReplyCap curThread False (blockingIPCCanGrant destState)) replySlot callerSlot; + + forM_x (take (unat (msgLength mi)) msgRegisters) + (\r. do v \ asUser curThread (getRegister r); + asUser dest (setRegister r v) od); + setThreadState Running dest; + Arch.switchToThread dest; + setCurThread dest; + + asUser dest $ zipWithM_x setRegister + [badgeRegister, msgInfoRegister] + [capEPBadge epCap, wordFromMessageInfo (mi\ msgCapsUnwrapped := 0 \)]; + + stateAssert kernelExitAssertions [] + od + + odE (\_. callKernel (SyscallEvent sysc)) + | SysReplyRecv \ doE + curThread \ liftE $ getCurThread; + mi \ liftE $ getMessageInfo curThread; + cptr \ liftE $ asUser curThread $ getRegister capRegister; + + fault \ liftE $ threadGet tcbFault curThread; + pickFastpath \ liftE $ alternative (return True) (return False); + unlessE (fault = None \ msgExtraCaps mi = 0 + \ msgLength mi \ of_nat size_msgRegisters \ pickFastpath) + $ throwError (); + + ctab \ liftE $ getThreadCSpaceRoot curThread >>= getCTE; + epCap \ unifyFailure (doE t \ resolveAddressBits (cteCap ctab) cptr (size cptr); + liftE (getSlotCap (fst t)) odE); + + unlessE (isEndpointCap epCap \ capEPCanReceive epCap) + $ throwError (); + + bound_ntfn \ liftE $ getBoundNotification curThread; + active_ntfn \ liftE $ case bound_ntfn of None \ return False + | Some ntfnptr \ liftM isActive $ getNotification ntfnptr; + unlessE (\ active_ntfn) $ throwError (); + + ep \ liftE $ getEndpoint (capEPPtr epCap); + unlessE (\ isSendEP ep) $ throwError (); + + callerSlot \ liftE $ getThreadCallerSlot curThread; + callerCTE \ liftE $ getCTE callerSlot; + callerCap \ returnOk $ cteCap callerCTE; + unlessE (isReplyCap callerCap \ \ capReplyMaster callerCap) + $ throwError (); + + caller \ returnOk $ capTCBPtr callerCap; + callerFault \ liftE $ threadGet tcbFault caller; + unlessE (callerFault = None) $ throwError (); + newVTable \ liftE $ getThreadVSpaceRoot caller >>= getCTE; + unlessE (isValidVTableRoot $ cteCap newVTable) $ throwError (); + + curDom \ liftE $ curDomain; + callerPrio \ liftE $ threadGet tcbPriority caller; + highest \ liftE $ isHighestPrio curDom callerPrio; + unlessE highest $ throwError (); + + pd \ returnOk $ capPDBasePtr $ capCap $ cteCap newVTable; + asidMap \ liftE $ gets $ armKSASIDMap o ksArchState; + unlessE (\v. {hwasid. (hwasid, pd) \ ran asidMap} = {v}) + $ throwError (); + callerDom \ liftE $ threadGet tcbDomain caller; + unlessE (callerDom = curDom) $ throwError (); + + liftE $ do + epCanGrant \ return $ capEPCanGrant epCap; + threadSet (tcbState_update (\_. BlockedOnReceive (capEPPtr epCap) epCanGrant)) curThread; + setEndpoint (capEPPtr epCap) + (case ep of IdleEP \ RecvEP [curThread] | RecvEP ts \ RecvEP (ts @ [curThread])); + mdbPrev \ liftM (mdbPrev o cteMDBNode) $ getCTE callerSlot; + assert (mdbPrev \ 0); + updateMDB mdbPrev (mdbNext_update (K 0) o mdbFirstBadged_update (K True) + o mdbRevocable_update (K True)); + setCTE callerSlot makeObject; + + forM_x (take (unat (msgLength mi)) msgRegisters) + (\r. do v \ asUser curThread (getRegister r); + asUser caller (setRegister r v) od); + setThreadState Running caller; + Arch.switchToThread caller; + setCurThread caller; + + asUser caller $ zipWithM_x setRegister + [badgeRegister, msgInfoRegister] + [0, wordFromMessageInfo (mi\ msgCapsUnwrapped := 0 \)]; + + stateAssert kernelExitAssertions [] + od + + odE (\_. callKernel (SyscallEvent sysc)) + + | _ \ callKernel (SyscallEvent sysc)" + +end + +end diff --git a/proof/crefine/ARM_HYP/Fastpath_Equiv.thy b/proof/crefine/ARM_HYP/Fastpath_Equiv.thy new file mode 100644 index 000000000..93c754795 --- /dev/null +++ b/proof/crefine/ARM_HYP/Fastpath_Equiv.thy @@ -0,0 +1,1908 @@ +(* + * Copyright 2014, General Dynamics C4 Systems + * Copyright 2020, Proofcraft Pty Ltd + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +(* Contains proofs that fastpath + callKernel is semantically identical to + callKernel. *) + +theory Fastpath_Equiv +imports Fastpath_Defs IsolatedThreadAction Refine.RAB_FN +begin + +lemma setCTE_obj_at'_queued: + "\obj_at' (\tcb. P (tcbQueued tcb)) t\ setCTE p v \\rv. obj_at' (\tcb. P (tcbQueued tcb)) t\" + unfolding setCTE_def + by (rule setObject_cte_obj_at_tcb', simp+) + +crunch obj_at'_queued: cteInsert "obj_at' (\tcb. P (tcbQueued tcb)) t" + (wp: setCTE_obj_at'_queued crunch_wps) + +crunch obj_at'_not_queued: emptySlot "obj_at' (\a. \ tcbQueued a) p" + (wp: setCTE_obj_at'_queued) + +lemma getEndpoint_obj_at': + "\obj_at' P ptr\ getEndpoint ptr \\rv s. P rv\" + apply (wp getEndpoint_wp) + apply (clarsimp simp: obj_at'_def projectKOs) + done + +lemmas setEndpoint_obj_at_tcb' = setEndpoint_obj_at'_tcb + +lemma tcbSchedEnqueue_tcbContext[wp]: + "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ + tcbSchedEnqueue t' + \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + apply (rule tcbSchedEnqueue_obj_at_unchangedT[OF all_tcbI]) + apply simp + done + +lemma setCTE_tcbContext: + "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ + setCTE slot cte + \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + apply (simp add: setCTE_def) + apply (rule setObject_cte_obj_at_tcb', simp_all) + done + +context begin interpretation Arch . (*FIXME: arch_split*) + +lemma seThreadState_tcbContext: + "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ + setThreadState a b + \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + apply (rule setThreadState_obj_at_unchanged) + apply (clarsimp simp: atcbContext_def)+ + done + +lemma setBoundNotification_tcbContext: + "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ + setBoundNotification a b + \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + apply (rule setBoundNotification_obj_at_unchanged) + apply (clarsimp simp: atcbContext_def)+ + done + +declare comp_apply [simp del] +crunch tcbContext[wp]: deleteCallerCap "obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t" + (wp: setEndpoint_obj_at_tcb' setBoundNotification_tcbContext + setNotification_tcb crunch_wps seThreadState_tcbContext + simp: crunch_simps unless_def) +declare comp_apply [simp] + + +crunch ksArch[wp]: asUser "\s. P (ksArchState s)" + (wp: crunch_wps) + +definition + tcbs_of :: "kernel_state => word32 => tcb option" +where + "tcbs_of s = (%x. if tcb_at' x s then projectKO_opt (the (ksPSpace s x)) else None)" + +lemma obj_at_tcbs_of: + "obj_at' P t s = (EX tcb. tcbs_of s t = Some tcb & P tcb)" + apply (simp add: tcbs_of_def split: if_split) + apply (intro conjI impI) + apply (clarsimp simp: obj_at'_def projectKOs) + apply (clarsimp simp: obj_at'_weakenE[OF _ TrueI]) + done + +lemma st_tcb_at_tcbs_of: + "st_tcb_at' P t s = (EX tcb. tcbs_of s t = Some tcb & P (tcbState tcb))" + by (simp add: st_tcb_at'_def obj_at_tcbs_of) + +lemma tcbs_of_ko_at': + "\ tcbs_of s p = Some tcb \ \ ko_at' tcb p s" + by (simp add: obj_at_tcbs_of) + +lemma tcbs_of_valid_tcb': + "\ valid_objs' s; tcbs_of s p = Some tcb \ \ valid_tcb' tcb s" + by (frule tcbs_of_ko_at') + (drule (1) ko_at_valid_objs', auto simp: projectKOs valid_obj'_def) + +lemma acc_CNodeCap_repr: + "isCNodeCap cap + \ cap = CNodeCap (capCNodePtr cap) (capCNodeBits cap) + (capCNodeGuard cap) (capCNodeGuardSize cap)" + by (clarsimp simp: isCap_simps) + +lemma valid_cnode_cap_cte_at': + "\ s \' c; isCNodeCap c; ptr = capCNodePtr c; v < 2 ^ capCNodeBits c \ + \ cte_at' (ptr + v * 2^cteSizeBits) s" + apply (drule less_mask_eq) + apply (drule(1) valid_cap_cte_at'[where addr=v]) + apply (simp add: mult.commute mult.left_commute) + done + +lemmas valid_cnode_cap_cte_at'' + = valid_cnode_cap_cte_at'[simplified objBits_defs, simplified] + +declare of_int_sint_scast[simp] + +lemma isCNodeCap_capUntypedPtr_capCNodePtr: + "isCNodeCap c \ capUntypedPtr c = capCNodePtr c" + by (clarsimp simp: isCap_simps) + +lemma of_bl_from_bool: + "of_bl [x] = from_bool x" + by (cases x, simp_all add: from_bool_def) + +lemma dmo_clearExMonitor_setCurThread_swap: + "(do _ \ doMachineOp ARM_HYP.clearExMonitor; + setCurThread thread + od) + = (do _ \ setCurThread thread; + doMachineOp ARM_HYP.clearExMonitor od)" + apply (simp add: setCurThread_def doMachineOp_def split_def) + apply (rule oblivious_modify_swap[symmetric]) + apply (intro oblivious_bind, + simp_all add: select_f_oblivious) + done + +lemma pd_at_asid_inj': + "pd_at_asid' pd asid s \ pd_at_asid' pd' asid s \ pd' = pd" + by (clarsimp simp: pd_at_asid'_def obj_at'_def) + +lemma bind_case_sum_rethrow: + "rethrowFailure fl f >>= case_sum e g + = f >>= case_sum (e \ fl) g" + apply (simp add: rethrowFailure_def handleE'_def + bind_assoc) + apply (rule bind_cong[OF refl]) + apply (simp add: throwError_bind split: sum.split) + done + +declare empty_fail_assertE[iff] + +declare empty_fail_resolveAddressBits[iff] + +lemma lookupExtraCaps_null: + "msgExtraCaps info = 0 \ + lookupExtraCaps thread buffer info = returnOk []" + by (clarsimp simp: lookupExtraCaps_def + getExtraCPtrs_def liftE_bindE + upto_enum_step_def mapM_Nil + split: Types_H.message_info.split option.split) + +lemma isRecvEP_endpoint_case: + "isRecvEP ep \ case_endpoint f g h ep = f (epQueue ep)" + by (clarsimp simp: isRecvEP_def split: endpoint.split_asm) + +lemma unifyFailure_catch_If: + "catch (unifyFailure f >>=E g) h + = f >>= (\rv. if isRight rv then catch (g (theRight rv)) h else h ())" + apply (simp add: unifyFailure_def rethrowFailure_def + handleE'_def catch_def bind_assoc + bind_bindE_assoc cong: if_cong) + apply (rule bind_cong[OF refl]) + apply (simp add: throwError_bind isRight_def return_returnOk + split: sum.split) + done + +lemma st_tcb_at_not_in_ep_queue: + "\ st_tcb_at' P t s; ko_at' ep epptr s; sym_refs (state_refs_of' s); + ep \ IdleEP; \ts. P ts \ tcb_st_refs_of' ts = {} \ + \ t \ set (epQueue ep)" + apply clarsimp + apply (drule(1) sym_refs_ko_atD') + apply (cases ep, simp_all add: st_tcb_at_refs_of_rev') + apply (fastforce simp: st_tcb_at'_def obj_at'_def projectKOs)+ + done + +lemma st_tcb_at_not_in_ntfn_queue: + "\ st_tcb_at' P t s; ko_at' ntfn ntfnptr s; sym_refs (state_refs_of' s); ntfnObj ntfn = WaitingNtfn xs; + \ts. P ts \ (ntfnptr, TCBSignal) \ tcb_st_refs_of' ts \ + \ t \ set xs" + apply (drule(1) sym_refs_ko_atD') + apply (clarsimp simp: st_tcb_at_refs_of_rev') + apply (drule_tac x="(t, NTFNSignal)" in bspec, simp) + apply (fastforce simp: st_tcb_at'_def obj_at'_def projectKOs ko_wp_at'_def tcb_bound_refs'_def) + done + +lemma sym_refs_upd_sD: + "\ sym_refs ((state_refs_of' s) (p := S)); valid_pspace' s; + ko_at' ko p s; refs_of' (injectKO koEx) = S; + objBits koEx = objBits ko \ + \ \s'. sym_refs (state_refs_of' s') + \ (\p' (ko' :: endpoint). ko_at' ko' p' s \ injectKO ko' \ injectKO ko + \ ko_at' ko' p' s') + \ (\p' (ko' :: Structures_H.notification). ko_at' ko' p' s \ injectKO ko' \ injectKO ko + \ ko_at' ko' p' s') + \ (ko_at' koEx p s')" + apply (rule exI, rule conjI) + apply (rule state_refs_of'_upd[where ko'="injectKO koEx" and ptr=p and s=s, + THEN ssubst[where P=sym_refs], rotated 2]) + apply simp+ + apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs) + apply (clarsimp simp: project_inject objBits_def) + apply (clarsimp simp: obj_at'_def ps_clear_upd projectKOs + split: if_split) + apply (clarsimp simp: project_inject objBits_def) + apply auto + done + +lemma sym_refs_upd_tcb_sD: + "\ sym_refs ((state_refs_of' s) (p := {r \ state_refs_of' s p. snd r = TCBBound})); valid_pspace' s; + ko_at' (tcb :: tcb) p s \ + \ \s'. sym_refs (state_refs_of' s') + \ (\p' (ko' :: endpoint). + ko_at' ko' p' s \ ko_at' ko' p' s') + \ (\p' (ko' :: Structures_H.notification). + ko_at' ko' p' s \ ko_at' ko' p' s') + \ (st_tcb_at' ((=) Running) p s')" + apply (drule(2) sym_refs_upd_sD[where koEx="makeObject\tcbState := Running, tcbBoundNotification := tcbBoundNotification tcb\"]) + apply (clarsimp dest!: ko_at_state_refs_ofD') + apply (simp add: objBits_simps) + apply (erule exEI) + apply clarsimp + apply (auto simp: st_tcb_at'_def elim!: obj_at'_weakenE) + done + +lemma updateCap_cte_wp_at_cteMDBNode: + "\cte_wp_at' (\cte. P (cteMDBNode cte)) p\ + updateCap ptr cap + \\rv. cte_wp_at' (\cte. P (cteMDBNode cte)) p\" + apply (wp updateCap_cte_wp_at_cases) + apply (simp add: o_def) + done + +lemma ctes_of_Some_cte_wp_at: + "ctes_of s p = Some cte \ cte_wp_at' P p s = P cte" + by (clarsimp simp: cte_wp_at_ctes_of) + +lemma user_getreg_wp: + "\\s. tcb_at' t s \ (\rv. obj_at' (\tcb. (atcbContextGet o tcbArch) tcb r = rv) t s \ Q rv s)\ + asUser t (getRegister r) \Q\" + apply (rule_tac Q="\rv s. \rv'. rv' = rv \ Q rv' s" in hoare_post_imp) + apply simp + apply (rule hoare_pre, wp hoare_vcg_ex_lift user_getreg_rv) + apply (clarsimp simp: obj_at'_def) + done + +lemma setUntypedCapAsFull_replyCap[simp]: + "setUntypedCapAsFull cap (ReplyCap curThread False cg) slot = return ()" + by (clarsimp simp:setUntypedCapAsFull_def isCap_simps) + +lemma option_case_liftM_getNotification_wp: + "\\s. \rv. (case x of None \ rv = v | Some p \ obj_at' (\ntfn. f ntfn = rv) p s) + \ Q rv s\ case x of None \ return v | Some ptr \ liftM f $ getNotification ptr \ Q \" + apply (rule hoare_pre, (wpc; wp getNotification_wp)) + apply (auto simp: obj_at'_def) + done + +lemma threadSet_st_tcb_at_state: + "\\s. tcb_at' t s \ (if p = t + then obj_at' (\tcb. P (tcbState (f tcb))) t s + else st_tcb_at' P p s)\ + threadSet f t \\_. st_tcb_at' P p\" + apply (rule hoare_chain) + apply (rule threadSet_obj_at'_really_strongest) + prefer 2 + apply (simp add: st_tcb_at'_def) + apply (clarsimp split: if_splits simp: st_tcb_at'_def o_def) + done + +lemma recv_ep_queued_st_tcb_at': + "\ ko_at' (Structures_H.endpoint.RecvEP ts) epptr s ; + t \ set ts; + sym_refs (state_refs_of' s) \ + \ st_tcb_at' isBlockedOnReceive t s" + apply (drule obj_at_ko_at') + apply clarsimp + apply (drule (1) sym_refs_ko_atD') + apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def refs_of_rev') + apply (erule_tac x=t in ballE; clarsimp?) + apply (erule ko_wp_at'_weakenE) + apply (clarsimp simp: isBlockedOnReceive_def projectKOs) + done + +lemma valid_ep_typ_at_lift': + "\ \p. \typ_at' TCBT p\ f \\rv. typ_at' TCBT p\ \ + \ \\s. valid_ep' ep s\ f \\rv s. valid_ep' ep s\" + apply (cases ep, simp_all add: valid_ep'_def) + apply (wp hoare_vcg_const_Ball_lift typ_at_lifts | assumption)+ + done + +lemma threadSet_tcbState_valid_objs: + "\valid_tcb_state' st and valid_objs'\ + threadSet (tcbState_update (\_. st)) t + \\rv. valid_objs'\" + apply (wp threadSet_valid_objs') + apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def) + done + +lemmas monadic_rewrite_symb_exec_l' = monadic_rewrite_symb_exec_l'_preserve_names + +lemma possibleSwitchTo_rewrite: + "monadic_rewrite True True + (\s. obj_at' (\tcb. tcbPriority tcb = destPrio \ tcbDomain tcb = destDom) t s + \ ksSchedulerAction s = ResumeCurrentThread + \ ksCurThread s = thread + \ ksCurDomain s = curDom + \ destDom = curDom) + (possibleSwitchTo t) (setSchedulerAction (SwitchToThread t))" + supply if_split[split del] + apply (simp add: possibleSwitchTo_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_symb_exec_l'[OF threadGet_inv empty_fail_threadGet, + where P'=\], simp) + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac P="targetDom = curDom" in monadic_rewrite_gen_asm) + apply simp + apply (rule_tac P="action = ResumeCurrentThread" in monadic_rewrite_gen_asm) + apply simp + apply (rule monadic_rewrite_refl) + apply (wp threadGet_wp cd_wp |simp add: bitmap_fun_defs)+ + apply (simp add: getCurThread_def curDomain_def gets_bind_ign getSchedulerAction_def) + apply (rule monadic_rewrite_refl) + apply clarsimp + apply (auto simp: obj_at'_def) + done + +lemma scheduleSwitchThreadFastfail_False_wp: + "\\s. ct \ it \ cprio \ tprio \ + scheduleSwitchThreadFastfail ct it cprio tprio + \\rv s. \ rv \" + unfolding scheduleSwitchThreadFastfail_def + by (wp threadGet_wp) + (auto dest!: obj_at_ko_at' simp: le_def obj_at'_def) + +lemma lookupBitmapPriority_lift: + assumes prqL1: "\P. \\s. P (ksReadyQueuesL1Bitmap s)\ f \\_ s. P (ksReadyQueuesL1Bitmap s)\" + and prqL2: "\P. \\s. P (ksReadyQueuesL2Bitmap s)\ f \\_ s. P (ksReadyQueuesL2Bitmap s)\" + shows "\\s. P (lookupBitmapPriority d s) \ f \\_ s. P (lookupBitmapPriority d s) \" + unfolding lookupBitmapPriority_def + apply (rule hoare_pre) + apply (wps prqL1 prqL2) + apply wpsimp+ + done + +(* slow path additionally requires current thread not idle *) +definition + "fastpathBestSwitchCandidate t \ \s. + ksReadyQueuesL1Bitmap s (ksCurDomain s) = 0 + \ (\tprio. obj_at' (\tcb. tcbPriority tcb = tprio) t s + \ (obj_at' (\tcb. tcbPriority tcb \ tprio) (ksCurThread s) s + \ lookupBitmapPriority (ksCurDomain s) s \ tprio))" + +lemma fastpathBestSwitchCandidateI: + "\ ksReadyQueuesL1Bitmap s (ksCurDomain s) = 0 + \ tcbPriority ctcb \ tcbPriority ttcb + \ lookupBitmapPriority (ksCurDomain s) s \ tcbPriority ttcb; + ko_at' ttcb t s; ko_at' ctcb (ksCurThread s) s\ + \ fastpathBestSwitchCandidate t s" + unfolding fastpathBestSwitchCandidate_def + by normalise_obj_at' + +lemma fastpathBestSwitchCandidate_lift: + assumes ct[wp]: "\P. \\s. P (ksCurThread s) \ f \ \_ s. P (ksCurThread s) \" + assumes cd[wp]: "\P. \\s. P (ksCurDomain s) \ f \ \_ s. P (ksCurDomain s) \" + assumes l1[wp]: "\P. \\s. P (ksReadyQueuesL1Bitmap s) \ f \ \_ s. P (ksReadyQueuesL1Bitmap s) \" + assumes l2[wp]: "\P. \\s. P (ksReadyQueuesL2Bitmap s) \ f \ \_ s. P (ksReadyQueuesL2Bitmap s) \" + assumes p[wp]: "\P t. \ obj_at' (\tcb. P (tcbPriority tcb)) t \ f \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t \" + shows "\ tcb_at' t and fastpathBestSwitchCandidate t \ f \\rv. fastpathBestSwitchCandidate t \" + unfolding fastpathBestSwitchCandidate_def lookupBitmapPriority_def l1IndexToPrio_def + apply (rule hoare_pre) + apply (rule hoare_lift_Pf2[where f=ksCurDomain]) + apply (wp hoare_vcg_disj_lift hoare_vcg_all_lift) + apply (rule hoare_lift_Pf2[where f=ksCurThread]) + apply (rule hoare_lift_Pf2[where f=ksReadyQueuesL1Bitmap]) + apply (rule hoare_lift_Pf2[where f=ksReadyQueuesL2Bitmap]) + apply (wp hoare_vcg_imp_lift') + apply (strengthen not_obj_at'_strengthen) + apply (wpsimp simp: comp_def wp: l1 l2 hoare_vcg_disj_lift)+ + apply (drule (1) tcb_at_not_obj_at_elim'[rotated]) + apply (rename_tac tprio, erule_tac x=tprio in allE) + apply clarsimp + apply (drule (1) tcb_at_not_obj_at_elim'[rotated]) + apply (clarsimp simp: obj_at'_def) + done + +lemma fastpathBestSwitchCandidate_ksSchedulerAction_simp[simp]: + "fastpathBestSwitchCandidate t (s\ksSchedulerAction := a\) + = fastpathBestSwitchCandidate t s" + unfolding fastpathBestSwitchCandidate_def lookupBitmapPriority_def + by simp + +lemma schedule_rewrite_ct_not_runnable': + "monadic_rewrite True True + (\s. ksSchedulerAction s = SwitchToThread t \ ct_in_state' (Not \ runnable') s + \ (ksCurThread s \ ksIdleThread s) + \ fastpathBestSwitchCandidate t s) + (schedule) + (do setSchedulerAction ResumeCurrentThread; switchToThread t od)" + supply subst_all [simp del] + apply (simp add: schedule_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac P="action = SwitchToThread t" in monadic_rewrite_gen_asm, simp) + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac P="\ wasRunnable \ action = SwitchToThread t" + in monadic_rewrite_gen_asm,simp) + apply (rule monadic_rewrite_bind_tail, rename_tac idleThread) + apply (rule monadic_rewrite_bind_tail, rename_tac targetPrio) + apply (rule monadic_rewrite_bind_tail, rename_tac curPrio) + apply (rule monadic_rewrite_bind_tail, rename_tac fastfail) + apply (rule monadic_rewrite_bind_tail, rename_tac curDom) + apply (rule monadic_rewrite_bind_tail, rename_tac highest) + apply (rule_tac P="\ (fastfail \ \ highest)" in monadic_rewrite_gen_asm, simp only:) + apply simp + apply (rule monadic_rewrite_refl) + apply (wpsimp wp: hoare_vcg_imp_lift) + apply (simp add: isHighestPrio_def') + apply wp+ + apply (wp hoare_vcg_disj_lift) + apply (wp scheduleSwitchThreadFastfail_False_wp) + apply (wp hoare_vcg_disj_lift threadGet_wp'' | simp add: comp_def)+ + (* remove no-ops, somewhat by magic *) + apply (rule monadic_rewrite_symb_exec_l'_TT, solves wp, + wpsimp wp: empty_fail_isRunnable simp: isHighestPrio_def')+ + apply (simp add: setSchedulerAction_def) + apply (subst oblivious_modify_swap[symmetric], rule oblivious_switchToThread_schact) + apply (rule monadic_rewrite_refl) + apply wp+ + apply (clarsimp simp: ct_in_state'_def) + apply (strengthen not_pred_tcb_at'_strengthen, simp) + supply word_neq_0_conv[simp del] + apply normalise_obj_at' + apply (simp add: fastpathBestSwitchCandidate_def) + apply (erule_tac x="tcbPriority ko" in allE) + apply (erule impE, normalise_obj_at'+) + done + +crunch tcb2[wp]: "Arch.switchToThread" "tcb_at' t" + (ignore: ARM_HYP.clearExMonitor) + +lemma resolveAddressBits_points_somewhere: + "\\s. \slot. Q slot s\ resolveAddressBits cp cptr bits \Q\,-" + apply (rule_tac Q'="\rv s. \rv. Q rv s" in hoare_post_imp_R) + apply wp + apply clarsimp + done + +lemma foldr_copy_register_tsrs: + "foldr (\r . copy_register_tsrs x y r r (\x. x)) rs s + = (s (y := TCBStateRegs (tsrState (s y)) + (\r. if r \ set rs then tsrContext (s x) r + else tsrContext (s y) r)))" + apply (induct rs) + apply simp + apply (simp add: copy_register_tsrs_def fun_eq_iff + split: if_split) + done + +lemmas cteInsert_obj_at'_not_queued = cteInsert_obj_at'_queued[of "\a. \ a"] + +lemma monadic_rewrite_exists_v: + "[| !! v. monadic_rewrite E F (Q v) f g |] + ==> monadic_rewrite E F (%x. (EX v. P v x) & (ALL v. P v x --> Q v x)) f g" + apply (rule monadic_rewrite_name_pre) + apply clarsimp + apply (erule_tac x=v in meta_allE) + apply (erule monadic_rewrite_imp) + apply clarsimp + done + +lemma monadic_rewrite_threadGet: + "monadic_rewrite E F (obj_at' (\tcb. f tcb = v) t) + (threadGet f t) (return v)" + unfolding getThreadState_def + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans[rotated]) + apply (rule monadic_rewrite_gets_known) + apply (unfold threadGet_def liftM_def fun_app_def) + apply (rule monadic_rewrite_symb_exec_l' | wp | rule empty_fail_getObject getObject_inv)+ + apply (clarsimp; rule no_fail_getObject_tcb) + apply (simp only: exec_gets) + apply (rule_tac P = "(\s. (f x)=v) and tcb_at' t" in monadic_rewrite_refl3) + apply (simp add:) + apply (wp OMG_getObject_tcb | wpc)+ + apply (auto intro: obj_tcb_at') + done + +lemma monadic_rewrite_getThreadState: + "monadic_rewrite E F (obj_at' (\tcb. tcbState tcb = v) t) + (getThreadState t) (return v)" + unfolding getThreadState_def + by (rule monadic_rewrite_threadGet) + +lemma setCTE_obj_at'_tcbIPCBuffer: + "\obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\ setCTE p v \\rv. obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\" + unfolding setCTE_def + by (rule setObject_cte_obj_at_tcb', simp+) + +context +notes if_cong[cong] +begin +crunches cteInsert, asUser + for obj_at'_tcbIPCBuffer[wp]: "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" + (wp: setCTE_obj_at'_queued crunch_wps threadSet_obj_at'_really_strongest) +end + +crunch ksReadyQueues_inv[wp]: cteInsert "\s. P (ksReadyQueues s)" + (wp: hoare_drop_imps) + +crunches cteInsert, threadSet, asUser, emptySlot + for ksReadyQueuesL1Bitmap_inv[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and ksReadyQueuesL2Bitmap_inv[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + (wp: hoare_drop_imps) + +crunch ksReadyQueuesL1Bitmap_inv[wp]: setEndpoint "\s. P (ksReadyQueuesL1Bitmap s)" + (wp: setObject_ksPSpace_only updateObject_default_inv) +crunch ksReadyQueuesL2Bitmap_inv[wp]: setEndpoint "\s. P (ksReadyQueuesL2Bitmap s)" + (wp: setObject_ksPSpace_only updateObject_default_inv) + +lemma setThreadState_runnable_bitmap_inv: + "runnable' ts \ + \ \s. P (ksReadyQueuesL1Bitmap s) \ setThreadState ts t \\rv s. P (ksReadyQueuesL1Bitmap s) \" + "runnable' ts \ + \ \s. Q (ksReadyQueuesL2Bitmap s) \ setThreadState ts t \\rv s. Q (ksReadyQueuesL2Bitmap s) \" + by (simp_all add: setThreadState_runnable_simp, wp+) + +lemma fastpath_callKernel_SysCall_corres: + "monadic_rewrite True False + (invs' and ct_in_state' ((=) Running) + and (\s. ksSchedulerAction s = ResumeCurrentThread) + and (\s. ksDomainTime s \ 0)) + (callKernel (SyscallEvent SysCall)) (fastpaths SysCall)" + supply if_cong[cong] option.case_cong[cong] if_split[split del] + apply (rule monadic_rewrite_introduce_alternative) + apply (simp add: callKernel_def) + apply (rule monadic_rewrite_imp) + apply (simp add: handleEvent_def handleCall_def + handleInvocation_def liftE_bindE_handle + bind_assoc getMessageInfo_def) + apply (simp add: catch_liftE_bindE unlessE_throw_catch_If + unifyFailure_catch_If catch_liftE + getMessageInfo_def alternative_bind + fastpaths_def + cong: if_cong) + apply (rule monadic_rewrite_rdonly_bind_l, wp) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_rdonly_bind_l, wp) + apply (rule monadic_rewrite_bind_tail) + apply (rename_tac msgInfo) + apply (rule monadic_rewrite_rdonly_bind_l, wp) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_symb_exec_r + [OF threadGet_inv no_fail_threadGet]) + apply (rename_tac thread msgInfo ptr tcbFault) + apply (rule monadic_rewrite_alternative_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (simp add: split_def Syscall_H.syscall_def + liftE_bindE_handle bind_assoc + capFaultOnFailure_def) + apply (simp only: bindE_bind_linearise[where f="rethrowFailure fn f'" for fn f'] + bind_case_sum_rethrow) + apply (simp add: lookupCapAndSlot_def lookupSlotForThread_def + lookupSlotForThread_def bindE_assoc + liftE_bind_return_bindE_returnOk split_def + getThreadCSpaceRoot_def locateSlot_conv + returnOk_liftE[symmetric] const_def + getSlotCap_def) + apply (simp only: liftE_bindE_assoc) + apply (rule monadic_rewrite_rdonly_bind_l, wp) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_rdonly_bind_l) + apply (wp | simp)+ + apply (rule_tac fn="case_sum Inl (Inr \ fst)" in monadic_rewrite_split_fn) + apply (simp add: liftME_liftM[symmetric] liftME_def bindE_assoc) + apply (rule monadic_rewrite_refl) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (simp add: isRight_right_map isRight_case_sum) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_rdonly_bind_l[OF lookupIPC_inv]) + apply (rule monadic_rewrite_symb_exec_l[OF lookupIPC_inv empty_fail_lookupIPCBuffer]) + apply (simp add: lookupExtraCaps_null returnOk_bind liftE_bindE_handle + bind_assoc liftE_bindE_assoc + decodeInvocation_def Let_def from_bool_0 + performInvocation_def liftE_handle + liftE_bind) + apply (rule monadic_rewrite_symb_exec_r [OF getEndpoint_inv no_fail_getEndpoint]) + apply (rename_tac "send_ep") + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (simp add: getThreadVSpaceRoot_def locateSlot_conv) + apply (rule monadic_rewrite_symb_exec_r [OF getCTE_inv no_fail_getCTE]) + apply (rename_tac "pdCapCTE") + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_symb_exec_r[OF curDomain_inv], + simp only: curDomain_def, rule non_fail_gets) + apply (rename_tac "curDom") + apply (rule monadic_rewrite_symb_exec_r [OF threadGet_inv no_fail_threadGet])+ + apply (rename_tac curPrio destPrio) + apply (simp add: isHighestPrio_def') + apply (rule monadic_rewrite_symb_exec_r [OF gets_inv non_fail_gets]) + apply (rename_tac highest) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_symb_exec_r [OF gets_inv non_fail_gets]) + apply (rename_tac asidMap) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + + apply (rule monadic_rewrite_symb_exec_r[OF threadGet_inv no_fail_threadGet]) + apply (rename_tac "destDom") + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_trans, + rule monadic_rewrite_pick_alternative_1) + apply (rule monadic_rewrite_symb_exec_l[OF get_mrs_inv' empty_fail_getMRs]) + (* now committed to fastpath *) + apply (rule monadic_rewrite_trans) + apply (rule_tac F=True and E=True in monadic_rewrite_weaken) + apply simp + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac x=thread in monadic_rewrite_symb_exec, + (wp empty_fail_getCurThread)+) + apply (simp add: sendIPC_def bind_assoc) + apply (rule_tac x=send_ep in monadic_rewrite_symb_exec, + (wp empty_fail_getEndpoint getEndpoint_obj_at')+) + apply (rule_tac P="epQueue send_ep \ []" in monadic_rewrite_gen_asm) + apply (simp add: isRecvEP_endpoint_case list_case_helper bind_assoc) + apply (rule monadic_rewrite_bind_tail) + apply (elim conjE) + apply (rule monadic_rewrite_bind_tail, rename_tac dest_st) + apply (rule_tac P="\gr. dest_st = BlockedOnReceive (capEPPtr (fst (theRight rv))) gr" + in monadic_rewrite_gen_asm) + apply (rule monadic_rewrite_symb_exec2, (wp | simp)+) + apply (rule monadic_rewrite_bind) + apply clarsimp + apply (rule_tac msgInfo=msgInfo in doIPCTransfer_simple_rewrite) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_bind) + apply (rule_tac destPrio=destPrio + and curDom=curDom and destDom=destDom and thread=thread + in possibleSwitchTo_rewrite) + apply (rule monadic_rewrite_bind) + apply (rule monadic_rewrite_trans) + apply (rule setupCallerCap_rewrite) + apply (rule monadic_rewrite_bind_head) + apply (rule setThreadState_rewrite_simple, simp) + apply (rule monadic_rewrite_trans) + apply (rule_tac x=BlockedOnReply in monadic_rewrite_symb_exec, + (wp empty_fail_getThreadState)+) + apply simp + apply (rule monadic_rewrite_refl) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_head) + apply (rule_tac t="hd (epQueue send_ep)" + in schedule_rewrite_ct_not_runnable') + apply (simp add: bind_assoc) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_bind) + apply (rule switchToThread_rewrite) + apply (rule monadic_rewrite_bind) + apply (rule activateThread_simple_rewrite) + apply (rule monadic_rewrite_refl) + apply wp + apply (wp setCurThread_ct_in_state) + apply (simp only: st_tcb_at'_def[symmetric]) + apply (wp, clarsimp simp: cur_tcb'_def ct_in_state'_def) + apply (simp add: getThreadCallerSlot_def getThreadReplySlot_def + locateSlot_conv ct_in_state'_def cur_tcb'_def) + + apply ((wp assert_inv threadSet_pred_tcb_at_state + cteInsert_obj_at'_not_queued + | wps)+)[1] + + apply (wp fastpathBestSwitchCandidate_lift[where f="cteInsert c w w'" for c w w']) + apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] + apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] + apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] + apply ((wp assert_inv threadSet_pred_tcb_at_state cteInsert_obj_at'_not_queued | wps)+)[1] + apply (wp fastpathBestSwitchCandidate_lift[where f="threadSet f t" for f t]) + apply simp + apply ((wp assert_inv threadSet_pred_tcb_at_state + cteInsert_obj_at'_not_queued + | wps)+)[1] + apply (simp add: setSchedulerAction_def) + apply wp[1] + apply (simp cong: if_cong HOL.conj_cong add: if_bool_simps) + apply (simp_all only:)[5] + apply ((wp setThreadState_oa_queued[of _ "\a _ _. \ a"] + setThreadState_obj_at_unchanged + asUser_obj_at_unchanged mapM_x_wp' + sts_st_tcb_at'_cases + setThreadState_no_sch_change + setEndpoint_obj_at_tcb' + fastpathBestSwitchCandidate_lift[where f="setThreadState f t" for f t] + setThreadState_oa_queued + fastpathBestSwitchCandidate_lift[where f="asUser t f" for f t] + fastpathBestSwitchCandidate_lift[where f="setEndpoint a b" for a b] + lookupBitmapPriority_lift + setThreadState_runnable_bitmap_inv + | simp add: setMessageInfo_def + | wp (once) hoare_vcg_disj_lift)+) + + apply (simp add: setThreadState_runnable_simp + getThreadCallerSlot_def getThreadReplySlot_def + locateSlot_conv bind_assoc) + apply (rule_tac P="\v. obj_at' (%tcb. tcbIPCBuffer tcb = v) (hd (epQueue send_ep))" + in monadic_rewrite_exists_v) + apply (rename_tac ipcBuffer) + + apply (rule_tac P="\v. obj_at' (\tcb. tcbState tcb = v) (hd (epQueue send_ep))" + in monadic_rewrite_exists_v) + apply (rename_tac destState) + + apply (simp add: ARM_HYP_H.switchToThread_def getTCB_threadGet bind_assoc) + (* retrieving state or thread registers is not thread_action_isolatable, + translate into return with suitable precondition *) + apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) + apply (rule_tac v=destState in monadic_rewrite_getThreadState + | rule monadic_rewrite_bind monadic_rewrite_refl)+ + apply (wp mapM_x_wp' getObject_inv | wpc | simp | wp (once) hoare_drop_imps)+ + apply (rule_tac v=destState in monadic_rewrite_getThreadState + | rule monadic_rewrite_bind monadic_rewrite_refl)+ + apply (wp mapM_x_wp' getObject_inv | wpc | simp | wp (once) hoare_drop_imps)+ + + apply (rule_tac P="inj (case_bool thread (hd (epQueue send_ep)))" + in monadic_rewrite_gen_asm) + apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) + apply (rule monadic_rewrite_weaken[where F=False and E=True], simp) + apply (rule isolate_thread_actions_rewrite_bind + fastpath_isolate_rewrites fastpath_isolatables + bool.simps setRegister_simple + threadGet_vcpu_isolatable[THEN thread_actions_isolatableD, simplified o_def] + threadGet_vcpu_isolatable[simplified o_def] + vcpuSwitch_isolatable[THEN thread_actions_isolatableD] vcpuSwitch_isolatable + setVMRoot_isolatable[THEN thread_actions_isolatableD] setVMRoot_isolatable + doMachineOp_isolatable[THEN thread_actions_isolatableD] doMachineOp_isolatable + kernelExitAssertions_isolatable[THEN thread_actions_isolatableD] + kernelExitAssertions_isolatable + zipWithM_setRegister_simple + thread_actions_isolatable_bind + | assumption + | wp assert_inv)+ + apply (rule_tac P="\s. ksSchedulerAction s = ResumeCurrentThread + \ tcb_at' thread s" + and F=True and E=False in monadic_rewrite_weaken) + apply simp + apply (rule monadic_rewrite_isolate_final) + apply (simp add: isRight_case_sum cong: list.case_cong) + apply (clarsimp simp: fun_eq_iff if_flip + cong: if_cong) + apply (drule obj_at_ko_at', clarsimp) + apply (frule get_tcb_state_regs_ko_at') + apply (clarsimp simp: zip_map2 zip_same_conv_map foldl_map + foldl_fun_upd + foldr_copy_register_tsrs + isRight_case_sum + cong: if_cong) + apply (simp add: upto_enum_def fromEnum_def + enum_register toEnum_def + msgRegisters_unfold + cong: if_cong) + apply (clarsimp split: if_split) + apply (rule ext) + apply (simp add: badgeRegister_def msgInfoRegister_def + ARM_HYP.badgeRegister_def + ARM_HYP.msgInfoRegister_def + split: if_split) + apply simp + apply (wp | simp cong: if_cong bool.case_cong + | rule getCTE_wp' gts_wp' threadGet_wp + getEndpoint_wp)+ + apply (rule validE_cases_valid) + apply (simp add: isRight_def getSlotCap_def) + apply (wp getCTE_wp') + apply (rule resolveAddressBits_points_somewhere) + apply (simp cong: if_cong bool.case_cong) + apply wp + apply simp + apply (wp user_getreg_wp threadGet_wp)+ + + apply clarsimp + apply (subgoal_tac "ksCurThread s \ ksIdleThread s") + prefer 2 + apply (fastforce simp: ct_in_state'_def dest: ct_running_not_idle' elim: pred_tcb'_weakenE) + + apply (clarsimp simp: ct_in_state'_def pred_tcb_at') + apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp+) + apply (clarsimp simp: isCap_simps valid_cap'_def maskCapRights_def) + apply (frule ko_at_valid_ep', clarsimp) + apply (frule sym_refs_ko_atD'[where 'a=endpoint], clarsimp) + apply (clarsimp simp: valid_ep'_def isRecvEP_endpoint_case neq_Nil_conv + tcbVTableSlot_def cte_level_bits_def + cte_at_tcb_at_16' length_msgRegisters + size_msgRegisters_def order_less_imp_le + ep_q_refs_of'_def st_tcb_at_refs_of_rev' + cong: if_cong) + apply (rename_tac blockedThread ys tcba tcbb) + apply (frule invs_mdb') + apply (thin_tac "Ball S P" for S P)+ + supply imp_disjL[simp del] + apply (subst imp_disjL[symmetric]) + + (* clean up broken up disj implication and excessive references to same tcbs *) + apply normalise_obj_at' + apply (clarsimp simp: invs'_def valid_state'_def) + apply (fold imp_disjL, intro allI impI) + + apply (subgoal_tac "ksCurThread s \ blockedThread") + prefer 2 + apply normalise_obj_at' + apply clarsimp + apply (frule_tac t="blockedThread" in valid_queues_not_runnable_not_queued, assumption) + subgoal by (fastforce simp: st_tcb_at'_def elim: obj_at'_weakenE) + apply (subgoal_tac "fastpathBestSwitchCandidate blockedThread s") + prefer 2 + apply (rule_tac ttcb=tcbb and ctcb=tcb in fastpathBestSwitchCandidateI) + apply (solves \simp only: disj_ac\) + apply simp+ + apply (clarsimp simp: st_tcb_at'_def obj_at'_def objBits_simps projectKOs valid_mdb'_def + valid_mdb_ctes_def inj_case_bool + split: bool.split)+ + done + +lemma capability_case_Null_ReplyCap: + "(case cap of NullCap \ f | ReplyCap t b cg \ g t b cg | _ \ h) + = (if isReplyCap cap then g (capTCBPtr cap) (capReplyMaster cap) (capReplyCanGrant cap) + else if isNullCap cap then f else h)" + by (simp add: isCap_simps split: capability.split split del: if_split) + +lemma injection_handler_catch: + "catch (injection_handler f x) y + = catch x (y o f)" + apply (simp add: injection_handler_def catch_def handleE'_def + bind_assoc) + apply (rule bind_cong[OF refl]) + apply (simp add: throwError_bind split: sum.split) + done + +lemma doReplyTransfer_simple: + "monadic_rewrite True False + (obj_at' (\tcb. tcbFault tcb = None) receiver) + (doReplyTransfer sender receiver slot grant) + (do state \ getThreadState receiver; + assert (isReply state); + cte \ getCTE slot; + mdbnode \ return $ cteMDBNode cte; + assert (mdbPrev mdbnode \ 0 \ mdbNext mdbnode = 0); + parentCTE \ getCTE (mdbPrev mdbnode); + assert (isReplyCap (cteCap parentCTE) \ capReplyMaster (cteCap parentCTE)); + doIPCTransfer sender Nothing 0 grant receiver; + cteDeleteOne slot; + setThreadState Running receiver; + possibleSwitchTo receiver + od)" + apply (simp add: doReplyTransfer_def liftM_def nullPointer_def getSlotCap_def) + apply (rule monadic_rewrite_bind_tail)+ + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_threadGet)+) + apply (rule_tac P="rv = None" in monadic_rewrite_gen_asm, simp) + apply (rule monadic_rewrite_refl) + apply (wp threadGet_const gts_wp' getCTE_wp')+ + apply (simp add: o_def) + done + +lemma monadic_rewrite_if_known: + "monadic_rewrite F E ((\s. C = X) and \) (if C then f else g) (if X then f else g)" + apply (rule monadic_rewrite_gen_asm) + apply (simp split del: if_split) + apply (rule monadic_rewrite_refl) + done + +lemma receiveIPC_simple_rewrite: + "monadic_rewrite True False + ((\_. isEndpointCap ep_cap \ \ isSendEP ep) and (ko_at' ep (capEPPtr ep_cap) and + (\s. \ntfnptr. bound_tcb_at' ((=) (Some ntfnptr)) thread s \ obj_at' (Not \ isActive) ntfnptr s))) + (receiveIPC thread ep_cap True) + (do + setThreadState (BlockedOnReceive (capEPPtr ep_cap) (capEPCanGrant ep_cap)) thread; + setEndpoint (capEPPtr ep_cap) (RecvEP (case ep of RecvEP q \ (q @ [thread]) | _ \ [thread])) + od)" + apply (rule monadic_rewrite_gen_asm) + apply (simp add: receiveIPC_def) + apply (rule monadic_rewrite_imp) + apply (rule_tac rv=ep in monadic_rewrite_symb_exec_l_known, + (wp empty_fail_getEndpoint)+) + apply (rule monadic_rewrite_symb_exec_l, (wp | simp add: getBoundNotification_def)+) + apply (rule monadic_rewrite_symb_exec_l) + apply (rule hoare_pre, wpc, wp+, simp) + apply (simp split: option.split) + apply (rule monadic_rewrite_trans, rule monadic_rewrite_if_known[where X=False], simp) + apply (rule monadic_rewrite_refl3[where P=\]) + apply (cases ep, simp_all add: isSendEP_def)[1] + apply (wp getNotification_wp gbn_wp' getEndpoint_wp | wpc)+ + apply (clarsimp simp: obj_at'_def projectKOs pred_tcb_at'_def) + done + +lemma empty_fail_isFinalCapability: + "empty_fail (isFinalCapability cte)" + by (simp add: isFinalCapability_def Let_def split: if_split) + +lemma cteDeleteOne_replycap_rewrite: + "monadic_rewrite True False + (cte_wp_at' (\cte. isReplyCap (cteCap cte)) slot) + (cteDeleteOne slot) + (emptySlot slot NullCap)" + apply (simp add: cteDeleteOne_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rule_tac P="cteCap rv \ NullCap \ isReplyCap (cteCap rv) + \ \ isEndpointCap (cteCap rv) + \ \ isNotificationCap (cteCap rv)" + in monadic_rewrite_gen_asm) + apply (simp add: finaliseCapTrue_standin_def + capRemovable_def) + apply (rule monadic_rewrite_symb_exec_l, + (wp isFinalCapability_inv empty_fail_isFinalCapability)+) + apply (rule monadic_rewrite_refl) + apply (wp getCTE_wp')+ + apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) + done + +lemma cteDeleteOne_nullcap_rewrite: + "monadic_rewrite True False + (cte_wp_at' (\cte. cteCap cte = NullCap) slot) + (cteDeleteOne slot) + (return ())" + apply (simp add: cteDeleteOne_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rule_tac P="cteCap rv = NullCap" in monadic_rewrite_gen_asm) + apply simp + apply (rule monadic_rewrite_refl) + apply (wp getCTE_wp') + apply (clarsimp simp: cte_wp_at_ctes_of) + done + +lemma deleteCallerCap_nullcap_rewrite: + "monadic_rewrite True False + (cte_wp_at' (\cte. cteCap cte = NullCap) (thread + 2 ^ cte_level_bits * tcbCallerSlot)) + (deleteCallerCap thread) + (return ())" + apply (simp add: deleteCallerCap_def getThreadCallerSlot_def locateSlot_conv + getSlotCap_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rule monadic_rewrite_assert) + apply (rule cteDeleteOne_nullcap_rewrite) + apply (wp getCTE_wp) + apply (clarsimp simp: cte_wp_at_ctes_of) + done + +lemma emptySlot_cnode_caps: + "\\s. P (only_cnode_caps (ctes_of s)) \ cte_wp_at' (\cte. \ isCNodeCap (cteCap cte)) slot s\ + emptySlot slot NullCap + \\rv s. P (only_cnode_caps (ctes_of s))\" + apply (simp add: only_cnode_caps_def map_option_comp2 + o_assoc[symmetric] cteCaps_of_def[symmetric]) + apply (wp emptySlot_cteCaps_of) + apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of + elim!: rsubst[where P=P] intro!: ext + split: if_split) + done + +lemma asUser_obj_at_ep[wp]: + "\obj_at' P p\ asUser t m \\rv. obj_at' (P :: endpoint \ bool) p\" + apply (simp add: asUser_def split_def) + apply (wp hoare_drop_imps | simp)+ + done + +lemma setCTE_obj_at_ep[wp]: + "\obj_at' (P :: endpoint \ bool) p\ setCTE ptr cte \\rv. obj_at' P p\" + unfolding setCTE_def + apply (rule obj_at_setObject2) + apply (clarsimp simp: updateObject_cte typeError_def in_monad + split: Structures_H.kernel_object.split_asm + if_split_asm) + done + +lemma setCTE_obj_at_ntfn[wp]: + "\obj_at' (P :: Structures_H.notification \ bool) p\ setCTE ptr cte \\rv. obj_at' P p\" + unfolding setCTE_def + apply (rule obj_at_setObject2) + apply (clarsimp simp: updateObject_cte typeError_def in_monad + split: Structures_H.kernel_object.split_asm + if_split_asm) + done + +crunch obj_at_ep[wp]: emptySlot "obj_at' (P :: endpoint \ bool) p" + +crunch nosch[wp]: emptySlot "\s. P (ksSchedulerAction s)" + +crunches emptySlot, asUser + for gsCNodes[wp]: "\s. P (gsCNodes s)" + (wp: crunch_wps) + +crunch cte_wp_at'[wp]: possibleSwitchTo "cte_wp_at' P p" + (wp: hoare_drop_imps) + +crunch tcbContext[wp]: possibleSwitchTo "obj_at' (\tcb. P ( (atcbContextGet o tcbArch) tcb)) t" + (wp: crunch_wps simp_del: comp_apply) + +crunch only_cnode_caps[wp]: doFaultTransfer "\s. P (only_cnode_caps (ctes_of s))" + (wp: crunch_wps simp: crunch_simps) + +lemma tcbSchedDequeue_rewrite_not_queued: "monadic_rewrite True False (tcb_at' t and obj_at' (Not \ tcbQueued) t) (tcbSchedDequeue t) (return ())" + apply (simp add: tcbSchedDequeue_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac P="\ queued" in monadic_rewrite_gen_asm) + apply (simp add: when_def) + apply (rule monadic_rewrite_refl) + apply (wp threadGet_const) + + apply (rule monadic_rewrite_symb_exec_l) + apply wp+ + apply (rule monadic_rewrite_refl) + apply (wp) + apply (clarsimp simp: o_def obj_at'_def) + done + +lemma schedule_known_rewrite: + "monadic_rewrite True False + (\s. ksSchedulerAction s = SwitchToThread t + \ tcb_at' t s + \ obj_at' (Not \ tcbQueued) t s + \ ksCurThread s = t' + \ st_tcb_at' (Not \ runnable') t' s + \ (ksCurThread s \ ksIdleThread s) + \ fastpathBestSwitchCandidate t s) + (schedule) + (do Arch.switchToThread t; + setCurThread t; + setSchedulerAction ResumeCurrentThread od)" + supply subst_all[simp del] if_split[split del] + apply (simp add: schedule_def) + apply (simp only: Thread_H.switchToThread_def) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac P="action = SwitchToThread t" in monadic_rewrite_gen_asm, simp) + apply (rule monadic_rewrite_bind_tail) + apply (rule_tac P="\ wasRunnable \ action = SwitchToThread t" in monadic_rewrite_gen_asm,simp) + apply (rule monadic_rewrite_bind_tail, rename_tac idleThread) + apply (rule monadic_rewrite_bind_tail, rename_tac targetPrio) + apply (rule monadic_rewrite_bind_tail, rename_tac curPrio) + apply (rule monadic_rewrite_bind_tail, rename_tac fastfail) + apply (rule monadic_rewrite_bind_tail, rename_tac curDom) + apply (rule monadic_rewrite_bind_tail, rename_tac highest) + apply (rule_tac P="\ (fastfail \ \ highest)" in monadic_rewrite_gen_asm, simp only:) + apply simp + apply (simp add: bind_assoc) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_bind) + apply (rule monadic_rewrite_trans) + apply (rule tcbSchedDequeue_rewrite_not_queued) + apply (rule monadic_rewrite_refl) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_refl) + apply (wpsimp wp: Arch_switchToThread_obj_at_pre)+ + apply (wp hoare_vcg_imp_lift)+ + apply (simp add: isHighestPrio_def') + apply wp+ + apply (wp hoare_vcg_disj_lift) + apply (wp scheduleSwitchThreadFastfail_False_wp) + apply wp+ + apply (wp hoare_vcg_disj_lift threadGet_wp'') + apply (wp hoare_vcg_disj_lift threadGet_wp'') + apply clarsimp + apply wp + apply (simp add: comp_def) + apply wp + apply wp + apply wp + (* remove no-ops, somewhat by magic *) + apply (rule monadic_rewrite_symb_exec_l'_TT, solves wp, + wpsimp wp: empty_fail_isRunnable simp: isHighestPrio_def')+ + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_symb_exec_l) + apply simp+ + apply (rule monadic_rewrite_refl) + apply wp+ + apply (rule monadic_rewrite_refl) + apply wp+ + apply (clarsimp simp: ct_in_state'_def) + apply (rule conjI) + apply (rule not_pred_tcb_at'_strengthen, assumption) + apply normalise_obj_at' + apply (simp add: fastpathBestSwitchCandidate_def) + apply normalise_obj_at' + done + +lemma tcb_at_cte_at_offset: + "\ tcb_at' t s; 2 ^ cte_level_bits * off \ dom tcb_cte_cases \ + \ cte_at' (t + 2 ^ cte_level_bits * off) s" + apply (clarsimp simp: obj_at'_def projectKOs objBits_simps) + apply (erule(2) cte_wp_at_tcbI') + apply fastforce + apply simp + done + +lemma emptySlot_cte_wp_at_cteCap: + "\\s. (p = p' \ P NullCap) \ (p \ p' \ cte_wp_at' (\cte. P (cteCap cte)) p s)\ + emptySlot p' irqopt + \\rv s. cte_wp_at' (\cte. P (cteCap cte)) p s\" + apply (simp add: tree_cte_cteCap_eq[unfolded o_def]) + apply (wp emptySlot_cteCaps_of) + apply (clarsimp split: if_split) + done + +lemma setEndpoint_getCTE_pivot[unfolded K_bind_def]: + "do setEndpoint p val; v <- getCTE slot; f v od + = do v <- getCTE slot; setEndpoint p val; f v od" + supply word_neq_0_conv[simp del] + apply (simp add: getCTE_assert_opt setEndpoint_def + setObject_modify_assert + fun_eq_iff bind_assoc) + apply (simp add: exec_gets assert_def assert_opt_def + exec_modify update_ep_map_to_ctes + split: if_split option.split) + done + +lemma setEndpoint_setCTE_pivot[unfolded K_bind_def]: + "do setEndpoint p val; setCTE slot cte; f od = + do setCTE slot cte; setEndpoint p val; f od" + supply if_split[split del] + apply (rule monadic_rewrite_to_eq) + apply simp + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans, + rule_tac f="ep_at' p" in monadic_rewrite_add_gets) + apply (rule monadic_rewrite_transverse, rule monadic_rewrite_add_gets, + rule monadic_rewrite_bind_tail) + apply (rename_tac epat) + apply (rule monadic_rewrite_transverse) + apply (rule monadic_rewrite_bind_tail) + apply (simp add: setEndpoint_def setObject_modify_assert bind_assoc) + apply (rule_tac rv=epat in monadic_rewrite_gets_known) + apply (wp setCTE_typ_at'[where T="koType TYPE(endpoint)", unfolded typ_at_to_obj_at'] + | simp)+ + apply (simp add: setCTE_assert_modify bind_assoc) + apply (rule monadic_rewrite_trans, rule monadic_rewrite_add_gets, + rule monadic_rewrite_bind_tail)+ + apply (rename_tac cteat tcbat) + apply (rule monadic_rewrite_trans, rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_trans) + apply (rule_tac rv=cteat in monadic_rewrite_gets_known) + apply (rule_tac rv=tcbat in monadic_rewrite_gets_known) + apply (wp setEndpoint_typ_at'[where T="koType TYPE(tcb)", unfolded typ_at_to_obj_at'] + setEndpoint_typ_at'[where T="koType TYPE(cte)", unfolded typ_at_to_obj_at'] + | simp)+ + apply (rule_tac P="\s. epat = ep_at' p s \ cteat = real_cte_at' slot s + \ tcbat = (tcb_at' (slot && ~~ mask 9) and (%y. slot && mask 9 : dom tcb_cte_cases)) s" + in monadic_rewrite_refl3) + apply (simp add: setEndpoint_def setObject_modify_assert bind_assoc + exec_gets assert_def exec_modify + split: if_split) + apply (auto split: if_split simp: obj_at'_def projectKOs objBits_defs + intro!: arg_cong[where f=f] ext kernel_state.fold_congs)[1] + apply wp+ + apply (simp add: objBits_defs) + done + +lemma setEndpoint_updateMDB_pivot[unfolded K_bind_def]: + "do setEndpoint p val; updateMDB slot mf; f od = + do updateMDB slot mf; setEndpoint p val; f od" + by (clarsimp simp: updateMDB_def bind_assoc + setEndpoint_getCTE_pivot + setEndpoint_setCTE_pivot + split: if_split) + +lemma setEndpoint_updateCap_pivot[unfolded K_bind_def]: + "do setEndpoint p val; updateCap slot mf; f od = + do updateCap slot mf; setEndpoint p val; f od" + by (clarsimp simp: updateCap_def bind_assoc + setEndpoint_getCTE_pivot + setEndpoint_setCTE_pivot) + +lemma modify_setEndpoint_pivot[unfolded K_bind_def]: + "\ \ksf s. ksPSpace_update ksf (sf s) = sf (ksPSpace_update ksf s) \ + \ (do modify sf; setEndpoint p val; f od) = + (do setEndpoint p val; modify sf; f od)" + apply (subgoal_tac "\s. ep_at' p (sf s) = ep_at' p s") + apply (simp add: setEndpoint_def setObject_modify_assert + bind_assoc fun_eq_iff + exec_gets exec_modify assert_def + split: if_split) + apply atomize + apply clarsimp + apply (drule_tac x="\_. ksPSpace s" in spec) + apply (drule_tac x="s" in spec) + apply (drule_tac f="ksPSpace" in arg_cong) + apply simp + apply (metis obj_at'_pspaceI) + done + +lemma setEndpoint_clearUntypedFreeIndex_pivot[unfolded K_bind_def]: + "do setEndpoint p val; v <- clearUntypedFreeIndex slot; f od + = do v <- clearUntypedFreeIndex slot; setEndpoint p val; f od" + supply option.case_cong_weak[cong del] + by (simp add: clearUntypedFreeIndex_def bind_assoc getSlotCap_def setEndpoint_getCTE_pivot + updateTrackedFreeIndex_def modify_setEndpoint_pivot + split: capability.split + | rule bind_cong[OF refl] allI impI bind_apply_cong[OF refl])+ + +lemma emptySlot_setEndpoint_pivot[unfolded K_bind_def]: + "(do emptySlot slot NullCap; setEndpoint p val; f od) = + (do setEndpoint p val; emptySlot slot NullCap; f od)" + apply (rule ext) + apply (simp add: emptySlot_def bind_assoc + setEndpoint_getCTE_pivot + setEndpoint_updateCap_pivot + setEndpoint_updateMDB_pivot + case_Null_If Retype_H.postCapDeletion_def + setEndpoint_clearUntypedFreeIndex_pivot + split: if_split + | rule bind_apply_cong[OF refl])+ + done + +lemma set_getCTE[unfolded K_bind_def]: + "do setCTE p cte; v <- getCTE p; f v od + = do setCTE p cte; f cte od" + apply simp + apply (rule monadic_rewrite_to_eq) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_bind_tail) + apply (simp add: getCTE_assert_opt bind_assoc) + apply (rule monadic_rewrite_trans, + rule_tac rv="Some cte" in monadic_rewrite_gets_known) + apply (simp add: assert_opt_def) + apply (rule monadic_rewrite_refl) + apply wp + apply simp + done + +lemma set_setCTE[unfolded K_bind_def]: + "do setCTE p val; setCTE p val' od = setCTE p val'" + supply if_split[split del] + apply simp + apply (rule monadic_rewrite_to_eq) + apply (rule monadic_rewrite_imp) + apply (rule monadic_rewrite_trans, + rule_tac f="real_cte_at' p" in monadic_rewrite_add_gets) + apply (rule monadic_rewrite_transverse, rule monadic_rewrite_add_gets, + rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_trans, + rule_tac f="tcb_at' (p && ~~ mask 9) and K (p && mask 9 \ dom tcb_cte_cases)" + in monadic_rewrite_add_gets) + apply (rule monadic_rewrite_transverse, rule monadic_rewrite_add_gets, + rule monadic_rewrite_bind_tail) + apply (rename_tac cteat tcbat) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_tail) + apply (simp add: setCTE_assert_modify) + apply (rule monadic_rewrite_trans, rule_tac rv=cteat in monadic_rewrite_gets_known) + apply (rule_tac rv=tcbat in monadic_rewrite_gets_known) + apply (wp setCTE_typ_at'[where T="koType TYPE(tcb)", unfolded typ_at_to_obj_at'] + setCTE_typ_at'[where T="koType TYPE(cte)", unfolded typ_at_to_obj_at'] + | simp)+ + apply (simp add: setCTE_assert_modify bind_assoc) + apply (rule monadic_rewrite_bind_tail)+ + apply (rule_tac P="c = cteat \ t = tcbat + \ (tcbat \ + (\ getF setF. tcb_cte_cases (p && mask 9) = Some (getF, setF) + \ (\ f g tcb. setF f (setF g tcb) = setF (f o g) tcb)))" + in monadic_rewrite_gen_asm) + apply (rule monadic_rewrite_refl2) + apply (simp add: exec_modify split: if_split) + apply (auto simp: simpler_modify_def projectKO_opt_tcb objBits_defs + intro!: kernel_state.fold_congs ext + split: if_split)[1] + apply wp+ + apply (clarsimp simp: objBits_defs intro!: all_tcbI) + apply (auto simp: tcb_cte_cases_def split: if_split_asm) + done + +lemma setCTE_updateCapMDB: + "p \ 0 \ + setCTE p cte = do updateCap p (cteCap cte); updateMDB p (const (cteMDBNode cte)) od" + supply if_split[split del] word_neq_0_conv[simp del] + apply (simp add: updateCap_def updateMDB_def bind_assoc set_getCTE + cte_overwrite set_setCTE) + apply (simp add: getCTE_assert_opt setCTE_assert_modify bind_assoc) + apply (rule ext, simp add: exec_gets assert_opt_def exec_modify + split: if_split option.split) + apply (cut_tac P=\ and p=p and s=x in cte_wp_at_ctes_of) + apply (cases cte) + apply (simp add: cte_wp_at_obj_cases') + apply (auto simp: mask_out_sub_mask) + done + +lemma clearUntypedFreeIndex_simple_rewrite: + "monadic_rewrite True False + (cte_wp_at' (Not o isUntypedCap o cteCap) slot) + (clearUntypedFreeIndex slot) (return ())" + apply (simp add: clearUntypedFreeIndex_def getSlotCap_def) + apply (rule monadic_rewrite_name_pre) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (rule monadic_rewrite_imp) + apply (rule_tac rv=cte in monadic_rewrite_symb_exec_l_known, wp+) + apply (simp split: capability.split, + strengthen monadic_rewrite_refl, simp) + apply clarsimp + apply (wp getCTE_wp') + apply (clarsimp simp: cte_wp_at_ctes_of) + done + +lemma emptySlot_replymaster_rewrite[OF refl]: + "mdbn = cteMDBNode cte \ + monadic_rewrite True False + ((\_. mdbNext mdbn = 0 \ mdbPrev mdbn \ 0) + and ((\_. cteCap cte \ NullCap) + and (cte_wp_at' ((=) cte) slot + and cte_wp_at' (\cte. isReplyCap (cteCap cte)) slot + and cte_wp_at' (\cte. isReplyCap (cteCap cte) \ capReplyMaster (cteCap cte)) + (mdbPrev mdbn) + and (\s. reply_masters_rvk_fb (ctes_of s)) + and (\s. no_0 (ctes_of s))))) + (emptySlot slot NullCap) + (do updateMDB (mdbPrev mdbn) (mdbNext_update (K 0) o mdbFirstBadged_update (K True) + o mdbRevocable_update (K True)); + setCTE slot makeObject + od)" + supply if_split[split del] word_neq_0_conv[simp del] + apply (rule monadic_rewrite_gen_asm)+ + apply (rule monadic_rewrite_imp) + apply (rule_tac P="slot \ 0" in monadic_rewrite_gen_asm) + apply (clarsimp simp: emptySlot_def setCTE_updateCapMDB) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_head) + apply (rule clearUntypedFreeIndex_simple_rewrite) + apply simp + apply (rule_tac rv=cte in monadic_rewrite_symb_exec_l_known, (wp empty_fail_getCTE)+) + apply (simp add: updateMDB_def Let_def bind_assoc makeObject_cte case_Null_If) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_bind) + apply (rule_tac P="mdbFirstBadged (cteMDBNode ctea) \ mdbRevocable (cteMDBNode ctea)" + in monadic_rewrite_gen_asm) + apply (rule monadic_rewrite_refl2) + apply (case_tac ctea, rename_tac mdbnode, case_tac mdbnode) + apply simp + apply (simp add: Retype_H.postCapDeletion_def) + apply (rule monadic_rewrite_refl) + apply (wp getCTE_wp')+ + apply (clarsimp simp: cte_wp_at_ctes_of reply_masters_rvk_fb_def) + apply (fastforce simp: isCap_simps) + done + +lemma all_prio_not_inQ_not_tcbQueued: "\ obj_at' (\a. (\d p. \ inQ d p a)) t s \ \ obj_at' (\a. \ tcbQueued a) t s" + apply (clarsimp simp: obj_at'_def inQ_def) +done + +crunches setThreadState, emptySlot, asUser + for ntfn_obj_at[wp]: "obj_at' (P::(Structures_H.notification \ bool)) ntfnptr" + (wp: obj_at_setObject2 crunch_wps + simp: crunch_simps updateObject_default_def in_monad) + +lemma st_tcb_at_is_Reply_imp_not_tcbQueued: "\s t.\ invs' s; st_tcb_at' isReply t s\ \ obj_at' (\a. \ tcbQueued a) t s" + apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def st_tcb_at'_def valid_queues_no_bitmap_def) + apply (rule all_prio_not_inQ_not_tcbQueued) + apply (clarsimp simp: obj_at'_def) + apply (erule_tac x="d" in allE) + apply (erule_tac x="p" in allE) + apply (erule conjE) + apply (erule_tac x="t" in ballE) + apply (clarsimp simp: obj_at'_def runnable'_def isReply_def) + apply (case_tac "tcbState obj") + apply ((clarsimp simp: inQ_def)+)[8] + apply (clarsimp simp: valid_queues'_def obj_at'_def) +done + +lemma valid_objs_ntfn_at_tcbBoundNotification: + "ko_at' tcb t s \ valid_objs' s \ tcbBoundNotification tcb \ None + \ ntfn_at' (the (tcbBoundNotification tcb)) s" + apply (drule(1) ko_at_valid_objs', simp add: projectKOs) + apply (simp add: valid_obj'_def valid_tcb'_def valid_bound_ntfn'_def) + apply clarsimp + done + +crunch bound_tcb_at'_Q[wp]: setThreadState "\s. Q (bound_tcb_at' P t s)" + (wp: threadSet_pred_tcb_no_state crunch_wps simp: unless_def) + +lemmas emptySlot_pred_tcb_at'_Q[wp] = lift_neg_pred_tcb_at'[OF emptySlot_typ_at' emptySlot_pred_tcb_at'] + +lemma emptySlot_tcb_at'[wp]: + "\\s. Q (tcb_at' t s)\ emptySlot a b \\_ s. Q (tcb_at' t s)\" + by (simp add: tcb_at_typ_at', wp) + +lemmas cnode_caps_gsCNodes_lift + = hoare_lift_Pf2[where P="\gs s. cnode_caps_gsCNodes (f s) gs" and f=gsCNodes for f] + hoare_lift_Pf2[where P="\gs s. Q s \ cnode_caps_gsCNodes (f s) gs" and f=gsCNodes for f Q] + +lemma resolveAddressBitsFn_eq_name_slot: + "monadic_rewrite F E (\s. (isCNodeCap cap \ cte_wp_at' (\cte. cteCap cte = cap) (slot s) s) + \ valid_objs' s \ cnode_caps_gsCNodes' s) + (resolveAddressBits cap capptr bits) + (gets (resolveAddressBitsFn cap capptr bits o only_cnode_caps o ctes_of))" + apply (rule monadic_rewrite_imp, rule resolveAddressBitsFn_eq) + apply auto + done + +crunch bound_tcb_at'_Q[wp]: asUser "\s. Q (bound_tcb_at' P t s)" + (simp: crunch_simps wp: threadSet_pred_tcb_no_state crunch_wps) + + +lemma asUser_tcb_at'_Q[wp]: + "\\s. Q (tcb_at' t s)\ asUser a b \\_ s. Q (tcb_at' t s)\" + by (simp add: tcb_at_typ_at', wp) + +lemma active_ntfn_check_wp: + "\\s. Q (\ntfnptr. bound_tcb_at' ((=) (Some ntfnptr)) thread s + \ \ obj_at' (Not o isActive) ntfnptr s) s \ do bound_ntfn \ getBoundNotification thread; + case bound_ntfn of None \ return False + | Some ntfnptr \ liftM EndpointDecls_H.isActive $ getNotification ntfnptr + od \Q\" + apply (rule hoare_pre) + apply (wp getNotification_wp gbn_wp' | wpc)+ + apply (auto simp: pred_tcb_at'_def obj_at'_def projectKOs) + done + +lemma tcbSchedEnqueue_tcbIPCBuffer: + "\obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\ + tcbSchedEnqueue t' + \\_. obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\" + apply (simp add: tcbSchedEnqueue_def unless_when) + apply (wp threadSet_obj_at' hoare_drop_imps threadGet_wp + |simp split: if_split)+ + done + +crunch obj_at'_tcbIPCBuffer[wp]: rescheduleRequired "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" + (wp: crunch_wps tcbSchedEnqueue_tcbIPCBuffer simp: rescheduleRequired_def) + +context +notes if_cong[cong] +begin +crunch obj_at'_tcbIPCBuffer[wp]: setThreadState "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" + (wp: crunch_wps threadSet_obj_at'_really_strongest) + +crunch obj_at'_tcbIPCBuffer[wp]: handleFault "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" + (wp: crunch_wps constOnFailure_wp tcbSchedEnqueue_tcbIPCBuffer threadSet_obj_at'_really_strongest + simp: zipWithM_x_mapM) +end + +crunch obj_at'_tcbIPCBuffer[wp]: emptySlot "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" + (wp: crunch_wps) + +lemma fastpath_callKernel_SysReplyRecv_corres: + "monadic_rewrite True False + (invs' and ct_in_state' ((=) Running) and (\s. ksSchedulerAction s = ResumeCurrentThread) + and cnode_caps_gsCNodes') + (callKernel (SyscallEvent SysReplyRecv)) (fastpaths SysReplyRecv)" + including no_pre + supply if_cong[cong] option.case_cong[cong] + supply word_neq_0_conv[simp del] + supply if_split[split del] + apply (rule monadic_rewrite_introduce_alternative) + apply ( simp add: callKernel_def) + apply (rule monadic_rewrite_imp) + apply (simp add: handleEvent_def handleReply_def + handleRecv_def liftE_bindE_handle liftE_handle + bind_assoc getMessageInfo_def liftE_bind) + apply (simp add: catch_liftE_bindE unlessE_throw_catch_If + unifyFailure_catch_If catch_liftE + getMessageInfo_def alternative_bind + fastpaths_def getThreadCallerSlot_def + locateSlot_conv capability_case_Null_ReplyCap + getThreadCSpaceRoot_def + cong: if_cong) + apply (rule monadic_rewrite_rdonly_bind_l, wp) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac thread msgInfo) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac cptr) + apply (rule monadic_rewrite_symb_exec_r[OF threadGet_inv no_fail_threadGet]) + apply (rename_tac tcbFault) + apply (rule monadic_rewrite_alternative_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (simp add: lookupCap_def liftME_def lookupCapAndSlot_def + lookupSlotForThread_def bindE_assoc + split_def getThreadCSpaceRoot_def + locateSlot_conv liftE_bindE bindE_bind_linearise + capFaultOnFailure_def rethrowFailure_injection + injection_handler_catch bind_bindE_assoc + getThreadCallerSlot_def bind_assoc + getSlotCap_def + case_bool_If o_def + isRight_def[where x="Inr v" for v] + isRight_def[where x="Inl v" for v] + cong: if_cong) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac "cTableCTE") + + apply (rule monadic_rewrite_transverse, + rule monadic_rewrite_bind_head, + rule resolveAddressBitsFn_eq) + apply (rule monadic_rewrite_symb_exec_r, (wp | simp)+) + apply (rename_tac "rab_ret") + + apply (rule_tac P="isRight rab_ret" in monadic_rewrite_cases[rotated]) + apply (case_tac rab_ret, simp_all add: isRight_def)[1] + apply (rule monadic_rewrite_alternative_l) + apply clarsimp + apply (simp add: isRight_case_sum liftE_bind + isRight_def[where x="Inr v" for v]) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac ep_cap) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_symb_exec_r[OF _ _ _ active_ntfn_check_wp, unfolded bind_assoc fun_app_def]) + apply (rule hoare_pre, (wp | wpc | simp)+)[1] + apply (unfold getBoundNotification_def)[1] + apply (wp threadGet_wp) + apply (rename_tac ep) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac ep) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_rdonly_bind_l, wp) + apply (rule monadic_rewrite_bind_tail) + apply (rename_tac replyCTE) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (simp add: bind_assoc) + apply (rule monadic_rewrite_rdonly_bind_l, wp assert_inv) + apply (rule monadic_rewrite_assert) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac callerFault) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (simp add: getThreadVSpaceRoot_def locateSlot_conv) + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac vTableCTE) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + + apply (rule monadic_rewrite_symb_exec_r[OF curDomain_inv], + simp only: curDomain_def, rule non_fail_gets) + apply (rename_tac "curDom") + apply (rule monadic_rewrite_symb_exec_r + [OF threadGet_inv no_fail_threadGet]) + apply (rename_tac callerPrio) + apply (simp add: isHighestPrio_def') + apply (rule monadic_rewrite_symb_exec_r [OF gets_inv non_fail_gets]) + apply (rename_tac highest) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + + apply (rule monadic_rewrite_symb_exec_r, wp+) + apply (rename_tac asidMap) + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_symb_exec_r[OF threadGet_inv no_fail_threadGet]) + apply (rename_tac "callerDom") + apply (rule monadic_rewrite_if_rhs[rotated]) + apply (rule monadic_rewrite_alternative_l) + apply (rule monadic_rewrite_trans, + rule monadic_rewrite_pick_alternative_1) + apply (rule_tac P="\v. obj_at' (%tcb. tcbIPCBuffer tcb = v) (capTCBPtr (cteCap replyCTE))" + in monadic_rewrite_exists_v) + apply (rename_tac ipcBuffer) + + apply (simp add: ARM_HYP_H.switchToThread_def bind_assoc) + apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) + + apply (rule monadic_rewrite_bind monadic_rewrite_refl)+ + apply (wp mapM_x_wp' getObject_inv | wpc | simp add: + | wp (once) hoare_drop_imps )+ + + apply (rule monadic_rewrite_bind monadic_rewrite_refl)+ + apply (wp setCTE_obj_at'_tcbIPCBuffer assert_inv mapM_x_wp' getObject_inv | wpc | simp + | wp (once) hoare_drop_imps )+ + + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind_head) + apply (rule monadic_rewrite_trans) + apply (rule doReplyTransfer_simple) + apply simp + apply (((rule monadic_rewrite_weaken2, + (rule_tac msgInfo=msgInfo in doIPCTransfer_simple_rewrite + | rule_tac destPrio=callerPrio + and curDom=curDom and destDom=callerDom + and thread=thread in possibleSwitchTo_rewrite)) + | rule cteDeleteOne_replycap_rewrite + | rule monadic_rewrite_bind monadic_rewrite_refl + | wp assert_inv mapM_x_wp' + setThreadState_obj_at_unchanged + asUser_obj_at_unchanged + hoare_strengthen_post[OF _ obj_at_conj'[simplified atomize_conjL], rotated] + lookupBitmapPriority_lift + setThreadState_runnable_bitmap_inv + | simp add: setMessageInfo_def setThreadState_runnable_simp + | wp (once) hoare_vcg_disj_lift)+)[1] + apply (simp add: setMessageInfo_def) + apply (rule monadic_rewrite_bind_tail) + apply (rename_tac unblocked) + apply (rule_tac rv=thread in monadic_rewrite_symb_exec_l_known, + (wp empty_fail_getCurThread)+) + apply (rule_tac rv=cptr in monadic_rewrite_symb_exec_l_known, + (wp empty_fail_asUser empty_fail_getRegister)+) + apply (rule monadic_rewrite_bind) + apply (rule monadic_rewrite_catch[OF _ monadic_rewrite_refl True_E_E]) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rename_tac cTableCTE2, + rule_tac P="cteCap cTableCTE2 = cteCap cTableCTE" + in monadic_rewrite_gen_asm) + apply simp + apply (rule monadic_rewrite_trans, + rule monadic_rewrite_bindE[OF _ monadic_rewrite_refl]) + apply (rule_tac slot="\s. ksCurThread s + 2 ^ cte_level_bits * tcbCTableSlot" + in resolveAddressBitsFn_eq_name_slot) + apply wp + apply (rule monadic_rewrite_trans) + apply (rule_tac rv=rab_ret + in monadic_rewrite_gets_known[where m="NonDetMonad.lift f" + for f, folded bindE_def]) + apply (simp add: NonDetMonad.lift_def isRight_case_sum) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rename_tac ep_cap2) + apply (rule_tac P="cteCap ep_cap2 = cteCap ep_cap" in monadic_rewrite_gen_asm) + apply (simp add: cap_case_EndpointCap_NotificationCap) + apply (rule monadic_rewrite_liftE) + apply (rule monadic_rewrite_trans) + apply (rule monadic_rewrite_bind) + apply (rule deleteCallerCap_nullcap_rewrite) + apply (rule_tac ep=ep in receiveIPC_simple_rewrite) + apply (wp, simp) + apply (rule monadic_rewrite_bind_head) + + apply (rule monadic_rewrite_weaken[where E=True and F=True], simp) + apply (rule setThreadState_rewrite_simple) + apply clarsimp + apply (wp getCTE_known_cap)+ + apply (rule monadic_rewrite_bind) + apply (rule_tac t="capTCBPtr (cteCap replyCTE)" + and t'=thread + in schedule_known_rewrite) + apply (rule monadic_rewrite_weaken[where E=True and F=True], simp) + apply (rule monadic_rewrite_bind) + apply (rule activateThread_simple_rewrite) + apply (rule monadic_rewrite_refl) + apply wp + apply wp + apply (simp add: ct_in_state'_def, simp add: ct_in_state'_def[symmetric]) + apply ((wp setCurThread_ct_in_state[folded st_tcb_at'_def] + Arch_switchToThread_pred_tcb')+)[2] + apply (simp add: catch_liftE) + apply (wp setEndpoint_obj_at_tcb' threadSet_pred_tcb_at_state[unfolded if_bool_eq_conj]) + + apply (wp setEndpoint_obj_at_tcb' + threadSet_pred_tcb_at_state[unfolded if_bool_eq_conj] + fastpathBestSwitchCandidate_lift[where f="setEndpoint a b" for a b] + fastpathBestSwitchCandidate_lift[where f="threadSet f t" for f t] + | simp + | rule hoare_lift_Pf2[where f=ksCurThread, OF _ setEndpoint_ct'] + hoare_lift_Pf2[where f=ksCurThread, OF _ threadSet_ct])+ + + apply (simp cong: rev_conj_cong) + apply (strengthen imp_consequent[where Q="tcb_at' t s" for t s]) + apply (unfold setSchedulerAction_def)[3] + apply ((wp setThreadState_oa_queued user_getreg_rv setThreadState_no_sch_change + setThreadState_obj_at_unchanged + sts_st_tcb_at'_cases sts_bound_tcb_at' + emptySlot_obj_at'_not_queued + emptySlot_cte_wp_at_cteCap + emptySlot_cnode_caps + user_getreg_inv asUser_typ_ats + asUser_obj_at_not_queued asUser_obj_at' mapM_x_wp' + static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift + static_imp_wp cnode_caps_gsCNodes_lift + hoare_vcg_ex_lift + | simp del: comp_apply + | clarsimp simp: obj_at'_weakenE[OF _ TrueI])+) + + apply (rule hoare_lift_Pf2[where f=ksCurThread, OF _ setThreadState_ct']) + apply (wp setThreadState_oa_queued + fastpathBestSwitchCandidate_lift[where f="setThreadState f t" for f t]) + apply (simp add: setThreadState_runnable_simp) + apply (wp threadSet_tcbState_st_tcb_at') + apply (clarsimp simp del: comp_apply) + apply (wp emptySlot_obj_at_ep)+ + + apply ((wp setThreadState_oa_queued user_getreg_rv + setThreadState_no_sch_change + setThreadState_obj_at_unchanged + sts_st_tcb_at'_cases sts_bound_tcb_at' + emptySlot_obj_at'_not_queued + emptySlot_cte_wp_at_cteCap + emptySlot_cnode_caps + user_getreg_inv asUser_typ_ats + asUser_obj_at_not_queued asUser_obj_at' mapM_x_wp' + static_imp_wp hoare_vcg_all_lift hoare_vcg_imp_lift + static_imp_wp cnode_caps_gsCNodes_lift + hoare_vcg_ex_lift + | simp del: comp_apply + | clarsimp simp: obj_at'_weakenE[OF _ TrueI] + | solves \ + rule hoare_lift_Pf2[where f=ksCurThread, OF _ emptySlot_ct] + hoare_lift_Pf2[where f=ksCurThread, OF _ asUser_ct], + wp fastpathBestSwitchCandidate_lift[where f="emptySlot a b" for a b] + fastpathBestSwitchCandidate_lift[where f="asUser a b" for a b] + user_getreg_inv asUser_typ_ats\)+) + + apply (clarsimp | wp getCTE_wp' gts_imp')+ + + apply (simp add: ARM_HYP_H.switchToThread_def getTCB_threadGet bind_assoc) + apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) + + apply (rule monadic_rewrite_bind monadic_rewrite_refl)+ + apply (wp mapM_x_wp' handleFault_obj_at'_tcbIPCBuffer getObject_inv | wpc | simp + | wp (once) hoare_drop_imps )+ + apply (rule monadic_rewrite_bind monadic_rewrite_refl)+ + apply (wp setCTE_obj_at'_tcbIPCBuffer assert_inv mapM_x_wp' getObject_inv | wpc | simp + | wp (once) hoare_drop_imps )+ + + apply (simp add: bind_assoc catch_liftE + receiveIPC_def Let_def liftM_def + setThreadState_runnable_simp) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getThreadState)+) + apply (rule monadic_rewrite_assert) + + apply (rule_tac P="inj (case_bool thread (capTCBPtr (cteCap replyCTE)))" + in monadic_rewrite_gen_asm) + apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse]) + apply (rule monadic_rewrite_weaken[where F=False and E=True], simp) + apply (rule isolate_thread_actions_rewrite_bind + fastpath_isolate_rewrites fastpath_isolatables + bool.simps setRegister_simple + zipWithM_setRegister_simple + thread_actions_isolatable_bind + thread_actions_isolatableD[OF setCTE_isolatable] + setCTE_isolatable + threadGet_vcpu_isolatable[THEN thread_actions_isolatableD, simplified o_def] + threadGet_vcpu_isolatable[simplified o_def] + vcpuSwitch_isolatable[THEN thread_actions_isolatableD] vcpuSwitch_isolatable + setVMRoot_isolatable[THEN thread_actions_isolatableD] setVMRoot_isolatable + doMachineOp_isolatable[THEN thread_actions_isolatableD] doMachineOp_isolatable + kernelExitAssertions_isolatable[THEN thread_actions_isolatableD] + kernelExitAssertions_isolatable + | assumption + | wp assert_inv)+ + apply (simp only: ) + apply (rule_tac P="(\s. ksSchedulerAction s = ResumeCurrentThread) + and tcb_at' thread + and (cte_wp_at' (\cte. isReplyCap (cteCap cte)) + (thread + 2 ^ cte_level_bits * tcbCallerSlot) + and (\s. \x. tcb_at' (case_bool thread (capTCBPtr (cteCap replyCTE)) x) s) + and valid_mdb')" + and F=True and E=False in monadic_rewrite_weaken) + apply (rule monadic_rewrite_isolate_final2) + apply simp + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rename_tac callerCTE) + apply (rule monadic_rewrite_assert) + apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_getCTE)+) + apply (rule monadic_rewrite_assert) + apply (simp add: emptySlot_setEndpoint_pivot) + apply (rule monadic_rewrite_bind) + apply (rule monadic_rewrite_refl2) + apply (clarsimp simp: isSendEP_def split: Structures_H.endpoint.split) + apply (rule_tac Q="\rv. (\_. rv = callerCTE) and Q'" for Q' + in monadic_rewrite_symb_exec_r, wp+) + apply (rule monadic_rewrite_gen_asm, simp) + apply (rule monadic_rewrite_trans, rule monadic_rewrite_bind_head, + rule_tac cte=callerCTE in emptySlot_replymaster_rewrite) + apply (simp add: bind_assoc o_def) + apply (rule monadic_rewrite_refl) + apply (simp add: cte_wp_at_ctes_of pred_conj_def) + apply (clarsimp | wp getCTE_ctes_wp)+ + apply (clarsimp simp: zip_map2 zip_same_conv_map foldl_map + foldl_fun_upd + foldr_copy_register_tsrs + isRight_case_sum + cong: if_cong) + apply (clarsimp simp: fun_eq_iff if_flip + cong: if_cong) + apply (drule obj_at_ko_at', clarsimp) + apply (frule get_tcb_state_regs_ko_at') + apply (clarsimp simp: zip_map2 zip_same_conv_map foldl_map + foldl_fun_upd + foldr_copy_register_tsrs + isRight_case_sum + cong: if_cong) + apply (simp add: upto_enum_def fromEnum_def + enum_register toEnum_def + msgRegisters_unfold + cong: if_cong) + apply (clarsimp split: if_split) + apply (rule ext) + apply (simp add: badgeRegister_def msgInfoRegister_def + ARM_HYP.msgInfoRegister_def + ARM_HYP.badgeRegister_def + cong: if_cong + split: if_split) + apply simp + apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps + map_to_ctes_partial_overwrite) + apply (simp add: valid_mdb'_def valid_mdb_ctes_def) + apply simp + apply (simp cong: if_cong bool.case_cong + | rule getCTE_wp' gts_wp' threadGet_wp + getEndpoint_wp gets_wp + user_getreg_wp + gets_the_wp gct_wp getNotification_wp + return_wp liftM_wp gbn_wp' + | (simp only: curDomain_def, wp)[1])+ + + apply clarsimp + apply (subgoal_tac "ksCurThread s \ ksIdleThread s") + prefer 2 + apply (fastforce simp: ct_in_state'_def dest: ct_running_not_idle' elim: pred_tcb'_weakenE) + + apply (clarsimp simp: ct_in_state'_def pred_tcb_at') + apply (subst tcb_at_cte_at_offset, + erule obj_at'_weakenE[OF _ TrueI], + simp add: tcb_cte_cases_def cte_level_bits_def tcbSlots) + apply (clarsimp simp: valid_objs_ntfn_at_tcbBoundNotification + invs_valid_objs' if_apply_def2) + apply (rule conjI[rotated]) + apply (fastforce elim: cte_wp_at_weakenE') + apply (clarsimp simp: isRight_def) + apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp+) + apply (frule resolveAddressBitsFn_real_cte_at', + (clarsimp | erule cte_wp_at_weakenE')+) + apply (frule real_cte_at', clarsimp) + apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp, + clarsimp simp: isCap_simps, simp add: valid_cap_simps') + apply (clarsimp simp: maskCapRights_def isCap_simps) + apply (frule_tac p="p' + 2 ^ cte_level_bits * tcbCallerSlot" for p' + in cte_wp_at_valid_objs_valid_cap', clarsimp+) + apply (clarsimp simp: valid_cap_simps') + apply (subst tcb_at_cte_at_offset, + assumption, simp add: tcb_cte_cases_def cte_level_bits_def tcbSlots) + apply (clarsimp simp: inj_case_bool cte_wp_at_ctes_of + length_msgRegisters + order_less_imp_le + tcb_at_invs' invs_mdb' + split: bool.split) + apply (subst imp_disjL[symmetric], intro allI impI) + apply (clarsimp simp: inj_case_bool cte_wp_at_ctes_of + length_msgRegisters size_msgRegisters_def order_less_imp_le + tcb_at_invs' invs_mdb' + split: bool.split) + + apply (subgoal_tac "fastpathBestSwitchCandidate v0a s") + prefer 2 + apply normalise_obj_at' + apply (rule_tac ttcb=tcba and ctcb=tcb in fastpathBestSwitchCandidateI) + apply (erule disjE, blast, blast) + apply simp+ + + apply (clarsimp simp: obj_at_tcbs_of tcbSlots + cte_level_bits_def) + apply (frule(1) st_tcb_at_is_Reply_imp_not_tcbQueued) + apply (auto simp: obj_at_tcbs_of tcbSlots + cte_level_bits_def) + done + +end + +lemma cnode_caps_gsCNodes_from_sr: + "\ valid_objs s; (s, s') \ state_relation \ \ cnode_caps_gsCNodes' s'" + apply (clarsimp simp: cnode_caps_gsCNodes_def only_cnode_caps_def + o_def ran_map_option) + apply (safe, simp_all) + apply (clarsimp elim!: ranE) + apply (frule(1) pspace_relation_cte_wp_atI[rotated]) + apply clarsimp + apply (clarsimp simp: is_cap_simps) + apply (frule(1) cte_wp_at_valid_objs_valid_cap) + apply (clarsimp simp: valid_cap_simps cap_table_at_gsCNodes_eq) + done + +end diff --git a/proof/crefine/ARM_HYP/Finalise_C.thy b/proof/crefine/ARM_HYP/Finalise_C.thy index 8750fda1a..cf8bcac7b 100644 --- a/proof/crefine/ARM_HYP/Finalise_C.thy +++ b/proof/crefine/ARM_HYP/Finalise_C.thy @@ -13,11 +13,6 @@ begin declare if_split [split del] -lemma empty_fail_getEndpoint: - "empty_fail (getEndpoint ep)" - unfolding getEndpoint_def - by (auto intro: empty_fail_getObject) - definition "option_map2 f m = option_map f \ m" diff --git a/proof/crefine/ARM_HYP/IpcCancel_C.thy b/proof/crefine/ARM_HYP/IpcCancel_C.thy index 5bcd3a632..5623d522e 100644 --- a/proof/crefine/ARM_HYP/IpcCancel_C.thy +++ b/proof/crefine/ARM_HYP/IpcCancel_C.thy @@ -2685,13 +2685,6 @@ lemma cancelSignal_ccorres [corres]: | clarsimp simp: eq_commute | drule_tac x=thread in bspec)+ -lemma ko_at_valid_ep': - "\ko_at' ep p s; valid_objs' s\ \ valid_ep' ep s" - apply (erule obj_atE') - apply (erule (1) valid_objsE') - apply (simp add: projectKOs valid_obj'_def) - done - lemma cmap_relation_ep: "(s, s') \ rf_sr \ cmap_relation (map_to_eps (ksPSpace s)) (cslift s') Ptr (cendpoint_relation (cslift s'))" diff --git a/proof/crefine/ARM_HYP/Ipc_C.thy b/proof/crefine/ARM_HYP/Ipc_C.thy index 39e001d30..40bcb0421 100644 --- a/proof/crefine/ARM_HYP/Ipc_C.thy +++ b/proof/crefine/ARM_HYP/Ipc_C.thy @@ -1535,13 +1535,6 @@ lemma ccorres_add_getRegister: apply fastforce done -lemma user_getreg_rv: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb r)) t\ asUser t (getRegister r) \\rv s. P rv\" - apply (simp add: asUser_def split_def) - apply (wp threadGet_wp) - apply (clarsimp simp: obj_at'_def projectKOs getRegister_def in_monad atcbContextGet_def) - done - lemma exceptionMessage_ccorres: "n < unat n_exceptionMessage \ register_from_H (ARM_HYP_H.exceptionMessage ! n) diff --git a/proof/crefine/ARM_HYP/IsolatedThreadAction.thy b/proof/crefine/ARM_HYP/IsolatedThreadAction.thy index 3819a35b2..81ce99387 100644 --- a/proof/crefine/ARM_HYP/IsolatedThreadAction.thy +++ b/proof/crefine/ARM_HYP/IsolatedThreadAction.thy @@ -5,7 +5,7 @@ *) theory IsolatedThreadAction -imports "CLib.MonadicRewrite_C" Finalise_C CSpace_All SyscallArgs_C +imports ArchMove_C begin datatype tcb_state_regs = TCBStateRegs "thread_state" "MachineTypes.register \ machine_word" @@ -117,10 +117,26 @@ lemmas setEndpoint_obj_at_tcb' = setEndpoint_obj_at'_tcb lemmas setNotification_tcb = set_ntfn_tcb_obj_at' -context kernel_m begin - context begin interpretation Arch . (*FIXME: arch_split*) +lemma setObject_modify: + fixes v :: "'a :: pspace_storable" shows + "\ obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; + (1 :: word32) < 2 ^ objBits v \ + \ setObject p v s + = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" + apply (clarsimp simp: setObject_def split_def exec_gets + obj_at'_def projectKOs lookupAround2_known1 + assert_opt_def updateObject_default_def + bind_assoc) + apply (simp add: projectKO_def alignCheck_assert) + apply (simp add: project_inject objBits_def) + apply (clarsimp simp only: objBitsT_koTypeOf[symmetric] koTypeOf_injectKO) + apply (frule(2) in_magnitude_check[where s'=s]) + apply (simp add: magnitudeCheck_assert in_monad) + apply (simp add: simpler_modify_def) + done + lemma getObject_return: fixes v :: "'a :: pspace_storable" shows "\ \a b c d. (loadObject a b c d :: 'a kernel) = loadObject_default a b c d; @@ -214,6 +230,8 @@ lemma isolate_thread_actions_asUser: apply (case_tac ko, simp) done +context begin interpretation Arch . (*FIXME: arch_split*) + lemma getRegister_simple: "getRegister r = (\con. ({(con r, con)}, False))" by (simp add: getRegister_def simpler_gets_def) @@ -253,6 +271,7 @@ lemma map_to_ctes_partial_overwrite: "\x. tcb_at' (idx x) s \ map_to_ctes (partial_overwrite idx tsrs (ksPSpace s)) = ctes_of s" + supply if_split[split del] apply (rule ext) apply (frule dom_partial_overwrite[where tsrs=tsrs]) apply (simp add: map_to_ctes_def partial_overwrite_def @@ -571,6 +590,7 @@ lemma page_directory_at_partial_overwrite: lemma findPDForASID_isolatable: "thread_actions_isolatable idx (findPDForASID asid)" + supply if_split[split del] apply (simp add: findPDForASID_def liftE_bindE liftME_def bindE_assoc case_option_If2 assertE_def liftE_def checkPDAt_def stateAssert_def2 @@ -767,6 +787,7 @@ lemma restoreVirtTimer_isolatable: lemma vcpuSave_isolatable: "thread_actions_isolatable idx (vcpuSave v)" + supply if_split[split del] apply (clarsimp simp: vcpuSave_def armvVCPUSave_def thread_actions_isolatable_fail when_def split: option.splits) apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] @@ -834,6 +855,7 @@ lemma liftM_getObject_return_tcb: lemma threadGet_vcpu_isolatable: "thread_actions_isolatable idx (threadGet (atcbVCPUPtr o tcbArch) t)" + supply if_split[split del] apply (clarsimp simp: threadGet_def thread_actions_isolatable_def) apply (clarsimp simp: isolate_thread_actions_def) apply (clarsimp simp: monadic_rewrite_def) @@ -875,6 +897,7 @@ lemma getTCB_threadGet: lemma setVMRoot_isolatable: "thread_actions_isolatable idx (setVMRoot t)" + supply if_split[split del] apply (simp add: setVMRoot_def getThreadVSpaceRoot_def locateSlot_conv getSlotCap_def cap_case_isPageDirectoryCap if_bool_simps whenE_def liftE_def checkPDNotInASIDMap_def stateAssert_def2 @@ -930,23 +953,16 @@ lemma lookupIPC_inv: "\P\ lookupIPCBuffer f t \\ lemmas empty_fail_user_getreg = empty_fail_asUser[OF empty_fail_getRegister] -lemma user_getreg_rv: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb r)) t\ asUser t (getRegister r) \\rv s. P rv\" - apply (simp add: asUser_def split_def) - apply (wp threadGet_wp) - apply (clarsimp simp: obj_at'_def projectKOs getRegister_def in_monad atcbContextGet_def) - done - lemma copyMRs_simple: - "msglen \ of_nat (length ARM_HYP_H.msgRegisters) \ + "msglen \ of_nat (length msgRegisters) \ copyMRs sender sbuf receiver rbuf msglen - = forM_x (take (unat msglen) ARM_HYP_H.msgRegisters) + = forM_x (take (unat msglen) msgRegisters) (\r. do v \ asUser sender (getRegister r); asUser receiver (setRegister r v) od) >>= (\rv. return msglen)" apply (clarsimp simp: copyMRs_def mapM_discarded) apply (rule bind_cong[OF refl]) - apply (simp add: length_msgRegisters n_msgRegisters_def min_def + apply (simp add: length_msgRegisters min_def word_le_nat_alt split: option.split) apply (simp add: upto_enum_def mapM_Nil) @@ -956,16 +972,16 @@ lemma doIPCTransfer_simple_rewrite: "monadic_rewrite True True ((\_. msgExtraCaps (messageInfoFromWord msgInfo) = 0 \ msgLength (messageInfoFromWord msgInfo) - \ of_nat (length ARM_HYP_H.msgRegisters)) + \ of_nat (length msgRegisters)) and obj_at' (\tcb. tcbFault tcb = None \ (atcbContextGet o tcbArch) tcb msgInfoRegister = msgInfo) sender) (doIPCTransfer sender ep badge grant rcvr) (do rv \ mapM_x (\r. do v \ asUser sender (getRegister r); asUser rcvr (setRegister r v) od) - (take (unat (msgLength (messageInfoFromWord msgInfo))) ARM_HYP_H.msgRegisters); + (take (unat (msgLength (messageInfoFromWord msgInfo))) msgRegisters); y \ setMessageInfo rcvr ((messageInfoFromWord msgInfo) \msgCapsUnwrapped := 0\); - asUser rcvr (setRegister ARM_HYP_H.badgeRegister badge) + asUser rcvr (setRegister badgeRegister badge) od)" supply if_cong[cong] apply (rule monadic_rewrite_gen_asm) @@ -1153,7 +1169,7 @@ lemma oblivious_vcpuSwitch_schact: lemma oblivious_switchToThread_schact: "oblivious (ksSchedulerAction_update f) (ThreadDecls_H.switchToThread t)" - apply (simp add: Thread_H.switchToThread_def ARM_HYP_H.switchToThread_def bind_assoc + apply (simp add: Thread_H.switchToThread_def switchToThread_def bind_assoc getCurThread_def setCurThread_def threadGet_def liftM_def threadSet_def tcbSchedEnqueue_def unless_when asUser_def getQueue_def setQueue_def storeWordUser_def setRegister_def @@ -1210,8 +1226,6 @@ crunch obj_at_prio[wp]: cteDeleteOne "obj_at' (\tcb. P (tcbPriority tcb) setThreadState_obj_at_unchanged setNotification_tcb setBoundNotification_obj_at_unchanged simp: crunch_simps unless_def) -context kernel_m begin - lemma setThreadState_no_sch_change: "\\s. P (ksSchedulerAction s) \ (runnable' st \ t \ ksCurThread s)\ setThreadState st t @@ -1243,6 +1257,8 @@ lemma bind_assoc: = do x \ m; y \ f x; g y od" by (rule bind_assoc) +context begin interpretation Arch . (*FIXME: arch_split*) + lemma setObject_modify_assert: "\ updateObject v = updateObject_default v \ \ setObject p v = do f \ gets (obj_at' (\v'. v = v' \ True) p); @@ -1267,6 +1283,7 @@ lemma setObject_modify_assert: lemma setEndpoint_isolatable: "thread_actions_isolatable idx (setEndpoint p e)" + supply if_split[split del] apply (simp add: setEndpoint_def setObject_modify_assert assert_def) apply (case_tac "p \ range idx") @@ -1360,6 +1377,7 @@ lemma partial_overwrite_fun_upd2: lemma setCTE_isolatable: "thread_actions_isolatable idx (setCTE p v)" + supply if_split[split del] apply (simp add: setCTE_assert_modify) apply (clarsimp simp: thread_actions_isolatable_def monadic_rewrite_def fun_eq_iff @@ -1422,7 +1440,7 @@ lemma assert_isolatable: lemma cteInsert_isolatable: "thread_actions_isolatable idx (cteInsert cap src dest)" - supply if_cong[cong] + supply if_split[split del] if_cong[cong] apply (simp add: cteInsert_def updateCap_def updateMDB_def Let_def setUntypedCapAsFull_def) apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] @@ -1522,7 +1540,7 @@ lemma threadGet_isolatable: lemma switchToThread_isolatable: "thread_actions_isolatable idx (Arch.switchToThread t)" - apply (simp add: ARM_HYP_H.switchToThread_def getTCB_threadGet + apply (simp add: switchToThread_def getTCB_threadGet storeWordUser_def stateAssert_def2) apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] gets_isolatable setVMRoot_isolatable @@ -1596,7 +1614,7 @@ lemma tcb_at_KOTCB_upd: = tcb_at' p s" apply (clarsimp simp: obj_at'_def projectKOs objBits_simps split: if_split) - apply (simp add: ps_clear_def) + apply (fastforce simp add: ps_clear_def) done definition @@ -1643,6 +1661,7 @@ lemma copy_register_isolate: asUser dest (setRegister r' (rf v)) od) (isolate_thread_actions idx (return ()) (copy_register_tsrs x y r r' rf) id)" + supply if_split[split del] apply (simp add: asUser_def split_def bind_assoc getRegister_def setRegister_def select_f_returns isolate_thread_actions_def @@ -1791,7 +1810,7 @@ lemmas fastpath_isolate_rewrites lemma lookupIPCBuffer_isolatable: "thread_actions_isolatable idx (lookupIPCBuffer w t)" - supply if_cong[cong] + supply if_split[split del] if_cong[cong] apply (simp add: lookupIPCBuffer_def) apply (rule thread_actions_isolatable_bind) apply (clarsimp simp: put_tcb_state_regs_tcb_def threadGet_isolatable @@ -1811,6 +1830,7 @@ lemma setThreadState_rewrite_simple: (\s. (runnable' st \ ksSchedulerAction s \ ResumeCurrentThread \ t \ ksCurThread s) \ tcb_at' t s) (setThreadState st t) (threadSet (tcbState_update (\_. st)) t)" + supply if_split[split del] apply (simp add: setThreadState_def) apply (rule monadic_rewrite_imp) apply (rule monadic_rewrite_trans) diff --git a/proof/crefine/ARM_HYP/PSpace_C.thy b/proof/crefine/ARM_HYP/PSpace_C.thy index 053682ddd..50d4aed6c 100644 --- a/proof/crefine/ARM_HYP/PSpace_C.thy +++ b/proof/crefine/ARM_HYP/PSpace_C.thy @@ -10,13 +10,6 @@ begin context kernel begin -lemma koTypeOf_injectKO: - fixes v :: "'a :: pspace_storable" shows - "koTypeOf (injectKO v) = koType TYPE('a)" - apply (cut_tac v1=v in iffD2 [OF project_inject, OF refl]) - apply (simp add: project_koType[symmetric]) - done - lemma setObject_obj_at_pre: "\ updateObject ko = updateObject_default ko; (1 :: word32) < 2 ^ objBits ko \ diff --git a/proof/crefine/ARM_HYP/Refine_C.thy b/proof/crefine/ARM_HYP/Refine_C.thy index 355c0633a..da1ed8688 100644 --- a/proof/crefine/ARM_HYP/Refine_C.thy +++ b/proof/crefine/ARM_HYP/Refine_C.thy @@ -7,7 +7,7 @@ chapter "Toplevel Refinement Statement" theory Refine_C -imports Init_C Fastpath_C CToCRefine +imports Init_C Fastpath_Equiv Fastpath_C CToCRefine begin context begin interpretation Arch . (*FIXME: arch_split*) @@ -18,6 +18,14 @@ end context kernel_m begin +text \Assemble fastpaths\ + +lemmas fastpath_call_ccorres_callKernel + = monadic_rewrite_ccorres_assemble[OF fastpath_call_ccorres fastpath_callKernel_SysCall_corres] + +lemmas fastpath_reply_recv_ccorres_callKernel + = monadic_rewrite_ccorres_assemble[OF fastpath_reply_recv_ccorres fastpath_callKernel_SysReplyRecv_corres] + declare liftE_handle [simp] lemma schedule_sch_act_wf: diff --git a/proof/crefine/ARM_HYP/Retype_C.thy b/proof/crefine/ARM_HYP/Retype_C.thy index 9aee30cdd..3a5d32dcc 100644 --- a/proof/crefine/ARM_HYP/Retype_C.thy +++ b/proof/crefine/ARM_HYP/Retype_C.thy @@ -7836,11 +7836,6 @@ end context begin interpretation Arch . (*FIXME: arch_split*) -crunches insertNewCap, Arch_createNewCaps, threadSet, Arch.createObject - for gsCNodes[wp]: "\s. P (gsCNodes s)" - (wp: crunch_wps setObject_ksPSpace_only - simp: unless_def updateObject_default_def crunch_simps) - lemma createNewCaps_1_gsCNodes_p: "\\s. P (gsCNodes s p) \ p \ ptr\ createNewCaps newType ptr 1 n dev\\rv s. P (gsCNodes s p)\" apply (simp add: createNewCaps_def) diff --git a/proof/crefine/ARM_HYP/SR_lemmas_C.thy b/proof/crefine/ARM_HYP/SR_lemmas_C.thy index 68599697c..c8a780b0b 100644 --- a/proof/crefine/ARM_HYP/SR_lemmas_C.thy +++ b/proof/crefine/ARM_HYP/SR_lemmas_C.thy @@ -310,67 +310,6 @@ lemma cmdbnode_relation_mdb_node_to_H [simp]: unfolding cmdbnode_relation_def mdb_node_to_H_def mdb_node_lift_def cte_lift_def by (fastforce split: option.splits) -(* MOVE --- here down doesn't really belong here, maybe in a haskell specific file?*) -lemma tcb_cte_cases_in_range1: - assumes tc:"tcb_cte_cases (y - x) = Some v" - and al: "is_aligned x tcbBlockSizeBits" - shows "x \ y" -proof - - note objBits_defs[simp] - - from tc obtain q where yq: "y = x + q" and qv: "q < 2 ^ tcbBlockSizeBits" - unfolding tcb_cte_cases_def - by (simp add: diff_eq_eq split: if_split_asm) - - have "x \ x + 2 ^ tcbBlockSizeBits - 1" using al - by (rule is_aligned_no_overflow) - - hence "x \ x + q" using qv - apply simp - apply unat_arith - apply simp - done - - thus ?thesis using yq by simp -qed - -lemma tcb_cte_cases_in_range2: - assumes tc: "tcb_cte_cases (y - x) = Some v" - and al: "is_aligned x tcbBlockSizeBits" - shows "y \ x + 2 ^ tcbBlockSizeBits - 1" -proof - - note objBits_defs[simp] - - from tc obtain q where yq: "y = x + q" and qv: "q \ 2 ^ tcbBlockSizeBits - 1" - unfolding tcb_cte_cases_def - by (simp add: diff_eq_eq split: if_split_asm) - - have "x + q \ x + (2 ^ tcbBlockSizeBits - 1)" using qv - apply (rule word_plus_mono_right) - apply (rule is_aligned_no_overflow' [OF al]) - done - - thus ?thesis using yq by (simp add: field_simps) -qed - -lemmas tcbSlots = - tcbCTableSlot_def tcbVTableSlot_def - tcbReplySlot_def tcbCallerSlot_def tcbIPCBufferSlot_def - -lemma updateObject_cte_tcb: - assumes tc: "tcb_cte_cases (ptr - ptr') = Some (accF, updF)" - shows "updateObject ctea (KOTCB tcb) ptr ptr' next = - (do alignCheck ptr' (objBits tcb); - magnitudeCheck ptr' next (objBits tcb); - return (KOTCB (updF (\_. ctea) tcb)) - od)" - using tc unfolding tcb_cte_cases_def - apply - - apply (clarsimp simp add: updateObject_cte Let_def - tcb_cte_cases_def objBits_simps' tcbSlots shiftl_t2n - split: if_split_asm cong: if_cong) - done - definition tcb_no_ctes_proj :: "tcb \ Structures_H.thread_state \ word32 \ word32 \ arch_tcb \ bool \ word8 \ word8 \ word8 \ nat \ fault option \ word32 option" where @@ -705,10 +644,6 @@ proof - qed fact+ qed -lemma ctes_of_cte_at: - "ctes_of s p = Some x \ cte_at' p s" - by (simp add: cte_wp_at_ctes_of) - lemma cor_map_relI: assumes dm: "dom am = dom am'" and rl: "\x y y' z. \ am x = Some y; am' x = Some y'; diff --git a/proof/crefine/ARM_HYP/Tcb_C.thy b/proof/crefine/ARM_HYP/Tcb_C.thy index 6bb6b0102..3f671d7fd 100644 --- a/proof/crefine/ARM_HYP/Tcb_C.thy +++ b/proof/crefine/ARM_HYP/Tcb_C.thy @@ -8,17 +8,6 @@ theory Tcb_C imports Delete_C Ipc_C begin -lemma asUser_obj_at' : - "\ K(t\t') and obj_at' P t' \ asUser t f \ \_. obj_at' (P::Structures_H.tcb \ bool) t' \" - including no_pre - apply (simp add: asUser_def) - apply wp - apply (case_tac "t=t'"; clarsimp) - apply (rule hoare_drop_imps) - apply wp - done - - lemma getObject_sched: "(x::tcb, s') \ fst (getObject t s) \ (x,s'\ksSchedulerAction := ChooseNewThread\) \ fst (getObject t (s\ksSchedulerAction := ChooseNewThread\))" diff --git a/proof/crefine/ARM_HYP/VSpace_C.thy b/proof/crefine/ARM_HYP/VSpace_C.thy index e8fa56d5c..141e5bf1b 100644 --- a/proof/crefine/ARM_HYP/VSpace_C.thy +++ b/proof/crefine/ARM_HYP/VSpace_C.thy @@ -865,18 +865,6 @@ lemma lookupPTSlot_ccorres: split: ARM_HYP_H.pde.split_asm) done -lemma cap_case_isPageDirectoryCap: - "(case cap of capability.ArchObjectCap (arch_capability.PageDirectoryCap pd ( Some asid)) \ fn pd asid - | _ => g) - = (if ( if (isArchObjectCap cap) then if (isPageDirectoryCap (capCap cap)) then capPDMappedASID (capCap cap) \ None else False else False) - then fn (capPDBasePtr (capCap cap)) (the ( capPDMappedASID (capCap cap))) else g)" - apply (cases cap; simp add: isArchObjectCap_def) - apply (rename_tac arch_capability) - apply (case_tac arch_capability, simp_all add: isPageDirectoryCap_def) - apply (rename_tac option) - apply (case_tac option; simp) - done - (* FIXME: MOVE to CSpaceAcc_C *) lemma ccorres_pre_gets_armKSASIDTable_ksArchState: assumes cc: "\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c" diff --git a/proof/crefine/Move_C.thy b/proof/crefine/Move_C.thy index c9a0db7c2..b4c5d6f20 100644 --- a/proof/crefine/Move_C.thy +++ b/proof/crefine/Move_C.thy @@ -8,7 +8,7 @@ (* Arch generic lemmas that should be moved into theory files before CRefine *) theory Move_C -imports CBaseRefine.Include_C +imports Refine.Refine begin lemma dumb_bool_for_all: "(\x. x) = False" @@ -414,15 +414,6 @@ lemma reset_name_seq_bound_helper: apply simp done -schematic_goal sz8_helper: - "((-1) << 8 :: addr) = ?v" - by (simp add: shiftl_t2n) - -lemmas reset_name_seq_bound_helper2 - = reset_name_seq_bound_helper[where sz=8 and v="v :: addr" for v, - simplified sz8_helper word_bits_def[symmetric], - THEN name_seq_bound_helper] - (* FIXME move to lib/Eisbach_Methods *) (* FIXME consider printing error on solve goal apply *) context @@ -470,14 +461,15 @@ lemma word_minus_1_shiftr: apply (simp only: uint_word_ariths uint_div uint_power_lower) apply (subst mod_pos_pos_trivial, fastforce, fastforce)+ apply (subst mod_pos_pos_trivial) - apply (simp add: word_less_def) + apply (simp add: word_less_def word_le_def) apply (subst uint_1[symmetric]) apply (fastforce intro: uint_sub_lt2p) apply (subst int_div_sub_1, fastforce) apply (clarsimp simp: and_mask_dvd low_bits_zero) apply (subst mod_pos_pos_trivial) - apply (metis le_step_down_int mult_zero_left shiftr_div_2n shiftr_div_2n_w uint_0_iff - uint_nonnegative word_not_simps(1)) + apply (simp add: word_le_def) + apply (metis mult_zero_left neq_zero div_positive_int linorder_not_le uint_2p_alt word_div_lt_eq_0 + word_less_def zless2p) apply (metis shiftr_div_2n uint_1 uint_sub_lt2p) apply fastforce done @@ -1351,4 +1343,138 @@ begin declare less_Suc0[iff del] end +lemma koTypeOf_injectKO: + fixes v :: "'a :: pspace_storable" shows + "koTypeOf (injectKO v) = koType TYPE('a)" + apply (cut_tac v1=v in iffD2 [OF project_inject, OF refl]) + apply (simp add: project_koType[symmetric]) + done + +lemma ctes_of_cte_at: + "ctes_of s p = Some x \ cte_at' p s" + by (simp add: cte_wp_at_ctes_of) + +lemmas tcbSlots = + tcbCTableSlot_def tcbVTableSlot_def + tcbReplySlot_def tcbCallerSlot_def tcbIPCBufferSlot_def + +lemma updateObject_cte_tcb: + assumes tc: "tcb_cte_cases (ptr - ptr') = Some (accF, updF)" + shows "updateObject ctea (KOTCB tcb) ptr ptr' next = + (do alignCheck ptr' (objBits tcb); + magnitudeCheck ptr' next (objBits tcb); + return (KOTCB (updF (\_. ctea) tcb)) + od)" + using tc unfolding tcb_cte_cases_def + apply - + apply (clarsimp simp add: updateObject_cte Let_def + tcb_cte_cases_def objBits_simps' tcbSlots shiftl_t2n + split: if_split_asm cong: if_cong) + done + +lemma tcb_cte_cases_in_range1: + assumes tc:"tcb_cte_cases (y - x) = Some v" + and al: "is_aligned x tcbBlockSizeBits" + shows "x \ y" +proof - + note objBits_defs [simp] + + from tc obtain q where yq: "y = x + q" and qv: "q < 2 ^ tcbBlockSizeBits" + unfolding tcb_cte_cases_def + by (simp add: diff_eq_eq split: if_split_asm) + + have "x \ x + 2 ^ tcbBlockSizeBits - 1" using al + by (rule is_aligned_no_overflow) + + hence "x \ x + q" using qv + apply simp + apply unat_arith + apply simp + done + + thus ?thesis using yq by simp +qed + +lemma tcb_cte_cases_in_range2: + assumes tc: "tcb_cte_cases (y - x) = Some v" + and al: "is_aligned x tcbBlockSizeBits" + shows "y \ x + 2 ^ tcbBlockSizeBits - 1" +proof - + note objBits_defs [simp] + + from tc obtain q where yq: "y = x + q" and qv: "q \ 2 ^ tcbBlockSizeBits - 1" + unfolding tcb_cte_cases_def + by (simp add: diff_eq_eq split: if_split_asm) + + have "x + q \ x + (2 ^ tcbBlockSizeBits - 1)" using qv + apply (rule word_plus_mono_right) + apply (rule is_aligned_no_overflow' [OF al]) + done + + thus ?thesis using yq by (simp add: field_simps) +qed + +lemma valid_cap_cte_at': + "\isCNodeCap cap; valid_cap' cap s'\ + \ cte_at' (capCNodePtr cap + 2^cteSizeBits * (addr && mask (capCNodeBits cap))) s'" + apply (clarsimp simp: isCap_simps valid_cap'_def) + apply (rule real_cte_at') + apply (erule spec) + done + +lemma cd_wp[wp]: + "\\s. P (ksCurDomain s) s\ curDomain \P\" + by (unfold curDomain_def, wp) + +lemma empty_fail_getEndpoint: + "empty_fail (getEndpoint ep)" + unfolding getEndpoint_def + by (auto intro: empty_fail_getObject) + +lemma ko_at_valid_ep': + "\ko_at' ep p s; valid_objs' s\ \ valid_ep' ep s" + apply (erule obj_atE') + apply (erule (1) valid_objsE') + apply (simp add: projectKOs valid_obj'_def) + done + +lemma cap_case_EndpointCap_NotificationCap: + "(case cap of EndpointCap v0 v1 v2 v3 v4 v5 \ f v0 v1 v2 v3 v4 v5 + | 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) (capEPCanGrantReply 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 split del: if_split) + +lemma asUser_obj_at': + "\ K(t\t') and obj_at' P t' \ asUser t f \ \_. obj_at' (P::Structures_H.tcb \ bool) t' \" + including no_pre + apply (simp add: asUser_def) + apply wpsimp + apply (case_tac "t=t'"; clarsimp) + apply (rule hoare_drop_imps) + apply wp + done + +(* FIXME: partial copy from SR_Lemmas since only map_to_ctes is defined. + All of the update_*_map_tos in SR_lemmas can be moved up. *) +lemma update_ep_map_to_ctes: + fixes P :: "endpoint \ bool" + assumes at: "obj_at' P p s" + shows "map_to_ctes (ksPSpace s(p \ KOEndpoint ko)) = map_to_ctes (ksPSpace s)" + using at + by (auto elim!: obj_atE' intro!: map_to_ctes_upd_other map_comp_eqI + simp: projectKOs projectKO_opts_defs split: kernel_object.splits if_split_asm) + +(* FIXME: move to MonadicRewrite *) +lemma monadic_rewrite_gets_l: + "(\x. monadic_rewrite F E (P x) (g x) m) + \ monadic_rewrite F E (\s. P (f s) s) (gets f >>= (\x. g x)) m" + by (auto simp add: monadic_rewrite_def exec_gets) + end diff --git a/proof/crefine/RISCV64/ArchMove_C.thy b/proof/crefine/RISCV64/ArchMove_C.thy index 15de5b107..f400e9ea3 100644 --- a/proof/crefine/RISCV64/ArchMove_C.thy +++ b/proof/crefine/RISCV64/ArchMove_C.thy @@ -358,6 +358,73 @@ lemma getActiveIRQ_neq_Some0x3FF: apply (auto dest: use_valid intro: getActiveIRQ_neq_Some0x3FF') done +(* We don't have access to n_msgRegisters from C here, but the number of msg registers in C should + be equivalent to what we have in the abstract/design specs. We want a number for this definition + that automatically updates if the number of registers changes, and we sanity check it later + in msgRegisters_size_sanity *) +definition size_msgRegisters :: nat where + size_msgRegisters_pre_def: "size_msgRegisters \ size (RISCV64.msgRegisters)" + +schematic_goal size_msgRegisters_def: + "size_msgRegisters = numeral ?x" + unfolding size_msgRegisters_pre_def RISCV64.msgRegisters_def + by (simp add: upto_enum_red fromEnum_def enum_register del: Suc_eq_numeral) + (simp only: Suc_eq_plus1_left, simp del: One_nat_def) + +lemma length_msgRegisters[simplified size_msgRegisters_def]: + "length RISCV64_H.msgRegisters = size_msgRegisters" + by (simp add: size_msgRegisters_pre_def RISCV64_H.msgRegisters_def) + +lemma empty_fail_loadWordUser[intro!, simp]: + "empty_fail (loadWordUser x)" + by (simp add: loadWordUser_def ef_loadWord ef_dmo') + +lemma empty_fail_getMRs[iff]: + "empty_fail (getMRs t buf mi)" + by (auto simp add: getMRs_def split: option.split) + +lemma empty_fail_getReceiveSlots: + "empty_fail (getReceiveSlots r rbuf)" +proof - + note + empty_fail_assertE[iff] + empty_fail_resolveAddressBits[iff] + show ?thesis + apply (clarsimp simp: getReceiveSlots_def loadCapTransfer_def split_def + split: option.split) + apply (rule empty_fail_bind) + apply (simp add: capTransferFromWords_def) + apply (simp add: emptyOnFailure_def unifyFailure_def) + apply (intro empty_fail_catch empty_fail_bindE empty_fail_rethrowFailure, + simp_all add: empty_fail_whenEs) + apply (simp_all add: lookupCap_def split_def lookupCapAndSlot_def + lookupSlotForThread_def liftME_def + getThreadCSpaceRoot_def locateSlot_conv bindE_assoc + lookupSlotForCNodeOp_def lookupErrorOnFailure_def + cong: if_cong) + apply (intro empty_fail_bindE, + simp_all add: getSlotCap_def) + apply (intro empty_fail_If empty_fail_bindE empty_fail_rethrowFailure impI, + simp_all add: empty_fail_whenEs rangeCheck_def) + done +qed + +lemma user_getreg_rv: + "\obj_at' (\tcb. P ((user_regs o atcbContextGet o tcbArch) tcb r)) t\ + asUser t (getRegister r) + \\rv s. P rv\" + apply (simp add: asUser_def split_def) + apply (wp threadGet_wp) + apply (clarsimp simp: obj_at'_def getRegister_def in_monad atcbContextGet_def) + done + +crunches insertNewCap, Arch_createNewCaps, threadSet, Arch.createObject, setThreadState, + updateFreeIndex, preemptionPoint + for gsCNodes[wp]: "\s. P (gsCNodes s)" + (wp: crunch_wps setObject_ksPSpace_only + simp: unless_def updateObject_default_def crunch_simps + ignore_del: preemptionPoint) + end end diff --git a/proof/crefine/RISCV64/CLevityCatch.thy b/proof/crefine/RISCV64/CLevityCatch.thy index 3c503b72d..1de20de45 100644 --- a/proof/crefine/RISCV64/CLevityCatch.thy +++ b/proof/crefine/RISCV64/CLevityCatch.thy @@ -61,14 +61,6 @@ lemma no_overlap_new_cap_addrs_disjoint: apply auto done -lemma empty_fail_loadWordUser[intro!, simp]: - "empty_fail (loadWordUser x)" - by (simp add: loadWordUser_def ef_loadWord) - -lemma empty_fail_getMRs[iff]: - "empty_fail (getMRs t buf mi)" - by (auto simp add: getMRs_def split: option.split) - lemma empty_fail_getExtraCPtrs [intro!, simp]: "empty_fail (getExtraCPtrs sendBuffer info)" apply (simp add: getExtraCPtrs_def) @@ -115,32 +107,6 @@ lemma asUser_get_registers: obj_at'_def) done -lemma empty_fail_getReceiveSlots: - "empty_fail (getReceiveSlots r rbuf)" -proof - - note - empty_fail_assertE[iff] - empty_fail_resolveAddressBits[iff] - show ?thesis - apply (clarsimp simp: getReceiveSlots_def loadCapTransfer_def split_def - split: option.split) - apply (rule empty_fail_bind) - apply (simp add: capTransferFromWords_def) - apply (simp add: emptyOnFailure_def unifyFailure_def) - apply (intro empty_fail_catch empty_fail_bindE empty_fail_rethrowFailure, - simp_all add: empty_fail_whenEs) - apply (simp_all add: lookupCap_def split_def lookupCapAndSlot_def - lookupSlotForThread_def liftME_def - getThreadCSpaceRoot_def locateSlot_conv bindE_assoc - lookupSlotForCNodeOp_def lookupErrorOnFailure_def - cong: if_cong) - apply (intro empty_fail_bindE, - simp_all add: getSlotCap_def) - apply (intro empty_fail_If empty_fail_bindE empty_fail_rethrowFailure impI, - simp_all add: empty_fail_whenEs rangeCheck_def) - done -qed - lemma exec_Basic_Guard_UNIV: "Semantic.exec \ (Basic f;; Guard F UNIV (Basic g)) x y = Semantic.exec \ (Basic (g o f)) x y" @@ -172,4 +138,13 @@ lemma option_to_ptr_not_0: "\ p \ 0 ; option_to_ptr v = Ptr p \ \ v = Some p" by (clarsimp simp: option_to_ptr_def option_to_0_def split: option.splits) +schematic_goal sz8_helper: + "((-1) << 8 :: addr) = ?v" + by (simp add: shiftl_t2n) + +lemmas reset_name_seq_bound_helper2 + = reset_name_seq_bound_helper[where sz=8 and v="v :: addr" for v, + simplified sz8_helper word_bits_def[symmetric], + THEN name_seq_bound_helper] + end diff --git a/proof/crefine/RISCV64/CSpaceAcc_C.thy b/proof/crefine/RISCV64/CSpaceAcc_C.thy index 9f61849a1..1bf605bbd 100644 --- a/proof/crefine/RISCV64/CSpaceAcc_C.thy +++ b/proof/crefine/RISCV64/CSpaceAcc_C.thy @@ -188,10 +188,6 @@ lemma ccorres_pre_getIdleThread: apply (clarsimp simp: rf_sr_ksIdleThread) done - -lemma cd_wp [wp]: "\\s. P (ksCurDomain s) s\ curDomain \P\" - by (unfold curDomain_def, wp) - lemma curDomain_sp: "\P\ curDomain \\rv s. ksCurDomain s = rv \ P s\" apply wp diff --git a/proof/crefine/RISCV64/CSpace_RAB_C.thy b/proof/crefine/RISCV64/CSpace_RAB_C.thy index 6689dcc94..75edfa870 100644 --- a/proof/crefine/RISCV64/CSpace_RAB_C.thy +++ b/proof/crefine/RISCV64/CSpace_RAB_C.thy @@ -92,13 +92,6 @@ lemma ccorres_req: apply (clarsimp elim!: bexI [rotated]) done -lemma valid_cap_cte_at': - "\isCNodeCap cap; valid_cap' cap s'\ \ cte_at' (capCNodePtr cap + 2^cteSizeBits * (addr && mask (capCNodeBits cap))) s'" - apply (clarsimp simp: isCap_simps valid_cap'_def) - apply (rule real_cte_at') - apply (erule spec) - done - declare mask_64_max_word [simp] lemma rightsFromWord_wordFromRights: diff --git a/proof/crefine/RISCV64/Finalise_C.thy b/proof/crefine/RISCV64/Finalise_C.thy index 05e744ba0..8e5e17251 100644 --- a/proof/crefine/RISCV64/Finalise_C.thy +++ b/proof/crefine/RISCV64/Finalise_C.thy @@ -31,11 +31,6 @@ lemma ccorres_dc_comp: declare if_split [split del] -lemma empty_fail_getEndpoint: - "empty_fail (getEndpoint ep)" - unfolding getEndpoint_def - by (auto intro: empty_fail_getObject) - definition "option_map2 f m = option_map f \ m" diff --git a/proof/crefine/RISCV64/Invoke_C.thy b/proof/crefine/RISCV64/Invoke_C.thy index f316f2e0e..5555e2533 100644 --- a/proof/crefine/RISCV64/Invoke_C.thy +++ b/proof/crefine/RISCV64/Invoke_C.thy @@ -1413,12 +1413,6 @@ crunch sch_act_wf[wp]: insertNewCap "\s. sch_act_wf (ksSchedulerAction s crunch ksCurThread[wp]: deleteObjects "\s. P (ksCurThread s)" (wp: crunch_wps simp: unless_def) -(* FIXME RAF move to Retype_C to extend original *) -crunches insertNewCap, Arch_createNewCaps, threadSet, Arch.createObject, doMachineOp - for gsCNodes[wp]: "\s. P (gsCNodes s)" - (wp: crunch_wps setObject_ksPSpace_only - simp: unless_def updateObject_default_def crunch_simps) - lemma deleteObjects_gsCNodes_at_pt: "\(\s. P (gsCNodes s ptr)) and K (ptr \ {ptr_base .. ptr_base + 2 ^ sz - 1} \ is_aligned ptr_base sz)\ diff --git a/proof/crefine/RISCV64/IpcCancel_C.thy b/proof/crefine/RISCV64/IpcCancel_C.thy index 28feccf6a..4e5d904bd 100644 --- a/proof/crefine/RISCV64/IpcCancel_C.thy +++ b/proof/crefine/RISCV64/IpcCancel_C.thy @@ -2642,13 +2642,6 @@ lemma cancelSignal_ccorres [corres]: | clarsimp simp: eq_commute | drule_tac x=thread in bspec)+ -lemma ko_at_valid_ep': - "\ko_at' ep p s; valid_objs' s\ \ valid_ep' ep s" - apply (erule obj_atE') - apply (erule (1) valid_objsE') - apply (simp add: projectKOs valid_obj'_def) - done - (* FIXME: MOVE *) lemma ccorres_pre_getEndpoint [corres_pre]: assumes cc: "\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c" diff --git a/proof/crefine/RISCV64/Ipc_C.thy b/proof/crefine/RISCV64/Ipc_C.thy index 9ec4f73cb..4f6c9da94 100644 --- a/proof/crefine/RISCV64/Ipc_C.thy +++ b/proof/crefine/RISCV64/Ipc_C.thy @@ -1459,13 +1459,6 @@ lemma ccorres_add_getRegister: apply fastforce done -lemma user_getreg_rv: - "\obj_at' (\tcb. P ((user_regs o atcbContextGet o tcbArch) tcb r)) t\ asUser t (getRegister r) \\rv s. P rv\" - apply (simp add: asUser_def split_def) - apply (wp threadGet_wp) - apply (clarsimp simp: obj_at'_def projectKOs getRegister_def in_monad atcbContextGet_def) - done - lemma exceptionMessage_ccorres: "n < unat n_exceptionMessage \ register_from_H (RISCV64_H.exceptionMessage ! n) diff --git a/proof/crefine/RISCV64/IsolatedThreadAction.thy b/proof/crefine/RISCV64/IsolatedThreadAction.thy index ea31a1e90..9f1faeea0 100644 --- a/proof/crefine/RISCV64/IsolatedThreadAction.thy +++ b/proof/crefine/RISCV64/IsolatedThreadAction.thy @@ -6,7 +6,7 @@ *) theory IsolatedThreadAction -imports "CLib.MonadicRewrite_C" Finalise_C CSpace_All SyscallArgs_C +imports ArchMove_C begin context begin interpretation Arch . @@ -128,10 +128,24 @@ lemmas setNotification_tcb = set_ntfn_tcb_obj_at' end -context kernel_m begin - context begin interpretation Arch . (*FIXME: arch_split*) +lemma setObject_modify: + fixes v :: "'a :: pspace_storable" shows + "\ obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; + (1 :: machine_word) < 2 ^ objBits v \ + \ setObject p v s + = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" + apply (clarsimp simp: setObject_def split_def exec_gets obj_at'_def lookupAround2_known1 + assert_opt_def updateObject_default_def bind_assoc) + apply (simp add: projectKO_def alignCheck_assert) + apply (simp add: project_inject objBits_def) + apply (clarsimp simp only: objBitsT_koTypeOf[symmetric] koTypeOf_injectKO) + apply (frule(2) in_magnitude_check[where s'=s]) + apply (simp add: magnitudeCheck_assert in_monad) + apply (simp add: simpler_modify_def) + done + lemma getObject_return: fixes v :: "'a :: pspace_storable" shows "\ \a b c d. (loadObject a b c d :: 'a kernel) = loadObject_default a b c d; @@ -163,6 +177,8 @@ lemma partial_overwrite_fun_upd: apply (clarsimp split: if_split) done +context begin interpretation Arch . (*FIXME: arch_split*) + lemma get_tcb_state_regs_ko_at': "ko_at' ko p s \ get_tcb_state_regs (ksPSpace s p) = TCBStateRegs (tcbState ko) ((user_regs o atcbContextGet o tcbArch) ko)" @@ -266,6 +282,7 @@ lemma map_to_ctes_partial_overwrite: "\x. tcb_at' (idx x) s \ map_to_ctes (partial_overwrite idx tsrs (ksPSpace s)) = ctes_of s" + supply if_split[split del] apply (rule ext) apply (frule dom_partial_overwrite[where tsrs=tsrs]) apply (simp add: map_to_ctes_def partial_overwrite_def @@ -615,6 +632,7 @@ lemma page_table_at_partial_overwrite: lemma findVSpaceForASID_isolatable: "thread_actions_isolatable idx (findVSpaceForASID asid)" + supply if_split[split del] apply (simp add: findVSpaceForASID_def liftE_bindE liftME_def bindE_assoc case_option_If2 assertE_def liftE_def checkPTAt_def stateAssert_def2 @@ -678,6 +696,7 @@ lemma cap_case_isPageTableCap: lemma setVMRoot_isolatable: "thread_actions_isolatable idx (setVMRoot t)" + supply if_split[split del] apply (simp add: setVMRoot_def getThreadVSpaceRoot_def locateSlot_conv getSlotCap_def if_bool_simps cap_case_isPageTableCap @@ -702,7 +721,10 @@ lemma transferCaps_simple: return (mi\msgExtraCaps := 0, msgCapsUnwrapped := 0\) od" apply (cases mi) - apply (clarsimp simp: transferCaps_def getThreadCSpaceRoot_def locateSlot_conv cong: option.case_cong) + apply (clarsimp simp: transferCaps_def getThreadCSpaceRoot_def locateSlot_conv) + apply (rule ext bind_apply_cong[OF refl])+ + apply (simp add: upto_enum_def + split: option.split) done lemma transferCaps_simple_rewrite: @@ -731,23 +753,16 @@ lemma lookupIPC_inv: "\P\ lookupIPCBuffer f t \\ lemmas empty_fail_user_getreg = empty_fail_asUser[OF empty_fail_getRegister] -lemma user_getreg_rv: - "\obj_at' (\tcb. P ((user_regs o atcbContextGet o tcbArch) tcb r)) t\ asUser t (getRegister r) \\rv s. P rv\" - apply (simp add: asUser_def split_def) - apply (wp threadGet_wp) - apply (clarsimp simp: obj_at'_def projectKOs getRegister_def in_monad atcbContextGet_def) - done - lemma copyMRs_simple: - "msglen \ of_nat (length RISCV64_H.msgRegisters) \ + "msglen \ of_nat (length msgRegisters) \ copyMRs sender sbuf receiver rbuf msglen - = forM_x (take (unat msglen) RISCV64_H.msgRegisters) + = forM_x (take (unat msglen) msgRegisters) (\r. do v \ asUser sender (getRegister r); asUser receiver (setRegister r v) od) >>= (\rv. return msglen)" apply (clarsimp simp: copyMRs_def mapM_discarded) apply (rule bind_cong[OF refl]) - apply (simp add: length_msgRegisters n_msgRegisters_def min_def + apply (simp add: length_msgRegisters min_def word_le_nat_alt split: option.split) apply (simp add: upto_enum_def mapM_Nil) @@ -757,16 +772,16 @@ lemma doIPCTransfer_simple_rewrite: "monadic_rewrite True True ((\_. msgExtraCaps (messageInfoFromWord msgInfo) = 0 \ msgLength (messageInfoFromWord msgInfo) - \ of_nat (length RISCV64_H.msgRegisters)) + \ of_nat (length msgRegisters)) and obj_at' (\tcb. tcbFault tcb = None \ (user_regs o atcbContextGet o tcbArch) tcb msgInfoRegister = msgInfo) sender) (doIPCTransfer sender ep badge grant rcvr) (do rv \ mapM_x (\r. do v \ asUser sender (getRegister r); asUser rcvr (setRegister r v) od) - (take (unat (msgLength (messageInfoFromWord msgInfo))) RISCV64_H.msgRegisters); + (take (unat (msgLength (messageInfoFromWord msgInfo))) msgRegisters); y \ setMessageInfo rcvr ((messageInfoFromWord msgInfo) \msgCapsUnwrapped := 0\); - asUser rcvr (setRegister RISCV64_H.badgeRegister badge) + asUser rcvr (setRegister badgeRegister badge) od)" supply if_cong[cong] apply (rule monadic_rewrite_gen_asm) @@ -916,7 +931,7 @@ lemma oblivious_setVMRoot_schact: lemma oblivious_switchToThread_schact: "oblivious (ksSchedulerAction_update f) (ThreadDecls_H.switchToThread t)" - apply (simp add: Thread_H.switchToThread_def RISCV64_H.switchToThread_def bind_assoc + apply (simp add: Thread_H.switchToThread_def switchToThread_def bind_assoc getCurThread_def setCurThread_def threadGet_def liftM_def threadSet_def tcbSchedEnqueue_def unless_when asUser_def getQueue_def setQueue_def storeWordUser_def setRegister_def @@ -972,8 +987,6 @@ crunch obj_at_prio[wp]: cteDeleteOne "obj_at' (\tcb. P (tcbPriority tcb) setThreadState_obj_at_unchanged setNotification_tcb setBoundNotification_obj_at_unchanged simp: crunch_simps unless_def) -context kernel_m begin - lemma setThreadState_no_sch_change: "\\s. P (ksSchedulerAction s) \ (runnable' st \ t \ ksCurThread s)\ setThreadState st t @@ -1005,6 +1018,8 @@ lemma bind_assoc: = do x \ m; y \ f x; g y od" by (rule bind_assoc) +context begin interpretation Arch . (*FIXME: arch_split*) + lemma setObject_modify_assert: "\ updateObject v = updateObject_default v \ \ setObject p v = do f \ gets (obj_at' (\v'. v = v' \ True) p); @@ -1029,6 +1044,7 @@ lemma setObject_modify_assert: lemma setEndpoint_isolatable: "thread_actions_isolatable idx (setEndpoint p e)" + supply if_split[split del] apply (simp add: setEndpoint_def setObject_modify_assert assert_def) apply (case_tac "p \ range idx") @@ -1127,6 +1143,7 @@ lemma atcbContextSetSetGet_eq[simp]: lemma setCTE_isolatable: "thread_actions_isolatable idx (setCTE p v)" + supply if_split[split del] apply (simp add: setCTE_assert_modify) apply (clarsimp simp: thread_actions_isolatable_def monadic_rewrite_def fun_eq_iff @@ -1189,7 +1206,7 @@ lemma assert_isolatable: lemma cteInsert_isolatable: "thread_actions_isolatable idx (cteInsert cap src dest)" - supply if_cong[cong] + supply if_split[split del] if_cong[cong] apply (simp add: cteInsert_def updateCap_def updateMDB_def Let_def setUntypedCapAsFull_def) apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] @@ -1289,7 +1306,7 @@ lemma threadGet_isolatable: lemma switchToThread_isolatable: "thread_actions_isolatable idx (Arch.switchToThread t)" - apply (simp add: RISCV64_H.switchToThread_def + apply (simp add: switchToThread_def storeWordUser_def stateAssert_def2) apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] gets_isolatable setVMRoot_isolatable @@ -1359,7 +1376,7 @@ lemma tcb_at_KOTCB_upd: = tcb_at' p s" apply (clarsimp simp: obj_at'_def projectKOs objBits_simps split: if_split) - apply (simp add: ps_clear_def) + apply (fastforce simp add: ps_clear_def) done definition @@ -1407,6 +1424,7 @@ lemma copy_register_isolate: asUser dest (setRegister r' (rf v)) od) (isolate_thread_actions idx (return ()) (copy_register_tsrs x y r r' rf) id)" + supply if_split[split del] apply (simp add: asUser_def split_def bind_assoc getRegister_def setRegister_def select_f_returns isolate_thread_actions_def @@ -1556,7 +1574,7 @@ lemmas fastpath_isolate_rewrites lemma lookupIPCBuffer_isolatable: "thread_actions_isolatable idx (lookupIPCBuffer w t)" - supply if_cong[cong] + supply if_cong[cong] if_split[split del] apply (simp add: lookupIPCBuffer_def) apply (rule thread_actions_isolatable_bind) apply (clarsimp simp: put_tcb_state_regs_tcb_def threadGet_isolatable @@ -1577,6 +1595,7 @@ lemma setThreadState_rewrite_simple: (\s. (runnable' st \ ksSchedulerAction s \ ResumeCurrentThread \ t \ ksCurThread s) \ tcb_at' t s) (setThreadState st t) (threadSet (tcbState_update (\_. st)) t)" + supply if_split[split del] apply (simp add: setThreadState_def) apply (rule monadic_rewrite_imp) apply (rule monadic_rewrite_trans) diff --git a/proof/crefine/RISCV64/PSpace_C.thy b/proof/crefine/RISCV64/PSpace_C.thy index feb31cd62..cbce98552 100644 --- a/proof/crefine/RISCV64/PSpace_C.thy +++ b/proof/crefine/RISCV64/PSpace_C.thy @@ -11,13 +11,6 @@ begin context kernel begin -lemma koTypeOf_injectKO: - fixes v :: "'a :: pspace_storable" shows - "koTypeOf (injectKO v) = koType TYPE('a)" - apply (cut_tac v1=v in iffD2 [OF project_inject, OF refl]) - apply (simp add: project_koType[symmetric]) - done - lemma setObject_obj_at_pre: "\ updateObject ko = updateObject_default ko; (1 :: machine_word) < 2 ^ objBits ko \ diff --git a/proof/crefine/RISCV64/Retype_C.thy b/proof/crefine/RISCV64/Retype_C.thy index f43feb1ef..3b5059712 100644 --- a/proof/crefine/RISCV64/Retype_C.thy +++ b/proof/crefine/RISCV64/Retype_C.thy @@ -6916,11 +6916,6 @@ end context begin interpretation Arch . (*FIXME: arch_split*) -crunches insertNewCap, Arch_createNewCaps, threadSet, Arch.createObject - for gsCNodes[wp]: "\s. P (gsCNodes s)" - (wp: crunch_wps setObject_ksPSpace_only - simp: unless_def updateObject_default_def crunch_simps) - lemma createNewCaps_1_gsCNodes_p: "\\s. P (gsCNodes s p) \ p \ ptr\ createNewCaps newType ptr 1 n dev\\rv s. P (gsCNodes s p)\" apply (simp add: createNewCaps_def) diff --git a/proof/crefine/RISCV64/SR_lemmas_C.thy b/proof/crefine/RISCV64/SR_lemmas_C.thy index d3bd774fc..b84a60b94 100644 --- a/proof/crefine/RISCV64/SR_lemmas_C.thy +++ b/proof/crefine/RISCV64/SR_lemmas_C.thy @@ -288,67 +288,6 @@ lemma cmdbnode_relation_mdb_node_to_H [simp]: unfolding cmdbnode_relation_def mdb_node_to_H_def mdb_node_lift_def cte_lift_def by (fastforce split: option.splits) -(* MOVE --- here down doesn't really belong here, maybe in a haskell specific file?*) -lemma tcb_cte_cases_in_range1: - assumes tc:"tcb_cte_cases (y - x) = Some v" - and al: "is_aligned x tcbBlockSizeBits" - shows "x \ y" -proof - - note objBits_defs [simp] - - from tc obtain q where yq: "y = x + q" and qv: "q < 2 ^ 9" - unfolding tcb_cte_cases_def - by (simp add: diff_eq_eq split: if_split_asm) - - have "x \ x + 2 ^ tcbBlockSizeBits - 1" using al - by (rule is_aligned_no_overflow) - - hence "x \ x + q" using qv - apply simp - apply unat_arith - apply simp - done - - thus ?thesis using yq by simp -qed - -lemma tcb_cte_cases_in_range2: - assumes tc: "tcb_cte_cases (y - x) = Some v" - and al: "is_aligned x tcbBlockSizeBits" - shows "y \ x + 2 ^ tcbBlockSizeBits - 1" -proof - - note objBits_defs [simp] - - from tc obtain q where yq: "y = x + q" and qv: "q \ 2 ^ tcbBlockSizeBits - 1" - unfolding tcb_cte_cases_def - by (simp add: diff_eq_eq split: if_split_asm) - - have "x + q \ x + (2 ^ tcbBlockSizeBits - 1)" using qv - apply (rule word_plus_mono_right) - apply (rule is_aligned_no_overflow' [OF al]) - done - - thus ?thesis using yq by (simp add: field_simps) -qed - -lemmas tcbSlots = - tcbCTableSlot_def tcbVTableSlot_def - tcbReplySlot_def tcbCallerSlot_def tcbIPCBufferSlot_def - -lemma updateObject_cte_tcb: - assumes tc: "tcb_cte_cases (ptr - ptr') = Some (accF, updF)" - shows "updateObject ctea (KOTCB tcb) ptr ptr' next = - (do alignCheck ptr' (objBits tcb); - magnitudeCheck ptr' next (objBits tcb); - return (KOTCB (updF (\_. ctea) tcb)) - od)" - using tc unfolding tcb_cte_cases_def - apply - - apply (clarsimp simp add: updateObject_cte Let_def - tcb_cte_cases_def objBits_simps' tcbSlots shiftl_t2n - split: if_split_asm cong: if_cong) - done - definition tcb_no_ctes_proj :: "tcb \ Structures_H.thread_state \ machine_word \ machine_word \ arch_tcb \ bool \ word8 \ word8 \ word8 \ nat \ fault option \ machine_word option" where @@ -658,10 +597,6 @@ proof - qed fact+ qed -lemma ctes_of_cte_at: - "ctes_of s p = Some x \ cte_at' p s" - by (simp add: cte_wp_at_ctes_of) - lemma cor_map_relI: assumes dm: "dom am = dom am'" and rl: "\x y y' z. \ am x = Some y; am' x = Some y'; diff --git a/proof/crefine/RISCV64/Syscall_C.thy b/proof/crefine/RISCV64/Syscall_C.thy index 0def69f32..dc1dc4d69 100644 --- a/proof/crefine/RISCV64/Syscall_C.thy +++ b/proof/crefine/RISCV64/Syscall_C.thy @@ -1144,21 +1144,6 @@ lemma deleteCallerCap_ccorres [corres]: tcb_aligned') done - -(* FIXME: MOVE *) -lemma cap_case_EndpointCap_NotificationCap: - "(case cap of EndpointCap v0 v1 v2 v3 v4 v5 \ f v0 v1 v2 v3 v4 v5 - | 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) (capEPCanGrantReply 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 to Corres_C.thy *) lemma ccorres_trim_redundant_throw_break: "\ccorres_underlying rf_sr \ arrel axf arrel axf G G' (SKIP # hs) a c; diff --git a/proof/crefine/RISCV64/Tcb_C.thy b/proof/crefine/RISCV64/Tcb_C.thy index 7568abb71..d45e09f02 100644 --- a/proof/crefine/RISCV64/Tcb_C.thy +++ b/proof/crefine/RISCV64/Tcb_C.thy @@ -9,11 +9,6 @@ theory Tcb_C imports Delete_C Ipc_C begin -lemma asUser_obj_at' : - "\ K(t\t') and obj_at' P t' \ asUser t f \ \_. obj_at' (P::Structures_H.tcb \ bool) t' \" - including no_pre - by (wpsimp wp: hoare_vcg_ball_lift threadGet_wp simp: split_def asUser_def) - lemma getObject_sched: "(x::tcb, s') \ fst (getObject t s) \ (x,s'\ksSchedulerAction := ChooseNewThread\) \ fst (getObject t (s\ksSchedulerAction := ChooseNewThread\))" diff --git a/proof/crefine/RISCV64/VSpace_C.thy b/proof/crefine/RISCV64/VSpace_C.thy index 1657cc7c0..a05371995 100644 --- a/proof/crefine/RISCV64/VSpace_C.thy +++ b/proof/crefine/RISCV64/VSpace_C.thy @@ -849,22 +849,6 @@ lemma ccorres_abstract_known: apply simp done -lemma setObject_modify: - fixes v :: "'a :: pspace_storable" shows - "\ obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; - (1 :: machine_word) < 2 ^ objBits v \ - \ setObject p v s - = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" - apply (clarsimp simp: setObject_def split_def exec_gets obj_at'_def lookupAround2_known1 - assert_opt_def updateObject_default_def bind_assoc) - apply (simp add: projectKO_def alignCheck_assert) - apply (simp add: project_inject objBits_def) - apply (clarsimp simp only: objBitsT_koTypeOf[symmetric] koTypeOf_injectKO) - apply (frule(2) in_magnitude_check[where s'=s]) - apply (simp add: magnitudeCheck_assert in_monad) - apply (simp add: simpler_modify_def) - done - lemma ccorres_name_pre_C: "(\s. s \ P' \ ccorres_underlying sr \ r xf arrel axf P {s} hs f g) \ ccorres_underlying sr \ r xf arrel axf P P' hs f g" diff --git a/proof/crefine/X64/ArchMove_C.thy b/proof/crefine/X64/ArchMove_C.thy index 529fc6d38..d5a610095 100644 --- a/proof/crefine/X64/ArchMove_C.thy +++ b/proof/crefine/X64/ArchMove_C.thy @@ -454,6 +454,84 @@ lemma valid_untyped': nat_le_linear power_overflow sub_wrap add_0 add_0_right word_add_increasing word_less_1 word_less_sub_1) +(* We don't have access to n_msgRegisters from C here, but the number of msg registers in C should + be equivalent to what we have in the abstract/design specs. We want a number for this definition + that automatically updates if the number of registers changes, and we sanity check it later + in msgRegisters_size_sanity *) +definition size_msgRegisters :: nat where + size_msgRegisters_pre_def: "size_msgRegisters \ size (X64.msgRegisters)" + +schematic_goal size_msgRegisters_def: + "size_msgRegisters = numeral ?x" + unfolding size_msgRegisters_pre_def X64.msgRegisters_def + by (simp add: upto_enum_red fromEnum_def enum_register del: Suc_eq_numeral) + (simp only: Suc_eq_plus1_left, simp del: One_nat_def) + +lemma length_msgRegisters[simplified size_msgRegisters_def]: + "length X64_H.msgRegisters = size_msgRegisters" + by (simp add: size_msgRegisters_pre_def X64_H.msgRegisters_def) + +lemma empty_fail_loadWordUser[intro!, simp]: + "empty_fail (loadWordUser x)" + by (simp add: loadWordUser_def ef_loadWord ef_dmo') + +lemma empty_fail_getMRs[iff]: + "empty_fail (getMRs t buf mi)" + by (auto simp add: getMRs_def split: option.split) + +lemma empty_fail_getReceiveSlots: + "empty_fail (getReceiveSlots r rbuf)" +proof - + note + empty_fail_assertE[iff] + empty_fail_resolveAddressBits[iff] + show ?thesis + apply (clarsimp simp: getReceiveSlots_def loadCapTransfer_def split_def + split: option.split) + apply (rule empty_fail_bind) + apply (simp add: capTransferFromWords_def) + apply (simp add: emptyOnFailure_def unifyFailure_def) + apply (intro empty_fail_catch empty_fail_bindE empty_fail_rethrowFailure, + simp_all add: empty_fail_whenEs) + apply (simp_all add: lookupCap_def split_def lookupCapAndSlot_def + lookupSlotForThread_def liftME_def + getThreadCSpaceRoot_def locateSlot_conv bindE_assoc + lookupSlotForCNodeOp_def lookupErrorOnFailure_def + cong: if_cong) + apply (intro empty_fail_bindE, + simp_all add: getSlotCap_def) + apply (intro empty_fail_If empty_fail_bindE empty_fail_rethrowFailure impI, + simp_all add: empty_fail_whenEs rangeCheck_def) + done +qed + +lemma user_getreg_rv: + "\obj_at' (\tcb. P ((user_regs o atcbContextGet o tcbArch) tcb r)) t\ + asUser t (getRegister r) + \\rv s. P rv\" + apply (simp add: asUser_def split_def) + apply (wp threadGet_wp) + apply (clarsimp simp: obj_at'_def getRegister_def in_monad atcbContextGet_def) + done + +crunches insertNewCap, Arch_createNewCaps, threadSet, Arch.createObject, setThreadState, + updateFreeIndex, preemptionPoint + for gsCNodes[wp]: "\s. P (gsCNodes s)" + (wp: crunch_wps setObject_ksPSpace_only + simp: unless_def updateObject_default_def crunch_simps + ignore_del: preemptionPoint) + +lemma cap_case_isPML4Cap: + "(case cap of ArchObjectCap (PML4Cap pm (Some asid)) \ fn pm asid | _ => g) + = (if (if isArchObjectCap cap then if isPML4Cap (capCap cap) then capPML4MappedASID (capCap cap) \ None else False else False) + then fn (capPML4BasePtr (capCap cap)) (the (capPML4MappedASID (capCap cap))) else g)" + apply (cases cap; simp add: isArchObjectCap_def) + apply (rename_tac arch_capability) + apply (case_tac arch_capability, simp_all add: isPML4Cap_def) + apply (rename_tac option) + apply (case_tac option; simp) + done + end end diff --git a/proof/crefine/X64/CLevityCatch.thy b/proof/crefine/X64/CLevityCatch.thy index 19f86fbe3..8cc7860ec 100644 --- a/proof/crefine/X64/CLevityCatch.thy +++ b/proof/crefine/X64/CLevityCatch.thy @@ -51,14 +51,6 @@ lemma no_overlap_new_cap_addrs_disjoint: declare empty_fail_doMachineOp [simp] -lemma empty_fail_loadWordUser[intro!, simp]: - "empty_fail (loadWordUser x)" - by (simp add: loadWordUser_def ef_loadWord) - -lemma empty_fail_getMRs[iff]: - "empty_fail (getMRs t buf mi)" - by (auto simp add: getMRs_def split: option.split) - lemma empty_fail_getExtraCPtrs [intro!, simp]: "empty_fail (getExtraCPtrs sendBuffer info)" apply (simp add: getExtraCPtrs_def) @@ -80,33 +72,6 @@ lemma empty_fail_unifyFailure [intro!, simp]: handleE'_def throwError_def split: sum.splits) - -lemma empty_fail_getReceiveSlots: - "empty_fail (getReceiveSlots r rbuf)" -proof - - note - empty_fail_assertE[iff] - empty_fail_resolveAddressBits[iff] - show ?thesis - apply (clarsimp simp: getReceiveSlots_def loadCapTransfer_def split_def - split: option.split) - apply (rule empty_fail_bind) - apply (simp add: capTransferFromWords_def) - apply (simp add: emptyOnFailure_def unifyFailure_def) - apply (intro empty_fail_catch empty_fail_bindE empty_fail_rethrowFailure, - simp_all add: empty_fail_whenEs) - apply (simp_all add: lookupCap_def split_def lookupCapAndSlot_def - lookupSlotForThread_def liftME_def - getThreadCSpaceRoot_def locateSlot_conv bindE_assoc - lookupSlotForCNodeOp_def lookupErrorOnFailure_def - cong: if_cong) - apply (intro empty_fail_bindE, - simp_all add: getSlotCap_def) - apply (intro empty_fail_If empty_fail_bindE empty_fail_rethrowFailure impI, - simp_all add: empty_fail_whenEs rangeCheck_def) - done -qed - lemma exec_Basic_Guard_UNIV: "Semantic.exec \ (Basic f;; Guard F UNIV (Basic g)) x y = Semantic.exec \ (Basic (g o f)) x y" @@ -138,4 +103,12 @@ lemma option_to_ptr_not_0: "\ p \ 0 ; option_to_ptr v = Ptr p \ \ v = Some p" by (clarsimp simp: option_to_ptr_def option_to_0_def split: option.splits) +schematic_goal sz8_helper: + "((-1) << 8 :: addr) = ?v" + by (simp add: shiftl_t2n) + +lemmas reset_name_seq_bound_helper2 + = reset_name_seq_bound_helper[where sz=8 and v="v :: addr" for v, + simplified sz8_helper word_bits_def[symmetric], + THEN name_seq_bound_helper] end diff --git a/proof/crefine/X64/CSpaceAcc_C.thy b/proof/crefine/X64/CSpaceAcc_C.thy index 1b7c7ebcc..79d4e7a93 100644 --- a/proof/crefine/X64/CSpaceAcc_C.thy +++ b/proof/crefine/X64/CSpaceAcc_C.thy @@ -187,15 +187,11 @@ lemma ccorres_pre_getIdleThread: apply (clarsimp simp: rf_sr_ksIdleThread) done - -lemma cd_wp [wp]: "\\s. P (ksCurDomain s) s\ curDomain \P\" - by (unfold curDomain_def, wp) - lemma curDomain_sp: "\P\ curDomain \\rv s. ksCurDomain s = rv \ P s\" apply wp apply simp -done + done lemma rf_sr_ksCurDomain: "(s, s') \ rf_sr \ ksCurDomain_' (globals s') diff --git a/proof/crefine/X64/CSpace_RAB_C.thy b/proof/crefine/X64/CSpace_RAB_C.thy index 20c08c7ca..5f33478ed 100644 --- a/proof/crefine/X64/CSpace_RAB_C.thy +++ b/proof/crefine/X64/CSpace_RAB_C.thy @@ -92,13 +92,6 @@ lemma ccorres_req: apply (clarsimp elim!: bexI [rotated]) done -lemma valid_cap_cte_at': - "\isCNodeCap cap; valid_cap' cap s'\ \ cte_at' (capCNodePtr cap + 2^cteSizeBits * (addr && mask (capCNodeBits cap))) s'" - apply (clarsimp simp: isCap_simps valid_cap'_def) - apply (rule real_cte_at') - apply (erule spec) - done - declare mask_64_max_word [simp] lemma rightsFromWord_wordFromRights: diff --git a/proof/crefine/X64/Finalise_C.thy b/proof/crefine/X64/Finalise_C.thy index ba3e95a46..f858a4f40 100644 --- a/proof/crefine/X64/Finalise_C.thy +++ b/proof/crefine/X64/Finalise_C.thy @@ -13,11 +13,6 @@ begin declare if_split [split del] -lemma empty_fail_getEndpoint: - "empty_fail (getEndpoint ep)" - unfolding getEndpoint_def - by (auto intro: empty_fail_getObject) - definition "option_map2 f m = option_map f \ m" diff --git a/proof/crefine/X64/IpcCancel_C.thy b/proof/crefine/X64/IpcCancel_C.thy index a09a7f373..a32787fcf 100644 --- a/proof/crefine/X64/IpcCancel_C.thy +++ b/proof/crefine/X64/IpcCancel_C.thy @@ -2696,13 +2696,6 @@ lemma cancelSignal_ccorres [corres]: | clarsimp simp: eq_commute | drule_tac x=thread in bspec)+ -lemma ko_at_valid_ep': - "\ko_at' ep p s; valid_objs' s\ \ valid_ep' ep s" - apply (erule obj_atE') - apply (erule (1) valid_objsE') - apply (simp add: projectKOs valid_obj'_def) - done - (* FIXME: MOVE *) lemma ccorres_pre_getEndpoint [corres_pre]: assumes cc: "\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c" diff --git a/proof/crefine/X64/Ipc_C.thy b/proof/crefine/X64/Ipc_C.thy index 2f193b798..8884a012e 100644 --- a/proof/crefine/X64/Ipc_C.thy +++ b/proof/crefine/X64/Ipc_C.thy @@ -1466,13 +1466,6 @@ lemma ccorres_add_getRegister: apply fastforce done -lemma user_getreg_rv: - "\obj_at' (\tcb. P ((user_regs o atcbContextGet o tcbArch) tcb r)) t\ asUser t (getRegister r) \\rv s. P rv\" - apply (simp add: asUser_def split_def) - apply (wp threadGet_wp) - apply (clarsimp simp: obj_at'_def projectKOs getRegister_def in_monad atcbContextGet_def) - done - lemma exceptionMessage_ccorres: "n < unat n_exceptionMessage \ register_from_H (X64_H.exceptionMessage ! n) diff --git a/proof/crefine/X64/IsolatedThreadAction.thy b/proof/crefine/X64/IsolatedThreadAction.thy index 739ea9674..efeade36d 100644 --- a/proof/crefine/X64/IsolatedThreadAction.thy +++ b/proof/crefine/X64/IsolatedThreadAction.thy @@ -5,7 +5,7 @@ *) theory IsolatedThreadAction -imports "CLib.MonadicRewrite_C" Finalise_C CSpace_All SyscallArgs_C +imports ArchMove_C begin context begin interpretation Arch . @@ -127,10 +127,26 @@ lemmas setNotification_tcb = set_ntfn_tcb_obj_at' end -context kernel_m begin - context begin interpretation Arch . (*FIXME: arch_split*) +lemma setObject_modify: + fixes v :: "'a :: pspace_storable" shows + "\ obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; + (1 :: machine_word) < 2 ^ objBits v \ + \ setObject p v s + = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" + apply (clarsimp simp: setObject_def split_def exec_gets + obj_at'_def projectKOs lookupAround2_known1 + assert_opt_def updateObject_default_def + bind_assoc) + apply (simp add: projectKO_def alignCheck_assert) + apply (simp add: project_inject objBits_def) + apply (clarsimp simp only: objBitsT_koTypeOf[symmetric] koTypeOf_injectKO) + apply (frule(2) in_magnitude_check[where s'=s]) + apply (simp add: magnitudeCheck_assert in_monad) + apply (simp add: simpler_modify_def) + done + lemma getObject_return: fixes v :: "'a :: pspace_storable" shows "\ \a b c d. (loadObject a b c d :: 'a kernel) = loadObject_default a b c d; @@ -162,6 +178,8 @@ lemma partial_overwrite_fun_upd: apply (clarsimp split: if_split) done +context begin interpretation Arch . (*FIXME: arch_split*) + lemma get_tcb_state_regs_ko_at': "ko_at' ko p s \ get_tcb_state_regs (ksPSpace s p) = TCBStateRegs (tcbState ko) ((user_regs o atcbContextGet o tcbArch) ko)" @@ -265,6 +283,7 @@ lemma map_to_ctes_partial_overwrite: "\x. tcb_at' (idx x) s \ map_to_ctes (partial_overwrite idx tsrs (ksPSpace s)) = ctes_of s" + supply if_split[split del] apply (rule ext) apply (frule dom_partial_overwrite[where tsrs=tsrs]) apply (simp add: map_to_ctes_def partial_overwrite_def @@ -614,6 +633,7 @@ lemma page_map_l4_at_partial_overwrite: lemma findVSpaceForASID_isolatable: "thread_actions_isolatable idx (findVSpaceForASID asid)" + supply if_split[split del] apply (simp add: findVSpaceForASID_def liftE_bindE liftME_def bindE_assoc case_option_If2 assertE_def liftE_def checkPML4At_def stateAssert_def2 @@ -680,6 +700,7 @@ lemma setCurrentUserVSpaceRoot_isolatable: lemma setVMRoot_isolatable: "thread_actions_isolatable idx (setVMRoot t)" + supply if_split[split del] apply (simp add: setVMRoot_def getThreadVSpaceRoot_def locateSlot_conv getSlotCap_def cap_case_isPML4Cap if_bool_simps @@ -706,8 +727,11 @@ lemma transferCaps_simple: return (mi\msgExtraCaps := 0, msgCapsUnwrapped := 0\) od" apply (cases mi) - apply (clarsimp simp: transferCaps_def getThreadCSpaceRoot_def locateSlot_conv - cong: option.case_cong) + apply (cases mi) + apply (clarsimp simp: transferCaps_def getThreadCSpaceRoot_def locateSlot_conv) + apply (rule ext bind_apply_cong[OF refl])+ + apply (simp add: upto_enum_def + split: option.split) done lemma transferCaps_simple_rewrite: @@ -736,23 +760,16 @@ lemma lookupIPC_inv: "\P\ lookupIPCBuffer f t \\ lemmas empty_fail_user_getreg = empty_fail_asUser[OF empty_fail_getRegister] -lemma user_getreg_rv: - "\obj_at' (\tcb. P ((user_regs o atcbContextGet o tcbArch) tcb r)) t\ asUser t (getRegister r) \\rv s. P rv\" - apply (simp add: asUser_def split_def) - apply (wp threadGet_wp) - apply (clarsimp simp: obj_at'_def projectKOs getRegister_def in_monad atcbContextGet_def) - done - lemma copyMRs_simple: - "msglen \ of_nat (length X64_H.msgRegisters) \ + "msglen \ of_nat (length msgRegisters) \ copyMRs sender sbuf receiver rbuf msglen - = forM_x (take (unat msglen) X64_H.msgRegisters) + = forM_x (take (unat msglen) msgRegisters) (\r. do v \ asUser sender (getRegister r); asUser receiver (setRegister r v) od) >>= (\rv. return msglen)" apply (clarsimp simp: copyMRs_def mapM_discarded) apply (rule bind_cong[OF refl]) - apply (simp add: length_msgRegisters n_msgRegisters_def min_def + apply (simp add: length_msgRegisters min_def word_le_nat_alt split: option.split) apply (simp add: upto_enum_def mapM_Nil) @@ -762,16 +779,16 @@ lemma doIPCTransfer_simple_rewrite: "monadic_rewrite True True ((\_. msgExtraCaps (messageInfoFromWord msgInfo) = 0 \ msgLength (messageInfoFromWord msgInfo) - \ of_nat (length X64_H.msgRegisters)) + \ of_nat (length msgRegisters)) and obj_at' (\tcb. tcbFault tcb = None \ (user_regs o atcbContextGet o tcbArch) tcb msgInfoRegister = msgInfo) sender) (doIPCTransfer sender ep badge grant rcvr) (do rv \ mapM_x (\r. do v \ asUser sender (getRegister r); asUser rcvr (setRegister r v) od) - (take (unat (msgLength (messageInfoFromWord msgInfo))) X64_H.msgRegisters); + (take (unat (msgLength (messageInfoFromWord msgInfo))) msgRegisters); y \ setMessageInfo rcvr ((messageInfoFromWord msgInfo) \msgCapsUnwrapped := 0\); - asUser rcvr (setRegister X64_H.badgeRegister badge) + asUser rcvr (setRegister badgeRegister badge) od)" supply if_cong[cong] apply (rule monadic_rewrite_gen_asm) @@ -923,7 +940,7 @@ lemma oblivious_setVMRoot_schact: lemma oblivious_switchToThread_schact: "oblivious (ksSchedulerAction_update f) (ThreadDecls_H.switchToThread t)" - apply (simp add: Thread_H.switchToThread_def X64_H.switchToThread_def bind_assoc + apply (simp add: Thread_H.switchToThread_def switchToThread_def bind_assoc getCurThread_def setCurThread_def threadGet_def liftM_def threadSet_def tcbSchedEnqueue_def unless_when asUser_def getQueue_def setQueue_def storeWordUser_def setRegister_def @@ -979,8 +996,6 @@ crunch obj_at_prio[wp]: cteDeleteOne "obj_at' (\tcb. P (tcbPriority tcb) setThreadState_obj_at_unchanged setNotification_tcb setBoundNotification_obj_at_unchanged simp: crunch_simps unless_def) -context kernel_m begin - lemma setThreadState_no_sch_change: "\\s. P (ksSchedulerAction s) \ (runnable' st \ t \ ksCurThread s)\ setThreadState st t @@ -1012,6 +1027,8 @@ lemma bind_assoc: = do x \ m; y \ f x; g y od" by (rule bind_assoc) +context begin interpretation Arch . (*FIXME: arch_split*) + lemma setObject_modify_assert: "\ updateObject v = updateObject_default v \ \ setObject p v = do f \ gets (obj_at' (\v'. v = v' \ True) p); @@ -1036,6 +1053,7 @@ lemma setObject_modify_assert: lemma setEndpoint_isolatable: "thread_actions_isolatable idx (setEndpoint p e)" + supply if_split[split del] apply (simp add: setEndpoint_def setObject_modify_assert assert_def) apply (case_tac "p \ range idx") @@ -1136,6 +1154,7 @@ lemma atcbContextSetSetGet_eq[simp]: lemma setCTE_isolatable: "thread_actions_isolatable idx (setCTE p v)" + supply if_split[split del] apply (simp add: setCTE_assert_modify) apply (clarsimp simp: thread_actions_isolatable_def monadic_rewrite_def fun_eq_iff @@ -1198,9 +1217,9 @@ lemma assert_isolatable: lemma cteInsert_isolatable: "thread_actions_isolatable idx (cteInsert cap src dest)" + supply if_split[split del] if_cong[cong] apply (simp add: cteInsert_def updateCap_def updateMDB_def - Let_def setUntypedCapAsFull_def - cong: if_cong) + Let_def setUntypedCapAsFull_def) apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] thread_actions_isolatable_if thread_actions_isolatable_returns assert_isolatable @@ -1298,7 +1317,7 @@ lemma threadGet_isolatable: lemma switchToThread_isolatable: "thread_actions_isolatable idx (Arch.switchToThread t)" - apply (simp add: X64_H.switchToThread_def + apply (simp add: switchToThread_def storeWordUser_def stateAssert_def2) apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] gets_isolatable setVMRoot_isolatable @@ -1368,7 +1387,7 @@ lemma tcb_at_KOTCB_upd: = tcb_at' p s" apply (clarsimp simp: obj_at'_def projectKOs objBits_simps split: if_split) - apply (simp add: ps_clear_def) + apply (fastforce simp add: ps_clear_def) done definition @@ -1416,6 +1435,7 @@ lemma copy_register_isolate: asUser dest (setRegister r' (rf v)) od) (isolate_thread_actions idx (return ()) (copy_register_tsrs x y r r' rf) id)" + supply if_split[split del] apply (simp add: asUser_def split_def bind_assoc getRegister_def setRegister_def select_f_returns isolate_thread_actions_def @@ -1565,7 +1585,7 @@ lemmas fastpath_isolate_rewrites lemma lookupIPCBuffer_isolatable: "thread_actions_isolatable idx (lookupIPCBuffer w t)" - supply if_cong[cong] + supply if_cong[cong] supply if_split[split del] apply (simp add: lookupIPCBuffer_def) apply (rule thread_actions_isolatable_bind) apply (clarsimp simp: put_tcb_state_regs_tcb_def threadGet_isolatable @@ -1586,6 +1606,7 @@ lemma setThreadState_rewrite_simple: (\s. (runnable' st \ ksSchedulerAction s \ ResumeCurrentThread \ t \ ksCurThread s) \ tcb_at' t s) (setThreadState st t) (threadSet (tcbState_update (\_. st)) t)" + supply if_split[split del] apply (simp add: setThreadState_def) apply (rule monadic_rewrite_imp) apply (rule monadic_rewrite_trans) diff --git a/proof/crefine/X64/PSpace_C.thy b/proof/crefine/X64/PSpace_C.thy index 13acd2283..14a69364e 100644 --- a/proof/crefine/X64/PSpace_C.thy +++ b/proof/crefine/X64/PSpace_C.thy @@ -10,13 +10,6 @@ begin context kernel begin -lemma koTypeOf_injectKO: - fixes v :: "'a :: pspace_storable" shows - "koTypeOf (injectKO v) = koType TYPE('a)" - apply (cut_tac v1=v in iffD2 [OF project_inject, OF refl]) - apply (simp add: project_koType[symmetric]) - done - lemma setObject_obj_at_pre: "\ updateObject ko = updateObject_default ko; (1 :: machine_word) < 2 ^ objBits ko \ diff --git a/proof/crefine/X64/Retype_C.thy b/proof/crefine/X64/Retype_C.thy index ea6de65b3..6360c8a64 100644 --- a/proof/crefine/X64/Retype_C.thy +++ b/proof/crefine/X64/Retype_C.thy @@ -8031,11 +8031,6 @@ end context begin interpretation Arch . (*FIXME: arch_split*) -crunches insertNewCap, Arch_createNewCaps, threadSet, Arch.createObject - for gsCNodes[wp]: "\s. P (gsCNodes s)" - (wp: crunch_wps setObject_ksPSpace_only - simp: unless_def updateObject_default_def crunch_simps) - lemma createNewCaps_1_gsCNodes_p: "\\s. P (gsCNodes s p) \ p \ ptr\ createNewCaps newType ptr 1 n dev\\rv s. P (gsCNodes s p)\" apply (simp add: createNewCaps_def) diff --git a/proof/crefine/X64/SR_lemmas_C.thy b/proof/crefine/X64/SR_lemmas_C.thy index 4dee18d8e..5b83c100d 100644 --- a/proof/crefine/X64/SR_lemmas_C.thy +++ b/proof/crefine/X64/SR_lemmas_C.thy @@ -292,67 +292,6 @@ lemma cmdbnode_relation_mdb_node_to_H [simp]: unfolding cmdbnode_relation_def mdb_node_to_H_def mdb_node_lift_def cte_lift_def by (fastforce split: option.splits) -(* MOVE --- here down doesn't really belong here, maybe in a haskell specific file?*) -lemma tcb_cte_cases_in_range1: - assumes tc:"tcb_cte_cases (y - x) = Some v" - and al: "is_aligned x tcbBlockSizeBits" - shows "x \ y" -proof - - note objBits_defs [simp] - - from tc obtain q where yq: "y = x + q" and qv: "q < 2 ^ 9" - unfolding tcb_cte_cases_def - by (simp add: diff_eq_eq split: if_split_asm) - - have "x \ x + 2 ^ tcbBlockSizeBits - 1" using al - by (rule is_aligned_no_overflow) - - hence "x \ x + q" using qv - apply simp - apply unat_arith - apply simp - done - - thus ?thesis using yq by simp -qed - -lemma tcb_cte_cases_in_range2: - assumes tc: "tcb_cte_cases (y - x) = Some v" - and al: "is_aligned x tcbBlockSizeBits" - shows "y \ x + 2 ^ tcbBlockSizeBits - 1" -proof - - note objBits_defs [simp] - - from tc obtain q where yq: "y = x + q" and qv: "q \ 2 ^ tcbBlockSizeBits - 1" - unfolding tcb_cte_cases_def - by (simp add: diff_eq_eq split: if_split_asm) - - have "x + q \ x + (2 ^ tcbBlockSizeBits - 1)" using qv - apply (rule word_plus_mono_right) - apply (rule is_aligned_no_overflow' [OF al]) - done - - thus ?thesis using yq by (simp add: field_simps) -qed - -lemmas tcbSlots = - tcbCTableSlot_def tcbVTableSlot_def - tcbReplySlot_def tcbCallerSlot_def tcbIPCBufferSlot_def - -lemma updateObject_cte_tcb: - assumes tc: "tcb_cte_cases (ptr - ptr') = Some (accF, updF)" - shows "updateObject ctea (KOTCB tcb) ptr ptr' next = - (do alignCheck ptr' (objBits tcb); - magnitudeCheck ptr' next (objBits tcb); - return (KOTCB (updF (\_. ctea) tcb)) - od)" - using tc unfolding tcb_cte_cases_def - apply - - apply (clarsimp simp add: updateObject_cte Let_def - tcb_cte_cases_def objBits_simps' tcbSlots shiftl_t2n - split: if_split_asm cong: if_cong) - done - definition tcb_no_ctes_proj :: "tcb \ Structures_H.thread_state \ machine_word \ machine_word \ arch_tcb \ bool \ word8 \ word8 \ word8 \ nat \ fault option \ machine_word option" where @@ -701,10 +640,6 @@ proof - qed fact+ qed -lemma ctes_of_cte_at: - "ctes_of s p = Some x \ cte_at' p s" - by (simp add: cte_wp_at_ctes_of) - lemma cor_map_relI: assumes dm: "dom am = dom am'" and rl: "\x y y' z. \ am x = Some y; am' x = Some y'; diff --git a/proof/crefine/X64/Syscall_C.thy b/proof/crefine/X64/Syscall_C.thy index 6476b19bd..99cdb2475 100644 --- a/proof/crefine/X64/Syscall_C.thy +++ b/proof/crefine/X64/Syscall_C.thy @@ -1142,21 +1142,6 @@ lemma deleteCallerCap_ccorres [corres]: tcb_aligned') done - -(* FIXME: MOVE *) -lemma cap_case_EndpointCap_NotificationCap: - "(case cap of EndpointCap v0 v1 v2 v3 v4 v5 \ f v0 v1 v2 v3 v4 v5 - | 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) (capEPCanGrantReply 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 to Corres_C.thy *) lemma ccorres_trim_redundant_throw_break: "\ccorres_underlying rf_sr \ arrel axf arrel axf G G' (SKIP # hs) a c; diff --git a/proof/crefine/X64/Tcb_C.thy b/proof/crefine/X64/Tcb_C.thy index fa21af666..0c19ceba6 100644 --- a/proof/crefine/X64/Tcb_C.thy +++ b/proof/crefine/X64/Tcb_C.thy @@ -8,11 +8,6 @@ theory Tcb_C imports Delete_C Ipc_C begin -lemma asUser_obj_at' : - "\ K(t\t') and obj_at' P t' \ asUser t f \ \_. obj_at' (P::Structures_H.tcb \ bool) t' \" - including no_pre - by (wpsimp wp: hoare_vcg_ball_lift threadGet_wp simp: split_def asUser_def) - lemma getObject_sched: "(x::tcb, s') \ fst (getObject t s) \ (x,s'\ksSchedulerAction := ChooseNewThread\) \ fst (getObject t (s\ksSchedulerAction := ChooseNewThread\))" diff --git a/proof/crefine/X64/VSpace_C.thy b/proof/crefine/X64/VSpace_C.thy index 1fb97f296..3b3fab607 100644 --- a/proof/crefine/X64/VSpace_C.thy +++ b/proof/crefine/X64/VSpace_C.thy @@ -840,17 +840,6 @@ lemma lookupPTSlot_ccorres: split: X64_H.pde.splits if_splits) done -lemma cap_case_isPML4Cap: - "(case cap of ArchObjectCap (PML4Cap pm (Some asid)) \ fn pm asid | _ => g) - = (if (if isArchObjectCap cap then if isPML4Cap (capCap cap) then capPML4MappedASID (capCap cap) \ None else False else False) - then fn (capPML4BasePtr (capCap cap)) (the (capPML4MappedASID (capCap cap))) else g)" - apply (cases cap; simp add: isArchObjectCap_def) - apply (rename_tac arch_capability) - apply (case_tac arch_capability, simp_all add: isPML4Cap_def) - apply (rename_tac option) - apply (case_tac option; simp) - done - abbreviation "findVSpaceForASID_xf \ liftxf errstate findVSpaceForASID_ret_C.status_C findVSpaceForASID_ret_C.vspace_root_C ret__struct_findVSpaceForASID_ret_C_'" @@ -1071,24 +1060,6 @@ lemma ccorres_abstract_known: apply simp done -lemma setObject_modify: - fixes v :: "'a :: pspace_storable" shows - "\ obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; - (1 :: machine_word) < 2 ^ objBits v \ - \ setObject p v s - = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" - apply (clarsimp simp: setObject_def split_def exec_gets - obj_at'_def projectKOs lookupAround2_known1 - assert_opt_def updateObject_default_def - bind_assoc) - apply (simp add: projectKO_def alignCheck_assert) - apply (simp add: project_inject objBits_def) - apply (clarsimp simp only: objBitsT_koTypeOf[symmetric] koTypeOf_injectKO) - apply (frule(2) in_magnitude_check[where s'=s]) - apply (simp add: magnitudeCheck_assert in_monad) - apply (simp add: simpler_modify_def) - done - lemma ccorres_name_pre_C: "(\s. s \ P' \ ccorres_underlying sr \ r xf arrel axf P {s} hs f g) \ ccorres_underlying sr \ r xf arrel axf P P' hs f g"