(* * Copyright 2014, General Dynamics C4 Systems * * This software may be distributed and modified according to the terms of * the GNU General Public License version 2. Note that NO WARRANTY is provided. * See "LICENSE_GPLv2.txt" for details. * * @TAG(GD_GPL) *) theory VSpace_C imports TcbAcc_C CSpace_C PSpace_C TcbQueue_C begin context begin interpretation Arch . (*FIXME: arch_split*) (* FIXME: move *) lemma empty_fail_findPDForASID[iff]: "empty_fail (findPDForASID asid)" apply (simp add: findPDForASID_def liftME_def) apply (intro empty_fail_bindE, simp_all split: option.split) apply (simp add: assertE_def split: split_if) apply (simp add: assertE_def split: split_if) apply (simp add: empty_fail_getObject) apply (simp add: assertE_def liftE_bindE checkPDAt_def split: split_if) done (* FIXME: move *) lemma empty_fail_findPDForASIDAssert[iff]: "empty_fail (findPDForASIDAssert asid)" apply (simp add: findPDForASIDAssert_def catch_def checkPDAt_def checkPDUniqueToASID_def checkPDASIDMapMembership_def) apply (intro empty_fail_bind, simp_all split: sum.split) done (* FIXME: move *) lemma mask_AND_less_0: "\x && mask n = 0; m \ n\ \ x && mask m = 0" apply (case_tac "len_of TYPE('a) \ n") apply (clarsimp simp: ge_mask_eq) apply (erule is_aligned_AND_less_0) apply (clarsimp simp: mask_2pm1 two_power_increasing) done end context kernel_m begin lemma pageBitsForSize_le: "pageBitsForSize x \ 24" by (simp add: pageBitsForSize_def split: vmpage_size.splits) lemma unat_of_nat_pageBitsForSize [simp]: "unat (of_nat (pageBitsForSize x)::word32) = pageBitsForSize x" apply (subst unat_of_nat32) apply (rule order_le_less_trans, rule pageBitsForSize_le) apply (simp add: word_bits_def) apply simp done lemma checkVPAlignment_ccorres: "ccorres (\a c. if to_bool c then a = Inr () else a = Inl AlignmentError) ret__unsigned_long_' \ (UNIV \ \sz = gen_framesize_to_H \sz \ \sz && mask 2 = \sz\ \ \\w = w\) [] (checkVPAlignment sz w) (Call checkVPAlignment_'proc)" proof - note [split del] = split_if show ?thesis apply (cinit lift: sz_' w_') apply (csymbr) apply clarsimp apply (rule ccorres_Guard [where A=\ and C'=UNIV]) apply (simp split: split_if) apply (rule conjI) apply (clarsimp simp: mask_def unlessE_def returnOk_def) apply (rule ccorres_guard_imp) apply (rule ccorres_return_C) apply simp apply simp apply simp apply simp apply (simp split: split_if add: to_bool_def) apply (clarsimp simp: mask_def unlessE_def throwError_def split: split_if) apply (rule ccorres_guard_imp) apply (rule ccorres_return_C) apply simp apply simp apply simp apply simp apply (simp split: split_if add: to_bool_def) apply (clarsimp split: split_if) apply (simp add: word_less_nat_alt) apply (rule order_le_less_trans, rule pageBitsForSize_le) apply simp done qed lemma rf_asidTable: "\ (\, x) \ rf_sr; valid_arch_state' \; idx \ mask asid_high_bits \ \ case armKSASIDTable (ksArchState \) idx of None \ index (armKSASIDTable_' (globals x)) (unat idx) = NULL | Some v \ index (armKSASIDTable_' (globals x)) (unat idx) = Ptr v \ index (armKSASIDTable_' (globals x)) (unat idx) \ NULL" apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def array_relation_def) apply (drule_tac x=idx in spec)+ apply (clarsimp simp: mask_def split: option.split) apply (drule sym, simp) apply (simp add: option_to_ptr_def option_to_0_def) apply (clarsimp simp: invs'_def valid_state'_def valid_arch_state'_def valid_asid_table'_def ran_def) done lemma getKSASIDTable_ccorres_stuff: "\ invs' \; (\, x) \ rf_sr; idx' = unat idx; idx < 2 ^ asid_high_bits \ \ case armKSASIDTable (ksArchState \) idx of None \ index (armKSASIDTable_' (globals x)) idx' = NULL | Some v \ index (armKSASIDTable_' (globals x)) idx' = Ptr v \ index (armKSASIDTable_' (globals x)) idx' \ NULL" apply (drule rf_asidTable [where idx=idx]) apply fastforce apply (simp add: mask_def) apply (simp add: minus_one_helper3) apply (clarsimp split: option.splits) done lemma asidLowBits_handy_convs: "sint Kernel_C.asidLowBits = 10" "Kernel_C.asidLowBits \ 0x20" "unat Kernel_C.asidLowBits = asid_low_bits" by (simp add: Kernel_C.asidLowBits_def asid_low_bits_def)+ lemma rf_sr_armKSASIDTable: "\ (s, s') \ rf_sr; n \ 2 ^ asid_high_bits - 1 \ \ index (armKSASIDTable_' (globals s')) (unat n) = option_to_ptr (armKSASIDTable (ksArchState s) n)" by (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def array_relation_def) lemma asid_high_bits_word_bits: "asid_high_bits < word_bits" by (simp add: asid_high_bits_def word_bits_def) lemma rf_sr_asid_map_pd_to_hwasids: "(s, s') \ rf_sr \ asid_map_pd_to_hwasids (armKSASIDMap (ksArchState s)) = set_option \ (pde_stored_asid \\<^sub>m cslift s' \\<^sub>m pd_pointer_to_asid_slot)" by (simp add: rf_sr_def cstate_relation_def Let_def carch_state_relation_def) lemma pd_at_asid_cross_over: "\ pd_at_asid' pd asid s; asid \ mask asid_bits; (s, s') \ rf_sr\ \ \apptr ap pde. index (armKSASIDTable_' (globals s')) (unat (asid >> asid_low_bits)) = (ap_Ptr apptr) \ cslift s' (ap_Ptr apptr) = Some (asid_pool_C ap) \ index ap (unat (asid && 2 ^ asid_low_bits - 1)) = pde_Ptr pd \ cslift s' (pde_Ptr (pd + 0x3FC0)) = Some pde \ is_aligned pd pdBits \ array_assertion (pde_Ptr pd) 4096 (hrs_htd (t_hrs_' (globals s'))) \ (valid_pde_mappings' s \ pde_get_tag pde = scast pde_pde_invalid)" apply (clarsimp simp: pd_at_asid'_def) apply (subgoal_tac "asid >> asid_low_bits \ 2 ^ asid_high_bits - 1") prefer 2 apply (simp add: asid_high_bits_word_bits) apply (rule shiftr_less_t2n) apply (simp add: mask_def) apply (simp add: asid_low_bits_def asid_high_bits_def asid_bits_def) apply (simp add: rf_sr_armKSASIDTable) apply (subgoal_tac "ucast (asid_high_bits_of asid) = asid >> asid_low_bits") prefer 2 apply (simp add: asid_high_bits_of_def ucast_ucast_mask asid_high_bits_def[symmetric]) apply (subst mask_eq_iff_w2p, simp add: asid_high_bits_def word_size) apply (rule shiftr_less_t2n) apply (simp add: mask_def, simp add: asid_bits_def asid_low_bits_def asid_high_bits_def) apply (simp add: option_to_ptr_def option_to_0_def) apply (rule cmap_relationE1 [OF rf_sr_cpspace_asidpool_relation], assumption, erule ko_at_projectKO_opt) apply (clarsimp simp: casid_pool_relation_def array_relation_def split: asid_pool_C.split_asm) apply (drule spec, drule sym [OF mp]) apply (rule_tac y=asid in word_and_le1) apply (frule(1) page_directory_at_rf_sr) apply (clarsimp simp: mask_2pm1[symmetric] option_to_ptr_def option_to_0_def page_directory_at'_def typ_at_to_obj_at_arches) apply (drule_tac x="pd_asid_slot" in spec, simp add: pd_asid_slot_def) apply (drule obj_at_ko_at'[where 'a=pde], clarsimp) apply (rule cmap_relationE1 [OF rf_sr_cpde_relation], assumption, erule ko_at_projectKO_opt) apply (subst array_ptr_valid_array_assertionI, erule h_t_valid_clift, simp+) apply (clarsimp simp: valid_pde_mappings'_def) apply (elim allE, drule(1) mp) apply (simp add: valid_pde_mapping'_def valid_pde_mapping_offset'_def pd_asid_slot_def mask_add_aligned) apply (simp add: mask_def pdBits_def pageBits_def) apply (clarsimp simp add: cpde_relation_def Let_def) by (simp add: pde_lift_def Let_def split: split_if_asm) lemma findPDForASIDAssert_pd_at_wp2: "\\s. \pd. pd_at_asid' pd asid s \ pd \ ran (option_map snd \ armKSASIDMap (ksArchState s) |` (- {asid})) \ option_map snd (armKSASIDMap (ksArchState s) asid) \ {None, Some pd} \ P pd s\ findPDForASIDAssert asid \P\" apply (rule hoare_pre) apply (simp add: findPDForASIDAssert_def const_def checkPDAt_def checkPDUniqueToASID_def checkPDASIDMapMembership_def) apply (wp findPDForASID_pd_at_wp) apply clarsimp apply (drule spec, erule mp) apply clarsimp apply (clarsimp split: option.split_asm) done lemma asid_shiftr_low_bits_less: "(asid :: word32) \ mask asid_bits \ asid >> asid_low_bits < 0x80" apply (rule_tac y="2 ^ 7" in order_less_le_trans) apply (rule shiftr_less_t2n) apply (simp add: le_mask_iff_lt_2n[THEN iffD1] asid_bits_def asid_low_bits_def) apply simp done lemma loadHWASID_ccorres: "ccorres (\a b. a = pde_stored_asid b \ pde_get_tag b = scast pde_pde_invalid) ret__struct_pde_C_' (valid_pde_mappings' and (\_. asid \ mask asid_bits)) (UNIV \ {s. asid_' s = asid}) [] (loadHWASID asid) (Call loadHWASID_'proc)" apply (rule ccorres_gen_asm) apply (cinit lift: asid_') apply (rule ccorres_Guard_Seq)+ apply (rule ccorres_symb_exec_l [OF _ _ _ empty_fail_gets]) apply (rule ccorres_symb_exec_l [OF _ _ _ empty_fail_findPDForASIDAssert]) apply (rename_tac pd) apply (rule_tac P="\s. pd_at_asid' pd asid s \ rv = armKSASIDMap (ksArchState s) \ pd \ ran (option_map snd o armKSASIDMap (ksArchState s) |` (- {asid})) \ option_map snd (armKSASIDMap (ksArchState s) asid) \ {None, Some pd} \ valid_pde_mappings' s" in ccorres_from_vcg_throws[where P'=UNIV]) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (frule(2) pd_at_asid_cross_over) apply (clarsimp simp: asidLowBits_handy_convs word_sless_def word_sle_def) apply (clarsimp simp: typ_heap_simps order_le_less_trans[OF word_and_le1] array_assertion_shrink_right ptr_add_assertion_def arg_cong[where f="\x. 2 ^ x", OF meta_eq_to_obj_eq, OF asid_low_bits_def]) apply (clarsimp split: option.split) apply (frule_tac x=pd in fun_cong [OF rf_sr_asid_map_pd_to_hwasids]) apply (simp add: asid_map_pd_to_hwasids_def pd_pointer_to_asid_slot_def) apply (intro conjI allI impI) apply (rule ccontr, clarsimp) apply (drule singleton_eqD) apply (clarsimp elim!: ranE) apply (erule notE, rule_tac a=xa in ranI) apply (simp add: restrict_map_def split: split_if) apply clarsimp apply clarsimp apply (drule_tac x=a in eqset_imp_iff) apply (drule iffD1) apply fastforce apply simp apply wp[1] apply (rule findPDForASIDAssert_pd_at_wp2) apply wp apply (clarsimp simp: asidLowBits_handy_convs word_sless_def word_sle_def Collect_const_mem asid_shiftr_low_bits_less) done lemma array_relation_update: "\ array_relation R bnd table (arr :: 'a['b :: finite]); x' = unat (x :: ('td :: len) word); R v v'; unat bnd < card (UNIV :: 'b set) \ \ array_relation R bnd (table (x := v)) (Arrays.update arr x' v')" by (simp add: array_relation_def word_le_nat_alt split: split_if) lemma asid_map_pd_to_hwasids_update: "\ pd \ ran (option_map snd \ m |` (- {asid})); \hw_asid pd'. m asid = Some (hw_asid, pd') \ pd' = pd \ \ asid_map_pd_to_hwasids (m (asid \ (hw_asid, pd))) = (asid_map_pd_to_hwasids m) (pd := {hw_asid})" apply (rule ext, rule set_eqI) apply (simp add: asid_map_pd_to_hwasids_def split: split_if) apply (intro conjI impI) apply (rule iffI) apply (rule ccontr, clarsimp elim!: ranE split: split_if_asm) apply (erule notE, rule ranI, simp add: restrict_map_def) apply (subst if_P, assumption) apply simp apply (fastforce split: split_if) apply (simp add: ran_def split: split_if) apply (rule iffI) apply fastforce apply (erule exEI) apply clarsimp done lemma storeHWASID_ccorres: "ccorres dc xfdc (valid_pde_mappings' and (\_. asid \ mask asid_bits)) (UNIV \ {s. asid_' s = asid} \ {s. hw_asid_' s = ucast hw_asid}) [] (storeHWASID asid hw_asid) (Call storeHWASID_'proc)" apply (rule ccorres_gen_asm) apply (cinit lift: asid_' hw_asid_') apply (rule ccorres_Guard_Seq)+ apply (rule ccorres_symb_exec_l [OF _ _ _ empty_fail_findPDForASIDAssert]) apply (rename_tac pd) apply (rule_tac P="\s. pd_at_asid' pd asid s \ pd \ ran (option_map snd o armKSASIDMap (ksArchState s) |` (- {asid})) \ option_map snd (armKSASIDMap (ksArchState s) asid) \ {None, Some pd} \ valid_pde_mappings' s" in ccorres_from_vcg[where P'=UNIV]) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: Collect_const_mem word_sle_def word_sless_def asidLowBits_handy_convs simpler_gets_def simpler_modify_def bind_def) apply (frule(2) pd_at_asid_cross_over) apply (clarsimp simp: typ_heap_simps) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cpspace_relation_def) apply (clarsimp simp: typ_heap_simps cmachine_state_relation_def carch_state_relation_def pd_at_asid'_def fun_upd_def[symmetric] carch_globals_def order_le_less_trans[OF word_and_le1] ptr_add_assertion_positive array_assertion_shrink_right arg_cong[where f="\x. 2 ^ x", OF meta_eq_to_obj_eq, OF asid_low_bits_def]) apply (subgoal_tac "ucast hw_asid ucast hw_asid < (256 :: sword32) \ (0 :: sword32) <=s ucast hw_asid") prefer 2 subgoal by (simp add: word_sless_msb_less ucast_less[THEN order_less_le_trans] word_0_sle_from_less) apply (simp add: word_sless_def word_sle_def cslift_ptr_safe) apply (intro conjI) apply (erule iffD1 [OF cmap_relation_cong, rotated -1], simp_all)[1] apply (simp split: split_if_asm) apply (clarsimp simp: cpde_relation_def Let_def pde_lift_pde_invalid cong: ARM_H.pde.case_cong) apply (erule array_relation_update) subgoal by simp subgoal by (simp add: option_to_0_def) subgoal by simp apply (subst asid_map_pd_to_hwasids_update, assumption) subgoal by clarsimp apply (rule ext, simp add: pd_pointer_to_asid_slot_def map_comp_def split: split_if) apply (clarsimp simp: pde_stored_asid_def true_def mask_def[where n="Suc 0"]) apply (subst less_mask_eq) apply (rule order_less_le_trans, rule ucast_less) subgoal by simp subgoal by simp apply (subst ucast_up_ucast_id) subgoal by (simp add: is_up_def source_size_def target_size_def word_size) subgoal by simp apply wp[1] apply (rule findPDForASIDAssert_pd_at_wp2) apply (clarsimp simp: asidLowBits_handy_convs word_sle_def word_sless_def Collect_const_mem asid_shiftr_low_bits_less) done lemma invalidateHWASIDEntry_ccorres: "hwasid' = unat hwasid \ ccorres dc xfdc \ UNIV [] (invalidateHWASIDEntry hwasid) (Basic (\s. globals_update ( armKSHWASIDTable_'_update (\_. Arrays.update (armKSHWASIDTable_' (globals s)) hwasid' (scast asidInvalid))) s))" apply (clarsimp simp: invalidateHWASIDEntry_def) apply (rule ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: bind_def simpler_gets_def simpler_modify_def) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) apply (clarsimp simp: carch_state_relation_def carch_globals_def cmachine_state_relation_def) apply (simp add: array_relation_def split: split_if, erule allEI) apply (clarsimp simp: word_le_nat_alt) apply (simp add: option_to_0_def asidInvalid_def) done lemma asid_map_pd_to_hwasids_clear: "\ pd \ ran (option_map snd \ m |` (- {asid})); \hw_asid pd'. m asid = Some (hw_asid, pd') \ pd' = pd \ \ asid_map_pd_to_hwasids (m (asid := None)) = (asid_map_pd_to_hwasids m) (pd := {})" apply (rule ext, rule set_eqI) apply (simp add: asid_map_pd_to_hwasids_def split: split_if) apply (intro conjI impI) apply (clarsimp elim!: ranE split: split_if_asm) apply (erule notE, rule ranI, simp add: restrict_map_def) apply (subst if_P, assumption) apply simp apply (simp add: ran_def split: split_if) apply (rule iffI) apply fastforce apply (erule exEI) apply clarsimp done lemma invalidateASID_ccorres: "ccorres dc xfdc (valid_pde_mappings' and (\_. asid \ mask asid_bits)) (UNIV \ {s. asid_' s = asid}) [] (invalidateASID asid) (Call invalidateASID_'proc)" apply (rule ccorres_gen_asm) apply (cinit lift: asid_') apply (rule ccorres_Guard_Seq)+ apply (rule ccorres_symb_exec_l [OF _ _ _ empty_fail_findPDForASIDAssert]) apply (rename_tac pd) apply (rule_tac P="\s. pd_at_asid' pd asid s \ valid_pde_mappings' s \ pd \ ran (option_map snd o armKSASIDMap (ksArchState s) |` (- {asid})) \ option_map snd (armKSASIDMap (ksArchState s) asid) \ {None, Some pd}" in ccorres_from_vcg[where P'=UNIV]) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: Collect_const_mem word_sle_def word_sless_def asidLowBits_handy_convs simpler_gets_def simpler_modify_def bind_def) apply (frule(2) pd_at_asid_cross_over) apply (clarsimp simp: typ_heap_simps) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cpspace_relation_def ptr_add_assertion_positive array_assertion_shrink_right) apply (clarsimp simp: typ_heap_simps cmachine_state_relation_def carch_state_relation_def pd_at_asid'_def carch_globals_def fun_upd_def[symmetric] order_le_less_trans[OF word_and_le1] arg_cong[where f="\x. 2 ^ x", OF meta_eq_to_obj_eq, OF asid_low_bits_def]) apply (intro conjI) apply (erule iffD1 [OF cmap_relation_cong, rotated -1], simp_all)[1] apply (simp split: split_if_asm) apply (clarsimp simp: cpde_relation_def Let_def pde_lift_pde_invalid cong: ARM_H.pde.case_cong) apply (subst asid_map_pd_to_hwasids_clear, assumption) subgoal by clarsimp apply (rule ext, simp add: pd_pointer_to_asid_slot_def map_comp_def split: split_if) subgoal by (clarsimp simp: pde_stored_asid_def false_def mask_def[where n="Suc 0"]) apply wp[1] apply (wp findPDForASIDAssert_pd_at_wp2) apply (clarsimp simp: asidLowBits_handy_convs word_sle_def word_sless_def asid_shiftr_low_bits_less) done definition "vm_fault_type_from_H fault \ case fault of vmfault_type.ARMDataAbort \ (scast Kernel_C.ARMDataAbort :: word32) | vmfault_type.ARMPrefetchAbort \ scast Kernel_C.ARMPrefetchAbort" lemma mask_32_id [simp]: "(x::word32) && mask 32 = x" using uint_lt2p [of x] by (simp add: mask_eq_iff) lemma handleVMFault_ccorres: "ccorres ((\a ex v. ex = scast EXCEPTION_FAULT \ (\vf. a = VMFault (fault_vm_fault_CL.address_CL vf) [instructionFault_CL vf, FSR_CL vf] \ errfault v = Some (Fault_vm_fault vf))) \ (\_. \)) (liftxf errstate id (K ()) ret__unsigned_long_') \ (UNIV \ \\thread = tcb_ptr_to_ctcb_ptr thread\ \ \\vm_faultType = vm_fault_type_from_H vm_fault\) [] (handleVMFault thread vm_fault) (Call handleVMFault_'proc)" apply (cinit lift: vm_faultType_') apply wpc apply (simp add: vm_fault_type_from_H_def Kernel_C.ARMDataAbort_def Kernel_C.ARMPrefetchAbort_def) apply (simp add: ccorres_cond_univ_iff) apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply (ctac (no_vcg) add: getFAR_ccorres pre: ccorres_liftE_Seq) apply (ctac (no_vcg) add: getDFSR_ccorres pre: ccorres_liftE_Seq) apply clarsimp apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (clarsimp simp add: throwError_def throw_def return_def) apply (rule conseqPre) apply vcg apply (clarsimp simp: errstate_def) apply (clarsimp simp: EXCEPTION_FAULT_def EXCEPTION_NONE_def) apply (simp add: fault_vm_fault_lift false_def) apply wp apply (simp add: vm_fault_type_from_H_def Kernel_C.ARMDataAbort_def Kernel_C.ARMPrefetchAbort_def) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff) apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply (ctac (no_vcg) pre: ccorres_liftE_Seq) apply (ctac (no_vcg) add: getIFSR_ccorres pre: ccorres_liftE_Seq) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (clarsimp simp add: throwError_def throw_def return_def) apply (rule conseqPre) apply vcg apply (clarsimp simp: errstate_def) apply (clarsimp simp: EXCEPTION_FAULT_def EXCEPTION_NONE_def) apply (simp add: fault_vm_fault_lift true_def mask_def) apply wp apply simp done lemma unat_asidLowBits [simp]: "unat Kernel_C.asidLowBits = asidLowBits" by (simp add: asidLowBits_def Kernel_C.asidLowBits_def asid_low_bits_def) lemma rf_sr_asidTable_None: "\ (\, x) \ rf_sr; asid && mask asid_bits = asid; valid_arch_state' \ \ \ (index (armKSASIDTable_' (globals x)) (unat (asid >> asid_low_bits)) = ap_Ptr 0) = (armKSASIDTable (ksArchState \) (ucast (asid_high_bits_of asid)) = None)" apply (simp add: asid_high_bits_of_def ucast_ucast_mask) apply (subgoal_tac "(asid >> asid_low_bits) && mask 7 = asid >> asid_low_bits")(*asid_low_bits*) prefer 2 apply (rule word_eqI) apply (subst (asm) bang_eq) apply (simp add: word_size nth_shiftr asid_bits_def asid_low_bits_def) apply (case_tac "n < 7", simp) (*asid_low_bits*) apply (clarsimp simp: linorder_not_less) apply (erule_tac x="n+10" in allE) apply simp apply simp apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def) apply (simp add: array_relation_def option_to_0_def) apply (erule_tac x="asid >> asid_low_bits" in allE) apply (erule impE) prefer 2 apply (drule sym [where t="index a b" for a b]) apply (simp add: option_to_0_def option_to_ptr_def split: option.splits) apply (clarsimp simp: valid_arch_state'_def valid_asid_table'_def ran_def) apply (simp add: and_mask_eq_iff_le_mask) apply (simp add: asid_high_bits_def mask_def) done lemma leq_asid_bits_shift: "x \ mask asid_bits \ (x::word32) >> asid_low_bits \ mask asid_high_bits" apply (rule word_leI) apply (simp add: nth_shiftr word_size) apply (rule ccontr) apply (clarsimp simp: linorder_not_less asid_high_bits_def asid_low_bits_def) apply (simp add: mask_def) apply (simp add: upper_bits_unset_is_l2p_32 [symmetric]) apply (simp add: asid_bits_def word_bits_def) apply (erule_tac x="n+10" in allE) apply (simp add: linorder_not_less) apply (drule test_bit_size) apply (simp add: word_size) done lemma ucast_asid_high_bits_is_shift: "asid \ mask asid_bits \ ucast (asid_high_bits_of asid) = (asid >> asid_low_bits)" apply (simp add: mask_def upper_bits_unset_is_l2p_32 [symmetric]) apply (simp add: asid_high_bits_of_def) apply (rule word_eqI) apply (simp add: word_size nth_shiftr nth_ucast asid_low_bits_def asid_bits_def word_bits_def) apply (erule_tac x="n+10" in allE) apply simp apply (case_tac "n < 7", simp) (*asid_low_bits*) apply (simp add: linorder_not_less) apply (rule notI) apply (frule test_bit_size) apply (simp add: word_size) done lemma cap_small_frame_cap_get_capFMappedASID_spec: "\s. \\ \s. cap_get_tag \cap = scast cap_small_frame_cap\ Call cap_small_frame_cap_get_capFMappedASID_'proc \\ret__unsigned_long = (cap_small_frame_cap_CL.capFMappedASIDHigh_CL (cap_small_frame_cap_lift \<^bsup>s\<^esup>cap) << asidLowBits) + (cap_small_frame_cap_CL.capFMappedASIDLow_CL (cap_small_frame_cap_lift \<^bsup>s\<^esup>cap))\" apply vcg apply (clarsimp simp: asidLowBits_def Kernel_C.asidLowBits_def word_sle_def asid_low_bits_def) done lemma cap_frame_cap_get_capFMappedASID_spec: "\s. \\ \s. cap_get_tag \cap = scast cap_frame_cap\ Call cap_frame_cap_get_capFMappedASID_'proc \\ret__unsigned_long = (cap_frame_cap_CL.capFMappedASIDHigh_CL (cap_frame_cap_lift \<^bsup>s\<^esup>cap) << asidLowBits) + (cap_frame_cap_CL.capFMappedASIDLow_CL (cap_frame_cap_lift \<^bsup>s\<^esup>cap))\" apply vcg apply (clarsimp simp: asidLowBits_def Kernel_C.asidLowBits_def word_sle_def asid_low_bits_def) done definition generic_frame_cap_get_capFMappedASID_CL :: "cap_CL option \ word32" where "generic_frame_cap_get_capFMappedASID_CL \ \cap. case cap of Some (Cap_small_frame_cap c) \ (cap_small_frame_cap_CL.capFMappedASIDHigh_CL c << asidLowBits) + (cap_small_frame_cap_CL.capFMappedASIDLow_CL c) | Some (Cap_frame_cap c) \ (cap_frame_cap_CL.capFMappedASIDHigh_CL c << asidLowBits) + (cap_frame_cap_CL.capFMappedASIDLow_CL c) | Some _ \ 0" lemma generic_frame_cap_get_capFMappedASID_spec: "\s. \ \ \s. cap_get_tag \cap = scast cap_small_frame_cap \ cap_get_tag \cap = scast cap_frame_cap\ Call generic_frame_cap_get_capFMappedASID_'proc \\ret__unsigned_long = generic_frame_cap_get_capFMappedASID_CL (cap_lift \<^bsup>s\<^esup>cap)\" apply vcg apply (clarsimp simp: generic_frame_cap_get_capFMappedASID_CL_def Kernel_C.asidLowBits_def word_sle_def ) apply (intro conjI impI, simp_all) apply (clarsimp simp: cap_lift_small_frame_cap cap_small_frame_cap_lift_def) apply (clarsimp simp: cap_lift_frame_cap cap_frame_cap_lift_def) done lemma generic_frame_cap_get_capFIsMapped_spec: "\s. \ \ \s. cap_get_tag \cap = scast cap_small_frame_cap \ cap_get_tag \cap = scast cap_frame_cap\ Call generic_frame_cap_get_capFIsMapped_'proc \\ret__unsigned_long = (if generic_frame_cap_get_capFMappedASID_CL (cap_lift \<^bsup>s\<^esup>cap) \ 0 then 1 else 0)\" apply vcg apply (clarsimp simp: generic_frame_cap_get_capFMappedASID_CL_def if_distrib [where f=scast]) done definition generic_frame_cap_get_capFMappedAddress_CL :: "cap_CL option \ word32" where "generic_frame_cap_get_capFMappedAddress_CL \ \cap. case cap of Some (Cap_small_frame_cap c) \ cap_small_frame_cap_CL.capFMappedAddress_CL c | Some (Cap_frame_cap c) \ cap_frame_cap_CL.capFMappedAddress_CL c | Some _ \ 0" lemma generic_frame_cap_get_capFMappedAddress_spec: "\s. \ \ \s. cap_get_tag \cap = scast cap_small_frame_cap \ cap_get_tag \cap = scast cap_frame_cap\ Call generic_frame_cap_get_capFMappedAddress_'proc \\ret__unsigned_long = generic_frame_cap_get_capFMappedAddress_CL (cap_lift \<^bsup>s\<^esup>cap)\" apply vcg apply (clarsimp simp: generic_frame_cap_get_capFMappedAddress_CL_def) apply (auto simp: cap_lift_small_frame_cap cap_small_frame_cap_lift_def cap_lift_frame_cap cap_frame_cap_lift_def) done definition generic_frame_cap_set_capFMappedAddress_CL :: "cap_CL option \ word32 \ word32 \ cap_CL option " where "generic_frame_cap_set_capFMappedAddress_CL \ \cap asid addr. case cap of Some (Cap_small_frame_cap c) \ Some ( Cap_small_frame_cap (c \ cap_small_frame_cap_CL.capFMappedASIDHigh_CL := (asid >> asidLowBits) && mask asidHighBits, cap_small_frame_cap_CL.capFMappedASIDLow_CL := asid && mask asidLowBits, cap_small_frame_cap_CL.capFMappedAddress_CL := addr AND NOT (mask 12) \)) | Some (Cap_frame_cap c) \ Some ( Cap_frame_cap (c \ cap_frame_cap_CL.capFMappedASIDHigh_CL := (asid >> asidLowBits) && mask asidHighBits, cap_frame_cap_CL.capFMappedASIDLow_CL := asid && mask asidLowBits, cap_frame_cap_CL.capFMappedAddress_CL := addr AND NOT (mask 14) \)) | Some ccap \ Some ccap" lemma generic_frame_cap_set_capFMappedAddress_spec: "\s. \ \ \s. cap_get_tag \cap = scast cap_small_frame_cap \ cap_get_tag \cap = scast cap_frame_cap\ Call generic_frame_cap_set_capFMappedAddress_'proc \ cap_lift \ret__struct_cap_C = generic_frame_cap_set_capFMappedAddress_CL (cap_lift \<^bsup>s\<^esup>cap) (\<^bsup>s\<^esup>asid ) (\<^bsup>s\<^esup>addr ) \" apply vcg apply (clarsimp simp: generic_frame_cap_set_capFMappedAddress_CL_def) apply (intro conjI impI) by (clarsimp simp: cap_lift_small_frame_cap cap_small_frame_cap_lift_def cap_lift_frame_cap cap_frame_cap_lift_def)+ lemma clift_ptr_safe: "clift (h, x) ptr = Some a \ ptr_safe ptr x" by (erule lift_t_ptr_safe[where g = c_guard]) lemma clift_ptr_safe2: "clift htd ptr = Some a \ ptr_safe ptr (hrs_htd htd)" by (cases htd, simp add: hrs_htd_def clift_ptr_safe) lemma generic_frame_cap_ptr_set_capFMappedAddress_spec: "\s cte_slot. \ \ \s. (\ cap. cslift s \<^bsup>s\<^esup>cap_ptr = Some cap \ cap_lift cap \ None \ (cap_get_tag cap = scast cap_small_frame_cap \ cap_get_tag cap = scast cap_frame_cap)) \ \cap_ptr = cap_Ptr &(cte_slot\[''cap_C'']) \ cslift s cte_slot \ None\ Call generic_frame_cap_ptr_set_capFMappedAddress_'proc {t. (\cte' cap'. generic_frame_cap_set_capFMappedAddress_CL (cap_lift (the (cslift s \<^bsup>s\<^esup>cap_ptr))) \<^bsup>s\<^esup>asid \<^bsup>s\<^esup>addr = Some cap' \ cte_lift cte' = option_map (cap_CL_update (K cap')) (cte_lift (the (cslift s cte_slot))) \ cslift t = cslift s(cte_slot \ cte')) \ cslift_all_but_cte_C t s \ (hrs_htd \<^bsup>t\<^esup>t_hrs) = (hrs_htd \<^bsup>s\<^esup>t_hrs)}" apply vcg apply (clarsimp simp: typ_heap_simps) apply (subgoal_tac "cap_lift ret__struct_cap_C \ None") prefer 2 apply (clarsimp simp: generic_frame_cap_set_capFMappedAddress_CL_def split: cap_CL.splits) apply (clarsimp simp: clift_ptr_safe2 typ_heap_simps) apply (rule_tac x="cte_C.cap_C_update (\_. ret__struct_cap_C) y" in exI) apply simp apply (case_tac y) apply (clarsimp simp: cte_lift_def) done lemma lookupPDSlot_spec: "\s. \ \ \s. array_assertion (pd_' s) (2 ^ pageBits) (hrs_htd (\t_hrs))\ Call lookupPDSlot_'proc \ \ret__ptr_to_struct_pde_C = Ptr (lookupPDSlot (ptr_val (pd_' s)) (vptr_' s)) \" apply vcg apply (clarsimp simp: lookupPDSlot_def) apply (simp add: ARM_A.lookup_pd_slot_def) apply (subst array_assertion_shrink_right, assumption) apply (rule unat_le_helper, simp) apply (rule order_less_imp_le, rule vptr_shiftr_le_2p) apply (simp add: Let_def word_sle_def) apply (case_tac pd) apply (simp add: word_shift_by_2) done lemma lookupPTSlot_nofail_spec: "\s. \ \ \s. array_assertion (pt_' s) (2 ^ (ptBits - 2)) (hrs_htd (\t_hrs))\ Call lookupPTSlot_nofail_'proc \ \ret__ptr_to_struct_pte_C = Ptr (lookup_pt_slot_no_fail (ptr_val (pt_' s)) (vptr_' s)) \" apply vcg apply (clarsimp simp: ) apply (simp add: ARM_A.lookup_pt_slot_no_fail_def) apply (subst array_assertion_shrink_right, assumption) apply (rule order_less_imp_le, rule unat_less_helper, simp) apply (rule order_le_less_trans, rule word_and_le1, simp add: ptBits_def pageBits_def) apply (simp add: Let_def word_sle_def) apply (case_tac pt) apply (simp add: word_shift_by_2) done lemma ccorres_pre_getObject_pde: assumes cc: "\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c" shows "ccorres r xf (\s. (\pde. ko_at' pde p s \ P pde s)) {s. \pde pde'. cslift s (pde_Ptr p) = Some pde' \ cpde_relation pde pde' \ s \ P' pde} hs (getObject p >>= (\rv. f rv)) c" apply (rule ccorres_guard_imp2) apply (rule ccorres_symb_exec_l) apply (rule ccorres_guard_imp2) apply (rule cc) apply (rule conjI) apply (rule_tac Q="ko_at' rv p s" in conjunct1) apply assumption apply assumption apply (wp getPDE_wp empty_fail_getObject | simp)+ apply clarsimp apply (erule cmap_relationE1 [OF rf_sr_cpde_relation], erule ko_at_projectKO_opt) apply simp done (* FIXME: move *) (* FIXME: delete duplicates in Corres_C *) lemma ccorres_abstract_cleanup: "ccorres r xf G G' hs a c \ ccorres r xf G ({s. s \ S \ s \ G'} \ S) hs a c" by (fastforce intro: ccorres_guard_imp) lemma pde_case_isPageTablePDE: "(case pde of PageTablePDE a b c \ fn a b c | _ \ g) = (if isPageTablePDE pde then fn (pdeTable pde) (pdeParity pde) (pdeDomain pde) else g)" by (cases pde, simp_all add: isPageTablePDE_def) lemma ptrFromPAddr_spec: "\s. \ \ {s} Call ptrFromPAddr_'proc \ \ret__ptr_to_void = Ptr (ptrFromPAddr (paddr_' s) ) \" apply vcg apply (simp add: ARM.ptrFromPAddr_def physMappingOffset_def kernelBase_addr_def physBase_def ARM.physBase_def) done lemma addrFromPPtr_spec: "\s. \ \ {s} Call addrFromPPtr_'proc \ \ret__unsigned_long = (addrFromPPtr (ptr_val (pptr_' s)) ) \" apply vcg apply (simp add: addrFromPPtr_def ARM.addrFromPPtr_def physMappingOffset_def kernelBase_addr_def physBase_def ARM.physBase_def) done abbreviation "lookupPTSlot_xf \ liftxf errstate lookupPTSlot_ret_C.status_C lookupPTSlot_ret_C.ptSlot_C ret__struct_lookupPTSlot_ret_C_'" lemma cpde_relation_pde_coarse: "cpde_relation pdea pde \ (pde_get_tag pde = scast pde_pde_coarse) = isPageTablePDE pdea" apply (simp add: cpde_relation_def Let_def) apply (simp add: pde_pde_coarse_lift) apply (case_tac pdea, simp_all add: isPageTablePDE_def) [1] apply clarsimp apply (simp add: pde_pde_coarse_lift_def) done lemma lookupPTSlot_ccorres: "ccorres (lookup_failure_rel \ (\rv rv'. rv' = pte_Ptr rv)) lookupPTSlot_xf (page_directory_at' pd) (UNIV \ \\pd = Ptr pd \ \ \\vptr = vptr \) [] (lookupPTSlot pd vptr) (Call lookupPTSlot_'proc)" apply (cinit lift: pd_' vptr_') apply (simp add: liftE_bindE pde_case_isPageTablePDE) apply (rule ccorres_pre_getObject_pde) apply csymbr apply csymbr apply (rule ccorres_abstract_cleanup) apply (rule_tac P="(ret__unsigned = scast pde_pde_coarse) = (isPageTablePDE rv)" in ccorres_gen_asm2) apply (rule ccorres_cond2'[where R=\]) apply (clarsimp simp: Collect_const_mem) apply simp apply (rule_tac P=\ and P' =UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: throwError_def return_def syscall_error_rel_def) apply (clarsimp simp: EXCEPTION_NONE_def EXCEPTION_LOOKUP_FAULT_def) apply (simp add: lookup_fault_missing_capability_lift) apply (simp add: mask_def) apply (rule ccorres_rhs_assoc)+ apply (simp add: checkPTAt_def bind_liftE_distrib liftE_bindE returnOk_liftE[symmetric]) apply (rule ccorres_stateAssert) apply (rule_tac P="page_table_at' (ptrFromPAddr (pdeTable rv)) and ko_at' rv (lookup_pd_slot pd vptr) and K (isPageTablePDE rv)" and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: returnOk_def return_def Collect_const_mem lookup_pd_slot_def word_sle_def) apply (frule(1) page_table_at_rf_sr, clarsimp) apply (erule cmap_relationE1[OF rf_sr_cpde_relation], erule ko_at_projectKO_opt) apply (clarsimp simp: typ_heap_simps cpde_relation_def Let_def isPageTablePDE_def pde_pde_coarse_lift_def pde_pde_coarse_lift split: pde.split_asm) apply (subst array_ptr_valid_array_assertionI, erule h_t_valid_clift, simp+) apply (rule unat_le_helper, rule order_trans[OF word_and_le1], simp) apply (simp add: word_shift_by_2 lookup_pt_slot_no_fail_def) apply (clarsimp simp: Collect_const_mem h_t_valid_clift) apply (frule(1) page_directory_at_rf_sr, clarsimp) apply (subst array_ptr_valid_array_assertionI, erule h_t_valid_clift, simp+) apply (simp add: pageBits_def) apply (clarsimp simp: cpde_relation_def pde_pde_coarse_lift_def pde_pde_coarse_lift Let_def isPageTablePDE_def split: ARM_H.pde.split_asm) done lemma cap_case_isPageDirectoryCap: "(case cap of capability.ArchObjectCap (arch_capability.PageDirectoryCap pd ( Some asid)) \ fn pd asid | _ => g) = (if ( if (isArchObjectCap cap) then if (isPageDirectoryCap (capCap cap)) then capPDMappedASID (capCap cap) \ None else False else False) then fn (capPDBasePtr (capCap cap)) (the ( capPDMappedASID (capCap cap))) else g)" apply (cases cap; simp add: isArchObjectCap_def) apply (rename_tac arch_capability) apply (case_tac arch_capability, simp_all add: isPageDirectoryCap_def) apply (rename_tac option) apply (case_tac option; simp) done (* FIXME: MOVE to CSpaceAcc_C *) lemma ccorres_pre_gets_armKSASIDTable_ksArchState: assumes cc: "\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c" shows "ccorres r xf (\s. (\rv. armKSASIDTable (ksArchState s) = rv \ P rv s)) {s. \rv. s \ P' rv } hs (gets (armKSASIDTable \ ksArchState) >>= (\rv. f rv)) c" apply (rule ccorres_guard_imp) apply (rule ccorres_symb_exec_l) defer apply wp[1] apply (rule gets_sp) apply (clarsimp simp: empty_fail_def simpler_gets_def) apply assumption apply clarsimp defer apply (rule ccorres_guard_imp) apply (rule cc) apply clarsimp apply assumption apply clarsimp done abbreviation "findPDForASID_xf \ liftxf errstate findPDForASID_ret_C.status_C findPDForASID_ret_C.pd_C ret__struct_findPDForASID_ret_C_'" lemma ccorres_pre_getObject_asidpool: assumes cc: "\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c" shows "ccorres r xf (\s. (\asidpool. ko_at' asidpool p s \ P asidpool s)) {s. \ asidpool asidpool'. cslift s (ap_Ptr p) = Some asidpool' \ casid_pool_relation asidpool asidpool' \ s \ P' asidpool} hs (getObject p >>= (\rv :: asidpool. f rv)) c" apply (rule ccorres_guard_imp2) apply (rule ccorres_symb_exec_l) apply (rule ccorres_guard_imp2) apply (rule cc) apply (rule conjI) apply (rule_tac Q="ko_at' rv p s" in conjunct1) apply assumption apply assumption apply (wp getASID_wp empty_fail_getObject | simp) apply (wp getASID_wp empty_fail_getObject | simp) apply (wp getASID_wp empty_fail_getObject | simp) apply (wp getASID_wp empty_fail_getObject | simp) apply clarsimp apply (erule cmap_relationE1 [OF rf_sr_cpspace_asidpool_relation], erule ko_at_projectKO_opt) apply simp done (* FIXME: move *) lemma ccorres_from_vcg_throws_nofail: "\\. \\ {s. P \ \ s \ P' \ (\, s) \ srel} c {}, {s. \snd (a \) \ (\(rv, \')\fst (a \). (\', s) \ srel \ arrel rv (axf s))} \ ccorres_underlying srel \ r xf arrel axf P P' (SKIP # hs) a c" apply (rule ccorresI') apply (drule_tac x = s in spec) apply (drule hoare_sound) apply (simp add: HoarePartialDef.valid_def cvalid_def) apply (erule exec_handlers.cases) apply clarsimp apply (drule spec, drule spec, drule (1) mp) apply (clarsimp dest!: exec_handlers_SkipD simp: split_def unif_rrel_simps elim!: bexI [rotated]) apply clarsimp apply (drule spec, drule spec, drule (1) mp) apply clarsimp apply simp done lemma findPDForASID_ccorres: "ccorres (lookup_failure_rel \ (\pdeptrc pdeptr. pdeptr = pde_Ptr pdeptrc)) findPDForASID_xf (valid_arch_state' and no_0_obj' and (\_. asid \ mask asid_bits)) (UNIV \ \\asid = asid\ ) [] (findPDForASID asid) (Call findPDForASID_'proc)" apply (rule ccorres_gen_asm) apply (cinit lift: asid_') apply (rule ccorres_Guard_Seq) apply (rule ccorres_Guard_Seq) apply (rule ccorres_assertE) apply (rule ccorres_assertE) apply (rule ccorres_liftE_Seq) apply (rule_tac r'="\asidTable rv'. rv' = option_to_ptr (asidTable (ucast (asid_high_bits_of asid)))" and xf'=poolPtr_' in ccorres_split_nothrow) apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: simpler_gets_def Kernel_C.asidLowBits_def) apply (simp add: ucast_asid_high_bits_is_shift) apply (erule rf_sr_armKSASIDTable) apply (drule leq_asid_bits_shift) apply (simp add: asid_high_bits_def mask_def) apply ceqv apply (simp add: liftME_def) apply (simp add: bindE_assoc) apply (rename_tac asidTable poolPtr) apply (subgoal_tac "(doE x \ case asidTable (ucast (asid_high_bits_of asid)) of None \ throw Fault_H.lookup_failure.InvalidRoot | Some ptr \ withoutFailure $ getObject ptr; (case inv asidpool.ASIDPool x (asid && mask asid_low_bits) of None \ throw Fault_H.lookup_failure.InvalidRoot | Some ptr \ doE haskell_assertE (ptr \ 0) []; withoutFailure $ checkPDAt ptr; returnOk ptr odE) odE) = (if ( asidTable (ucast (asid_high_bits_of asid))=None) then (doE x\ throw Fault_H.lookup_failure.InvalidRoot; (case inv asidpool.ASIDPool x (asid && mask asid_low_bits) of None \ throw Fault_H.lookup_failure.InvalidRoot | Some ptr \ doE haskell_assertE (ptr \ 0) []; withoutFailure $ checkPDAt ptr; returnOk ptr odE) odE) else (doE x\ withoutFailure $ getObject (the (asidTable (ucast (asid_high_bits_of asid)))); (case inv asidpool.ASIDPool x (asid && mask asid_low_bits) of None \ throw Fault_H.lookup_failure.InvalidRoot | Some ptr \ doE haskell_assertE (ptr \ 0) []; withoutFailure $ checkPDAt ptr; returnOk ptr odE) odE))") prefer 2 apply (case_tac "asidTable (ucast (asid_high_bits_of asid))", clarsimp, clarsimp) apply simp apply (thin_tac "a = (if b then c else d)" for a b c d) apply (rule_tac Q="\s. asidTable = (armKSASIDTable (ksArchState s))\ valid_arch_state' s \ no_0_obj' s \ (asid \ mask asid_bits) " and Q'="\s'. option_to_ptr (asidTable (ucast (asid_high_bits_of asid))) = index (armKSASIDTable_' (globals s')) (unat (asid >> asid_low_bits))" in ccorres_if_cond_throws) apply clarsimp apply (subgoal_tac "asid && mask asid_bits = asid") prefer 2 apply (rule less_mask_eq) apply (simp add: mask_def) apply (simp add: rf_sr_asidTable_None [symmetric] Collect_const_mem) apply (rule_tac P=\ and P' =UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: throwError_def return_def bindE_def bind_def NonDetMonad.lift_def) apply (clarsimp simp: EXCEPTION_NONE_def EXCEPTION_LOOKUP_FAULT_def) apply (simp add: lookup_fault_lift_invalid_root) apply (simp add: Collect_const[symmetric] del: Collect_const) apply (rule ccorres_liftE_Seq) apply (rule ccorres_pre_getObject_asidpool) apply (rule ccorres_Guard_Seq)+ (*Note for Tom: apply wpc breaks here - blocks everything, cannot be interrupted *) apply (case_tac "inv ASIDPool rv (asid && mask asid_low_bits) = Some 0") apply simp apply (rule ccorres_fail') apply (rule_tac P="\s. asidTable=armKSASIDTable (ksArchState s) \ valid_arch_state' s \ (asid \ mask asid_bits) " and P'= "{s'. (\ ap'. cslift s' (ap_Ptr (the (asidTable (ucast (asid_high_bits_of asid))))) = Some ap' \ casid_pool_relation rv ap')}" in ccorres_from_vcg_throws_nofail) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: ucast_asid_high_bits_is_shift) apply (frule_tac idx="(asid >> asid_low_bits)" in rf_asidTable, assumption, simp add: leq_asid_bits_shift) apply (clarsimp simp: option_to_ptr_def option_to_0_def) apply (clarsimp simp: typ_heap_simps) apply (case_tac rv, clarsimp simp: inv_def) apply (simp add:casid_pool_relation_def) apply (case_tac ap', simp) apply (simp add: array_relation_def) apply (erule_tac x="(asid && 2 ^ asid_low_bits - 1)" in allE) apply (simp add: word_and_le1 mask_def option_to_ptr_def option_to_0_def) apply (rename_tac "fun" array) apply (case_tac "fun (asid && 2 ^ asid_low_bits - 1)", clarsimp) apply (clarsimp simp: throwError_def return_def ) apply (clarsimp simp: EXCEPTION_NONE_def EXCEPTION_LOOKUP_FAULT_def) apply (simp add: lookup_fault_lift_invalid_root) apply (clarsimp simp: returnOk_def return_def checkPDAt_def in_monad stateAssert_def liftE_bindE get_def bind_def assert_def fail_def split:if_splits) apply vcg apply simp apply wp apply vcg apply (clarsimp simp: Collect_const_mem) apply (simp add: Kernel_C.asidLowBits_def word_sle_def asid_shiftr_low_bits_less order_le_less_trans[OF word_and_le1] arg_cong[where f="\x. 2 ^ x", OF meta_eq_to_obj_eq, OF asid_low_bits_def]) apply (clarsimp simp: option_to_0_def option_to_ptr_def) apply (clarsimp simp: typ_heap_simps split: option.split_asm) done lemma ccorres_pre_gets_armKSGlobalPD_ksArchState: assumes cc: "\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c" shows "ccorres r xf (\s. (\rv. armKSGlobalPD (ksArchState s) = rv \ P rv s)) (P' (ptr_val ((Ptr ::(32 word \ (pde_C[4096]) ptr)) (symbol_table ''armKSGlobalPD'')))) hs (gets (armKSGlobalPD \ ksArchState) >>= (\rv. f rv)) c" apply (rule ccorres_guard_imp) apply (rule ccorres_symb_exec_l) defer apply wp[1] apply (rule gets_sp) apply (clarsimp simp: empty_fail_def simpler_gets_def) apply assumption apply clarsimp defer apply (rule ccorres_guard_imp) apply (rule cc) apply clarsimp apply assumption apply (drule rf_sr_armKSGlobalPD) apply simp done lemma flushSpace_ccorres: "ccorres dc xfdc (valid_pde_mappings' and (\_. asid \ mask asid_bits)) (UNIV \ {s. asid_' s = asid}) [] (flushSpace asid) (Call flushSpace_'proc)" apply (rule ccorres_gen_asm) apply (cinit lift: asid_') apply (ctac (no_vcg) add: loadHWASID_ccorres) apply (ctac (no_vcg) add: cleanCaches_PoU_ccorres) apply csymbr apply (simp add: case_option_If2) apply (rule_tac Q=\ and Q'=\ in ccorres_if_cond_throws2) apply (clarsimp simp: Collect_const_mem pde_stored_asid_def) apply (simp add: split_if_eq1 to_bool_def) apply (rule ccorres_return_void_C [unfolded dc_def]) apply csymbr apply (clarsimp simp: pde_stored_asid_def) apply (case_tac "to_bool (stored_asid_valid_CL (pde_pde_invalid_lift stored_hw_asid___struct_pde_C))") prefer 2 apply clarsimp apply clarsimp apply (case_tac "pde_get_tag stored_hw_asid___struct_pde_C = scast pde_pde_invalid") prefer 2 apply clarsimp apply clarsimp apply (rule ccorres_call, rule invalidateTLB_ASID_ccorres [unfolded dc_def xfdc_def], simp+)[1] apply vcg apply wp apply simp done (* FIXME: MOVE *) lemma ccorres_pre_gets_armKSHWASIDTable_ksArchState: assumes cc: "\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c" shows "ccorres r xf (\s. (\rv. armKSHWASIDTable (ksArchState s) = rv \ P rv s)) {s. \rv. s \ P' rv } hs (gets (armKSHWASIDTable \ ksArchState) >>= (\rv. f rv)) c" apply (rule ccorres_guard_imp) apply (rule ccorres_symb_exec_l) defer apply wp[1] apply (rule gets_sp) apply (clarsimp simp: empty_fail_def simpler_gets_def) apply assumption apply clarsimp defer apply (rule ccorres_guard_imp) apply (rule cc) apply clarsimp apply assumption apply clarsimp done (* FIXME: MOVE *) lemma ccorres_pre_gets_armKSNextASID_ksArchState: assumes cc: "\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c" shows "ccorres r xf (\s. (\rv. armKSNextASID (ksArchState s) = rv \ P rv s)) {s. \rv. s \ P' rv } hs (gets (armKSNextASID \ ksArchState) >>= (\rv. f rv)) c" apply (rule ccorres_guard_imp) apply (rule ccorres_symb_exec_l) defer apply wp[1] apply (rule gets_sp) apply (clarsimp simp: empty_fail_def simpler_gets_def) apply assumption apply clarsimp defer apply (rule ccorres_guard_imp) apply (rule cc) apply clarsimp apply assumption apply clarsimp done lemma ccorres_from_vcg_might_throw: "(\\. Gamm \ {s. P \ \ s \ P' \ (\, s) \ sr} c {s. \(rv, \') \ fst (a \). (\', s) \ sr \ r rv (xf s)}, {s. \(rv, \') \ fst (a \). (\', s) \ sr \ arrel rv (axf s)}) \ ccorres_underlying sr Gamm r xf arrel axf P P' (SKIP # hs) a c" apply (rule ccorresI') apply (drule_tac x=s in spec) apply (erule exec_handlers.cases, simp_all) apply clarsimp apply (erule exec_handlers.cases, simp_all)[1] apply (auto elim!: exec_Normal_elim_cases)[1] apply (drule(1) exec_abrupt[rotated]) apply simp apply (clarsimp simp: unif_rrel_simps elim!: exec_Normal_elim_cases) apply fastforce apply (clarsimp simp: unif_rrel_simps) apply (drule hoare_sound) apply (clarsimp simp: cvalid_def HoarePartialDef.valid_def) apply fastforce done lemma rf_sr_armKSASIDTable_rel: "(s, s') \ rf_sr \ array_relation (op = \ option_to_0) 0xFF (armKSHWASIDTable (ksArchState s)) (armKSHWASIDTable_' (globals s'))" by (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def) lemma rf_sr_armKSASIDTable_rel': "\ (s, s') \ rf_sr; valid_arch_state' s \ \ index (armKSHWASIDTable_' (globals s')) (unat x) = option_to_0 (armKSHWASIDTable (ksArchState s) x) \ ((option_to_0 (armKSHWASIDTable (ksArchState s) x) = 0) = (armKSHWASIDTable (ksArchState s) x = None))" apply (rule conjI) apply (drule rf_sr_armKSASIDTable_rel) apply (clarsimp simp: array_relation_def) apply (rule sym, drule spec, erule mp) apply (rule order_trans, rule word_n1_ge) apply simp apply (clarsimp simp: option_to_0_def split: option.splits) apply (clarsimp simp: valid_arch_state'_def valid_asid_map'_def) apply (drule (1) is_inv_SomeD) apply (drule subsetD, fastforce) apply simp done lemma rf_sr_armKSNextASID: "(s, s') \ rf_sr \ armKSNextASID_' (globals s') = armKSNextASID (ksArchState s)" by (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def) end context begin interpretation Arch . (*FIXME: arch_split*) crunch armKSNextASID[wp]: invalidateASID "\s. P (armKSNextASID (ksArchState s))" crunch armKSNextASID[wp]: invalidateHWASIDEntry "\s. P (armKSNextASID (ksArchState s))" lemma scast_ucast_down_same: "(scast :: word32 \ word8) = (ucast :: word32 \ word8)" apply (rule down_cast_same [symmetric]) apply (simp add: is_down_def target_size_def source_size_def word_size) done end context kernel_m begin lemma findFreeHWASID_ccorres: "ccorres (op =) ret__unsigned_char_' (valid_arch_state' and valid_pde_mappings') UNIV [] (findFreeHWASID) (Call findFreeHWASID_'proc)" apply (cinit) apply csymbr apply (rule ccorres_pre_gets_armKSHWASIDTable_ksArchState) apply (rule ccorres_pre_gets_armKSNextASID_ksArchState) apply (simp add: whileAnno_def case_option_find_give_me_a_map mapME_def del: Collect_const map_append) apply (rule ccorres_splitE_novcg) apply (rule ccorres_Guard) apply (subgoal_tac "[nextASID .e. maxBound] @ init [minBound .e. nextASID] = map (\x. nextASID + (of_nat x)) [0 ..< 256]") -- "Remove the Guard SignedArithmetic \True\ SKIP" apply (rule ccorres_semantic_equivD2 [rotated]) apply (iprover intro: semantic_equiv_While_cong semantic_equiv_Guard_Skip_Seq) apply (rule_tac xf=hw_asid_offset_' and i=0 and xf_update=hw_asid_offset_'_update and r'=dc and xf'=xfdc and Q=UNIV and F="\n s. rv = armKSHWASIDTable (ksArchState s) \ nextASID = armKSNextASID (ksArchState s) \ valid_arch_state' s" in ccorres_sequenceE_while_gen') apply (rule ccorres_from_vcg_might_throw) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: rf_sr_armKSNextASID) apply (subst down_cast_same [symmetric], simp add: is_down_def target_size_def source_size_def word_size)+ apply (simp add: ucast_ucast_mask ucast_ucast_add ucast_and_mask ucast_of_nat_small asidInvalid_def word_sless_msb_less ucast_less[THEN order_less_le_trans] word_0_sle_from_less) apply (simp add: word_sint_msb_eq not_msb_from_less word_of_nat_less trans[OF msb_nth nth_ucast] bang_big word_size uint_up_ucast is_up_def source_size_def target_size_def word_size) apply (simp add: uint_nat unat_of_nat) apply (rule conjI, unat_arith, simp) apply (simp add: rf_sr_armKSASIDTable_rel' throwError_def return_def) apply (clarsimp simp: returnOk_def return_def) apply (simp add: minus_one_norm) apply unat_arith apply (rule conseqPre, vcg) apply clarsimp apply simp apply (rule hoare_pre, wp) apply simp apply simp apply simp apply simp apply (cut_tac x=nextASID in leq_maxBound[unfolded word_le_nat_alt]) apply (simp add: minBound_word init_def maxBound_word minus_one_norm) apply (simp add: upto_enum_word) apply (rule nth_equalityI) apply (simp add: min.absorb2 del: upt.simps) apply (simp add: min.absorb2 del: upt.simps) apply (simp add: nth_append split: split_if) apply ceqv apply (rule ccorres_assert) apply (rule_tac A="\s. nextASID = armKSNextASID (ksArchState s) \ rv = armKSHWASIDTable (ksArchState s) \ valid_arch_state' s \ valid_pde_mappings' s" in ccorres_guard_imp2[where A'=UNIV]) apply (simp add: split_def) apply (rule ccorres_symb_exec_r) apply (rule_tac xf'=hw_asid_' in ccorres_abstract, ceqv) apply (rule_tac P="rv'a = nextASID" in ccorres_gen_asm2) apply (simp del: Collect_const) apply ((rule ccorres_move_const_guard )+)? apply (ctac(no_vcg) add: invalidateASID_ccorres) apply ((rule ccorres_move_const_guard | simp only: ccorres_seq_simps)+)? apply (ctac(no_vcg) add: invalidateTLB_ASID_ccorres) apply (rule ccorres_split_nothrow) apply (rule ccorres_move_const_guard )+ apply (rule ccorres_handlers_weaken) apply (rule invalidateHWASIDEntry_ccorres[OF refl]) apply ceqv apply (rule_tac P="\s. nextASID = armKSNextASID (ksArchState s)" in ccorres_from_vcg_throws[where P'=UNIV]) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp del: rf_sr_upd_safe) apply (clarsimp simp: rf_sr_def bind_def simpler_modify_def return_def cstate_relation_def Let_def) apply (simp add: carch_state_relation_def carch_globals_def cmachine_state_relation_def) apply (subst down_cast_same [symmetric], simp add: is_down_def target_size_def source_size_def word_size)+ apply (clarsimp simp: maxBound_word minBound_word ucast_ucast_add minus_one_norm split: split_if) apply (simp add: word_sint_msb_eq uint_up_ucast word_size msb_nth nth_ucast bang_big is_up_def source_size_def target_size_def) apply (simp add: uint_nat) apply unat_arith subgoal by simp apply wp apply vcg apply simp apply wp[1] apply simp apply wp apply vcg apply (rule conseqPre, vcg) apply clarsimp apply (drule_tac x=nextASID in bspec, simp) apply (clarsimp simp: rf_sr_armKSNextASID rf_sr_armKSASIDTable_rel' valid_arch_state'_def valid_asid_map'_def Collect_const_mem word_sless_msb_less ucast_less[THEN order_less_le_trans] word_0_sle_from_less) apply (simp add: option_to_0_def) apply (frule(1) is_inv_SomeD, clarsimp) apply (drule subsetD, erule domI) apply simp apply (fold mapME_def) apply (wp mapME_wp') apply (rule hoare_pre, wp) apply simp apply (clarsimp simp: guard_is_UNIV_def) apply simp done lemma all_invs_but_ct_idle_or_in_cur_domain_valid_pde_mappings': "all_invs_but_ct_idle_or_in_cur_domain' s \ valid_pde_mappings' s" by (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def) lemma invs_valid_pde_mappings': "invs' s \ valid_pde_mappings' s" by (clarsimp simp: invs'_def valid_state'_def) lemmas invs_valid_pde_mappings'[rule_format, elim!] lemma getHWASID_ccorres: "ccorres (op =) ret__unsigned_char_' (all_invs_but_ct_idle_or_in_cur_domain' and (\s. asid \ mask asid_bits)) (UNIV \ {s. asid_' s = asid}) [] (getHWASID asid) (Call getHWASID_'proc)" apply (cinit lift: asid_') apply (ctac(no_vcg) add: loadHWASID_ccorres) apply csymbr apply wpc apply (rule ccorres_cond_false) apply (rule ccorres_rhs_assoc)+ apply csymbr apply simp apply (ctac(no_vcg) add: findFreeHWASID_ccorres) apply (ctac(no_vcg) add: storeHWASID_ccorres) apply (rule ccorres_return_C, simp+)[1] apply wp apply (strengthen all_invs_but_ct_idle_or_in_cur_domain_valid_pde_mappings') apply (wp findFreeHWASID_invs_no_cicd') apply (rule ccorres_cond_true) apply (rule ccorres_from_vcg_throws[where P=\ and P'=UNIV]) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def pde_stored_asid_def split: split_if_asm) apply wp apply (clarsimp simp: pde_stored_asid_def) apply (clarsimp simp: to_bool_def split: split_if) apply (auto simp: all_invs_but_ct_idle_or_in_cur_domain'_def) done lemma armv_contextSwitch_ccorres: "ccorres dc xfdc (all_invs_but_ct_idle_or_in_cur_domain' and (\s. asid \ mask asid_bits)) (UNIV \ {s. cap_pd_' s = pde_Ptr pd} \ {s. asid_' s = asid} ) [] (armv_contextSwitch pd asid) (Call armv_contextSwitch_'proc)" apply (cinit lift: cap_pd_' asid_') apply simp apply (ctac(no_vcg) add: getHWASID_ccorres) apply (fold dc_def) apply (ctac (no_vcg)add: armv_contextSwitch_HWASID_ccorres) apply wp apply clarsimp done (* FIXME: move *) lemma ccorres_h_t_valid_armKSGlobalPD: "ccorres r xf P P' hs f (f' ;; g') \ ccorres r xf P P' hs f (Guard C_Guard {s'. s' \\<^sub>c (Ptr::(32 word \ (pde_C[4096]) ptr)) (symbol_table ''armKSGlobalPD'')} f';; g')" apply (rule ccorres_guard_imp2) apply (rule ccorres_move_c_guards[where P = \]) apply clarsimp apply assumption apply simp by (simp add:rf_sr_def cstate_relation_def Let_def) lemma setVMRoot_ccorres: "ccorres dc xfdc (all_invs_but_ct_idle_or_in_cur_domain' and tcb_at' thread) (UNIV \ {s. tcb_' s = tcb_ptr_to_ctcb_ptr thread}) [] (setVMRoot thread) (Call setVMRoot_'proc)" apply (cinit lift: tcb_') apply (rule ccorres_move_array_assertion_tcb_ctes) apply (rule ccorres_move_c_guard_tcb_ctes) apply (simp add: getThreadVSpaceRoot_def locateSlot_conv) apply (ctac) apply csymbr apply csymbr apply (simp add: if_1_0_0 cap_get_tag_isCap_ArchObject2 del: Collect_const) apply (rule ccorres_Cond_rhs_Seq) apply (simp add: cap_case_isPageDirectoryCap cong: if_cong) apply (rule ccorres_cond_true_seq) apply (rule ccorres_rhs_assoc) apply (simp add: throwError_def catch_def dc_def[symmetric]) apply (rule ccorres_rhs_assoc)+ apply (rule ccorres_h_t_valid_armKSGlobalPD) apply csymbr apply (rule ccorres_pre_gets_armKSGlobalPD_ksArchState[unfolded comp_def]) apply (rule ccorres_add_return2) apply (ctac (no_vcg) add: setCurrentPD_ccorres) apply (rule ccorres_split_throws) apply (rule ccorres_return_void_C) apply vcg apply wp apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply (rule_tac P="to_bool (capPDIsMapped_CL (cap_page_directory_cap_lift threadRoot)) = (capPDMappedASID (capCap rv) \ None)" in ccorres_gen_asm2) apply (simp add: if_1_0_0 to_bool_def del: Collect_const) apply (rule ccorres_Cond_rhs_Seq) apply (simp add: cap_case_isPageDirectoryCap cong: if_cong) apply (simp add: throwError_def catch_def) apply (rule ccorres_rhs_assoc)+ apply (rule ccorres_h_t_valid_armKSGlobalPD) apply csymbr apply (rule ccorres_pre_gets_armKSGlobalPD_ksArchState[unfolded comp_def]) apply (rule ccorres_add_return2) apply (ctac (no_vcg) add: setCurrentPD_ccorres) apply (rule ccorres_split_throws) apply (rule ccorres_return_void_C [unfolded dc_def]) apply vcg apply wp apply (simp add: cap_case_isPageDirectoryCap) apply (simp add: catch_def) apply csymbr apply csymbr apply csymbr apply (simp add: liftE_bindE) apply (simp add: bindE_bind_linearise bind_assoc liftE_def) apply (rule_tac f'=lookup_failure_rel and r'="\pdeptrc pdeptr. pdeptr = pde_Ptr pdeptrc" and xf'=find_ret_' in ccorres_split_nothrow_case_sum) apply (ctac add: findPDForASID_ccorres) apply ceqv apply (rule_tac P="capPDBasePtr_CL (cap_page_directory_cap_lift threadRoot) = capPDBasePtr (capCap rv)" in ccorres_gen_asm2) apply (simp del: Collect_const) apply (rule ccorres_Cond_rhs_Seq) apply (simp add: whenE_def throwError_def checkPDNotInASIDMap_def checkPDASIDMapMembership_def) apply (rule ccorres_stateAssert) apply (rule ccorres_pre_gets_armKSGlobalPD_ksArchState[unfolded o_def]) apply (rule ccorres_rhs_assoc)+ apply (rule ccorres_h_t_valid_armKSGlobalPD) apply csymbr apply (rule ccorres_add_return2) apply (ctac(no_vcg) add: setCurrentPD_ccorres) apply (rule ccorres_split_throws) apply (rule ccorres_return_void_C[unfolded dc_def]) apply vcg apply wp apply (simp add: whenE_def returnOk_def) apply (rule ccorres_add_return2) apply (ctac (no_vcg) add: armv_contextSwitch_ccorres[unfolded dc_def]) apply simp apply (rule ccorres_cond_empty) apply (rule ccorres_return_Skip[simplified dc_def]) apply wp[1] apply (simp add: checkPDNotInASIDMap_def checkPDASIDMapMembership_def) apply (rule ccorres_stateAssert) apply (rule ccorres_rhs_assoc)+ apply (rule ccorres_pre_gets_armKSGlobalPD_ksArchState[unfolded o_def]) apply (rule ccorres_h_t_valid_armKSGlobalPD) apply csymbr apply (rule ccorres_add_return2) apply (ctac(no_vcg) add: setCurrentPD_ccorres) apply (rule ccorres_split_throws) apply (rule ccorres_return_void_C[unfolded dc_def]) apply vcg apply wp apply simp apply (wp hoare_drop_imps)[1] apply (simp add: Collect_const_mem) apply (vcg exspec=findPDForASID_modifies) apply (simp add: getSlotCap_def) apply (wp getCTE_wp') apply (simp add: Collect_const_mem if_1_0_0) apply vcg apply (clarsimp simp: Collect_const_mem word_sle_def) apply (rule conjI) apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def) apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp+) apply (auto simp: isCap_simps valid_cap'_def mask_def)[1] apply (clarsimp simp: ptr_val_tcb_ptr_mask' size_of_def cte_level_bits_def tcbVTableSlot_def tcb_cnode_index_defs ccap_rights_relation_def cap_rights_to_H_def to_bool_def true_def allRights_def mask_def[where n="Suc 0"] cte_at_tcb_at_16' addrFromPPtr_def) apply (clarsimp simp: cap_get_tag_isCap_ArchObject2 dest!: isCapDs) by (clarsimp simp: cap_get_tag_isCap_ArchObject[symmetric] cap_lift_page_directory_cap cap_to_H_def cap_page_directory_cap_lift_def to_bool_def elim!: ccap_relationE split: split_if_asm) (* FIXME: move *) lemma invs'_invs_no_cicd: "invs' s \ all_invs_but_ct_idle_or_in_cur_domain' s" by (clarsimp simp add: invs'_def all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def newKernelState_def) lemma setVMRootForFlush_ccorres: "ccorres (\rv rv'. rv' = from_bool rv) ret__unsigned_long_' (invs' and (\s. asid \ mask asid_bits)) (UNIV \ {s. pd_' s = pde_Ptr pd} \ {s. asid_' s = asid}) [] (setVMRootForFlush pd asid) (Call setVMRootForFlush_'proc)" apply (cinit lift: pd_' asid_') apply (rule ccorres_pre_getCurThread) apply (simp add: getThreadVSpaceRoot_def locateSlot_conv del: Collect_const) apply (rule ccorres_Guard_Seq)+ apply (ctac add: getSlotCap_h_val_ccorres) apply csymbr apply csymbr apply (simp add: cap_get_tag_isCap_ArchObject2 if_1_0_0 del: Collect_const) apply (rule ccorres_if_lhs) apply (rule_tac P="(capPDIsMapped_CL (cap_page_directory_cap_lift threadRoot) = 0) = (capPDMappedASID (capCap rva) = None) \ capPDBasePtr_CL (cap_page_directory_cap_lift threadRoot) = capPDBasePtr (capCap rva)" in ccorres_gen_asm2) apply (rule ccorres_rhs_assoc | csymbr | simp add: Collect_True del: Collect_const)+ apply (rule ccorres_split_throws) apply (rule ccorres_return_C, simp+) apply vcg apply (rule ccorres_rhs_assoc2, rule ccorres_rhs_assoc2, rule ccorres_symb_exec_r) apply simp apply (ctac (no_vcg)add: armv_contextSwitch_ccorres) apply (ctac add: ccorres_return_C) apply wp apply (simp add: true_def from_bool_def) apply vcg apply (rule conseqPre, vcg) apply (simp add: Collect_const_mem) apply clarsimp apply simp apply (wp hoare_drop_imps) apply vcg apply (clarsimp simp: Collect_const_mem if_1_0_0 word_sle_def ccap_rights_relation_def cap_rights_to_H_def mask_def[where n="Suc 0"] true_def to_bool_def allRights_def size_of_def cte_level_bits_def tcbVTableSlot_def Kernel_C.tcbVTable_def invs'_invs_no_cicd) apply (clarsimp simp: rf_sr_ksCurThread ptr_add_assertion_positive) apply (subst rf_sr_tcb_ctes_array_assertion[THEN array_assertion_shrink_right], assumption, simp add: tcb_at_invs', simp add: tcb_cnode_index_defs)+ apply (clarsimp simp: rf_sr_ksCurThread ptr_val_tcb_ptr_mask' [OF tcb_at_invs']) apply (frule cte_at_tcb_at_16'[OF tcb_at_invs'], clarsimp simp: cte_wp_at_ctes_of) apply (rule cmap_relationE1[OF cmap_relation_cte], assumption+) apply (clarsimp simp: false_def true_def from_bool_def typ_heap_simps') apply (case_tac "isArchObjectCap rv \ isPageDirectoryCap (capCap rv)") apply (clarsimp simp: isCap_simps(2) cap_get_tag_isCap_ArchObject[symmetric]) apply (clarsimp simp: cap_page_directory_cap_lift cap_to_H_def elim!: ccap_relationE) apply (simp add: to_bool_def split: split_if) by (auto simp: cap_get_tag_isCap_ArchObject2) (* FIXME: move to StateRelation_C *) definition "framesize_from_H sz \ case sz of ARM.ARMSmallPage \ (scast Kernel_C.ARMSmallPage :: word32) | ARM.ARMLargePage \ scast Kernel_C.ARMLargePage | ARM.ARMSection \ scast Kernel_C.ARMSection | ARM.ARMSuperSection \ scast Kernel_C.ARMSuperSection" lemma framesize_from_to_H: "gen_framesize_to_H (framesize_from_H sz) = sz" by (simp add: gen_framesize_to_H_def framesize_from_H_def Kernel_C.ARMSmallPage_def Kernel_C.ARMLargePage_def Kernel_C.ARMSection_def Kernel_C.ARMSuperSection_def split: split_if vmpage_size.splits) lemma framesize_from_H_mask: "framesize_from_H vmsz && mask 2 = framesize_from_H vmsz" by (simp add: framesize_from_H_def mask_def Kernel_C.ARMSmallPage_def Kernel_C.ARMLargePage_def Kernel_C.ARMSection_def Kernel_C.ARMSuperSection_def split: vmpage_size.splits) (* FIXME: move *) lemma dmo_invalidateCacheRange_RAM_invs'[wp]: "valid invs' (doMachineOp (invalidateCacheRange_RAM vs ve ps)) (\rv. invs')" apply (wp dmo_invs' no_irq no_irq_invalidateCacheRange_RAM) apply (clarsimp simp: disj_commute[of "pointerInUserData p s" for p s]) apply (erule use_valid) apply (wp, simp) done lemma dmo_flushtype_case: "(doMachineOp (case t of ARM_H.flush_type.Clean \ f | ARM_H.flush_type.Invalidate \ g | ARM_H.flush_type.CleanInvalidate \ h | ARM_H.flush_type.Unify \ i)) = (case t of ARM_H.flush_type.Clean \ doMachineOp f | ARM_H.flush_type.Invalidate \ doMachineOp g | ARM_H.flush_type.CleanInvalidate \ doMachineOp h | ARM_H.flush_type.Unify \ doMachineOp i)" by (case_tac "t", simp_all) definition "flushtype_relation typ label \ case typ of ARM_H.flush_type.Clean \ (label = Kernel_C.ARMPageClean_Data \ label = Kernel_C.ARMPDClean_Data) | ARM_H.flush_type.Invalidate \(label = Kernel_C.ARMPageInvalidate_Data \ label = Kernel_C.ARMPDInvalidate_Data) | ARM_H.flush_type.CleanInvalidate \ (label = Kernel_C.ARMPageCleanInvalidate_Data \ label = Kernel_C.ARMPDCleanInvalidate_Data) | ARM_H.flush_type.Unify \ (label = Kernel_C.ARMPageUnify_Instruction \ label = Kernel_C.ARMPDUnify_Instruction)" lemma ccorres_seq_IF_False: "ccorres_underlying sr \ r xf arrel axf G G' hs a (IF False THEN x ELSE y FI ;; c) = ccorres_underlying sr \ r xf arrel axf G G' hs a (y ;; c)" by simp lemma doFlush_ccorres: "ccorres dc xfdc (\s. vs \ ve \ ps \ ps + (ve - vs) \ vs && mask 5 = ps && mask 5 \ unat (ve - vs) \ gsMaxObjectSize s) (\flushtype_relation t \invLabel___int\ \ \\start = vs\ \ \\end = ve\ \ \\pstart = ps\) [] (doMachineOp (doFlush t vs ve ps)) (Call doFlush_'proc)" apply (cinit' lift: pstart_') apply (unfold doMachineOp_bind doFlush_def) apply (rule ccorres_Guard_Seq) apply (rule ccorres_basic_srnoop) apply (simp only: ccorres_seq_IF_False ccorres_seq_skip) apply (rule_tac xf'=invLabel___int_' in ccorres_abstract, ceqv, rename_tac invlabel) apply (rule_tac P="flushtype_relation t invlabel" in ccorres_gen_asm2) apply (rule_tac xf'=start_' in ccorres_abstract, ceqv, rename_tac start') apply (rule_tac P="start' = vs" in ccorres_gen_asm2) apply (rule_tac xf'=end_' in ccorres_abstract, ceqv, rename_tac end') apply (rule_tac P="end' = ve" in ccorres_gen_asm2) apply (simp only: dmo_flushtype_case) apply wpc apply (rule ccorres_cond_true) apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) apply (rule ccorres_cond_false) apply (rule ccorres_cond_true) apply (ctac (no_vcg) add: invalidateCacheRange_RAM_ccorres) apply (rule ccorres_cond_false) apply (rule ccorres_cond_false) apply (rule ccorres_cond_true) apply (ctac (no_vcg) add: cleanInvalidateCacheRange_RAM_ccorres) apply (rule ccorres_cond_false) apply (rule ccorres_cond_false) apply (rule ccorres_cond_false) apply (rule ccorres_cond_true) apply (simp add: empty_fail_cleanCacheRange_PoU empty_fail_dsb empty_fail_invalidateCacheRange_I empty_fail_branchFlushRange empty_fail_isb doMachineOp_bind) apply (rule ccorres_rhs_assoc)+ apply (fold dc_def) apply (ctac (no_vcg) add: cleanCacheRange_PoU_ccorres) apply (ctac (no_vcg) add: dsb_ccorres) apply (ctac (no_vcg) add: invalidateCacheRange_I_ccorres) apply (ctac (no_vcg) add: branchFlushRange_ccorres) apply (ctac (no_vcg) add: isb_ccorres) apply wp apply simp apply (clarsimp simp: Collect_const_mem) apply (auto simp: flushtype_relation_def o_def Kernel_C.ARMPageClean_Data_def Kernel_C.ARMPDClean_Data_def Kernel_C.ARMPageInvalidate_Data_def Kernel_C.ARMPDInvalidate_Data_def Kernel_C.ARMPageCleanInvalidate_Data_def Kernel_C.ARMPDCleanInvalidate_Data_def Kernel_C.ARMPageUnify_Instruction_def Kernel_C.ARMPDUnify_Instruction_def dest: ghost_assertion_size_logic[rotated] split: ARM_H.flush_type.splits) done end context begin interpretation Arch . (*FIXME: arch_split*) crunch gsMaxObjectSize[wp]: setVMRootForFlush "\s. P (gsMaxObjectSize s)" (wp: crunch_wps) end context kernel_m begin lemma performPageFlush_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and K (asid \ mask asid_bits) and (\s. ps \ ps + (ve - vs) \ vs && mask 5 = ps && mask 5 \ unat (ve - vs) \ gsMaxObjectSize s)) (\\pd = Ptr pd\ \ \\asid = asid\ \ \\start = vs\ \ \\end = ve\ \ \\pstart = ps\ \ \flushtype_relation typ \invLabel___int \) [] (liftE (performPageInvocation (PageFlush typ vs ve ps pd asid))) (Call performPageFlush_'proc)" apply (simp only: liftE_liftM ccorres_liftM_simp) apply (cinit lift: pd_' asid_' start_' end_' pstart_' invLabel___int_') apply (unfold when_def) apply (rule ccorres_cond_seq) apply (rule ccorres_cond2[where R=\]) apply (simp split: split_if) apply (rule ccorres_rhs_assoc)+ apply (ctac (no_vcg) add: setVMRootForFlush_ccorres) apply (ctac (no_vcg) add: doFlush_ccorres) apply (rule ccorres_add_return2) apply (rule ccorres_split_nothrow_novcg_dc) apply (rule ccorres_cond2[where R=\]) apply (simp add: from_bool_def split: split_if bool.splits) apply (rule ccorres_pre_getCurThread) apply (ctac add: setVMRoot_ccorres) apply (rule ccorres_return_Skip) apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply wp apply (simp add: guard_is_UNIV_def) apply (simp add: cur_tcb'_def[symmetric]) apply (rule_tac Q="\_ s. invs' s \ cur_tcb' s" in hoare_post_imp) apply (simp add: invs'_invs_no_cicd) apply (wp) apply (simp) apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (clarsimp simp: order_less_imp_le) done lemma length_of_msgRegisters: "length ARM_H.msgRegisters = 4" by (auto simp: ARM_H.msgRegisters_def msgRegisters_unfold) (* FIXME: move *) lemma register_from_H_bound[simp]: "unat (register_from_H v) < 18" by (cases v, simp_all add: "StrictC'_register_defs") (* FIXME: move *) lemma register_from_H_inj: "inj register_from_H" apply (rule inj_onI) apply (case_tac x) by (case_tac y, simp_all add: "StrictC'_register_defs")+ (* FIXME: move *) lemmas register_from_H_eq_iff[simp] = inj_on_eq_iff [OF register_from_H_inj, simplified] lemma setRegister_ccorres: "ccorres dc xfdc \ (UNIV \ \\thread = tcb_ptr_to_ctcb_ptr thread\ \ \\reg = register_from_H reg\ \ {s. w_' s = val}) [] (asUser thread (setRegister reg val)) (Call setRegister_'proc)" apply (cinit' lift: thread_' reg_' w_') apply (simp add: asUser_def dc_def[symmetric] split_def split del: split_if) apply (rule ccorres_pre_threadGet) apply (rule ccorres_Guard) apply (simp add: setRegister_def simpler_modify_def exec_select_f_singleton) apply (rule_tac P="\tcb. tcbContext tcb = rv" in threadSet_ccorres_lemma2 [unfolded dc_def]) apply vcg apply (clarsimp simp: setRegister_def HaskellLib_H.runState_def simpler_modify_def typ_heap_simps) apply (subst StateSpace.state.fold_congs[OF refl refl]) apply (rule globals.fold_congs[OF refl refl]) apply (rule heap_update_field_hrs, simp) apply (fastforce intro: typ_heap_simps) apply simp apply (erule(1) rf_sr_tcb_update_no_queue2, (simp add: typ_heap_simps')+) apply (rule ball_tcb_cte_casesI, simp+) apply (clarsimp simp: ctcb_relation_def ccontext_relation_def split: split_if) apply (clarsimp simp: Collect_const_mem register_from_H_sless register_from_H_less) apply (auto intro: typ_heap_simps elim: obj_at'_weakenE) done lemma wordFromMessageInfo_spec: defines "mil s \ seL4_MessageInfo_lift \<^bsup>s\<^esup>mi" shows "\s. \ \ {s} Call wordFromMessageInfo_'proc \\ret__unsigned_long = (label_CL (mil s) << 12) || (capsUnwrapped_CL (mil s) << 9) || (extraCaps_CL (mil s) << 7) || length_CL (mil s)\" unfolding mil_def apply vcg apply (simp add: seL4_MessageInfo_lift_def mask_shift_simps word_sless_def word_sle_def) apply word_bitwise done lemmas wordFromMessageInfo_spec2 = wordFromMessageInfo_spec lemma wordFromMessageInfo_ccorres [corres]: "\mi. ccorres (op =) ret__unsigned_long_' \ {s. mi = message_info_to_H (mi_' s)} [] (return (wordFromMessageInfo mi)) (Call wordFromMessageInfo_'proc)" apply (rule ccorres_from_spec_modifies [where P = \, simplified]) apply (rule wordFromMessageInfo_spec) apply (rule wordFromMessageInfo_modifies) apply simp apply simp apply (simp add: return_def wordFromMessageInfo_def Let_def message_info_to_H_def Types_H.msgLengthBits_def Types_H.msgExtraCapBits_def Types_H.msgMaxExtraCaps_def shiftL_nat word_bw_assocs word_bw_comms word_bw_lcs) done (* FIXME move *) lemma unat_register_from_H_range: "unat (register_from_H r) < 18" by (case_tac r, simp_all add: C_register_defs) (* FIXME move *) lemma register_from_H_eq: "(r = r') = (register_from_H r = register_from_H r')" apply (case_tac r, simp_all add: C_register_defs) by (case_tac r', simp_all add: C_register_defs)+ lemma setMessageInfo_ccorres: "ccorres dc xfdc (tcb_at' thread) (UNIV \ \mi = message_info_to_H mi'\) hs (setMessageInfo thread mi) (\ret__unsigned_long :== CALL wordFromMessageInfo(mi');; CALL setRegister(tcb_ptr_to_ctcb_ptr thread, scast Kernel_C.msgInfoRegister, \ret__unsigned_long))" unfolding setMessageInfo_def apply (rule ccorres_guard_imp2) apply ctac apply simp apply (ctac add: setRegister_ccorres) apply wp apply vcg apply (simp add: ARM_H.msgInfoRegister_def ARM.msgInfoRegister_def Kernel_C.msgInfoRegister_def Kernel_C.R1_def) done lemma performPageGetAddress_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') \ (UNIV \ {s. vbase_ptr_' s = Ptr ptr}) [] (liftE (performPageInvocation (PageGetAddr ptr))) (Call performPageGetAddress_'proc)" apply (simp only: liftE_liftM ccorres_liftM_simp) apply (cinit lift: vbase_ptr_') apply csymbr apply (rule ccorres_pre_getCurThread) apply (clarsimp simp add: setMRs_def zipWithM_x_mapM_x mapM_x_Nil length_of_msgRegisters zip_singleton msgRegisters_unfold mapM_x_singleton) apply (rule ccorres_Guard_Seq)+ apply (ctac add: setRegister_ccorres) apply csymbr apply (rule ccorres_add_return2) apply (rule ccorres_rhs_assoc2) apply (rule ccorres_split_nothrow_novcg[where r'=dc and xf'=xfdc]) apply (unfold setMessageInfo_def) apply ctac apply (simp only: fun_app_def) apply (ctac add: setRegister_ccorres) apply wp apply vcg apply ceqv apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply wp apply (simp add: guard_is_UNIV_def) apply wp apply vcg by (auto simp: ARM_H.fromPAddr_def message_info_to_H_def mask_def ARM_H.msgInfoRegister_def ARM.msgInfoRegister_def Kernel_C.msgInfoRegister_def Kernel_C.R1_def word_sle_def word_sless_def Kernel_C.R2_def kernel_all_global_addresses.msgRegisters_def fupdate_def Arrays.update_def fcp_beta) lemma performPageDirectoryInvocationFlush_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and K (asid \ mask asid_bits) and (\s. ps \ ps + (ve - vs) \ vs && mask 5 = ps && mask 5 \ unat (ve - vs) \ gsMaxObjectSize s)) (\\pd = Ptr pd\ \ \\asid = asid\ \ \\start = vs\ \ \\end = ve\ \ \\pstart = ps\ \ \flushtype_relation typ \invLabel___int \) [] (liftE (performPageDirectoryInvocation (PageDirectoryFlush typ vs ve ps pd asid))) (Call performPDFlush_'proc)" apply (simp only: liftE_liftM ccorres_liftM_simp) apply (cinit lift: pd_' asid_' start_' end_' pstart_' invLabel___int_') apply (unfold when_def) apply (rule ccorres_cond_seq) apply (rule ccorres_cond2[where R=\]) apply (simp split: split_if) apply (rule ccorres_rhs_assoc)+ apply (ctac (no_vcg) add: setVMRootForFlush_ccorres) apply (ctac (no_vcg) add: doFlush_ccorres) apply (rule ccorres_add_return2) apply (rule ccorres_split_nothrow_novcg_dc) apply (rule ccorres_cond2[where R=\]) apply (simp add: from_bool_def split: split_if bool.splits) apply (rule ccorres_pre_getCurThread) apply (ctac add: setVMRoot_ccorres) apply (rule ccorres_return_Skip) apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply wp apply (simp add: guard_is_UNIV_def) apply (simp add: cur_tcb'_def[symmetric]) apply (rule_tac Q="\_ s. invs' s \ cur_tcb' s" in hoare_post_imp) apply (simp add: invs'_invs_no_cicd) apply (wp) apply (simp) apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (clarsimp simp: order_less_imp_le) done lemma flushPage_ccorres: "ccorres dc xfdc (invs' and (\s. asid \ mask asid_bits \ is_aligned vptr pageBits)) (UNIV \ {s. gen_framesize_to_H (page_size_' s) = sz \ page_size_' s < 4} \ {s. pd_' s = pde_Ptr pd} \ {s. asid_' s = asid} \ {s. vptr_' s = vptr}) [] (flushPage sz pd asid vptr) (Call flushPage_'proc)" apply (cinit lift: page_size_' pd_' asid_' vptr_') apply (rule ccorres_assert) apply (simp del: Collect_const) apply (ctac(no_vcg) add: setVMRootForFlush_ccorres) apply (ctac(no_vcg) add: loadHWASID_ccorres) apply csymbr apply (simp add: when_def del: Collect_const) apply (rule ccorres_cond2[where R=\]) apply (clarsimp simp: pde_stored_asid_def to_bool_def split: split_if) apply (rule ccorres_Guard_Seq ccorres_rhs_assoc)+ apply csymbr apply csymbr apply (ctac(no_vcg) add: invalidateTLB_VAASID_ccorres) apply (rule ccorres_cond2[where R=\]) apply (simp add: from_bool_0 Collect_const_mem) apply (rule ccorres_pre_getCurThread) apply (fold dc_def) apply (ctac add: setVMRoot_ccorres) apply (rule ccorres_return_Skip) apply (wp | simp add: cur_tcb'_def[symmetric])+ apply (rule_tac Q="\_ s. invs' s \ cur_tcb' s" in hoare_post_imp) apply (simp add: invs'_invs_no_cicd) apply (wp | simp add: cur_tcb'_def[symmetric])+ apply (rule ccorres_return_Skip) apply wp apply (simp only: pred_conj_def simp_thms) apply (strengthen invs_valid_pde_mappings') apply (wp hoare_drop_imps setVMRootForFlush_invs') apply (clarsimp simp: Collect_const_mem word_sle_def) apply (rule conjI, clarsimp+) apply (clarsimp simp: pde_stored_asid_def to_bool_def cong: conj_cong ucast_ucast_mask) apply (drule aligned_neg_mask) apply (simp add: pde_pde_invalid_lift_def pde_lift_def mask_def[where n=8] word_bw_assocs mask_def[where n=pageBits]) apply (simp add: pageBits_def mask_eq_iff_w2p word_size) done lemma ignoreFailure_liftM: "ignoreFailure = liftM (\v. ())" apply (rule ext)+ apply (simp add: ignoreFailure_def liftM_def catch_def) apply (rule bind_apply_cong[OF refl]) apply (simp split: sum.split) done lemma ccorres_pre_getObject_pte: assumes cc: "\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c" shows "ccorres r xf (\s. (\pte. ko_at' pte p s \ P pte s)) {s. \pte pte'. cslift s (pte_Ptr p) = Some pte' \ cpte_relation pte pte' \ s \ P' pte} hs (getObject p >>= (\rv. f rv)) c" apply (rule ccorres_guard_imp2) apply (rule ccorres_symb_exec_l) apply (rule ccorres_guard_imp2) apply (rule cc) apply (rule conjI) apply (rule_tac Q="ko_at' rv p s" in conjunct1) apply assumption apply assumption apply (wp getPTE_wp empty_fail_getObject | simp)+ apply clarsimp apply (erule cmap_relationE1 [OF rf_sr_cpte_relation], erule ko_at_projectKO_opt) apply simp done lemmas unfold_checkMapping_return = from_bool_0[where 'a=32, folded exception_defs] to_bool_def end context begin interpretation Arch . (*FIXME: arch_split*) crunch no_0_obj'[wp]: flushPage "no_0_obj'" end context kernel_m begin lemma checkMappingPPtr_pte_ccorres: assumes pre: "\pte \. \ \ {s. True \ (\pte'. cslift s (pte_Ptr pte_ptr) = Some pte' \ cpte_relation pte pte') \ (\, s) \ rf_sr} call1 ;; Cond S return_void_C Skip;; call2;; Cond T return_void_C Skip {s. (\, s) \ rf_sr \ (isSmallPagePTE pte \ pgsz = ARMSmallPage \ isLargePagePTE pte \ pgsz = ARMLargePage) \ pteFrame pte = addrFromPPtr pptr}, {s. (\, s) \ rf_sr \ \ ((isSmallPagePTE pte \ pgsz = ARMSmallPage \ isLargePagePTE pte \ pgsz = ARMLargePage) \ pteFrame pte = addrFromPPtr pptr)}" shows "ccorres_underlying rf_sr \ (inr_rrel dc) xfdc (inl_rrel dc) xfdc \ UNIV [SKIP] (checkMappingPPtr pptr pgsz (Inl pte_ptr)) (call1;; Cond S return_void_C Skip;; call2;; Cond T return_void_C Skip)" apply (simp add: checkMappingPPtr_def liftE_bindE) apply (rule ccorres_symb_exec_l[where Q'="\_. UNIV", OF _ _ getObject_ko_at, simplified]) apply (rule stronger_ccorres_guard_imp) apply (rule ccorres_from_vcg_might_throw[where P=\]) apply (rule allI) apply (rule conseqPost, rule conseqPre, rule_tac \1=\ and pte1=rv in pre) apply clarsimp apply (erule CollectE, assumption) apply (fold_subgoals (prefix))[2] subgoal by (auto simp: in_monad Bex_def isSmallPagePTE_def isLargePagePTE_def split: pte.split vmpage_size.split) apply (wp empty_fail_getObject | simp)+ apply (erule cmap_relationE1[OF rf_sr_cpte_relation]) apply (erule ko_at_projectKO_opt) apply simp apply (wp empty_fail_getObject | simp add: objBits_simps archObjSize_def)+ done lemma checkMappingPPtr_pde_ccorres: assumes pre: "\pde \. \ \ {s. True \ (\pde'. cslift s (pde_Ptr pde_ptr) = Some pde' \ cpde_relation pde pde') \ (\, s) \ rf_sr} call1;; Cond S return_void_C Skip;; call2;; Cond T return_void_C Skip;; call3;; Cond U return_void_C Skip {s. (\, s) \ rf_sr \ (isSectionPDE pde \ pgsz = ARMSection \ isSuperSectionPDE pde \ pgsz = ARMSuperSection) \ pdeFrame pde = addrFromPPtr pptr}, {s. (\, s) \ rf_sr \ \ ((isSectionPDE pde \ pgsz = ARMSection \ isSuperSectionPDE pde \ pgsz = ARMSuperSection) \ pdeFrame pde = addrFromPPtr pptr)}" shows "ccorres_underlying rf_sr \ (inr_rrel dc) xfdc (inl_rrel dc) xfdc \ UNIV [SKIP] (checkMappingPPtr pptr pgsz (Inr pde_ptr)) (call1;; Cond S return_void_C Skip;; call2;; Cond T return_void_C Skip;; call3;; Cond U return_void_C Skip)" apply (simp add: checkMappingPPtr_def liftE_bindE) apply (rule ccorres_symb_exec_l[where Q'="\_. UNIV", OF _ _ getObject_ko_at, simplified]) apply (rule stronger_ccorres_guard_imp) apply (rule ccorres_from_vcg_might_throw[where P=\]) apply (rule allI) apply (rule conseqPost, rule conseqPre, rule_tac \1=\ and pde1=rv in pre) apply clarsimp apply (erule CollectE, assumption) apply (fold_subgoals (prefix))[2] subgoal by (auto simp: in_monad Bex_def isSectionPDE_def isSuperSectionPDE_def split: pde.split vmpage_size.split) apply (wp empty_fail_getObject | simp)+ apply (erule cmap_relationE1[OF rf_sr_cpde_relation]) apply (erule ko_at_projectKO_opt) apply simp apply (wp empty_fail_getObject | simp add: objBits_simps archObjSize_def)+ done lemma ccorres_return_void_C': "ccorres_underlying rf_sr \ (inr_rrel dc) xfdc (inl_rrel dc) xfdc (\_. True) UNIV (SKIP # hs) (return (Inl rv)) return_void_C" apply (rule ccorres_from_vcg_throws) apply (simp add: return_def) apply (rule allI, rule conseqPre, vcg) apply auto done lemma is_aligned_cache_preconds: "\is_aligned rva n; n \ 6\ \ rva \ rva + 0x3F \ addrFromPPtr rva \ addrFromPPtr rva + 0x3F \ rva && mask 5 = addrFromPPtr rva && mask 5" apply (drule is_aligned_weaken, simp) apply (rule conjI) apply (drule is_aligned_no_overflow, simp, unat_arith)[1] apply (rule conjI) apply (drule is_aligned_addrFromPPtr_n, simp) apply (drule is_aligned_no_overflow, unat_arith) apply (frule is_aligned_addrFromPPtr_n, simp) apply (drule_tac x=6 and y=5 in is_aligned_weaken, simp)+ apply (simp add: is_aligned_mask) done lemma pte_pte_invalid_new_spec: "\s. \ \ {s} \ret__struct_pte_C :== PROC pte_pte_invalid_new() \ pte_lift \ret__struct_pte_C = Some (Pte_pte_large \ pte_pte_large_CL.address_CL = 0, XN_CL = 0, TEX_CL = 0, nG_CL = 0, S_CL = 0, APX_CL = 0, AP_CL = 0, C_CL = 0, B_CL = 0, reserved_CL = 0 \)\" apply vcg apply (clarsimp simp: pte_lift_def pte_get_tag_def pte_pte_large_def fupdate_def) done lemma ccorres_name_pre_C: "(\s. s \ P' \ ccorres_underlying sr \ r xf arrel axf P {s} hs f g) \ ccorres_underlying sr \ r xf arrel axf P P' hs f g" apply (rule ccorres_guard_imp) apply (rule_tac xf'=id in ccorres_abstract, rule ceqv_refl) apply (rule_tac P="rv' \ P'" in ccorres_gen_asm2) apply assumption apply simp apply simp done lemma ccorres_flip_Guard: assumes cc: "ccorres_underlying sr \ r xf arrel axf A C hs a (Guard F S (Guard F1 S1 c))" shows "ccorres_underlying sr \ r xf arrel axf A C hs a (Guard F1 S1 (Guard F S c))" apply (rule ccorres_name_pre_C) using cc apply (case_tac "s \ (S1 \ S)") apply (clarsimp simp: ccorres_underlying_def) apply (erule exec_handlers.cases; fastforce elim!: exec_Normal_elim_cases intro: exec_handlers.intros exec.Guard) apply (clarsimp simp: ccorres_underlying_def) apply (case_tac "s \ S") apply (fastforce intro: exec.Guard exec.GuardFault exec_handlers.intros) apply (fastforce intro: exec.Guard exec.GuardFault exec_handlers.intros) done lemma ccorres_second_Guard: assumes cc: "ccorres_underlying sr \ r xf arrel axf A C' hs a (Guard F1 S1 c)" shows "ccorres_underlying sr \ r xf arrel axf A (C' \ S) hs a (Guard F1 S1 (Guard F S c))" apply (rule ccorres_flip_Guard) apply (rule ccorres_Guard) apply (rule cc) done lemma multiple_add_less_nat: "a < (c :: nat) \ x dvd a \ x dvd c \ b < x \ a + b < c" apply (subgoal_tac "b < c - a") apply simp apply (erule order_less_le_trans) apply (rule dvd_imp_le) apply simp apply simp done lemma large_ptSlot_array_constraint: "is_aligned (ptSlot :: word32) 6 \ n \ limit - 240 \ 240 \ limit \ \i. ptSlot = (ptSlot && ~~ mask ptBits) + of_nat i * 4 \ i + n \ limit" apply (rule_tac x="unat ((ptSlot && mask ptBits) >> 2)" in exI) apply (simp add: shiftl_t2n[where n=2, symmetric, THEN trans[rotated], OF mult.commute, simplified]) apply (simp add: shiftr_shiftl1) apply (rule conjI, rule trans, rule word_plus_and_or_coroll2[symmetric, where w="mask ptBits"]) apply (simp, rule aligned_neg_mask[THEN sym], rule is_aligned_andI1, erule is_aligned_weaken, simp) apply (clarsimp simp add: le_diff_conv2) apply (erule order_trans[rotated], simp) apply (rule unat_le_helper) apply (simp add: is_aligned_mask mask_def ptBits_def pageBits_def) apply (word_bitwise, simp?) done lemma large_pdSlot_array_constraint: "is_aligned pd pdBits \ vmsz_aligned vptr ARMSuperSection \ n \ limit - 4080 \ 4080 \ limit \ \i. lookup_pd_slot pd vptr = pd + of_nat i * 4 \ i + n \ limit" apply (rule_tac x="unat (vptr >> 20)" in exI) apply (rule conjI) apply (simp add: lookup_pd_slot_def shiftl_t2n) apply (clarsimp simp add: le_diff_conv2) apply (erule order_trans[rotated], simp) apply (rule unat_le_helper) apply (simp add: is_aligned_mask mask_def pdBits_def pageBits_def vmsz_aligned_def) apply (word_bitwise, simp?) done lemma findPDForASID_page_directory_at'_simple[wp]: notes checkPDAt_inv[wp del] shows "\\\ findPDForASID asiv \\rv s. page_directory_at' rv s\,-" apply (simp add:findPDForASID_def) apply (wp getASID_wp|simp add:checkPDAt_def | wpc)+ apply auto done lemma array_assertion_abs_pte_16: "\s s'. (s, s') \ rf_sr \ (page_table_at' (ptr_val ptPtr && ~~ mask ptBits) s \ is_aligned (ptr_val ptPtr) 6) \ (n s' \ 16 \ (x s' \ 0 \ n s' \ 0)) \ (x s' = 0 \ array_assertion (ptPtr :: pte_C ptr) (n s') (hrs_htd (t_hrs_' (globals s'))))" apply (intro allI impI disjCI2, clarsimp) apply (drule(1) page_table_at_rf_sr, clarsimp) apply (cases ptPtr, simp) apply (erule clift_array_assertion_imp, simp_all) apply (rule large_ptSlot_array_constraint, simp_all) done lemmas ccorres_move_array_assertion_pte_16 = ccorres_move_array_assertions [OF array_assertion_abs_pte_16] lemma array_assertion_abs_pde_16: "\s s'. (s, s') \ rf_sr \ (page_directory_at' pd s \ vmsz_aligned vptr ARMSuperSection) \ (n s' \ 16 \ (x s' \ 0 \ n s' \ 0)) \ (x s' = 0 \ array_assertion (pde_Ptr (lookup_pd_slot pd vptr)) (n s') (hrs_htd (t_hrs_' (globals s'))))" apply (intro allI impI disjCI2, clarsimp) apply (frule(1) page_directory_at_rf_sr, clarsimp) apply (erule clift_array_assertion_imp, simp_all) apply (rule large_pdSlot_array_constraint, simp_all add: page_directory_at'_def) done lemmas array_assertion_abs_pde_16_const = array_assertion_abs_pde_16[where x="\_. Suc 0", simplified nat.simps simp_thms] lemmas ccorres_move_array_assertion_pde_16 = ccorres_move_Guard_Seq [OF array_assertion_abs_pde_16] ccorres_move_Guard [OF array_assertion_abs_pde_16] ccorres_move_Guard_Seq [OF array_assertion_abs_pde_16] ccorres_move_Guard [OF array_assertion_abs_pde_16] ccorres_move_Guard_Seq [OF array_assertion_abs_pde_16_const] ccorres_move_Guard [OF array_assertion_abs_pde_16_const] ccorres_move_Guard_Seq [OF array_assertion_abs_pde_16_const] ccorres_move_Guard [OF array_assertion_abs_pde_16_const] lemma unmapPage_ccorres: "ccorres dc xfdc (invs' and (\s. 2 ^ pageBitsForSize sz \ gsMaxObjectSize s) and (\_. asid \ mask asid_bits \ vmsz_aligned' vptr sz \ vptr < kernelBase)) (UNIV \ {s. gen_framesize_to_H (page_size_' s) = sz \ page_size_' s < 4} \ {s. asid_' s = asid} \ {s. vptr_' s = vptr} \ {s. pptr_' s = Ptr pptr}) [] (unmapPage sz asid vptr pptr) (Call unmapPage_'proc)" apply (rule ccorres_gen_asm) apply (cinit lift: page_size_' asid_' vptr_' pptr_') apply (simp add: ignoreFailure_liftM ptr_add_assertion_positive Collect_True del: Collect_const) apply ccorres_remove_UNIV_guard apply csymbr apply (ctac add: findPDForASID_ccorres) apply (rename_tac pdPtr pd') apply (rule_tac P="page_directory_at' pdPtr" in ccorres_cross_over_guard) apply (simp add: liftE_bindE Collect_False bind_bindE_assoc del: Collect_const) apply (rule ccorres_splitE_novcg[where r'=dc and xf'=xfdc]) -- "ARMSmallPage" apply (rule ccorres_Cond_rhs) apply (simp add: gen_framesize_to_H_def dc_def[symmetric]) apply (rule ccorres_rhs_assoc)+ apply csymbr apply (ctac add: lookupPTSlot_ccorres) apply (rename_tac pt_slot pt_slot') apply (simp add: dc_def[symmetric]) apply (rule ccorres_rhs_assoc2, rule ccorres_rhs_assoc2, rule ccorres_rhs_assoc2) apply (rule ccorres_splitE_novcg) apply (simp only: inl_rrel_inl_rrel) apply (rule checkMappingPPtr_pte_ccorres) apply (rule conseqPre, vcg) apply (clarsimp simp: typ_heap_simps') apply (simp add: cpte_relation_def Let_def pte_lift_def isSmallPagePTE_def pte_tag_defs pte_pte_small_lift_def pte_pte_invalid_def split: split_if_asm pte.split_asm) apply (rule ceqv_refl) apply (simp add: unfold_checkMapping_return liftE_liftM Collect_const[symmetric] dc_def[symmetric] del: Collect_const) apply (rule ccorres_handlers_weaken2) apply csymbr apply (rule ccorres_split_nothrow_novcg_dc) apply (rule storePTE_Basic_ccorres) apply (simp add: cpte_relation_def Let_def) apply csymbr apply simp apply (ctac add: cleanByVA_PoU_ccorres[unfolded dc_def]) apply wp apply (simp add: guard_is_UNIV_def) apply wp apply (simp add: ccHoarePost_def guard_is_UNIV_def) apply (simp add: throwError_def) apply (rule ccorres_split_throws) apply (rule ccorres_return_void_C') apply vcg apply (wp) apply simp apply (vcg exspec=lookupPTSlot_modifies) -- "ARMLargePage" apply (rule ccorres_Cond_rhs) apply (simp add: gen_framesize_to_H_def dc_def[symmetric]) apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply (ctac add: lookupPTSlot_ccorres) apply (rename_tac ptSlot lookupPTSlot_ret) apply (simp add: Collect_False dc_def[symmetric] del: Collect_const) apply (rule ccorres_rhs_assoc2, rule ccorres_rhs_assoc2, rule ccorres_rhs_assoc2) apply (rule ccorres_splitE_novcg, simp only: inl_rrel_inl_rrel, rule checkMappingPPtr_pte_ccorres) apply (rule conseqPre, vcg) apply (clarsimp simp: typ_heap_simps') subgoal by (simp add: cpte_relation_def Let_def pte_lift_def isLargePagePTE_def pte_tag_defs pte_pte_large_lift_def pte_pte_invalid_def split: split_if_asm pte.split_asm) apply (rule ceqv_refl) apply (simp add: liftE_liftM dc_def[symmetric] mapM_discarded whileAnno_def ARMLargePageBits_def ARMSmallPageBits_def Collect_False unfold_checkMapping_return word_sle_def del: Collect_const) apply (ccorres_remove_UNIV_guard) apply (rule ccorres_rhs_assoc2) apply (rule ccorres_split_nothrow_novcg) apply (rule_tac P="is_aligned ptSlot 6" in ccorres_gen_asm) apply (rule_tac F="\_. page_table_at' (ptSlot && ~~ mask ptBits)" in ccorres_mapM_x_while) apply clarsimp apply (rule ccorres_guard_imp2) apply csymbr apply (rule ccorres_move_array_assertion_pte_16) apply (rule ccorres_flip_Guard, rule ccorres_move_array_assertion_pte_16) apply (rule storePTE_Basic_ccorres) apply (simp add: cpte_relation_def Let_def) apply clarsimp apply (simp add: unat_of_nat upto_enum_word of_nat_gt_0 upto_enum_step_def del: upt.simps) apply (simp add: upto_enum_step_def) apply (rule allI, rule conseqPre, vcg) apply clarsimp apply wp apply (simp add: upto_enum_step_def word_bits_def) apply ceqv apply (rule ccorres_handlers_weaken2) apply (rule ccorres_move_c_guard_pte) apply csymbr apply (rule ccorres_move_c_guard_pte ccorres_move_array_assertion_pte_16)+ apply (rule ccorres_add_return2, ctac(no_vcg) add: cleanCacheRange_PoU_ccorres[unfolded dc_def]) apply (rule ccorres_move_array_assertion_pte_16, rule ccorres_return_Skip') apply wp apply (rule_tac P="is_aligned ptSlot 6" in hoare_gen_asm) apply (rule hoare_strengthen_post) apply (rule hoare_vcg_conj_lift) apply (rule_tac P="\s. page_table_at' (ptSlot && ~~ mask ptBits) s \ 2 ^ pageBitsForSize sz \ gsMaxObjectSize s" in mapM_x_wp') apply wp[1] apply (rule mapM_x_accumulate_checks) apply (simp add: storePTE_def) apply (rule obj_at_setObject3) apply simp apply (simp add: objBits_simps archObjSize_def) apply (simp add: typ_at_to_obj_at_arches[symmetric]) apply wp apply clarify apply (subgoal_tac "P" for P) apply (frule bspec, erule hd_in_set) apply (frule bspec, erule last_in_set) subgoal by (simp add: upto_enum_step_def upto_enum_word hd_map last_map typ_at_to_obj_at_arches field_simps objBits_simps archObjSize_def, clarsimp dest!: is_aligned_cache_preconds) apply (simp add: upto_enum_step_def upto_enum_word) apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem) apply (simp add: hd_map last_map upto_enum_step_def objBits_simps archObjSize_def upto_enum_word) apply wp apply (simp add: guard_is_UNIV_def) apply (simp add: throwError_def) apply (rule ccorres_split_throws) apply (rule ccorres_return_void_C') apply vcg apply (wp lookupPTSlot_inv Arch_R.lookupPTSlot_aligned lookupPTSlot_page_table_at' | simp add: K_def)+ apply (vcg exspec=lookupPTSlot_modifies) -- "ARMSection" apply (rule ccorres_Cond_rhs) apply (rule ccorres_rhs_assoc)+ apply (csymbr, csymbr) apply (simp add: gen_framesize_to_H_def dc_def[symmetric] liftE_liftM del: Collect_const) apply (simp split: split_if, rule conjI[rotated], rule impI, rule ccorres_empty, rule impI) apply (rule ccorres_rhs_assoc2, rule ccorres_rhs_assoc2, rule ccorres_rhs_assoc2, rule ccorres_rhs_assoc2, rule ccorres_rhs_assoc2) apply (rule ccorres_splitE_novcg, simp only: inl_rrel_inl_rrel, rule checkMappingPPtr_pde_ccorres) apply (rule conseqPre, vcg) apply (clarsimp simp: typ_heap_simps') subgoal by (simp add: pde_pde_section_lift_def cpde_relation_def pde_lift_def Let_def pde_tag_defs isSectionPDE_def split: pde.split_asm split_if_asm) apply (rule ceqv_refl) apply (simp add: unfold_checkMapping_return Collect_False dc_def[symmetric] del: Collect_const) apply (rule ccorres_handlers_weaken2, simp) apply csymbr apply (rule ccorres_split_nothrow_novcg_dc) apply (rule storePDE_Basic_ccorres) apply (simp add: cpde_relation_def Let_def pde_lift_pde_invalid) apply csymbr apply (ctac add: cleanByVA_PoU_ccorres[unfolded dc_def]) apply wp apply (clarsimp simp: guard_is_UNIV_def) apply simp apply wp apply (simp add: guard_is_UNIV_def) -- "ARMSuperSection" apply (rule ccorres_Cond_rhs) apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply csymbr apply (case_tac "pd = pde_Ptr (lookup_pd_slot pdPtr vptr)") prefer 2 apply (simp, rule ccorres_empty) apply (simp add: gen_framesize_to_H_def dc_def[symmetric] liftE_liftM mapM_discarded whileAnno_def del: Collect_const) apply (rule ccorres_rhs_assoc2, rule ccorres_rhs_assoc2, rule ccorres_rhs_assoc2, rule ccorres_rhs_assoc2, rule ccorres_rhs_assoc2) apply (rule ccorres_splitE_novcg, simp only: inl_rrel_inl_rrel, rule checkMappingPPtr_pde_ccorres) apply (rule conseqPre, vcg) apply (clarsimp simp: typ_heap_simps') subgoal by (simp add: cpde_relation_def Let_def pde_lift_def isSuperSectionPDE_def pde_tag_defs pde_pde_section_lift_def split: split_if_asm pde.split_asm) apply (rule ceqv_refl) apply (simp add: unfold_checkMapping_return Collect_False ARMSuperSectionBits_def ARMSectionBits_def word_sle_def del: Collect_const) apply (ccorres_remove_UNIV_guard) apply (rule ccorres_rhs_assoc2, rule ccorres_split_nothrow_novcg) apply (rule_tac P="is_aligned pdPtr pdBits" in ccorres_gen_asm) apply (rule_tac F="\_. page_directory_at' pdPtr" in ccorres_mapM_x_while) apply clarsimp apply (rule ccorres_guard_imp2) apply csymbr apply (rule ccorres_move_array_assertion_pde_16) apply (rule ccorres_flip_Guard, rule ccorres_move_array_assertion_pde_16) apply (rule storePDE_Basic_ccorres) apply (simp add: cpde_relation_def Let_def pde_lift_pde_invalid) apply clarsimp apply (simp add: unat_of_nat of_nat_gt_0 upto_enum_step_def upto_enum_word) apply (simp add: vmsz_aligned'_def vmsz_aligned_def) apply (clarsimp simp: lookup_pd_slot_def Let_def mask_add_aligned field_simps) apply (erule less_kernelBase_valid_pde_offset') apply (simp add: vmsz_aligned'_def) apply (simp add: word_le_nat_alt unat_of_nat) apply (simp add: upto_enum_step_def) apply (rule allI, rule conseqPre, vcg) apply clarsimp apply wp apply (simp add: upto_enum_step_def word_bits_def) apply ceqv apply (rule ccorres_handlers_weaken2) apply (rule ccorres_move_c_guard_pde) apply csymbr apply (rule ccorres_move_c_guard_pde ccorres_move_array_assertion_pde_16)+ apply (rule ccorres_add_return2) apply (ctac(no_vcg) add: cleanCacheRange_PoU_ccorres[unfolded dc_def]) apply (rule ccorres_move_array_assertion_pde_16, rule ccorres_return_Skip') apply wp apply (rule_tac P="is_aligned pdPtr pdBits" in hoare_gen_asm) apply (rule hoare_strengthen_post) apply (rule hoare_vcg_conj_lift) apply (rule_tac P="\s. page_directory_at' pdPtr s \ 2 ^ pageBitsForSize sz \ gsMaxObjectSize s" in mapM_x_wp') apply wp[1] apply (rule mapM_x_accumulate_checks) apply (simp add: storePDE_def) apply (rule obj_at_setObject3) apply simp apply (simp add: objBits_simps archObjSize_def) apply (simp add: typ_at_to_obj_at_arches[symmetric]) apply wp apply (clarsimp simp: vmsz_aligned_def vmsz_aligned'_def) apply (subgoal_tac "P" for P) apply (frule bspec, erule hd_in_set) apply (frule bspec, erule last_in_set) apply (simp add: upto_enum_step_def upto_enum_word hd_map last_map typ_at_to_obj_at_arches field_simps objBits_simps archObjSize_def vmsz_aligned'_def pageBitsForSize_def pdBits_def pageBits_def) apply (frule_tac x=14 and y=6 in is_aligned_weaken, clarsimp+) apply (drule is_aligned_lookup_pd_slot, simp) apply (clarsimp dest!: is_aligned_cache_preconds) apply (simp add: upto_enum_step_def upto_enum_word) apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem objBits_simps archObjSize_def) apply (simp add: upto_enum_step_def upto_enum_word hd_map last_map) apply (simp, wp) apply (simp add: guard_is_UNIV_def) apply (rule ccorres_empty[where P=\]) apply ceqv apply (simp add: liftE_liftM) apply (ctac add: flushPage_ccorres[unfolded dc_def]) apply ((wp lookupPTSlot_inv mapM_storePTE_invs[unfolded swp_def] mapM_storePDE_invs[unfolded swp_def] | wpc | simp)+)[1] apply (simp add: guard_is_UNIV_def) apply (simp add: throwError_def) apply (rule ccorres_split_throws) apply (rule ccorres_return_void_C[unfolded dc_def]) apply vcg apply (simp add: lookup_pd_slot_def Let_def) apply (wp hoare_vcg_const_imp_lift_R) apply (simp add: Collect_const_mem) apply (vcg exspec=findPDForASID_modifies) apply (clarsimp simp: invs_arch_state' invs_no_0_obj' invs_valid_objs' is_aligned_weaken[OF _ pbfs_atleast_pageBits] vmsz_aligned'_def) by (auto simp: invs_arch_state' invs_no_0_obj' invs_valid_objs' vmsz_aligned'_def is_aligned_weaken[OF _ pbfs_atleast_pageBits] pageBitsForSize_def gen_framesize_to_H_def Collect_const_mem vm_page_size_defs word_sle_def ccHoarePost_def typ_heap_simps pageBits_def dest!: page_directory_at_rf_sr elim!: clift_array_assertion_imp split: vmpage_size.splits | unat_arith)+ (* FIXME: move *) lemma cap_to_H_PageCap_tag: "\ cap_to_H cap = ArchObjectCap (PageCap d p R sz A); cap_lift C_cap = Some cap \ \ cap_get_tag C_cap = scast cap_frame_cap \ cap_get_tag C_cap = scast cap_small_frame_cap" apply (clarsimp simp: cap_to_H_def Let_def split: cap_CL.splits split_if_asm) by (simp_all add: Let_def cap_lift_def split_def split: if_splits) lemma generic_frame_mapped_address: "\ cap_to_H a = capability.ArchObjectCap (arch_capability.PageCap d v0 v1 v2 v3); cap_lift (cte_C.cap_C cte') = Some a; cl_valid_cte \cap_CL = a, cteMDBNode_CL = mdb_node_lift (cteMDBNode_C cte')\; generic_frame_cap_set_capFMappedAddress_CL (Some a) (scast asidInvalid) 0 = Some cap'; cap_lift (cte_C.cap_C cte'a) = Some cap'\ \ ArchObjectCap (PageCap d v0 v1 v2 None) = cap_to_H cap' \ c_valid_cap (cte_C.cap_C cte'a)" apply (cases cte') apply (cases cte'a) apply (clarsimp simp: cl_valid_cte_def) apply (frule (1) cap_to_H_PageCap_tag) apply (erule disjE) apply (simp add: cap_frame_cap_lift) apply (simp add: generic_frame_cap_set_capFMappedAddress_CL_def) apply (clarsimp simp: cap_to_H_def) apply (simp add: asidInvalid_def split: split_if) apply (simp add: c_valid_cap_def cl_valid_cap_def) apply (simp add: cap_small_frame_cap_lift) apply (simp add: generic_frame_cap_set_capFMappedAddress_CL_def) apply (clarsimp simp: cap_to_H_def) apply (simp add: asidInvalid_def split: split_if) apply (simp add: c_valid_cap_def cl_valid_cap_def) done lemma updateCap_frame_mapped_addr_ccorres: notes option.case_cong_weak [cong] shows "ccorres dc xfdc (cte_wp_at' (\c. ArchObjectCap cap = cteCap c) ctSlot and K (isPageCap cap)) UNIV [] (updateCap ctSlot (ArchObjectCap (capVPMappedAddress_update empty cap))) (CALL generic_frame_cap_ptr_set_capFMappedAddress(cap_Ptr &(cte_Ptr ctSlot\[''cap_C'']),(scast asidInvalid),0))" unfolding updateCap_def apply (rule ccorres_guard_imp2) apply (rule ccorres_pre_getCTE) apply (rule_tac P = "\s. ctes_of s ctSlot = Some cte \ cteCap cte = ArchObjectCap cap \ isPageCap cap" and P' = "UNIV" in ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply clarsimp apply (erule (1) rf_sr_ctes_of_cliftE) apply (frule cap_CL_lift) apply (clarsimp simp: typ_heap_simps) apply (rule conjI) apply (clarsimp simp: isCap_simps) apply (drule cap_CL_lift) apply (drule (1) cap_to_H_PageCap_tag) apply simp apply (clarsimp simp: isCap_simps) apply (rule exI) apply (rule conjI, rule refl) apply clarsimp apply (rule fst_setCTE [OF ctes_of_cte_at], assumption) apply (erule bexI [rotated]) apply clarsimp apply (frule (1) rf_sr_ctes_of_clift) apply clarsimp apply (subgoal_tac "ccte_relation (cteCap_update (\_. ArchObjectCap (PageCap d v0 v1 v2 None)) (cte_to_H ctel')) cte'a") prefer 2 apply (clarsimp simp: ccte_relation_def) apply (clarsimp simp: cte_lift_def) apply (simp split: option.splits) apply clarsimp apply (simp add: cte_to_H_def c_valid_cte_def) apply (erule (4) generic_frame_mapped_address) apply (clarsimp simp add: rf_sr_def cstate_relation_def typ_heap_simps Let_def cpspace_relation_def) apply (rule conjI) apply (erule (3) cmap_relation_updI) subgoal by simp apply (erule_tac t = s' in ssubst) apply (simp add: heap_to_user_data_def) apply (rule conjI) apply (erule (1) setCTE_tcb_case) subgoal by (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps h_t_valid_clift_Some_iff cvariable_array_map_const_add_map_option[where f="tcb_no_ctes_proj"]) apply (clarsimp simp: cte_wp_at_ctes_of) done (* FIXME: move *) lemma diminished_PageCap: "diminished' (ArchObjectCap (PageCap d p R sz a)) cap \ \R'. cap = ArchObjectCap (PageCap d p R' sz a)" apply (clarsimp simp: diminished'_def) apply (clarsimp simp: maskCapRights_def Let_def) apply (cases cap, simp_all add: isCap_simps) apply (simp add: ARM_H.maskCapRights_def) apply (simp add: isPageCap_def split: arch_capability.splits) done (* FIXME: move *) lemma aligend_mask_disjoint: "\is_aligned (a :: word32) n; b \ mask n; n < word_bits\ \ a && b = 0" apply (rule word_eqI) apply (clarsimp simp: is_aligned_nth word_size mask_def simp del: word_less_sub_le) apply (drule le2p_bits_unset_32[OF word_less_sub_1]) apply (case_tac "na < n") apply simp apply (simp add: linorder_not_less word_bits_def) done (* FIXME: move *) lemma word_aligend_0_sum: "\ a + b = 0; is_aligned (a :: word32) n; b \ mask n; n < word_bits \ \ a = 0 \ b = 0" by (simp add: word_plus_and_or_coroll aligend_mask_disjoint word_or_zero) (* FIXME: move *) lemma ccap_relation_mapped_asid_0: "ccap_relation (ArchObjectCap (PageCap d v0 v1 v2 v3)) cap \ (generic_frame_cap_get_capFMappedASID_CL (cap_lift cap) \ 0 \ v3 \ None) \ (generic_frame_cap_get_capFMappedASID_CL (cap_lift cap) = 0 \ v3 = None)" apply (erule ccap_relationE) apply (drule sym, frule (1) cap_to_H_PageCap_tag) apply (rule conjI) apply (rule impI) apply (rule notI, erule notE) apply clarsimp apply (erule disjE) apply (clarsimp simp: cap_lift_frame_cap cap_to_H_def generic_frame_cap_get_capFMappedASID_CL_def split: split_if_asm) apply (clarsimp simp: cap_lift_small_frame_cap cap_to_H_def generic_frame_cap_get_capFMappedASID_CL_def split: split_if_asm) apply clarsimp apply (erule disjE) apply (rule ccontr) apply clarsimp apply (clarsimp simp: cap_lift_frame_cap cap_to_H_def generic_frame_cap_get_capFMappedASID_CL_def split: split_if_asm) apply (drule word_aligend_0_sum [where n=asid_low_bits]) apply fastforce apply (simp add: mask_def asid_low_bits_def word_and_le1) apply (simp add: asid_low_bits_def word_bits_def) apply clarsimp apply (drule word_shift_zero [where m=8]) apply (rule order_trans) apply (rule word_and_le1) apply simp apply (simp add: asid_low_bits_def word_bits_def) apply simp apply (rule ccontr) apply clarsimp apply (clarsimp simp: cap_lift_small_frame_cap cap_to_H_def generic_frame_cap_get_capFMappedASID_CL_def split: split_if_asm) apply (drule word_aligend_0_sum [where n=asid_low_bits]) apply fastforce apply (simp add: mask_def asid_low_bits_def word_and_le1) apply (simp add: asid_low_bits_def word_bits_def) apply clarsimp apply (drule word_shift_zero [where m=8]) apply (rule order_trans) apply (rule word_and_le1) apply simp apply (simp add: asid_low_bits_def word_bits_def) apply simp done (* FIXME: move *) lemma getSlotCap_wp': "\\s. \cap. cte_wp_at' (\c. cteCap c = cap) p s \ Q cap s\ getSlotCap p \Q\" apply (simp add: getSlotCap_def) apply (wp getCTE_wp') apply (clarsimp simp: cte_wp_at_ctes_of) done lemma vmsz_aligned_aligned_pageBits: "vmsz_aligned' ptr sz \ is_aligned ptr pageBits" apply (simp add: vmsz_aligned'_def) apply (erule is_aligned_weaken) apply (simp add: pageBits_def pageBitsForSize_def split: vmpage_size.split) done lemma ccap_relation_PageCap_generics: "ccap_relation (ArchObjectCap (PageCap d ptr rghts sz mapdata)) cap' \ (mapdata \ None \ generic_frame_cap_get_capFMappedAddress_CL (cap_lift cap') = snd (the mapdata) \ generic_frame_cap_get_capFMappedASID_CL (cap_lift cap') = fst (the mapdata)) \ ((generic_frame_cap_get_capFMappedASID_CL (cap_lift cap') = 0) = (mapdata = None)) \ vmrights_to_H (generic_frame_cap_get_capFVMRights_CL (cap_lift cap')) = rghts \ gen_framesize_to_H (generic_frame_cap_get_capFSize_CL (cap_lift cap')) = sz \ generic_frame_cap_get_capFBasePtr_CL (cap_lift cap') = ptr \ generic_frame_cap_get_capFVMRights_CL (cap_lift cap') < 4 \ generic_frame_cap_get_capFSize_CL (cap_lift cap') < 4 \ to_bool (generic_frame_cap_get_capFIsDevice_CL (cap_lift cap')) = d" apply (frule ccap_relation_mapped_asid_0) apply (case_tac "sz = ARMSmallPage") apply (frule(1) cap_get_tag_isCap_unfolded_H_cap) apply (clarsimp simp: cap_lift_small_frame_cap cap_to_H_def generic_frame_cap_get_capFMappedAddress_CL_def generic_frame_cap_get_capFVMRights_CL_def generic_frame_cap_get_capFSize_CL_def generic_frame_cap_get_capFMappedASID_CL_def generic_frame_cap_get_capFBasePtr_CL_def generic_frame_cap_get_capFIsDevice_CL_def elim!: ccap_relationE) apply (simp add: gen_framesize_to_H_def) apply (simp add: vm_page_size_defs order_le_less_trans [OF word_and_le1] split: split_if) apply (clarsimp split: split_if_asm) apply (frule(1) cap_get_tag_isCap_unfolded_H_cap) apply (clarsimp simp: cap_lift_frame_cap cap_to_H_def generic_frame_cap_get_capFMappedAddress_CL_def generic_frame_cap_get_capFVMRights_CL_def generic_frame_cap_get_capFSize_CL_def generic_frame_cap_get_capFMappedASID_CL_def generic_frame_cap_get_capFBasePtr_CL_def generic_frame_cap_get_capFIsDevice_CL_def c_valid_cap_def cl_valid_cap_def option_to_0_def elim!: ccap_relationE) apply (simp add: gen_framesize_to_H_is_framesize_to_H_if_not_ARMSmallPage) apply (simp add: vm_page_size_defs order_le_less_trans [OF word_and_le1] split: split_if) apply (clarsimp split: split_if_asm) done lemma performPageInvocationUnmap_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and cte_wp_at' (diminished' (ArchObjectCap cap) o cteCap) ctSlot and K (isPageCap cap)) (UNIV \ \ccap_relation (ArchObjectCap cap) \cap\ \ \\ctSlot = Ptr ctSlot\) [] (liftE (performPageInvocation (PageUnmap cap ctSlot))) (Call performPageInvocationUnmap_'proc)" apply (simp only: liftE_liftM ccorres_liftM_simp) apply (cinit lift: cap_' ctSlot_') apply csymbr apply (rule ccorres_guard_imp [where A= "invs' and cte_wp_at' (diminished' (ArchObjectCap cap) o cteCap) ctSlot and K (isPageCap cap)"]) apply wpc apply (rule_tac P=" ret__unsigned_long = 0" in ccorres_gen_asm) apply simp apply (rule ccorres_symb_exec_l) apply (subst bind_return [symmetric]) apply (rule ccorres_split_nothrow_novcg) apply (rule ccorres_Guard) apply (rule updateCap_frame_mapped_addr_ccorres) apply ceqv apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply wp[1] apply (simp add: guard_is_UNIV_def) apply (wp getSlotCap_wp', simp) apply (wp getSlotCap_wp') apply simp apply (rule_tac P=" ret__unsigned_long \ 0" in ccorres_gen_asm) apply (simp cong: Guard_no_cong) apply (rule ccorres_rhs_assoc)+ apply (csymbr) apply csymbr apply csymbr apply csymbr apply wpc apply (ctac (no_vcg) add: unmapPage_ccorres) apply (rule ccorres_add_return2) apply (rule ccorres_split_nothrow_novcg) apply (rule ccorres_move_Guard [where P="cte_at' ctSlot" and P'=\]) apply (clarsimp simp: cte_wp_at_ctes_of) apply (drule (1) rf_sr_ctes_of_clift) apply (fastforce intro: typ_heap_simps) apply (rule ccorres_symb_exec_l) apply (rule updateCap_frame_mapped_addr_ccorres) apply (wp getSlotCap_wp', simp) apply (wp getSlotCap_wp') apply simp apply ceqv apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply wp[1] apply (simp add: guard_is_UNIV_def) apply (simp add: cte_wp_at_ctes_of) apply wp apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps split: split_if) apply (drule diminished_PageCap) apply clarsimp apply (drule ccap_relation_mapped_asid_0) apply (frule ctes_of_valid', clarsimp) apply (drule valid_global_refsD_with_objSize, clarsimp) apply (clarsimp simp: mask_def valid_cap'_def vmsz_aligned_aligned_pageBits) apply assumption apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps split: split_if) apply (drule diminished_PageCap) apply clarsimp apply (frule (1) rf_sr_ctes_of_clift) apply (clarsimp simp: typ_heap_simps') apply (frule ccap_relation_PageCap_generics) apply (case_tac "v2 = ARMSmallPage") apply (auto simp add: cap_get_tag_isCap_ArchObject2 isCap_simps) done lemma APFromVMRights_spec: "\s. \ \ \s. \vm_rights < 4\ Call APFromVMRights_'proc \ \ret__unsigned_long = ap_from_vm_rights (vmrights_to_H \<^bsup>s\<^esup>vm_rights) \" apply vcg apply (simp add: vmrights_to_H_def ap_from_vm_rights_def Kernel_C.VMNoAccess_def Kernel_C.VMKernelOnly_def Kernel_C.VMReadOnly_def Kernel_C.VMReadWrite_def) apply clarsimp apply (drule word_less_cases, auto)+ done lemma ap_from_vm_rights_mask: "ap_from_vm_rights R && 3 = (ap_from_vm_rights R :: word32)" by (simp add: ap_from_vm_rights_def split: vmrights.splits) lemma mask_eq1_nochoice: "(x:: word32) && 1 = x \ x = 0 \ x = 1" apply (simp add:mask_eq_iff[where n = 1,unfolded mask_def,simplified]) apply (drule word_2p_lem[where n = 1 and w = x,symmetric,simplified,THEN iffD1,rotated]) apply (simp add:word_size) apply word_bitwise apply clarsimp done definition "shared_bit_from_cacheable cacheable \ if cacheable = 0x1 then 0 else 1" definition "tex_bits_from_cacheable cacheable \ if cacheable = 0x1 then 5 else 0" definition "iwb_from_cacheable cacheable \ if cacheable = 0x1 then 1 else 0" lemma makeUserPDE_spec: "\s. \ \ \s. (\page_size = scast Kernel_C.ARMSection \ \page_size = scast Kernel_C.ARMSuperSection) \ \vm_rights < 4 \ vmsz_aligned' (\paddr) (gen_framesize_to_H \page_size) \ \parity && 1 = \parity \ \domain && 0xF = \domain \ \cacheable && 1 = \cacheable \ \nonexecutable && 1 = \nonexecutable\ Call makeUserPDE_'proc \ pde_lift \ret__struct_pde_C = Some (Pde_pde_section \ pde_pde_section_CL.address_CL = \<^bsup>s\<^esup>paddr, size_CL = if \<^bsup>s\<^esup>page_size = scast Kernel_C.ARMSection then 0 else 1, nG_CL = 1, S_CL = shared_bit_from_cacheable \<^bsup>s\<^esup>cacheable, APX_CL = 0, TEX_CL = tex_bits_from_cacheable \<^bsup>s\<^esup>cacheable, AP_CL = ap_from_vm_rights (vmrights_to_H \<^bsup>s\<^esup>vm_rights), P_CL = \<^bsup>s\<^esup>parity, Domain_CL = \<^bsup>s\<^esup>domain, XN_CL = \<^bsup>s\<^esup>nonexecutable, C_CL = 0, B_CL = iwb_from_cacheable \<^bsup>s\<^esup>cacheable \) \" apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp:ap_from_vm_rights_mask split:if_splits) apply (intro conjI impI allI | clarsimp )+ apply (simp only:pde_pde_section_lift pde_pde_section_lift_def) apply (simp add: vmsz_aligned'_def gen_framesize_to_H_def ap_from_vm_rights_mask) apply (clarsimp simp: Kernel_C.ARMSection_def Kernel_C.ARMSmallPage_def Kernel_C.ARMLargePage_def is_aligned_neg_mask_eq ) apply (clarsimp simp:mask_def ap_from_vm_rights_mask shared_bit_from_cacheable_def tex_bits_from_cacheable_def iwb_from_cacheable_def split:if_splits dest!:mask_eq1_nochoice) apply (simp only:pde_pde_section_lift pde_pde_section_lift_def) apply (simp add: vmsz_aligned'_def gen_framesize_to_H_def ap_from_vm_rights_mask) apply (clarsimp simp: Kernel_C.ARMSection_def Kernel_C.ARMSmallPage_def Kernel_C.ARMLargePage_def is_aligned_neg_mask_eq) apply (clarsimp simp:ap_from_vm_rights_mask mask_def shared_bit_from_cacheable_def tex_bits_from_cacheable_def iwb_from_cacheable_def split:if_splits dest!:mask_eq1_nochoice) apply (clarsimp) apply (intro conjI impI allI) apply (simp add:pde_pde_section_lift pde_pde_section_lift_def) apply (simp add: vmsz_aligned'_def gen_framesize_to_H_def ap_from_vm_rights_mask) apply (drule is_aligned_weaken[where y = 20]) apply (clarsimp simp: Kernel_C.ARMSuperSection_def Kernel_C.ARMSmallPage_def Kernel_C.ARMLargePage_def is_aligned_neg_mask_eq)+ apply (clarsimp simp:mask_def ap_from_vm_rights_mask shared_bit_from_cacheable_def tex_bits_from_cacheable_def iwb_from_cacheable_def split:if_splits dest!:mask_eq1_nochoice) apply (simp add:pde_pde_section_lift pde_pde_section_lift_def) apply (simp add: vmsz_aligned'_def gen_framesize_to_H_def ap_from_vm_rights_mask) apply (drule is_aligned_weaken[where y = 20]) apply (clarsimp simp: Kernel_C.ARMSuperSection_def Kernel_C.ARMSmallPage_def Kernel_C.ARMLargePage_def is_aligned_neg_mask_eq)+ apply (clarsimp simp:mask_def ap_from_vm_rights_mask shared_bit_from_cacheable_def tex_bits_from_cacheable_def iwb_from_cacheable_def split:if_splits dest!:mask_eq1_nochoice) done lemma makeUserPTE_spec: "\s. \ \ \s. (\page_size = scast Kernel_C.ARMSmallPage \ \page_size = scast Kernel_C.ARMLargePage) \ \vm_rights < 4 \ vmsz_aligned' \paddr (gen_framesize_to_H \page_size) \ \cacheable && 1 = \cacheable \ \nonexecutable && 1 = \nonexecutable\ Call makeUserPTE_'proc \ pte_lift \ret__struct_pte_C = Some (if \<^bsup>s\<^esup>page_size = scast Kernel_C.ARMSmallPage then Pte_pte_small \ address_CL = \<^bsup>s\<^esup>paddr, nG_CL = 1, S_CL = shared_bit_from_cacheable \<^bsup>s\<^esup>cacheable, APX_CL = 0, TEX_CL = tex_bits_from_cacheable \<^bsup>s\<^esup>cacheable, AP_CL = ap_from_vm_rights (vmrights_to_H \<^bsup>s\<^esup>vm_rights), C_CL = 0, B_CL = iwb_from_cacheable \<^bsup>s\<^esup>cacheable, XN_CL = \<^bsup>s\<^esup>nonexecutable \ else Pte_pte_large \ pte_pte_large_CL.address_CL = \<^bsup>s\<^esup>paddr, XN_CL = \<^bsup>s\<^esup>nonexecutable, TEX_CL = tex_bits_from_cacheable \<^bsup>s\<^esup>cacheable, nG_CL = 1, S_CL = shared_bit_from_cacheable \<^bsup>s\<^esup>cacheable, APX_CL = 0, AP_CL = ap_from_vm_rights (vmrights_to_H \<^bsup>s\<^esup>vm_rights), C_CL = 0, B_CL = iwb_from_cacheable \<^bsup>s\<^esup>cacheable, reserved_CL = 1 \)\" apply vcg apply (clarsimp simp:vmsz_aligned'_def) apply (intro conjI) apply (rule impI) apply (drule is_aligned_weaken[where y = 12]) apply (clarsimp simp:gen_framesize_to_H_def pageBitsForSize_def split:if_splits) apply (clarsimp dest:is_aligned_neg_mask_eq) apply (intro conjI impI allI) apply (fold_subgoals (prefix))[2] subgoal premises prems using prems by ((clarsimp simp add: pte_lift_def pte_pte_small_lift_def pte_tag_defs mask_def ap_from_vm_rights_mask addrFromPPtr_def shared_bit_from_cacheable_def tex_bits_from_cacheable_def iwb_from_cacheable_def dest!:mask_eq1_nochoice)+) apply (clarsimp) apply (drule is_aligned_weaken[where y = 16]) apply (clarsimp simp:gen_framesize_to_H_def pageBitsForSize_def split:if_splits) apply (intro conjI impI allI) apply ((clarsimp simp add: pte_lift_def pte_pte_large_lift_def pte_tag_defs mask_def ap_from_vm_rights_mask addrFromPPtr_def shared_bit_from_cacheable_def tex_bits_from_cacheable_def iwb_from_cacheable_def dest!:mask_eq1_nochoice is_aligned_neg_mask_eq)+)[2] done lemma vmAttributesFromWord_spec: "\s. \ \ \s. True\ Call vmAttributesFromWord_'proc \ vm_attributes_lift \ret__struct_vm_attributes_C = \ armExecuteNever_CL = (\<^bsup>s\<^esup>w >> 2) && 1, armParityEnabled_CL = (\<^bsup>s\<^esup>w >> 1) && 1, armPageCacheable_CL = \<^bsup>s\<^esup>w && 1 \ \" by (vcg, simp add: vm_attributes_lift_def word_sless_def word_sle_def) lemma cap_to_H_PDCap_tag: "\ cap_to_H cap = ArchObjectCap (PageDirectoryCap p A); cap_lift C_cap = Some cap \ \ cap_get_tag C_cap = scast cap_page_directory_cap" apply (clarsimp simp: cap_to_H_def Let_def split: cap_CL.splits split_if_asm) apply (simp_all add: Let_def cap_lift_def split: if_splits) done lemma cap_to_H_PDCap: "cap_to_H cap = ArchObjectCap (PageDirectoryCap p asid) \ \cap_CL. cap = Cap_page_directory_cap cap_CL \ to_bool (capPDIsMapped_CL cap_CL) = (asid \ None) \ (asid \ None \ capPDMappedASID_CL cap_CL = the asid) \ capPDBasePtr_CL cap_CL = p" by (auto simp add: cap_to_H_def Let_def split: cap_CL.splits if_splits) lemma cap_lift_PDCap_Base: "\ cap_to_H cap_cl = ArchObjectCap (PageDirectoryCap p asid); cap_lift cap_c = Some cap_cl \ \ p = capPDBasePtr_CL (cap_page_directory_cap_lift cap_c)" apply (simp add: cap_page_directory_cap_lift_def) apply (clarsimp simp: cap_to_H_def Let_def split: cap_CL.splits if_splits) done (* FIXME: move *) lemma word_le_mask_eq: "\ x \ mask n; n < word_bits \ \ x && mask n = (x::word32)" by (rule le_mask_imp_and_mask) declare mask_Suc_0[simp] (* FIXME: move *) lemma setCTE_asidpool': "\ ko_at' (ASIDPool pool) p \ setCTE c p' \\_. ko_at' (ASIDPool pool) p\" apply (clarsimp simp: setCTE_def) apply (simp add: setObject_def split_def) apply (rule hoare_seq_ext [OF _ hoare_gets_post]) apply (clarsimp simp: valid_def in_monad) apply (frule updateObject_type) apply (clarsimp simp: obj_at'_def projectKOs) apply (rule conjI) apply (clarsimp simp: lookupAround2_char1) apply (clarsimp split: split_if) apply (case_tac obj', auto)[1] apply (rename_tac arch_kernel_object) apply (case_tac arch_kernel_object, auto)[1] apply (simp add: updateObject_cte) apply (clarsimp simp: updateObject_cte typeError_def magnitudeCheck_def in_monad split: kernel_object.splits if_splits option.splits) apply (clarsimp simp: ps_clear_upd' lookupAround2_char1) done (* FIXME: move *) lemma udpateCap_asidpool': "\ ko_at' (ASIDPool pool) p \ updateCap c p' \\_. ko_at' (ASIDPool pool) p\" apply (simp add: updateCap_def) apply (wp setCTE_asidpool') done (* FIXME: move *) lemma asid_pool_at_rf_sr: "\ko_at' (ASIDPool pool) p s; (s, s') \ rf_sr\ \ \pool'. cslift s' (ap_Ptr p) = Some pool' \ casid_pool_relation (ASIDPool pool) pool'" apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cpspace_relation_def) apply (erule (1) cmap_relation_ko_atE) apply clarsimp done (* FIXME: move *) lemma asid_pool_at_ko: "asid_pool_at' p s \ \pool. ko_at' (ASIDPool pool) p s" apply (clarsimp simp: typ_at'_def obj_at'_def ko_wp_at'_def projectKOs) apply (case_tac ko, auto) apply (rename_tac arch_kernel_object) apply (case_tac arch_kernel_object, auto)[1] apply (rename_tac asidpool) apply (case_tac asidpool, auto)[1] done (* FIXME: move *) lemma asid_pool_at_c_guard: "\asid_pool_at' p s; (s, s') \ rf_sr\ \ c_guard (ap_Ptr p)" by (fastforce intro: typ_heap_simps dest!: asid_pool_at_ko asid_pool_at_rf_sr) (* FIXME: move *) lemma setObjectASID_Basic_ccorres: "ccorres dc xfdc \ {s. f s = p \ casid_pool_relation pool (asid_pool_C (pool' s))} hs (setObject p pool) ((Basic (\s. globals_update( t_hrs_'_update (hrs_mem_update (heap_update (Ptr &(ap_Ptr (f s)\[''array_C''])) (pool' s)))) s)))" apply (rule setObject_ccorres_helper) apply (simp_all add: objBits_simps archObjSize_def pageBits_def) apply (rule conseqPre, vcg) apply (rule subsetI, clarsimp simp: Collect_const_mem) apply (rule cmap_relationE1, erule rf_sr_cpspace_asidpool_relation, erule ko_at_projectKO_opt) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) apply (rule conjI) apply (clarsimp simp: cpspace_relation_def typ_heap_simps update_asidpool_map_to_asidpools update_asidpool_map_tos) apply (case_tac y') apply clarsimp apply (erule cmap_relation_updI, erule ko_at_projectKO_opt, simp+) apply (simp add: cready_queues_relation_def carch_state_relation_def cmachine_state_relation_def Let_def typ_heap_simps update_asidpool_map_tos) done lemma performASIDPoolInvocation_ccorres: notes option.case_cong_weak [cong] shows "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and cte_wp_at' (isPDCap o cteCap) ctSlot and asid_pool_at' poolPtr and K (asid \ mask asid_bits)) (UNIV \ \\poolPtr = Ptr poolPtr\ \ \\asid = asid\ \ \\pdCapSlot = Ptr ctSlot\) [] (liftE (performASIDPoolInvocation (Assign asid poolPtr ctSlot))) (Call performASIDPoolInvocation_'proc)" apply (simp only: liftE_liftM ccorres_liftM_simp) apply (cinit lift: poolPtr_' asid_' pdCapSlot_') apply (rule ccorres_symb_exec_l) apply (rule ccorres_symb_exec_l) apply (rule_tac P="ko_at' (ASIDPool pool) poolPtr" in ccorres_cross_over_guard) apply (rule ccorres_rhs_assoc2) apply (rule_tac ccorres_split_nothrow [where r'=dc and xf'=xfdc]) apply (simp add: updateCap_def) apply (rule_tac A="cte_wp_at' (op = rv o cteCap) ctSlot and K (isPDCap rv \ asid \ mask asid_bits)" and A'=UNIV in ccorres_guard_imp2) apply (rule ccorres_pre_getCTE) apply (rule_tac P="cte_wp_at' (op = rv o cteCap) ctSlot and K (isPDCap rv \ asid \ mask asid_bits) and cte_wp_at' (op = rva) ctSlot" and P'=UNIV in ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: cte_wp_at_ctes_of) apply (erule (1) rf_sr_ctes_of_cliftE) apply (clarsimp simp: typ_heap_simps) apply (rule conjI) apply (clarsimp simp: isPDCap_def) apply (drule cap_CL_lift) apply (drule (1) cap_to_H_PDCap_tag) apply simp apply (clarsimp simp: typ_heap_simps' isPDCap_def) apply (rule fst_setCTE [OF ctes_of_cte_at], assumption) apply (erule bexI [rotated]) apply clarsimp apply (frule (1) rf_sr_ctes_of_clift) apply clarsimp apply (clarsimp simp: rf_sr_def cstate_relation_def typ_heap_simps Let_def cpspace_relation_def) apply (rule conjI) apply (erule (2) cmap_relation_updI) apply (clarsimp simp: ccte_relation_def) apply (clarsimp simp: cte_lift_def) apply (simp split: option.splits) apply clarsimp apply (case_tac cte') apply clarsimp apply (rule conjI) apply (clarsimp simp: cap_lift_def Let_def cap_tag_defs) apply clarsimp apply (simp add: cte_to_H_def c_valid_cte_def) apply (simp add: cap_page_directory_cap_lift) apply (simp (no_asm) add: cap_to_H_def) apply (simp add: to_bool_def asid_bits_def le_mask_imp_and_mask word_bits_def) apply (erule (1) cap_lift_PDCap_Base) apply simp apply (erule_tac t = s' in ssubst) apply (simp add: heap_to_user_data_def) apply (rule conjI) apply (erule (1) setCTE_tcb_case) apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps h_t_valid_clift_Some_iff cvariable_array_map_const_add_map_option[where f="tcb_no_ctes_proj"]) apply (clarsimp simp: cte_wp_at_ctes_of) apply ceqv apply (rule ccorres_move_c_guard_cte) apply (rule ccorres_symb_exec_r) apply (rule ccorres_Guard_Seq[where F=ArrayBounds])? apply (rule ccorres_move_c_guard_ap) apply (simp only: Kernel_C.asidLowBits_def word_sle_def) apply (rule ccorres_Guard_Seq)+ apply (rule ccorres_add_return2) apply (rule ccorres_split_nothrow_novcg) apply (rule setObjectASID_Basic_ccorres) apply ceqv apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply wp apply (simp add: guard_is_UNIV_def) apply (vcg) apply (rule conseqPre, vcg) apply clarsimp apply (wp udpateCap_asidpool') apply vcg apply (wp getASID_wp) apply simp apply wp apply (simp add: o_def inv_def) apply (wp getASID_wp) apply simp apply (rule empty_fail_getObject) apply simp apply wp apply (wp getSlotCap_wp') apply simp apply (clarsimp simp: cte_wp_at_ctes_of) apply (rule conjI) apply (clarsimp dest!: asid_pool_at_ko simp: obj_at'_def) apply (rule cmap_relationE1[OF cmap_relation_cte], assumption+) apply (clarsimp simp: typ_heap_simps cap_get_tag_isCap_ArchObject2 isPDCap_def isCap_simps order_le_less_trans[OF word_and_le1] asid_low_bits_def dest!: ccte_relation_ccap_relation) apply (simp add: casid_pool_relation_def mask_def) apply (rule array_relation_update) apply (drule (1) asid_pool_at_rf_sr) apply (clarsimp simp: typ_heap_simps) apply (case_tac pool') apply (simp add: casid_pool_relation_def) apply simp apply (simp add: option_to_ptr_def option_to_0_def) apply (erule(1) rf_sr_ctes_of_cliftE, simp(no_asm_simp)) apply (clarsimp simp: ccap_relation_def map_option_Some_eq2 cap_lift_PDCap_Base) apply (simp add: asid_low_bits_def) done lemma pte_case_isInvalidPTE: "(case pte of InvalidPTE \ P | _ \ Q) = (if isInvalidPTE pte then P else Q)" by (cases pte, simp_all add: isInvalidPTE_def) lemma flushTable_ccorres: "ccorres dc xfdc (invs' and cur_tcb' and (\_. asid \ mask asid_bits)) (UNIV \ {s. pd_' s = pde_Ptr pd} \ {s. asid_' s = asid} \ {s. vptr_' s = vptr} \ {s. pt_' s = pte_Ptr pt}) [] (flushTable pd asid vptr) (Call flushTable_'proc)" apply (cinit lift: pd_' asid_' vptr_' pt_') apply (rule ccorres_assert) apply (simp add: objBits_simps archObjSize_def ARMSmallPageBits_def word_sle_def del: Collect_const) apply (ctac (no_vcg) add: setVMRootForFlush_ccorres) apply (ctac (no_vcg) add: loadHWASID_ccorres) apply csymbr apply (simp add: when_def del: Collect_const) apply (rule ccorres_cond2[where R=\]) apply (clarsimp simp: pde_stored_asid_def to_bool_def split: split_if) apply (rule ccorres_Guard_Seq ccorres_rhs_assoc)+ apply csymbr apply (simp add: word_sle_def mapM_discarded whileAnno_def Collect_False del: Collect_const) apply (ctac (no_vcg) add: invalidateTLB_ASID_ccorres) apply (rule_tac R=\ in ccorres_cond2) apply (clarsimp simp: from_bool_0 Collect_const_mem) apply (rule ccorres_pre_getCurThread) apply (ctac (no_vcg) add: setVMRoot_ccorres [unfolded dc_def]) apply (rule ccorres_return_Skip[unfolded dc_def]) apply (wp static_imp_wp) apply clarsimp apply (rule_tac Q="\_ s. invs' s \ cur_tcb' s" in hoare_post_imp) apply (simp add: invs'_invs_no_cicd cur_tcb'_def) apply (wp mapM_x_wp_inv getPTE_wp | wpc)+ apply (rule ccorres_return_Skip[unfolded dc_def]) apply wp apply clarsimp apply (strengthen invs_valid_pde_mappings') apply (wp setVMRootForFlush_invs' hoare_drop_imps) apply (clarsimp simp:Collect_const_mem) apply (simp add: pde_pde_invalid_lift_def pde_lift_def pde_stored_asid_def to_bool_def) done lemma performPageTableInvocationMap_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (cte_at' ctSlot and (\_. valid_pde_mapping_offset' (pdSlot && mask pdBits))) (UNIV \ \ccap_relation cap \cap\ \ \\ctSlot = Ptr ctSlot\ \ \cpde_relation pde \pde\ \ \\pdSlot = Ptr pdSlot\) [] (liftE (performPageTableInvocation (PageTableMap cap ctSlot pde pdSlot))) (Call performPageTableInvocationMap_'proc)" apply (simp only: liftE_liftM ccorres_liftM_simp) apply (cinit lift: cap_' ctSlot_' pde_' pdSlot_') apply (ctac (no_vcg)) apply (rule ccorres_split_nothrow_novcg) apply simp apply (erule storePDE_Basic_ccorres) apply ceqv apply (rule ccorres_symb_exec_r) apply (rule ccorres_add_return2) apply (rule ccorres_split_nothrow_novcg) apply simp apply (rule ccorres_call) apply (rule cleanByVA_PoU_ccorres) apply (rule refl) apply (simp add: xfdc_def) apply simp apply ceqv apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply wp apply (simp add: guard_is_UNIV_def) apply vcg apply (rule conseqPre, vcg) apply clarsimp apply wp apply (simp add: guard_is_UNIV_def) apply wp apply simp apply simp done end end