(* * 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) *) (* Top level architecture related proofs. *) theory Arch_R imports Untyped_R Finalise_R begin context begin interpretation Arch . (*FIXME: arch_split*) declare is_aligned_shiftl [intro!] declare is_aligned_shiftr [intro!] definition "asid_ci_map i \ case i of ARM_A.MakePool frame slot parent base \ ARM_HYP_H.MakePool frame (cte_map slot) (cte_map parent) base" definition "valid_aci' aci \ case aci of MakePool frame slot parent base \ \s. cte_wp_at' (\c. cteCap c = NullCap) slot s \ cte_wp_at' (\cte. \idx. cteCap cte = UntypedCap False frame pageBits idx) parent s \ descendants_of' parent (ctes_of s) = {} \ slot \ parent \ ex_cte_cap_to' slot s \ sch_act_simple s \ is_aligned base asid_low_bits \ base \ 2^asid_bits - 1" lemma vp_strgs': "valid_pspace' s \ pspace_distinct' s" "valid_pspace' s \ pspace_aligned' s" "valid_pspace' s \ valid_mdb' s" by auto lemma safe_parent_strg': "cte_wp_at' (\cte. cteCap cte = UntypedCap False frame pageBits idx) p s \ descendants_of' p (ctes_of s) = {} \ valid_pspace' s \ safe_parent_for' (ctes_of s) p (ArchObjectCap (ASIDPoolCap frame base))" apply (clarsimp simp: safe_parent_for'_def cte_wp_at_ctes_of) apply (case_tac cte) apply (simp add: isCap_simps) apply (subst conj_comms) apply (rule context_conjI) apply (drule ctes_of_valid_cap', fastforce) apply (clarsimp simp: valid_cap'_def capAligned_def) apply (drule is_aligned_no_overflow) apply (clarsimp simp: capRange_def asid_low_bits_def pageBits_def) apply (clarsimp simp: sameRegionAs_def2 isCap_simps capRange_def asid_low_bits_def pageBits_def) done lemma descendants_of'_helper: "\P\ f \\r s. Q (descendants_of' t (null_filter' (ctes_of s)))\ \ \P\ f \\r s. Q (descendants_of' t (ctes_of s))\" apply (clarsimp simp:valid_def) apply (subst null_filter_descendants_of') prefer 2 apply fastforce apply simp done lemma createObject_typ_at': "\\s. koTypeOf ty = otype \ is_aligned ptr (objBitsKO ty) \ pspace_aligned' s \ pspace_no_overlap' ptr (objBitsKO ty) s\ createObjects' ptr (Suc 0) ty 0 \\rv s. typ_at' otype ptr s\" apply (clarsimp simp:createObjects'_def alignError_def split_def | wp hoare_unless_wp | wpc )+ apply (simp add:obj_at'_def)+ apply (wp hoare_unless_wp)+ apply (clarsimp simp:ko_wp_at'_def typ_at'_def pspace_distinct'_def)+ apply (subgoal_tac "ps_clear ptr (objBitsKO ty) (s\ksPSpace := \a. if a = ptr then Some ty else ksPSpace s a\)") apply (simp add:ps_clear_def)+ apply (rule ccontr) apply (drule int_not_emptyD) apply clarsimp apply (unfold pspace_no_overlap'_def) apply (erule allE)+ apply (erule(1) impE) apply (subgoal_tac "x \ {x..x + 2 ^ objBitsKO y - 1}") apply (fastforce simp:is_aligned_neg_mask_eq p_assoc_help) apply (drule(1) pspace_alignedD') apply (clarsimp simp: is_aligned_no_wrap' p_assoc_help) done lemma retype_region2_ext_retype_region_ArchObject: "retype_region ptr n us (ArchObject x)= retype_region2 ptr n us (ArchObject x)" apply (rule ext) apply (simp add:retype_region_def retype_region2_def bind_assoc retype_region2_ext_def retype_region_ext_def default_ext_def) apply (rule ext) apply (intro monad_eq_split_tail ext)+ apply simp apply simp apply (simp add:gets_def get_def bind_def return_def simpler_modify_def ) apply (rule_tac x = xc in fun_cong) apply (rule_tac f = do_extended_op in arg_cong) apply (rule ext) apply simp apply simp done lemma set_cap_device_and_range_aligned: "is_aligned ptr sz \ \\_. True\ set_cap (cap.UntypedCap dev ptr sz idx) aref \\rv s. \slot. cte_wp_at (\c. cap_is_device c = dev \ up_aligned_area ptr sz \ cap_range c) slot s\" apply (subst is_aligned_neg_mask_eq[symmetric]) apply simp apply (wp set_cap_device_and_range) done lemma pac_corres: "asid_ci_map i = i' \ corres dc (einvs and ct_active and valid_aci i) (invs' and ct_active' and valid_aci' i') (perform_asid_control_invocation i) (performASIDControlInvocation i')" apply (cases i) apply (rename_tac word1 prod1 prod2 word2) apply (clarsimp simp: asid_ci_map_def) apply (simp add: perform_asid_control_invocation_def placeNewObject_def2 performASIDControlInvocation_def) apply (rule corres_name_pre) apply (clarsimp simp:valid_aci_def valid_aci'_def cte_wp_at_ctes_of cte_wp_at_caps_of_state) apply (subgoal_tac "valid_cap' (capability.UntypedCap False word1 pageBits idx) s'") prefer 2 apply (case_tac ctea) apply clarsimp apply (erule ctes_of_valid_cap') apply fastforce apply (frule valid_capAligned) apply (clarsimp simp: capAligned_def page_bits_def) apply (rule corres_guard_imp) apply (rule corres_split) prefer 2 apply (erule detype_corres) apply (simp add:pageBits_def) apply (rule corres_split[OF _ getSlotCap_corres]) apply (rule_tac F = " pcap = (cap.UntypedCap False word1 pageBits idxa)" in corres_gen_asm) apply (rule corres_split[OF _ updateFreeIndex_corres]) apply (rule corres_split) prefer 2 apply (simp add: retype_region2_ext_retype_region_ArchObject ) apply (rule corres_retype [where ty="Inl (KOArch (KOASIDPool F))", unfolded APIType_map2_def makeObjectKO_def, THEN createObjects_corres',simplified, where val = "makeObject::asidpool"]) apply simp apply (simp add: objBits_simps obj_bits_api_def arch_kobj_size_def default_arch_object_def archObjSize_def)+ apply (simp add: obj_relation_retype_def default_object_def default_arch_object_def objBits_simps archObjSize_def) apply (simp add: other_obj_relation_def asid_pool_relation_def) apply (simp add: makeObject_asidpool const_def inv_def) apply (rule range_cover_full) apply (simp add:obj_bits_api_def arch_kobj_size_def default_arch_object_def)+ apply (rule corres_split) prefer 2 apply (rule cins_corres_simple, simp, rule refl, rule refl) apply (rule_tac F="is_aligned word2 asid_low_bits" in corres_gen_asm) apply (simp add: is_aligned_mask dc_def[symmetric]) apply (rule corres_split [where P=\ and P'=\ and r'="\t t'. t = t' o ucast"]) prefer 2 apply (clarsimp simp: state_relation_def arch_state_relation_def) apply (rule corres_trivial) apply (rule corres_modify) apply (thin_tac "x \ state_relation" for x) apply (clarsimp simp: state_relation_def arch_state_relation_def o_def) apply (rule ext) apply clarsimp apply (erule_tac P = "x = asid_high_bits_of word2" in notE) apply (rule word_eqI) apply (drule_tac x1="ucast x" in bang_eq [THEN iffD1]) apply (erule_tac x=n in allE) apply (simp add: word_size nth_ucast) apply wp+ apply (strengthen safe_parent_strg[where idx = "2^pageBits"]) apply (strengthen invs_valid_objs invs_distinct invs_psp_aligned invs_mdb | simp cong:conj_cong)+ apply (wp retype_region_plain_invs[where sz = pageBits] retype_cte_wp_at[where sz = pageBits])+ apply (strengthen vp_strgs' safe_parent_strg'[where idx = "2^pageBits"]) apply (simp cong: conj_cong) apply (wp createObjects_valid_pspace' [where sz = pageBits and ty="Inl (KOArch (KOASIDPool undefined))"]) apply (simp add: makeObjectKO_def)+ apply (simp add:objBits_simps archObjSize_def range_cover_full)+ apply (clarsimp simp:valid_cap'_def) apply (wp createObject_typ_at' createObjects_orig_cte_wp_at'[where sz = pageBits]) apply (rule descendants_of'_helper) apply (wp createObjects_null_filter' [where sz = pageBits and ty="Inl (KOArch (KOASIDPool undefined))"]) apply (clarsimp simp:is_cap_simps) apply (simp add: free_index_of_def) apply (clarsimp simp: conj_comms obj_bits_api_def arch_kobj_size_def objBits_simps archObjSize_def default_arch_object_def pred_conj_def) apply (clarsimp simp: conj_comms | strengthen invs_mdb invs_valid_pspace)+ apply (simp add:region_in_kernel_window_def) apply (wp set_untyped_cap_invs_simple[where sz = pageBits] set_cap_cte_wp_at set_cap_caps_no_overlap[where sz = pageBits] set_cap_no_overlap set_cap_device_and_range_aligned[where dev = False,simplified] set_untyped_cap_caps_overlap_reserved[where sz = pageBits])+ apply (clarsimp simp: conj_comms obj_bits_api_def arch_kobj_size_def objBits_simps archObjSize_def default_arch_object_def makeObjectKO_def range_cover_full simp del: capFreeIndex_update.simps | strengthen invs_valid_pspace' invs_pspace_aligned' invs_pspace_distinct' exI[where x="makeObject :: asidpool"])+ apply (wp updateFreeIndex_forward_invs' updateFreeIndex_pspace_no_overlap' updateFreeIndex_caps_no_overlap'' updateFreeIndex_descendants_of2 updateFreeIndex_cte_wp_at updateFreeIndex_caps_overlap_reserved | simp add: descendants_of_null_filter' split del: if_split)+ apply (wp get_cap_wp)+ apply (subgoal_tac "word1 && ~~ mask pageBits = word1 \ pageBits \ word_bits \ word_size_bits \ pageBits") prefer 2 apply (clarsimp simp:pageBits_def word_bits_def is_aligned_neg_mask_eq word_size_bits_def) apply (simp only:delete_objects_rewrite) apply wp+ apply (clarsimp simp: conj_comms) apply (clarsimp simp: conj_comms ex_disj_distrib | strengthen invs_valid_pspace' invs_pspace_aligned' invs_pspace_distinct')+ apply (wp deleteObjects_invs'[where p="makePoolParent i'"] deleteObjects_cte_wp_at' deleteObjects_descendants[where p="makePoolParent i'"]) apply (clarsimp split del: if_split simp:valid_cap'_def) apply (wp hoare_vcg_ex_lift deleteObjects_caps_no_overlap''[where slot="makePoolParent i'"] deleteObject_no_overlap deleteObjects_ct_active'[where cref="makePoolParent i'"]) apply (clarsimp simp: is_simple_cap_def valid_cap'_def max_free_index_def is_cap_simps cong: conj_cong) apply (strengthen empty_descendants_range_in') apply (wp deleteObjects_descendants[where p="makePoolParent i'"] deleteObjects_cte_wp_at' deleteObjects_null_filter[where p="makePoolParent i'"]) apply (clarsimp simp:invs_mdb max_free_index_def invs_untyped_children) apply (subgoal_tac "detype_locale x y sa" for x y) prefer 2 apply (simp add:detype_locale_def) apply (fastforce simp:cte_wp_at_caps_of_state descendants_range_def2 empty_descendants_range_in invs_untyped_children) apply (intro conjI) apply (clarsimp) apply (erule(1) caps_of_state_valid) subgoal by (fastforce simp:cte_wp_at_caps_of_state descendants_range_def2 empty_descendants_range_in) apply (fold_subgoals (prefix))[2] subgoal premises prems using prems by (clarsimp simp:invs_def valid_state_def)+ apply (clarsimp simp:cte_wp_at_caps_of_state) apply (drule detype_locale.non_null_present) apply (fastforce simp:cte_wp_at_caps_of_state) apply simp apply (frule_tac ptr = "(aa,ba)" in detype_invariants [rotated 3]) apply fastforce apply simp apply (simp add: cte_wp_at_caps_of_state) apply (simp add: is_cap_simps) apply (simp add:empty_descendants_range_in descendants_range_def2) apply (frule intvl_range_conv[where bits = pageBits]) apply (clarsimp simp:pageBits_def word_bits_def) apply (clarsimp simp: invs_valid_objs cte_wp_at_caps_of_state range_cover_full invs_psp_aligned invs_distinct cap_master_cap_simps is_cap_simps is_simple_cap_def) apply (clarsimp simp: conj_comms) apply (rule conjI,clarsimp) apply (frule ex_cte_cap_protects) apply (simp add:cte_wp_at_caps_of_state) apply (simp add:empty_descendants_range_in) apply fastforce apply (rule subset_refl) apply fastforce apply clarsimp apply (rule conjI,clarsimp simp:clear_um_def) apply (simp add:detype_clear_um_independent) apply (rule conjI,erule caps_no_overlap_detype[OF descendants_range_caps_no_overlapI]) apply (clarsimp simp:is_aligned_neg_mask_eq cte_wp_at_caps_of_state) apply (simp add:empty_descendants_range_in)+ apply (rule conjI) apply clarsimp apply (drule_tac p = "(aa,ba)" in cap_refs_in_kernel_windowD2[OF caps_of_state_cteD]) apply fastforce apply (clarsimp simp: region_in_kernel_window_def valid_cap_def cap_aligned_def is_aligned_neg_mask_eq detype_def clear_um_def) apply (rule conjI, rule pspace_no_overlap_subset, rule pspace_no_overlap_detype[OF caps_of_state_valid]) apply (simp add:invs_psp_aligned invs_valid_objs is_aligned_neg_mask_eq)+ apply (clarsimp simp: detype_def clear_um_def detype_ext_def valid_sched_def valid_etcbs_def st_tcb_at_kh_def obj_at_kh_def st_tcb_at_def obj_at_def is_etcb_at_def) apply (simp add: detype_def clear_um_def) apply (drule_tac x = "cte_map (aa,ba)" in pspace_relation_cte_wp_atI[OF state_relation_pspace_relation]) apply (simp add:invs_valid_objs)+ apply clarsimp apply (drule cte_map_inj_eq) apply ((fastforce simp:cte_wp_at_caps_of_state)+)[5] apply (clarsimp simp:cte_wp_at_caps_of_state invs_valid_pspace' conj_comms cte_wp_at_ctes_of valid_cap_simps') apply (strengthen refl) apply clarsimp apply (frule empty_descendants_range_in') apply (intro conjI, simp_all add: is_simple_cap'_def isCap_simps descendants_range'_def2 null_filter_descendants_of'[OF null_filter_simp'] capAligned_def asid_low_bits_def) apply (erule descendants_range_caps_no_overlapI') apply (fastforce simp:cte_wp_at_ctes_of is_aligned_neg_mask_eq) apply (simp add:empty_descendants_range_in') apply (simp add:word_bits_def pageBits_def) apply (rule is_aligned_weaken) apply (rule is_aligned_shiftl_self[unfolded shiftl_t2n,where p = 1,simplified]) apply (simp add:pageBits_def) apply clarsimp apply (drule(1) cte_cap_in_untyped_range) apply (fastforce simp:cte_wp_at_ctes_of) apply assumption+ apply fastforce apply simp apply clarsimp apply (drule (1) cte_cap_in_untyped_range) apply (fastforce simp add: cte_wp_at_ctes_of) apply assumption+ apply (clarsimp simp: invs'_def valid_state'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of) apply fastforce apply simp done definition vcpu_invocation_map :: "vcpu_invocation \ vcpuinvocation" where "vcpu_invocation_map vcpui \ case vcpui of vcpu_invocation.VCPUSetTCB v t \ VCPUSetTCB v t | vcpu_invocation.VCPUInjectIRQ obj n vreg \ VCPUInjectIRQ obj n vreg | vcpu_invocation.VCPUReadRegister obj vreg \ VCPUReadRegister obj vreg | vcpu_invocation.VCPUWriteRegister obj vreg word \ VCPUWriteRegister obj vreg word " definition archinv_relation :: "arch_invocation \ Arch.invocation \ bool" where "archinv_relation ai ai' \ case ai of arch_invocation.InvokePageTable pti \ \pti'. ai' = InvokePageTable pti' \ page_table_invocation_map pti pti' | arch_invocation.InvokePageDirectory pdi \ \pdi'. ai' = InvokePageDirectory pdi' \ page_directory_invocation_map pdi pdi' | arch_invocation.InvokePage pgi \ \pgi'. ai' = InvokePage pgi' \ page_invocation_map pgi pgi' | arch_invocation.InvokeASIDControl aci \ \aci'. ai' = InvokeASIDControl aci' \ aci' = asid_ci_map aci | arch_invocation.InvokeASIDPool ap \ \ap'. ai' = InvokeASIDPool ap' \ ap' = asid_pool_invocation_map ap | arch_invocation.InvokeVCPU vcpui \ \vcpui'. ai' = InvokeVCPU vcpui' \ vcpui' = vcpu_invocation_map vcpui" definition valid_arch_inv' :: "Arch.invocation \ kernel_state \ bool" where "valid_arch_inv' ai \ case ai of InvokePageTable pti \ valid_pti' pti | InvokePageDirectory pdi \ \ | InvokePage pgi \ valid_page_inv' pgi | InvokeASIDControl aci \ valid_aci' aci | InvokeASIDPool ap \ valid_apinv' ap | InvokeVCPU v \ valid_vcpuinv' v" lemma mask_vmrights_corres: "maskVMRights (vmrights_map R) (rightsFromWord d) = vmrights_map (mask_vm_rights R (data_to_rights d))" by (clarsimp simp: rightsFromWord_def data_to_rights_def vmrights_map_def Let_def maskVMRights_def mask_vm_rights_def nth_ucast validate_vm_rights_def vm_read_write_def vm_kernel_only_def vm_read_only_def split: bool.splits) definition "parity_mask attrs \ case attrs of VMAttributes c p xn \ VMAttributes c False xn" lemma vm_attributes_corres: "vmattributes_map (attribs_from_word w) = attribsFromWord w" by (clarsimp simp: attribsFromWord_def attribs_from_word_def Let_def vmattributes_map_def parity_mask_def) lemma check_vp_corres: "corres (ser \ dc) \ \ (check_vp_alignment sz w) (checkVPAlignment sz w)" apply (simp add: check_vp_alignment_def checkVPAlignment_def) apply (cases sz, simp_all add: corres_returnOk unlessE_whenE is_aligned_mask) apply ((rule corres_guard_imp, rule corres_whenE, rule refl, auto)[1])+ done lemma checkVP_wpR [wp]: "\\s. vmsz_aligned' w sz \ P () s\ checkVPAlignment sz w \P\, -" apply (simp add: checkVPAlignment_def unlessE_whenE cong: vmpage_size.case_cong) apply (rule hoare_pre) apply (wp hoare_whenE_wp|wpc)+ apply (simp add: is_aligned_mask vmsz_aligned'_def) done lemma checkVP_inv: "\P\ checkVPAlignment sz w \\_. P\" apply (simp add: checkVPAlignment_def unlessE_whenE cong: vmpage_size.case_cong) apply (rule hoare_pre) apply (wp hoare_whenE_wp|wpc)+ apply simp done lemma asidHighBits [simp]: "asidHighBits = asid_high_bits" by (simp add: asidHighBits_def asid_high_bits_def) declare word_unat_power [symmetric, simp del] lemma ARMMMU_improve_cases: "(if isPageDirectoryCap cap then P else if isPageTableCap cap then Q else if isPageCap cap then R else if isASIDControlCap cap then S else if isASIDPoolCap cap then T else if isVCPUCap cap then U else undefined) = (if isPageDirectoryCap cap then P else if isPageTableCap cap then Q else if isPageCap cap then R else if isASIDControlCap cap then S else if isASIDPoolCap cap then T else U)" by (cases cap, simp_all add: isCap_simps) (* not sure if this is useful as is *) lemma decodeVCPUInjectIRQ_inv[wp]: "\P\ decodeVCPUInjectIRQ a b \\_. P\" by (wpsimp simp: decodeVCPUInjectIRQ_def Let_def wp: hoare_whenE_wp getVCPU_wp | rule conjI)+ crunch inv [wp]: "ARM_HYP_H.decodeInvocation" "P" (wp: crunch_wps mapME_x_inv_wp getASID_wp simp: forME_x_def crunch_simps ARMMMU_improve_cases ignore: forME_x getObject) (* FIXME: Move *) lemma case_option_corres: assumes nonec: "corres r Pn Qn (nc >>= f) (nc' >>= g)" and somec: "\v'. corres r (Ps v') (Qs v') (sc v' >>= f) (sc' v' >>= g)" shows "corres r (case_option Pn Ps v) (case_option Qn Qs v) (case_option nc sc v >>= f) (case_option nc' sc' v >>= g)" apply (cases v) apply simp apply (rule nonec) apply simp apply (rule somec) done lemma case_option_corresE: assumes nonec: "corres r Pn Qn (nc >>=E f) (nc' >>=E g)" and somec: "\v'. corres r (Ps v') (Qs v') (sc v' >>=E f) (sc' v' >>=E g)" shows "corres r (case_option Pn Ps v) (case_option Qn Qs v) (case_option nc sc v >>=E f) (case_option nc' sc' v >>=E g)" apply (cases v) apply simp apply (rule nonec) apply simp apply (rule somec) done lemma cap_relation_Untyped_eq: "cap_relation c (UntypedCap d p sz f) = (c = cap.UntypedCap d p sz f)" by (cases c) auto lemma vmsz_aligned_less_kernel_base_eq: "\ptr + 2 ^ pageBitsForSize vmpage_size - 1 < kernel_base;vmsz_aligned ptr vmpage_size\ \ ptr < kernel_base" apply (simp add:vmsz_aligned_def) apply (rule ccontr) apply (simp add:not_less) apply (drule(1) less_le_trans) apply (drule is_aligned_no_overflow) apply (simp add:not_less[symmetric]) done declare check_vp_alignment_inv[wp del] lemma select_ext_fa: "free_asid_select asid_tbl \ S \ ((select_ext (\_. free_asid_select asid_tbl) S) :: (7 word) det_ext_monad) = return (free_asid_select asid_tbl)" by (simp add: select_ext_def get_def gets_def bind_def assert_def return_def fail_def) lemma select_ext_fap: "free_asid_pool_select p b \ S \ ((select_ext (\_. free_asid_pool_select p b) S) :: (10 word) det_ext_monad) = return (free_asid_pool_select p b)" by (simp add: select_ext_def get_def gets_def bind_def assert_def return_def) lemma lookup_pt_slot_no_fail_corres[simp]: "lookupPTSlotFromPT pt vptr = (do stateAssert (page_table_at' pt) []; return (lookup_pt_slot_no_fail pt vptr) od)" by (simp add: lookup_pt_slot_no_fail_def lookupPTSlotFromPT_def mask_def checkPTAt_def) lemma page_base_corres[simp]: "pageBase vaddr vmsize = page_base vaddr vmsize" by (clarsimp simp: pageBase_def page_base_def) lemma flush_type_map: "ARM_HYP_H.isPageFlushLabel (invocation_type (mi_label mi)) \ ARM_HYP_H.isPDFlushLabel (invocation_type (mi_label mi)) \ labelToFlushType (mi_label mi) = flush_type_map (label_to_flush_type (invocation_type (mi_label mi)))" by (clarsimp simp: label_to_flush_type_def labelToFlushType_def flush_type_map_def ARM_HYP_H.isPageFlushLabel_def ARM_HYP_H.isPDFlushLabel_def split: ARM_A.flush_type.splits invocation_label.splits arch_invocation_label.splits) lemma resolve_vaddr_corres: "\ is_aligned pd pd_bits; vaddr < kernel_base \ \ corres (op =) (pspace_aligned and valid_vspace_objs and page_directory_at pd and (\\ (lookup_pd_slot pd vaddr && ~~ mask pd_bits))) (\s. pspace_aligned' s \ pspace_distinct' s \ vs_valid_duplicates' (ksPSpace s)) (resolve_vaddr pd vaddr) (resolveVAddr pd vaddr)" apply (clarsimp simp: resolve_vaddr_def resolveVAddr_def) apply (rule stronger_corres_guard_imp) apply (rule_tac R="\rv s. valid_pde rv s \ pspace_aligned s" and R'="\_ s. pspace_distinct' s \ pspace_aligned' s \ vs_valid_duplicates' (ksPSpace s)" in corres_split[OF _ get_master_pde_corres]) apply (case_tac rv; clarsimp simp: master_pde_relation_def pde_relation'_def isSuperSection_def' page_base_def split: if_split_asm) apply (rule corres_stateAssert_assume_stronger) apply (rule stronger_corres_guard_imp) apply (rule corres_split[OF _ get_master_pte_corres]) apply (rule corres_trivial) apply (case_tac rv; clarsimp simp: master_pte_relation_def pte_relation'_def isLargePage_def' page_base_def split: if_split_asm) apply (wp get_master_pte_inv)+ apply (clarsimp simp: page_table_pte_at_lookupI) apply (clarsimp simp: page_table_pte_at_lookupI' page_table_at_state_relation) apply clarsimp apply (erule(3) page_table_at_state_relation) apply wpsimp+ apply (clarsimp simp: page_directory_pde_at_lookupI) apply (clarsimp simp: page_directory_pde_at_lookupI' page_directory_at_state_relation) done lemma dec_arch_inv_page_flush_corres: "ARM_HYP_H.isPageFlushLabel (invocation_type (mi_label mi)) \ corres (ser \ archinv_relation) (invs and valid_cap (cap.ArchObjectCap (arch_cap.PageCap d word seta vmpage_size option)) and cte_wp_at (is_arch_diminished (cap.ArchObjectCap (arch_cap.PageCap d word seta vmpage_size option))) slot and (\s. \x\set excaps. s \ fst x \ cte_wp_at (\_. True) (snd x) s)) (invs' and valid_cap' (capability.ArchObjectCap (arch_capability.PageCap d word (vmrights_map seta) vmpage_size option)) and (\s. \x\set excaps'. valid_cap' (fst x) s \ cte_wp_at' (\_. True) (snd x) s) and (\s. vs_valid_duplicates' (ksPSpace s))) (if Suc 0 < length args then let start = args ! 0; end = args ! 1 in doE (asid, vaddr) \ case option of None \ throwError ExceptionTypes_A.syscall_error.IllegalOperation | Some x \ returnOk x; pd \ lookup_error_on_failure False $ find_pd_for_asid asid; whenE (end \ start) $ throwError $ ExceptionTypes_A.syscall_error.InvalidArgument 1; page_size \ returnOk $ 1 << pageBitsForSize vmpage_size; whenE (page_size \ start \ page_size < end) $ throwError $ ExceptionTypes_A.syscall_error.InvalidArgument 0; returnOk $ arch_invocation.InvokePage $ ARM_A.page_invocation.PageFlush (* Must use word in hyp mode. *) (label_to_flush_type (invocation_type (mi_label mi))) (start + word) (end + word - 1) (addrFromPPtr word + start) pd asid odE else throwError ExceptionTypes_A.syscall_error.TruncatedMessage) (decodeARMPageFlush (mi_label mi) args (arch_capability.PageCap d word (vmrights_map seta) vmpage_size option))" apply (simp add: decodeARMPageFlush_def split del: if_split) apply (cases args, simp) apply (rename_tac a0 as) apply (case_tac as, simp) apply (rename_tac a1 as') apply (cases option, simp) apply (case_tac a) apply (rename_tac asid vref) apply clarsimp apply (rule corres_guard_imp) apply (rule corres_splitEE) prefer 2 apply (rule corres_lookup_error) apply (rule find_pd_for_asid_corres[OF refl]) apply (rule whenE_throwError_corres, simp) apply simp apply (rule whenE_throwError_corres, simp) apply simp apply (rule corres_trivial) apply (rule corres_returnOk) apply (clarsimp simp: archinv_relation_def page_invocation_map_def flush_type_map_def) apply (clarsimp simp: archinv_relation_def page_invocation_map_def label_to_flush_type_def labelToFlushType_def flush_type_map_def ARM_HYP_H.isPageFlushLabel_def split: flush_type.splits invocation_label.splits arch_invocation_label.splits) apply wp+ apply (fastforce simp: valid_cap_def mask_def) apply auto done lemma lookup_pd_slot_mask_6_gumpf: "is_aligned pd pd_bits \ lookup_pd_slot pd vaddr && ~~ mask 7 = lookup_pd_slot pd (vaddr && ~~ mask (pageBitsForSize ARMSuperSection))" apply (clarsimp simp: lookup_pd_slot_def vspace_bits_defs is_aligned_mask shiftr_shiftl1) apply (simp add: shiftr_over_and_dist) apply (simp add: mask_def word_bw_assocs) apply word_bitwise apply (clarsimp simp: xor3_simps carry_simps) done lemma neg_mask_combine: "~~ mask a && ~~ mask b = ~~ mask (max a b)" by (auto simp: word_ops_nth_size word_size intro!: word_eqI) lemma vs_lookup_pages1I: "\ ko_at ko p s; (r, p') \ vs_refs_pages ko; rs' = r # rs \ \ ((rs,p) \1 (rs',p')) s" by (fastforce simp add: vs_lookup_pages1_def) lemma vs_refs_pages_ptI: "pt x = pte \ pte_ref_pages pte = Some r' \ (VSRef (ucast x) (Some APageTable), r') \ vs_refs_pages (ArchObj (PageTable pt))" apply (simp add: vs_refs_pages_def) apply (rule image_eqI[rotated], rule graph_ofI[where x=x], simp) apply simp done lemmas vs_refs_pages_pt_largeI = vs_refs_pages_ptI[where pte="ARM_A.pte.LargePagePTE x y z" for x y z, unfolded pte_ref_pages_def, simplified, OF _ refl] lemmas vs_refs_pages_pt_smallI = vs_refs_pages_ptI[where pte="ARM_A.pte.SmallPagePTE x y z" for x y z, unfolded pte_ref_pages_def, simplified, OF _ refl] lemma vs_refs_pages_pdI: "pd x = pde \ pde_ref_pages pde = Some r' \ (VSRef (ucast x) (Some APageDirectory), r') \ vs_refs_pages (ArchObj (PageDirectory pd))" apply (simp add: vs_refs_pages_def) apply (rule image_eqI[rotated], rule graph_ofI[where x=x], simp) apply simp done lemmas vs_refs_pages_pd_sectionI = vs_refs_pages_pdI[where pde="ARM_A.pde.SectionPDE x y z" for x y z, unfolded pde_ref_pages_def, simplified, OF _ refl] lemmas vs_refs_pages_pd_supersectionI = vs_refs_pages_pdI[where pde="ARM_A.pde.SuperSectionPDE x y z" for x y z, unfolded pde_ref_pages_def, simplified, OF _ refl] lemma get_master_pde_sp: "\ P \ get_master_pde pd_slot \ \pde s. P s \ (\pd pd_slot'. ko_at (ArchObj (PageDirectory pd)) (pd_slot && ~~ mask pd_bits) s \ pd_slot' && ~~ mask pd_bits = pd_slot && ~~ mask pd_bits (* \ ((ucast (pd_slot' && mask pd_bits >> 2) \ kernel_mapping_slots) \ (ucast (pd_slot && mask pd_bits >> 2) \ kernel_mapping_slots))*) \ pd (ucast (pd_slot' && mask pd_bits >> 3)) = pde) \" apply (simp add: get_master_pde_def) apply (wp get_pde_wp | wpc)+ apply (clarsimp simp: obj_at_def) apply (safe, simp_all add: exI[where x=pd_slot] vspace_bits_defs) apply (cut_tac max.absorb2[where a=6 and b=pd_bits]) apply (clarsimp simp: word_bw_assocs neg_mask_combine) apply (rule_tac x="pd_slot && ~~ mask 7" in exI) apply (clarsimp simp add: word_bw_assocs neg_mask_combine pd_bits_def)+ done lemma get_master_pte_wp: "\ \s. (\pt pt_slot'. ko_at (ArchObj (PageTable pt)) (pt_slot && ~~ mask pt_bits) s \ pt_slot' && ~~ mask pt_bits = pt_slot && ~~ mask pt_bits \ Q (pt (ucast (pt_slot' && mask pt_bits >> pte_bits))) s) \ get_master_pte pt_slot \ Q \" apply (simp add: get_master_pte_def) apply (wp get_pte_wp | wpc)+ apply clarsimp apply (drule spec, drule_tac x="pt_slot && ~~ mask 7" in spec) apply (cut_tac max.absorb2[where a=7 and b=pt_bits]) apply (simp add: word_bw_assocs neg_mask_combine obj_at_def) apply fastforce apply (simp add: pt_bits_def pageBits_def) done lemma vaddr_segment_nonsense5: "is_aligned (p :: word32) 12 \ p + ((vaddr >> 12) && mask 9 << 3) && ~~ mask pt_bits = p" by (frule vaddr_segment_nonsense3) (simp add: mask_def) lemma resolve_vaddr_valid_mapping_size: "\ valid_vs_lookup and pspace_aligned and valid_vspace_objs and page_directory_at pd and (\\ (lookup_pd_slot pd vaddr && ~~ mask pd_bits)) and valid_objs and K (vaddr < kernel_base) \ resolve_vaddr pd vaddr \ \rv s. case rv of None \ True | Some (a, b) \ \p cap. caps_of_state s p = Some cap \ (case cap of cap.ArchObjectCap c \ is_page_cap c | _ \ False) \ cap_bits cap = pageBitsForSize a \ " apply (simp add: resolve_vaddr_def) apply (rule hoare_seq_ext[OF _ get_master_pde_sp]) apply (rule hoare_pre) apply (wp get_master_pte_wp | wpc | simp add: lookup_pt_slot_no_fail_def)+ apply (clarsimp simp: obj_at_def) apply (frule(1) pspace_alignedD, simp) apply (drule_tac y=pd_bits in is_aligned_weaken, simp add: vspace_bits_defs) apply (frule valid_vspace_objsD, simp add: obj_at_def lookup_pd_slot_eq, simp) apply (simp add: lookup_pd_slot_eq) apply (drule_tac x="ucast (pd_slot' && mask pd_bits >> 3)" in spec) apply (rule conjI) apply clarsimp apply (drule vs_lookup_step) apply (rule vs_lookup1I, simp add: obj_at_def) apply (erule vs_refs_pdI2) apply simp apply (drule sym[where s=pd]) apply (simp add: lookup_pd_slot_eq) apply (frule(1) is_aligned_pt) apply (frule is_aligned_weaken[where x=pt_bits and y=10]) apply (simp add: pt_bits_def pageBits_def pte_bits_def) apply (simp add: vspace_bits_defs) apply (frule_tac vaddr=vaddr in vaddr_segment_nonsense5, simp add: vspace_bits_defs) apply (frule_tac valid_vspace_objsD, simp add: obj_at_def, simp) apply (drule vs_lookup_pages_vs_lookupI) apply (rule conjI) apply clarsimp apply (drule_tac x="ucast (pt_slot' && mask pt_bits >> 3)" in spec) apply (drule vs_lookup_pages_step) apply (rule vs_lookup_pages1I, simp add: obj_at_def) apply (erule vs_refs_pages_pt_largeI) apply simp apply (drule(1) valid_vs_lookupD) apply simp apply (erule exEI)+ apply (clarsimp simp: vs_cap_ref_def vspace_bits_defs split: cap.split_asm arch_cap.split_asm option.split_asm vmpage_size.split_asm) apply (frule(1) caps_of_state_valid_cap) apply (clarsimp simp: valid_cap_def obj_at_def data_at_def a_type_simps split: if_split_asm)+ apply (drule_tac x="ucast (pt_slot' && mask pt_bits >> 3)" in spec) apply (drule vs_lookup_pages_step) apply (rule vs_lookup_pages1I, simp add: obj_at_def) apply (erule vs_refs_pages_pt_smallI) apply simp apply (drule(1) valid_vs_lookupD) apply simp apply (erule exEI)+ apply (clarsimp simp: vs_cap_ref_def vspace_bits_defs split: cap.split_asm arch_cap.split_asm option.split_asm vmpage_size.split_asm) apply (frule(1) caps_of_state_valid_cap) apply (clarsimp simp: valid_cap_def obj_at_def data_at_def a_type_simps split: if_split_asm)+ apply (drule vs_lookup_pages_vs_lookupI) apply (rule conjI) apply clarsimp apply (drule vs_lookup_pages_step) apply (rule vs_lookup_pages1I, simp add: obj_at_def) apply (erule vs_refs_pages_pd_sectionI) apply simp apply (drule(1) valid_vs_lookupD) apply simp apply (erule exEI)+ apply (clarsimp simp: vs_cap_ref_def split: cap.split_asm arch_cap.split_asm option.split_asm vmpage_size.split_asm) apply (frule(1) caps_of_state_valid_cap) apply (clarsimp simp: valid_cap_def obj_at_def data_at_def a_type_simps split: if_split_asm) apply (frule(1) caps_of_state_valid_cap) apply (clarsimp simp: valid_cap_def obj_at_def data_at_def a_type_simps split: if_split_asm) apply clarsimp apply (drule vs_lookup_pages_step) apply (rule vs_lookup_pages1I, simp add: obj_at_def) apply (erule vs_refs_pages_pd_supersectionI) apply simp apply (drule(1) valid_vs_lookupD) apply simp apply (erule exEI)+ apply (clarsimp simp: vs_cap_ref_def split: cap.split_asm arch_cap.split_asm option.split_asm vmpage_size.split_asm) apply (frule(1) caps_of_state_valid_cap) apply (clarsimp simp: valid_cap_def obj_at_def data_at_def a_type_simps split: if_split_asm) apply (frule(1) caps_of_state_valid_cap) apply (clarsimp simp: valid_cap_def obj_at_def data_at_def a_type_simps split: if_split_asm) done lemma list_all2_Cons: "list_all2 f (x#xs) b \ \y ys. b = y # ys" by (induct b; simp) lemma corres_gets_numlistregsE[corres]: "corres (r \ op =) \ \ (liftE (gets (arm_gicvcpu_numlistregs \ arch_state))) (liftE (gets (armKSGICVCPUNumListRegs \ ksArchState)))" by (clarsimp simp: state_relation_def arch_state_relation_def) lemma corres_gets_numlistregs [corres]: "corres (op =) \ \ (gets (arm_gicvcpu_numlistregs \ arch_state)) (gets (armKSGICVCPUNumListRegs \ ksArchState))" by (clarsimp simp: state_relation_def arch_state_relation_def) lemma corres_whenE_str: "\G \ G' \ corres_underlying sr nf nf' (r \ dc) P P' a c\ \ corres_underlying sr nf nf' (r \ dc) (K(G = G') and (\x. G \ P x)) (\x. G' \ P' x) (whenE G a) (whenE G' c)" apply (simp add: corres_underlying_def) apply (cases "G = G'"; cases G; simp add: whenE_def) by (clarsimp simp: whenE_def returnOk_def return_def) theorem corres_throwError_ser[corres]: "corres (ser \ r) (\_. b = syscall_error_map a) (\_. True) (throwError a) (throwError b)" by simp lemmas corres_liftE_rel_sumI = corres_liftE_rel_sum[THEN iffD2] lemmas corres_liftMI = corres_liftM_simp[THEN iffD2] lemmas corres_liftM2I = corres_liftM2_simp[THEN iffD2] lemma get_vcpu_LR_corres[corres]: "corres (r \ (\vcpu lr. vgic_lr (vcpu_vgic vcpu) = lr)) (vcpu_at v) (vcpu_at' v) (liftE (get_vcpu v)) (liftE (liftM (vgicLR \ vcpuVGIC) (getObject v)))" apply simp apply (rule corres_rel_imp, rule corres_get_vcpu) apply (rename_tac vcpu', case_tac vcpu') apply (clarsimp simp: vcpu_relation_def vgic_map_def) done lemma vgi_mask[simp]: "vgicIRQMask = vgic_irq_mask" "vgicIRQActive = vgic_irq_active" by (auto simp: vgicIRQMask_def vgic_irq_mask_def vgic_irq_active_def vgicIRQActive_def) (* FIXME: move *) lemma corres_splitE: "\ corres_underlying sr nf nf' (f \ r') P P' a c; \rv rv'. r' rv rv' \ corres_underlying sr nf nf' (f \ r) (R rv) (R' rv') (b rv) (d rv'); \Q\ a \R\, \\_ _. True\; \Q'\ c \R'\, \\_ _. True\\ \ corres_underlying sr nf nf' (f \ r) (P and Q) (P' and Q') (a >>=E b) (c >>=E d)" by (rule corres_splitEE) lemma dec_vcpu_inv_corres: notes if_split [split del] shows "\acap_relation arch_cap arch_cap'; list_all2 cap_relation (map fst excaps) (map fst excaps'); list_all2 (\s s'. s' = cte_map s) (map snd excaps) (map snd excaps')\ \ corres (ser \ archinv_relation) (invs and valid_cap (cap.ArchObjectCap arch_cap) and (\s. \x\set excaps. s \ fst x \ cte_wp_at (\_. True) (snd x) s)) (invs' and valid_cap' (capability.ArchObjectCap arch_cap') and (\s. \x\set excaps'. valid_cap' (fst x) s \ cte_wp_at' (\_. True) (snd x) s) and (\s. vs_valid_duplicates' (ksPSpace s))) (decode_vcpu_invocation label args arch_cap excaps) (decodeARMVCPUInvocation label args cptr' cte arch_cap' excaps')" apply (simp add: decode_vcpu_invocation_def decodeARMVCPUInvocation_def) apply (cases arch_cap; cases "invocation_type label"; simp add: isVCPUCap_def) apply (rename_tac vcpui) apply (case_tac vcpui; simp split del: if_split) (* set_tcb *) apply (simp add: decode_vcpu_set_tcb_def decodeVCPUSetTCB_def Let_def isVCPUCap_def) apply (cases excaps; simp add: null_def) apply (frule list_all2_Cons) apply clarsimp apply (case_tac a; clarsimp simp add: cap_relation_def) apply (corres corres: corres_returnOkTT) apply (clarsimp simp: archinv_relation_def vcpu_invocation_map_def) (* inject_irq *) apply (simp add: decode_vcpu_inject_irq_def decodeVCPUInjectIRQ_def isVCPUCap_def) apply (cases args; clarsimp) apply (case_tac list; clarsimp simp add: rangeCheck_def range_check_def unlessE_whenE) apply (clarsimp simp: shiftL_nat whenE_bindE_throwError_to_if) apply (corressimp wp: get_vcpu_wp) apply (clarsimp simp: archinv_relation_def vcpu_invocation_map_def ucast_id valid_cap'_def valid_cap_def make_virq_def makeVIRQ_def split:if_split) (* read register *) apply (clarsimp simp: decode_vcpu_read_register_def decodeVCPUReadReg_def) apply (cases args; clarsimp simp: isCap_simps whenE_def split: if_split) apply (rule corres_returnOk) apply (simp add: archinv_relation_def vcpu_invocation_map_def) (* write register *) apply (clarsimp simp: decode_vcpu_write_register_def decodeVCPUWriteReg_def) apply (cases args; clarsimp simp: isCap_simps) apply (case_tac list; clarsimp) apply (clarsimp simp: whenE_def split: if_split) apply (rule corres_returnOk) apply (simp add: archinv_relation_def vcpu_invocation_map_def ucast_id) done lemma dec_arch_inv_corres: notes check_vp_inv[wp del] check_vp_wpR[wp] [[goals_limit = 1]] (* FIXME: check_vp_inv shadowed check_vp_wpR. Instead, check_vp_wpR should probably be generalised to replace check_vp_inv. *) notes valid_arch_imp_valid_vspace_objs[simp add] notes valid_arch_objs_lift[simp add] shows "\ acap_relation arch_cap arch_cap'; list_all2 cap_relation (map fst excaps) (map fst excaps'); list_all2 (\s s'. s' = cte_map s) (map snd excaps) (map snd excaps') \ \ corres (ser \ archinv_relation) (invs and valid_cap (cap.ArchObjectCap arch_cap) and cte_wp_at (is_arch_diminished (cap.ArchObjectCap arch_cap)) slot and (\s. \x\set excaps. s \ fst x \ cte_at (snd x) s)) (invs' and valid_cap' (capability.ArchObjectCap arch_cap') and (\s. \x\set excaps'. s \' fst x \ cte_at' (snd x) s) and (\s. vs_valid_duplicates' (ksPSpace s))) (arch_decode_invocation (mi_label mi) args (to_bl cptr') slot arch_cap excaps) (Arch.decodeInvocation (mi_label mi) args cptr' (cte_map slot) arch_cap' excaps')" unfolding arch_decode_invocation_def ARM_HYP_H.decodeInvocation_def decodeARMMMUInvocation_def decode_mmu_invocation_def apply (cases arch_cap) apply (simp add: isCap_simps Let_def split del: if_split) apply (cases "invocation_type (mi_label mi) \ ArchInvocationLabel ARMASIDPoolAssign") apply (clarsimp split: invocation_label.split arch_invocation_label.split) apply (rename_tac word1 word2) apply (cases "excaps", simp) apply (cases "excaps'", simp) apply clarsimp apply (case_tac a, simp_all)[1] apply (rename_tac arch_capa) apply (case_tac arch_capa, simp_all)[1] apply (rename_tac word3 option) apply (case_tac option, simp_all)[1] apply (rule corres_guard_imp) apply (rule corres_splitEE) prefer 2 apply (rule corres_trivial [where r="ser \ (\p p'. p = p' o ucast)"]) apply (clarsimp simp: state_relation_def arch_state_relation_def) apply (rule whenE_throwError_corres, simp) apply (simp add: lookup_failure_map_def) apply simp apply (rule_tac P="\s. asid_table (asid_high_bits_of word2) = Some word1 \ asid_pool_at word1 s" and P'="pspace_aligned' and pspace_distinct'" in corres_inst) apply (simp add: liftME_return) apply (rule whenE_throwError_corres_initial, simp) apply auto[1] apply (rule corres_guard_imp) apply (rule corres_splitEE) prefer 2 apply simp apply (rule get_asid_pool_corres_inv') apply (simp add: bindE_assoc) apply (rule corres_splitEE) prefer 2 apply (rule corres_whenE) apply (subst conj_assoc [symmetric]) apply (subst assocs_empty_dom_comp [symmetric]) apply (rule dom_ucast_eq) apply (rule corres_trivial) apply simp apply simp apply (rule_tac F="- dom pool \ {x. x \ 2 ^ asid_low_bits - 1 \ ucast x + word2 \ 0} \ {}" in corres_gen_asm) apply (frule dom_hd_assocsD) apply (simp add: select_ext_fap[simplified free_asid_pool_select_def] free_asid_pool_select_def) apply (simp add: returnOk_liftE[symmetric]) apply (rule corres_returnOk) apply (simp add: archinv_relation_def asid_pool_invocation_map_def) apply (wp hoare_whenE_wp) apply (clarsimp simp: ucast_fst_hd_assocs) apply (wp hoareE_TrueI hoare_whenE_wp getASID_wp | simp)+ apply ((clarsimp simp: p2_low_bits_max | rule TrueI impI)+)[2] apply (wp hoare_whenE_wp getASID_wp)+ apply (clarsimp simp: valid_cap_def) apply auto[1] apply (simp add: isCap_simps split del: if_split) apply (cases "invocation_type (mi_label mi) \ ArchInvocationLabel ARMASIDControlMakePool") apply (simp split: invocation_label.split arch_invocation_label.split) apply (subgoal_tac "length excaps' = length excaps") prefer 2 apply (simp add: list_all2_iff) apply (cases args, simp) apply (rename_tac a0 as) apply (case_tac as, simp) apply (rename_tac a1 as') apply (cases excaps, simp) apply (rename_tac excap0 exs) apply (case_tac exs) apply (auto split: list.split)[1] apply (rename_tac excap1 exss) apply (case_tac excap0) apply (rename_tac c0 slot0) apply (case_tac excap1) apply (rename_tac c1 slot1) apply (clarsimp simp: Let_def split del: if_split) apply (cases excaps', simp) apply (case_tac list, simp) apply (rename_tac c0' exs' c1' exss') apply (clarsimp split del: if_split) apply (rule corres_guard_imp) apply (rule corres_splitEE [where r'="\p p'. p = p' o ucast"]) prefer 2 apply (rule corres_trivial) apply (clarsimp simp: state_relation_def arch_state_relation_def) apply (simp only: bindE_assoc) apply (rule corres_splitEE) prefer 2 apply (rule corres_whenE) apply (subst assocs_empty_dom_comp [symmetric]) apply (simp add: o_def) apply (rule dom_ucast_eq_7) apply (rule corres_trivial, simp, simp) apply (simp split del: if_split) apply (rule_tac F="- dom (asidTable \ ucast) \ {x. x \ 2 ^ asid_high_bits - 1} \ {}" in corres_gen_asm) apply (drule dom_hd_assocsD) apply (simp add: select_ext_fa[simplified free_asid_select_def] free_asid_select_def o_def returnOk_liftE[symmetric] split del: if_split) apply (thin_tac "fst a \ b \ P" for a b P) apply (case_tac "isUntypedCap a \ capBlockSize a = objBits (makeObject::asidpool) \ \ capIsDevice a") prefer 2 apply (rule corres_guard_imp) apply (rule corres_trivial) apply (case_tac ad, simp_all add: isCap_simps split del: if_split)[1] apply (case_tac x21, simp_all split del: if_split)[1] apply (clarsimp simp: objBits_simps archObjSize_def split del: if_split) apply clarsimp apply (rule TrueI)+ apply (clarsimp simp: isCap_simps cap_relation_Untyped_eq lookupTargetSlot_def objBits_simps archObjSize_def bindE_assoc split_def) apply (rule corres_splitEE) prefer 2 apply (fold ser_def) apply (rule ensure_no_children_corres, rule refl) apply (rule corres_splitEE) prefer 2 apply (erule lsfc_corres, rule refl) apply (rule corres_splitEE) prefer 2 apply (rule ensure_empty_corres) apply clarsimp apply (rule corres_returnOk[where P="\"]) apply (clarsimp simp add: archinv_relation_def asid_ci_map_def split_def) apply (clarsimp simp add: ucast_assocs[unfolded o_def] split_def filter_map asid_high_bits_def) apply (simp add: ord_le_eq_trans [OF word_n1_ge]) apply wp+ apply (simp add: o_def validE_R_def) apply (wp hoare_whenE_wp)+ apply fastforce apply clarsimp apply (simp add: null_def split_def asid_high_bits_def word_le_make_less) apply (subst hd_map, assumption) (* need abstract guard to show list nonempty *) apply (simp add: word_le_make_less) apply (subst ucast_ucast_len) apply (drule hd_in_set) apply simp apply fastforce apply (rename_tac word cap_rights vmpage_size option) apply (simp add: isCap_simps split del: if_split) apply (cases "invocation_type (mi_label mi) = ArchInvocationLabel ARMPageMap") apply (case_tac "\(2 < length args \ excaps \ [])") apply (auto simp: Let_def split: list.split)[1] apply (simp add: Let_def neq_Nil_conv) apply (elim exE conjE) apply (simp split: list.split, intro conjI impI allI, simp_all)[1] apply (rule corres_guard_imp) apply (rule whenE_throwError_corres) apply simp apply simp apply (simp split: cap.split, intro conjI impI allI, simp_all)[1] apply (rename_tac arch_capa) apply (case_tac arch_capa, simp_all)[1] apply (rename_tac wd opt) apply (case_tac opt, simp_all)[1] apply (rename_tac optv) apply (rule corres_splitEE) prefer 2 apply (rule corres_lookup_error) apply (rule_tac P="valid_arch_state and valid_arch_objs and pspace_aligned and equal_kernel_mappings and valid_cap (cap.ArchObjectCap (arch_cap.PageDirectoryCap wd (Some optv)))" in corres_guard_imp) apply (rule find_pd_for_asid_corres[OF refl]) apply (clarsimp simp: valid_cap_def) apply (simp add: mask_def) apply assumption apply (rule whenE_throwError_corres, simp, simp) apply (rule_tac R="\_ s. valid_arch_objs s \ pspace_aligned s \ hd args + 2 ^ pageBitsForSize vmpage_size - 1 < kernel_base \ valid_arch_state s \ equal_kernel_mappings s \ s \ (fst (hd excaps)) \ (\\ (lookup_pd_slot (obj_ref_of (fst (hd excaps))) (hd args) && ~~ mask pd_bits)) s \ (\\ rv') s \ page_directory_at rv' s" and R'="\_ s. s \' (fst (hd excaps')) \ valid_objs' s \ pspace_aligned' s \ pspace_distinct' s \ valid_arch_state' s \ vs_valid_duplicates' (ksPSpace s)" in corres_splitEE) prefer 2 apply (rule corres_whenE) apply (simp add: kernel_base_def ARM_HYP.kernelBase_def kernelBase_def shiftl_t2n) apply (rule corres_trivial, simp) apply simp apply (rule corres_guard_imp) apply (rule corres_splitEE) prefer 2 apply (rule check_vp_corres) apply (rule corres_splitEE) prefer 2 apply (simp only: addrFromPPtr_def) apply (rule create_mapping_entries_corres) apply (simp add: mask_vmrights_corres) apply (simp add: vm_attributes_corres) apply (rule corres_splitEE) prefer 2 apply (erule ensure_safe_mapping_corres) apply (rule corres_trivial) apply (rule corres_returnOk) apply (clarsimp simp: archinv_relation_def page_invocation_map_def) apply (wp hoare_whenE_wp check_vp_wpR)+ apply (clarsimp simp: valid_cap_def dest!: vmsz_aligned_less_kernel_base_eq) apply (frule_tac vptr="hd args" in page_directory_pde_at_lookupI, assumption) apply (clarsimp simp: vmsz_aligned_def pageBitsForSize_def valid_global_objs_def page_directory_at_aligned_pd_bits split: vmpage_size.splits) apply (clarsimp simp: valid_cap'_def) apply simp apply (rule whenE_throwError_wp[unfolded validE_R_def]) apply (wp hoare_whenE_wp)+ apply (rule hoare_drop_imps)+ apply (simp add:not_le) apply (wp hoare_drop_imps)+ apply (clarsimp simp: invs_def valid_state_def) apply fastforce apply (cases "invocation_type (mi_label mi) = ArchInvocationLabel ARMPageRemap") apply (case_tac "\(1 < length args \ excaps \ [])") subgoal by (auto simp: Let_def split: list.split) apply (simp add: Let_def split: list.split) apply (case_tac args, simp) apply (clarsimp simp: split_def) apply (rename_tac w1 w2 w3) apply (case_tac excaps', simp) apply (clarsimp simp add: isIOSpaceFrame_def) apply (rule corres_guard_imp) apply (rule corres_splitEE [where r' = "op ="]) prefer 2 apply (clarsimp simp: list_all2_Cons2) apply (case_tac "fst (hd excaps)", simp_all)[1] apply clarsimp apply (rename_tac arch_capa arch_capb) apply (case_tac arch_capa, simp_all)[1] apply (rename_tac opt) apply (case_tac opt, simp_all)[1] apply (rule corres_returnOkTT) apply simp apply (simp add: Let_def split: list.split) apply (rule case_option_corresE) apply (rule corres_trivial) apply simp apply simp apply (rule corres_splitEE) prefer 2 apply (rule corres_lookup_error) apply (rule find_pd_for_asid_corres[OF refl]) apply (rule whenE_throwError_corres) apply simp apply simp apply simp apply (rule corres_splitEE) prefer 2 apply (rule check_vp_corres) apply (rule corres_splitEE) prefer 2 apply (simp only: addrFromPPtr_def) apply (rule create_mapping_entries_corres) apply (simp add: mask_vmrights_corres) apply (simp add: vm_attributes_corres) apply (rule corres_splitEE) prefer 2 apply (erule ensure_safe_mapping_corres) apply (rule corres_trivial) apply (rule corres_returnOk) apply (clarsimp simp: archinv_relation_def page_invocation_map_def) apply wp+ apply (subgoal_tac "valid_arch_objs s \ pspace_aligned s \ (snd v') < kernel_base \ equal_kernel_mappings s \ valid_arch_state s \ (\\ (lookup_pd_slot (fst pa) (snd v') && ~~ mask pd_bits)) s \ page_directory_at (fst pa) s \ (\\ (fst pa)) s") prefer 2 apply assumption apply clarsimp apply (frule_tac pd = aa and vptr = bc in page_directory_pde_at_lookupI,assumption) apply (clarsimp simp: vmsz_aligned_def pageBitsForSize_def valid_global_objs_def page_directory_at_aligned_pd_bits split:vmpage_size.splits) apply wp apply (wpc | wp throwE_R | wp_once hoare_drop_imps)+ apply clarsimp apply (drule bspec [where x = "excaps ! 0"]) apply simp apply (clarsimp simp: valid_cap_def mask_def split: option.split) apply (fastforce simp: invs_def valid_state_def valid_pspace_def) apply (clarsimp split: option.split) apply fastforce apply (simp split del: if_split) apply (cases "invocation_type (mi_label mi) = ArchInvocationLabel ARMPageUnmap") apply simp apply (rule corres_returnOk) apply (clarsimp simp: archinv_relation_def page_invocation_map_def) apply (cases "ARM_HYP_H.isPageFlushLabel (invocation_type (mi_label mi))") apply (clarsimp simp: ARM_HYP_H.isPageFlushLabel_def split del: if_split) apply (clarsimp split: invocation_label.splits arch_invocation_label.splits split del: if_split) apply (rule dec_arch_inv_page_flush_corres, clarsimp simp: ARM_HYP_H.isPageFlushLabel_def)+ apply (clarsimp simp: ARM_HYP_H.isPageFlushLabel_def split del: if_split) apply (cases "invocation_type (mi_label mi) = ArchInvocationLabel ARMPageGetAddress") apply simp apply (rule corres_returnOk) apply (clarsimp simp: archinv_relation_def page_invocation_map_def) subgoal by (clarsimp split: invocation_label.splits arch_invocation_label.splits split del: if_split) apply (simp add: isCap_simps Let_def split del: if_split) apply (simp split: invocation_label.split arch_invocation_label.splits split del: if_split) apply (intro conjI impI allI) apply (simp split: list.split, intro conjI impI allI, simp_all)[1] apply (clarsimp simp: neq_Nil_conv) apply (rule whenE_throwError_corres_initial, simp+) apply (simp split: cap.split arch_cap.split option.split, intro conjI allI impI, simp_all)[1] apply (rule whenE_throwError_corres_initial, simp) apply (simp add: kernel_base_def ARM_HYP.kernelBase_def kernelBase_def) apply (rule corres_guard_imp) apply (rule corres_splitEE) prefer 2 apply (rule corres_lookup_error) apply (rule find_pd_for_asid_corres [OF refl]) apply (rule whenE_throwError_corres, simp, simp) apply (rule corres_splitEE) prefer 2 apply simp apply (rule get_master_pde_corres') apply (simp add: unlessE_whenE) apply (rule corres_splitEE) prefer 2 apply (rule corres_whenE) apply clarsimp apply (case_tac oldpde; clarsimp simp: master_pde_relation_def isSuperSection_def' split: if_split_asm) apply (rule corres_trivial) apply simp apply simp apply (rule corres_trivial) apply (rule corres_returnOk) apply (clarsimp simp: archinv_relation_def page_table_invocation_map_def) apply (simp add: shiftr_shiftl1) apply (wp hoare_whenE_wp get_master_pde_wp getPDE_wp find_pd_for_asid_inv | wp_once hoare_drop_imps)+ apply (fastforce simp: valid_cap_def mask_def) apply (clarsimp simp: valid_cap'_def) apply fastforce apply (clarsimp simp: unlessE_whenE liftE_bindE) apply (rule stronger_corres_guard_imp) apply (rule corres_symb_exec_r_conj) apply (rule_tac F="isArchCap isPageTableCap (cteCap cteVal)" in corres_gen_asm2) apply (rule corres_split[OF _ final_cap_corres[where ptr=slot]]) apply (drule mp) apply (clarsimp simp: isCap_simps final_matters'_def) apply (rule whenE_throwError_corres) apply simp apply simp apply (rule corres_trivial, simp add: returnOk_def archinv_relation_def page_table_invocation_map_def) apply (wp getCTE_wp' | wp_once hoare_drop_imps)+ apply (clarsimp) apply (rule no_fail_pre, rule no_fail_getCTE) apply (erule conjunct2) apply (clarsimp simp: cte_wp_at_caps_of_state is_arch_diminished_def cap_rights_update_def acap_rights_update_def) apply (frule diminished_is_update[rotated]) apply (frule (2) caps_of_state_valid) apply (clarsimp simp add: cap_rights_update_def acap_rights_update_def) apply (clarsimp simp: cte_wp_at_ctes_of is_arch_diminished_def cap_rights_update_def acap_rights_update_def cte_wp_at_caps_of_state) apply (frule diminished_is_update[rotated]) apply (frule (2) caps_of_state_valid) apply (clarsimp simp add: cap_rights_update_def acap_rights_update_def) apply (drule pspace_relation_ctes_ofI[OF _ caps_of_state_cteD, rotated], erule invs_pspace_aligned', clarsimp+) apply (simp add: isCap_simps) apply (simp add: isCap_simps split del: if_split) apply (cases "ARM_HYP_H.isPDFlushLabel (invocation_type (mi_label mi))") apply (clarsimp split del: if_split) apply (cases args, simp) apply (rename_tac a0 as) apply (case_tac as, simp) apply (rename_tac a1 as') apply clarsimp apply (rule corres_guard_imp) apply (rule whenE_throwError_corres, simp) apply clarsimp apply (rule whenE_throwError_corres, simp) apply (clarsimp simp: kernel_base_def ARM_HYP.kernelBase_def kernelBase_def) apply (rule case_option_corresE) apply (rule corres_trivial) apply clarsimp apply clarsimp apply (rule corres_splitEE) prefer 2 apply (rule corres_lookup_error) apply (rule find_pd_for_asid_corres [OF refl]) apply (rule whenE_throwError_corres, simp) apply clarsimp apply (simp add: liftE_bindE) apply (rule corres_split[OF _ _ resolve_vaddr_valid_mapping_size]) prefer 2 apply clarsimp apply (rule resolve_vaddr_corres[THEN corres_gen_asm]) apply simp apply (clarsimp simp: not_le) apply (case_tac rva) apply clarsimp apply (rule_tac P'="pspace_aligned' and pspace_distinct' and valid_global_refs'" in corres_inst[where P="\"]) apply (rule corres_returnOk) apply (clarsimp simp: archinv_relation_def page_directory_invocation_map_def) apply (clarsimp simp: Let_def liftE_bindE checkValidMappingSize_def) apply (rule corres_stateAssert_implied[where P'="\", simplified]) apply (rule corres_guard_imp) apply (rule whenE_throwError_corres, simp) apply clarsimp apply (rule corres_trivial) apply (rule corres_returnOk) apply (clarsimp simp: archinv_relation_def page_directory_invocation_map_def flush_type_map)+ apply (clarsimp simp: state_relation_def) apply (frule pspace_relation_cte_wp_at, simp add: cte_wp_at_caps_of_state, simp+) apply (clarsimp simp: cte_wp_at_ctes_of) apply (drule(1) valid_global_refsD_with_objSize) subgoal by (clarsimp simp: is_page_cap_def split: cap.split_asm) apply (wp hoare_drop_imps)+ apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_cap_simps mask_2pm1 valid_arch_state_def valid_arch_caps_def linorder_not_le split: option.splits) apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def split: option.splits) apply clarsimp apply (simp, rule corres_guard_imp[OF dec_vcpu_inv_corres]; simp) done lemma invokeVCPUInjectIRQ_corres: "corres (op =) (vcpu_at v) (vcpu_at' v) (do y \ invoke_vcpu_inject_irq v index virq; return [] od) (invokeVCPUInjectIRQ v index virq)" unfolding invokeVCPUInjectIRQ_def invoke_vcpu_inject_irq_def apply (clarsimp simp: bind_assoc) apply (corressimp corres: corres_get_vcpu set_vcpu_corres wp: get_vcpu_wp) apply clarsimp apply (safe ; case_tac "vcpuVGIC rv'" ; clarsimp simp: vcpu_relation_def vgic_map_def if_split ; rule ext ; rename_tac x ; case_tac "index = x"; clarsimp) done lemmas corres_discard_r = corres_symb_exec_r [where P'=P' and Q'="\_. P'" for P', simplified] lemma dmo_gets_corres: "corres (op =) P P' (do_machine_op (gets f)) (doMachineOp (gets f))" apply (corres) apply (auto simp : corres_underlyingK_def) done lemmas corres_returnTT = corres_return[where P=\ and P'=\, THEN iffD2] lemma [wp]:"no_fail \ getSCTLR" by (clarsimp simp: getSCTLR_def) lemma invoke_vcpu_read_register_corres: "corres (op =) (vcpu_at v) (vcpu_at' v) (invoke_vcpu_read_register v r) (invokeVCPUReadReg v r)" unfolding invoke_vcpu_read_register_def invokeVCPUReadReg_def read_vcpu_register_def readVCPUReg_def apply (rule corres_discard_r) apply (corressimp corres: corres_get_vcpu wp: get_vcpu_wp) apply (clarsimp simp: vcpu_relation_def split: option.splits) apply (wpsimp simp: getCurThread_def)+ done lemma dmo_rest_corres: "corres dc P P' (do_machine_op (machine_op_lift f)) (doMachineOp (machine_op_lift f))" apply (rule corres_rel_imp, rule corres_guard_imp) apply (rule corres_machine_op) apply (rule corres_underlying_trivial) apply (rule no_fail_machine_op_lift) apply auto done lemma [wp]:"no_fail \ (setSCTLR x)" by (clarsimp simp: setSCTLR_def) lemma invoke_vcpu_write_register_corres: "corres op = (vcpu_at vcpu) (vcpu_at' vcpu) (do y \ invoke_vcpu_write_register vcpu r v; return [] od) (invokeVCPUWriteReg vcpu r v)" unfolding invokeVCPUWriteReg_def invoke_vcpu_write_register_def write_vcpu_register_def writeVCPUReg_def apply (rule corres_discard_r) apply (corressimp corres: set_vcpu_corres corres_get_vcpu wp: get_vcpu_wp) subgoal by (auto simp: vcpu_relation_def split: option.splits) apply (wpsimp simp: getCurThread_def)+ done lemma option_case_corres: "\ \ x = None; x' = None \ \ corres_underlying sr nf nf' r P P' A C; \z. \ x = Some z; x' = Some z \ \ corres_underlying sr nf nf' r (Q z) (Q' z) (B z) (D z)\ \ corres_underlying sr nf nf' r (\s. x = x' \ (x = None \ P s) \ (\z. x = Some z \ Q z s)) (\s. (x' = None \ P' s) \ (\z. x' = Some z \ Q' z s)) (case x of None \ A | Some y \ B y) (case x' of None \ C | Some y \ D y)" apply (rule corres_assume_pre, simp) apply (rule option_corres; simp) done lemma archThreadSet_corres_vcpu_Some[corres]: "corres dc (tcb_at t) (tcb_at' t) (arch_thread_set (tcb_vcpu_update (\_. Some v)) t) (archThreadSet (atcbVCPUPtr_update (\_. Some v)) t)" apply (rule archThreadSet_corres) apply (simp add: arch_tcb_relation_def) done lemma associate_vcpu_tcb_corres: "corres op = (invs and vcpu_at v and tcb_at t) (invs' and vcpu_at' v and tcb_at' t) (do y \ associate_vcpu_tcb v t; return [] od) (associateVCPUTCB v t)" unfolding associate_vcpu_tcb_def associateVCPUTCB_def apply (clarsimp simp: bind_assoc) apply (corressimp search: corres_get_vcpu set_vcpu_corres wp: get_vcpu_wp getVCPU_wp simp: vcpu_relation_def) apply (rule_tac Q="\_. invs and tcb_at t" in hoare_strengthen_post) apply wp apply clarsimp apply (rule conjI) apply (clarsimp simp: vcpu_relation_def) apply (rule conjI) apply (frule (1) sym_refs_vcpu_tcb, fastforce) apply (clarsimp simp: obj_at_def)+ apply (wpsimp) apply (rule_tac Q="\_. invs' and tcb_at' t" in hoare_strengthen_post) apply wpsimp apply clarsimp apply (rule conjI) apply clarsimp apply (frule valid_objs_valid_vcpu'[rotated], fastforce) apply (simp add: valid_vcpu'_def typ_at_tcb') apply (clarsimp simp: typ_at_to_obj_at_arches obj_at'_def) apply (clarsimp simp: typ_at_to_obj_at_arches obj_at'_def) apply (corressimp wp: arch_thread_get_wp getObject_tcb_wp simp: archThreadGet_def)+ apply (rule conjI) apply clarsimp apply (rule conjI) apply clarsimp apply (frule (1) sym_refs_tcb_vcpu, fastforce) apply (clarsimp simp: obj_at_def) apply (clarsimp simp: vcpu_relation_def) apply (frule (1) sym_refs_vcpu_tcb, fastforce) apply (clarsimp simp: obj_at_def) apply normalise_obj_at' apply (drule valid_objs_valid_tcb'[rotated], fastforce) apply (clarsimp simp: valid_tcb'_def valid_arch_tcb'_def) apply (drule valid_objs_valid_vcpu'[rotated], fastforce) apply (simp add: valid_vcpu'_def typ_at_tcb') done lemma perform_vcpu_invocation_corres: notes inv_corres = invokeVCPUInjectIRQ_corres invoke_vcpu_read_register_corres invoke_vcpu_write_register_corres associate_vcpu_tcb_corres shows "corres (op =) (einvs and ct_active and valid_vcpu_invocation iv) (invs' and ct_active' and valid_vcpuinv' (vcpu_invocation_map iv)) (perform_vcpu_invocation iv) (performARMVCPUInvocation (vcpu_invocation_map iv))" unfolding perform_vcpu_invocation_def performARMVCPUInvocation_def apply (cases iv; simp add: vcpu_invocation_map_def valid_vcpu_invocation_def valid_vcpuinv'_def) apply (rule inv_corres [THEN corres_guard_imp]; simp)+ done lemma inv_arch_corres: assumes "archinv_relation ai ai'" shows "corres (intr \ op=) (einvs and ct_active and valid_arch_inv ai) (invs' and ct_active' and valid_arch_inv' ai' and (\s. vs_valid_duplicates' (ksPSpace s))) (arch_perform_invocation ai) (Arch.performInvocation ai')" proof - note invocation_corres = perform_page_table_corres perform_page_directory_corres pac_corres pap_corres perform_page_corres perform_vcpu_invocation_corres from assms show ?thesis unfolding arch_perform_invocation_def ARM_HYP_H.performInvocation_def performARMMMUInvocation_def apply clarsimp apply (cases ai; clarsimp simp add: archinv_relation_def liftE_bind_return_bindE_returnOk[symmetric]) by (rule corres_split'[where r'=dc, OF _ corres_trivial] | rule invocation_corres[THEN corres_guard_imp] | (fastforce simp: valid_arch_inv_def valid_arch_inv'_def)+ | wpsimp+)+ qed lemma asid_pool_typ_at_ext': "asid_pool_at' = obj_at' (\::asidpool \ bool)" apply (rule ext)+ apply (simp add: typ_at_to_obj_at_arches) done lemma st_tcb_strg': "st_tcb_at' P p s \ tcb_at' p s" by (auto simp: pred_tcb_at') lemma performASIDControlInvocation_tcb_at': "\st_tcb_at' active' p and invs' and ct_active' and valid_aci' aci\ performASIDControlInvocation aci \\y. tcb_at' p\" apply (rule hoare_name_pre_state) apply (clarsimp simp: performASIDControlInvocation_def split: asidcontrol_invocation.splits) apply (clarsimp simp: valid_aci'_def cte_wp_at_ctes_of cong: conj_cong) apply (wp static_imp_wp |simp add:placeNewObject_def2)+ apply (wp createObjects_orig_obj_at2' updateFreeIndex_pspace_no_overlap' getSlotCap_wp static_imp_wp)+ apply (clarsimp simp: projectKO_opts_defs) apply (strengthen st_tcb_strg' [where P=\]) apply (wp deleteObjects_invs_derivatives[where p="makePoolParent aci"] hoare_vcg_ex_lift deleteObjects_cte_wp_at'[where d=False] deleteObjects_st_tcb_at'[where p="makePoolParent aci"] static_imp_wp updateFreeIndex_pspace_no_overlap' deleteObject_no_overlap[where d=False])+ apply (case_tac ctea) apply (clarsimp) apply (frule ctes_of_valid_cap') apply (simp add:invs_valid_objs')+ apply (clarsimp simp:valid_cap'_def capAligned_def cte_wp_at_ctes_of) apply (strengthen refl order_refl pred_tcb'_weakenE[mk_strg I E]) apply (clarsimp simp: conj_comms invs_valid_pspace' isCap_simps descendants_range'_def2 empty_descendants_range_in') apply (frule ctes_of_valid', clarsimp, simp, drule capFreeIndex_update_valid_cap'[where fb="2 ^ pageBits", rotated -1], simp_all) apply (simp add: pageBits_def is_aligned_def) apply (simp add: valid_cap_simps' range_cover_def objBits_simps archObjSize_def capAligned_def unat_eq_0 and_mask_eq_iff_shiftr_0[symmetric] word_bw_assocs) apply clarsimp apply (drule(1) cte_cap_in_untyped_range, fastforce simp add: cte_wp_at_ctes_of, assumption, simp_all) apply (clarsimp simp: invs'_def valid_state'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of) apply clarsimp done crunch tcb_at'[wp]: performARMVCPUInvocation "tcb_at' p" lemma invokeArch_tcb_at': "\invs' and valid_arch_inv' ai and ct_active' and st_tcb_at' active' p\ Arch.performInvocation ai \\rv. tcb_at' p\" apply (simp add: ARM_HYP_H.performInvocation_def) apply (cases ai; simp add: performARMMMUInvocation_def) apply (wp, clarsimp simp: pred_tcb_at') apply (wp, clarsimp simp: pred_tcb_at') apply (wp, clarsimp simp: st_tcb_strg'[rule_format]) apply (wp performASIDControlInvocation_tcb_at', clarsimp simp: valid_arch_inv'_def) apply (wp, clarsimp simp: pred_tcb_at') apply wpsimp done (* FIXME random place to have these *) lemma pspace_no_overlap_queuesL1 [simp]: "pspace_no_overlap' w sz (ksReadyQueuesL1Bitmap_update f s) = pspace_no_overlap' w sz s" by (simp add: pspace_no_overlap'_def) (* FIXME random place to have these *) lemma pspace_no_overlap_queuesL2 [simp]: "pspace_no_overlap' w sz (ksReadyQueuesL2Bitmap_update f s) = pspace_no_overlap' w sz s" by (simp add: pspace_no_overlap'_def) crunch pspace_no_overlap'[wp]: setThreadState "pspace_no_overlap' w s" (simp: unless_def) lemma sts_cte_cap_to'[wp]: "\ex_cte_cap_to' p\ setThreadState st t \\rv. ex_cte_cap_to' p\" by (wp ex_cte_cap_to'_pres) lemma valid_slots_duplicated_lift': assumes ko_wp_at': "\P p. \ko_wp_at' (\ko. P (vs_entry_align ko)) p \ f \\rv. ko_wp_at' (\ko. P (vs_entry_align ko)) p\" and pt_at: "\p. \page_table_at' p \ f \\rv. page_table_at' p\" and pd_at: "\p. \page_directory_at' p\ f \\rv. page_directory_at' p\" shows "\valid_slots_duplicated' x\ f \\r. valid_slots_duplicated' x\" apply (simp add:valid_slots_duplicated'_def) apply (case_tac x) apply (case_tac a) apply (case_tac aa) apply simp_all apply (rule hoare_pre) apply simp apply (wp hoare_vcg_ex_lift ko_wp_at' pt_at pd_at | simp)+ apply (case_tac b) apply (case_tac a) apply (wp hoare_vcg_ex_lift ko_wp_at' pt_at pd_at | simp)+ done lemma setTCB_pdpt_bits'[wp]: "\\s. ko_wp_at' (\ko. P (vs_entry_align ko)) p s\ setObject a (tcb::tcb) \\rv. ko_wp_at' (\ko. P (vs_entry_align ko)) p\" apply (clarsimp simp: setObject_def split_def valid_def in_monad projectKOs pspace_aligned'_def ps_clear_upd' objBits_def[symmetric] lookupAround2_char1 split: if_split_asm) apply (frule pspace_storable_class.updateObject_type[where v = tcb,simplified]) apply (clarsimp simp:ko_wp_at'_def) apply (intro conjI) subgoal by (clarsimp simp:updateObject_default_def assert_def bind_def alignCheck_def in_monad when_def alignError_def magnitudeCheck_def assert_opt_def return_def fail_def typeError_def objBits_simps vs_entry_align_def split:if_splits option.splits Structures_H.kernel_object.splits, ((erule(1) ps_clear_updE)+)) apply (clarsimp) apply (erule(1) ps_clear_updE) done lemma ko_wp_at'_cong: "ksPSpace s = ksPSpace m \ ko_wp_at' P p s = ko_wp_at' P p m" by (simp add:ko_wp_at'_def ps_clear_def) crunch vs_entry_align'[wp]: threadSet "ko_wp_at' (\ko. P (vs_entry_align ko)) p" (ignore: getObject setObject wp:crunch_wps) crunch vs_entry_align'[wp]: addToBitmap "ko_wp_at' (\ko. P (vs_entry_align ko)) p" (ignore: getObject setObject wp:crunch_wps) lemma tcbSchedEnqueue_vs_entry_align[wp]: "\\s. ko_wp_at' (\ko. P (vs_entry_align ko)) p s\ tcbSchedEnqueue pa \\rv. ko_wp_at' (\ko. P (vs_entry_align ko)) p\" apply (clarsimp simp: tcbSchedEnqueue_def setQueue_def) by (wp hoare_unless_wp | simp)+ crunch vs_entry_align[wp]: setThreadState "ko_wp_at' (\ko. P (vs_entry_align ko)) p" (ignore: getObject setObject wp:crunch_wps) lemma sts_valid_arch_inv': "\valid_arch_inv' ai\ setThreadState st t \\rv. valid_arch_inv' ai\" apply (cases ai, simp_all add: valid_arch_inv'_def) apply (clarsimp simp: valid_pti'_def split: page_table_invocation.splits) apply (intro allI conjI impI) apply (wp | simp)+ apply (rename_tac page_invocation) apply (case_tac page_invocation, simp_all add: valid_page_inv'_def)[1] apply (wp valid_slots_lift' valid_slots_duplicated_lift'|simp)+ apply (clarsimp simp: valid_aci'_def split: asidcontrol_invocation.splits) apply (clarsimp simp: cte_wp_at_ctes_of) apply (rule hoare_pre, wp) apply clarsimp apply (clarsimp simp: valid_apinv'_def split: asidpool_invocation.splits) apply (rule hoare_pre, wp) apply simp apply (rename_tac vcpui) apply (case_tac vcpui; wpsimp simp: valid_vcpuinv'_def) done lemma less_kernelBase_valid_pde_offset': "\ vptr < kernelBase; x = 0 \ is_aligned vptr 25; x \ 0x0F \ \ valid_pde_mapping_offset' (((x * 8) + (vptr >> 21 << 3)) && mask pdBits)" apply (clarsimp simp: ARM_HYP.kernelBase_def kernelBase_def pdBits_def pageBits_def valid_pde_mapping_offset'_def pd_asid_slot_def pt_index_bits_def vspace_bits_defs) apply (drule minus_one_helper3, simp) apply (drule le_shiftr[where u=vptr and n=21]) apply (subst(asm) iffD2[OF mask_eq_iff_w2p]) apply (simp add: word_size) apply (simp add: shiftl_t2n unat_arith_simps iffD1[OF unat_mult_lem]) apply (erule disjE) apply (simp add: shiftl_t2n unat_arith_simps iffD1[OF unat_mult_lem]) apply (frule arg_cong[where f="\v. v && mask 7"]) apply (subst(asm) field_simps, subst(asm) is_aligned_add_helper[where n=7], rule is_aligned_shiftl) apply (rule is_aligned_shiftr, simp) apply simp apply (simp add: unat_arith_simps iffD1[OF unat_mult_lem]) apply (simp add: shiftl_t2n unat_arith_simps iffD1[OF unat_mult_lem]) done lemmas less_kernelBase_valid_pde_offset'' = less_kernelBase_valid_pde_offset'[where x=0, simplified pd_bits_def pdBits_def pdeBits_def, simplified] lemma createMappingEntries_valid_pde_slots': "\K (vmsz_aligned' vptr sz \ is_aligned pd pdBits \ vptr < kernelBase)\ createMappingEntries base vptr sz vm_rights attrib pd \\rv s. valid_pde_slots' rv\,-" apply (simp add: createMappingEntries_def valid_pde_slots'_def) apply (cases sz, simp_all) apply (wp | simp)+ apply (clarsimp simp: lookup_pd_slot_def Let_def mask_add_aligned vspace_bits_defs) apply (erule less_kernelBase_valid_pde_offset'') apply (rule hoare_pre, wp) apply (clarsimp simp: vmsz_aligned'_def superSectionPDEOffsets_def vspace_bits_defs del: ballI) apply (simp add: lookup_pd_slot_def Let_def vspace_bits_defs) apply (clarsimp simp: upto_enum_step_def linorder_not_less pd_bits_def lookup_pd_slot_def Let_def field_simps mask_add_aligned) apply (erule less_kernelBase_valid_pde_offset' [simplified pdBits_def pdeBits_def, simplified]) apply simp apply simp done lemma inv_ASIDPool: "inv ASIDPool = (\v. case v of ASIDPool a \ a)" apply (rule ext) apply (case_tac v) apply simp apply (rule inv_f_f, rule inj_onI) apply simp done lemma findPDForASID_aligned[wp]: "\valid_objs'\ findPDForASID p \\rv s. is_aligned rv pd_bits\,-" apply (simp add: findPDForASID_def assertE_def cong: option.case_cong split del: if_split) apply (rule hoare_pre) apply (wp getASID_wp | wpc)+ apply clarsimp apply (drule(1) obj_at_valid_objs') apply (clarsimp simp: projectKOs valid_obj'_def inv_ASIDPool ranI split: asidpool.split_asm) done lemma findPDForASID_valid_offset'[wp]: "\valid_objs' and K (vptr < kernelBase)\ findPDForASID p \\rv s. valid_pde_mapping_offset' (rv + (vptr >> 21 << 3) && mask pd_bits)\,-" apply (rule hoare_gen_asmE) apply (rule hoare_post_imp_R, rule findPDForASID_aligned) apply (simp add: mask_add_aligned vspace_bits_defs) apply (erule less_kernelBase_valid_pde_offset'') done lemma diminished_arch_update': "diminished' (ArchObjectCap cp) (cteCap cte) \ is_arch_update' (ArchObjectCap cp) cte" by (clarsimp simp: is_arch_update'_def isCap_simps diminished'_def) lemma lookupPTSlot_page_table_at': "\valid_objs'\ lookupPTSlot pd vptr \\rv s. page_table_at' (rv && ~~ mask pt_bits) s\,-" apply (simp add:lookupPTSlot_def) apply (wp getPDE_wp|wpc|simp add:checkPTAt_def)+ apply (clarsimp simp:ptBits_def lookup_pt_slot_no_fail_def pt_bits_def pte_bits_def pageBits_def mask_def[of 9]) apply (subst vaddr_segment_nonsense3[unfolded pt_bits_def pte_bits_def,simplified]) apply (simp add:page_table_at'_def pageBits_def pt_bits_def pte_bits_def) apply simp done lemma findPDForASID_page_directory_at': notes checkPDAt_inv[wp del] shows "\\\ findPDForASID asiv \\rv s. page_directory_at' (lookup_pd_slot rv vptr && ~~ mask pd_bits) s\,-" apply (simp add:findPDForASID_def) apply (wp getASID_wp|simp add:checkPDAt_def | wpc)+ apply (clarsimp simp:lookup_pd_slot_def pdBits_def pageBits_def pte_bits_def pt_bits_def pde_bits_def pd_bits_def) apply (subst vaddr_segment_nonsense[unfolded pd_bits_def pde_bits_def,simplified]) apply (simp add:page_directory_at'_def pdBits_def pageBits_def pd_bits_def pde_bits_def) apply simp done definition "slots_duplicated_ensured \ \m s. case m of Inl (pte, xs) \ (case pte of pte.LargePagePTE _ _ _ _ \ \p. xs = [p, p+8 .e. p + mask 7] \ is_aligned p 7 \ page_table_at' (p && ~~ mask ptBits) s | pte.InvalidPTE \ False | _ \ \p. xs = [p] \ page_table_at' (p && ~~ mask ptBits) s) | Inr (pde, xs) \ (case pde of pde.SuperSectionPDE _ _ _ _ \ \p. xs = [p, p+8 .e. p + mask 7] \ is_aligned p 7 \ page_directory_at' (p && ~~ mask pdBits) s \ is_aligned p 7 | pde.InvalidPDE \ False | _ \ \p. xs = [p] \ page_directory_at' (p && ~~ mask pdBits) s)" lemma ensureSafeMapping_valid_slots_duplicated': "\\s. slots_duplicated_ensured entries s\ ensureSafeMapping entries \\rv s. valid_slots_duplicated' entries s\,-" apply (simp add:ensureSafeMapping_def) apply (case_tac entries) apply (case_tac a) apply (case_tac aa) apply (simp add:slots_duplicated_ensured_def | wp)+ apply (rule hoare_pre) apply (wp mapME_x_inv_wp getPTE_wp| wpc)+ apply clarsimp apply (clarsimp simp:valid_slots_duplicated'_def) apply (simp add:slots_duplicated_ensured_def) apply (rule hoare_pre) apply (rule_tac P = "\p. b = [p]" and P' = "\s. \p. b = [p] \ page_table_at' (p && ~~ mask ptBits) s" in hoare_gen_asmE) apply (clarsimp simp:mapME_singleton) apply (wp getPTE_wp|wpc)+ apply (clarsimp simp:valid_slots_duplicated'_def obj_at'_real_def split:option.splits) apply (intro impI conjI) apply (erule ko_wp_at'_weakenE) apply (simp add:projectKO_opt_pte vs_entry_align_def split:Structures_H.kernel_object.splits arch_kernel_object.splits) apply (erule ko_wp_at'_weakenE) apply (simp add:projectKO_opt_pte vs_entry_align_def split:Structures_H.kernel_object.splits arch_kernel_object.splits) apply (clarsimp simp add: vspace_bits_defs) apply (case_tac b) apply (case_tac a) apply (simp add:slots_duplicated_ensured_def | wp)+ apply (rule hoare_pre) apply (rule_tac P = "\p. ba = [p]" and P' = "\s. \p. ba = [p] \ page_directory_at' (p && ~~ mask pdBits) s" in hoare_gen_asmE) apply (clarsimp simp:mapME_singleton) apply (wp getPDE_wp|wpc)+ apply (clarsimp simp:valid_slots_duplicated'_def obj_at'_real_def split:option.splits) apply (intro impI conjI) apply (erule ko_wp_at'_weakenE) apply (simp add:projectKO_opt_pde vs_entry_align_def split:Structures_H.kernel_object.splits arch_kernel_object.splits) apply (erule ko_wp_at'_weakenE) apply (simp add:projectKO_opt_pde vs_entry_align_def split:Structures_H.kernel_object.splits arch_kernel_object.splits) apply clarsimp apply (simp add:slots_duplicated_ensured_def) apply (rule hoare_pre) apply (wp mapME_x_inv_wp getPDE_wp| wpc)+ apply clarsimp apply (fastforce simp:valid_slots_duplicated'_def) done lemma is_aligned_ptrFromPAddr_aligned: "m \ 28 \ is_aligned (ptrFromPAddr p) m = is_aligned p m" apply (simp add:ptrFromPAddr_def is_aligned_mask physMappingOffset_def kernelBase_addr_def ARM_HYP.physBase_def physBase_def) apply (subst add.commute) apply (subst mask_add_aligned) apply (erule is_aligned_weaken[rotated]) apply (simp add:is_aligned_def) apply simp done (* FIXME: this lemma is too specific *) lemma lookupPTSlot_aligned: "\\s. is_aligned vptr 16 \ valid_objs' s\ lookupPTSlot pd vptr \\p s. is_aligned p 7\,-" apply (simp add:lookupPTSlot_def) apply (wp getPDE_wp |wpc|simp)+ apply (clarsimp simp:obj_at'_real_def ko_wp_at'_def) apply (erule(1) valid_objsE') apply (clarsimp simp:projectKO_opt_pde split:Structures_H.kernel_object.splits arch_kernel_object.splits) apply (simp add:valid_obj'_def lookup_pt_slot_no_fail_def) apply (rule aligned_add_aligned) apply (rule is_aligned_ptrFromPAddr_aligned[where m = 7,THEN iffD2]) apply simp apply (erule is_aligned_weaken) apply (simp add: vspace_bits_defs) apply (rule is_aligned_shiftl) apply (rule is_aligned_andI1) apply (rule is_aligned_shiftr) apply (simp add: pte_bits_def pageBits_def pt_bits_def) apply simp done lemma createMappingEntires_valid_slots_duplicated'[wp]: "\\s. vs_valid_duplicates' (ksPSpace s) \ vmsz_aligned vptr vmsz \ valid_objs' s \ page_directory_at' (lookup_pd_slot pd vptr && ~~ mask pdBits) s \ is_aligned pd pdBits\ createMappingEntries base vptr vmsz vmrights attrib pd \\rv s. slots_duplicated_ensured rv s\, -" apply (clarsimp simp:createMappingEntries_def) apply (rule hoare_pre) apply (wpc | wp lookupPTSlot_page_table_at' | simp add: slots_duplicated_ensured_def)+ apply (rule_tac Q' = "\p s. is_aligned p 7 \ page_table_at' (p && ~~ mask pt_bits) s" in hoare_post_imp_R) apply (wp lookupPTSlot_aligned lookupPTSlot_page_table_at' | simp add: vspace_bits_defs largePagePTEOffsets_def superSectionPDEOffsets_def)+ apply (rule_tac x = r in exI) apply clarsimp apply (frule is_aligned_no_wrap'[where off = "0x78"]) apply simp apply (drule upto_enum_step_shift[where n = 7 and m = 3,simplified]) apply (clarsimp simp:mask_def add.commute upto_enum_step_def) apply wp+ apply (intro conjI impI) apply ((clarsimp simp: vmsz_aligned_def pageBitsForSize_def slots_duplicated_ensured_def split:vmpage_size.splits)+)[9] apply clarsimp apply (drule lookup_pd_slot_aligned_6) apply (simp add:pdBits_def pageBits_def pd_bits_def pde_bits_def) apply (clarsimp simp:slots_duplicated_ensured_def) apply (rule_tac x = "(lookup_pd_slot pd vptr)" in exI) apply (clarsimp simp: superSectionPDEOffsets_def Let_def pde_bits_def) apply (frule is_aligned_no_wrap'[where off = "0x78" and sz = 7]) apply simp apply (drule upto_enum_step_shift[where n = 7 and m = 3,simplified]) apply (clarsimp simp:mask_def add.commute upto_enum_step_def) done lemma arch_decodeARMPageFlush_wf: "ARM_HYP_H.isPageFlushLabel (invocation_type label) \ \invs' and valid_cap' (capability.ArchObjectCap (arch_capability.PageCap d word vmrights vmpage_size option)) and cte_wp_at' (diminished' (capability.ArchObjectCap (arch_capability.PageCap d word vmrights vmpage_size option)) \ cteCap) slot and (\s. \x\set excaps. cte_wp_at' (diminished' (fst x) \ cteCap) (snd x) s) and sch_act_simple and (\s. vs_valid_duplicates' (ksPSpace s))\ decodeARMPageFlush label args (arch_capability.PageCap d word vmrights vmpage_size option) \valid_arch_inv'\, -" supply hoare_True_E_R [simp del] apply (simp add: decodeARMPageFlush_def) apply (wpsimp wp: whenE_throwError_wp simp: valid_arch_inv'_def valid_page_inv'_def) done lemma zobj_refs_maksCapRights[simp]: "zobj_refs' (maskCapRights R cap) = zobj_refs' cap" by (cases cap; clarsimp simp: maskCapRights_def ARM_HYP_H.maskCapRights_def Let_def isCap_simps) lemma diminished_zobj_refs': "diminished' cap cap' \ zobj_refs' cap' = zobj_refs' cap" by (cases cap'; clarsimp simp: diminished'_def) lemma arch_decodeInvocation_wf[wp]: notes ensureSafeMapping_inv[wp del] shows "\invs' and valid_cap' (ArchObjectCap arch_cap) and cte_wp_at' (diminished' (ArchObjectCap arch_cap) o cteCap) slot and (\s. \x \ set excaps. cte_wp_at' (diminished' (fst x) o cteCap) (snd x) s) and sch_act_simple and (\s. vs_valid_duplicates' (ksPSpace s))\ Arch.decodeInvocation label args cap_index slot arch_cap excaps \valid_arch_inv'\,-" apply (cases arch_cap) apply (simp add: decodeARMMMUInvocation_def ARM_HYP_H.decodeInvocation_def Let_def split_def isCap_simps cong: if_cong split del: if_split) apply (rule hoare_pre) apply ((wp whenE_throwError_wp getASID_wp| wpc| simp add: valid_arch_inv'_def valid_apinv'_def)+)[1] apply (clarsimp simp: word_neq_0_conv valid_cap'_def) apply (rule conjI) apply (erule cte_wp_at_weakenE') apply (clarsimp simp: diminished_isPDCap) apply (subst (asm) conj_assoc [symmetric]) apply (subst (asm) assocs_empty_dom_comp [symmetric]) apply (drule dom_hd_assocsD) apply (simp add: capAligned_def) apply (elim conjE) apply (subst field_simps, erule is_aligned_add_less_t2n) apply assumption apply (simp add: asid_low_bits_def asid_bits_def) apply assumption apply (simp add: decodeARMMMUInvocation_def ARM_HYP_H.decodeInvocation_def Let_def split_def isCap_simps cong: if_cong invocation_label.case_cong arch_invocation_label.case_cong list.case_cong prod.case_cong split del: if_split) apply (rule hoare_pre) apply ((wp whenE_throwError_wp ensureEmptySlot_stronger| wpc| simp add: valid_arch_inv'_def valid_aci'_def is_aligned_shiftl_self split del: if_split)+)[1] apply (rule_tac Q'= "\rv. K (fst (hd [p\assocs asidTable . fst p \ 2 ^ asid_high_bits - 1 \ snd p = None]) << asid_low_bits \ 2 ^ asid_bits - 1) and real_cte_at' rv and ex_cte_cap_to' rv and cte_wp_at' (\cte. \idx. cteCap cte = (UntypedCap False frame pageBits idx)) (snd (excaps!0)) and sch_act_simple and (\s. descendants_of' (snd (excaps!0)) (ctes_of s) = {}) " in hoare_post_imp_R) apply (simp add: lookupTargetSlot_def) apply wp apply (clarsimp simp: cte_wp_at_ctes_of) apply (simp split del: if_split) apply (wp ensureNoChildren_sp whenE_throwError_wp|wpc)+ apply clarsimp apply (rule conjI) apply (clarsimp simp: null_def neq_Nil_conv) apply (drule filter_eq_ConsD) apply clarsimp apply (rule shiftl_less_t2n) apply (simp add: asid_bits_def asid_low_bits_def asid_high_bits_def) apply unat_arith apply (simp add: asid_bits_def) apply clarsimp apply (rule conjI, fastforce) apply (clarsimp simp: cte_wp_at_ctes_of objBits_simps archObjSize_def) apply (rule conjI) apply (case_tac cteb) apply clarsimp apply (drule ctes_of_valid_cap', fastforce) apply (simp add: diminished_valid') apply clarsimp apply (simp add: ex_cte_cap_to'_def cte_wp_at_ctes_of) apply (rule_tac x=ba in exI) apply (simp add: diminished_cte_refs') apply (simp add: decodeARMMMUInvocation_def ARM_HYP_H.decodeInvocation_def Let_def split_def isCap_simps cong: if_cong split del: if_split) apply (cases "invocation_type label = ArchInvocationLabel ARMPageMap") apply (rename_tac word vmrights vmpage_size option) apply (simp add: split_def split del: if_split cong: list.case_cong prod.case_cong) apply (rule hoare_pre) apply (wp|wpc|simp add:valid_arch_inv'_def valid_page_inv'_def)+ apply (rule hoare_vcg_conj_lift_R,(wp ensureSafeMapping_inv)[1])+ apply ((wp whenE_throwError_wp checkVP_wpR hoare_vcg_const_imp_lift_R ensureSafeMapping_valid_slots_duplicated' createMappingEntries_valid_pde_slots' findPDForASID_page_directory_at' | wpc | simp add: valid_arch_inv'_def valid_page_inv'_def | rule_tac x="fst p" in hoare_imp_eq_substR)+)[8] apply (clarsimp simp: neq_Nil_conv invs_valid_objs' linorder_not_le cte_wp_at_ctes_of) apply (drule ctes_of_valid', fastforce)+ apply (clarsimp simp: diminished_valid' [symmetric]) apply (clarsimp simp: valid_cap'_def ptBits_def pageBits_def) apply (clarsimp simp: is_arch_update'_def isCap_simps capAligned_def vmsz_aligned'_def dest!: diminished_capMaster) apply (rule conjI) apply (erule is_aligned_addrFromPPtr_n, case_tac vmpage_size, simp_all)[1] apply (simp add:vmsz_aligned_def) apply (erule order_le_less_trans[rotated]) apply (erule is_aligned_no_overflow'[simplified field_simps]) apply (cases "invocation_type label = ArchInvocationLabel ARMPageRemap") apply (rename_tac word vmrights vmpage_size option) apply (simp add: split_def invs_valid_objs' split del: if_split cong: list.case_cong prod.case_cong) apply (rule hoare_pre) apply (wp|wpc|simp add:valid_arch_inv'_def valid_page_inv'_def)+ apply (rule hoare_vcg_conj_lift_R,(wp ensureSafeMapping_inv)[1])+ apply ((wp whenE_throwError_wp checkVP_wpR hoare_vcg_const_imp_lift_R ensureSafeMapping_valid_slots_duplicated' createMappingEntries_valid_pde_slots' | wpc | simp add: valid_arch_inv'_def valid_page_inv'_def)+)[6] apply (simp add: eq_commute[where b="fst x" for x]) apply ((wp whenE_throwError_wp checkVP_wpR hoare_vcg_const_imp_lift_R hoare_drop_impE_R findPDForASID_page_directory_at' createMappingEntries_valid_pde_slots' | wpc | simp add: valid_arch_inv'_def valid_page_inv'_def)+)[3] apply (clarsimp simp: invs_valid_objs' linorder_not_le cte_wp_at_ctes_of) apply (drule ctes_of_valid', fastforce)+ apply (clarsimp simp: diminished_valid' [symmetric]) apply (clarsimp simp: valid_cap'_def ptBits_def pageBits_def) apply (clarsimp simp: is_arch_update'_def isCap_simps capAligned_def vmsz_aligned'_def pdBits_def pageBits_def vmsz_aligned_def dest!: diminished_capMaster) apply (erule is_aligned_addrFromPPtr_n, case_tac vmpage_size, simp_all)[1] apply (cases "invocation_type label = ArchInvocationLabel ARMPageUnmap") apply (simp split del: if_split) apply (rule hoare_pre, wp) apply (clarsimp simp: valid_arch_inv'_def valid_page_inv'_def) apply (thin_tac "Ball S P" for S P) apply (erule cte_wp_at_weakenE') apply (clarsimp simp: is_arch_update'_def isCap_simps dest!: diminished_capMaster) apply (cases "ARM_HYP_H.isPageFlushLabel (invocation_type label)") apply (clarsimp simp: ARM_HYP_H.isPageFlushLabel_def split: invocation_label.splits arch_invocation_label.splits) apply (rule arch_decodeARMPageFlush_wf, clarsimp simp: ARM_HYP_H.isPageFlushLabel_def)+ apply (cases "invocation_type label = ArchInvocationLabel ARMPageGetAddress") apply (simp split del: if_split) apply (rule hoare_pre, wp) apply (clarsimp simp: valid_arch_inv'_def valid_page_inv'_def) apply (simp add: ARM_HYP_H.isPageFlushLabel_def throwError_R' split: invocation_label.split_asm arch_invocation_label.split_asm) apply (simp add: decodeARMMMUInvocation_def ARM_HYP_H.decodeInvocation_def Let_def split_def isCap_simps vs_entry_align_def cong: if_cong list.case_cong invocation_label.case_cong arch_invocation_label.case_cong prod.case_cong split del: if_split) apply (rename_tac word option) apply (rule hoare_pre) apply ((wp whenE_throwError_wp isFinalCapability_inv getPDE_wp | wpc | simp add: valid_arch_inv'_def valid_pti'_def unlessE_whenE| rule_tac x="fst p" in hoare_imp_eq_substR )+) apply (rule_tac Q'="\b c. ko_at' ARM_HYP_H.pde.InvalidPDE (b + (hd args >> 21 << 3)) c \ cte_wp_at' (is_arch_update' (capability.ArchObjectCap (arch_capability.PageTableCap word (Some (snd p, hd args >> 21 << 21))))) slot c \ c \' capability.ArchObjectCap (arch_capability.PageTableCap word (Some (snd p, hd args >> 21 << 21))) \ is_aligned (addrFromPPtr word) ptBits \ valid_pde_mapping_offset' (b + (hd args >> 21 << 3) && mask pd_bits) " in hoare_post_imp_R) apply ((wp whenE_throwError_wp isFinalCapability_inv getPDE_wp | wpc | simp add: valid_arch_inv'_def valid_pti'_def unlessE_whenE| rule_tac x="fst p" in hoare_imp_eq_substR | rule hoare_drop_impE_R)+) apply (clarsimp simp:ko_wp_at'_def obj_at'_real_def) apply (clarsimp simp: projectKO_opt_pde vs_entry_align_def vspace_bits_defs split:Structures_H.kernel_object.splits arch_kernel_object.splits) apply ((wp whenE_throwError_wp isFinalCapability_inv | wpc |simp add: valid_arch_inv'_def valid_pti'_def unlessE_whenE | rule hoare_drop_imp)+)[14] apply (clarsimp simp: linorder_not_le isCap_simps cte_wp_at_ctes_of diminished_arch_update') apply (simp add: valid_cap'_def capAligned_def) apply (rule conjI) apply (clarsimp simp: is_arch_update'_def isCap_simps dest!: diminished_capMaster) apply (clarsimp simp: neq_Nil_conv vs_entry_align_def invs_valid_objs' ptBits_def pageBits_def is_aligned_addrFromPPtr_n) apply (thin_tac "Ball S P" for S P)+ apply (drule ctes_of_valid', fastforce)+ apply (clarsimp simp: diminished_valid' [symmetric]) apply (clarsimp simp: valid_cap'_def ptBits_def pageBits_def is_aligned_addrFromPPtr_n invs_valid_objs' vs_entry_align_def and_not_mask[symmetric] vspace_bits_defs) apply (erule order_le_less_trans[rotated]) apply (rule word_and_le2) apply (simp add: decodeARMMMUInvocation_def ARM_HYP_H.decodeInvocation_def isCap_simps Let_def) supply hoare_True_E_R [simp del] apply(cases "ARM_HYP_H.isPDFlushLabel (invocation_type label)", simp_all) apply(cases args; simp) apply(wp) apply (wpsimp wp: whenE_throwError_wp simp: valid_arch_inv'_def) apply(wp) supply if_split [split del] apply (simp add: ARM_HYP_H.decodeInvocation_def decodeARMVCPUInvocation_def Let_def) apply (wpsimp wp: whenE_throwError_wp getVCPU_wp simp: decodeVCPUSetTCB_def decodeVCPUInjectIRQ_def Let_def decodeVCPUReadReg_def decodeVCPUWriteReg_def) apply (clarsimp simp: valid_arch_inv'_def valid_vcpuinv'_def null_def isCap_simps valid_cap'_def) apply (rename_tac vcpu s tcb) apply (clarsimp simp: neq_Nil_conv ex_nonz_cap_to'_def cte_wp_at_ctes_of) apply (rename_tac cref exc' cte') apply (frule_tac p=cref in ctes_of_valid', fastforce) apply (subgoal_tac "s \' ThreadCap tcb") prefer 2 apply (drule diminished_valid')+ apply clarsimp apply (rule conjI) apply (clarsimp simp: valid_cap'_def) apply (drule diminished_zobj_refs')+ by fastforce lemma setObject_cte_nosch [wp]: "\\s. P (ksSchedulerAction s)\ setObject p (cte::cte) \\_ s. P (ksSchedulerAction s)\" apply (rule setObject_nosch) apply (simp add: updateObject_cte) apply (rule hoare_pre) apply (wp|wpc|simp add: unless_def)+ done lemma setObject_pte_nosch [wp]: "\\s. P (ksSchedulerAction s)\ setObject p (pte::pte) \\_ s. P (ksSchedulerAction s)\" apply (rule setObject_nosch) apply (simp add: updateObject_default_def) apply wp apply simp done lemma setObject_pde_nosch [wp]: "\\s. P (ksSchedulerAction s)\ setObject p (pde::pde) \\_ s. P (ksSchedulerAction s)\" apply (rule setObject_nosch) apply (simp add: updateObject_default_def) apply wp apply simp done crunch nosch[wp]: setMRs "\s. P (ksSchedulerAction s)" (ignore: getRestartPC setRegister transferCapsToSlots wp: hoare_drop_imps hoare_vcg_split_case_option mapM_wp' simp: split_def zipWithM_x_mapM) crunch nosch [wp]: performARMMMUInvocation, performARMVCPUInvocation "\s. P (ksSchedulerAction s)" (ignore: getObject setObject wp: crunch_wps getObject_cte_inv getASID_wp) lemma arch_pinv_nosch[wp]: "\\s. P (ksSchedulerAction s)\ Arch.performInvocation invok \\rv s. P (ksSchedulerAction s)\" unfolding ARM_HYP_H.performInvocation_def by wpsimp lemmas setObject_cte_st_tcb_at' [wp] = setCTE_pred_tcb_at' [unfolded setCTE_def] crunch st_tcb_at': performPageDirectoryInvocation, performPageTableInvocation, performPageInvocation, performASIDPoolInvocation "st_tcb_at' P t" (ignore: getObject setObject wp: crunch_wps getASID_wp getObject_cte_inv FalseI simp: crunch_simps) crunch st_tcb_at': performARMVCPUInvocation "st_tcb_at' P t" (ignore: getObject setObject wp: crunch_wps simp: crunch_simps) lemma performASIDControlInvocation_st_tcb_at': "\st_tcb_at' (P and op \ Inactive and op \ IdleThreadState) t and valid_aci' aci and invs' and ct_active'\ performASIDControlInvocation aci \\y. st_tcb_at' P t\" apply (rule hoare_name_pre_state) apply (clarsimp simp: performASIDControlInvocation_def split: asidcontrol_invocation.splits) apply (clarsimp simp: valid_aci'_def cte_wp_at_ctes_of cong: conj_cong) apply (rule hoare_pre) apply (wp createObjects_orig_obj_at'[where P="P \ tcbState", folded st_tcb_at'_def] updateFreeIndex_pspace_no_overlap' getSlotCap_wp hoare_vcg_ex_lift deleteObjects_cte_wp_at' deleteObjects_invs_derivatives deleteObjects_st_tcb_at' static_imp_wp | simp add: placeNewObject_def2)+ apply (case_tac ctea) apply (clarsimp) apply (frule ctes_of_valid_cap') apply (simp add:invs_valid_objs')+ apply (clarsimp simp:valid_cap'_def capAligned_def cte_wp_at_ctes_of) apply (rule conjI) apply clarsimp apply (drule (1) cte_cap_in_untyped_range) apply (fastforce simp add: cte_wp_at_ctes_of) apply assumption+ subgoal by (clarsimp simp: invs'_def valid_state'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of) subgoal by fastforce apply simp apply (rule conjI,assumption) apply (clarsimp simp:invs_valid_pspace' objBits_simps archObjSize_def range_cover_full descendants_range'_def2 isCap_simps) apply (intro conjI) apply (fastforce simp:empty_descendants_range_in')+ apply clarsimp apply (drule (1) cte_cap_in_untyped_range) apply (fastforce simp add: cte_wp_at_ctes_of) apply assumption+ apply (clarsimp simp: invs'_def valid_state'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of) apply fastforce apply simp apply auto done lemma arch_pinv_st_tcb_at': "\valid_arch_inv' ai and st_tcb_at' (P and op \ Inactive and op \ IdleThreadState) t and invs' and ct_active'\ Arch.performInvocation ai \\rv. st_tcb_at' P t\" (is "?pre (pgi ai) ?post") proof(cases ai) txt {* The preservation rules for each invocation have already been proved by crunch, so this just becomes a case distinction. *} case InvokePage thus ?thesis by (simp add: ARM_HYP_H.performInvocation_def performARMMMUInvocation_def, wp performPageInvocation_st_tcb_at', fastforce elim!: pred_tcb'_weakenE) next case InvokeASIDControl thus ?thesis by (simp add: ARM_HYP_H.performInvocation_def performARMMMUInvocation_def valid_arch_inv'_def, wp performASIDControlInvocation_st_tcb_at', fastforce elim!: pred_tcb'_weakenE) next case InvokeASIDPool thus ?thesis by (simp add: ARM_HYP_H.performInvocation_def performARMMMUInvocation_def valid_arch_inv'_def, wp performASIDPoolInvocation_st_tcb_at', fastforce elim!: pred_tcb'_weakenE) next case InvokePageTable thus ?thesis by (simp add: ARM_HYP_H.performInvocation_def performARMMMUInvocation_def valid_arch_inv'_def, wp performPageTableInvocation_st_tcb_at', fastforce elim!: pred_tcb'_weakenE) next case InvokePageDirectory thus ?thesis by (simp add: ARM_HYP_H.performInvocation_def performARMMMUInvocation_def valid_arch_inv'_def, wp performPageDirectoryInvocation_st_tcb_at', fastforce elim!: pred_tcb'_weakenE) next case InvokeVCPU thus ?thesis by (simp add: ARM_HYP_H.performInvocation_def valid_arch_inv'_def, wp performARMVCPUInvocation_st_tcb_at', clarsimp elim!: pred_tcb'_weakenE) qed crunch aligned': "Arch.finaliseCap" pspace_aligned' (ignore: getObject wp: crunch_wps getASID_wp simp: crunch_simps) lemmas arch_finalise_cap_aligned' = finaliseCap_aligned' crunch distinct': "Arch.finaliseCap" pspace_distinct' (ignore: getObject wp: crunch_wps getASID_wp simp: crunch_simps) lemmas arch_finalise_cap_distinct' = finaliseCap_distinct' crunch nosch [wp]: "Arch.finaliseCap" "\s. P (ksSchedulerAction s)" (ignore: getObject wp: crunch_wps getASID_wp simp: crunch_simps updateObject_default_def) crunch st_tcb_at' [wp]: "Arch.finaliseCap" "st_tcb_at' P t" (ignore: getObject setObject wp: crunch_wps getASID_wp simp: crunch_simps) crunch typ_at' [wp]: "Arch.finaliseCap" "\s. P (typ_at' T p s)" (ignore: getObject setObject wp: crunch_wps getASID_wp simp: crunch_simps) crunch cte_wp_at': "Arch.finaliseCap" "cte_wp_at' P p" (ignore: getObject setObject wp: crunch_wps getASID_wp simp: crunch_simps) lemma invs_asid_table_strenghten': "invs' s \ asid_pool_at' ap s \ asid \ 2 ^ asid_high_bits - 1 \ invs' (s\ksArchState := armKSASIDTable_update (\_. (armKSASIDTable \ ksArchState) s(asid \ ap)) (ksArchState s)\)" apply (clarsimp simp: invs'_def valid_state'_def) apply (rule conjI) apply (clarsimp simp: valid_global_refs'_def global_refs'_def) apply (clarsimp simp: valid_arch_state'_def) apply (clarsimp simp: valid_asid_table'_def ran_def) apply (rule conjI) apply (clarsimp split: if_split_asm) apply fastforce apply (rule conjI) apply (clarsimp simp: valid_pspace'_def) apply (simp add: valid_machine_state'_def split: option.splits prod.splits) done lemma freeIndexUpdate_ex_cte: "\\s. ex_cte_cap_wp_to' (\_. True) slot s \ cte_wp_at' (\c. cteCap c = pcap) src s \ isUntypedCap pcap\ updateCap src (capFreeIndex_update (\_. idx) pcap) \\rv s. ex_cte_cap_wp_to' (\_. True) slot s\" apply (clarsimp simp:ex_cte_cap_wp_to'_def) apply (rule hoare_pre) apply (wps) apply (wp hoare_vcg_ex_lift updateCap_cte_wp_at_cases) apply (clarsimp simp:cte_wp_at_ctes_of isCap_simps) apply (rule_tac x = cref in exI) apply clarsimp done lemma ex_cte_not_in_untyped_range: "\(ctes_of s) cref = Some (CTE (capability.UntypedCap d ptr bits idx) mnode); descendants_of' cref (ctes_of s) = {}; invs' s; ex_cte_cap_wp_to' (\_. True) x s; valid_global_refs' s\ \ x \ {ptr .. ptr + 2 ^ bits - 1}" apply clarsimp apply (drule(1) cte_cap_in_untyped_range) apply (fastforce simp:cte_wp_at_ctes_of)+ done lemma performASIDControlInvocation_invs' [wp]: "\invs' and ct_active' and valid_aci' aci\ performASIDControlInvocation aci \\y. invs'\" apply (rule hoare_name_pre_state) apply (clarsimp simp: performASIDControlInvocation_def valid_aci'_def placeNewObject_def2 cte_wp_at_ctes_of split: asidcontrol_invocation.splits) apply (rename_tac w1 w2 w3 w4 cte ctea idx) apply (case_tac ctea) apply (clarsimp) apply (frule ctes_of_valid_cap') apply fastforce apply (rule hoare_pre) apply (wp hoare_vcg_const_imp_lift) apply (strengthen invs_asid_table_strenghten') apply (wp cteInsert_simple_invs) apply (wp createObjects'_wp_subst[OF createObjects_no_cte_invs [where sz = pageBits and ty="Inl (KOArch (KOASIDPool pool))"]] createObjects_orig_cte_wp_at'[where sz = pageBits] hoare_vcg_const_imp_lift |simp add: makeObjectKO_def projectKOs asid_pool_typ_at_ext' valid_cap'_def cong: rev_conj_cong |strengthen safe_parent_strg'[where idx= "2^ pageBits"])+ apply (rule hoare_vcg_conj_lift) apply (rule descendants_of'_helper) apply (wp createObjects_null_filter' [where sz = pageBits and ty="Inl (KOArch (KOASIDPool ap))"] createObjects_valid_pspace' [where sz = pageBits and ty="Inl (KOArch (KOASIDPool ap))"] | simp add: makeObjectKO_def projectKOs asid_pool_typ_at_ext' valid_cap'_def cong: rev_conj_cong)+ apply (simp add: objBits_simps archObjSize_def valid_cap'_def capAligned_def range_cover_full) apply (wp createObjects'_wp_subst[OF createObjects_ex_cte_cap_to[where sz = pageBits]] createObjects_orig_cte_wp_at'[where sz = pageBits] hoare_vcg_const_imp_lift |simp add: makeObjectKO_def projectKOs asid_pool_typ_at_ext' valid_cap'_def cong: rev_conj_cong |strengthen safe_parent_strg'[where idx = "2^ pageBits"])+ apply (simp add:asid_pool_typ_at_ext'[symmetric]) apply (wp createObject_typ_at') apply (simp add: objBits_simps archObjSize_def valid_cap'_def capAligned_def range_cover_full makeObjectKO_def projectKOs asid_pool_typ_at_ext' cong: rev_conj_cong) apply (clarsimp simp:conj_comms descendants_of_null_filter' | strengthen invs_pspace_aligned' invs_pspace_distinct' invs_pspace_aligned' invs_valid_pspace')+ apply (wp updateFreeIndex_forward_invs' updateFreeIndex_cte_wp_at updateFreeIndex_pspace_no_overlap' updateFreeIndex_caps_no_overlap'' updateFreeIndex_descendants_of2 updateFreeIndex_caps_overlap_reserved updateCap_cte_wp_at_cases freeIndexUpdate_ex_cte static_imp_wp getSlotCap_wp)+ apply (clarsimp simp:conj_comms ex_disj_distrib is_aligned_mask | strengthen invs_valid_pspace' invs_pspace_aligned' invs_pspace_distinct' empty_descendants_range_in')+ apply (wp deleteObjects_invs'[where p="makePoolParent aci"] hoare_vcg_ex_lift deleteObjects_caps_no_overlap''[where slot="makePoolParent aci"] deleteObject_no_overlap deleteObjects_cap_to'[where p="makePoolParent aci"] deleteObjects_ct_active'[where cref="makePoolParent aci"] deleteObjects_descendants[where p="makePoolParent aci"] deleteObjects_cte_wp_at' deleteObjects_null_filter[where p="makePoolParent aci"]) apply (frule valid_capAligned) apply (clarsimp simp: invs_mdb' invs_valid_pspace' capAligned_def cte_wp_at_ctes_of is_simple_cap'_def isCap_simps) apply (strengthen refl ctes_of_valid_cap'[mk_strg I E]) apply (clarsimp simp: conj_comms invs_valid_objs') apply (frule_tac ptr="w1" in descendants_range_caps_no_overlapI'[where sz = pageBits]) apply (fastforce simp:is_aligned_neg_mask_eq cte_wp_at_ctes_of) apply (simp add:empty_descendants_range_in') apply (frule(1) if_unsafe_then_capD'[OF _ invs_unsafe_then_cap',rotated]) apply (fastforce simp:cte_wp_at_ctes_of) apply (drule ex_cte_not_in_untyped_range[rotated -2]) apply (simp add:invs_valid_global')+ apply (drule ex_cte_not_in_untyped_range[rotated -2]) apply (simp add:invs_valid_global')+ apply (subgoal_tac "is_aligned (2 ^ pageBits) 4") prefer 2 apply (rule is_aligned_weaken) apply (rule is_aligned_shiftl_self[unfolded shiftl_t2n,where p = 1,simplified]) apply (simp add:pageBits_def) apply (frule_tac cte="CTE (capability.UntypedCap False a b c) m" for a b c m in valid_global_refsD', clarsimp) apply (simp add: is_aligned_neg_mask_eq Int_commute) by (auto simp:empty_descendants_range_in' objBits_simps max_free_index_def archObjSize_def asid_low_bits_def word_bits_def pageBits_def range_cover_full descendants_range'_def2 is_aligned_mask null_filter_descendants_of'[OF null_filter_simp'] valid_cap_simps' mask_def live'_def hyp_live'_def arch_live'_def) lemma doFlush_underlying_memory[wp]: "\ \m'. underlying_memory m' p = um \ doFlush flush_type vstart vend pstart \ \_ m'. underlying_memory m' p = um \" unfolding doFlush_def by(cases flush_type; wpsimp simp: Let_def) (* FIXME: move *) lemma dmo_invs'_simple: "no_irq f \ (\p um. \\m'. underlying_memory m' p = um\ f \\_ m'. underlying_memory m' p = um\) \ \ invs' \ doMachineOp f \ \y. invs' \" by (rule hoare_pre, rule dmo_invs', wp no_irq, simp_all add:valid_def split_def) (* FIXME: move *) lemma doFlush_invs[wp]: "\ invs' \ doMachineOp (doFlush flush_type vstart vend pstart) \ \y. invs' \" by(wp dmo_invs'_simple) lemma performPageDirectoryInvocation_invs'[wp]: "\ invs' \ performPageDirectoryInvocation pdi \ \rv. invs' \" by(cases pdi, simp_all add:performPageDirectoryInvocation_def, (wp|simp)+) lemma archThreadSet_ex_nonz_cap_to'[wp]: "archThreadSet f t \ex_nonz_cap_to' v\" unfolding ex_nonz_cap_to'_def cte_wp_at_ctes_of by wp lemma assoc_invs': "\invs' and ko_at' (vcpu\vcpuTCBPtr:= None\) v and obj_at' (\tcb. atcbVCPUPtr (tcbArch tcb) = None) t and ex_nonz_cap_to' v and ex_nonz_cap_to' t\ do archThreadSet (atcbVCPUPtr_update (\_. Just v)) t; setObject v $ vcpuTCBPtr_update (\_. Just t) vcpu od \\_. invs'\" unfolding invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def supply fun_upd_apply[simp del] apply (wpsimp wp: sch_act_wf_lift tcb_in_cur_domain'_lift valid_queues_lift setObject_tcb_valid_objs setObject_vcpu_valid_objs' setObject_state_refs_of' setObject_state_hyp_refs_of' valid_global_refs_lift' valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift valid_pde_mappings_lift' setObject_typ_at' cur_tcb_lift setVCPU_valid_arch' simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb valid_arch_tcb'_def | wp_once hoare_vcg_imp_lift)+ apply (drule (1) valid_objs_valid_vcpu') apply (clarsimp simp: valid_vcpu'_def) apply (rule conjI) apply (clarsimp simp: typ_at_to_obj_at_arches obj_at'_def) apply (rule conjI) apply (clarsimp simp: typ_at_tcb' obj_at'_def) supply fun_upd_apply[simp] apply (clarsimp simp: hyp_live'_def arch_live'_def) apply (rule_tac rfs'="state_hyp_refs_of' s" in delta_sym_refs, assumption) apply (clarsimp split: if_split_asm) apply (clarsimp simp: state_hyp_refs_of'_def obj_at'_def projectKOs tcb_vcpu_refs'_def split: option.splits if_split_asm) by (clarsimp simp: state_hyp_refs_of'_def obj_at'_def projectKOs split: option.splits if_split_asm) lemma setVCPU_archThreadSet_Some_eq: "do archThreadSet (atcbVCPUPtr_update (\_. Just v)) tcb; setObject v $ vcpuTCBPtr_update (\_. Just tcb) vcpu; f od = do do archThreadSet (atcbVCPUPtr_update (\_. Just v)) tcb; setObject v $ vcpuTCBPtr_update (\_. Just tcb) vcpu od; f od" by (simp add: bind_assoc) lemma asUser_obj_at_vcpu[wp]: "\obj_at' (P :: vcpu \ bool) t\ asUser t' f \\rv. obj_at' P t\" apply (simp add: asUser_def threadGet_stateAssert_gets_asUser) apply (wpsimp wp: threadSet_ko_wp_at2' simp: obj_at'_real_def) apply (simp add: asUser_fetch_def projectKOs split: option.splits) done lemma archThreadSet_obj_at'_vcpu[wp]: "archThreadSet f t \obj_at' (P::vcpu \ bool) p\" unfolding archThreadSet_def by (wpsimp wp: obj_at_setObject2 simp: updateObject_default_def in_monad) lemma asUser_atcbVCPUPtr[wp]: "asUser t' f \obj_at' (\t. P (atcbVCPUPtr (tcbArch t))) t\" unfolding asUser_def threadGet_stateAssert_gets_asUser by (wpsimp simp: asUser_fetch_def obj_at'_def projectKOs atcbContextGet_def atcbContextSet_def) lemma dissociateVCPUTCB_no_vcpu[wp]: "\\s. t \ t' \ obj_at' (\tcb. atcbVCPUPtr (tcbArch tcb) = None) t s\ dissociateVCPUTCB vcpu t' \\rv. obj_at' (\tcb. atcbVCPUPtr (tcbArch tcb) = None) t\" unfolding dissociateVCPUTCB_def by (wpsimp wp: getVCPU_wp setObject_tcb_strongest simp: archThreadSet_def archThreadGet_def) lemma dissociateVCPUTCB_no_tcb[wp]: "\ko_at' v vcpu\ dissociateVCPUTCB vcpu tcb \\rv. ko_at' (vcpuTCBPtr_update Map.empty v) vcpu\" unfolding dissociateVCPUTCB_def apply (wpsimp wp: obj_at_setObject3 getVCPU_wp simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def archThreadGet_def) apply (clarsimp simp: obj_at'_def) done lemma dissociateVCPUTCB_ex_nonz_cap_to'[wp]: "dissociateVCPUTCB v' t \ex_nonz_cap_to' v\" unfolding ex_nonz_cap_to'_def cte_wp_at_ctes_of by wp lemma associateVCPUTCB_invs'[wp]: "\invs' and ex_nonz_cap_to' vcpu and ex_nonz_cap_to' tcb\ associateVCPUTCB vcpu tcb \\_. invs'\" unfolding associateVCPUTCB_def setVCPU_archThreadSet_Some_eq apply (wpsimp wp: assoc_invs' getVCPU_wp) apply (rule_tac Q="\_. invs' and obj_at' (\tcb. atcbVCPUPtr (tcbArch tcb) = None) tcb and ex_nonz_cap_to' vcpu and ex_nonz_cap_to' tcb" in hoare_strengthen_post) apply wpsimp apply (clarsimp simp: obj_at'_def projectKOs) apply (rename_tac v obj) apply (case_tac v, simp) apply (wpsimp wp: getObject_tcb_wp simp: archThreadGet_def) apply clarsimp apply normalise_obj_at' apply (clarsimp simp: obj_at'_def projectKOs) apply (rename_tac v) apply (case_tac v, simp) done lemma setVCPU_vgic_vcpu_live[wp]: "\ko_wp_at' (is_vcpu' and hyp_live') p and ko_at' vcpu v\ setObject v (vcpuVGIC_update f' vcpu) \\_. ko_wp_at' (is_vcpu' and hyp_live') p\" apply (wp setObject_ko_wp_at, simp) apply (simp add: objBits_simps archObjSize_def) apply (clarsimp simp: vcpu_bits_def pageBits_def) apply (clarsimp simp: pred_conj_def is_vcpu'_def ko_wp_at'_def obj_at'_real_def projectKOs) done lemma setVCPU_vgic_valid_arch'[wp]: "\valid_arch_state' and ko_at' vcpu v\ setObject v (vcpuVGIC_update f' vcpu) \\_. valid_arch_state'\" apply (simp add: valid_arch_state'_def valid_asid_table'_def option_case_all_conv) apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift) apply (clarsimp simp: pred_conj_def o_def) done lemma setVCPU_vgic_invs'[wp]: "\invs' and ko_at' vcpu v\ setObject v (vcpuVGIC_update f' vcpu) \\_. invs'\" unfolding invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def supply fun_upd_apply[simp del] apply (wpsimp wp: setObject_vcpu_no_tcb_update [where f="\vcpu. vcpuVGIC_update f' vcpu"] sch_act_wf_lift tcb_in_cur_domain'_lift valid_queues_lift setObject_state_refs_of' setObject_state_hyp_refs_of' valid_global_refs_lift' valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift valid_pde_mappings_lift' setObject_typ_at' cur_tcb_lift simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) apply (fastforce simp: ko_wp_at'_def projectKOs) done lemma invokeVCPUInjectIRQ_invs'[wp]: "invokeVCPUInjectIRQ v ir idx \invs'\" unfolding invokeVCPUInjectIRQ_def apply (wpsimp wp: dmo_invs' simp: set_gic_vcpu_ctrl_lr_def machine_op_lift_def machine_rest_lift_def) apply (clarsimp simp: in_monad select_f_def) done lemma invokeVCPUReadReg_inv[wp]: "invokeVCPUReadReg vcpu r \P\" unfolding invokeVCPUReadReg_def readVCPUReg_def by (wpsimp wp: dmo_inv' simp: getSCTLR_def vcpuregs_gets) lemma setVCPU_regs_vcpu_live[wp]: "\ko_wp_at' (is_vcpu' and hyp_live') p and ko_at' vcpu v\ setObject v (vcpuRegs_update f' vcpu) \\_. ko_wp_at' (is_vcpu' and hyp_live') p\" apply (wp setObject_ko_wp_at, simp) apply (simp add: objBits_simps archObjSize_def) apply (clarsimp simp: vcpu_bits_def pageBits_def) apply (clarsimp simp: pred_conj_def is_vcpu'_def ko_wp_at'_def obj_at'_real_def projectKOs) done lemma setVCPU_regs_valid_arch'[wp]: "\valid_arch_state' and ko_at' vcpu v\ setObject v (vcpuRegs_update f' vcpu) \\_. valid_arch_state'\" apply (simp add: valid_arch_state'_def valid_asid_table'_def option_case_all_conv) apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift) apply (clarsimp simp: pred_conj_def o_def) done lemma setVCPU_regs_invs'[wp]: "\invs' and ko_at' vcpu v\ setObject v (vcpuRegs_update f' vcpu) \\_. invs'\" unfolding invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def supply fun_upd_apply[simp del] apply (wpsimp wp: setObject_vcpu_no_tcb_update [where f="\vcpu. vcpuRegs_update f' vcpu"] sch_act_wf_lift tcb_in_cur_domain'_lift valid_queues_lift setObject_state_refs_of' setObject_state_hyp_refs_of' valid_global_refs_lift' valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift valid_pde_mappings_lift' setObject_typ_at' cur_tcb_lift simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) apply (fastforce simp: ko_wp_at'_def projectKOs) done lemma invokeVCPUWriteReg_invs'[wp]: "invokeVCPUWriteReg vcpu r v \invs'\" unfolding invokeVCPUWriteReg_def writeVCPUReg_def by (wpsimp wp: dmo_machine_op_lift_invs' simp: setSCTLR_def vcpuregs_sets) lemma performARMVCPUInvocation_invs'[wp]: "\invs' and valid_vcpuinv' i\ performARMVCPUInvocation i \\_. invs'\" unfolding performARMVCPUInvocation_def valid_vcpuinv'_def by wpsimp lemma arch_performInvocation_invs': "\invs' and ct_active' and valid_arch_inv' invocation\ Arch.performInvocation invocation \\rv. invs'\" unfolding ARM_HYP_H.performInvocation_def by (cases invocation, simp_all add: performARMMMUInvocation_def valid_arch_inv'_def, (wp|simp)+) end end