(* * Copyright 2019, Data61, CSIRO * * 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(DATA61_GPL) *) (* RISCV64 VSpace refinement *) theory VSpace_R imports TcbAcc_R begin context begin interpretation Arch . (*FIXME: arch_split*) definition "vspace_at_asid' vs asid \ \s. \ap pool. riscvKSASIDTable (ksArchState s) (ucast (asid_high_bits_of (ucast asid))) = Some ap \ ko_at' (ASIDPool pool) ap s \ pool (ucast (asid_low_bits_of (ucast asid))) = Some vs \ page_table_at' vs s" lemma findVSpaceForASID_vs_at_wp: "\\s. \pm. asid \ 0 \ asid_wf asid \ vspace_at_asid' pm asid s \ P pm s\ findVSpaceForASID asid \P\,-" apply (simp add: findVSpaceForASID_def assertE_def checkPTAt_def asidRange_def mask_2pm1[symmetric] le_mask_asidBits_asid_wf cong: option.case_cong split del: if_split) apply (wpsimp wp: getASID_wp) apply (erule allE; erule mp; clarsimp simp: vspace_at_asid'_def page_table_at'_def) apply (case_tac ko; simp) apply (subst (asm) inv_f_f, rule inj_onI, simp) apply (rule conjI, fastforce) apply (simp add: asid_low_bits_of_def ucast_ucast_a is_down ucast_ucast_mask asid_low_bits_def) by fastforce lemma findVSpaceForASIDAssert_vs_at_wp: "\(\s. \pd. vspace_at_asid' pd asid s \ P pd s)\ findVSpaceForASIDAssert asid \P\" apply (simp add: findVSpaceForASIDAssert_def const_def checkPTAt_def) apply (rule hoare_pre, wp findVSpaceForASID_vs_at_wp) apply simp done crunch inv[wp]: findVSpaceForASIDAssert "P" (simp: const_def crunch_simps wp: loadObject_default_inv crunch_wps ignore_del: getObject) lemma asidBits_asid_bits[simp]: "asidBits = asid_bits" by (simp add: bit_simps' asid_bits_def asidBits_def) lemma no_fail_read_sbadaddr[intro!,simp]: "no_fail \ read_sbadaddr" by (simp add: read_sbadaddr_def) lemma hv_corres: "corres (fr \ dc) (tcb_at thread) (tcb_at' thread) (handle_vm_fault thread fault) (handleVMFault thread fault)" apply (simp add: RISCV64_H.handleVMFault_def handle_vm_fault_def) apply (rule corres_guard_imp) apply (rule corres_split_eqrE) apply (cases fault; simp) apply simp apply (rule corres_machine_op[where r="(=)"]) apply (rule corres_Id, rule refl, simp) apply (rule no_fail_read_sbadaddr) apply wpsimp+ done lemma no_fail_setVSpaceRoot[intro!, simp]: "no_fail \ (setVSpaceRoot v a)" by (simp add: setVSpaceRoot_def) lemma set_vm_root_corres [corres]: assumes "t' = t" shows "corres dc (tcb_at t and valid_vspace_objs and valid_asid_table and pspace_aligned and pspace_distinct and valid_objs and valid_global_arch_objs) (no_0_obj') (set_vm_root t) (setVMRoot t')" proof - have global: "(\s. P s \ valid_global_arch_objs s) \ corres dc P Q (do global_pt <- gets global_pt; do_machine_op (setVSpaceRoot (RISCV64.addrFromKPPtr global_pt) 0) od) (do globalPT <- gets (riscvKSGlobalPT \ ksArchState); doMachineOp (setVSpaceRoot (addrFromKPPtr globalPT) 0) od)" for P Q apply (corressimp corres: corres_gets_global_pt corres_machine_op) apply fastforce apply (simp add: RISCV64.addrFromKPPtr_def addrFromKPPtr_def) done show ?thesis unfolding set_vm_root_def setVMRoot_def catchFailure_def withoutFailure_def throw_def apply (rule corres_cross_over_guard[where Q="no_0_obj' and pspace_distinct' and pspace_aligned'"]) apply (clarsimp simp add: pspace_distinct_cross pspace_aligned_cross state_relation_def) apply (rule corres_guard_imp) apply (rule corres_split[where r'="(=) \ cte_map" and P=\ and P'=\]) prefer 2 apply (simp add: getThreadVSpaceRoot_def locateSlotTCB_def locateSlotBasic_def tcbVTableSlot_def cte_map_def objBits_def cte_level_bits_def objBitsKO_def tcb_cnode_index_def to_bl_1 assms cteSizeBits_def) apply (rule_tac R="\thread_root. valid_vspace_objs and valid_asid_table and pspace_aligned and pspace_distinct and valid_objs and valid_global_arch_objs and cte_wp_at ((=) thread_root) thread_root_slot" and R'="\thread_root. no_0_obj'" in corres_split[OF _ getSlotCap_corres]) prefer 2 apply simp apply (rename_tac cap cap') apply (case_tac cap; clarsimp simp: isCap_simps catch_throwError intro!: global) apply (rename_tac acap acap') apply (case_tac acap; clarsimp simp: isCap_simps catch_throwError intro!: global) apply (rename_tac m) apply (case_tac m; clarsimp simp: isCap_simps catch_throwError intro!: global) apply (rule corres_guard_imp) apply (rule corres_split_catch [where f=lfr and E'="\_. \"]) apply (rule global, assumption) apply (rule corres_split_eqrE [OF _ find_vspace_for_asid_corres[OF refl]]) apply (rule whenE_throwError_corres; simp add: lookup_failure_map_def) apply (rule corres_machine_op) apply corressimp apply fastforce apply simp apply wpsimp+ apply (frule (1) cte_wp_at_valid_objs_valid_cap) apply (clarsimp simp: valid_cap_def mask_def wellformed_mapdata_def) apply (wpsimp wp: get_cap_wp simp: getThreadVSpaceRoot_def)+ apply (auto dest!: tcb_at_cte_at_1) done qed lemma get_asid_pool_corres_inv': assumes "p' = p" shows "corres (\p. (\p'. p = p' o ucast) \ inv ASIDPool) (asid_pool_at p and pspace_aligned and pspace_distinct) \ (get_asid_pool p) (getObject p')" apply (rule corres_rel_imp) apply (rule get_asid_pool_corres[OF assms]) apply simp done lemma dMo_no_0_obj'[wp]: "doMachineOp f \no_0_obj'\" apply (simp add: doMachineOp_def split_def) apply wp by (simp add: no_0_obj'_def) lemma dMo_riscvKSASIDTable_inv[wp]: "doMachineOp f \\s. P (riscvKSASIDTable (ksArchState s))\" apply (simp add: doMachineOp_def split_def) apply wp by (clarsimp) lemma dMo_valid_arch_state'[wp]: "\\s. P (valid_arch_state' s)\ doMachineOp f \\_ s. P (valid_arch_state' s)\" apply (simp add: doMachineOp_def split_def) apply wp by (clarsimp) crunch no_0_obj'[wp]: deleteASID "no_0_obj'" (simp: crunch_simps wp: crunch_wps getObject_inv loadObject_default_inv) lemma asid_high_bits_of_ucast_ucast[simp]: "asid_high_bits_of (ucast (ucast asid :: machine_word)) = asid_high_bits_of asid" by (simp add: ucast_down_ucast_id is_down) lemma no_fail_hwAIDFlush[intro!, wp, simp]: "no_fail \ (hwASIDFlush a)" by (simp add: hwASIDFlush_def) lemma hwASIDFlush_corres[corres]: "corres dc \ \ (do_machine_op (hwASIDFlush x)) (doMachineOp (hwASIDFlush x))" by (corressimp corres: corres_machine_op) lemma delete_asid_corres [corres]: assumes "asid' = ucast asid" "pm' = pm" shows "corres dc invs no_0_obj' (delete_asid asid pm) (deleteASID asid' pm')" unfolding delete_asid_def deleteASID_def using assms apply simp 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 \ pspace_aligned s \ pspace_distinct s" and P'="\" and Q="invs and (\s. asid_table s = asidTable \ ucast)" in corres_split) prefer 2 apply (simp add: dom_def) apply (rule get_asid_pool_corres_inv'[OF refl, unfolded pred_conj_def, simplified]) apply (rule corres_when) apply (simp add: mask_asid_low_bits_ucast_ucast asid_low_bits_of_def ucast_ucast_a is_down) apply (rule corres_split [OF _ hwASIDFlush_corres]) apply (rule_tac P="asid_pool_at (the (asidTable (ucast (asid_high_bits_of asid)))) and pspace_aligned and pspace_distinct" and P'="\" 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 ucast_ucast_a is_down asid_low_bits_of_def) apply (word_bitwise, clarsimp) apply (rule corres_split [OF _ gct_corres]) apply simp apply (rule set_vm_root_corres[OF refl]) apply wp+ apply (thin_tac "x = f o g" for x f g) apply (simp del: fun_upd_apply) apply (fold cur_tcb_def) apply (wp set_asid_pool_vs_lookup_unmap' set_asid_pool_vspace_objs_unmap_single | strengthen valid_arch_state_asid_table valid_arch_state_global_arch_objs)+ apply (auto simp: obj_at_def a_type_def graph_of_def split: if_split_asm dest: invs_valid_asid_table)[1] apply (wp getASID_wp) apply clarsimp apply assumption apply wp+ apply clarsimp apply (frule invs_valid_asid_table) apply (drule (1) valid_asid_tableD) apply (clarsimp simp: invs_distinct) apply simp done lemma valid_arch_state_unmap_strg': "valid_arch_state' s \ valid_arch_state' (s\ksArchState := riscvKSASIDTable_update (\_. (riscvKSASIDTable (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 lemma is_aligned_asid_low_bits_of_zero: "is_aligned asid asid_low_bits \ asid_low_bits_of asid = 0" apply (simp add: is_aligned_mask word_eq_iff word_size asid_bits_defs asid_bits_of_defs nth_ucast) apply (intro iffI allI; drule_tac x=n in spec; fastforce) done lemma mask_is_asid_low_bits_of[simp]: "(ucast asid :: machine_word) && mask asid_low_bits = ucast (asid_low_bits_of asid)" apply (simp add: asid_low_bits_of_def asid_low_bits_def) apply (word_bitwise, simp add: word_size) done lemma delete_asid_pool_corres: assumes "base' = ucast base" "ptr' = ptr" shows "corres dc (invs and K (is_aligned base asid_low_bits) and asid_pool_at ptr) (no_0_obj') (delete_asid_pool base ptr) (deleteASIDPool base' ptr)" using assms apply (simp add: delete_asid_pool_def deleteASIDPool_def) apply (rule corres_assume_pre) apply (simp add: is_aligned_asid_low_bits_of_zero 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[OF refl]]) 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 (rename_tac x n) apply (drule_tac x1="ucast x" in bang_eq [THEN iffD1]) apply (erule_tac x=n in allE) apply (simp add: word_size nth_ucast) apply (rule corres_split[OF _ gct_corres]) apply (rule set_vm_root_corres, simp) apply (wp getASID_wp)+ apply (clarsimp simp: invs_psp_aligned invs_distinct invs_arch_state invs_cur[unfolded cur_tcb_def] valid_arch_state_global_arch_objs invs_valid_objs simp del: fun_upd_apply) apply (rule conjI) apply (rule valid_vspace_objs_unmap_strg[THEN mp]) apply clarsimp apply (drule invs_arch_state) apply (drule valid_arch_state_asid_table) apply (auto simp: valid_asid_table_def ran_def inj_on_def)[1] apply clarsimp done 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'] (* FIXME: move to Lib *) lemma get_mapM_x_lower: fixes P :: "'a option \ 's \ bool" fixes f :: "('s,'a) nondet_monad" fixes g :: "'a \ 'b \ ('s,'c) nondet_monad" \ \@{term g} preserves the state that @{term f} cares about\ assumes g: "\x y. \ P (Some x) \ g x y \ \_. P (Some x) \" \ \@{term P} specifies whether @{term f} either fails or returns a deterministic result\ assumes f: "\opt_x s. P opt_x s \ f s = case_option ({},True) (\x. ({(x,s)},False)) opt_x" \ \Every state determines P, and therefore the behaviour of @{term f}\ assumes x: "\s. \ opt_x. P opt_x s" \ \If @{term f} may fail, ensure there is at least one @{term f}\ assumes y: "\s. P None s \ ys \ []" shows "do x \ f; mapM_x (g x) ys od = mapM_x (\y. do x \ f; g x y od) ys" proof - have f_rv: "\\\ f \\r. P (Some r)\" using x f apply (clarsimp simp: valid_def) apply (drule_tac x=s in meta_spec; clarsimp) apply (case_tac opt_x; simp) done { fix y and h :: "'a \ ('s,'d) nondet_monad" have "do x \ f; _ \ g x y; h x od = do x \ f; _ \ g x y; x \ f; h x od" apply (rule ext) apply (subst monad_eq_split[where g="do x \ f; g x y; return x od" and P="\" and Q="\r. P (Some r)" and f="h" and f'="\_. f >>= h", simplified bind_assoc, simplified]) apply (wpsimp wp: g f_rv simp: f return_def bind_def)+ done } note f_redundant = this show ?thesis proof (cases "\s. P None s") case True show ?thesis apply (cases ys; simp add: True y mapM_x_Cons bind_assoc) subgoal for y ys apply (thin_tac _) apply (induct ys arbitrary: y; simp add: mapM_x_Nil mapM_x_Cons bind_assoc) apply (subst f_redundant; simp) done done next case False show ?thesis using False apply (induct ys; simp add: mapM_x_Nil mapM_x_Cons bind_assoc) apply (rule ext) subgoal for s by (insert x[of s]; drule spec[of _ s]; clarsimp; case_tac opt_x; clarsimp simp: bind_def return_def f) apply (subst f_redundant; simp) done qed qed lemma get_pt_mapM_x_lower: assumes g: "\P pt x. \ \s. P (kheap s pt_ptr) \ g pt x \ \_ s. P (kheap s pt_ptr) \" assumes y: "ys \ []" notes [simp] = gets_map_def get_object_def gets_def get_def bind_def return_def assert_opt_def fail_def opt_map_def shows "do pt \ get_pt pt_ptr; mapM_x (g pt) ys od = mapM_x (\y. get_pt pt_ptr >>= (\pt. g pt y)) ys" apply (rule get_mapM_x_lower [where P="\opt_pt s. case kheap s pt_ptr of Some (ArchObj (PageTable pt)) \ opt_pt = Some pt | _ \ opt_pt = None", OF _ _ _ y]) apply (wp g) apply (case_tac "kheap s pt_ptr"; simp; rename_tac ko; case_tac ko; simp; rename_tac ako; case_tac ako; simp)+ done lemma get_pte_corres'': assumes "p' = p" shows "corres pte_relation' (pte_at p and pspace_aligned and pspace_distinct) \ (get_pte p) (getObject p')" using assms get_pte_corres by simp (* FIXME: move to Lib *) lemma zip_map_rel: assumes "(x,y) \ set (zip xs ys)" "map f xs = map g ys" shows "f x = g y" using assms by (induct xs arbitrary: x y ys; cases ys) auto crunches unmapPageTable, unmapPage for aligned'[wp]: "pspace_aligned'" and distinct'[wp]: "pspace_distinct'" and ctes [wp]: "\s. P (ctes_of s)" and typ_at'[wp]: "\s. P (typ_at' T p s)" (simp: crunch_simps wp: crunch_wps getObject_inv loadObject_default_inv) crunches storePTE for no_0_obj'[wp]: no_0_obj' and valid_arch'[wp]: valid_arch_state' and cur_tcb'[wp]: cur_tcb' lemma no_fail_sfence[intro!,simp,wp]: "no_fail \ sfence" by (simp add: sfence_def) lemma unmap_page_table_corres: assumes "asid' = ucast asid" "vptr' = vptr" "pt' = pt" shows "corres dc (invs and K (0 < asid \ vptr \ user_region)) no_0_obj' (unmap_page_table asid vptr pt) (unmapPageTable asid' vptr' pt')" apply (clarsimp simp: assms unmap_page_table_def unmapPageTable_def ignoreFailure_def const_def) apply (rule corres_guard_imp) apply (rule corres_split_catch[where E="\\" and E'="\\"], simp) apply (rule corres_split_eqrE[OF _ find_vspace_for_asid_corres[OF refl]]) apply (rule corres_split_eqrE[OF _ pt_lookup_from_level_corres[OF _ refl]]) apply (simp add: liftE_bindE) apply (rule corres_split[OF _ store_pte_corres]) apply simp apply (rule corres_machine_op) apply (rule corres_Id; simp) apply (wpsimp wp: pt_lookup_from_level_wp)+ apply (clarsimp simp: invs_distinct invs_psp_aligned invs_vspace_objs invs_valid_asid_table pte_at_eq) apply (rule_tac x=asid in exI) apply (rule_tac x=0 in exI) apply (simp add: vspace_for_asid_vs_lookup) apply simp done 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: "pte_relation' pte pte' \ corres (dc \ dc) \ \ (whenE (is_PagePTE pte \ pptr_from_pte pte \ pptr) (throwError ExceptionTypes_A.InvalidRoot)) (checkMappingPPtr pptr pte')" apply (simp add: liftE_bindE checkMappingPPtr_def) apply (cases pte; simp add: pptr_from_pte_def addr_from_ppn_def) apply (auto simp: whenE_def corres_returnOk) done crunch inv[wp]: checkMappingPPtr "P" (wp: crunch_wps loadObject_default_inv simp: crunch_simps) lemmas liftE_get_pte_corres = get_pte_corres[THEN corres_liftE_rel_sum[THEN iffD2]] lemma unmap_page_corres: assumes "sz' = sz" "asid' = ucast asid" "vptr' = vptr" "pptr' = pptr" shows "corres dc (invs and K (valid_unmap sz (asid,vptr) \ vptr \ user_region)) (no_0_obj') (unmap_page sz asid vptr pptr) (unmapPage sz' asid' vptr' pptr')" apply (clarsimp simp: assms unmap_page_def unmapPage_def ignoreFailure_def const_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]) apply (rule find_vspace_for_asid_corres[OF refl]) apply (rule corres_splitEE) prefer 2 apply simp apply (rule lookup_pt_slot_corres) apply (clarsimp simp: unlessE_whenE) apply datatype_schem apply (rule whenE_throwError_corres_initial, simp, simp) apply (rule corres_splitEE) prefer 2 apply (rule corres_rel_imp) apply (rule liftE_get_pte_corres[@lift_corres_args], simp) apply fastforce apply (rule corres_splitEE[OF _ check_mapping_corres]; assumption?) apply (simp add: liftE_bindE) apply (rule corres_split[OF _ store_pte_corres]) apply simp apply (rule corres_machine_op, rule corres_Id, rule refl; simp) apply simp apply wpsimp+ apply (clarsimp simp: invs_psp_aligned invs_distinct invs_vspace_objs valid_unmap_def invs_valid_asid_table) apply (rule conjI) apply (rule_tac x=asid in exI) apply (rule_tac x=0 in exI) apply (simp add: vspace_for_asid_vs_lookup) apply clarsimp apply (frule (1) pt_lookup_slot_vs_lookup_slotI) apply (fastforce dest!: vs_lookup_slot_pte_at) apply simp done definition "mapping_map \ \(pte, r) (pte', r'). pte_relation' pte pte' \ r' = r" definition "page_invocation_map pgi pgi' \ case pgi of RISCV64_A.PageMap c slot m \ \c' m'. pgi' = PageMap c' (cte_map slot) m' \ cap_relation (Structures_A.ArchObjectCap c) c' \ mapping_map m m' | RISCV64_A.PageUnmap c ptr \ \c'. pgi' = PageUnmap c' (cte_map ptr) \ acap_relation c c' | RISCV64_A.PageGetAddr ptr \ pgi' = PageGetAddr ptr" definition "valid_page_inv' pgi \ case pgi of PageMap cap ptr m \ cte_wp_at' (is_arch_update' cap) ptr and valid_cap' cap | PageUnmap cap ptr \ K (isFrameCap cap) and cte_wp_at' (is_arch_update' (ArchObjectCap cap)) ptr and valid_cap' (ArchObjectCap cap) | PageGetAddr ptr \ \" 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" using shiftr_mask_eq[where 'a=64 and n=12] 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 and pspace_aligned and pspace_distinct) \ (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 crunches unmapPage for cte_at'[wp]: "cte_at' p" (wp: crunch_wps simp: crunch_simps) lemma perform_page_corres: assumes "page_invocation_map pgi pgi'" shows "corres dc (invs and valid_page_inv pgi) (no_0_obj' and valid_page_inv' pgi') (perform_page_invocation pgi) (performPageInvocation pgi')" apply (rule corres_cross_over_guard [where Q="no_0_obj' and valid_page_inv' pgi' and pspace_aligned' and pspace_distinct'"]) apply (fastforce intro!: pspace_aligned_cross pspace_distinct_cross) using assms unfolding perform_page_invocation_def performPageInvocation_def page_invocation_map_def apply (cases pgi; clarsimp simp: valid_page_inv_def mapping_map_def) apply (simp add: perform_pg_inv_map_def) apply (rule corres_guard_imp) apply (rule corres_split[OF _ updateCap_same_master]) apply (rule corres_split[OF _ store_pte_corres]) apply (rule corres_machine_op, rule corres_Id; simp) apply assumption apply wpsimp+ apply (clarsimp simp: invs_valid_objs invs_distinct invs_psp_aligned) apply (clarsimp simp: cte_wp_at_caps_of_state is_arch_update_def is_cap_simps) apply (clarsimp simp: same_ref_def) apply (erule (3) vs_lookup_slot_pte_at) apply (clarsimp simp: valid_page_inv'_def cte_wp_at_ctes_of) apply (clarsimp simp: perform_pg_inv_unmap_def liftM_def) apply (rename_tac cap a b cap') apply (rule_tac F="is_FrameCap cap" in corres_req; clarsimp) apply (clarsimp simp: is_FrameCap_def) apply (rule corres_guard_imp) apply (rule corres_split[where r'=dc]) apply (rule corres_split[OF _ getSlotCap_corres[OF refl]]) apply (rule_tac F="is_frame_cap old_cap" in corres_gen_asm) apply (rule updateCap_same_master) apply (clarsimp simp: update_map_data_def is_cap_simps) apply (wpsimp wp: get_cap_wp)+ apply (rename_tac m) apply (rule option_corres[where P=\ and P'=\]) prefer 3 apply (case_tac m; simp add: mdata_map_def) apply clarsimp apply clarsimp apply datatype_schem apply (fold dc_def)[1] apply (rule unmap_page_corres; simp) apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift')+ apply (clarsimp simp: invs_valid_objs invs_psp_aligned invs_distinct) apply (clarsimp simp: cte_wp_at_caps_of_state wellformed_pte_def cap_master_cap_simps is_cap_simps update_map_data_def mdata_map_def wellformed_mapdata_def valid_arch_cap_def) apply (clarsimp simp: valid_page_inv'_def cte_wp_at_ctes_of) apply (clarsimp simp: perform_pg_inv_get_addr_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 simp: fromPAddr_def) apply wp+ apply (clarsimp simp: tcb_at_invs invs_distinct) apply clarsimp done definition "page_table_invocation_map pti pti' \ case pti of RISCV64_A.PageTableMap cap ptr pte pt_slot \ \cap' pte'. pti' = PageTableMap cap' (cte_map ptr) pte' pt_slot \ cap_relation (Structures_A.ArchObjectCap cap) cap' \ pte_relation' pte pte' | RISCV64_A.PageTableUnmap cap ptr \ \cap'. pti' = PageTableUnmap cap' (cte_map ptr) \ acap_relation cap cap'" definition "valid_pti' pti \ case pti of PageTableMap cap slot pte pteSlot \ cte_wp_at' (is_arch_update' cap) slot and valid_cap' cap | PageTableUnmap cap slot \ cte_wp_at' (is_arch_update' (ArchObjectCap cap)) slot and valid_cap' (ArchObjectCap cap) and K (isPageTableCap cap)" (* extend with arch rules *) lemmas store_pte_typ_ats[wp] = store_pte_typ_ats abs_atyp_at_lifts[OF store_pte_typ_at] lemma clear_page_table_corres: "corres dc (pspace_aligned and pspace_distinct and pt_at p) \ (mapM_x (swp store_pte RISCV64_A.InvalidPTE) [p , p + 2^pte_bits .e. p + 2 ^ pt_bits - 1]) (mapM_x (swp storePTE RISCV64_H.InvalidPTE) [p , p + 2^pte_bits .e. p + 2 ^ pt_bits - 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: bit_simps) apply (simp add: upto_enum_step_subtract[where x=p and y="p + 2^pte_bits"] is_aligned_no_overflow bit_simps upto_enum_step_red[where us=3, 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 \ pspace_distinct s" and Q'="\_. \" in corres_mapM_list_all2, simp_all) apply (rule corres_guard_imp, rule store_pte_corres) apply (simp add:pte_relation_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 bit_simps, simplified]) apply (simp add: bit_simps word_less_nat_alt word_le_nat_alt unat_of_nat) apply simp done 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_pti pti) (no_0_obj' and valid_pti' pti') (perform_page_table_invocation pti) (performPageTableInvocation pti')" apply (rule corres_cross_over_guard [where Q="no_0_obj' and valid_pti' pti' and pspace_aligned' and pspace_distinct'"]) apply (fastforce intro!: pspace_aligned_cross pspace_distinct_cross) apply (simp add: perform_page_table_invocation_def performPageTableInvocation_def page_table_invocation_map_def) apply (cases pti) apply (rename_tac cap slot pte pte_slot) apply (clarsimp simp: perform_pt_inv_map_def) apply (rule corres_name_pre) apply (clarsimp simp: valid_pti_def valid_pti'_def split: arch_cap.splits capability.split_asm arch_capability.split_asm) apply (rule corres_guard_imp) apply (rule corres_split [OF _ updateCap_same_master]) prefer 2 apply simp apply (rule corres_split [OF _ store_pte_corres]) apply (rule corres_machine_op, rule corres_Id; simp) apply assumption apply wpsimp+ apply (clarsimp simp: cte_wp_at_caps_of_state is_arch_update_def invs_valid_objs invs_psp_aligned invs_distinct) apply (case_tac cap; simp add: is_cap_simps cap_master_cap_simps) apply (clarsimp simp: cte_wp_at_ctes_of valid_pti'_def) apply (clarsimp simp: perform_pt_inv_unmap_def) apply (rename_tac acap a b acap') apply (rule_tac F="is_PageTableCap acap" in corres_req; clarsimp) apply (clarsimp simp: valid_pti_def) apply (clarsimp simp: is_PageTableCap_def split_def cong: option.case_cong) apply (simp add: case_option_If2 split del: if_split) apply (rule corres_guard_imp) apply (rule corres_split_nor) apply (simp add: liftM_def) apply (rule corres_split [OF _ getSlotCap_corres[OF refl]]) apply (rule_tac F="is_pt_cap x" in corres_gen_asm) apply (rule updateCap_same_master) apply (clarsimp simp: is_cap_simps update_map_data_def) apply (wp get_cap_wp)+ apply (rule corres_if3) apply (fastforce simp: acap_map_data_def mdata_map_def is_PageTableCap_def) apply (rule corres_split [OF _ unmap_page_table_corres]) apply (rule clear_page_table_corres) apply (clarsimp simp: mdata_map_def) apply (clarsimp simp: mdata_map_def) apply (rule refl) apply wp+ apply (rule corres_trivial, simp) apply (wpsimp wp: mapM_x_wp' hoare_vcg_all_lift hoare_vcg_imp_lift' simp: wellformed_pte_def)+ apply (clarsimp simp: valid_pti_def valid_arch_cap_def cte_wp_at_caps_of_state invs_valid_objs invs_psp_aligned invs_distinct cap_master_cap_simps is_cap_simps update_map_data_def wellformed_mapdata_def) apply (clarsimp 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 (ucast asid) p (cte_map slot)" definition "valid_apinv' ap \ case ap of Assign asid p slot \ cte_wp_at' (isArchCap isPageTableCap o cteCap) slot and K (0 < asid \ asid_wf asid)" crunches copy_global_mappings for aligned[wp]: pspace_aligned and distinct[wp]: pspace_distinct (wp: crunch_wps) lemma pap_corres: assumes "ap' = asid_pool_invocation_map ap" shows "corres dc (valid_objs and pspace_aligned and pspace_distinct and valid_arch_state and valid_apinv ap) (no_0_obj' and valid_apinv' ap') (perform_asid_pool_invocation ap) (performASIDPoolInvocation ap')" apply (rule corres_cross_over_guard [where Q="no_0_obj' and valid_apinv' ap' and pspace_aligned' and pspace_distinct'"]) apply (fastforce intro!: pspace_aligned_cross pspace_distinct_cross) using assms apply (clarsimp simp: perform_asid_pool_invocation_def performASIDPoolInvocation_def) apply (cases ap, simp add: asid_pool_invocation_map_def) apply (rule corres_guard_imp) apply (rule corres_split[OF _ getSlotCap_corres[OF refl] get_cap_wp getSlotCap_wp]) apply (rule corres_assert_gen_asm_l, rule corres_assert_gen_asm_l) apply (rule_tac F="is_pt_cap pt_cap" in corres_gen_asm) apply (rule corres_split[OF _ updateCap_same_master]) prefer 2 apply (clarsimp simp: is_cap_simps update_map_data_def) apply (rule corres_split[OF _ copy_global_mappings_corres]) apply (unfold store_asid_pool_entry_def)[1] apply (rule corres_split[where r'="\pool pool'. pool = pool' \ ucast"]) prefer 2 apply (simp cong: corres_weak_cong) apply (rule corres_rel_imp) apply (rule get_asid_pool_corres[OF refl]) apply simp apply (simp cong: corres_weak_cong) apply (rule set_asid_pool_corres) apply (rule ext) apply (clarsimp simp: inv_def is_cap_simps ucast_up_inj) apply (wp getASID_wp)+ apply (clarsimp simp: is_cap_simps) apply (wpsimp wp: set_cap_typ_at hoare_drop_imps|strengthen valid_arch_state_global_arch_objs)+ apply (clarsimp simp: valid_apinv_def cte_wp_at_caps_of_state is_cap_simps cap_master_cap_simps update_map_data_def) apply (drule (1) caps_of_state_valid_cap) apply (simp add: valid_cap_def obj_at_def) apply (clarsimp simp: valid_apinv'_def cte_wp_at_ctes_of) done crunch obj_at[wp]: setVMRoot "\s. P (obj_at' P' t s)" (simp: crunch_simps) crunches doMachineOp for arch[wp]: "\s. P (ksArchState s)" and irq_node'[wp]: "\s. P (irq_node' s)" and gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" and ksInterruptState[wp]: "\s. P (ksInterruptState s)" and cur'[wp]: "\s. P (ksCurThread s)" and cteCaps_of[wp]: "\s. P (cteCaps_of s)" and dmo_global_refs'[wp]: "\s. P (global_refs' s)" and ksPSpace[wp]: "\s. P (ksPSpace s)" and ksCurDomain[wp]: "\s. P (ksCurDomain s)" and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" crunches sfence, setVSpaceRoot for irq_masks[wp]: "\s. P (irq_masks s)" lemma dmo_sfence_invs'[wp]: "doMachineOp sfence \invs'\" apply (wp dmo_invs') apply (clarsimp simp: in_monad sfence_def machine_op_lift_def machine_rest_lift_def select_f_def) done lemma dmo_setVSpaceRoot_invs'[wp]: "doMachineOp (setVSpaceRoot r a) \invs'\" apply (wp dmo_invs') apply (clarsimp simp: setVSpaceRoot_def machine_op_lift_def machine_rest_lift_def in_monad select_f_def) done lemma dmo_setVSpaceRoot_irq_masks[wp]: "doMachineOp (setVSpaceRoot r a) \\s. P (irq_masks (ksMachineState s))\" unfolding doMachineOp_def apply wpsimp apply (drule use_valid, rule setVSpaceRoot_irq_masks; assumption) done lemma dmo_setVSpaceRoot_memory[wp]: "doMachineOp (setVSpaceRoot r a) \\s. P (underlying_memory (ksMachineState s))\" unfolding doMachineOp_def apply wpsimp apply (drule use_valid, rule setVSpaceRoot_underlying_memory_inv; assumption) done lemma dmo_setVSpaceRoot_invs_no_cicd'[wp]: "doMachineOp (setVSpaceRoot r a) \invs_no_cicd'\" unfolding all_invs_but_ct_idle_or_in_cur_domain'_def valid_global_refs'_def valid_irq_node'_def valid_irq_handlers'_def irq_issued'_def irqs_masked'_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def ct_not_inQ_def pspace_domain_valid_def by (wpsimp wp: hoare_vcg_ball_lift hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_disj_lift simp: o_def | wps)+ lemma setVMRoot_invs [wp]: "setVMRoot p \invs'\" unfolding setVMRoot_def getThreadVSpaceRoot_def by (wpsimp wp: hoare_whenE_wp findVSpaceForASID_vs_at_wp hoare_drop_imps hoare_vcg_ex_lift hoare_vcg_all_lift) lemma setVMRoot_invs_no_cicd': "\invs_no_cicd'\ setVMRoot p \\rv. invs_no_cicd'\" unfolding setVMRoot_def getThreadVSpaceRoot_def by (wpsimp wp: hoare_whenE_wp findVSpaceForASID_vs_at_wp hoare_drop_imps hoare_vcg_ex_lift hoare_vcg_all_lift) crunch nosch [wp]: setVMRoot "\s. P (ksSchedulerAction s)" (wp: crunch_wps getObject_inv simp: crunch_simps loadObject_default_def) crunch it' [wp]: deleteASIDPool "\s. P (ksIdleThread s)" (simp: crunch_simps loadObject_default_def wp: getObject_inv mapM_wp') lemma lookupPTSlot_inv: "lookupPTSlot pt vptr \P\" unfolding lookupPTSlot_def by (wp lookupPTSlotFromLevel_inv) crunch it' [wp]: storePTE "\s. P (ksIdleThread s)" (simp: crunch_simps updateObject_default_def wp: setObject_idle') crunch it' [wp]: deleteASID "\s. P (ksIdleThread s)" (simp: crunch_simps loadObject_default_def updateObject_default_def wp: getObject_inv) crunch typ_at' [wp]: performPageTableInvocation "\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 simp: crunch_simps) lemma performASIDPoolInvocation_typ_at' [wp]: "\\s. P (typ_at' T p s)\ performASIDPoolInvocation api \\_ s. P (typ_at' T p s)\" by (wpsimp simp: performASIDPoolInvocation_def wp: getASID_wp hoare_vcg_imp_lift[where P'=\, simplified]) lemmas performPageTableInvocation_typ_ats' [wp] = typ_at_lifts [OF performPageTableInvocation_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 storePTE_pred_tcb_at' [wp]: "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 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 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 pte \\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)+ apply (clarsimp simp: 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]: "\valid_queues'\ storePTE p pte \\_. valid_queues'\" by (wp valid_queues_lift') 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) apply (auto simp: updateObject_default_def in_monad) 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 ksInterruptState [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)[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) crunch arch' [wp]: storePTE "\s. P (ksArchState s)" crunch cur' [wp]: storePTE "\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_vms'[wp]: "\valid_machine_state'\ storePTE p pte \\_. 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 (wp_pre, wps) 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 pte \\rv s. P (ksCurDomain s)\" by (simp add: storePTE_def) wp lemma storePTE_ksDomSchedule[wp]: "\\s. P (ksDomSchedule s)\ storePTE p pte \\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 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)+ crunches storePTE 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) crunches storePTE for pspace_canonical'[wp]: "pspace_canonical'" and pspace_in_kernel_mappings'[wp]: "pspace_in_kernel_mappings'" lemma storePTE_valid_objs[wp]: "storePTE p pte \valid_objs'\" apply (simp add: storePTE_def doMachineOp_def split_def) apply (rule hoare_pre, rule setObject_valid_objs'[where P=\]) apply (clarsimp simp: updateObject_default_def in_monad valid_obj'_def) apply simp done 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_invs[wp]: "storePTE p pte \invs'\" unfolding invs'_def valid_state'_def valid_pspace'_def by (wpsimp 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: cteCaps_of_def o_def) lemma setASIDPool_valid_objs [wp]: "setObject p (ap::asidpool) \valid_objs'\" apply (wp setObject_valid_objs'[where P=\]) apply (clarsimp simp: updateObject_default_def in_monad valid_obj'_def) apply simp 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 (wpsimp wp: setObject_ko_wp_at simp: objBits_simps) apply (simp add: pageBits_def) apply simp apply (clarsimp simp: obj_at'_def ko_wp_at'_def) 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_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 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 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) apply (auto simp: updateObject_default_def in_monad 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)[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_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 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 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]: "setObject p (ap::asidpool) \invs'\" apply (simp add: invs'_def valid_state'_def valid_pspace'_def) 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: o_def) done crunch cte_wp_at'[wp]: unmapPageTable "\s. P (cte_wp_at' P' p s)" (wp: crunch_wps simp: crunch_simps) lemmas storePTE_Invalid_invs = storePTE_invs[where pte=InvalidPTE, simplified] crunch invs'[wp]: unmapPageTable "invs'" (ignore: doMachineOp wp: storePTE_Invalid_invs mapM_wp' crunch_wps simp: crunch_simps) lemma perform_pti_invs [wp]: "\invs' and valid_pti' pti\ performPageTableInvocation pti \\_. invs'\" apply (clarsimp simp: performPageTableInvocation_def getSlotCap_def valid_pti'_def split: page_table_invocation.splits) apply (intro conjI allI impI; wpsimp wp: arch_update_updateCap_invs getCTE_wp' mapM_x_wp' hoare_vcg_all_lift hoare_vcg_imp_lift') apply (auto simp: cte_wp_at_ctes_of is_arch_update'_def isCap_simps valid_cap'_def capAligned_def) done crunches unmapPage for cte_wp_at': "\s. P (cte_wp_at' P' p s)" (wp: crunch_wps lookupPTSlotFromLevel_inv simp: crunch_simps) lemmas unmapPage_typ_ats [wp] = typ_at_lifts [OF unmapPage_typ_at'] lemma unmapPage_invs' [wp]: "unmapPage sz asid vptr pptr \invs'\" unfolding unmapPage_def by (wpsimp wp: lookupPTSlot_inv hoare_drop_imp hoare_vcg_all_lift) lemma perform_page_invs [wp]: "\invs' and valid_page_inv' pt\ performPageInvocation pt \\_. invs'\" apply (simp add: performPageInvocation_def) apply (cases pt) apply clarsimp apply ((wpsimp wp: hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_const_imp_lift arch_update_updateCap_invs unmapPage_cte_wp_at' getSlotCap_wp simp: valid_page_inv'_def is_arch_update'_def | (auto simp: is_arch_update'_def)[1])+)[3] apply (clarsimp simp: cte_wp_at_ctes_of valid_page_inv'_def) apply (clarsimp simp: is_arch_update'_def isCap_simps valid_cap'_def capAligned_def split: option.splits) done lemma setObject_cte_obj_at_ap': shows "\\s. P' (obj_at' (P :: asidpool \ bool) p s)\ setObject c (cte::cte) \\_ s. P' (obj_at' P p s)\" apply (clarsimp simp: setObject_def in_monad split_def valid_def lookupAround2_char1 obj_at'_def ps_clear_upd' split del: if_split) apply (clarsimp elim!: rsubst[where P=P']) apply (clarsimp simp: updateObject_cte in_monad objBits_simps tcbCTableSlot_def tcbVTableSlot_def typeError_def split: if_split_asm Structures_H.kernel_object.split_asm) done lemma updateCap_ko_at_ap_inv'[wp]: "\\s. P (ko_at' (ko::asidpool) p s )\ updateCap a b \\rv s. P ( ko_at' ko p s)\" by (wpsimp simp: updateCap_def setCTE_def wp: setObject_cte_obj_at_ap') lemma storePTE_asid_pool_obj_at'[wp]: "storePTE p pte \\s. P (obj_at' (P'::asidpool \ bool) t s)\" apply (simp add: storePTE_def) apply (clarsimp simp: setObject_def in_monad split_def valid_def lookupAround2_char1 obj_at'_def ps_clear_upd' split del: if_split) apply (clarsimp elim!: rsubst[where P=P]) apply (clarsimp simp: updateObject_default_def in_monad) done crunches copyGlobalMappings for asid_pool_obj_at'[wp]: "\s. P (obj_at' (P'::asidpool \ bool) p s)" and invs'[wp]: invs' (ignore: storePTE wp: crunch_wps) lemma perform_aci_invs [wp]: "\invs' and valid_apinv' api\ performASIDPoolInvocation api \\_. invs'\" apply (clarsimp simp: performASIDPoolInvocation_def split: asidpool_invocation.splits) apply (wpsimp wp: arch_update_updateCap_invs getASID_wp getSlotCap_wp hoare_vcg_all_lift hoare_vcg_imp_lift') apply (clarsimp simp: valid_apinv'_def cte_wp_at_ctes_of) apply (case_tac cte, clarsimp) apply (drule ctes_of_valid_cap', fastforce) apply (clarsimp simp: valid_cap'_def capAligned_def is_arch_update'_def isCap_simps wellformed_mapdata'_def) done 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