(* * Copyright 2014, General Dynamics C4 Systems * * This software may be distributed and modified according to the terms of * the GNU General Public License version 2. Note that NO WARRANTY is provided. * See "LICENSE_GPLv2.txt" for details. * * @TAG(GD_GPL) *) theory CLevityCatch imports Include_C "../../lib/LemmaBucket_C" "../../lib/LemmaBucket" 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] (* works much better *) lemmas typ_heap_simps' = typ_heap_simps c_guard_clift lemmas asUser_return = submonad.return [OF submonad_asUser] lemma setMRs_Nil: "setMRs thread buffer [] = stateAssert (tcb_at' thread) [] >>= (\_. return 0)" unfolding setMRs_def by (simp add: zipWithM_x_def sequence_x_def zipWith_def asUser_return) lemmas asUser_bind_distrib = submonad_bind [OF submonad_asUser submonad_asUser submonad_asUser] lemma ps_clear_upd_None: "ksPSpace s y = None \ ps_clear x n (ksPSpace_update (\a. (ksPSpace s)(y := None)) s') = ps_clear x n s" by (rule iffI | clarsimp elim!: ps_clear_domE | fastforce)+ lemma ntfnQueue_head_mask_4 : "ntfnQueue_head_CL (notification_lift ko') && ~~ mask 4 = ntfnQueue_head_CL (notification_lift ko')" unfolding notification_lift_def by (clarsimp simp: mask_def word_bw_assocs) (* Levity: moved from Ipc_C (20090419 09:44:31) *) (* and remove from Syscall_C *) lemma empty_fail_doMachineOp[intro!]: "empty_fail m \ empty_fail (doMachineOp m)" by (rule ef_dmo') (* Levity: moved from Ipc_C (20090419 09:44:31) *) (* why isn't this in Kernel_C? *) lemmas C_register_defs = Kernel_C.R0_def Kernel_C.R1_def Kernel_C.R2_def Kernel_C.R3_def Kernel_C.R4_def Kernel_C.R5_def Kernel_C.R6_def Kernel_C.R7_def Kernel_C.R8_def Kernel_C.R9_def Kernel_C.R10_def Kernel_C.R11_def Kernel_C.R12_def Kernel_C.SP_def Kernel_C.LR_def Kernel_C.LR_svc_def Kernel_C.CPSR_def Kernel_C.FaultInstruction_def (* Levity: moved from Retype_C (20090419 09:44:41) *) lemma no_overlap_new_cap_addrs_disjoint: "\ range_cover ptr sz (objBitsKO ko) n; pspace_aligned' s; pspace_no_overlap' ptr sz s \ \ set (new_cap_addrs n ptr ko) \ dom (ksPSpace s) = {}" apply (erule disjoint_subset [OF new_cap_addrs_subset, where sz1=sz]) apply (clarsimp simp: Word_Lib.ptr_add_def field_simps) apply (rule pspace_no_overlap_disjoint') apply auto done lemma empty_fail_asUser[iff]: "empty_fail m \ empty_fail (asUser t m)" apply (simp add: asUser_def split_def) apply (intro empty_fail_bind, simp_all) apply (simp add: select_f_def empty_fail_def) done 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) apply (cases info, simp) apply (cases sendBuffer, simp_all) done lemma empty_fail_loadCapTransfer [intro!, simp]: "empty_fail (loadCapTransfer a)" by (simp add: loadCapTransfer_def capTransferFromWords_def) lemma empty_fail_emptyOnFailure [intro!, simp]: "empty_fail m \ empty_fail (emptyOnFailure m)" by (auto simp: emptyOnFailure_def catch_def split: sum.splits) lemma empty_fail_unifyFailure [intro!, simp]: "empty_fail m \ empty_fail (unifyFailure m)" by (auto simp: unifyFailure_def catch_def rethrowFailure_def handleE'_def throwError_def split: sum.splits) lemma asUser_mapM_x: "(\x. empty_fail (f x)) \ asUser t (mapM_x f xs) = do stateAssert (tcb_at' t) []; mapM_x (\x. asUser t (f x)) xs od" apply (simp add: mapM_x_mapM asUser_bind_distrib) apply (subst submonad_mapM [OF submonad_asUser submonad_asUser]) apply simp apply (simp add: asUser_return bind_assoc o_def) apply (rule ext) apply (rule bind_apply_cong [OF refl])+ apply (clarsimp simp: in_monad dest!: fst_stateAssertD) apply (drule use_valid, rule mapM_wp', rule asUser_tcb_at', assumption) apply (simp add: stateAssert_def get_def NonDetMonad.bind_def) done lemma asUser_get_registers: "\tcb_at' target\ asUser target (mapM getRegister xs) \\rv s. obj_at' (\tcb. map (tcbContext tcb) xs = rv) target s\" apply (induct xs) apply (simp add: mapM_empty asUser_return) apply wp apply simp apply (simp add: mapM_Cons asUser_bind_distrib asUser_return) apply wp apply simp apply (rule hoare_strengthen_post) apply (erule hoare_vcg_conj_lift) apply (rule asUser_inv) apply (simp add: getRegister_def) apply (wp mapM_wp') apply clarsimp apply (erule(1) obj_at_conj') apply (rule hoare_pre, wp) apply (simp add: asUser_def split_def threadGet_def) apply (wp getObject_tcb_wp) apply (clarsimp simp: getRegister_def simpler_gets_def obj_at'_def) done (* FIXME: should fall through to LemmaBucket or alike *) lemma is_aligned_neg_mask2 [simp]: "is_aligned (a && ~~ mask n) n" apply (cases "n < len_of TYPE('a)") apply (simp add: and_not_mask) apply (subst shiftl_t2n) apply (rule is_aligned_mult_triv1) apply (simp add: not_less NOT_mask power_overflow) done lemma projectKO_user_data_device: "(projectKO_opt ko = Some (t :: user_data_device)) = (ko = KOUserDataDevice)" by (cases ko) (auto simp: projectKO_opts_defs split: arch_kernel_object.splits) lemma device_data_at_ko: "typ_at' UserDataDeviceT p s \ ko_at' UserDataDevice p s" apply (clarsimp simp: typ_at'_def obj_at'_def ko_wp_at'_def projectKO_user_data_device projectKO_eq projectKO_eq2) apply (case_tac ko, auto) done (* FIXME: move *) lemma user_data_at_ko: "typ_at' UserDataT p s \ ko_at' UserData p s" apply (clarsimp simp: typ_at'_def obj_at'_def ko_wp_at'_def projectKOs) apply (case_tac ko, auto) done (* FIXME: move *) lemma map_to_ko_atI: "\(projectKO_opt \\<^sub>m ksPSpace s) x = Some v; pspace_aligned' s; pspace_distinct' s\ \ ko_at' v x s" apply (clarsimp simp: map_comp_Some_iff) apply (erule (2) aligned_distinct_obj_atI') apply (simp add: project_inject) done lemma empty_fail_rethrowFailure: "empty_fail f \ empty_fail (rethrowFailure fn f)" apply (simp add: rethrowFailure_def handleE'_def) apply (erule empty_fail_bind) apply (simp split: sum.split) done lemma empty_fail_resolveAddressBits: "empty_fail (resolveAddressBits cap cptr bits)" proof - note empty_fail_assertE[iff] show ?thesis apply (rule empty_fail_use_cutMon) apply (induct rule: resolveAddressBits.induct) apply (subst resolveAddressBits.simps) apply (unfold Let_def cnode_cap_case_if fun_app_def K_bind_def haskell_assertE_def split_def) apply (intro empty_fail_cutMon_intros) apply (clarsimp simp: empty_fail_drop_cutMon empty_fail_whenEs locateSlot_conv returnOk_liftE[symmetric] isCap_simps)+ done qed 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" apply (rule iffI) apply (elim exec_elim_cases, simp_all, clarsimp)[1] apply (simp add: o_def, rule exec.Basic) apply (elim exec_elim_cases) apply simp_all apply (rule exec_Seq' exec.Basic exec.Guard | simp)+ done end end