(* * 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) *) (* ARM VSpace refinement *) theory VSpace_R imports TcbAcc_R begin context Arch begin global_naming ARM (*FIXME: arch_split*) lemmas store_pte_typ_ats[wp] = store_pte_typ_ats abs_atyp_at_lifts[OF store_pte_typ_at] lemmas store_pde_typ_ats[wp] = store_pde_typ_ats abs_atyp_at_lifts[OF store_pde_typ_at] end context begin interpretation Arch . (*FIXME: arch_split*) definition "pd_at_asid' pd asid \ \s. \ap pool. armKSASIDTable (ksArchState s) (ucast (asid_high_bits_of asid)) = Some ap \ ko_at' (ASIDPool pool) ap s \ pool (asid && mask asid_low_bits) = Some pd \ page_directory_at' pd s" defs checkPDASIDMapMembership_def: "checkPDASIDMapMembership pd asids \ stateAssert (\s. pd \ ran ((option_map snd o armKSASIDMap (ksArchState s) |` (- set asids)))) []" crunch inv[wp]:checkPDAt P lemma findPDForASID_pd_at_wp: "\\s. \pd. (page_directory_at' pd s \ pd_at_asid' pd asid s) \ P pd s\ findPDForASID asid \P\,-" apply (simp add: findPDForASID_def assertE_def cong: option.case_cong split del: if_split) apply (rule hoare_pre) apply (wp getASID_wp | wpc | simp add: o_def split del: if_split)+ apply (clarsimp simp: pd_at_asid'_def) apply (case_tac ko, simp) apply (subst(asm) inv_f_f) apply (rule inj_onI, simp+) apply fastforce done lemma findPDForASIDAssert_pd_at_wp: "\(\s. \pd. pd_at_asid' pd asid s \ pd \ ran ((option_map snd o armKSASIDMap (ksArchState s) |` (- {asid}))) \ P pd s)\ findPDForASIDAssert asid \P\" apply (simp add: findPDForASIDAssert_def const_def checkPDAt_def checkPDUniqueToASID_def checkPDASIDMapMembership_def) apply (rule hoare_pre, wp getPDE_wp findPDForASID_pd_at_wp) apply simp done crunch inv[wp]: findPDForASIDAssert "P" (simp: const_def crunch_simps wp: loadObject_default_inv crunch_wps ignore_del: getObject) lemma pspace_relation_pd: assumes p: "pspace_relation (kheap a) (ksPSpace c)" assumes pa: "pspace_aligned a" assumes pad: "pspace_aligned' c" "pspace_distinct' c" assumes t: "page_directory_at p a" shows "page_directory_at' p c" using assms pd_aligned [OF pa t] apply (clarsimp simp: obj_at_def) apply (drule(1) pspace_relation_absD) apply (clarsimp split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) apply (clarsimp simp: page_directory_at'_def pdBits_def pageBits_def typ_at_to_obj_at_arches pdeBits_def) apply (drule_tac x="ucast y" in spec, clarsimp) apply (simp add: ucast_ucast_mask iffD2 [OF mask_eq_iff_w2p] word_size) apply (clarsimp simp add: pde_relation_def) apply (drule(2) aligned_distinct_pde_atI') apply (erule obj_at'_weakenE) apply simp done lemma find_pd_for_asid_eq_helper: "\ vspace_at_asid asid pd s; valid_vspace_objs s; asid \ 0; pspace_aligned s \ \ find_pd_for_asid asid s = returnOk pd s \ page_directory_at pd s \ is_aligned pd pdBits" apply (clarsimp simp: vspace_at_asid_def valid_vspace_objs_def) apply (frule spec, drule mp, erule exI) apply (clarsimp simp: vs_asid_refs_def graph_of_def elim!: vs_lookupE) apply (erule rtranclE) apply simp apply (clarsimp dest!: vs_lookup1D) apply (erule rtranclE) defer apply (drule vs_lookup1_trans_is_append') apply (clarsimp dest!: vs_lookup1D) apply (clarsimp dest!: vs_lookup1D) apply (drule spec, drule mp, rule exI, rule vs_lookupI[unfolded vs_asid_refs_def]) apply (rule image_eqI[OF refl]) apply (erule graph_ofI) apply clarsimp apply (rule rtrancl.intros(1)) apply (clarsimp simp: vs_refs_def graph_of_def split: Structures_A.kernel_object.splits arch_kernel_obj.splits) apply (clarsimp simp: obj_at_def) apply (drule bspec, erule ranI) apply clarsimp apply (drule ucast_up_inj, simp) apply (simp add: find_pd_for_asid_def bind_assoc word_neq_0_conv[symmetric] liftE_bindE) apply (simp add: exec_gets liftE_bindE bind_assoc get_asid_pool_def get_object_def) apply (simp add: mask_asid_low_bits_ucast_ucast) apply (drule ucast_up_inj, simp) apply (clarsimp simp: returnOk_def get_pde_def get_pd_def get_object_def bind_assoc) apply (frule(1) pspace_alignedD[where p=pd]) apply (simp add: pdBits_def pageBits_def pdeBits_def) done lemma find_pd_for_asid_assert_eq: "\ vspace_at_asid asid pd s; valid_vspace_objs s; asid \ 0; pspace_aligned s \ \ find_pd_for_asid_assert asid s = return pd s" apply (drule(3) find_pd_for_asid_eq_helper) apply (simp add: find_pd_for_asid_assert_def catch_def bind_assoc) apply (clarsimp simp: returnOk_def obj_at_def a_type_def cong: bind_apply_cong) apply (clarsimp split: Structures_A.kernel_object.splits arch_kernel_obj.splits if_split_asm) apply (simp add: get_pde_def get_pd_def get_object_def bind_assoc is_aligned_neg_mask_eq pd_bits_def pdBits_def pdeBits_def pageBits_def) apply (simp add: exec_gets) done lemma find_pd_for_asid_valids: "\ vspace_at_asid asid pd and valid_vspace_objs and pspace_aligned and K (asid \ 0) \ find_pd_for_asid asid \\rv s. pde_at rv s\,-" "\ vspace_at_asid asid pd and valid_vspace_objs and pspace_aligned and K (asid \ 0) and K (is_aligned pd pdBits \ P pd) \ find_pd_for_asid asid \\rv s. P rv\,-" "\ vspace_at_asid asid pd and valid_vspace_objs and pspace_aligned and K (asid \ 0) and pd_at_uniq asid pd \ find_pd_for_asid asid \\rv s. pd_at_uniq asid rv s\,-" "\ vspace_at_asid asid pd and valid_vspace_objs and pspace_aligned and K (asid \ 0) \ find_pd_for_asid asid -,\\\\" apply (simp_all add: validE_def validE_R_def validE_E_def valid_def split: sum.split) apply (auto simp: returnOk_def return_def pdeBits_def pde_at_def pd_bits_def pdBits_def pageBits_def is_aligned_neg_mask_eq dest!: find_pd_for_asid_eq_helper elim!: is_aligned_weaken) done lemma asidBits_asid_bits[simp]: "asidBits = asid_bits" by (simp add: asid_bits_def asidBits_def asidHighBits_def asid_low_bits_def) lemma find_pd_for_asid_assert_corres: "corres (\rv rv'. rv = pd \ rv' = pd) (K (asid \ 0 \ asid \ mask asid_bits) and pspace_aligned and pspace_distinct and valid_vspace_objs and valid_asid_map and vspace_at_asid asid pd and pd_at_uniq asid pd) (pspace_aligned' and pspace_distinct' and no_0_obj') (find_pd_for_asid_assert asid) (findPDForASIDAssert asid)" apply (simp add: find_pd_for_asid_assert_def const_def findPDForASIDAssert_def liftM_def) apply (rule corres_guard_imp) apply (rule corres_split_eqr) apply (rule_tac F="is_aligned pda pdBits \ pda = pd" in corres_gen_asm) apply (clarsimp simp add: is_aligned_mask[symmetric]) apply (rule_tac P="pde_at pd and pd_at_uniq asid pd and pspace_aligned and pspace_distinct and vspace_at_asid asid pd and valid_asid_map" and P'="pspace_aligned' and pspace_distinct'" in stronger_corres_guard_imp) apply (rule corres_symb_exec_l[where P="pde_at pd and pd_at_uniq asid pd and valid_asid_map and vspace_at_asid asid pd"]) apply (rule corres_symb_exec_r[where P'="page_directory_at' pd"]) apply (simp add: checkPDUniqueToASID_def ran_option_map checkPDASIDMapMembership_def) apply (rule_tac P'="pd_at_uniq asid pd" in corres_stateAssert_implied) apply (simp add: gets_def bind_assoc[symmetric] stateAssert_def[symmetric, where L="[]"]) apply (rule_tac P'="valid_asid_map and vspace_at_asid asid pd" in corres_stateAssert_implied) apply (rule corres_trivial, simp) apply (clarsimp simp: state_relation_def arch_state_relation_def valid_asid_map_def split: option.split) apply (drule bspec, erule graph_ofI) apply clarsimp apply (drule(1) pd_at_asid_unique2) apply simp apply (clarsimp simp: state_relation_def arch_state_relation_def pd_at_uniq_def ran_option_map) apply wp+ apply (simp add: checkPDAt_def stateAssert_def) apply (rule no_fail_pre, wp) apply simp apply (clarsimp simp: pde_at_def obj_at_def a_type_def) apply (clarsimp split: Structures_A.kernel_object.splits arch_kernel_obj.splits if_split_asm) apply (simp add: get_pde_def exs_valid_def bind_def return_def get_pd_def get_object_def simpler_gets_def) apply wp apply simp apply (simp add: get_pde_def get_pd_def) apply (rule no_fail_pre) apply (wp get_object_wp | wpc)+ apply (clarsimp simp: pde_at_def obj_at_def a_type_def) apply (clarsimp split: Structures_A.kernel_object.splits arch_kernel_obj.splits if_split_asm) apply simp apply (clarsimp simp: state_relation_def) apply (erule(3) pspace_relation_pd) apply (simp add: pde_at_def pd_bits_def pdBits_def is_aligned_neg_mask_eq pdeBits_def pageBits_def) apply (rule corres_split_catch [OF _ find_pd_for_asid_corres'[where pd=pd]]) apply (rule_tac P="\" and P'="\" in corres_inst) apply (simp add: corres_fail) apply (wp find_pd_for_asid_valids[where pd=pd])+ apply (clarsimp simp: word_neq_0_conv valid_vspace_objs_def) apply simp done lemma findPDForASIDAssert_known_corres: "corres r P P' f (g pd) \ corres r (vspace_at_asid asid pd and pd_at_uniq asid pd and valid_vspace_objs and valid_asid_map and pspace_aligned and pspace_distinct and K (asid \ 0 \ asid \ mask asid_bits) and P) (P' and pspace_aligned' and pspace_distinct' and no_0_obj') f (findPDForASIDAssert asid >>= g)" apply (subst return_bind[symmetric]) apply (subst corres_cong [OF refl refl _ refl refl]) apply (rule bind_apply_cong [OF _ refl]) apply clarsimp apply (erule(3) find_pd_for_asid_assert_eq[symmetric]) apply (rule corres_guard_imp) apply (rule corres_split [OF _ find_pd_for_asid_assert_corres[where pd=pd]]) apply simp apply wp+ apply clarsimp apply simp done lemma load_hw_asid_corres: "corres (=) (valid_vspace_objs and pspace_distinct and pspace_aligned and valid_asid_map and vspace_at_asid a pd and (\s. \pd. vspace_at_asid a pd s \ pd_at_uniq a pd s) and K (a \ 0 \ a \ mask asid_bits)) (pspace_aligned' and pspace_distinct' and no_0_obj') (load_hw_asid a) (loadHWASID a)" apply (simp add: load_hw_asid_def loadHWASID_def) apply (rule_tac r'="(=)" in corres_split' [OF _ _ gets_sp gets_sp]) apply (clarsimp simp: state_relation_def arch_state_relation_def) apply (case_tac "rv' a") apply simp apply (rule corres_guard_imp) apply (rule_tac pd=pd in findPDForASIDAssert_known_corres) apply (rule corres_trivial, simp) apply clarsimp apply clarsimp apply clarsimp apply (rule corres_guard_imp) apply (rule_tac pd=b in findPDForASIDAssert_known_corres) apply (rule corres_trivial, simp) apply (clarsimp simp: valid_arch_state_def valid_asid_map_def) apply (drule subsetD, erule domI) apply (drule bspec, erule graph_ofI) apply clarsimp apply simp done crunch inv[wp]: loadHWASID "P" (wp: crunch_wps) lemma store_hw_asid_corres: "corres dc (vspace_at_asid a pd and pd_at_uniq a pd and valid_vspace_objs and pspace_distinct and pspace_aligned and K (a \ 0 \ a \ mask asid_bits) and valid_asid_map) (pspace_aligned' and pspace_distinct' and no_0_obj') (store_hw_asid a h) (storeHWASID a h)" apply (simp add: store_hw_asid_def storeHWASID_def) apply (rule corres_guard_imp) apply (rule corres_split [OF _ find_pd_for_asid_assert_corres[where pd=pd]]) apply (rule corres_split_eqr) apply (rule corres_split) prefer 2 apply (rule corres_trivial, rule corres_modify) apply (clarsimp simp: state_relation_def) apply (simp add: arch_state_relation_def) apply (rule ext) apply simp apply (rule corres_split_eqr) apply (rule corres_trivial, rule corres_modify) apply (clarsimp simp: state_relation_def arch_state_relation_def) apply (rule ext) apply simp apply (rule corres_trivial) apply (clarsimp simp: state_relation_def arch_state_relation_def) apply ((wp | simp)+)[4] apply (rule corres_trivial) apply (clarsimp simp: state_relation_def arch_state_relation_def) apply (wp | simp)+ done lemma invalidate_asid_corres: "corres dc (valid_asid_map and valid_vspace_objs and pspace_aligned and pspace_distinct and vspace_at_asid a pd and pd_at_uniq a pd and K (a \ 0 \ a \ mask asid_bits)) (pspace_aligned' and pspace_distinct' and no_0_obj') (invalidate_asid a) (invalidateASID a)" (is "corres dc ?P ?P' ?f ?f'") apply (simp add: invalidate_asid_def invalidateASID_def) apply (rule corres_guard_imp) apply (rule_tac pd=pd in findPDForASIDAssert_known_corres) apply (rule_tac P="?P" and P'="?P'" in corres_inst) apply (rule_tac r'="(=)" in corres_split' [OF _ _ gets_sp gets_sp]) apply (clarsimp simp: state_relation_def arch_state_relation_def) apply (rule corres_modify) apply (simp add: state_relation_def arch_state_relation_def fun_upd_def) apply simp apply simp done lemma invalidate_asid_ext_corres: "corres dc (\s. \pd. valid_asid_map s \ valid_vspace_objs s \ pspace_aligned s \ pspace_distinct s \ vspace_at_asid a pd s \ pd_at_uniq a pd s \ a \ 0 \ a \ mask asid_bits) (pspace_aligned' and pspace_distinct' and no_0_obj') (invalidate_asid a) (invalidateASID a)" apply (insert invalidate_asid_corres) apply (clarsimp simp: corres_underlying_def) apply fastforce done lemma invalidate_hw_asid_entry_corres: "corres dc \ \ (invalidate_hw_asid_entry a) (invalidateHWASIDEntry a)" apply (simp add: invalidate_hw_asid_entry_def invalidateHWASIDEntry_def) apply (rule corres_guard_imp) apply (rule corres_split_eqr) apply (rule corres_trivial, rule corres_modify) defer apply (rule corres_trivial) apply (wp | clarsimp simp: state_relation_def arch_state_relation_def)+ apply (rule ext) apply simp done lemma find_free_hw_asid_corres: "corres (=) (valid_asid_map and valid_vspace_objs and pspace_aligned and pspace_distinct and (unique_table_refs o caps_of_state) and valid_vs_lookup and valid_arch_state and valid_global_objs) (pspace_aligned' and pspace_distinct' and no_0_obj') find_free_hw_asid findFreeHWASID" apply (simp add: find_free_hw_asid_def findFreeHWASID_def) apply (rule corres_guard_imp) apply (rule corres_split_eqr [OF _ corres_trivial]) apply (rule corres_split_eqr [OF _ corres_trivial]) apply (subgoal_tac "take (length [minBound .e. maxBound :: hardware_asid]) ([next_asid .e. maxBound] @ [minBound .e. next_asid]) = [next_asid .e. maxBound] @ init [minBound .e. next_asid]") apply (cut_tac option="find (\a. hw_asid_table a = None) ([next_asid .e. maxBound] @ init [minBound .e. next_asid])" in option.nchotomy[rule_format]) apply (erule corres_disj_division) apply (clarsimp split del: if_split) apply (rule corres_split [OF _ invalidate_asid_ext_corres]) apply (rule corres_split' [where r'=dc]) apply (rule corres_trivial, rule corres_machine_op) apply (rule corres_no_failI) apply (rule no_fail_invalidateLocalTLB_ASID) apply fastforce apply (rule corres_split) prefer 2 apply (rule invalidate_hw_asid_entry_corres) apply (rule corres_split) apply (rule corres_trivial) apply simp apply (rule corres_trivial) apply (rule corres_modify) apply (simp add: minBound_word maxBound_word state_relation_def arch_state_relation_def) apply (wp | simp split del: if_split)+ apply (rule corres_trivial, clarsimp) apply (cut_tac x=next_asid in leq_maxBound) apply (simp only: word_le_nat_alt) apply (simp add: init_def upto_enum_word minBound_word del: upt.simps) apply (wp | clarsimp simp: arch_state_relation_def state_relation_def)+ apply (clarsimp dest!: findNoneD) apply (drule bspec, rule UnI1, simp, rule order_refl) apply (clarsimp simp: valid_arch_state_def) apply (frule(1) is_inv_SomeD) apply (clarsimp simp: valid_asid_map_def) apply (frule bspec, erule graph_ofI, clarsimp) apply (frule pd_at_asid_uniq, simp_all add: valid_asid_map_def valid_arch_state_def)[1] apply (drule subsetD, erule domI) apply simp apply (simp add: valid_vspace_objs_def) apply fastforce apply clarsimp done crunch aligned'[wp]: findFreeHWASID "pspace_aligned'" (simp: crunch_simps) crunch distinct'[wp]: findFreeHWASID "pspace_distinct'" (simp: crunch_simps) crunch no_0_obj'[wp]: getHWASID "no_0_obj'" lemma get_hw_asid_corres: "corres (=) (vspace_at_asid a pd and K (a \ 0 \ a \ mask asid_bits) and unique_table_refs o caps_of_state and valid_global_objs and valid_vs_lookup and valid_asid_map and valid_vspace_objs and pspace_aligned and pspace_distinct and valid_arch_state) (pspace_aligned' and pspace_distinct' and no_0_obj') (get_hw_asid a) (getHWASID a)" apply (simp add: get_hw_asid_def getHWASID_def) apply (rule corres_guard_imp) apply (rule corres_split_eqr [OF _ load_hw_asid_corres[where pd=pd]]) apply (case_tac maybe_hw_asid, simp_all)[1] apply clarsimp apply (rule corres_split_eqr [OF _ find_free_hw_asid_corres]) apply (rule corres_split [OF _ store_hw_asid_corres[where pd=pd]]) apply (rule corres_trivial, simp ) apply (wpsimp wp: load_hw_asid_wp)+ apply (simp add: pd_at_asid_uniq) apply simp done lemma setCurrentPD_to_abs: "setCurrentPD = set_current_pd" by (rule ext) (clarsimp simp: set_current_pd_def setCurrentPD_def writeTTBR0Ptr_def fromPAddr_def) lemma arm_context_switch_corres: "corres dc (vspace_at_asid a pd and K (a \ 0 \ a \ mask asid_bits) and unique_table_refs o caps_of_state and valid_global_objs and valid_vs_lookup and valid_asid_map and valid_vspace_objs and pspace_aligned and pspace_distinct and valid_arch_state) (pspace_aligned' and pspace_distinct' and no_0_obj') (arm_context_switch pd a) (armv_contextSwitch pd a)" apply (simp add: arm_context_switch_def armv_contextSwitch_def armv_contextSwitch_HWASID_def) apply (rule corres_guard_imp) apply (rule corres_split_eqr [OF _ get_hw_asid_corres[where pd=pd]]) apply (rule corres_machine_op) apply (simp add: setCurrentPD_to_abs) apply (rule corres_rel_imp) apply (rule corres_underlying_trivial) apply (rule no_fail_pre) apply (wpsimp wp: no_fail_set_current_pd no_fail_setHardwareASID no_irq_set_current_pd simp: setCurrentPD_to_abs)+ done lemma hv_corres: "corres (fr \ dc) (tcb_at thread) (tcb_at' thread) (handle_vm_fault thread fault) (handleVMFault thread fault)" apply (simp add: ARM_H.handleVMFault_def) apply (cases fault) apply simp apply (rule corres_guard_imp) apply (rule corres_splitEE) prefer 2 apply simp apply (rule corres_machine_op [where r="(=)"]) apply (rule corres_Id, rule refl, simp) apply (rule no_fail_getFAR) apply (rule corres_splitEE) prefer 2 apply simp apply (rule corres_machine_op [where r="(=)"]) apply (rule corres_Id, rule refl, simp) apply (rule no_fail_getDFSR) apply (rule corres_trivial, simp add: arch_fault_map_def) apply wp+ apply simp+ apply (rule corres_guard_imp) apply (rule corres_splitEE) prefer 2 apply simp apply (rule corres_as_user') apply (rule corres_no_failI [where R="(=)"]) apply (rule no_fail_getRestartPC) apply fastforce apply (rule corres_splitEE) prefer 2 apply simp apply (rule corres_machine_op [where r="(=)"]) apply (rule corres_Id, rule refl, simp) apply (rule no_fail_getIFSR) apply (rule corres_trivial, simp add: arch_fault_map_def) apply wp+ apply simp+ done lemma flush_space_corres: "corres dc (K (asid \ mask asid_bits \ asid \ 0) and valid_asid_map and valid_vspace_objs and pspace_aligned and pspace_distinct and unique_table_refs o caps_of_state and valid_global_objs and valid_vs_lookup and valid_arch_state and vspace_at_asid asid pd) (pspace_aligned' and pspace_distinct' and no_0_obj') (flush_space asid) (flushSpace asid)" apply (simp add: flushSpace_def flush_space_def) apply (rule corres_guard_imp) apply (rule corres_split) prefer 2 apply (rule load_hw_asid_corres[where pd=pd]) apply (rule corres_split [where R="\_. \" and R'="\_. \"]) prefer 2 apply (rule corres_machine_op [where r=dc]) apply (rule corres_Id, rule refl, simp) apply (rule no_fail_cleanCaches_PoU) apply (case_tac maybe_hw_asid) apply simp apply clarsimp apply (rule corres_machine_op) apply (rule corres_Id, rule refl, simp) apply (rule no_fail_invalidateLocalTLB_ASID) apply wp+ apply clarsimp apply (simp add: pd_at_asid_uniq) apply simp done lemma invalidate_tlb_by_asid_corres: "corres dc (K (asid \ mask asid_bits \ asid \ 0) and valid_asid_map and valid_vspace_objs and pspace_aligned and pspace_distinct and unique_table_refs o caps_of_state and valid_global_objs and valid_vs_lookup and valid_arch_state and vspace_at_asid asid pd) (pspace_aligned' and pspace_distinct' and no_0_obj') (invalidate_tlb_by_asid asid) (invalidateTLBByASID asid)" apply (simp add: invalidate_tlb_by_asid_def invalidateTLBByASID_def) apply (rule corres_guard_imp) apply (rule corres_split [where R="\_. \" and R'="\_. \"]) prefer 2 apply (rule load_hw_asid_corres[where pd=pd]) apply (case_tac maybe_hw_asid) apply simp apply clarsimp apply (rule corres_machine_op) apply (rule corres_Id, rule refl, simp) apply (rule no_fail_invalidateLocalTLB_ASID) apply wp+ apply clarsimp apply (simp add: pd_at_asid_uniq) apply simp done lemma invalidate_tlb_by_asid_corres_ex: "corres dc (\s. asid \ mask asid_bits \ asid \ 0 \ valid_asid_map s \ valid_vspace_objs s \ pspace_aligned s \ pspace_distinct s \ unique_table_refs (caps_of_state s) \ valid_global_objs s \ valid_vs_lookup s \ valid_arch_state s \ (\pd. vspace_at_asid asid pd s)) (pspace_aligned' and pspace_distinct' and no_0_obj') (invalidate_tlb_by_asid asid) (invalidateTLBByASID asid)" apply (rule corres_name_pre, clarsimp) apply (rule corres_guard_imp) apply (rule_tac pd=pd in invalidate_tlb_by_asid_corres) apply simp+ done crunch valid_global_objs[wp]: do_machine_op "valid_global_objs" lemma state_relation_asid_map: "(s, s') \ state_relation \ armKSASIDMap (ksArchState s') = arm_asid_map (arch_state s)" by (simp add: state_relation_def arch_state_relation_def) lemma find_pd_for_asid_pd_at_asid_again: "\\s. (\pd. vspace_at_asid asid pd s \ P pd s) \ (\ex. (\pd. \ vspace_at_asid asid pd s) \ Q ex s) \ valid_vspace_objs s \ pspace_aligned s \ asid \ 0\ find_pd_for_asid asid \P\,\Q\" apply (unfold validE_def, rule hoare_name_pre_state, fold validE_def) apply (case_tac "\pd. vspace_at_asid asid pd s") apply clarsimp apply (rule_tac Q="\rv s'. s' = s \ rv = pd" and E="\\" in hoare_post_impErr) apply (rule hoare_pre, wp find_pd_for_asid_valids) apply fastforce apply simp+ apply (rule_tac Q="\rv s'. s' = s \ vspace_at_asid asid rv s'" and E="\rv s'. s' = s" in hoare_post_impErr) apply (rule hoare_pre, wp) apply clarsimp+ done lemmas setCurrentPD_no_fails = no_fail_dsb no_fail_isb no_fail_writeTTBR0 lemmas setCurrentPD_no_irqs = no_irq_dsb no_irq_isb no_irq_writeTTBR0 lemma setCurrentPD_corres: "corres dc \ \ (do_machine_op (setCurrentPD addr)) (doMachineOp (setCurrentPD addr))" apply (simp add: setCurrentPD_def writeTTBR0Ptr_def) apply (rule corres_machine_op) apply (rule corres_guard_imp) apply (rule corres_split_eqr) apply (rule corres_split_eqr) apply (rule corres_rel_imp) apply (wp | rule corres_underlying_trivial | rule setCurrentPD_no_fails | rule setCurrentPD_no_irqs | simp add: dc_def)+ done lemma set_vm_root_corres: "corres dc (tcb_at t and valid_arch_state and valid_objs and valid_asid_map and unique_table_refs o caps_of_state and valid_vs_lookup and valid_global_objs and pspace_aligned and pspace_distinct and valid_vspace_objs) (pspace_aligned' and pspace_distinct' and valid_arch_state' and tcb_at' t and no_0_obj') (set_vm_root t) (setVMRoot t)" proof - have P: "corres dc \ \ (do global_pd \ gets (arm_global_pd \ arch_state); do_machine_op (setCurrentPD (addrFromPPtr global_pd)) od) (do globalPD \ gets (armKSGlobalPD \ ksArchState); doMachineOp (setCurrentPD (addrFromPPtr globalPD)) od)" apply (rule corres_guard_imp) apply (rule corres_split_eqr) apply (rule setCurrentPD_corres) apply (subst corres_gets) apply (clarsimp simp: state_relation_def arch_state_relation_def) apply (wp | simp)+ done have Q: "\P P'. corres dc P P' (throwError ExceptionTypes_A.lookup_failure.InvalidRoot (\_ . do global_pd \ gets (arm_global_pd \ arch_state); do_machine_op $ setCurrentPD $ addrFromPPtr global_pd od)) (throwError Fault_H.lookup_failure.InvalidRoot (\_ . do globalPD \ gets (armKSGlobalPD \ ksArchState); doMachineOp $ setCurrentPD $ addrFromPPtr globalPD od))" apply (rule corres_guard_imp) apply (rule corres_split_catch [where f=lfr]) apply (simp, rule P) apply (subst corres_throwError, simp add: lookup_failure_map_def) apply (wp | simp)+ done show ?thesis unfolding set_vm_root_def setVMRoot_def locateSlot_conv getThreadVSpaceRoot_def setCurrentPD_to_abs[symmetric] apply (rule corres_guard_imp) apply (rule corres_split' [where r'="(=) \ cte_map"]) apply (simp add: tcbVTableSlot_def cte_map_def objBits_def cte_level_bits_def objBitsKO_def tcb_cnode_index_def to_bl_1) apply (rule_tac R="\thread_root. valid_arch_state and valid_asid_map and valid_vspace_objs and valid_vs_lookup and unique_table_refs o caps_of_state and valid_global_objs and valid_objs and pspace_aligned and pspace_distinct and cte_wp_at ((=) thread_root) thread_root_slot" and R'="\thread_root. pspace_aligned' and pspace_distinct' and no_0_obj'" in corres_split [OF _ getSlotCap_corres]) apply (insert Q) apply (case_tac rv, simp_all add: isCap_simps Q[simplified])[1] apply (rename_tac arch_cap) apply (case_tac arch_cap, simp_all add: isCap_simps Q[simplified])[1] apply (rename_tac word option) apply (case_tac option, simp_all add: Q[simplified])[1] apply (clarsimp simp: cap_asid_def) apply (rule corres_guard_imp) apply (rule corres_split_catch [where f=lfr]) apply (simp add: checkPDNotInASIDMap_def checkPDASIDMapMembership_def) apply (rule_tac P'="(Not \ vspace_at_asid aa word) and K (aa \ mask asid_bits) and pd_at_uniq aa word and valid_asid_map and valid_vs_lookup and (unique_table_refs o caps_of_state) and valid_vspace_objs and valid_global_objs and valid_arch_state" in corres_stateAssert_implied) apply (rule P) apply (clarsimp simp: restrict_map_def state_relation_asid_map elim!: ranE) apply (frule(1) valid_asid_mapD) apply (case_tac "x = aa") apply clarsimp apply (clarsimp simp: pd_at_uniq_def restrict_map_def) apply (erule notE, rule_tac a=x in ranI) apply simp apply (rule corres_split_eqrE [OF _ find_pd_for_asid_corres]) apply (rule whenE_throwError_corres) apply (simp add: lookup_failure_map_def) apply simp apply simp apply (rule arm_context_switch_corres) apply ((wp find_pd_for_asid_pd_at_asid_again | simp add: if_apply_def2 | wp (once) hoare_drop_imps)+) apply clarsimp apply (frule page_directory_cap_pd_at_uniq, simp+) apply (frule(1) cte_wp_at_valid_objs_valid_cap) apply (clarsimp simp: valid_cap_def mask_def word_neq_0_conv) apply (drule(1) pd_at_asid_unique2, simp) apply simp+ apply (wp get_cap_wp | simp)+ apply (clarsimp simp: tcb_at_cte_at_1 [simplified]) apply simp done qed lemma invalidateTLBByASID_invs'[wp]: "\invs'\ invalidateTLBByASID param_a \\_. invs'\" apply (clarsimp simp: invalidateTLBByASID_def loadHWASID_def | wp dmo_invs' no_irq_invalidateLocalTLB_ASID no_irq | wpc)+ apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" in use_valid) apply (clarsimp simp: invalidateLocalTLB_ASID_def machine_op_lift_def machine_rest_lift_def split_def | wp)+ done crunches flushSpace for aligned' [wp]: pspace_aligned' and distinct' [wp]: pspace_distinct' and valid_arch' [wp]: valid_arch_state' and cur_tcb' [wp]: cur_tcb' lemma get_asid_pool_corres_inv': "corres (\p. (\p'. p = p' o ucast) \ inv ASIDPool) (asid_pool_at p) (pspace_aligned' and pspace_distinct') (get_asid_pool p) (getObject p)" apply (rule corres_rel_imp) apply (rule get_asid_pool_corres') apply simp done lemma loadHWASID_wp [wp]: "\\s. P (option_map fst (armKSASIDMap (ksArchState s) asid)) s\ loadHWASID asid \P\" apply (simp add: loadHWASID_def) apply (wp findPDForASIDAssert_pd_at_wp | wpc | simp | wp (once) hoare_drop_imps)+ apply (auto split: option.split) done lemma invalidate_asid_entry_corres: "corres dc (valid_vspace_objs and valid_asid_map and K (asid \ mask asid_bits \ asid \ 0) and vspace_at_asid asid pd and valid_vs_lookup and unique_table_refs o caps_of_state and valid_global_objs and valid_arch_state and pspace_aligned and pspace_distinct) (pspace_aligned' and pspace_distinct' and no_0_obj') (invalidate_asid_entry asid) (invalidateASIDEntry asid)" apply (simp add: invalidate_asid_entry_def invalidateASIDEntry_def) apply (rule corres_guard_imp) apply (rule corres_split [OF _ load_hw_asid_corres[where pd=pd]]) apply (rule corres_split [OF _ corres_when]) apply (rule invalidate_asid_corres[where pd=pd]) apply simp apply simp apply (rule invalidate_hw_asid_entry_corres) apply (wp load_hw_asid_wp | clarsimp cong: if_cong)+ apply (simp add: pd_at_asid_uniq) apply simp done crunch aligned'[wp]: invalidateASID "pspace_aligned'" crunch distinct'[wp]: invalidateASID "pspace_distinct'" lemma invalidateASID_cur' [wp]: "\cur_tcb'\ invalidateASID x \\_. cur_tcb'\" by (simp add: invalidateASID_def|wp)+ crunch aligned' [wp]: invalidateASIDEntry pspace_aligned' crunch distinct' [wp]: invalidateASIDEntry pspace_distinct' crunch cur' [wp]: invalidateASIDEntry cur_tcb' lemma invalidateASID_valid_arch_state [wp]: "\valid_arch_state'\ invalidateASIDEntry x \\_. valid_arch_state'\" apply (simp add: invalidateASID_def invalidateASIDEntry_def invalidateHWASIDEntry_def) apply (wp | simp)+ apply (clarsimp simp: valid_arch_state'_def simp del: fun_upd_apply) apply (clarsimp simp: is_inv_None_upd fun_upd_def[symmetric] comp_upd_simp inj_on_fun_upd_elsewhere valid_asid_map'_def) apply (auto elim!: subset_inj_on dest!: ran_del_subset)[1] done crunch no_0_obj'[wp]: deleteASID "no_0_obj'" (simp: crunch_simps wp: crunch_wps getObject_inv loadObject_default_inv) lemma delete_asid_corres: "corres dc (invs and valid_etcbs and K (asid \ mask asid_bits \ asid \ 0)) (pspace_aligned' and pspace_distinct' and no_0_obj' and valid_arch_state' and cur_tcb') (delete_asid asid pd) (deleteASID asid pd)" apply (simp add: delete_asid_def deleteASID_def) apply (rule corres_guard_imp) apply (rule corres_split [OF _ corres_gets_asid]) apply (case_tac "asid_table (asid_high_bits_of asid)", simp) apply clarsimp apply (rule_tac P="\s. asid_high_bits_of asid \ dom (asidTable o ucast) \ asid_pool_at (the ((asidTable o ucast) (asid_high_bits_of asid))) s" and P'="pspace_aligned' and pspace_distinct'" and Q="invs and valid_etcbs and K (asid \ mask asid_bits \ asid \ 0) and (\s. arm_asid_table (arch_state s) = asidTable \ ucast)" in corres_split) prefer 2 apply (simp add: dom_def) apply (rule get_asid_pool_corres_inv') apply (rule corres_when, simp add: mask_asid_low_bits_ucast_ucast) apply (rule corres_split [OF _ flush_space_corres[where pd=pd]]) apply (rule corres_split [OF _ invalidate_asid_entry_corres[where pd=pd]]) apply (rule_tac P="asid_pool_at (the (asidTable (ucast (asid_high_bits_of asid)))) and valid_etcbs" and P'="pspace_aligned' and pspace_distinct'" in corres_split) prefer 2 apply (simp del: fun_upd_apply) apply (rule set_asid_pool_corres') apply (simp add: inv_def mask_asid_low_bits_ucast_ucast) apply (rule ext) apply (clarsimp simp: o_def) apply (erule notE) apply (erule ucast_ucast_eq, simp, simp) apply (rule corres_split [OF _ gct_corres]) apply simp apply (rule set_vm_root_corres) apply wp+ apply (simp del: fun_upd_apply) apply (fold cur_tcb_def) apply (wp set_asid_pool_asid_map_unmap set_asid_pool_vspace_objs_unmap_single set_asid_pool_vs_lookup_unmap')+ apply simp apply (fold cur_tcb'_def) apply (wp invalidate_asid_entry_invalidates)+ apply (wp | clarsimp simp: o_def)+ apply (subgoal_tac "vspace_at_asid asid pd s") apply (auto simp: obj_at_def a_type_def graph_of_def invs_vspace_objs[simplified] split: if_split_asm)[1] apply (simp add: vspace_at_asid_def) apply (rule vs_lookupI) apply (simp add: vs_asid_refs_def) apply (rule image_eqI[OF refl]) apply (erule graph_ofI) apply (rule r_into_rtrancl) apply simp apply (erule vs_lookup1I [OF _ _ refl]) apply (simp add: vs_refs_def) apply (rule image_eqI[rotated], erule graph_ofI) apply (simp add: mask_asid_low_bits_ucast_ucast) apply wp apply (simp add: o_def) apply (wp getASID_wp) apply clarsimp apply assumption apply wp+ apply clarsimp apply (clarsimp simp: valid_arch_state_def valid_asid_table_def dest!: invs_arch_state) apply blast apply (clarsimp simp: valid_arch_state'_def valid_asid_table'_def) done lemma valid_arch_state_unmap_strg': "valid_arch_state' s \ valid_arch_state' (s\ksArchState := armKSASIDTable_update (\_. (armKSASIDTable (ksArchState s))(ptr := None)) (ksArchState s)\)" apply (simp add: valid_arch_state'_def valid_asid_table'_def) apply (auto simp: ran_def split: if_split_asm) done crunch armKSASIDTable_inv[wp]: invalidateASIDEntry "\s. P (armKSASIDTable (ksArchState s))" crunch armKSASIDTable_inv[wp]: flushSpace "\s. P (armKSASIDTable (ksArchState s))" lemma delete_asid_pool_corres: "corres dc (invs and K (is_aligned base asid_low_bits \ base \ mask asid_bits) and asid_pool_at ptr) (pspace_aligned' and pspace_distinct' and no_0_obj' and valid_arch_state' and cur_tcb') (delete_asid_pool base ptr) (deleteASIDPool base ptr)" apply (simp add: delete_asid_pool_def deleteASIDPool_def) apply (rule corres_assume_pre, simp add: is_aligned_mask cong: corres_weak_cong) apply (thin_tac P for P)+ apply (rule corres_guard_imp) apply (rule corres_split [OF _ corres_gets_asid]) apply (rule corres_when) apply simp apply (simp add: liftM_def) apply (rule corres_split [OF _ get_asid_pool_corres']) apply (rule corres_split) prefer 2 apply (rule corres_mapM [where r=dc and r'=dc], simp, simp) prefer 5 apply (rule order_refl) apply (drule_tac t="inv f x \ g" for f x g in sym) apply (rule_tac P="invs and ko_at (ArchObj (arch_kernel_obj.ASIDPool pool)) ptr and [VSRef (ucast (asid_high_bits_of base)) None] \ ptr and K (is_aligned base asid_low_bits \ base \ mask asid_bits)" and P'="pspace_aligned' and pspace_distinct' and no_0_obj'" in corres_guard_imp) apply (rule corres_when) apply (clarsimp simp: ucast_ucast_low_bits) apply simp apply (rule_tac pd1="the (pool (ucast xa))" in corres_split [OF _ flush_space_corres]) apply (rule_tac pd="the (pool (ucast xa))" in invalidate_asid_entry_corres) apply wp apply clarsimp apply (wpsimp)+ apply (clarsimp simp: invs_def valid_state_def valid_arch_caps_def valid_pspace_def vspace_at_asid_def cong: conj_cong) apply (rule conjI) apply (clarsimp simp: mask_def asid_low_bits_word_bits elim!: is_alignedE) apply (subgoal_tac "of_nat q < (2 ^ asid_high_bits :: word32)") apply (subst mult.commute, rule word_add_offset_less) apply assumption apply assumption apply (simp add: asid_bits_def word_bits_def) apply (erule order_less_le_trans) apply (simp add: word_bits_def asid_low_bits_def asid_high_bits_def) apply (simp add: asid_bits_def asid_high_bits_def asid_low_bits_def) apply (drule word_power_less_diff) apply (drule of_nat_mono_maybe[where 'a=32, rotated]) apply (simp add: word_bits_def asid_low_bits_def) apply (subst word_unat_power, simp) apply (simp add: asid_bits_def word_bits_def) apply (simp add: asid_low_bits_def word_bits_def) apply (simp add: asid_bits_def asid_low_bits_def asid_high_bits_def) apply (subst conj_commute, rule context_conjI, simp add: valid_vspace_objs_def) apply (erule vs_lookup_trancl_step) apply (rule r_into_trancl) apply (erule vs_lookup1I) apply (simp add: vs_refs_def) apply (rule image_eqI[rotated]) apply (rule graph_ofI, simp) apply clarsimp apply fastforce apply (simp add: add_mask_eq asid_low_bits_word_bits ucast_ucast_mask asid_low_bits_def[symmetric] asid_high_bits_of_def) apply (rule conjI) apply (rule sym) apply (simp add: is_aligned_add_helper[THEN conjunct1] mask_eq_iff_w2p asid_low_bits_def word_size) apply (rule_tac f="\a. a && mask n" for n in arg_cong) apply (rule shiftr_eq_mask_eq) apply (simp add: is_aligned_add_helper is_aligned_neg_mask_eq) apply clarsimp apply (subgoal_tac "base \ base + xa") apply (simp add: valid_vs_lookup_def asid_high_bits_of_def) subgoal by (fastforce intro: vs_lookup_pages_vs_lookupI) apply (erule is_aligned_no_wrap') apply (simp add: asid_low_bits_word_bits) apply (simp add: asid_low_bits_word_bits) apply clarsimp apply ((wp|clarsimp simp: o_def)+)[3] apply (rule corres_split) prefer 2 apply (rule corres_modify [where P=\ and P'=\]) apply (simp add: state_relation_def arch_state_relation_def) apply (rule ext) apply clarsimp apply (erule notE) apply (rule word_eqI[rule_format]) apply (drule_tac x1="ucast xa" in bang_eq [THEN iffD1]) apply (erule_tac x=n in allE) apply (simp add: word_size nth_ucast) apply (rule corres_split) prefer 2 apply (rule gct_corres) apply (simp only:) apply (rule set_vm_root_corres) apply wp+ apply (rule_tac R="\_ s. rv = arm_asid_table (arch_state s)" in hoare_post_add) apply (drule sym, simp only: ) apply (drule sym, simp only: ) apply (thin_tac "P" for P)+ apply (simp only: pred_conj_def cong: conj_cong) apply simp apply (fold cur_tcb_def) apply (strengthen valid_arch_state_unmap_strg valid_vspace_objs_unmap_strg valid_asid_map_unmap valid_vs_lookup_unmap_strg) apply (simp add: valid_global_objs_arch_update) apply (rule hoare_vcg_conj_lift, (rule mapM_invalidate[where ptr=ptr])?, ((wp mapM_wp' | simp)+)[1])+ apply (rule_tac R="\_ s. rv' = armKSASIDTable (ksArchState s)" in hoare_post_add) apply (simp only: pred_conj_def cong: conj_cong) apply simp apply (strengthen valid_arch_state_unmap_strg') apply (fold cur_tcb'_def) apply (wp mapM_wp')+ apply (clarsimp simp: cur_tcb'_def) apply (simp add: o_def pred_conj_def) apply wp apply (wp getASID_wp)+ apply (clarsimp simp: conj_comms) apply (auto simp: vs_lookup_def invs_vspace_objs[simplified] intro: vs_asid_refsI)[1] apply clarsimp done lemma set_vm_root_for_flush_corres: "corres (=) (cur_tcb and vspace_at_asid asid pd and K (asid \ 0 \ asid \ mask asid_bits) and valid_asid_map and valid_vs_lookup and valid_vspace_objs and valid_global_objs and unique_table_refs o caps_of_state and valid_arch_state and pspace_aligned and pspace_distinct) (pspace_aligned' and pspace_distinct' and no_0_obj') (set_vm_root_for_flush pd asid) (setVMRootForFlush pd asid)" proof - have X: "corres (=) (vspace_at_asid asid pd and K (asid \ 0 \ asid \ mask asid_bits) and valid_asid_map and valid_vs_lookup and valid_vspace_objs and valid_global_objs and unique_table_refs o caps_of_state and valid_arch_state and pspace_aligned and pspace_distinct) (pspace_aligned' and pspace_distinct' and no_0_obj') (do arm_context_switch pd asid; return True od) (do armv_contextSwitch pd asid; return True od)" apply (rule corres_guard_imp) apply (rule corres_split [OF _ arm_context_switch_corres]) apply (rule corres_trivial) apply (wp | simp)+ done show ?thesis apply (simp add: set_vm_root_for_flush_def setVMRootForFlush_def getThreadVSpaceRoot_def locateSlot_conv) apply (rule corres_guard_imp) apply (rule corres_split [OF _ gct_corres]) apply (rule corres_split [where R="\_. vspace_at_asid asid pd and K (asid \ 0 \ asid \ mask asid_bits) and valid_asid_map and valid_vs_lookup and valid_vspace_objs and valid_global_objs and unique_table_refs o caps_of_state and valid_arch_state and pspace_aligned and pspace_distinct" and R'="\_. pspace_aligned' and pspace_distinct' and no_0_obj'", OF _ getSlotCap_corres]) apply (case_tac "isArchObjectCap rv' \ isPageDirectoryCap (capCap rv') \ capPDMappedASID (capCap rv') \ None \ capPDBasePtr (capCap rv') = pd") apply (case_tac rv, simp_all add: isCap_simps)[1] apply (rename_tac arch_cap) apply (case_tac arch_cap, auto)[1] apply (case_tac rv, simp_all add: isCap_simps[simplified] X[simplified])[1] apply (rename_tac arch_cap) apply (case_tac arch_cap, auto simp: X[simplified] split: option.splits)[1] apply (simp add: cte_map_def objBits_simps tcb_cnode_index_def tcbVTableSlot_def to_bl_1 cte_level_bits_def) apply wp+ apply (clarsimp simp: cur_tcb_def) apply (erule tcb_at_cte_at) apply (simp add: tcb_cap_cases_def) apply clarsimp done qed crunch typ_at' [wp]: armv_contextSwitch "\s. P (typ_at' T p s)" (simp: crunch_simps) crunch typ_at' [wp]: setVMRoot "\s. P (typ_at' T p s)" (simp: crunch_simps) lemmas setVMRoot_typ_ats [wp] = typ_at_lifts [OF setVMRoot_typ_at'] lemmas loadHWASID_typ_ats [wp] = typ_at_lifts [OF loadHWASID_inv] crunch typ_at' [wp]: setVMRootForFlush "\s. P (typ_at' T p s)" (wp: hoare_drop_imps) lemmas setVMRootForFlush_typ_ats' [wp] = typ_at_lifts [OF setVMRootForFlush_typ_at'] crunch aligned' [wp]: setVMRootForFlush pspace_aligned' (wp: hoare_drop_imps) crunch distinct' [wp]: setVMRootForFlush pspace_distinct' (wp: hoare_drop_imps) crunch cur' [wp]: setVMRootForFlush cur_tcb' (wp: hoare_drop_imps) lemma findPDForASID_inv2: "\\s. asid \ 0 \ asid \ mask asid_bits \ P s\ findPDForASID asid \\rv. P\" apply (cases "asid \ 0 \ asid \ mask asid_bits") apply (simp add: findPDForASID_inv) apply (simp add: findPDForASID_def assertE_def asidRange_def mask_def) apply clarsimp done lemma storeHWASID_valid_arch' [wp]: "\valid_arch_state' and (\s. armKSASIDMap (ksArchState s) asid = None \ armKSHWASIDTable (ksArchState s) hw_asid = None)\ storeHWASID asid hw_asid \\_. valid_arch_state'\" supply image_cong_simp [cong del] apply (simp add: storeHWASID_def) apply wp prefer 2 apply assumption apply (simp add: valid_arch_state'_def comp_upd_simp fun_upd_def[symmetric]) apply wp apply (simp add: findPDForASIDAssert_def const_def checkPDUniqueToASID_def checkPDASIDMapMembership_def) apply wp apply (rule_tac Q'="\rv s. valid_asid_map' (armKSASIDMap (ksArchState s)) \ asid \ 0 \ asid \ mask asid_bits" in hoare_post_imp_R) apply (wp findPDForASID_inv2)+ apply (clarsimp simp: valid_asid_map'_def) apply (subst conj_commute, rule context_conjI) apply clarsimp apply (rule ccontr, erule notE, rule_tac a=x in ranI) apply (simp add: restrict_map_def) apply (erule(1) inj_on_fun_updI2) apply clarsimp apply (frule is_inv_NoneD[rotated], simp) apply (simp add: ran_def) apply (simp add: is_inv_def) done lemma storeHWASID_obj_at [wp]: "\\s. P (obj_at' P' t s)\ storeHWASID x y \\rv s. P (obj_at' P' t s)\" apply (simp add: storeHWASID_def) apply (wp | simp)+ done lemma findFreeHWASID_obj_at [wp]: "\\s. P (obj_at' P' t s)\ findFreeHWASID \\rv s. P (obj_at' P' t s)\" apply (simp add: findFreeHWASID_def invalidateASID_def invalidateHWASIDEntry_def bind_assoc cong: option.case_cong) apply (wp doMachineOp_obj_at|wpc|simp)+ done lemma findFreeHWASID_valid_arch [wp]: "\valid_arch_state'\ findFreeHWASID \\_. valid_arch_state'\" apply (simp add: findFreeHWASID_def invalidateHWASIDEntry_def invalidateASID_def doMachineOp_def split_def cong: option.case_cong) apply (wp|wpc|simp split del: if_split)+ apply (clarsimp simp: valid_arch_state'_def fun_upd_def[symmetric] comp_upd_simp valid_asid_map'_def) apply (frule is_inv_inj) apply (drule findNoneD) apply (drule_tac x="armKSNextASID (ksArchState s)" in bspec) apply clarsimp apply (clarsimp simp: is_inv_def ran_upd[folded fun_upd_def] dom_option_map inj_on_fun_upd_elsewhere) apply (rule conjI) apply clarsimp apply (drule_tac x="x" and y="armKSNextASID (ksArchState s)" in inj_onD) apply simp apply blast apply blast apply simp apply (rule conjI) apply (erule subset_inj_on, clarsimp) apply (erule order_trans[rotated]) apply clarsimp done lemma findFreeHWASID_None_map [wp]: "\\s. armKSASIDMap (ksArchState s) asid = None\ findFreeHWASID \\rv s. armKSASIDMap (ksArchState s) asid = None\" apply (simp add: findFreeHWASID_def invalidateHWASIDEntry_def invalidateASID_def doMachineOp_def split_def cong: option.case_cong) apply (rule hoare_pre) apply (wp|wpc|simp split del: if_split)+ apply auto done lemma findFreeHWASID_None_HWTable [wp]: "\\\ findFreeHWASID \\rv s. armKSHWASIDTable (ksArchState s) rv = None\" apply (simp add: findFreeHWASID_def invalidateHWASIDEntry_def invalidateASID_def doMachineOp_def cong: option.case_cong) apply (wp|wpc|simp)+ apply (auto dest!: findSomeD) done lemma getHWASID_valid_arch': "\valid_arch_state'\ getHWASID asid \\_. valid_arch_state'\" apply (simp add: getHWASID_def) apply (wp | wpc | simp)+ done crunch valid_arch' [wp]: setVMRootForFlush "valid_arch_state'" (wp: hoare_drop_imps) lemma load_hw_asid_corres2: "corres (=) (valid_vspace_objs and pspace_distinct and pspace_aligned and valid_asid_map and vspace_at_asid a pd and valid_vs_lookup and valid_global_objs and unique_table_refs o caps_of_state and valid_arch_state and K (a \ 0 \ a \ mask asid_bits)) (pspace_aligned' and pspace_distinct' and no_0_obj') (load_hw_asid a) (loadHWASID a)" apply (rule stronger_corres_guard_imp) apply (rule load_hw_asid_corres[where pd=pd]) apply (clarsimp simp: pd_at_asid_uniq) apply simp done crunch no_0_obj'[wp]: flushTable "no_0_obj'" (wp: crunch_wps simp: crunch_simps) lemma flush_table_corres: "corres dc (pspace_aligned and valid_objs and valid_arch_state and cur_tcb and vspace_at_asid asid pd and valid_asid_map and valid_vspace_objs and pspace_aligned and pspace_distinct and valid_vs_lookup and valid_global_objs and unique_table_refs o caps_of_state and K (is_aligned vptr (pageBitsForSize ARMSection) \ asid \ mask asid_bits \ asid \ 0)) (pspace_aligned' and pspace_distinct' and no_0_obj' and valid_arch_state' and cur_tcb') (flush_table pd asid vptr ptr) (flushTable pd asid vptr)" apply (simp add: flush_table_def flushTable_def) apply (rule corres_assume_pre) apply (simp add: ptBits_def pt_bits_def pageBits_def is_aligned_mask cong: corres_weak_cong) apply (thin_tac "P" for P)+ apply (rule corres_guard_imp) apply (rule corres_split [OF _ set_vm_root_for_flush_corres]) apply (rule corres_split [OF _ load_hw_asid_corres2[where pd=pd]]) apply (clarsimp) apply (rule corres_when, rule refl) apply (rule corres_split[where r' = dc, OF corres_when corres_machine_op]) apply simp apply (rule corres_split[OF _ gct_corres]) apply (simp, rule set_vm_root_corres) apply ((wp mapM_wp' hoare_vcg_const_imp_lift get_pte_wp getPTE_wp| wpc|simp|fold cur_tcb_def cur_tcb'_def)+)[4] apply (rule corres_Id[OF refl]) apply simp apply (rule no_fail_invalidateLocalTLB_ASID) apply (wp hoare_drop_imps | simp)+ apply (wp load_hw_asid_wp hoare_drop_imps | simp add: cur_tcb'_def [symmetric] cur_tcb_def [symmetric] )+ done lemma flush_page_corres: "corres dc (K (is_aligned vptr pageBits \ asid \ mask asid_bits \ asid \ 0) and cur_tcb and valid_arch_state and valid_objs and vspace_at_asid asid pd and valid_asid_map and valid_vspace_objs and valid_vs_lookup and valid_global_objs and unique_table_refs o caps_of_state and pspace_aligned and pspace_distinct) (pspace_aligned' and pspace_distinct' and no_0_obj' and valid_arch_state' and cur_tcb') (flush_page pageSize pd asid vptr) (flushPage pageSize pd asid vptr)" apply (clarsimp simp: flush_page_def flushPage_def) apply (rule corres_assume_pre) apply (simp add: is_aligned_mask cong: corres_weak_cong) apply (thin_tac P for P)+ apply (rule corres_guard_imp) apply (rule corres_split [OF _ set_vm_root_for_flush_corres]) apply (rule corres_split [OF _ load_hw_asid_corres2[where pd=pd]]) apply clarsimp apply (rule corres_when, rule refl) apply (rule corres_split [OF _ corres_machine_op [where r=dc]]) apply (rule corres_when, rule refl) apply (rule corres_split [OF _ gct_corres]) apply simp apply (rule set_vm_root_corres) apply wp+ apply (rule corres_Id, rule refl, simp) apply (rule no_fail_pre, wp no_fail_invalidateLocalTLB_VAASID) apply simp apply (simp add: cur_tcb_def [symmetric] cur_tcb'_def [symmetric]) apply (wp hoare_drop_imps)[1] apply (assumption | wp hoare_drop_imps load_hw_asid_wp | clarsimp simp: cur_tcb_def [symmetric] cur_tcb'_def [symmetric])+ done crunch typ_at' [wp]: flushTable "\s. P (typ_at' T p s)" (wp: crunch_wps) lemmas flushTable_typ_ats' [wp] = typ_at_lifts [OF flushTable_typ_at'] lemmas findPDForASID_typ_ats' [wp] = typ_at_lifts [OF findPDForASID_inv] crunch aligned'[wp]: unmapPageTable "pspace_aligned'" (simp: crunch_simps wp: crunch_wps getObject_inv loadObject_default_inv) crunch distinct'[wp]: unmapPageTable "pspace_distinct'" (simp: crunch_simps wp: crunch_wps getObject_inv loadObject_default_inv) lemma page_table_mapped_corres: "corres (=) (valid_arch_state and valid_vspace_objs and pspace_aligned and K (asid \ 0 \ asid \ mask asid_bits)) (pspace_aligned' and pspace_distinct' and no_0_obj') (page_table_mapped asid vaddr pt) (pageTableMapped asid vaddr pt)" apply (simp add: page_table_mapped_def pageTableMapped_def) apply (rule corres_guard_imp) apply (rule corres_split_catch) apply (rule corres_trivial, simp) apply (rule corres_split_eqrE [OF _ find_pd_for_asid_corres]) apply (simp add: liftE_bindE) apply (rule corres_split [OF _ get_pde_corres']) apply (rule corres_trivial) apply (case_tac rv, simp_all add: returnOk_def pde_relation_aligned_def split:if_splits ARM_H.pde.splits)[1] apply (wp | simp add: lookup_pd_slot_def Let_def)+ apply (simp add: word_neq_0_conv) apply simp done crunch inv[wp]: pageTableMapped "P" (wp: loadObject_default_inv) crunches storePDE, storePTE for no_0_obj'[wp]: no_0_obj' and valid_arch'[wp]: valid_arch_state' and cur_tcb'[wp]: cur_tcb' lemma unmap_page_table_corres: "corres dc (invs and valid_etcbs and page_table_at pt and K (0 < asid \ is_aligned vptr 20 \ asid \ mask asid_bits)) (valid_arch_state' and pspace_aligned' and pspace_distinct' and no_0_obj' and cur_tcb' and valid_objs') (unmap_page_table asid vptr pt) (unmapPageTable asid vptr pt)" apply (clarsimp simp: unmapPageTable_def unmap_page_table_def ignoreFailure_def const_def cong: option.case_cong) apply (rule corres_guard_imp) apply (rule corres_split_eqr [OF _ page_table_mapped_corres]) apply (simp add: case_option_If2 split del: if_split) apply (rule corres_if2[OF refl]) apply (rule corres_split [OF _ store_pde_corres']) apply (rule corres_split[OF _ corres_machine_op]) apply (rule flush_table_corres) apply (rule corres_Id, rule refl, simp) apply (wp no_fail_cleanByVA_PoU)+ apply (simp, wp+) apply (simp add:pde_relation_aligned_def)+ apply (wp store_pde_pd_at_asid store_pde_vspace_objs_invalid) apply (rule hoare_vcg_conj_lift) apply (simp add: store_pde_def) apply (wp set_pd_vs_lookup_unmap)+ apply (rule corres_trivial, simp) apply (wp page_table_mapped_wp) apply (wp hoare_drop_imps)[1] apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_arch_caps_def word_gt_0) apply (frule (1) page_directory_pde_at_lookupI) apply (auto elim: simp: empty_table_def valid_pde_mappings_def pde_ref_def obj_at_def vs_refs_pages_def graph_of_def split: if_splits) done crunch typ_at' [wp]: flushPage "\s. P (typ_at' T p s)" (wp: crunch_wps hoare_drop_imps) lemmas flushPage_typ_ats' [wp] = typ_at_lifts [OF flushPage_typ_at'] crunch valid_objs' [wp]: flushPage "valid_objs'" (wp: crunch_wps hoare_drop_imps simp: crunch_simps) crunch inv: lookupPTSlot "P" (wp: loadObject_default_inv) crunch aligned' [wp]: unmapPage pspace_aligned' (wp: crunch_wps simp: crunch_simps) crunch distinct' [wp]: unmapPage pspace_distinct' (wp: crunch_wps simp: crunch_simps) lemma corres_split_strengthen_ftE: "\ corres (ftr \ r') P P' f j; \rv rv'. r' rv rv' \ corres (ftr' \ r) (R rv) (R' rv') (g rv) (k rv'); \Q\ f \R\,-; \Q'\ j \R'\,- \ \ corres (dc \ r) (P and Q) (P' and Q') (f >>=E (\rv. g rv)) (j >>=E (\rv'. k rv'))" apply (rule_tac r'=r' in corres_splitEE) apply (rule corres_rel_imp, assumption) apply (case_tac x, auto)[1] apply (erule corres_rel_imp) apply (case_tac x, auto)[1] apply (simp add: validE_R_def)+ done lemma check_mapping_corres: "corres (dc \ dc) ((case slotptr of Inl ptr \ pte_at ptr | Inr ptr \ pde_at ptr) and (\s. (case slotptr of Inl ptr \ is_aligned ptr (pg_entry_align sz) | Inr ptr \ is_aligned ptr (pg_entry_align sz)))) (pspace_aligned' and pspace_distinct') (throw_on_false v (check_mapping_pptr pptr sz slotptr)) (checkMappingPPtr pptr sz slotptr)" apply (rule corres_gen_asm) apply (simp add: throw_on_false_def liftE_bindE check_mapping_pptr_def checkMappingPPtr_def) apply (cases slotptr, simp_all add: liftE_bindE) apply (rule corres_guard_imp) apply (rule corres_split[OF _ get_pte_corres']) apply (rule corres_trivial) subgoal by (cases sz, auto simp add: is_aligned_mask[symmetric] is_aligned_shiftr pg_entry_align_def unlessE_def returnOk_def pte_relation_aligned_def split: ARM_A.pte.split if_splits ARM_H.pte.split ) apply wp+ apply simp apply (simp add:is_aligned_mask[symmetric] is_aligned_shiftr pg_entry_align_def) apply (rule corres_guard_imp) apply (rule corres_split[OF _ get_pde_corres']) apply (rule corres_trivial) subgoal by (cases sz, auto simp add: is_aligned_mask[symmetric] is_aligned_shiftr pg_entry_align_def unlessE_def returnOk_def pde_relation_aligned_def split: ARM_A.pde.split if_splits ARM_H.pde.split ) apply wp+ apply simp+ done crunch inv[wp]: checkMappingPPtr "P" (wp: crunch_wps loadObject_default_inv simp: crunch_simps) lemma store_pte_pd_at_asid[wp]: "\vspace_at_asid asid pd\ store_pte p pte \\_. vspace_at_asid asid pd\" apply (simp add: store_pte_def set_pd_def set_object_def vspace_at_asid_def) apply (wp get_object_wp) apply clarsimp done lemma unmap_page_corres: "corres dc (invs and valid_etcbs and K (valid_unmap sz (asid,vptr) \ vptr < kernel_base \ asid \ mask asid_bits)) (valid_objs' and valid_arch_state' and pspace_aligned' and pspace_distinct' and no_0_obj' and cur_tcb') (unmap_page sz asid vptr pptr) (unmapPage sz asid vptr pptr)" apply (clarsimp simp: unmap_page_def unmapPage_def ignoreFailure_def const_def largePagePTEOffsets_def) apply (rule corres_guard_imp) apply (rule corres_split_catch [where E="\_. \" and E'="\_. \"], simp) apply (rule corres_split_strengthen_ftE[where ftr'=dc], rule find_pd_for_asid_corres,simp) apply (rule corres_splitEE) apply clarsimp apply (rule flush_page_corres) apply (rule_tac F = "vptr < kernel_base" in corres_gen_asm) apply (rule_tac P="\\ pd and page_directory_at pd and vspace_at_asid asid pd and (\\ (lookup_pd_slot pd vptr && ~~ mask pd_bits)) and valid_arch_state and valid_vspace_objs and equal_kernel_mappings and pspace_aligned and valid_global_objs and valid_etcbs and K (valid_unmap sz (asid,vptr) )" and P'="pspace_aligned' and pspace_distinct'" in corres_inst) apply clarsimp apply (rename_tac pd) apply (cases sz, simp_all)[1] apply (rule corres_guard_imp) apply (rule_tac F = "vptr < kernel_base" in corres_gen_asm) apply (rule corres_split_strengthen_ftE[OF lookup_pt_slot_corres[OF refl refl]]) apply simp apply (rule corres_splitEE[OF _ check_mapping_corres]) apply simp apply (rule corres_split [OF _ store_pte_corres']) apply (rule corres_machine_op) apply (rule corres_Id, rule refl, simp) apply (rule no_fail_cleanByVA_PoU) apply (wp hoare_drop_imps lookup_pt_slot_inv lookupPTSlot_inv lookup_pt_slot_is_aligned | simp add: pte_relation_aligned_def)+ apply (clarsimp simp: page_directory_pde_at_lookupI page_directory_at_aligned_pd_bits vmsz_aligned_def) apply (simp add:valid_unmap_def pageBits_def) apply (erule less_kernel_base_mapping_slots) apply (simp add:page_directory_at_aligned_pd_bits) apply simp apply (rule corres_guard_imp) apply (rule corres_split_strengthen_ftE[OF lookup_pt_slot_corres[OF refl refl]]) apply (rule_tac F="is_aligned p 6" in corres_gen_asm) apply (simp add: is_aligned_mask[symmetric]) apply (rule corres_split_strengthen_ftE[OF check_mapping_corres]) apply (simp add: largePagePTEOffsets_def pteBits_def) apply (rule corres_split [OF _ corres_mapM]) prefer 8 apply (rule order_refl) apply (rule corres_machine_op) apply (clarsimp simp: last_byte_pte_def objBits_simps archObjSize_def) apply (rule corres_Id, rule refl, simp) apply (rule no_fail_cleanCacheRange_PoU) apply simp apply simp apply clarsimp apply (rule_tac P="(\s. \x\set [0, 4 .e. 0x3C]. pte_at (x + pa) s) and pspace_aligned and valid_etcbs" and P'="pspace_aligned' and pspace_distinct'" in corres_guard_imp) apply (rule store_pte_corres', simp add:pte_relation_aligned_def) apply clarsimp apply clarsimp apply (wp store_pte_typ_at hoare_vcg_const_Ball_lift | simp | wp (once) hoare_drop_imps)+ apply (wp lookup_pt_slot_ptes lookup_pt_slot_inv lookupPTSlot_inv lookup_pt_slot_is_aligned lookup_pt_slot_is_aligned_6)+ apply (clarsimp simp: page_directory_pde_at_lookupI vmsz_aligned_def pd_aligned pd_bits_def pageBits_def valid_unmap_def) apply (drule(1) less_kernel_base_mapping_slots[OF _ page_directory_at_aligned_pd_bits]) apply simp apply (simp add:pd_bits_def pageBits_def) apply (clarsimp simp: pd_aligned page_directory_pde_at_lookupI) apply (rule corres_guard_imp) apply (rule corres_split_strengthen_ftE[OF check_mapping_corres]) apply simp apply (rule corres_split[OF _ store_pde_corres']) apply (rule corres_machine_op) apply (rule corres_Id, rule refl, simp) apply (rule no_fail_cleanByVA_PoU) apply (wp | simp add:pde_relation_aligned_def | wp (once) hoare_drop_imps)+ apply (clarsimp simp: page_directory_pde_at_lookupI pg_entry_align_def) apply (clarsimp simp:lookup_pd_slot_def) apply (erule(1) aligned_add_aligned[OF page_directory_at_aligned_pd_bits]) apply (simp add:is_aligned_shiftl_self) apply (simp add:pd_bits_def pageBits_def word_bits_conv) apply (simp add:pd_bits_def pageBits_def) apply (rule corres_guard_imp) apply (rule corres_split_strengthen_ftE[OF check_mapping_corres]) apply (rule_tac F="is_aligned (lookup_pd_slot pd vptr) 6" in corres_gen_asm) apply (simp add: is_aligned_mask[symmetric]) apply (rule corres_split) apply (rule corres_machine_op) apply (clarsimp simp: last_byte_pde_def objBits_simps archObjSize_def superSectionPDEOffsets_def pdeBits_def) apply (rule corres_Id, rule refl, simp) apply (rule no_fail_cleanCacheRange_PoU) apply (rule_tac P="page_directory_at pd and pspace_aligned and valid_etcbs and K (valid_unmap sz (asid, vptr))" in corres_mapM [where r=dc], simp, simp) prefer 5 apply (rule order_refl) apply (clarsimp simp: superSectionPDEOffsets_def pdeBits_def) apply (rule corres_guard_imp, rule store_pde_corres') apply (simp add:pde_relation_aligned_def)+ apply clarsimp apply (erule (2) pde_at_aligned_vptr) apply (simp add: valid_unmap_def) apply assumption apply (wp | simp add: superSectionPDEOffsets_def pdeBits_def | wp (once) hoare_drop_imps)+ apply (clarsimp simp: valid_unmap_def page_directory_pde_at_lookupI lookup_pd_slot_aligned_6 pg_entry_align_def pd_aligned vmsz_aligned_def) apply simp apply wp apply (rule_tac Q'="\_. invs and vspace_at_asid asid pda" in hoare_post_imp_R) apply (wp lookup_pt_slot_inv lookup_pt_slot_cap_to2' lookup_pt_slot_cap_to_multiple2 store_pde_invs_unmap store_pde_pd_at_asid mapM_swp_store_pde_invs_unmap | wpc | simp | wp hoare_drop_imps | wp mapM_wp')+ apply (auto simp: invs_vspace_objs[simplified])[1] apply (wp lookupPTSlot_inv mapM_wp' | wpc | clarsimp)+ apply (wp hoare_vcg_const_imp_lift_R | strengthen lookup_pd_slot_kernel_mappings_strg not_in_global_refs_vs_lookup page_directory_at_lookup_mask_aligned_strg lookup_pd_slot_kernel_mappings_set_strg page_directory_at_lookup_mask_add_aligned_strg | wp hoare_vcg_const_Ball_lift_R)+ apply (clarsimp simp add: valid_unmap_def valid_asid_def) apply (case_tac sz) apply (auto simp: invs_def valid_state_def valid_arch_state_def pageBits_def valid_arch_caps_def vmsz_aligned_def) done definition "flush_type_map type \ case type of ARM_A.flush_type.Clean \ ARM_H.flush_type.Clean | ARM_A.flush_type.Invalidate \ ARM_H.flush_type.Invalidate | ARM_A.flush_type.CleanInvalidate \ ARM_H.flush_type.CleanInvalidate | ARM_A.flush_type.Unify \ ARM_H.flush_type.Unify" lemma do_flush_corres: "corres_underlying Id nf nf' dc \ \ (do_flush typ start end pstart) (doFlush (flush_type_map typ) start end pstart)" apply (simp add: do_flush_def doFlush_def) apply (cases "typ", simp_all add: flush_type_map_def) apply (rule corres_Id [where r=dc], rule refl, simp) apply (wp no_fail_cleanCacheRange_RAM) apply (rule corres_Id [where r=dc], rule refl, simp) apply (wp no_fail_invalidateCacheRange_RAM) apply (rule corres_Id [where r=dc], rule refl, simp) apply (wp no_fail_cleanInvalidateCacheRange_RAM) apply (rule corres_Id [where r=dc], rule refl, simp) apply (rule no_fail_pre, wp add: no_fail_cleanCacheRange_PoU no_fail_invalidateCacheRange_I no_fail_dsb no_fail_isb del: no_irq) apply clarsimp done definition "page_directory_invocation_map pdi pdi' \ case pdi of ARM_A.PageDirectoryNothing \ pdi' = PageDirectoryNothing | ARM_A.PageDirectoryFlush typ start end pstart pd asid \ pdi' = PageDirectoryFlush (flush_type_map typ) start end pstart pd asid" lemma perform_page_directory_corres: "page_directory_invocation_map pdi pdi' \ corres dc (invs and valid_pdi pdi) (valid_objs' and pspace_aligned' and pspace_distinct' and no_0_obj' and cur_tcb' and valid_arch_state') (perform_page_directory_invocation pdi) (performPageDirectoryInvocation pdi')" apply (simp add: perform_page_directory_invocation_def performPageDirectoryInvocation_def) apply (cases pdi) apply (clarsimp simp: page_directory_invocation_map_def) apply (rule corres_guard_imp) apply (rule corres_when, simp) apply (rule corres_split [OF _ set_vm_root_for_flush_corres]) apply (rule corres_split [OF _ corres_machine_op]) prefer 2 apply (rule do_flush_corres) apply (rule corres_when, simp) apply (rule corres_split [OF _ gct_corres]) apply clarsimp apply (rule set_vm_root_corres) apply wp+ apply (simp add: cur_tcb_def[symmetric]) apply (wp hoare_drop_imps) apply (simp add: cur_tcb'_def[symmetric]) apply (wp hoare_drop_imps)+ apply clarsimp apply (auto simp: valid_pdi_def invs_vspace_objs[simplified])[2] apply (clarsimp simp: page_directory_invocation_map_def) done definition "page_invocation_map pgi pgi' \ case pgi of ARM_A.PageMap a c ptr m \ \c' m'. pgi' = PageMap a c' (cte_map ptr) m' \ cap_relation c c' \ mapping_map m m' | ARM_A.PageUnmap c ptr \ \c'. pgi' = PageUnmap c' (cte_map ptr) \ acap_relation c c' | ARM_A.PageFlush typ start end pstart pd asid \ pgi' = PageFlush (flush_type_map typ) start end pstart pd asid | ARM_A.PageGetAddr ptr \ pgi' = PageGetAddr ptr" definition "valid_pde_slots' m \ case m of Inl (pte, xs) \ True | Inr (pde, xs) \ \x \ set xs. valid_pde_mapping' (x && mask pdBits) pde" definition "vs_entry_align obj \ case obj of KOArch (KOPTE pte) \ pte_align' pte | KOArch (KOPDE pde) \ pde_align' pde | _ \ 0" definition "valid_slots_duplicated' \ \m s. case m of Inl (pte, xs) \ (case pte of pte.LargePagePTE _ _ _ _ _ \ \p. xs = [p, p+4 .e. p + mask 6] \ is_aligned p 6 \ page_table_at' (p && ~~ mask ptBits) s | _ \ \p. xs = [p] \ ko_wp_at' (\ko. vs_entry_align ko = 0) p s \ page_table_at' (p && ~~ mask ptBits) s) | Inr (pde, xs) \ (case pde of pde.SuperSectionPDE _ _ _ _ _ _ \ \p. xs = [p, p+4 .e. p + mask 6] \ is_aligned p 6 \ page_directory_at' (p && ~~ mask pdBits) s | _ \ \p. xs = [p] \ ko_wp_at' (\ko. vs_entry_align ko = 0) p s \ page_directory_at' (p && ~~ mask pdBits) s)" lemma valid_slots_duplicated_pteD': assumes "valid_slots_duplicated' (Inl (pte, xs)) s" shows "(is_aligned (hd xs >> 2) (pte_align' pte)) \ (\p \ set (tl xs). \ is_aligned (p >> 2) (pte_align' pte))" proof - have is_aligned_estimate: "\x. is_aligned (x::word32) 4 \ x \ 0 \ 2 ^ 4 \ x" apply (simp add:is_aligned_mask mask_def) apply word_bitwise apply auto done show ?thesis using assms apply - apply (clarsimp simp:valid_slots_duplicated'_def split:ARM_H.pte.splits) apply (subgoal_tac "p \ p + mask 6") apply (clarsimp simp:upto_enum_step_def not_less) apply (intro conjI impI,simp) apply (simp add:hd_map_simp mask_def is_aligned_shiftr upto_enum_word) apply (clarsimp simp:mask_def upto_enum_word) apply (subst (asm) tl_map_simp upto_enum_word) apply simp apply (clarsimp simp:image_def) apply (cut_tac w = "of_nat x :: word32" in shiftl_t2n[where n = 2,simplified,symmetric]) apply (clarsimp simp:field_simps) apply (drule is_aligned_shiftl[where n = 6 and m = 2,simplified]) apply (subst (asm) shiftr_shiftl1) apply simp apply (simp add: tl_nat_list_simp) apply (subst (asm) is_aligned_neg_mask_eq) apply (erule aligned_add_aligned[OF _ is_aligned_shiftl_self]) apply simp apply (drule(1) is_aligned_addD1) apply (drule_tac w = "(of_nat x::word32) << 2" in is_aligned_shiftr[where n = 4 and m = 2,simplified]) apply (clarsimp simp: shiftl_shiftr_id word_of_nat_less)+ apply (drule is_aligned_estimate) apply (rule of_nat_neq_0) apply simp apply simp apply (drule unat_le_helper) apply simp apply (erule is_aligned_no_wrap') apply (simp add:mask_def) done qed lemma valid_slots_duplicated_pdeD': assumes "valid_slots_duplicated' (Inr (pde, xs)) s" shows "(is_aligned (hd xs >> 2) (pde_align' pde)) \ (\p \ set (tl xs). \ is_aligned (p >> 2) (pde_align' pde))" proof - have is_aligned_estimate: "\x. is_aligned (x::word32) 4 \ x \ 0 \ 2 ^ 4 \ x" apply (simp add:is_aligned_mask mask_def) apply word_bitwise apply auto done show ?thesis using assms apply - apply (clarsimp simp:valid_slots_duplicated'_def split:ARM_H.pde.splits) apply (subgoal_tac "p \ p + mask 6") apply (clarsimp simp:upto_enum_step_def not_less) apply (intro conjI impI,simp) apply (simp add:hd_map_simp mask_def is_aligned_shiftr upto_enum_word) apply (clarsimp simp:mask_def upto_enum_word) apply (subst (asm) tl_map_simp upto_enum_word) apply simp apply (clarsimp simp:image_def) apply (cut_tac w = "of_nat x :: word32" in shiftl_t2n[where n = 2,simplified,symmetric]) apply (clarsimp simp:field_simps) apply (drule is_aligned_shiftl[where n = 6 and m = 2,simplified]) apply (subst (asm) shiftr_shiftl1) apply simp apply (simp add: tl_nat_list_simp) apply (subst (asm) is_aligned_neg_mask_eq) apply (erule aligned_add_aligned[OF _ is_aligned_shiftl_self]) apply simp apply (drule(1) is_aligned_addD1) apply (drule_tac w = "(of_nat x::word32) << 2" in is_aligned_shiftr[where n = 4 and m = 2,simplified]) apply (clarsimp simp: shiftl_shiftr_id word_of_nat_less)+ apply (drule is_aligned_estimate) apply (rule of_nat_neq_0) apply simp apply simp apply (drule unat_le_helper) apply simp apply (erule is_aligned_no_wrap') apply (simp add:mask_def) done qed lemma setCTE_vs_entry_align[wp]: "\\s. ko_wp_at' (\ko. P (vs_entry_align ko)) p s\ setCTE ptr cte \\rv. ko_wp_at' (\ko. P (vs_entry_align ko)) p\" apply (clarsimp simp: setCTE_def setObject_def split_def valid_def in_monad ko_wp_at'_def split del: if_split elim!: rsubst[where P=P]) apply (drule(1) updateObject_cte_is_tcb_or_cte [OF _ refl, rotated]) apply (elim exE conjE disjE) apply (clarsimp simp: ps_clear_upd' objBits_simps lookupAround2_char1) apply (simp add:vs_entry_align_def) apply (clarsimp simp: ps_clear_upd' objBits_simps vs_entry_align_def) done lemma updateCap_vs_entry_align[wp]: "\ko_wp_at' (\ko. P (vs_entry_align ko)) p \ updateCap ptr cap \\rv. ko_wp_at' (\ko. P (vs_entry_align ko)) p\" apply (simp add:updateCap_def) apply wp done lemma valid_slots_duplicated_updateCap[wp]: "\valid_slots_duplicated' m'\ updateCap cap c' \\rv s. valid_slots_duplicated' m' s\" apply (case_tac m') apply (simp_all add:valid_slots_duplicated'_def) apply (case_tac a,case_tac aa,simp_all) apply (wp hoare_vcg_ex_lift)+ apply (case_tac b,case_tac a,simp_all) apply (wp hoare_vcg_ex_lift)+ done definition "valid_page_inv' pgi \ case pgi of PageMap asid cap ptr m \ cte_wp_at' (is_arch_update' cap) ptr and valid_slots' m and valid_cap' cap and K (valid_pde_slots' m) and (valid_slots_duplicated' m) | PageUnmap cap ptr \ \s. \d r R sz m. cap = PageCap d r R sz m \ cte_wp_at' (is_arch_update' (ArchObjectCap cap)) ptr s \ s \' (ArchObjectCap cap) | PageFlush typ start end pstart pd asid \ \ | PageGetAddr ptr \ \" crunch ctes [wp]: unmapPage "\s. P (ctes_of s)" (wp: crunch_wps simp: crunch_simps) lemma corres_store_pde_with_invalid_tail: "\slot \set ys. \ is_aligned (slot >> 2) (pde_align' ab) \corres dc ((\s. \y\ set ys. pde_at y s) and pspace_aligned and valid_etcbs) (pspace_aligned' and pspace_distinct') (mapM (swp store_pde ARM_A.pde.InvalidPDE) ys) (mapM (swp storePDE ab) ys)" apply (rule_tac S ="{(x,y). x = y \ x \ set ys}" in corres_mapM[where r = dc and r' = dc]) apply simp apply simp apply clarsimp apply (rule corres_guard_imp) apply (rule store_pde_corres') apply (drule bspec) apply simp apply (simp add:pde_relation_aligned_def) apply auto[1] apply (drule bspec, simp) apply simp apply (wp hoare_vcg_ball_lift | simp)+ apply clarsimp done lemma corres_store_pte_with_invalid_tail: "\slot\ set ys. \ is_aligned (slot >> 2) (pte_align' aa) \ corres dc ((\s. \y\set ys. pte_at y s) and pspace_aligned and valid_etcbs) (pspace_aligned' and pspace_distinct') (mapM (swp store_pte ARM_A.pte.InvalidPTE) ys) (mapM (swp storePTE aa) ys)" apply (rule_tac S ="{(x,y). x = y \ x \ set ys}" in corres_mapM[where r = dc and r' = dc]) apply simp apply simp apply clarsimp apply (rule corres_guard_imp) apply (rule store_pte_corres') apply (drule bspec) apply simp apply (simp add:pte_relation_aligned_def) apply auto[1] apply (drule bspec,simp) apply simp apply (wp hoare_vcg_ball_lift | simp)+ apply clarsimp done lemma updateCap_valid_slots'[wp]: "\valid_slots' x2\ updateCap cte cte' \\_ s. valid_slots' x2 s \" apply (case_tac x2) apply (clarsimp simp:valid_slots'_def) apply (wp hoare_vcg_ball_lift) apply (clarsimp simp:valid_slots'_def) apply (wp hoare_vcg_ball_lift) done lemma pte_check_if_mapped_corres: "corres (=) (pte_at slot) ((\s. vs_valid_duplicates' (ksPSpace s)) and pspace_aligned' and pspace_distinct') (pte_check_if_mapped slot) (pteCheckIfMapped slot)" apply (simp add: pte_check_if_mapped_def pteCheckIfMapped_def) apply (rule corres_guard_imp) apply (rule corres_split[OF _ get_master_pte_corres', simplified]) apply (rule corres_return[where P="pte_at slot" and P'="pspace_aligned' and pspace_distinct'", THEN iffD2]) apply (clarsimp simp: pte_relation'_def split: ) apply (case_tac pt, simp_all)[1] apply wp+ apply (simp) apply simp done lemma pde_check_if_mapped_corres: "corres (=) (pde_at slot) ((\s. vs_valid_duplicates' (ksPSpace s)) and pspace_aligned' and pspace_distinct') (pde_check_if_mapped slot) (pdeCheckIfMapped slot)" apply (simp add: pde_check_if_mapped_def pdeCheckIfMapped_def) apply (rule corres_guard_imp) apply (rule corres_split[OF _ get_master_pde_corres', simplified]) apply (rule corres_return[where P="pde_at slot" and P'="pspace_aligned' and pspace_distinct'", THEN iffD2]) apply (clarsimp simp: pte_relation'_def split: ) apply (case_tac pd, simp_all)[1] apply wp+ apply (clarsimp simp: pte_relation_aligned_def split: if_split_asm) apply simp done crunches do_machine_op, store_pte for unique_table_refs[wp]: "\s. (unique_table_refs (caps_of_state s))" and valid_asid_map[wp]: "valid_asid_map" lemma set_cap_pd_at_asid [wp]: "\vspace_at_asid asid pd\ set_cap t st \\rv. vspace_at_asid asid pd\" apply (simp add: vspace_at_asid_def) apply wp done lemma set_cap_valid_slots_inv[wp]: "\valid_slots m\ set_cap t st \\rv. valid_slots m\" by (cases m, (clarsimp simp: valid_slots_def, wp hoare_vcg_ball_lift set_cap.vs_lookup set_cap_typ_ats)+) lemma set_cap_same_refs_inv[wp]: "\\s. same_refs m cap s\ set_cap t st \\rv s. same_refs m cap s\" by (cases m, (clarsimp simp: same_refs_def, wp)+) definition "valid_page_map_inv asid cap ptr m \ (\s. caps_of_state s ptr = Some cap) and same_refs m cap and valid_slots m and valid_cap cap and K (is_pg_cap cap \ empty_refs m \ asid \ mask asid_bits \ asid \ 0) and (\s. \sl. cte_wp_at (parent_for_refs m) sl s) and (\s. \pd. vspace_at_asid asid pd s)" lemma set_cap_valid_page_map_inv: "\valid_page_inv (ARM_A.page_invocation.PageMap asid cap slot m)\ set_cap cap slot \\rv. valid_page_map_inv asid cap slot m\" apply (simp add: valid_page_inv_def valid_page_map_inv_def) apply (wp set_cap_cte_wp_at_cases hoare_vcg_ex_lift| simp)+ apply clarsimp apply (rule conjI, fastforce simp: cte_wp_at_def) apply (rule_tac x=a in exI, rule_tac x=b in exI) apply (subgoal_tac "(a,b) \ slot") apply clarsimp apply (clarsimp simp: cte_wp_at_def parent_for_refs_def) apply (auto simp: is_pt_cap_def is_pg_cap_def is_pd_cap_def split: sum.splits) done lemma duplicate_address_set_simp: "\koTypeOf m \ ArchT PDET; koTypeOf m \ ArchT PTET \ \ p && ~~ mask (vs_ptr_align m) = p" by (auto simp:vs_ptr_align_def koTypeOf_def split:kernel_object.splits arch_kernel_object.splits)+ lemma valid_duplicates'_non_pd_pt_I: "\koTypeOf ko \ ArchT PDET; koTypeOf ko \ ArchT PTET; vs_valid_duplicates' (ksPSpace s) ; ksPSpace s p = Some ko; koTypeOf ko = koTypeOf m\ \ vs_valid_duplicates' (ksPSpace s(p \ m))" apply (subst vs_valid_duplicates'_def) apply (intro allI impI) apply (clarsimp split:if_splits simp:duplicate_address_set_simp option.splits) apply (intro conjI impI allI) apply (frule_tac p = x and p' = p in valid_duplicates'_D) apply assumption apply simp apply (simp add:duplicate_address_set_simp)+ apply (drule_tac m = "ksPSpace s" and p = x in valid_duplicates'_D) apply simp+ done lemma setCTE_valid_duplicates'[wp]: "\\s. vs_valid_duplicates' (ksPSpace s)\ setCTE p cte \\rv s. vs_valid_duplicates' (ksPSpace s)\" apply (simp add:setCTE_def) 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 = cte,simplified]) apply (clarsimp simp:ObjectInstances_H.updateObject_cte assert_def bind_def alignCheck_def in_monad when_def alignError_def magnitudeCheck_def assert_opt_def return_def fail_def typeError_def split:if_splits option.splits Structures_H.kernel_object.splits) apply (erule valid_duplicates'_non_pd_pt_I[rotated 3],simp+)+ done crunch valid_duplicates'[wp]: updateCap "\s. vs_valid_duplicates' (ksPSpace s)" (wp: crunch_wps simp: crunch_simps unless_def) lemma message_info_to_data_eqv: "wordFromMessageInfo (message_info_map mi) = message_info_to_data mi" apply (cases mi) apply (simp add: wordFromMessageInfo_def msgLengthBits_def msgExtraCapBits_def msgMaxExtraCaps_def shiftL_nat) done lemma message_info_from_data_eqv: "message_info_map (data_to_message_info rv) = messageInfoFromWord rv" by (auto simp: data_to_message_info_def messageInfoFromWord_def Let_def not_less msgLengthBits_def msgExtraCapBits_def msgMaxExtraCaps_def mask_def shiftL_nat msgMaxLength_def msgLabelBits_def) lemma set_mi_corres: "mi' = message_info_map mi \ corres dc (tcb_at t) (tcb_at' t) (set_message_info t mi) (setMessageInfo t mi')" apply (simp add: setMessageInfo_def set_message_info_def) apply (subgoal_tac "wordFromMessageInfo (message_info_map mi) = message_info_to_data mi") apply (simp add: user_setreg_corres msg_info_register_def msgInfoRegister_def) apply (simp add: message_info_to_data_eqv) done lemma set_mi_invs'[wp]: "\invs' and tcb_at' t\ setMessageInfo t a \\x. invs'\" by (simp add: setMessageInfo_def) wp lemma set_mi_tcb' [wp]: "\ tcb_at' t \ setMessageInfo receiver msg \\rv. tcb_at' t\" by (simp add: setMessageInfo_def) wp lemma setMRs_typ_at': "\\s. P (typ_at' T p s)\ setMRs receiver recv_buf mrs \\rv s. P (typ_at' T p s)\" by (simp add: setMRs_def zipWithM_x_mapM split_def, wp crunch_wps) lemmas setMRs_typ_at_lifts[wp] = typ_at_lifts [OF setMRs_typ_at'] lemma set_mrs_invs'[wp]: "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" apply (simp add: setMRs_def) apply (wp dmo_invs' no_irq_mapM no_irq_storeWord crunch_wps| simp add: zipWithM_x_mapM split_def)+ done lemma same_refs_vs_cap_ref_eq: assumes "valid_slots entries s" assumes "same_refs entries cap s" assumes "same_refs entries cap' s" shows "vs_cap_ref cap = vs_cap_ref cap'" using assms apply (cases entries; clarsimp simp: same_refs_def valid_slots_def) apply (all \rename_tac pte slots p; case_tac slots; clarsimp\) done lemma perform_page_corres: assumes "page_invocation_map pgi pgi'" shows "corres dc (invs and valid_etcbs and valid_page_inv pgi) (invs' and valid_page_inv' pgi' and (\s. vs_valid_duplicates' (ksPSpace s))) (perform_page_invocation pgi) (performPageInvocation pgi')" proof - have pull_out_P: "\P s Q c p. P s \ (\c. caps_of_state s p = Some c \ Q s c) \ (\c. caps_of_state s p = Some c \ P s \ Q s c)" by blast show ?thesis using assms apply (cases pgi) apply (rename_tac word cap prod sum) \ \PageMap\ apply (clarsimp simp: perform_page_invocation_def performPageInvocation_def page_invocation_map_def) apply (rule corres_guard_imp) apply (rule_tac R="\_. invs and (valid_page_map_inv word cap (a,b) sum) and valid_etcbs and (\s. caps_of_state s (a,b) = Some cap)" and R'="\_. invs' and valid_slots' m' and pspace_aligned' and valid_slots_duplicated' m' and pspace_distinct' and (\s. vs_valid_duplicates' (ksPSpace s))" in corres_split) prefer 2 apply (erule updateCap_same_master) apply (case_tac sum, case_tac aa) apply (clarsimp simp: mapping_map_def valid_slots'_def valid_slots_def valid_page_inv_def neq_Nil_conv valid_page_map_inv_def) apply (rule corres_name_pre) apply (clarsimp simp: mapM_Cons bind_assoc split del: if_split) apply (rule corres_guard_imp) apply (rule corres_split[OF _ pte_check_if_mapped_corres]) apply (rule corres_split[OF _ store_pte_corres']) apply (rule corres_split[where r' = dc, OF _ corres_store_pte_with_invalid_tail]) apply (rule corres_split[where r'=dc, OF _ corres_machine_op[OF corres_Id]]) apply (clarsimp simp add: when_def) apply (rule invalidate_tlb_by_asid_corres_ex) apply (simp add: last_byte_pte_def objBits_simps archObjSize_def pteBits_def) apply simp apply (rule no_fail_cleanCacheRange_PoU) apply (wp hoare_vcg_ex_lift)+ apply (clarsimp simp: pte_relation_aligned_def) apply (clarsimp dest!: valid_slots_duplicated_pteD') apply (rule_tac Q="\_. K (word \ mask asid_bits \ word \ 0) and invs and (\s. \pd. vspace_at_asid word pd s)" in hoare_strengthen_post) prefer 2 apply (auto simp: invs_vspace_objs[simplified])[1] apply (wp mapM_swp_store_pte_invs[where pte="ARM_A.pte.InvalidPTE", simplified] hoare_vcg_ex_lift) apply (wp mapM_UNIV_wp | simp add: swp_def del: fun_upd_apply)+ apply (clarsimp simp:pte_relation_aligned_def) apply (clarsimp dest!:valid_slots_duplicated_pteD') apply (clarsimp simp del: fun_upd_apply simp add: cte_wp_at_caps_of_state) apply (wp hoare_vcg_const_Ball_lift store_pte_typ_at store_pte_cte_wp_at hoare_vcg_ex_lift)+ apply (wpsimp simp: pteCheckIfMapped_def) apply (clarsimp simp add: cte_wp_at_caps_of_state valid_slots_def parent_for_refs_def empty_refs_def invs_psp_aligned simp del: fun_upd_apply) apply (rule conjI) apply (rule_tac x=aa in exI, rule_tac x=ba in exI) apply (clarsimp simp: is_pt_cap_def cap_asid_def image_def neq_Nil_conv Collect_disj_eq split: Structures_A.cap.splits arch_cap.splits option.splits) apply (rule conjI) apply clarsimp apply (drule same_refs_lD) apply (rule_tac x=a in exI, rule_tac x=b in exI) apply clarify apply (drule_tac x=refa in spec) apply clarsimp apply (rule conjI[rotated], fastforce) apply auto[1] apply clarsimp apply (case_tac ba) apply (clarsimp simp: mapping_map_def valid_slots_def valid_slots'_def neq_Nil_conv valid_page_inv_def valid_page_map_inv_def) apply (rule corres_name_pre) apply (clarsimp simp: mapM_Cons bind_assoc split del:if_split) apply (rule corres_guard_imp) apply (rule corres_split[OF _ pde_check_if_mapped_corres]) apply (rule corres_split[OF _ store_pde_corres']) apply (rule corres_split[where r'=dc, OF _ corres_store_pde_with_invalid_tail]) apply (rule corres_split[where r'=dc,OF _ corres_machine_op[OF corres_Id]]) apply (clarsimp simp: when_def) apply (rule invalidate_tlb_by_asid_corres_ex) apply (simp add: last_byte_pde_def objBits_simps archObjSize_def pdeBits_def) apply simp apply (rule no_fail_cleanCacheRange_PoU) apply (wp hoare_vcg_ex_lift)+ apply (clarsimp simp: pde_relation_aligned_def) apply (clarsimp dest!:valid_slots_duplicated_pdeD' ) apply (rule_tac Q="\_. K (word \ mask asid_bits \ word \ 0) and invs and (\s. \pd. vspace_at_asid word pd s)" in hoare_strengthen_post) prefer 2 apply (auto simp: invs_vspace_objs[simplified])[1] apply (wp mapM_swp_store_pde_invs_unmap[where pde="ARM_A.pde.InvalidPDE", simplified] hoare_vcg_ex_lift) apply (wp mapM_UNIV_wp store_pde_pd_at_asid | clarsimp simp add: swp_def)+ apply (clarsimp simp: pde_relation_aligned_def) apply (clarsimp dest!:valid_slots_duplicated_pdeD') apply (clarsimp simp add: cte_wp_at_caps_of_state simp del: fun_upd_apply) apply (wp hoare_vcg_const_Ball_lift store_pde_typ_at hoare_vcg_ex_lift store_pde_pd_at_asid) apply (rule hoare_vcg_conj_lift) apply (rule_tac slots="y # ys" in store_pde_invs_unmap') apply (wp hoare_vcg_const_Ball_lift store_pde_pd_at_asid hoare_vcg_ex_lift) apply (wp | simp add: pdeCheckIfMapped_def)+ apply (clarsimp simp add: cte_wp_at_caps_of_state valid_slots_def parent_for_refs_def empty_refs_def invs_psp_aligned simp del: fun_upd_apply) apply (rule conjI, rule_tac x=ref in exI, clarsimp) apply (rule conjI) apply (rule_tac x=aa in exI, rule_tac x=ba in exI) apply auto[1] apply (rule conjI) apply (rule_tac x=a in exI, rule_tac x=b in exI, auto simp: same_refs_def)[1] apply (rule conjI) apply (clarsimp simp: pde_at_def obj_at_def caps_of_state_cteD'[where P=\, simplified]) apply (drule_tac cap=capa and ptr="(aa,ba)" in valid_global_refsD[OF invs_valid_global_refs]) apply assumption+ apply (clarsimp simp: cap_range_def) apply (rule conjI) apply (clarsimp simp: pde_at_def obj_at_def a_type_def) apply (clarsimp split: Structures_A.kernel_object.split_asm if_split_asm ARM_A.arch_kernel_obj.splits) apply (rule conjI[rotated], fastforce) apply (erule ballEI) apply (clarsimp simp: pde_at_def obj_at_def caps_of_state_cteD'[where P=\, simplified]) apply (drule_tac cap=capa and ptr="(aa,ba)" in valid_global_refsD[OF invs_valid_global_refs]) apply assumption+ apply (drule_tac x=x in imageI[where f="\x. x && ~~ mask pd_bits"]) apply (drule (1) subsetD) apply (clarsimp simp: cap_range_def) apply clarsimp apply (wp arch_update_cap_invs_map set_cap_valid_page_map_inv) apply (wp arch_update_updateCap_invs) apply (clarsimp simp: invs_valid_objs invs_psp_aligned invs_distinct valid_page_inv_def cte_wp_at_caps_of_state is_arch_update_def is_cap_simps) apply (erule (3) subst[OF same_refs_vs_cap_ref_eq, rotated 2]) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' valid_page_inv'_def cte_wp_at'_def) \ \PageUnmap\ apply (clarsimp simp: performPageInvocation_def perform_page_invocation_def page_invocation_map_def) apply (rule corres_assume_pre) apply (clarsimp simp: valid_page_inv_def valid_page_inv'_def isCap_simps is_page_cap_def cong: option.case_cong prod.case_cong) apply (case_tac m) apply simp apply (rule corres_guard_imp) apply (rule corres_split [where r'="acap_relation"]) prefer 2 apply simp apply (rule corres_rel_imp) apply (rule get_cap_corres_all_rights_P[where P=is_arch_cap], rule refl) apply (clarsimp simp: is_cap_simps) apply (rule_tac F="is_page_cap cap" in corres_gen_asm) apply (rule updateCap_same_master) apply (clarsimp simp: is_page_cap_def update_map_data_def) apply (wp get_cap_wp getSlotCap_wp)+ apply (clarsimp simp: cte_wp_at_caps_of_state) apply (clarsimp simp: cap_rights_update_def acap_rights_update_def update_map_data_def is_cap_simps) apply auto[1] apply (auto simp: cte_wp_at_ctes_of)[1] apply clarsimp apply (rule corres_guard_imp) apply (rule corres_split) prefer 2 apply (rule unmap_page_corres) apply (rule corres_split [where r'=acap_relation]) prefer 2 apply simp apply (rule corres_rel_imp) apply (rule get_cap_corres_all_rights_P[where P=is_arch_cap], rule refl) apply (clarsimp simp: is_cap_simps) apply (rule_tac F="is_page_cap cap" in corres_gen_asm) apply (rule updateCap_same_master) apply (clarsimp simp: is_page_cap_def update_map_data_def) apply (wp get_cap_wp getSlotCap_wp)+ apply (simp add: cte_wp_at_caps_of_state) apply (strengthen pull_out_P)+ apply wp apply (simp add: cte_wp_at_ctes_of) apply wp apply (clarsimp simp: valid_unmap_def cte_wp_at_caps_of_state) apply (clarsimp simp: is_cap_simps split: cap.splits arch_cap.splits) apply (clarsimp simp: cap_rights_update_def is_page_cap_def cap_master_cap_simps update_map_data_def acap_rights_update_def) apply (clarsimp simp add: valid_cap_def mask_def) apply auto[1] apply (auto simp: cte_wp_at_ctes_of)[1] \ \PageFlush\ apply (clarsimp simp: performPageInvocation_def perform_page_invocation_def page_invocation_map_def) apply (rule corres_guard_imp) apply (rule corres_when, simp) apply (rule corres_split [OF _ set_vm_root_for_flush_corres]) apply (rule corres_split [OF _ corres_machine_op]) prefer 2 apply (rule do_flush_corres) apply (rule corres_when, simp) apply (rule corres_split [OF _ gct_corres]) apply simp apply (rule set_vm_root_corres) apply wp+ apply (simp add: cur_tcb_def [symmetric] cur_tcb'_def [symmetric]) apply (wp hoare_drop_imps) apply (simp add: cur_tcb_def [symmetric] cur_tcb'_def [symmetric]) apply (wp hoare_drop_imps)+ apply (auto simp: valid_page_inv_def invs_vspace_objs[simplified])[2] \ \PageGetAddr\ apply (clarsimp simp: perform_page_invocation_def performPageInvocation_def page_invocation_map_def fromPAddr_def) apply (rule corres_guard_imp) apply (rule corres_split[OF _ gct_corres]) apply simp apply (rule corres_split[OF set_mi_corres set_mrs_corres]) apply (simp add: message_info_map_def) apply clarsimp apply (wp)+ apply (clarsimp simp: tcb_at_invs) apply (clarsimp simp: tcb_at_invs') done qed definition "page_table_invocation_map pti pti' \ case pti of ARM_A.PageTableMap cap ptr pde p \ \cap' pde'. pti' = PageTableMap cap' (cte_map ptr) pde' p \ cap_relation cap cap' \ pde_relation' pde pde' \ is_aligned (p >> 2) (pde_align' pde') | ARM_A.PageTableUnmap cap ptr \ \cap'. pti' = PageTableUnmap cap' (cte_map ptr) \ cap_relation cap (ArchObjectCap cap')" definition "valid_pti' pti \ case pti of PageTableMap cap slot pde pdeSlot \ cte_wp_at' (is_arch_update' cap) slot and ko_wp_at' (\ko. vs_entry_align ko = 0) pdeSlot and valid_cap' cap and valid_pde' pde and K (valid_pde_mapping' (pdeSlot && mask pdBits) pde \ vs_entry_align (KOArch (KOPDE pde)) = 0) | PageTableUnmap cap slot \ cte_wp_at' (is_arch_update' (ArchObjectCap cap)) slot and valid_cap' (ArchObjectCap cap) and K (isPageTableCap cap)" lemma clear_page_table_corres: "corres dc (pspace_aligned and page_table_at p and valid_etcbs) (pspace_aligned' and pspace_distinct') (mapM_x (swp store_pte ARM_A.InvalidPTE) [p , p + 4 .e. p + 2 ^ ptBits - 1]) (mapM_x (swp storePTE ARM_H.InvalidPTE) [p , p + 4 .e. p + 2 ^ ptBits - 1])" apply (rule_tac F="is_aligned p ptBits" in corres_req) apply (clarsimp simp: obj_at_def a_type_def) apply (clarsimp split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) apply (drule(1) pspace_alignedD) apply (simp add: ptBits_def pageBits_def pteBits_def) apply (simp add: upto_enum_step_subtract[where x=p and y="p + 4"] is_aligned_no_overflow pt_bits_stuff upto_enum_step_red[where us=2, simplified] mapM_x_mapM liftM_def[symmetric]) apply (rule corres_guard_imp, rule_tac r'=dc and S="(=)" and Q="\xs s. \x \ set xs. pte_at x s \ pspace_aligned s \ valid_etcbs s" and Q'="\xs. pspace_aligned' and pspace_distinct'" in corres_mapM_list_all2, simp_all) apply (rule corres_guard_imp, rule store_pte_corres') apply (simp add:pte_relation_aligned_def)+ apply (wp hoare_vcg_const_Ball_lift | simp)+ apply (simp add: list_all2_refl) apply (clarsimp simp: upto_enum_step_def) apply (erule page_table_pte_atI[simplified shiftl_t2n mult.commute, simplified]) apply (simp add: ptBits_def pageBits_def pt_bits_def word_less_nat_alt word_le_nat_alt unat_of_nat pteBits_def) apply simp done crunch typ_at'[wp]: unmapPageTable "\s. P (typ_at' T p s)" lemmas unmapPageTable_typ_ats[wp] = typ_at_lifts[OF unmapPageTable_typ_at'] lemma perform_page_table_corres: "page_table_invocation_map pti pti' \ corres dc (invs and valid_etcbs and valid_pti pti) (invs' and valid_pti' pti') (perform_page_table_invocation pti) (performPageTableInvocation pti')" (is "?mp \ corres dc ?P ?P' ?f ?g") apply (simp add: perform_page_table_invocation_def performPageTableInvocation_def) apply (cases pti) apply (clarsimp simp: page_table_invocation_map_def) apply (rule corres_guard_imp) apply (rule corres_split [OF _ updateCap_same_master]) prefer 2 apply assumption apply (rule corres_split [OF _ store_pde_corres']) apply (rule corres_machine_op) apply (rule corres_Id, rule refl, simp) apply (rule no_fail_cleanByVA_PoU) apply (simp add: pde_relation_aligned_def) apply (wp set_cap_typ_at)+ apply (clarsimp simp: valid_pti_def cte_wp_at_caps_of_state is_arch_update_def) apply (clarsimp simp: is_cap_simps cap_master_cap_simps dest!: cap_master_cap_eqDs) apply auto[1] apply (clarsimp simp: cte_wp_at_ctes_of valid_pti'_def) apply auto[1] apply (clarsimp simp:valid_pde_mapping'_def split:ARM_H.pde.split) apply (rename_tac cap a b) apply (clarsimp simp: page_table_invocation_map_def) apply (rule_tac F="is_pt_cap cap" in corres_req) apply (clarsimp simp: valid_pti_def) apply (clarsimp simp: is_pt_cap_def split_def pt_bits_stuff objBits_simps archObjSize_def cong: option.case_cong) apply (simp add: case_option_If2 getSlotCap_def split del: if_split) apply (rule corres_guard_imp) apply (rule corres_split_nor) apply (simp add: liftM_def) apply (rule corres_split [OF _ get_cap_corres]) apply (rule_tac F="is_pt_cap x" in corres_gen_asm) apply (rule updateCap_same_master) apply (clarsimp simp: is_pt_cap_def update_map_data_def) apply (wp get_cap_wp)+ apply (rule corres_if[OF refl]) apply (rule corres_split [OF _ unmap_page_table_corres]) apply (rule corres_split_nor) apply (rule corres_machine_op, rule corres_Id) apply (simp add: pteBits_def)+ apply (rule clear_page_table_corres) apply wp+ apply (rule corres_trivial, simp) apply (simp add: cte_wp_at_caps_of_state pred_conj_def split del: if_split) apply (rule hoare_lift_Pf2[where f=caps_of_state]) apply (wp hoare_vcg_all_lift hoare_vcg_const_imp_lift mapM_x_wp' | simp split del: if_split)+ apply (clarsimp simp: valid_pti_def cte_wp_at_caps_of_state cap_master_cap_simps update_map_data_def is_cap_simps cap_rights_update_def acap_rights_update_def dest!: cap_master_cap_eqDs) apply (auto simp: valid_cap_def mask_def cap_master_cap_def cap_rights_update_def acap_rights_update_def split: option.split_asm)[1] apply (auto simp: valid_pti'_def cte_wp_at_ctes_of) done definition "asid_pool_invocation_map ap \ case ap of asid_pool_invocation.Assign asid p slot \ Assign asid p (cte_map slot)" definition "isPDCap cap \ \p asid. cap = ArchObjectCap (PageDirectoryCap p asid)" definition "valid_apinv' ap \ case ap of Assign asid p slot \ asid_pool_at' p and cte_wp_at' (isPDCap o cteCap) slot and K (0 < asid \ asid \ 2^asid_bits - 1)" lemma pap_corres: "ap' = asid_pool_invocation_map ap \ corres dc (valid_objs and pspace_aligned and pspace_distinct and valid_apinv ap and valid_etcbs) (pspace_aligned' and pspace_distinct' and valid_apinv' ap') (perform_asid_pool_invocation ap) (performASIDPoolInvocation ap')" apply (clarsimp simp: perform_asid_pool_invocation_def performASIDPoolInvocation_def) apply (cases ap, simp add: asid_pool_invocation_map_def) apply (rename_tac word1 word2 prod) apply (rule corres_guard_imp) apply (rule corres_split [OF _ getSlotCap_corres]) apply (rule_tac F="\p asid. rv = Structures_A.ArchObjectCap (ARM_A.PageDirectoryCap p asid)" in corres_gen_asm) apply clarsimp apply (rule_tac Q="valid_objs and pspace_aligned and pspace_distinct and asid_pool_at word2 and valid_etcbs and cte_wp_at (\c. cap_master_cap c = cap_master_cap (cap.ArchObjectCap (arch_cap.PageDirectoryCap p asid))) (a,b)" in corres_split) prefer 2 apply simp apply (rule get_asid_pool_corres_inv') apply (rule corres_split) prefer 2 apply (rule updateCap_same_master) apply simp apply (rule corres_rel_imp) apply simp apply (rule set_asid_pool_corres[OF refl]) apply (simp add: inv_def) apply (rule ext) apply (clarsimp simp: mask_asid_low_bits_ucast_ucast) apply (drule ucast_ucast_eq, simp, simp, simp) apply assumption apply (wp set_cap_typ_at)+ apply clarsimp apply (erule cte_wp_at_weakenE) apply (clarsimp simp: is_cap_simps cap_master_cap_simps dest!: cap_master_cap_eqDs) apply (wp getASID_wp) apply (rule refl) apply (wp get_cap_wp getCTE_wp)+ apply (clarsimp simp: valid_apinv_def cte_wp_at_def cap_master_cap_def is_pd_cap_def obj_at_def) apply (clarsimp simp: a_type_def) apply (clarsimp simp: cte_wp_at_ctes_of valid_apinv'_def) done lemma armv_contextSwitch_obj_at [wp]: "\\s. P (obj_at' P' t s)\ armv_contextSwitch pd a \\rv s. P (obj_at' P' t s)\" apply (simp add: armv_contextSwitch_def armv_contextSwitch_HWASID_def getHWASID_def) apply (wp doMachineOp_obj_at|wpc|simp)+ done crunch obj_at[wp]: setVMRoot "\s. P (obj_at' P' t s)" (simp: crunch_simps) lemma storeHWASID_invs: "\invs' and (\s. armKSASIDMap (ksArchState s) asid = None \ armKSHWASIDTable (ksArchState s) hw_asid = None)\ storeHWASID asid hw_asid \\x. invs'\" apply (rule hoare_add_post) apply (rule storeHWASID_valid_arch') apply fastforce apply (simp add: storeHWASID_def) apply (wp findPDForASIDAssert_pd_at_wp) apply (clarsimp simp: invs'_def valid_state'_def valid_arch_state'_def valid_global_refs'_def global_refs'_def valid_machine_state'_def ct_not_inQ_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) done lemma storeHWASID_invs_no_cicd': "\invs_no_cicd' and (\s. armKSASIDMap (ksArchState s) asid = None \ armKSHWASIDTable (ksArchState s) hw_asid = None)\ storeHWASID asid hw_asid \\x. invs_no_cicd'\" apply (rule hoare_add_post) apply (rule storeHWASID_valid_arch') apply (fastforce simp: all_invs_but_ct_idle_or_in_cur_domain'_def) apply (simp add: storeHWASID_def) apply (wp findPDForASIDAssert_pd_at_wp) apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def valid_arch_state'_def valid_global_refs'_def global_refs'_def valid_machine_state'_def ct_not_inQ_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) done lemma findFreeHWASID_invs: "\invs'\ findFreeHWASID \\asid. invs'\" apply (rule hoare_add_post) apply (rule findFreeHWASID_valid_arch) apply fastforce apply (simp add: findFreeHWASID_def invalidateHWASIDEntry_def invalidateASID_def doMachineOp_def split_def cong: option.case_cong) apply (wp findPDForASIDAssert_pd_at_wp | wpc)+ apply (clarsimp simp: invs'_def valid_state'_def valid_arch_state'_def valid_global_refs'_def global_refs'_def valid_machine_state'_def ct_not_inQ_def split del: if_split) apply (intro conjI) apply (fastforce dest: no_irq_use [OF no_irq_invalidateLocalTLB_ASID]) apply clarsimp apply (drule_tac x=p in spec) apply (drule use_valid) apply (rule_tac p=p in invalidateLocalTLB_ASID_underlying_memory) apply blast apply clarsimp apply (simp add: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) done lemma findFreeHWASID_invs_no_cicd': "\invs_no_cicd'\ findFreeHWASID \\asid. invs_no_cicd'\" apply (rule hoare_add_post) apply (rule findFreeHWASID_valid_arch) apply (fastforce simp: all_invs_but_ct_idle_or_in_cur_domain'_def) apply (simp add: findFreeHWASID_def invalidateHWASIDEntry_def invalidateASID_def doMachineOp_def split_def cong: option.case_cong) apply (wp findPDForASIDAssert_pd_at_wp | wpc)+ apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def valid_arch_state'_def valid_global_refs'_def global_refs'_def valid_machine_state'_def ct_not_inQ_def split del: if_split) apply (intro conjI) apply (fastforce dest: no_irq_use [OF no_irq_invalidateLocalTLB_ASID]) apply clarsimp apply (drule_tac x=p in spec) apply (drule use_valid) apply (rule_tac p=p in invalidateLocalTLB_ASID_underlying_memory) apply blast apply clarsimp done lemma getHWASID_invs [wp]: "\invs'\ getHWASID asid \\hw_asid. invs'\" apply (simp add: getHWASID_def) apply (wp storeHWASID_invs findFreeHWASID_invs|wpc)+ apply simp done lemma getHWASID_invs_no_cicd': "\invs_no_cicd'\ getHWASID asid \\hw_asid. invs_no_cicd'\" apply (simp add: getHWASID_def) apply (wp storeHWASID_invs_no_cicd' findFreeHWASID_invs_no_cicd'|wpc)+ apply simp done lemmas armv_ctxt_sw_defs = armv_contextSwitch_HWASID_def setHardwareASID_def setCurrentPD_def writeTTBR0_def writeTTBR0Ptr_def set_current_pd_def isb_def dsb_def lemma no_irq_armv_contextSwitch_HWASID: "no_irq (armv_contextSwitch_HWASID pd hwasid)" apply (simp add: armv_contextSwitch_HWASID_def setCurrentPD_to_abs) apply (wp no_irq_set_current_pd no_irq_setHardwareASID) done lemma armv_contextSwitch_invs [wp]: "\invs'\ armv_contextSwitch pd asid \\rv. invs'\" apply (simp add: armv_contextSwitch_def) apply (wp dmo_invs' no_irq_armv_contextSwitch_HWASID no_irq hoare_vcg_all_lift) apply (rule hoare_post_imp[rotated], rule hoare_vcg_prop[where P=True]) apply clarsimp apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" in use_valid) apply (simp add: machine_op_lift_def machine_rest_lift_def split_def armv_ctxt_sw_defs writeTTBR0Ptr_def | wp)+ done lemma armv_contextSwitch_invs_no_cicd': "\invs_no_cicd'\ armv_contextSwitch pd asid \\rv. invs_no_cicd'\" apply (simp add: armv_contextSwitch_def armv_contextSwitch_HWASID_def setCurrentPD_to_abs) apply (wp dmo_invs_no_cicd' no_irq_setHardwareASID no_irq_set_current_pd no_irq) apply (rule hoare_post_imp[rotated], rule getHWASID_invs_no_cicd') apply clarsimp apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" in use_valid) apply (clarsimp simp: machine_op_lift_def machine_rest_lift_def split_def armv_ctxt_sw_defs | wp)+ done lemma dmo_setCurrentPD_invs'[wp]: "\invs'\ doMachineOp (setCurrentPD addr) \\rv. invs'\" apply (wpsimp wp: dmo_invs' no_irq_set_current_pd no_irq simp: setCurrentPD_to_abs) apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" in use_valid) apply (clarsimp simp: set_current_pd_def machine_op_lift_def writeTTBR0_def dsb_def isb_def machine_rest_lift_def split_def | wp)+ done lemma dmo_setCurrentPD_invs_no_cicd': "\invs_no_cicd'\ doMachineOp (setCurrentPD addr) \\rv. invs_no_cicd'\" apply (wpsimp wp: dmo_invs_no_cicd' no_irq_set_current_pd no_irq simp: setCurrentPD_to_abs) apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" in use_valid) apply (clarsimp simp: set_current_pd_def machine_op_lift_def writeTTBR0_def dsb_def isb_def machine_rest_lift_def split_def | wp)+ done crunch invs[wp]: setVMRoot "invs'" (wp: crunch_wps simp: crunch_simps ignore: doMachineOp) crunch invs_no_cicd': setVMRoot "invs_no_cicd'" (wp: crunch_wps dmo_setCurrentPD_invs_no_cicd' simp: crunch_simps ignore: doMachineOp) crunch nosch [wp]: setVMRoot "\s. P (ksSchedulerAction s)" (wp: crunch_wps getObject_inv simp: crunch_simps loadObject_default_def) crunch it' [wp]: findPDForASID "\s. P (ksIdleThread s)" (simp: crunch_simps loadObject_default_def wp: getObject_inv) crunch it' [wp]: deleteASIDPool "\s. P (ksIdleThread s)" (simp: crunch_simps loadObject_default_def wp: getObject_inv mapM_wp') crunch it' [wp]: lookupPTSlot "\s. P (ksIdleThread s)" (simp: crunch_simps loadObject_default_def wp: getObject_inv) crunch it' [wp]: storePTE "\s. P (ksIdleThread s)" (simp: crunch_simps updateObject_default_def wp: setObject_idle') crunch it' [wp]: storePDE "\s. P (ksIdleThread s)" (simp: crunch_simps updateObject_default_def wp: setObject_idle') crunch it' [wp]: flushTable "\s. P (ksIdleThread s)" (simp: crunch_simps loadObject_default_def wp: setObject_idle' hoare_drop_imps mapM_wp') crunch it' [wp]: deleteASID "\s. P (ksIdleThread s)" (simp: crunch_simps loadObject_default_def updateObject_default_def wp: getObject_inv) lemma valid_slots_lift': assumes t: "\T p. \typ_at' T p\ f \\rv. typ_at' T p\" shows "\valid_slots' x\ f \\rv. valid_slots' x\" apply (clarsimp simp: valid_slots'_def split: sum.splits prod.splits) apply safe apply (rule hoare_pre, wp hoare_vcg_const_Ball_lift t valid_pde_lift' valid_pte_lift', simp)+ done crunch typ_at' [wp]: performPageTableInvocation "\s. P (typ_at' T p s)" (wp: crunch_wps) crunch typ_at' [wp]: performPageDirectoryInvocation "\s. P (typ_at' T p s)" (wp: crunch_wps) crunch typ_at' [wp]: performPageInvocation "\s. P (typ_at' T p s)" (wp: crunch_wps) crunch typ_at' [wp]: performASIDPoolInvocation "\s. P (typ_at' T p s)" (wp: getObject_cte_inv getASID_wp) lemmas performPageTableInvocation_typ_ats' [wp] = typ_at_lifts [OF performPageTableInvocation_typ_at'] lemmas performPageDirectoryInvocation_typ_ats' [wp] = typ_at_lifts [OF performPageDirectoryInvocation_typ_at'] lemmas performPageInvocation_typ_ats' [wp] = typ_at_lifts [OF performPageInvocation_typ_at'] lemmas performASIDPoolInvocation_typ_ats' [wp] = typ_at_lifts [OF performASIDPoolInvocation_typ_at'] lemma storePDE_pred_tcb_at' [wp]: "\pred_tcb_at' proj P t\ storePDE p pde \\_. pred_tcb_at' proj P t\" apply (simp add: storePDE_def pred_tcb_at'_def) apply (rule obj_at_setObject2) apply (clarsimp simp add: updateObject_default_def in_monad) done lemma storePTE_pred_tcb_at' [wp]: "\pred_tcb_at' proj P t\ storePTE p pte \\_. pred_tcb_at' proj P t\" apply (simp add: storePTE_def pred_tcb_at'_def) apply (rule obj_at_setObject2) apply (clarsimp simp add: updateObject_default_def in_monad) done lemma setASID_pred_tcb_at' [wp]: "\pred_tcb_at' proj P t\ setObject p (ap::asidpool) \\_. pred_tcb_at' proj P t\" apply (simp add: pred_tcb_at'_def) apply (rule obj_at_setObject2) apply (clarsimp simp add: updateObject_default_def in_monad) done lemma dmo_ct[wp]: "\\s. P (ksCurThread s)\ doMachineOp m \\rv s. P (ksCurThread s)\" apply (simp add: doMachineOp_def split_def) apply wp apply clarsimp done lemma storePDE_valid_mdb [wp]: "\valid_mdb'\ storePDE p pde \\rv. valid_mdb'\" by (simp add: valid_mdb'_def) wp crunch nosch [wp]: storePDE "\s. P (ksSchedulerAction s)" (simp: updateObject_default_def ignore_del: setObject) crunch ksQ [wp]: storePDE "\s. P (ksReadyQueues s)" (simp: updateObject_default_def) lemma storePDE_inQ[wp]: "\\s. P (obj_at' (inQ d p) t s)\ storePDE ptr pde \\rv s. P (obj_at' (inQ d p) t s)\" apply (simp add: obj_at'_real_def storePDE_def) apply (wp setObject_ko_wp_at | simp add: objBits_simps archObjSize_def pdeBits_def)+ apply (clarsimp simp: projectKOs obj_at'_def ko_wp_at'_def) done crunch norqL1[wp]: storePDE "\s. P (ksReadyQueuesL1Bitmap s)" (simp: updateObject_default_def) crunch norqL2[wp]: storePDE "\s. P (ksReadyQueuesL2Bitmap s)" (simp: updateObject_default_def) lemma storePDE_valid_queues [wp]: "\Invariants_H.valid_queues\ storePDE p pde \\_. Invariants_H.valid_queues\" by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ lemma storePDE_valid_queues' [wp]: "\valid_queues'\ storePDE p pde \\_. valid_queues'\" by (wp valid_queues_lift') lemma storePDE_state_refs' [wp]: "\\s. P (state_refs_of' s)\ storePDE p pde \\rv s. P (state_refs_of' s)\" apply (clarsimp simp: storePDE_def) apply (clarsimp simp: setObject_def valid_def in_monad split_def updateObject_default_def projectKOs objBits_simps in_magnitude_check state_refs_of'_def ps_clear_upd' elim!: rsubst[where P=P] intro!: ext split del: if_split cong: option.case_cong if_cong) apply (simp split: option.split) done lemma storePDE_iflive [wp]: "\if_live_then_nonz_cap'\ storePDE p pde \\rv. if_live_then_nonz_cap'\" apply (simp add: storePDE_def) apply (rule hoare_pre) apply (rule setObject_iflive' [where P=\], simp) apply (simp add: objBits_simps archObjSize_def) apply (auto simp: updateObject_default_def in_monad projectKOs pdeBits_def) done lemma setObject_pde_ksInt [wp]: "\\s. P (ksInterruptState s)\ setObject p (pde::pde) \\_. \s. P (ksInterruptState s)\" by (wp setObject_ksInterrupt updateObject_default_inv|simp)+ crunch ksInterruptState [wp]: storePDE "\s. P (ksInterruptState s)" lemma storePDE_ifunsafe [wp]: "\if_unsafe_then_cap'\ storePDE p pde \\rv. if_unsafe_then_cap'\" apply (simp add: storePDE_def) apply (rule hoare_pre) apply (rule setObject_ifunsafe' [where P=\], simp) apply (auto simp: updateObject_default_def in_monad projectKOs)[2] apply wp apply simp done lemma storePDE_idle [wp]: "\valid_idle'\ storePDE p pde \\rv. valid_idle'\" unfolding valid_idle'_def by (rule hoare_lift_Pf [where f="ksIdleThread"]; wp) crunches storePDE for arch'[wp]: "\s. P (ksArchState s)" and cur'[wp]: "\s. P (ksCurThread s)" lemma storePDE_irq_states' [wp]: "\valid_irq_states'\ storePDE pde p \\_. valid_irq_states'\" apply (simp add: storePDE_def) apply (wpsimp wp: valid_irq_states_lift' dmo_lift' no_irq_storeWord setObject_ksMachine updateObject_default_inv) done crunch no_0_obj' [wp]: storePDE no_0_obj' lemma storePDE_pde_mappings'[wp]: "\valid_pde_mappings' and K (valid_pde_mapping' (p && mask pdBits) pde)\ storePDE p pde \\rv. valid_pde_mappings'\" apply (rule hoare_gen_asm) apply (wp valid_pde_mappings_lift') apply (rule hoare_post_imp) apply (simp only: obj_at'_real_def) apply (simp add: storePDE_def) apply (wp setObject_ko_wp_at) apply simp apply (simp add: objBits_simps archObjSize_def) apply (simp add: pdeBits_def) apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs) apply assumption done lemma storePDE_vms'[wp]: "\valid_machine_state'\ storePDE p pde \\_. valid_machine_state'\" apply (simp add: storePDE_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) apply (wp setObject_typ_at_inv setObject_ksMachine updateObject_default_inv hoare_vcg_all_lift hoare_vcg_disj_lift | simp)+ done crunch pspace_domain_valid[wp]: storePDE "pspace_domain_valid" lemma storePDE_ct_not_inQ[wp]: "\ct_not_inQ\ storePDE p pde \\_. ct_not_inQ\" apply (rule ct_not_inQ_lift [OF storePDE_nosch]) apply (simp add: storePDE_def) apply (rule hoare_weaken_pre) apply (wps setObject_PDE_ct) apply (rule obj_at_setObject2) apply (clarsimp simp: updateObject_default_def in_monad)+ done lemma setObject_pde_cur_domain[wp]: "\\s. P (ksCurDomain s)\ setObject t (v::pde) \\rv s. P (ksCurDomain s)\" apply (simp add: setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done lemma setObject_pde_ksDomSchedule[wp]: "\\s. P (ksDomSchedule s)\ setObject t (v::pde) \\rv s. P (ksDomSchedule s)\" apply (simp add: setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done lemma storePDE_cur_domain[wp]: "\\s. P (ksCurDomain s)\ storePDE p pde \\rv s. P (ksCurDomain s)\" by (simp add: storePDE_def) wp lemma storePDE_ksDomSchedule[wp]: "\\s. P (ksDomSchedule s)\ storePDE p pde \\rv s. P (ksDomSchedule s)\" by (simp add: storePDE_def) wp lemma storePDE_tcb_obj_at'[wp]: "\obj_at' (P::tcb \ bool) t\ storePDE p pde \\_. obj_at' P t\" apply (simp add: storePDE_def) apply (rule obj_at_setObject2) apply (clarsimp simp add: updateObject_default_def in_monad) done lemma storePDE_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t\ storePDE p pde \\_. tcb_in_cur_domain' t\" by (wp tcb_in_cur_domain'_lift) lemma storePDE_ct_idle_or_in_cur_domain'[wp]: "\ct_idle_or_in_cur_domain'\ storePDE p pde \\_. ct_idle_or_in_cur_domain'\" by (wp ct_idle_or_in_cur_domain'_lift hoare_vcg_disj_lift) lemma setObject_pte_ksDomScheduleIdx [wp]: "\\s. P (ksDomScheduleIdx s)\ setObject p (pte::pte) \\_. \s. P (ksDomScheduleIdx s)\" by (wp updateObject_default_inv|simp add:setObject_def | wpc)+ lemma setObject_pde_ksDomScheduleIdx [wp]: "\\s. P (ksDomScheduleIdx s)\ setObject p (pde::pde) \\_. \s. P (ksDomScheduleIdx s)\" by (wp updateObject_default_inv|simp add:setObject_def | wpc)+ crunches storePTE, storePDE for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" and gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" (wp: setObject_ksPSpace_only updateObject_default_inv) lemma storePDE_invs[wp]: "\invs' and valid_pde' pde and (\s. valid_pde_mapping' (p && mask pdBits) pde)\ storePDE p pde \\_. invs'\" apply (simp add: invs'_def valid_state'_def valid_pspace'_def) apply (rule hoare_pre) apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' untyped_ranges_zero_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp done lemma storePTE_valid_mdb [wp]: "\valid_mdb'\ storePTE p pte \\rv. valid_mdb'\" by (simp add: valid_mdb'_def) wp crunch nosch [wp]: storePTE "\s. P (ksSchedulerAction s)" (simp: updateObject_default_def ignore_del: setObject) crunch ksQ [wp]: storePTE "\s. P (ksReadyQueues s)" (simp: updateObject_default_def) lemma storePTE_inQ[wp]: "\\s. P (obj_at' (inQ d p) t s)\ storePTE ptr pde \\rv s. P (obj_at' (inQ d p) t s)\" apply (simp add: obj_at'_real_def storePTE_def) apply (wp setObject_ko_wp_at | simp add: objBits_simps archObjSize_def pteBits_def)+ apply (clarsimp simp: projectKOs obj_at'_def ko_wp_at'_def) done crunch norqL1[wp]: storePTE "\s. P (ksReadyQueuesL1Bitmap s)" (simp: updateObject_default_def) crunch norqL2[wp]: storePTE "\s. P (ksReadyQueuesL2Bitmap s)" (simp: updateObject_default_def) lemma storePTE_valid_queues [wp]: "\Invariants_H.valid_queues\ storePTE p pde \\_. Invariants_H.valid_queues\" by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ lemma storePTE_valid_queues' [wp]: "\valid_queues'\ storePTE p pde \\_. valid_queues'\" by (wp valid_queues_lift') lemma storePTE_state_refs' [wp]: "\\s. P (state_refs_of' s)\ storePTE p pte \\rv s. P (state_refs_of' s)\" apply (clarsimp simp: storePTE_def) apply (clarsimp simp: setObject_def valid_def in_monad split_def updateObject_default_def projectKOs objBits_simps in_magnitude_check state_refs_of'_def ps_clear_upd' elim!: rsubst[where P=P] intro!: ext split del: if_split cong: option.case_cong if_cong) apply (simp split: option.split) done lemma storePTE_iflive [wp]: "\if_live_then_nonz_cap'\ storePTE p pte \\rv. if_live_then_nonz_cap'\" apply (simp add: storePTE_def) apply (rule hoare_pre) apply (rule setObject_iflive' [where P=\], simp) apply (simp add: objBits_simps archObjSize_def) apply (auto simp: updateObject_default_def in_monad projectKOs pteBits_def) done lemma setObject_pte_ksInt [wp]: "\\s. P (ksInterruptState s)\ setObject p (pte::pte) \\_. \s. P (ksInterruptState s)\" by (wp setObject_ksInterrupt updateObject_default_inv|simp)+ crunch ksInt' [wp]: storePTE "\s. P (ksInterruptState s)" lemma storePTE_ifunsafe [wp]: "\if_unsafe_then_cap'\ storePTE p pte \\rv. if_unsafe_then_cap'\" apply (simp add: storePTE_def) apply (rule hoare_pre) apply (rule setObject_ifunsafe' [where P=\], simp) apply (auto simp: updateObject_default_def in_monad projectKOs)[2] apply wp apply simp done lemma storePTE_idle [wp]: "\valid_idle'\ storePTE p pte \\rv. valid_idle'\" unfolding valid_idle'_def by (rule hoare_lift_Pf [where f="ksIdleThread"]; wp) crunches storePTE for arch'[wp]: "\s. P (ksArchState s)" and cur'[wp]: "\s. P (ksCurThread s)" lemma storePTE_irq_states' [wp]: "\valid_irq_states'\ storePTE pte p \\_. valid_irq_states'\" apply (simp add: storePTE_def) apply (wpsimp wp: valid_irq_states_lift' dmo_lift' no_irq_storeWord setObject_ksMachine updateObject_default_inv) done lemma storePTE_valid_objs [wp]: "\valid_objs' and valid_pte' pte\ storePTE p pte \\_. valid_objs'\" apply (simp add: storePTE_def doMachineOp_def split_def) apply (rule hoare_pre) apply (wp hoare_drop_imps|wpc|simp)+ apply (rule setObject_valid_objs') prefer 2 apply assumption apply (clarsimp simp: updateObject_default_def in_monad) apply (clarsimp simp: valid_obj'_def) done crunch no_0_obj' [wp]: storePTE no_0_obj' lemma storePTE_pde_mappings'[wp]: "\valid_pde_mappings'\ storePTE p pte \\rv. valid_pde_mappings'\" apply (wp valid_pde_mappings_lift') apply (simp add: storePTE_def) apply (rule obj_at_setObject2) apply (clarsimp dest!: updateObject_default_result) apply assumption done lemma storePTE_vms'[wp]: "\valid_machine_state'\ storePTE p pde \\_. valid_machine_state'\" apply (simp add: storePTE_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) apply (wp setObject_typ_at_inv setObject_ksMachine updateObject_default_inv hoare_vcg_all_lift hoare_vcg_disj_lift | simp)+ done crunch pspace_domain_valid[wp]: storePTE "pspace_domain_valid" lemma storePTE_ct_not_inQ[wp]: "\ct_not_inQ\ storePTE p pte \\_. ct_not_inQ\" apply (rule ct_not_inQ_lift [OF storePTE_nosch]) apply (simp add: storePTE_def) apply (rule hoare_weaken_pre) apply (wps setObject_pte_ct) apply (rule obj_at_setObject2) apply (clarsimp simp: updateObject_default_def in_monad)+ done lemma setObject_pte_cur_domain[wp]: "\\s. P (ksCurDomain s)\ setObject t (v::pte) \\rv s. P (ksCurDomain s)\" apply (simp add: setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done lemma setObject_pte_ksDomSchedule[wp]: "\\s. P (ksDomSchedule s)\ setObject t (v::pte) \\rv s. P (ksDomSchedule s)\" apply (simp add: setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done lemma storePTE_cur_domain[wp]: "\\s. P (ksCurDomain s)\ storePTE p pde \\rv s. P (ksCurDomain s)\" by (simp add: storePTE_def) wp lemma storePTE_ksDomSchedule[wp]: "\\s. P (ksDomSchedule s)\ storePTE p pde \\rv s. P (ksDomSchedule s)\" by (simp add: storePTE_def) wp lemma storePTE_tcb_obj_at'[wp]: "\obj_at' (P::tcb \ bool) t\ storePTE p pte \\_. obj_at' P t\" apply (simp add: storePTE_def) apply (rule obj_at_setObject2) apply (clarsimp simp add: updateObject_default_def in_monad) done lemma storePTE_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t\ storePTE p pte \\_. tcb_in_cur_domain' t\" by (wp tcb_in_cur_domain'_lift) lemma storePTE_ct_idle_or_in_cur_domain'[wp]: "\ct_idle_or_in_cur_domain'\ storePTE p pte \\_. ct_idle_or_in_cur_domain'\" by (wp ct_idle_or_in_cur_domain'_lift hoare_vcg_disj_lift) lemma storePTE_invs [wp]: "\invs' and valid_pte' pte\ storePTE p pte \\_. invs'\" apply (simp add: invs'_def valid_state'_def valid_pspace'_def) apply (rule hoare_pre) apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' untyped_ranges_zero_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp done lemma setASIDPool_valid_objs [wp]: "\valid_objs' and valid_asid_pool' ap\ setObject p (ap::asidpool) \\_. valid_objs'\" apply (rule hoare_pre) apply (rule setObject_valid_objs') prefer 2 apply assumption apply (clarsimp simp: updateObject_default_def in_monad) apply (clarsimp simp: valid_obj'_def) done lemma setASIDPool_valid_mdb [wp]: "\valid_mdb'\ setObject p (ap::asidpool) \\rv. valid_mdb'\" by (simp add: valid_mdb'_def) wp lemma setASIDPool_nosch [wp]: "\\s. P (ksSchedulerAction s)\ setObject p (ap::asidpool) \\rv s. P (ksSchedulerAction s)\" by (wp setObject_nosch updateObject_default_inv|simp)+ lemma setASIDPool_ksQ [wp]: "\\s. P (ksReadyQueues s)\ setObject p (ap::asidpool) \\rv s. P (ksReadyQueues s)\" by (wp setObject_qs updateObject_default_inv|simp)+ lemma setASIDPool_inQ[wp]: "\\s. P (obj_at' (inQ d p) t s)\ setObject ptr (ap::asidpool) \\rv s. P (obj_at' (inQ d p) t s)\" apply (simp add: obj_at'_real_def) apply (wp setObject_ko_wp_at | simp add: objBits_simps archObjSize_def)+ apply (simp add: pageBits_def) apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs) done lemma setASIDPool_qsL1 [wp]: "\\s. P (ksReadyQueuesL1Bitmap s)\ setObject p (ap::asidpool) \\rv s. P (ksReadyQueuesL1Bitmap s)\" by (wp setObject_qs updateObject_default_inv|simp)+ lemma setASIDPool_qsL2 [wp]: "\\s. P (ksReadyQueuesL2Bitmap s)\ setObject p (ap::asidpool) \\rv s. P (ksReadyQueuesL2Bitmap s)\" by (wp setObject_qs updateObject_default_inv|simp)+ lemma setASIDPool_valid_queues [wp]: "\Invariants_H.valid_queues\ setObject p (ap::asidpool) \\_. Invariants_H.valid_queues\" by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ lemma setASIDPool_valid_queues' [wp]: "\valid_queues'\ setObject p (ap::asidpool) \\_. valid_queues'\" by (wp valid_queues_lift') lemma setASIDPool_state_refs' [wp]: "\\s. P (state_refs_of' s)\ setObject p (ap::asidpool) \\rv s. P (state_refs_of' s)\" apply (clarsimp simp: setObject_def valid_def in_monad split_def updateObject_default_def projectKOs objBits_simps in_magnitude_check state_refs_of'_def ps_clear_upd' elim!: rsubst[where P=P] intro!: ext split del: if_split cong: option.case_cong if_cong) apply (simp split: option.split) done lemma setASIDPool_iflive [wp]: "\if_live_then_nonz_cap'\ setObject p (ap::asidpool) \\rv. if_live_then_nonz_cap'\" apply (rule hoare_pre) apply (rule setObject_iflive' [where P=\], simp) apply (simp add: objBits_simps archObjSize_def) apply (auto simp: updateObject_default_def in_monad projectKOs pageBits_def) done lemma setASIDPool_ksInt [wp]: "\\s. P (ksInterruptState s)\ setObject p (ap::asidpool) \\_. \s. P (ksInterruptState s)\" by (wp setObject_ksInterrupt updateObject_default_inv|simp)+ lemma setASIDPool_ifunsafe [wp]: "\if_unsafe_then_cap'\ setObject p (ap::asidpool) \\rv. if_unsafe_then_cap'\" apply (rule hoare_pre) apply (rule setObject_ifunsafe' [where P=\], simp) apply (auto simp: updateObject_default_def in_monad projectKOs)[2] apply wp apply simp done lemma setASIDPool_it' [wp]: "\\s. P (ksIdleThread s)\ setObject p (ap::asidpool) \\_. \s. P (ksIdleThread s)\" by (wp setObject_it updateObject_default_inv|simp)+ lemma setASIDPool_idle [wp]: "\valid_idle'\ setObject p (ap::asidpool) \\rv. valid_idle'\" unfolding valid_idle'_def by (rule hoare_lift_Pf [where f="ksIdleThread"]; wp) lemma setASIDPool_irq_states' [wp]: "\valid_irq_states'\ setObject p (ap::asidpool) \\_. valid_irq_states'\" apply (rule hoare_pre) apply (rule hoare_use_eq [where f=ksInterruptState, OF setObject_ksInterrupt]) apply (simp, rule updateObject_default_inv) apply (rule hoare_use_eq [where f=ksMachineState, OF setObject_ksMachine]) apply (simp, rule updateObject_default_inv) apply wp apply assumption done lemma setObject_asidpool_mappings'[wp]: "\valid_pde_mappings'\ setObject p (ap::asidpool) \\rv. valid_pde_mappings'\" apply (wp valid_pde_mappings_lift') apply (rule obj_at_setObject2) apply (clarsimp dest!: updateObject_default_result) apply assumption done lemma setASIDPool_vms'[wp]: "\valid_machine_state'\ setObject p (ap::asidpool) \\_. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) apply (wp setObject_typ_at_inv setObject_ksMachine updateObject_default_inv hoare_vcg_all_lift hoare_vcg_disj_lift | simp)+ done lemma setASIDPool_ct_not_inQ[wp]: "\ct_not_inQ\ setObject p (ap::asidpool) \\_. ct_not_inQ\" apply (rule ct_not_inQ_lift [OF setObject_nosch]) apply (simp add: updateObject_default_def | wp)+ apply (rule hoare_weaken_pre) apply (wps setObject_ASID_ct) apply (rule obj_at_setObject2) apply (clarsimp simp: updateObject_default_def in_monad)+ done lemma setObject_asidpool_cur'[wp]: "\\s. P (ksCurThread s)\ setObject p (ap::asidpool) \\rv s. P (ksCurThread s)\" apply (simp add: setObject_def) apply (wp | wpc | simp add: updateObject_default_def)+ done lemma setObject_asidpool_cur_domain[wp]: "\\s. P (ksCurDomain s)\ setObject p (ap::asidpool) \\rv s. P (ksCurDomain s)\" apply (simp add: setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done lemma setObject_asidpool_ksDomSchedule[wp]: "\\s. P (ksDomSchedule s)\ setObject p (ap::asidpool) \\rv s. P (ksDomSchedule s)\" apply (simp add: setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done lemma setObject_tcb_obj_at'[wp]: "\obj_at' (P::tcb \ bool) t\ setObject p (ap::asidpool) \\_. obj_at' P t\" apply (rule obj_at_setObject2) apply (clarsimp simp add: updateObject_default_def in_monad) done lemma setObject_asidpool_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t\ setObject p (ap::asidpool) \\_. tcb_in_cur_domain' t\" by (wp tcb_in_cur_domain'_lift) lemma setObject_asidpool_ct_idle_or_in_cur_domain'[wp]: "\ct_idle_or_in_cur_domain'\ setObject p (ap::asidpool) \\_. ct_idle_or_in_cur_domain'\" apply (rule ct_idle_or_in_cur_domain'_lift) apply (wp hoare_vcg_disj_lift)+ done lemma setObject_ap_ksDomScheduleIdx [wp]: "\\s. P (ksDomScheduleIdx s)\ setObject p (ap::asidpool) \\_. \s. P (ksDomScheduleIdx s)\" by (wp updateObject_default_inv|simp add:setObject_def | wpc)+ lemma setASIDPool_invs [wp]: "\invs' and valid_asid_pool' ap\ setObject p (ap::asidpool) \\_. invs'\" apply (simp add: invs'_def valid_state'_def valid_pspace'_def) apply (rule hoare_pre) apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' untyped_ranges_zero_lift updateObject_default_inv | simp add: cteCaps_of_def | rule setObject_ksPSpace_only)+ apply (clarsimp simp add: setObject_def o_def) done crunch cte_wp_at'[wp]: unmapPageTable "\s. P (cte_wp_at' P' p s)" (wp: crunch_wps simp: crunch_simps) lemmas storePDE_Invalid_invs = storePDE_invs[where pde=InvalidPDE, simplified] lemma setVMRootForFlush_invs'[wp]: "\invs'\ setVMRootForFlush a b \\_. invs'\" apply (simp add: setVMRootForFlush_def) apply (wp storePDE_Invalid_invs mapM_wp' crunch_wps | simp add: crunch_simps)+ done lemma dmo_invalidateLocalTLB_VAASID_invs'[wp]: "\invs'\ doMachineOp (invalidateLocalTLB_VAASID x) \\_. invs'\" apply (wp dmo_invs' no_irq_invalidateLocalTLB_VAASID no_irq) apply clarsimp apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" in use_valid) apply (clarsimp simp: invalidateLocalTLB_VAASID_def machine_op_lift_def machine_rest_lift_def split_def | wp)+ done lemma dmo_cVA_PoU_invs'[wp]: "\invs'\ doMachineOp (cleanByVA_PoU w p) \\_. invs'\" apply (wp dmo_invs' no_irq_cleanByVA_PoU no_irq) apply clarsimp apply (drule_tac Q="\_ m'. underlying_memory m' pa = underlying_memory m pa" in use_valid) apply (clarsimp simp: cleanByVA_PoU_def machine_op_lift_def machine_rest_lift_def split_def | wp)+ done lemma dmo_ccr_PoU_invs'[wp]: "\invs'\ doMachineOp (cleanCacheRange_PoU s e p) \\r. invs'\" apply (wp dmo_invs' no_irq_cleanCacheRange_PoU no_irq) apply clarsimp apply (drule_tac Q="\_ m'. underlying_memory m' pa = underlying_memory m pa" in use_valid) apply (clarsimp simp: cleanCacheRange_PoU_def machine_op_lift_def machine_rest_lift_def split_def | wp)+ done (* FIXME: Move *) lemma dmo_invalidateLocalTLB_ASID_invs'[wp]: "\invs'\ doMachineOp (invalidateLocalTLB_ASID a) \\_. invs'\" apply (wp dmo_invs' no_irq_invalidateLocalTLB_ASID no_irq) apply clarsimp apply (drule_tac P4="\m'. underlying_memory m' p = underlying_memory m p" in use_valid[where P=P and Q="\_. P" for P]) apply (simp add: invalidateLocalTLB_ASID_def machine_op_lift_def machine_rest_lift_def split_def | wp)+ done lemma dmo_cleanCaches_PoU_invs'[wp]: "\invs'\ doMachineOp cleanCaches_PoU \\_. invs'\" apply (wp dmo_invs' no_irq_cleanCaches_PoU no_irq) apply clarsimp apply (drule_tac P4="\m'. underlying_memory m' p = underlying_memory m p" in use_valid[where P=P and Q="\_. P" for P]) apply (simp add: cleanCaches_PoU_def machine_op_lift_def machine_rest_lift_def split_def | wp)+ done crunch invs'[wp]: unmapPageTable "invs'" (ignore: storePDE doMachineOp wp: dmo_invalidateLocalTLB_VAASID_invs' dmo_setCurrentPD_invs' storePDE_Invalid_invs mapM_wp' no_irq_set_current_pd crunch_wps simp: crunch_simps setCurrentPD_to_abs) lemma perform_pti_invs [wp]: "\invs' and valid_pti' pti\ performPageTableInvocation pti \\_. invs'\" apply (clarsimp simp: performPageTableInvocation_def getSlotCap_def split: page_table_invocation.splits) apply (intro conjI allI impI) apply (rule hoare_pre) apply (wp arch_update_updateCap_invs getCTE_wp hoare_vcg_ex_lift no_irq_cleanCacheRange_PoU mapM_x_wp' | wpc | simp add: o_def | (simp only: imp_conv_disj, rule hoare_vcg_disj_lift))+ apply (clarsimp simp: valid_pti'_def cte_wp_at_ctes_of is_arch_update'_def isCap_simps valid_cap'_def capAligned_def) apply (rule hoare_pre) apply (wp arch_update_updateCap_invs valid_pde_lift' no_irq_cleanByVA_PoU | simp)+ apply (clarsimp simp: cte_wp_at_ctes_of valid_pti'_def) done crunch invs'[wp]: setVMRootForFlush "invs'" lemma mapM_storePTE_invs: "\invs' and valid_pte' pte\ mapM (swp storePTE pte) ps \\xa. invs'\" apply (rule hoare_post_imp) prefer 2 apply (rule mapM_wp') apply simp apply (wp valid_pte_lift') apply simp+ done lemma mapM_storePDE_invs: "\invs' and valid_pde' pde and K (\p \ set ps. valid_pde_mapping' (p && mask pdBits) pde)\ mapM (swp storePDE pde) ps \\xa. invs'\" apply (rule hoare_post_imp) prefer 2 apply (rule mapM_wp') apply simp apply (wp valid_pde_lift') apply simp+ done crunch cte_wp_at': unmapPage "\s. P (cte_wp_at' P' p s)" (wp: crunch_wps simp: crunch_simps) lemmas unmapPage_typ_ats [wp] = typ_at_lifts [OF unmapPage_typ_at'] crunch inv: lookupPTSlot P (wp: crunch_wps simp: crunch_simps) lemma flushPage_invs' [wp]: "\invs'\ flushPage sz pd asid vptr \\_. invs'\" apply (simp add: flushPage_def) apply (wp dmo_invalidateLocalTLB_VAASID_invs' hoare_drop_imps setVMRootForFlush_invs' no_irq_invalidateLocalTLB_VAASID |simp)+ done lemma unmapPage_invs' [wp]: "\invs'\ unmapPage sz asid vptr pptr \\_. invs'\" apply (simp add: unmapPage_def) apply (rule hoare_pre) apply (wp lookupPTSlot_inv mapM_storePTE_invs mapM_storePDE_invs hoare_vcg_const_imp_lift |wpc |simp)+ done crunch (no_irq) no_irq[wp]: doFlush crunches pteCheckIfMapped, pdeCheckIfMapped for invs'[wp]: "invs'" and valid_pte'[wp]: "valid_pte' pte" and valid_pde'[wp]: "valid_pde' pde" lemma perform_pt_invs [wp]: notes no_irq[wp] shows "\invs' and valid_page_inv' pt\ performPageInvocation pt \\_. invs'\" apply (simp add: performPageInvocation_def) apply (cases pt) apply clarsimp apply ((wp dmo_invs' hoare_vcg_all_lift setVMRootForFlush_invs' | simp add: tcb_at_invs')+)[2] apply (rule hoare_pre_imp[of _ \], assumption) apply (clarsimp simp: valid_def disj_commute[of "pointerInUserData p s" for p s]) apply (thin_tac "x : fst (setVMRootForFlush a b s)" for x a b) apply (erule use_valid) apply (clarsimp simp: doFlush_def split: flush_type.splits) apply (clarsimp split: sum.split | intro conjI impI | wp)+ apply (clarsimp simp: valid_page_inv'_def valid_slots'_def valid_pde_slots'_def split: sum.split option.splits | intro conjI impI | wp mapM_storePTE_invs mapM_storePDE_invs hoare_vcg_all_lift hoare_vcg_const_imp_lift arch_update_updateCap_invs unmapPage_cte_wp_at' getSlotCap_wp | wpc)+ apply (clarsimp simp: cte_wp_at_ctes_of) apply (case_tac cte) apply clarsimp apply (drule ctes_of_valid_cap', fastforce) apply (clarsimp simp: valid_cap'_def cte_wp_at_ctes_of valid_page_inv'_def capAligned_def is_arch_update'_def isCap_simps) apply clarsimp apply (wp arch_update_updateCap_invs unmapPage_cte_wp_at' getSlotCap_wp|wpc)+ apply (rename_tac acap word a b) apply (rule_tac Q="\_. invs' and cte_wp_at' (\cte. \d r R sz m. cteCap cte = ArchObjectCap (PageCap d r R sz m)) word" in hoare_strengthen_post) apply (wp unmapPage_cte_wp_at') apply (clarsimp simp: cte_wp_at_ctes_of) apply (case_tac cte) apply clarsimp apply (frule ctes_of_valid_cap') apply (auto simp: valid_page_inv'_def valid_slots'_def cte_wp_at_ctes_of valid_pde_slots'_def)[1] apply (simp add: is_arch_update'_def isCap_simps) apply (simp add: valid_cap'_def capAligned_def) apply (clarsimp simp: cte_wp_at_ctes_of) apply (simp add: is_arch_update'_def isCap_simps) apply (case_tac cte) apply clarsimp+ done lemma ucast_ucast_le_low_bits [simp]: "ucast (ucast x :: 10 word) \ (2 ^ asid_low_bits - 1 :: word32)" apply (rule word_less_sub_1) apply (rule order_less_le_trans) apply (rule ucast_less) apply simp apply (simp add: asid_low_bits_def) done lemma perform_aci_invs [wp]: "\invs' and valid_apinv' api\ performASIDPoolInvocation api \\_. invs'\" apply (clarsimp simp: performASIDPoolInvocation_def split: asidpool_invocation.splits) apply (wp arch_update_updateCap_invs getASID_wp getSlotCap_wp) apply (clarsimp simp: valid_apinv'_def cte_wp_at_ctes_of) apply (case_tac cte) apply clarsimp apply (drule ctes_of_valid_cap', fastforce) apply (clarsimp simp: isPDCap_def valid_cap'_def capAligned_def is_arch_update'_def isCap_simps) apply (drule ko_at_valid_objs', fastforce, simp add: projectKOs) apply (clarsimp simp: valid_obj'_def ran_def mask_asid_low_bits_ucast_ucast split: if_split_asm) apply (case_tac ko, clarsimp simp: inv_def) apply (clarsimp simp: page_directory_at'_def, drule_tac x=0 in spec) apply auto done lemma capMaster_isPDCap: "capMasterCap cap' = capMasterCap cap \ isPDCap cap' = isPDCap cap" by (simp add: capMasterCap_def isPDCap_def split: capability.splits arch_capability.splits) lemma isPDCap_PD : "isPDCap (ArchObjectCap (PageDirectoryCap r m))" by (simp add: isPDCap_def) end lemma cteCaps_of_ctes_of_lift: "(\P. \\s. P (ctes_of s)\ f \\_ s. P (ctes_of s)\) \ \\s. P (cteCaps_of s) \ f \\_ s. P (cteCaps_of s)\" unfolding cteCaps_of_def . end