diff --git a/proof/access-control/ARM/ArchRetype_AC.thy b/proof/access-control/ARM/ArchRetype_AC.thy index 63deb8b9a8..5b2f637b27 100644 --- a/proof/access-control/ARM/ArchRetype_AC.thy +++ b/proof/access-control/ARM/ArchRetype_AC.thy @@ -209,25 +209,21 @@ lemma copy_global_invs_mappings_restricted': lemma init_arch_objects_pas_refined[Retype_AC_assms]: "\pas_refined aag and post_retype_invs tp refs and (\s. \ x\set refs. x \ global_refs s) and K (\ref \ set refs. is_aligned ref (obj_bits_api tp obj_sz))\ - init_arch_objects tp ptr bits obj_sz refs + init_arch_objects tp dev ptr bits obj_sz refs \\_. pas_refined aag\" + supply if_split[split del] apply (rule hoare_gen_asm) - apply (cases tp) - apply (simp_all add: init_arch_objects_def) - apply (wp | simp)+ - apply (rename_tac aobject_type) - apply (case_tac aobject_type, simp_all) - apply ((simp | wp)+)[5] - apply wp - apply (rule_tac Q'="\rv. pas_refined aag and + apply (cases tp; + (wpsimp simp: init_arch_objects_def + wp: mapM_x_wp'[where f="\r. do_machine_op (m r)" for m])) + apply (rule_tac Q'="\rv. pas_refined aag and all_invs_but_equal_kernel_mappings_restricted (set refs) and (\s. \x \ set refs. x \ global_refs s)" in hoare_strengthen_post) - apply (wp mapM_x_wp[OF _ subset_refl]) - apply ((wp copy_global_mappings_pas_refined copy_global_invs_mappings_restricted' - copy_global_mappings_global_refs_inv copy_global_invs_mappings_restricted' - | fastforce simp: obj_bits_api_def default_arch_object_def pd_bits_def pageBits_def)+)[2] - apply (wp dmo_invs hoare_vcg_const_Ball_lift valid_irq_node_typ - | fastforce simp: post_retype_invs_def)+ + apply (wp mapM_x_wp[OF _ subset_refl]) + apply ((wp copy_global_mappings_pas_refined copy_global_invs_mappings_restricted' + copy_global_mappings_global_refs_inv copy_global_invs_mappings_restricted' + | fastforce simp: obj_bits_api_def default_arch_object_def pd_bits_def pageBits_def)+)[2] + apply (fastforce simp: post_retype_invs_def split: if_split) done lemma region_in_kernel_window_preserved: @@ -287,7 +283,7 @@ crunch delete_objects (ignore: do_machine_op freeMemory) lemma init_arch_objects_pas_cur_domain[Retype_AC_assms, wp]: - "init_arch_objects tp ptr n us refs \pas_cur_domain aag\" + "init_arch_objects tp dev ptr n us refs \pas_cur_domain aag\" by wp lemma retype_region_pas_cur_domain[Retype_AC_assms, wp]: @@ -366,13 +362,12 @@ lemma dmo_clearMemory_respects'[Retype_AC_assms]: \\_. integrity aag X st\" unfolding do_machine_op_def clearMemory_def apply (simp add: split_def cleanCacheRange_PoU_def) - apply wp - apply clarsimp + apply wpsimp apply (erule use_valid) - apply wp - apply (simp add: cleanCacheRange_RAM_def cleanCacheRange_PoC_def cacheRangeOp_def cleanL2Range_def - cleanByVA_def split_def dsb_def) - apply (wp mol_respects mapM_x_wp' storeWord_respects)+ + apply (wp mapM_x_wp') + apply (simp add: cleanCacheRange_RAM_def cleanCacheRange_PoC_def cacheRangeOp_def cleanL2Range_def + cleanByVA_def split_def dsb_def) + apply (wp mol_respects mapM_x_wp' storeWord_respects)+ apply (simp add: word_size_bits_def) apply (clarsimp simp: word_size_def word_bits_def upto_enum_step_shift_red[where us=2, simplified]) apply (erule bspec) @@ -396,6 +391,12 @@ lemma dmo_cleanCacheRange_PoU_respects [wp]: "do_machine_op (cleanCacheRange_PoU vstart vend pstart) \integrity aag X st\" by (wpsimp wp: dmo_cacheRangeOp_lift simp: cleanCacheRange_PoU_def cleanByVA_PoU_def) +lemma dmo_cleanCacheRange_RAM_respects [wp]: + "do_machine_op (cleanCacheRange_RAM vstart vend pstart) \integrity aag X st\" + by (wpsimp wp: dmo_cacheRangeOp_lift + simp: dmo_bind_valid cleanCacheRange_RAM_def cleanCacheRange_PoC_def + cleanL2Range_def dsb_def cleanByVA_def) + lemma dmo_mapM_x_cleanCacheRange_PoU_integrity: "do_machine_op (mapM_x (\x. cleanCacheRange_PoU (f x) (g x) (h x)) refs) \integrity aag X st\" by (wp dmo_mapM_x_wp_inv) @@ -403,7 +404,7 @@ lemma dmo_mapM_x_cleanCacheRange_PoU_integrity: lemma init_arch_objects_integrity[Retype_AC_assms]: "\integrity aag X st and K (\x\set refs. is_subject aag x) and K (\ref \ set refs. is_aligned ref (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr num_objects obj_sz refs + init_arch_objects new_type dev ptr num_objects obj_sz refs \\_. integrity aag X st\" apply (rule hoare_gen_asm)+ apply (cases new_type; simp add: init_arch_objects_def split del: if_split) diff --git a/proof/access-control/DomainSepInv.thy b/proof/access-control/DomainSepInv.thy index 6f33d347fd..7d2c2c6421 100644 --- a/proof/access-control/DomainSepInv.thy +++ b/proof/access-control/DomainSepInv.thy @@ -315,7 +315,7 @@ locale DomainSepInv_1 = and arch_post_cap_deletion_domain_sep_inv[wp]: "arch_post_cap_deletion acap \\s :: det_ext state. domain_sep_inv irqs st s\" and init_arch_objects_domain_sep_inv[wp]: - "init_arch_objects typ ptr n sz refs \\s :: det_ext state. domain_sep_inv irqs st s\" + "init_arch_objects typ dev ptr n sz refs \\s :: det_ext state. domain_sep_inv irqs st s\" and prepare_thread_delete_domain_sep_inv[wp]: "prepare_thread_delete t \\s :: det_ext state. domain_sep_inv irqs st s\" and arch_finalise_cap_rv: diff --git a/proof/access-control/Retype_AC.thy b/proof/access-control/Retype_AC.thy index dbda41be06..b81ad611ab 100644 --- a/proof/access-control/Retype_AC.thy +++ b/proof/access-control/Retype_AC.thy @@ -184,15 +184,15 @@ locale Retype_AC_1 = "\tp. is_aligned p (obj_bits_api (ArchObject tp) n) \ aobj_ref' (arch_default_cap tp p n dev) \ ptr_range p (obj_bits_api (ArchObject tp) n)" and init_arch_objects_pas_refined: - "\tp. \pas_refined aag and post_retype_invs tp refs + "\tp dev. \pas_refined aag and post_retype_invs tp refs and (\s. \x\set refs. x \ global_refs s) and K (\ref \ set refs. is_aligned ref (obj_bits_api tp obj_sz))\ - init_arch_objects tp ptr bits obj_sz refs - \\_. pas_refined aag\" + init_arch_objects tp dev ptr bits obj_sz refs + \\_. pas_refined aag\" and dmo_freeMemory_invs: "do_machine_op (freeMemory ptr bits) \\s :: det_ext state. invs s\" and init_arch_objects_pas_cur_domain[wp]: - "\tp. init_arch_objects tp ptr n us refs \pas_cur_domain aag\" + "\tp dev. init_arch_objects tp dev ptr n us refs \pas_cur_domain aag\" and retype_region_pas_cur_domain[wp]: "\tp. retype_region ptr n us tp dev \pas_cur_domain aag\" and reset_untyped_cap_pas_cur_domain[wp]: @@ -222,7 +222,7 @@ locale Retype_AC_1 = and init_arch_objects_integrity: "\integrity aag X st and K (\x\set refs. is_subject aag x) and K (\ref \ set refs. is_aligned ref (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr num_objects obj_sz refs + init_arch_objects new_type dev ptr num_objects obj_sz refs \\_. integrity aag X st\" and integrity_asids_detype: "\r \ R. pasObjectAbs aag r \ subjects diff --git a/proof/access-control/Syscall_AC.thy b/proof/access-control/Syscall_AC.thy index b505d09d9c..ad13ff9fb8 100644 --- a/proof/access-control/Syscall_AC.thy +++ b/proof/access-control/Syscall_AC.thy @@ -504,7 +504,7 @@ locale Syscall_AC_1 = and handle_reserved_irq_arch_state[wp]: "\P. handle_reserved_irq irq \\s :: det_ext state. P (arch_state s)\" and init_arch_objects_arch_state[wp]: - "\P. init_arch_objects new_type ptr n sz refs \\s :: det_ext state. P (arch_state s)\" + "\P. init_arch_objects new_type dev ptr n sz refs \\s :: det_ext state. P (arch_state s)\" and getActiveIRQ_inv: "\P. \f s. P s \ P (irq_state_update f s) \ \P\ getActiveIRQ in_kernel \\rv. P\" diff --git a/proof/crefine/AARCH64/Invoke_C.thy b/proof/crefine/AARCH64/Invoke_C.thy index 15b994746a..ce40f158ad 100644 --- a/proof/crefine/AARCH64/Invoke_C.thy +++ b/proof/crefine/AARCH64/Invoke_C.thy @@ -1649,43 +1649,34 @@ lemma clearMemory_untyped_ccorres: apply (cinit' lift: bits_' ptr___ptr_to_unsigned_long_') apply (rule_tac P="ptr \ 0 \ sz < word_bits" in ccorres_gen_asm) apply (simp add: clearMemory_def) - apply (simp add: doMachineOp_bind storeWord_empty_fail) - apply (rule ccorres_split_nothrow_novcg_dc) - apply (rule_tac P="?P" and P'="{s. region_actually_is_bytes ptr (2 ^ sz) s}" in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (rule conjI; clarsimp) - apply (simp add: word_less_nat_alt unat_of_nat word_bits_def) - apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def - is_aligned_no_wrap'[OF _ word64_power_less_1] - unat_of_nat_eq word_bits_def) - apply (simp add: is_aligned_weaken is_aligned_triv[THEN is_aligned_weaken]) - apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] region_actually_is_bytes_dom_s) - apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step - word_bits_def cte_wp_at_ctes_of) - apply (frule ctes_of_valid', clarify+) - apply (simp add: doMachineOp_def split_def exec_gets) - apply (simp add: select_f_def simpler_modify_def bind_def valid_cap_simps' capAligned_def) - apply (subst pspace_no_overlap_underlying_zero_update; simp?) - apply (case_tac sz, simp_all)[1] - apply (case_tac nat, simp_all)[1] - apply (case_tac nata, simp_all)[1] - apply (clarsimp dest!: region_actually_is_bytes) - apply (drule(1) rf_sr_rep0) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def) - apply csymbr - apply (ctac add: cleanCacheRange_RAM_ccorres) - apply wp - apply (simp add: guard_is_UNIV_def unat_of_nat - word_bits_def capAligned_def word_of_nat_less) + apply (rule_tac P="?P" and P'="{s. region_actually_is_bytes ptr (2 ^ sz) s}" in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (rule conjI; clarsimp) + apply (simp add: word_less_nat_alt unat_of_nat word_bits_def) + apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def + is_aligned_no_wrap'[OF _ word64_power_less_1] + unat_of_nat_eq word_bits_def) + apply (simp add: is_aligned_weaken is_aligned_triv[THEN is_aligned_weaken]) + apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] region_actually_is_bytes_dom_s) + apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step + word_bits_def cte_wp_at_ctes_of) + apply (frule ctes_of_valid', clarify+) + apply (simp add: doMachineOp_def split_def exec_gets) + apply (simp add: select_f_def simpler_modify_def bind_def valid_cap_simps' capAligned_def) + apply (subst pspace_no_overlap_underlying_zero_update; simp?) + apply (case_tac sz, simp_all)[1] + apply (case_tac nat, simp_all)[1] + apply (case_tac nata, simp_all)[1] + apply (clarsimp dest!: region_actually_is_bytes) + apply (drule(1) rf_sr_rep0) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) apply (clarsimp simp: cte_wp_at_ctes_of) apply (frule ctes_of_valid'; clarify?) apply (clarsimp simp: isCap_simps valid_cap_simps' capAligned_def word_of_nat_less Kernel_Config.resetChunkBits_def word_bits_def unat_2p_sub_1) - apply (strengthen is_aligned_no_wrap'[where sz=sz] is_aligned_addrFromPPtr_n)+ - apply (simp add: addrFromPPtr_mask_cacheLineSize pptrBaseOffset_alignment_def) apply (cases "ptr = 0"; simp) apply (drule subsetD, rule intvl_self, simp) apply simp diff --git a/proof/crefine/AARCH64/Machine_C.thy b/proof/crefine/AARCH64/Machine_C.thy index 1e02ad82ad..2415ee3245 100644 --- a/proof/crefine/AARCH64/Machine_C.thy +++ b/proof/crefine/AARCH64/Machine_C.thy @@ -199,6 +199,13 @@ assumes cleanCacheRange_RAM_preserves_kernel_bytes: \ (\x. snd (hrs_htd (t_hrs_' (globals s)) x) 0 \ None \ hrs_mem (t_hrs_' (globals t)) x = hrs_mem (t_hrs_' (globals s)) x)}" +assumes cleanCacheRange_PoU_preserves_kernel_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_PoU_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ (\x. snd (hrs_htd (t_hrs_' (globals s)) x) 0 \ None + \ hrs_mem (t_hrs_' (globals t)) x = hrs_mem (t_hrs_' (globals s)) x)}" + + (* Hypervisor-related machine ops *) (* ARM Hypervisor hardware register getters and setters *) diff --git a/proof/crefine/AARCH64/Recycle_C.thy b/proof/crefine/AARCH64/Recycle_C.thy index 98055bab5b..9817958250 100644 --- a/proof/crefine/AARCH64/Recycle_C.thy +++ b/proof/crefine/AARCH64/Recycle_C.thy @@ -252,8 +252,6 @@ lemma range_cover_nca_neg: "\x p (off :: 9 word). apply (simp add: pageBits_def objBits_simps) done -lemmas unat_of_nat32' = unat_of_nat_eq[where 'a=32] - lemma clearMemory_PageCap_ccorres: "ccorres dc xfdc (invs' and valid_cap' (ArchObjectCap (FrameCap ptr undefined sz False None)) and (\s. 2 ^ pageBitsForSize sz \ gsMaxObjectSize s) @@ -268,30 +266,27 @@ lemma clearMemory_PageCap_ccorres: apply (cinit' lift: bits_' ptr___ptr_to_unsigned_long_') apply (rule_tac P="capAligned (ArchObjectCap (FrameCap ptr undefined sz False None))" in ccorres_gen_asm) - apply (rule ccorres_Guard_Seq) + apply (rule ccorres_Guard) apply (simp add: clearMemory_def) - apply (simp add: doMachineOp_bind) - apply (rule ccorres_split_nothrow_novcg_dc) - apply (rule_tac P="?P" in ccorres_from_vcg[where P'=UNIV]) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: valid_cap'_def capAligned_def - is_aligned_no_wrap'[OF _ word64_power_less_1]) - apply (prop_tac "ptr \ 0") - subgoal - apply (simp add: frame_at'_def) - apply (drule_tac x=0 in spec) - apply (clarsimp simp: pageBitsForSize_def bit_simps split: vmpage_size.splits) - done - apply simp - apply (prop_tac "3 \ pageBitsForSize sz") - apply (simp add: pageBitsForSize_def bit_simps split: vmpage_size.split) - apply (rule conjI) - apply (erule is_aligned_weaken) - apply (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits) - apply (rule conjI) - apply (rule is_aligned_power2) - apply (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits) - apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def]) + apply (rule_tac P="?P" in ccorres_from_vcg[where P'=UNIV]) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: valid_cap'_def capAligned_def + is_aligned_no_wrap'[OF _ word64_power_less_1]) + apply (prop_tac "ptr \ 0") + subgoal + apply (simp add: frame_at'_def) + apply (drule_tac x=0 in spec) + apply (clarsimp simp: pageBitsForSize_def bit_simps split: vmpage_size.splits) + done + apply simp + apply (prop_tac "3 \ pageBitsForSize sz") + apply (simp add: pageBitsForSize_def bit_simps split: vmpage_size.split) + apply (rule conjI) + apply (erule is_aligned_weaken) + apply (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits) + apply (rule conjI) + apply (rule is_aligned_power2) + apply (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits) apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] frame_at'_def) apply (simp add: flex_user_data_at_rf_sr_dom_s bit_simps) apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step) @@ -308,7 +303,7 @@ lemma clearMemory_PageCap_ccorres: apply (erule allfEI[where f=of_nat]) apply (clarsimp simp: bit_simps) apply (subst(asm) of_nat_power, assumption) - apply simp + apply simp apply (insert pageBitsForSize_64 [of sz])[1] apply (erule order_le_less_trans [rotated]) apply simp @@ -376,25 +371,8 @@ lemma clearMemory_PageCap_ccorres: apply (simp add: bit_simps) apply (simp add: of_nat_power[where 'a=64, folded word_bits_def]) apply (simp add: pageBits_def ko_at_projectKO_opt[OF user_data_at_ko]) - (* FIXME AARCH64 indentation *) apply (rule inj_Ptr) - apply csymbr - apply (ctac add: cleanCacheRange_RAM_ccorres) - apply wp - apply (simp add: guard_is_UNIV_def unat_of_nat - word_bits_def capAligned_def word_of_nat_less) - apply (clarsimp simp: word_bits_def valid_cap'_def - capAligned_def word_of_nat_less) - apply (frule is_aligned_addrFromPPtr_n, simp add: pageBitsForSize_def split: vmpage_size.splits) - apply (simp add: bit_simps pptrBaseOffset_alignment_def)+ - apply (simp add: is_aligned_no_overflow') - apply (rule conjI) - subgoal - apply (prop_tac "cacheLineSize \ pageBitsForSize sz") - apply (simp add: pageBitsForSize_def bit_simps cacheLineSize_def split: vmpage_size.splits) - apply (simp add: is_aligned_mask[THEN iffD1] is_aligned_weaken) - done - apply (simp add: pageBitsForSize_def bit_simps split: vmpage_size.splits) + apply (clarsimp simp: word_bits_def valid_cap'_def capAligned_def word_of_nat_less) done declare replicate_numeral [simp] diff --git a/proof/crefine/AARCH64/Retype_C.thy b/proof/crefine/AARCH64/Retype_C.thy index 20481e5bd0..cc718b1970 100644 --- a/proof/crefine/AARCH64/Retype_C.thy +++ b/proof/crefine/AARCH64/Retype_C.thy @@ -5818,6 +5818,41 @@ lemma updatePTType_ccorres: apply (clarsimp simp: cvariable_array_map_relation_def split: if_splits) done +lemma placeNewDataObject_dev_ccorres: + "ccorresG rf_sr \ dc xfdc + (createObject_hs_preconds regionBase newType us True + and K (APIType_capBits newType us = pageBits + us)) + ({s. region_actually_is_bytes regionBase (2 ^ (pageBits + us)) s}) + hs + (placeNewDataObject regionBase us True) + (global_htd_update (\s. (ptr_retyps (2^us) (Ptr regionBase :: user_data_device_C ptr))))" + apply (simp add: placeNewDataObject_def ccorres_cond_univ_iff) + apply (rule ccorres_guard_imp, rule placeNewObject_user_data_device, simp_all) + apply (clarsimp simp: createObject_hs_preconds_def invs'_def + valid_state'_def valid_pspace'_def) + done + +lemma placeNewDataObject_no_dev_ccorres: + "ccorresG rf_sr \ dc xfdc + (createObject_hs_preconds regionBase newType us False + and K (APIType_capBits newType us = pageBits + us)) + ({s. region_actually_is_bytes regionBase (2 ^ (pageBits + us)) s + \ (heap_list_is_zero (hrs_mem (t_hrs_' (globals s))) regionBase (2 ^ (pageBits + us)))}) + hs + (placeNewDataObject regionBase us False) + (global_htd_update (\s. (ptr_retyps (2^us) (Ptr regionBase :: user_data_C ptr))))" + apply (simp add: placeNewDataObject_def ccorres_cond_empty_iff) + apply (rule ccorres_guard_imp, rule placeNewObject_user_data, simp_all) + apply (clarsimp simp: createObject_hs_preconds_def invs'_def + valid_state'_def valid_pspace'_def) + apply (frule range_cover.sz(1), simp add: word_bits_def) + done + + +crunch placeNewDataObject, updatePTType + for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" + (simp: crunch_simps) + lemma Arch_createObject_ccorres: assumes t: "toAPIType newType = None" shows "ccorres (\a b. ccap_relation (ArchObjectCap a) b) ret__struct_cap_C_' @@ -5866,31 +5901,62 @@ proof - canonical_address_and_maskD) done - apply (in_case "HugePageObject") -subgoal - apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') - apply (simp add: object_type_from_H_def Kernel_C_defs) - apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps - ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps - AARCH64_H.createObject_def pageBits_def ptTranslationBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=18 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) + subgoal + apply (in_case "HugePageObject") + apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') + apply (simp add: object_type_from_H_def Kernel_C_defs) + apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + AARCH64_H.createObject_def pageBits_def ptTranslationBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=18 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vm_page_size_defs ptTranslationBits_def + canonical_address_and_maskD[unfolded mask_def, simplified] + vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=18 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vm_page_size_defs ptTranslationBits_def + canonical_address_and_maskD[unfolded mask_def, simplified] + vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs ptTranslationBits_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vm_page_size_defs ptTranslationBits_def - canonical_address_and_maskD[unfolded mask_def, simplified] - vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) - done + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_cacheLineSize) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp add: pptrBaseOffset_alignment_def) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + done apply (in_case "VSpaceObject") subgoal apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') @@ -5902,25 +5968,30 @@ subgoal apply (clarsimp simp: hrs_htd_update bitSimps objBits_simps AARCH64_H.createObject_def pt_bits_minus_pte_bits) apply (ctac pre only: add: placeNewObject_pte_vs[simplified]) - apply (ctac only: add: updatePTType_ccorres) + apply (ctac (no_vcg) only: add: updatePTType_ccorres) apply csymbr - apply (rule ccorres_return_C) - apply simp - apply simp - apply simp - apply wp - apply vcg + apply (ctac (no_vcg) only: add: cleanCacheRange_PoU_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wpsimp + apply clarsimp + apply (rule conjI) + apply (solves \simp add: bit_simps Kernel_Config.config_ARM_PA_SIZE_BITS_40_def mask_def\) + apply (clarsimp simp: ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_vspace_cap_lift + vmrights_to_H_def isFrameType_def canonical_address_and_maskD) apply wp apply vcg apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' APIType_capBits_def invs_valid_objs' - invs_urz) - apply clarsimp - apply (clarsimp simp: ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_vspace_cap_lift - vmrights_to_H_def isFrameType_def canonical_address_and_maskD) + invs_urz is_aligned_no_overflow_mask addrFromPPtr_mask_cacheLineSize) + apply (rule conjI, solves \clarsimp simp: bit_simps mask_def split: if_splits\) + apply (drule is_aligned_addrFromPPtr_n, simp add: pptrBaseOffset_alignment_def bit_simps split: if_splits) + apply (simp add: is_aligned_no_overflow_mask) + apply (clarsimp simp: APIType_capBits_def isFrameType_def) apply (prop_tac "c_guard (vs_Ptr regionBase)") apply (rule is_aligned_c_guard[where m=pte_bits], simp, simp) apply (simp add: align_of_array) @@ -5945,18 +6016,50 @@ subgoal AARCH64_H.createObject_def pageBits_def cond_second_eq_seq_ccorres modify_gsUserPages_update intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=0 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def cl_valid_cap_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift vm_page_size_defs - canonical_address_and_maskD[unfolded mask_def, simplified] - vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=0 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vm_page_size_defs ptTranslationBits_def + canonical_address_and_maskD[unfolded mask_def, simplified] + vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=0 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vm_page_size_defs ptTranslationBits_def + canonical_address_and_maskD[unfolded mask_def, simplified] + vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs ptTranslationBits_def + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_cacheLineSize) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp add: pptrBaseOffset_alignment_def) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) done apply (in_case "LargePageObject") subgoal @@ -5969,25 +6072,56 @@ subgoal pageBits_def ptTranslationBits_def cond_second_eq_seq_ccorres modify_gsUserPages_update intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=9 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs ptTranslationBits_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - ptTranslationBits_def vm_page_size_defs vmrights_to_H_def - canonical_address_and_maskD[unfolded mask_def, simplified] - mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=9 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vm_page_size_defs ptTranslationBits_def + canonical_address_and_maskD[unfolded mask_def, simplified] + vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=9 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vm_page_size_defs ptTranslationBits_def + canonical_address_and_maskD[unfolded mask_def, simplified] + vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs ptTranslationBits_def + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_cacheLineSize) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp add: pptrBaseOffset_alignment_def) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) done apply (in_case "PageTableObject") (* FIXME AARCH64: goal here shows a vs_Ptr, but that is only because pt_Ptr and vs_Ptr are the same type in this config. Probably should get a comment at def of vs_Ptr *) -subgoal + subgoal apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff asidInvalid_def @@ -5998,25 +6132,30 @@ subgoal AARCH64_H.createObject_def pageBits_def pt_bits_def table_size pte_bits_def) apply (ctac pre only: add: placeNewObject_pte_pt[simplified ptTranslationBits_def, simplified]) - apply (ctac only: add: updatePTType_ccorres) + apply (ctac (no_vcg) only: add: updatePTType_ccorres) apply csymbr - apply (rule ccorres_return_C) - apply simp - apply simp - apply simp - apply wp - apply vcg + apply (ctac (no_vcg) only: add: cleanCacheRange_PoU_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wpsimp + apply clarsimp + apply (rule conjI) + apply (solves \simp add: bit_simps Kernel_Config.config_ARM_PA_SIZE_BITS_40_def mask_def\) + apply (clarsimp simp: bit_simps ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_page_table_cap_lift + vmrights_to_H_def isFrameType_def canonical_address_and_maskD) apply wp apply vcg apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_valid_objs' - invs_urz bit_simps) - apply clarsimp - apply (clarsimp simp: bit_simps ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_page_table_cap_lift - vmrights_to_H_def isFrameType_def canonical_address_and_maskD) + APIType_capBits_def invs_valid_objs' bit_simps + invs_urz is_aligned_no_overflow_mask addrFromPPtr_mask_cacheLineSize) + apply (rule conjI, solves \clarsimp simp: bit_simps mask_def split: if_splits\) + apply (drule is_aligned_addrFromPPtr_n, simp add: pptrBaseOffset_alignment_def split: if_splits) + apply (simp add: is_aligned_no_overflow_mask) + apply (clarsimp simp: APIType_capBits_def isFrameType_def bit_simps) apply (prop_tac "c_guard (pt_Ptr regionBase)") apply (rule is_aligned_c_guard[where m=pte_bits], simp, simp) apply (simp add: align_of_array) @@ -7956,14 +8095,18 @@ lemma Arch_createObject_preserves_bytes: exspec=cap_page_table_cap_new_modifies exspec=addrFromPPtr_modifies exspec=cap_vcpu_cap_new_modifies + exspec=cleanCacheRange_RAM_preserves_kernel_bytes + exspec=cleanCacheRange_PoU_preserves_kernel_bytes ) + apply (clarsimp simp: vm_page_size_defs) apply (safe intro!: byte_regions_unmodified_hrs_mem_update, - (simp_all add: h_t_valid_field hrs_htd_update)+) - apply (safe intro!: ptr_retyp_d ptr_retyps_out) - apply (simp_all add: object_type_from_H_def Kernel_C_defs APIType_capBits_def - bit_simps - split: object_type.split_asm ArchTypes_H.apiobject_type.split_asm) - apply (simp add: Kernel_Config.config_ARM_PA_SIZE_BITS_40_def) (* FIXME AARCH64: from bit_simps above *) + simp_all add: h_t_valid_field hrs_htd_update) + apply (safe intro!: ptr_retyp_d ptr_retyps_out) + apply (simp_all add: object_type_from_H_def Kernel_C_defs APIType_capBits_def + bit_simps + split: object_type.split_asm ArchTypes_H.apiobject_type.split_asm) + apply (all \(solves \simp add: byte_regions_unmodified_def\)?\) + apply (simp add: Kernel_Config.config_ARM_PA_SIZE_BITS_40_def) (* from bit_simps above, matches guard *) apply (drule intvlD) apply clarsimp apply (erule notE, rule intvlI) @@ -8156,6 +8299,14 @@ lemma insertNewCap_ccorres: apply (simp add: untypedZeroRange_def Let_def) done +lemma Arch_createObject_not_untyped: + "\s. \\\<^bsub>/UNIV\<^esub> + {s} Call Arch_createObject_'proc {t. cap_get_tag (ret__struct_cap_C_' t) \ scast cap_untyped_cap}" + apply (rule allI, rule conseqPre) + apply (vcg exspec=cleanCacheRange_PoU_modifies exspec=cleanCacheRange_RAM_modifies) + apply (clarsimp simp: cap_tag_defs vm_page_size_defs) + done + lemma createObject_untyped_region_is_zero_bytes: "\\. \\\<^bsub>/UNIV\<^esub> {s. let tp = (object_type_to_H (t_' s)); sz = APIType_capBits tp (unat (userSize_' s)) @@ -8167,7 +8318,7 @@ lemma createObject_untyped_region_is_zero_bytes: {t. cap_get_tag (ret__struct_cap_C_' t) = scast cap_untyped_cap \ (case untypedZeroRange (cap_to_H (the (cap_lift (ret__struct_cap_C_' t)))) of None \ True | Some (a, b) \ region_actually_is_zero_bytes a (unat ((b + 1) - a)) t)}" - apply (rule allI, rule conseqPre, vcg exspec=Arch_initContext_modifies) + apply (rule allI, rule conseqPre, vcg exspec=Arch_initContext_modifies exspec=Arch_createObject_not_untyped) apply (clarsimp simp: cap_tag_defs Let_def) apply (simp add: cap_lift_untyped_cap cap_tag_defs cap_to_H_simps cap_untyped_cap_lift_def object_type_from_H_def) diff --git a/proof/crefine/ARM/Invoke_C.thy b/proof/crefine/ARM/Invoke_C.thy index 9cccf1178e..c9efb80268 100644 --- a/proof/crefine/ARM/Invoke_C.thy +++ b/proof/crefine/ARM/Invoke_C.thy @@ -1517,45 +1517,37 @@ lemma clearMemory_untyped_ccorres: apply (cinit' lift: bits_' ptr___ptr_to_unsigned_long_') apply (rule_tac P="ptr \ 0 \ sz < word_bits" in ccorres_gen_asm) - apply (rule ccorres_Guard_Seq) + apply (rule ccorres_Guard) apply (simp add: clearMemory_def) - apply (simp add: doMachineOp_bind ef_storeWord) - apply (rule ccorres_split_nothrow_novcg_dc) - apply (rule_tac P="?P" and P'="{s. region_actually_is_bytes ptr (2 ^ sz) s}" - in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def - is_aligned_no_wrap'[OF _ word32_power_less_1] - unat_of_nat_eq word_bits_def) - apply (simp add: is_aligned_weaken is_aligned_triv[THEN is_aligned_weaken]) - apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] - region_actually_is_bytes_dom_s) - apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step - word_bits_def cte_wp_at_ctes_of) - apply (frule ctes_of_valid', clarify+) - apply (simp add: doMachineOp_def split_def exec_gets) - apply (simp add: select_f_def simpler_modify_def bind_def - valid_cap_simps' capAligned_def) - apply (subst pspace_no_overlap_underlying_zero_update, simp+) - apply (case_tac sz, simp_all)[1] - apply (case_tac nat, simp_all)[1] - apply (clarsimp dest!: region_actually_is_bytes) - apply (drule(1) rf_sr_rep0) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def) - apply csymbr - apply (ctac add: cleanCacheRange_RAM_ccorres) - apply wp - apply (simp add: guard_is_UNIV_def unat_of_nat - word_bits_def capAligned_def word_of_nat_less) + apply (rule_tac P="?P" and P'="{s. region_actually_is_bytes ptr (2 ^ sz) s}" in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def + is_aligned_no_wrap'[OF _ word32_power_less_1] + unat_of_nat_eq word_bits_def) + apply (simp add: is_aligned_weaken is_aligned_triv[THEN is_aligned_weaken]) + apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] + region_actually_is_bytes_dom_s) + apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step + word_bits_def cte_wp_at_ctes_of) + apply (frule ctes_of_valid', clarify+) + apply (simp add: doMachineOp_def split_def exec_gets) + apply (simp add: select_f_def simpler_modify_def bind_def + valid_cap_simps' capAligned_def) + apply (subst pspace_no_overlap_underlying_zero_update, simp+) + apply (case_tac sz, simp_all)[1] + apply (case_tac nat, simp_all)[1] + apply (clarsimp dest!: region_actually_is_bytes) + apply (drule(1) rf_sr_rep0) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (simp add: guard_is_UNIV_def unat_of_nat + word_bits_def capAligned_def word_of_nat_less) apply (clarsimp simp: cte_wp_at_ctes_of) apply (frule ctes_of_valid', clarify+) apply (clarsimp simp: isCap_simps valid_cap_simps' capAligned_def word_of_nat_less Kernel_Config.resetChunkBits_def word_bits_def unat_2p_sub_1) - apply (strengthen is_aligned_no_wrap'[where sz=sz] is_aligned_addrFromPPtr_n)+ - apply (simp add: addrFromPPtr_mask) apply (cases "ptr = 0") apply (drule subsetD, rule intvl_self, simp) apply (simp split: if_split_asm) diff --git a/proof/crefine/ARM/Retype_C.thy b/proof/crefine/ARM/Retype_C.thy index f72ef05c28..5e60b44e87 100644 --- a/proof/crefine/ARM/Retype_C.thy +++ b/proof/crefine/ARM/Retype_C.thy @@ -4533,6 +4533,40 @@ lemma cond_second_eq_seq_ccorres: apply (auto elim!: exec_Normal_elim_cases intro: exec.Seq exec.CondTrue exec.CondFalse) done +lemma placeNewDataObject_dev_ccorres: + "ccorresG rf_sr \ dc xfdc + (createObject_hs_preconds regionBase newType us True + and K (APIType_capBits newType us = pageBits + us)) + ({s. region_actually_is_bytes regionBase (2 ^ (pageBits + us)) s}) + hs + (placeNewDataObject regionBase us True) + (global_htd_update (\s. (ptr_retyps (2^us) (Ptr regionBase :: user_data_device_C ptr))))" + apply (simp add: placeNewDataObject_def ccorres_cond_univ_iff) + apply (rule ccorres_guard_imp, rule placeNewObject_user_data_device, simp_all) + apply (clarsimp simp: createObject_hs_preconds_def invs'_def + valid_state'_def valid_pspace'_def) + done + +lemma placeNewDataObject_no_dev_ccorres: + "ccorresG rf_sr \ dc xfdc + (createObject_hs_preconds regionBase newType us False + and K (APIType_capBits newType us = pageBits + us)) + ({s. region_actually_is_bytes regionBase (2 ^ (pageBits + us)) s + \ (heap_list_is_zero (hrs_mem (t_hrs_' (globals s))) regionBase (2 ^ (pageBits + us)))}) + hs + (placeNewDataObject regionBase us False) + (global_htd_update (\s. (ptr_retyps (2^us) (Ptr regionBase :: user_data_C ptr))))" + apply (simp add: placeNewDataObject_def ccorres_cond_empty_iff) + apply (rule ccorres_guard_imp, rule placeNewObject_user_data, simp_all) + apply (clarsimp simp: createObject_hs_preconds_def invs'_def + valid_state'_def valid_pspace'_def) + apply (frule range_cover.sz(1), simp add: word_bits_def) + done + +crunch placeNewDataObject + for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" + (simp: crunch_simps) + lemma Arch_createObject_ccorres: assumes t: "toAPIType newType = None" shows "ccorres (\a b. ccap_relation (ArchObjectCap a) b) ret__struct_cap_C_' @@ -4552,179 +4586,288 @@ proof - apply (frule range_cover.aligned) apply (cut_tac t) apply (case_tac newType, - simp_all add: toAPIType_def - bind_assoc - ARMLargePageBits_def) + simp_all add: toAPIType_def bind_assoc ARMLargePageBits_def) + apply (in_case "SmallPageObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_H.createObject_def pageBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=0 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_small_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs) - - \ \Page objects: could possibly fix the duplication here\ + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + ARM_H.createObject_def pageBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=0 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_small_frame_cap_lift + vmrights_to_H_def vm_rights_defs, + simp add: mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=0 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_small_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + vm_page_size_defs) + apply (simp add: mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_5) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + + apply (in_case "LargePageObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_H.createObject_def pageBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=4 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs vm_page_size_defs - cl_valid_cap_def c_valid_cap_def - is_aligned_neg_mask_eq_concrete[THEN sym]) - + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + ARM_H.createObject_def pageBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=4 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=4 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_5) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + + apply (in_case "SectionObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_H.createObject_def pageBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=8 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs vm_page_size_defs - cl_valid_cap_def c_valid_cap_def - is_aligned_neg_mask_eq_concrete[THEN sym]) + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + ARM_H.createObject_def pageBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=8 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=8 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_5) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + apply (in_case "SuperSectionObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_H.createObject_def pageBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=12 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs vm_page_size_defs - cl_valid_cap_def c_valid_cap_def - is_aligned_neg_mask_eq_concrete[THEN sym]) - - \ \PageTableObject\ + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + ARM_H.createObject_def pageBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=12 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=12 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_5) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + + apply (in_case "PageTableObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) - apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def) - apply (ccorres_remove_UNIV_guard) + apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff asidInvalid_def + APIType_capBits_def shiftL_nat objBits_simps + ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def) apply (rule ccorres_rhs_assoc)+ apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_H.createObject_def pageBits_def) + ARM_H.createObject_def pageBits_def pt_bits_def) apply (ctac pre only: add: placeNewObject_pte[simplified]) apply csymbr - apply (rule ccorres_return_C) - apply simp - apply simp - apply simp + apply (ctac (no_vcg) add: cleanCacheRange_PoU_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp apply wp apply vcg apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_valid_objs' - invs_urz) - apply clarsimp - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_page_table_cap_lift - is_aligned_neg_mask_eq vmrights_to_H_def - Kernel_C.VMReadWrite_def Kernel_C.VMNoAccess_def - Kernel_C.VMKernelOnly_def Kernel_C.VMReadOnly_def) - apply (simp add: isFrameType_def) - - \ \PageDirectoryObject\ + APIType_capBits_def invs_valid_objs' is_aligned_no_overflow_mask + invs_urz addrFromPPtr_mask_5 pteBits_def) + apply (rule conjI, simp add: mask_def) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (clarsimp simp: ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_page_table_cap_lift + vmrights_to_H_def pteBits_def vmrights_defs) + apply (clarsimp simp: isFrameType_def mask_def is_aligned_neg_mask_eq_concrete[THEN sym]) + + apply (in_case "PageDirectoryObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - asidInvalid_def sle_positive APIType_capBits_def shiftL_nat - objBits_simps archObjSize_def - ptBits_def pageBits_def pdBits_def word_sle_def word_sless_def) - apply (ccorres_remove_UNIV_guard) + asidInvalid_def APIType_capBits_def shiftL_nat + objBits_simps archObjSize_def isFrameType_def + ptBits_def pageBits_def pdBits_def word_sle_def word_sless_def) apply (rule ccorres_rhs_assoc)+ apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_H.createObject_def pageBits_def pdBits_def) + ARM_H.createObject_def pageBits_def pdBits_def pd_bits_def) apply (ctac pre only: add: placeNewObject_pde[simplified]) apply (ctac add: copyGlobalMappings_ccorres) apply csymbr apply (ctac add: cleanCacheRange_PoU_ccorres) apply csymbr - apply (rule ccorres_return_C) - apply simp - apply simp - apply simp + apply (rule ccorres_return_C; simp) apply wp apply clarsimp apply vcg apply wp apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_page_directory_cap_lift - is_aligned_neg_mask_eq vmrights_to_H_def - Kernel_C.VMReadWrite_def Kernel_C.VMNoAccess_def - Kernel_C.VMKernelOnly_def Kernel_C.VMReadOnly_def) + framesize_to_H_def cap_to_H_simps cap_page_directory_cap_lift + vmrights_to_H_def vm_rights_defs) apply (vcg exspec=copyGlobalMappings_modifies) apply (clarsimp simp:placeNewObject_def2) apply (wp createObjects'_pde_mappings' createObjects'_page_directory_at_global[where sz=pdBits] @@ -4732,20 +4875,23 @@ proof - apply clarsimp apply vcg apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' - archObjSize_def invs_valid_global' makeObject_pde pdBits_def - pageBits_def range_cover.aligned projectKOs APIType_capBits_def - object_type_from_H_def objBits_simps pdeBits_def - invs_valid_objs' isFrameType_def) + archObjSize_def invs_valid_global' makeObject_pde pdBits_def + pageBits_def range_cover.aligned projectKOs APIType_capBits_def + object_type_from_H_def objBits_simps pdeBits_def + invs_valid_objs' isFrameType_def) apply (frule invs_arch_state') apply (frule range_cover.aligned) apply (frule is_aligned_addrFromPPtr_n, simp) apply (intro conjI, simp_all) - apply fastforce - apply fastforce - apply (clarsimp simp: pageBits_def pdeBits_def - valid_arch_state'_def page_directory_at'_def pdBits_def) - apply (clarsimp simp: is_aligned_no_overflow'[where n=14, simplified] pdeBits_def - field_simps is_aligned_mask[symmetric] mask_AND_less_0)+ + apply fastforce + apply fastforce + apply (clarsimp simp: valid_arch_state'_def page_directory_at'_def) + apply (simp add: mask_def) + apply (simp add: is_aligned_no_overflow_mask) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (clarsimp simp: is_aligned_mask[symmetric] mask_AND_less_0) + apply (clarsimp simp: mask_def) done qed @@ -6470,6 +6616,43 @@ lemma cleanCacheRange_PoU_preserves_bytes: elim!: byte_regions_unmodified_trans byte_regions_unmodified_trans[rotated], (simp_all add: h_t_valid_field)+) +lemma cleanByVA_preserves_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanByVA_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" + apply (rule allI, rule conseqPost, rule cleanByVA_preserves_kernel_bytes[rule_format]) + apply simp_all + apply (clarsimp simp: byte_regions_unmodified_def) + done + +lemma cleanCacheRange_PoC_preserves_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_PoC_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" + apply (hoare_rule HoarePartial.ProcNoRec1) + apply (clarsimp simp only: whileAnno_def) + apply (subst whileAnno_def[symmetric, where V=undefined + and I="{t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" for s]) + apply (rule conseqPre, vcg exspec=cleanByVA_preserves_bytes) + by (safe intro!: byte_regions_unmodified_hrs_mem_update + elim!: byte_regions_unmodified_trans byte_regions_unmodified_trans[rotated], + (simp_all add: h_t_valid_field)+) + +lemma cleanCacheRange_RAM_preserves_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_RAM_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" + apply (hoare_rule HoarePartial.ProcNoRec1, rule allI) + apply (rule conseqPre, vcg exspec=cleanCacheRange_PoC_preserves_bytes + exspec=cleanL2Range_preserves_kernel_bytes + exspec=dsb_preserves_kernel_bytes) + apply (safe intro!: byte_regions_unmodified_hrs_mem_update + elim!: byte_regions_unmodified_trans byte_regions_unmodified_trans[rotated], + (simp_all add: h_t_valid_field)+) + apply (clarsimp simp: byte_regions_unmodified_def) + done + lemma hrs_htd_update_canon: "hrs_htd_update (\_. f (hrs_htd hrs)) hrs = hrs_htd_update f hrs" by (cases hrs, simp add: hrs_htd_update_def hrs_htd_def) @@ -6488,15 +6671,18 @@ lemma Arch_createObject_preserves_bytes: exspec=copyGlobalMappings_preserves_bytes exspec=addrFromPPtr_modifies exspec=cleanCacheRange_PoU_preserves_bytes - exspec=cap_page_directory_cap_new_modifies) + exspec=cleanCacheRange_RAM_preserves_bytes + exspec=cap_page_directory_cap_new_modifies) find_names ARMSmallPage_def apply (safe intro!: byte_regions_unmodified_hrs_mem_update, (simp_all add: h_t_valid_field hrs_htd_update)+) - apply (safe intro!: ptr_retyp_d ptr_retyps_out) - apply (simp_all add: object_type_from_H_def Kernel_C_defs APIType_capBits_def - split: object_type.split_asm apiobject_type.split_asm) - apply (rule byte_regions_unmodified_flip, simp) - apply (rule byte_regions_unmodified_trans[rotated], - assumption, simp_all add: hrs_htd_update_canon hrs_htd_update) + apply (safe intro!: ptr_retyp_d ptr_retyps_out) + apply (simp_all add: object_type_from_H_def Kernel_C_defs APIType_capBits_def + vm_page_size_defs + split: object_type.split_asm apiobject_type.split_asm) + apply (all \(solves \simp add: mask_def\)?\) + apply (rule byte_regions_unmodified_flip, simp, + rule byte_regions_unmodified_trans[rotated], assumption; + simp add: hrs_htd_update_canon hrs_htd_update)+ done lemma ptr_arr_retyps_eq_outside_dom: @@ -6646,6 +6832,16 @@ lemma insertNewCap_ccorres: apply (simp add: untypedZeroRange_def Let_def) done +lemma Arch_createObject_not_untyped: + "\s. \\\<^bsub>/UNIV\<^esub> + {s} Call Arch_createObject_'proc {t. cap_get_tag (ret__struct_cap_C_' t) \ scast cap_untyped_cap}" + apply (rule allI, rule conseqPre) + apply (vcg exspec=cleanCacheRange_PoU_modifies + exspec=cleanCacheRange_RAM_modifies + exspec=copyGlobalMappings_modifies) + apply (clarsimp simp: cap_tag_defs vm_page_size_defs mask_def) + done + lemma createObject_untyped_region_is_zero_bytes: "\\. \\\<^bsub>/UNIV\<^esub> {s. let tp = (object_type_to_H (t_' s)); sz = APIType_capBits tp (unat (userSize_' s)) @@ -6657,9 +6853,8 @@ lemma createObject_untyped_region_is_zero_bytes: {t. cap_get_tag (ret__struct_cap_C_' t) = scast cap_untyped_cap \ (case untypedZeroRange (cap_to_H (the (cap_lift (ret__struct_cap_C_' t)))) of None \ True | Some (a, b) \ region_actually_is_zero_bytes a (unat ((b + 1) - a)) t)}" - apply (rule allI, rule conseqPre, vcg exspec=copyGlobalMappings_modifies - exspec=Arch_initContext_modifies - exspec=cleanCacheRange_PoU_modifies) + apply (rule allI, rule conseqPre, + vcg exspec=Arch_createObject_not_untyped exspec=Arch_initContext_modifies) apply (clarsimp simp: cap_tag_defs) apply (simp add: cap_lift_untyped_cap cap_tag_defs cap_to_H_simps cap_untyped_cap_lift_def object_type_from_H_def) diff --git a/proof/crefine/ARM_HYP/Invoke_C.thy b/proof/crefine/ARM_HYP/Invoke_C.thy index 103d13b238..ae98d1e6ea 100644 --- a/proof/crefine/ARM_HYP/Invoke_C.thy +++ b/proof/crefine/ARM_HYP/Invoke_C.thy @@ -1677,45 +1677,37 @@ lemma clearMemory_untyped_ccorres: apply (cinit' lift: bits_' ptr___ptr_to_unsigned_long_') apply (rule_tac P="ptr \ 0 \ sz < word_bits" in ccorres_gen_asm) - apply (rule ccorres_Guard_Seq) + apply (rule ccorres_Guard) apply (simp add: clearMemory_def) - apply (simp add: doMachineOp_bind ef_storeWord) - apply (rule ccorres_split_nothrow_novcg_dc) - apply (rule_tac P="?P" and P'="{s. region_actually_is_bytes ptr (2 ^ sz) s}" - in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def - is_aligned_no_wrap'[OF _ word32_power_less_1] - unat_of_nat_eq word_bits_def) - apply (simp add: is_aligned_weaken is_aligned_triv[THEN is_aligned_weaken]) - apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] - region_actually_is_bytes_dom_s) - apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step - word_bits_def cte_wp_at_ctes_of) - apply (frule ctes_of_valid', clarify+) - apply (simp add: doMachineOp_def split_def exec_gets) - apply (simp add: select_f_def simpler_modify_def bind_def - valid_cap_simps' capAligned_def) - apply (subst pspace_no_overlap_underlying_zero_update, simp+) - apply (case_tac sz, simp_all)[1] - apply (case_tac nat, simp_all)[1] - apply (clarsimp dest!: region_actually_is_bytes) - apply (drule(1) rf_sr_rep0) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def) - apply csymbr - apply (ctac add: cleanCacheRange_RAM_ccorres) - apply wp - apply (simp add: guard_is_UNIV_def unat_of_nat - word_bits_def capAligned_def word_of_nat_less) + apply (rule_tac P="?P" and P'="{s. region_actually_is_bytes ptr (2 ^ sz) s}" in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def + is_aligned_no_wrap'[OF _ word32_power_less_1] + unat_of_nat_eq word_bits_def) + apply (simp add: is_aligned_weaken is_aligned_triv[THEN is_aligned_weaken]) + apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] + region_actually_is_bytes_dom_s) + apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step + word_bits_def cte_wp_at_ctes_of) + apply (frule ctes_of_valid', clarify+) + apply (simp add: doMachineOp_def split_def exec_gets) + apply (simp add: select_f_def simpler_modify_def bind_def + valid_cap_simps' capAligned_def) + apply (subst pspace_no_overlap_underlying_zero_update, simp+) + apply (case_tac sz, simp_all)[1] + apply (case_tac nat, simp_all)[1] + apply (clarsimp dest!: region_actually_is_bytes) + apply (drule(1) rf_sr_rep0) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (simp add: guard_is_UNIV_def unat_of_nat + word_bits_def capAligned_def word_of_nat_less) apply (clarsimp simp: cte_wp_at_ctes_of) apply (frule ctes_of_valid', clarify+) apply (clarsimp simp: isCap_simps valid_cap_simps' capAligned_def word_of_nat_less Kernel_Config.resetChunkBits_def word_bits_def unat_2p_sub_1) - apply (strengthen is_aligned_no_wrap'[where sz=sz] is_aligned_addrFromPPtr_n)+ - apply (simp add: addrFromPPtr_mask) apply (cases "ptr = 0") apply (drule subsetD, rule intvl_self, simp) apply (simp split: if_split_asm) diff --git a/proof/crefine/ARM_HYP/Machine_C.thy b/proof/crefine/ARM_HYP/Machine_C.thy index 2ad8e55adf..4edaf89d5f 100644 --- a/proof/crefine/ARM_HYP/Machine_C.thy +++ b/proof/crefine/ARM_HYP/Machine_C.thy @@ -224,7 +224,7 @@ assumes getFAR_ccorres: (doMachineOp getFAR) (Call getFAR_'proc)" -(* FIXME ARMHYP double-check this, assumption is ccorres holds regardless of in_kernel *) +(* assumption is ccorres holds regardless of in_kernel *) assumes getActiveIRQ_ccorres: "\in_kernel. ccorres (\(a::irq option) c::machine_word. diff --git a/proof/crefine/ARM_HYP/Recycle_C.thy b/proof/crefine/ARM_HYP/Recycle_C.thy index f6e39812f7..2db441b729 100644 --- a/proof/crefine/ARM_HYP/Recycle_C.thy +++ b/proof/crefine/ARM_HYP/Recycle_C.thy @@ -264,121 +264,109 @@ lemma clearMemory_PageCap_ccorres: apply (cinit' lift: bits_' ptr___ptr_to_unsigned_long_') apply (rule_tac P="capAligned (ArchObjectCap (PageCap False ptr undefined sz None))" in ccorres_gen_asm) - apply (rule ccorres_Guard_Seq) + apply (rule ccorres_Guard) apply (simp add: clearMemory_def) - apply (simp add: doMachineOp_bind ef_storeWord) - apply (rule ccorres_split_nothrow_novcg_dc) - apply (rule_tac P="?P" in ccorres_from_vcg[where P'=UNIV]) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: valid_cap'_def capAligned_def - is_aligned_no_wrap'[OF _ word32_power_less_1]) - apply (subgoal_tac "2 \ pageBitsForSize sz") - prefer 2 - apply (simp add: pageBitsForSize_def split: vmpage_size.split) - apply (rule conjI) - apply (erule is_aligned_weaken) - apply (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits) - apply (rule conjI) - apply (rule is_aligned_power2) - apply (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits) - apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def]) - apply (simp add: flex_user_data_at_rf_sr_dom_s) - apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step) - apply (simp add: doMachineOp_def split_def exec_gets) - apply (simp add: select_f_def simpler_modify_def bind_def) - apply (fold replicateHider_def)[1] - apply (subst coerce_heap_update_to_heap_updates' - [where chunk=4096 and m="2 ^ (pageBitsForSize sz - pageBits)"]) - apply (simp add: pageBitsForSize_def pageBits_def - split: vmpage_size.split) - apply (subst coerce_memset_to_heap_update_user_data) - apply (subgoal_tac "\p<2 ^ (pageBitsForSize sz - pageBits). - x \\<^sub>c (Ptr (ptr + of_nat p * 0x1000) :: user_data_C ptr)") - prefer 2 - apply (erule allfEI[where f=of_nat]) - apply clarsimp - apply (subst(asm) of_nat_power, assumption) - apply simp - apply (insert pageBitsForSize_32 [of sz])[1] - apply (erule order_le_less_trans [rotated]) - apply simp - apply (simp, drule ko_at_projectKO_opt[OF user_data_at_ko]) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cpspace_relation_def) - apply (erule cmap_relationE1, simp(no_asm) add: heap_to_user_data_def Let_def) - apply fastforce - subgoal by (simp add: pageBits_def typ_heap_simps) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) - apply (clarsimp simp: cpspace_relation_def typ_heap_simps - clift_foldl_hrs_mem_update foldl_id - carch_state_relation_def - cmachine_state_relation_def - foldl_fun_upd_const[unfolded fun_upd_def] - power_user_page_foldl_zero_ranges - dom_heap_to_device_data) - apply (rule conjI[rotated]) - apply (simp add:pageBitsForSize_mess_multi) - apply (rule cmap_relationI) - apply (clarsimp simp: dom_heap_to_device_data cmap_relation_def) - apply (simp add:cuser_user_data_device_relation_def) - apply (subst help_force_intvl_range_conv, assumption) - subgoal by (simp add: pageBitsForSize_def split: vmpage_size.split) - apply assumption - apply (subst heap_to_user_data_update_region) - apply (drule map_to_user_data_aligned, clarsimp) - apply (rule aligned_range_offset_mem[where m=pageBits], simp_all)[1] - apply (rule pbfs_atleast_pageBits) - apply (erule cmap_relation_If_upd) - apply (clarsimp simp: cuser_user_data_relation_def order_less_le_trans[OF unat_lt2p]) - apply (simp add: update_ti_t_word32_0s) - apply (rule image_cong[OF _ refl]) - apply (rule set_eqI, rule iffI) - apply (clarsimp simp del: atLeastAtMost_iff) - apply (drule map_to_user_data_aligned, clarsimp) - apply (simp only: mask_in_range[symmetric]) - apply (rule_tac x="unat ((xa && mask (pageBitsForSize sz)) >> pageBits)" in image_eqI) - apply (simp add: subtract_mask(2)[symmetric]) - apply (cut_tac w="xa - ptr" and n=pageBits in and_not_mask[symmetric]) - apply (simp add: shiftl_t2n field_simps pageBits_def) - apply (subst is_aligned_neg_mask_eq, simp_all)[1] - apply (erule aligned_sub_aligned, simp_all add: word_bits_def)[1] - apply (erule is_aligned_weaken) - apply (rule pbfs_atleast_pageBits[unfolded pageBits_def]) - apply simp - apply (rule unat_less_power) - apply (fold word_bits_def, simp) - apply (rule shiftr_less_t2n) - apply (simp add: pbfs_atleast_pageBits) - apply (rule and_mask_less_size) - apply (simp add: word_bits_def word_size) - apply (rule IntI) - apply (clarsimp simp del: atLeastAtMost_iff) - apply (subst aligned_range_offset_mem, assumption, simp_all)[1] - apply (rule order_le_less_trans[rotated], erule shiftl_less_t2n [OF of_nat_power], - simp_all add: word_bits_def)[1] - apply (insert pageBitsForSize_32 [of sz])[1] - apply (erule order_le_less_trans [rotated]) - subgoal by simp - subgoal by (simp add: pageBits_def shiftl_t2n field_simps) - apply clarsimp - apply (drule_tac x="of_nat n" in spec) - apply (simp add: of_nat_power[where 'a=32, folded word_bits_def]) - apply (rule exI) - subgoal by (simp add: pageBits_def ko_at_projectKO_opt[OF user_data_at_ko]) + apply (rule_tac P="?P" in ccorres_from_vcg[where P'=UNIV]) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: valid_cap'_def capAligned_def + is_aligned_no_wrap'[OF _ word32_power_less_1]) + apply (prop_tac "ptr \ 0", simp) + apply simp + apply (prop_tac "2 \ pageBitsForSize sz") + apply (simp add: pageBitsForSize_def split: vmpage_size.split) + apply (rule conjI) + apply (erule is_aligned_weaken, simp) + apply (rule conjI) + apply (rule is_aligned_power2, simp) + apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def]) + apply (simp add: flex_user_data_at_rf_sr_dom_s) + apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step) + apply (simp add: doMachineOp_def split_def exec_gets) + apply (simp add: select_f_def simpler_modify_def bind_def) + apply (fold replicateHider_def)[1] + apply (subst coerce_heap_update_to_heap_updates' + [where chunk=4096 and m="2 ^ (pageBitsForSize sz - pageBits)"]) + apply (simp add: pageBitsForSize_def pageBits_def + split: vmpage_size.split) + apply (subst coerce_memset_to_heap_update_user_data) + apply (subgoal_tac "\p<2 ^ (pageBitsForSize sz - pageBits). + x \\<^sub>c (Ptr (ptr + of_nat p * 0x1000) :: user_data_C ptr)") + prefer 2 + apply (erule allfEI[where f=of_nat]) + apply clarsimp + apply (subst(asm) of_nat_power, assumption) + apply simp + apply (insert pageBitsForSize_32 [of sz])[1] + apply (erule order_le_less_trans [rotated]) + apply simp + apply (simp, drule ko_at_projectKO_opt[OF user_data_at_ko]) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cpspace_relation_def) + apply (erule cmap_relationE1, simp(no_asm) add: heap_to_user_data_def Let_def) + apply fastforce + subgoal by (simp add: pageBits_def typ_heap_simps) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) + apply (clarsimp simp: cpspace_relation_def typ_heap_simps + clift_foldl_hrs_mem_update foldl_id + carch_state_relation_def + cmachine_state_relation_def + foldl_fun_upd_const[unfolded fun_upd_def] + power_user_page_foldl_zero_ranges + dom_heap_to_device_data) + apply (rule conjI[rotated]) + apply (simp add:pageBitsForSize_mess_multi) + apply (rule cmap_relationI) + apply (clarsimp simp: dom_heap_to_device_data cmap_relation_def) + apply (simp add:cuser_user_data_device_relation_def) + apply (subst help_force_intvl_range_conv, assumption) + subgoal by (simp add: pageBitsForSize_def split: vmpage_size.split) + apply assumption + apply (subst heap_to_user_data_update_region) + apply (drule map_to_user_data_aligned, clarsimp) + apply (rule aligned_range_offset_mem[where m=pageBits], simp_all)[1] + apply (rule pbfs_atleast_pageBits) + apply (erule cmap_relation_If_upd) + apply (clarsimp simp: cuser_user_data_relation_def order_less_le_trans[OF unat_lt2p]) + apply (simp add: update_ti_t_word32_0s) + apply (rule image_cong[OF _ refl]) + apply (rule set_eqI, rule iffI) + apply (clarsimp simp del: atLeastAtMost_iff) + apply (drule map_to_user_data_aligned, clarsimp) + apply (simp only: mask_in_range[symmetric]) + apply (rule_tac x="unat ((xa && mask (pageBitsForSize sz)) >> pageBits)" in image_eqI) + apply (simp add: subtract_mask(2)[symmetric]) + apply (cut_tac w="xa - ptr" and n=pageBits in and_not_mask[symmetric]) + apply (simp add: shiftl_t2n field_simps pageBits_def) + apply (subst is_aligned_neg_mask_eq, simp_all)[1] + apply (erule aligned_sub_aligned, simp_all add: word_bits_def)[1] + apply (erule is_aligned_weaken) + apply (rule pbfs_atleast_pageBits[unfolded pageBits_def]) + apply simp + apply (rule unat_less_power) + apply (fold word_bits_def, simp) + apply (rule shiftr_less_t2n) + apply (simp add: pbfs_atleast_pageBits) + apply (rule and_mask_less_size) + apply (simp add: word_bits_def word_size) + apply (rule IntI) + apply (clarsimp simp del: atLeastAtMost_iff) + apply (subst aligned_range_offset_mem, assumption, simp_all)[1] + apply (rule order_le_less_trans[rotated], erule shiftl_less_t2n [OF of_nat_power], + simp_all add: word_bits_def)[1] + apply (insert pageBitsForSize_32 [of sz])[1] + apply (erule order_le_less_trans [rotated]) subgoal by simp - apply csymbr - apply (ctac add: cleanCacheRange_RAM_ccorres) - apply wp - apply (simp add: guard_is_UNIV_def unat_of_nat - word_bits_def capAligned_def word_of_nat_less) + subgoal by (simp add: pageBits_def shiftl_t2n field_simps) + apply clarsimp + apply (drule_tac x="of_nat n" in spec) + apply (simp add: of_nat_power[where 'a=32, folded word_bits_def]) + apply (rule exI) + subgoal by (simp add: pageBits_def ko_at_projectKO_opt[OF user_data_at_ko]) + subgoal by simp + apply (simp add: guard_is_UNIV_def unat_of_nat + word_bits_def capAligned_def word_of_nat_less) apply (clarsimp simp: word_bits_def valid_cap'_def capAligned_def word_of_nat_less) - apply (frule is_aligned_addrFromPPtr_n, simp add: pageBitsForSize_def split: vmpage_size.splits) - by (clarsimp simp: is_aligned_no_overflow'[where n=12, simplified] - is_aligned_no_overflow'[where n=16, simplified] - is_aligned_no_overflow'[where n=21, simplified] - is_aligned_no_overflow'[where n=25, simplified] pageBits_def - is_aligned_mask[symmetric] mask_AND_less_0 - pageBitsForSize_def split: vmpage_size.splits) + done lemma coerce_memset_to_heap_update_asidpool: "heap_update_list x (replicateHider 4096 0) diff --git a/proof/crefine/ARM_HYP/Retype_C.thy b/proof/crefine/ARM_HYP/Retype_C.thy index be5ff3990e..4395fcfb03 100644 --- a/proof/crefine/ARM_HYP/Retype_C.thy +++ b/proof/crefine/ARM_HYP/Retype_C.thy @@ -5676,6 +5676,40 @@ lemma placeNewObject_vcpu_ccorres: apply fastforce done +lemma placeNewDataObject_dev_ccorres: + "ccorresG rf_sr \ dc xfdc + (createObject_hs_preconds regionBase newType us True + and K (APIType_capBits newType us = pageBits + us)) + ({s. region_actually_is_bytes regionBase (2 ^ (pageBits + us)) s}) + hs + (placeNewDataObject regionBase us True) + (global_htd_update (\s. (ptr_retyps (2^us) (Ptr regionBase :: user_data_device_C ptr))))" + apply (simp add: placeNewDataObject_def ccorres_cond_univ_iff) + apply (rule ccorres_guard_imp, rule placeNewObject_user_data_device, simp_all) + apply (clarsimp simp: createObject_hs_preconds_def invs'_def + valid_state'_def valid_pspace'_def) + done + +lemma placeNewDataObject_no_dev_ccorres: + "ccorresG rf_sr \ dc xfdc + (createObject_hs_preconds regionBase newType us False + and K (APIType_capBits newType us = pageBits + us)) + ({s. region_actually_is_bytes regionBase (2 ^ (pageBits + us)) s + \ (heap_list_is_zero (hrs_mem (t_hrs_' (globals s))) regionBase (2 ^ (pageBits + us)))}) + hs + (placeNewDataObject regionBase us False) + (global_htd_update (\s. (ptr_retyps (2^us) (Ptr regionBase :: user_data_C ptr))))" + apply (simp add: placeNewDataObject_def ccorres_cond_empty_iff) + apply (rule ccorres_guard_imp, rule placeNewObject_user_data, simp_all) + apply (clarsimp simp: createObject_hs_preconds_def invs'_def + valid_state'_def valid_pspace'_def) + apply (frule range_cover.sz(1), simp add: word_bits_def) + done + +crunch placeNewDataObject + for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" + (simp: crunch_simps) + lemma Arch_createObject_ccorres: assumes t: "toAPIType newType = None" notes is_aligned_neg_mask_eq[simp del] @@ -5698,173 +5732,289 @@ proof - apply (cut_tac t) apply (case_tac newType, simp_all add: toAPIType_def bind_assoc ARMLargePageBits_def) - apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') - apply (simp add: object_type_from_H_def Kernel_C_defs) - apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_HYP_H.createObject_def pageBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=0 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_small_frame_cap_lift - vmrights_to_H_def vm_rights_defs is_aligned_neg_mask_eq, - simp add: mask_def) - - \ \Page objects: could possibly fix the duplication here\ + apply (in_case "SmallPageObject") + apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') + apply (simp add: object_type_from_H_def Kernel_C_defs) + apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + ARM_HYP_H.createObject_def pageBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=0 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_small_frame_cap_lift + vmrights_to_H_def vm_rights_defs is_aligned_neg_mask_eq, + simp add: mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=0 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_small_frame_cap_lift + vmrights_to_H_def vm_rights_defs is_aligned_neg_mask_eq gen_framesize_to_H_def + vm_page_size_defs) + apply (simp add: mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_6) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + + apply (in_case "LargePageObject") + apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') + apply (simp add: object_type_from_H_def Kernel_C_defs) + apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + ARM_HYP_H.createObject_def pageBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=4 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=4 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_6) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + + apply (in_case "SectionObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps ARM_HYP_H.createObject_def pageBits_def cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=4 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs vm_page_size_defs - cl_valid_cap_def c_valid_cap_def - is_aligned_neg_mask_eq_concrete[THEN sym]) - + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=9 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=9 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_6) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + + apply (in_case "SuperSectionObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps ARM_HYP_H.createObject_def pageBits_def cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=9 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs vm_page_size_defs - cl_valid_cap_def c_valid_cap_def - is_aligned_neg_mask_eq_concrete[THEN sym]) + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=13 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=13 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_6) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + apply (in_case "PageTableObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) - apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) + apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff asidInvalid_def + APIType_capBits_def shiftL_nat objBits_simps + ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def) + apply (rule ccorres_rhs_assoc)+ apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_HYP_H.createObject_def pageBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=13 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] + ARM_HYP_H.createObject_def pageBits_def pt_bits_def pte_bits_def) + apply (ctac pre only: add: placeNewObject_pte[simplified]) + apply csymbr + apply (ctac (no_vcg) add: cleanCacheRange_PoU_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply vcg + apply clarify apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) + apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' + APIType_capBits_def invs_valid_objs' is_aligned_no_overflow_mask + invs_urz addrFromPPtr_mask_6) + apply (rule conjI, simp add: mask_def) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply clarsimp apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs vm_page_size_defs - cl_valid_cap_def c_valid_cap_def - is_aligned_neg_mask_eq_concrete[THEN sym]) + framesize_to_H_def cap_to_H_simps cap_page_table_cap_lift + is_aligned_neg_mask_eq vmrights_to_H_def + Kernel_C.VMReadWrite_def Kernel_C.VMNoAccess_def + Kernel_C.VMKernelOnly_def Kernel_C.VMReadOnly_def) + apply (clarsimp simp: isFrameType_def mask_def is_aligned_neg_mask_eq_concrete[THEN sym]) - \ \PageTableObject\ + apply (in_case "PageDirectoryObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def) - apply (ccorres_remove_UNIV_guard) + asidInvalid_def APIType_capBits_def shiftL_nat + objBits_simps archObjSize_def isFrameType_def + ptBits_def pageBits_def pdBits_def word_sle_def word_sless_def) apply (rule ccorres_rhs_assoc)+ apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_HYP_H.createObject_def pageBits_def pt_bits_def) - apply (ctac pre only: add: placeNewObject_pte[simplified]) - apply csymbr - apply (rule ccorres_return_C) - apply simp - apply simp - apply simp - apply wp - apply vcg - apply clarify - apply (intro conjI) - apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_valid_objs' - invs_urz) - apply clarsimp - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_page_table_cap_lift - is_aligned_neg_mask_eq vmrights_to_H_def - Kernel_C.VMReadWrite_def Kernel_C.VMNoAccess_def - Kernel_C.VMKernelOnly_def Kernel_C.VMReadOnly_def) - apply (clarsimp simp: isFrameType_def) - apply (rule sym) - apply (simp add: is_aligned_neg_mask_eq'[symmetric] is_aligned_weaken) - - \ \PageDirectoryObject\ - apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') - apply (simp add: object_type_from_H_def Kernel_C_defs) - apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - asidInvalid_def sle_positive APIType_capBits_def shiftL_nat - objBits_simps archObjSize_def - ptBits_def pageBits_def pdBits_def word_sle_def word_sless_def) - apply (ccorres_remove_UNIV_guard) - apply (rule ccorres_rhs_assoc)+ - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_HYP_H.createObject_def pageBits_def pdBits_def pd_bits_def) - apply (ctac pre only: add: placeNewObject_pde[simplified]) - apply (ctac add: copyGlobalMappings_ccorres) - apply csymbr - apply (ctac add: cleanCacheRange_PoU_ccorres) - apply csymbr - apply (rule ccorres_return_C) + ARM_HYP_H.createObject_def pageBits_def pdBits_def pd_bits_def) + apply (ctac pre only: add: placeNewObject_pde[simplified]) + apply (ctac add: copyGlobalMappings_ccorres) + apply csymbr + apply (ctac add: cleanCacheRange_PoU_ccorres) + apply csymbr + apply (rule ccorres_return_C) + apply simp apply simp apply simp - apply simp - apply wp - apply clarsimp - apply vcg - apply wp + apply wp + apply clarsimp + apply vcg + apply wp apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def framesize_to_H_def cap_to_H_simps cap_page_directory_cap_lift is_aligned_neg_mask_eq vmrights_to_H_def @@ -5884,16 +6034,20 @@ proof - apply (frule invs_arch_state') apply (frule range_cover.aligned) apply (frule is_aligned_addrFromPPtr_n, simp) - apply (intro conjI, simp_all add: table_bits_defs)[1] - apply fastforce - apply ((clarsimp simp: is_aligned_no_overflow'[where n=14, simplified] - field_simps is_aligned_mask[symmetric] mask_AND_less_0)+)[3] + apply (intro conjI, simp_all add: table_bits_defs)[1] + apply fastforce + apply (clarsimp simp: mask_def) + apply (simp add: is_aligned_no_overflow_mask) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (clarsimp simp: is_aligned_mask[symmetric] mask_AND_less_0) + apply (simp add: mask_def) \ \VCPU\ apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply ccorres_rewrite apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - asidInvalid_def sle_positive APIType_capBits_def shiftL_nat + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps archObjSize_def word_sle_def word_sless_def) apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def ARM_HYP_H.createObject_def pageBits_def pdBits_def) @@ -7808,6 +7962,43 @@ lemma cleanCacheRange_PoU_preserves_bytes: elim!: byte_regions_unmodified_trans byte_regions_unmodified_trans[rotated], (simp_all add: h_t_valid_field)+) +lemma cleanByVA_preserves_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanByVA_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" + apply (rule allI, rule conseqPost, rule cleanByVA_preserves_kernel_bytes[rule_format]) + apply simp_all + apply (clarsimp simp: byte_regions_unmodified_def) + done + +lemma cleanCacheRange_PoC_preserves_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_PoC_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" + apply (hoare_rule HoarePartial.ProcNoRec1) + apply (clarsimp simp only: whileAnno_def) + apply (subst whileAnno_def[symmetric, where V=undefined + and I="{t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" for s]) + apply (rule conseqPre, vcg exspec=cleanByVA_preserves_bytes) + by (safe intro!: byte_regions_unmodified_hrs_mem_update + elim!: byte_regions_unmodified_trans byte_regions_unmodified_trans[rotated], + (simp_all add: h_t_valid_field)+) + +lemma cleanCacheRange_RAM_preserves_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_RAM_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" + apply (hoare_rule HoarePartial.ProcNoRec1, rule allI) + apply (rule conseqPre, vcg exspec=cleanCacheRange_PoC_preserves_bytes + exspec=cleanL2Range_preserves_kernel_bytes + exspec=dsb_preserves_kernel_bytes) + apply (safe intro!: byte_regions_unmodified_hrs_mem_update + elim!: byte_regions_unmodified_trans byte_regions_unmodified_trans[rotated], + (simp_all add: h_t_valid_field)+) + apply (clarsimp simp: byte_regions_unmodified_def) + done + lemma hrs_htd_update_canon: "hrs_htd_update (\_. f (hrs_htd hrs)) hrs = hrs_htd_update f hrs" by (cases hrs, simp add: hrs_htd_update_def hrs_htd_def) @@ -7821,21 +8012,24 @@ lemma Arch_createObject_preserves_bytes: apply (hoare_rule HoarePartial.ProcNoRec1) apply clarsimp apply (rule conseqPre, vcg exspec=cap_small_frame_cap_new_modifies - exspec=cap_frame_cap_new_modifies - exspec=cap_page_table_cap_new_modifies - exspec=copyGlobalMappings_preserves_bytes - exspec=addrFromPPtr_modifies - exspec=cleanCacheRange_PoU_preserves_bytes - exspec=cap_page_directory_cap_new_modifies - exspec=cap_vcpu_cap_new_modifies) + exspec=cap_frame_cap_new_modifies + exspec=cap_page_table_cap_new_modifies + exspec=copyGlobalMappings_preserves_bytes + exspec=addrFromPPtr_modifies + exspec=cleanCacheRange_PoU_preserves_bytes + exspec=cleanCacheRange_RAM_preserves_bytes + exspec=cap_page_directory_cap_new_modifies + exspec=cap_vcpu_cap_new_modifies) + apply (clarsimp simp: vm_page_size_defs) apply (safe intro!: byte_regions_unmodified_hrs_mem_update, (simp_all add: h_t_valid_field hrs_htd_update)+) - apply (safe intro!: ptr_retyp_d ptr_retyps_out) - apply (simp_all add: object_type_from_H_def Kernel_C_defs APIType_capBits_def - split: object_type.split_asm ArchTypes_H.apiobject_type.split_asm) - apply (rule byte_regions_unmodified_flip, simp) - apply (rule byte_regions_unmodified_trans[rotated], - assumption, simp_all add: hrs_htd_update_canon hrs_htd_update) + apply (safe intro!: ptr_retyp_d ptr_retyps_out) + apply (simp_all add: object_type_from_H_def Kernel_C_defs APIType_capBits_def + split: object_type.split_asm ArchTypes_H.apiobject_type.split_asm) + apply (all \(solves \simp add: mask_def\)?\) + apply (rule byte_regions_unmodified_flip, simp, + rule byte_regions_unmodified_trans[rotated], assumption; + simp add: hrs_htd_update_canon hrs_htd_update)+ apply (drule intvlD) apply clarsimp apply (erule notE, rule intvlI) @@ -7990,6 +8184,14 @@ lemma insertNewCap_ccorres: apply (simp add: untypedZeroRange_def Let_def) done +lemma Arch_createObject_not_untyped: + "\s. \\\<^bsub>/UNIV\<^esub> + {s} Call Arch_createObject_'proc {t. cap_get_tag (ret__struct_cap_C_' t) \ scast cap_untyped_cap}" + apply (rule allI, rule conseqPre) + apply (vcg exspec=cleanCacheRange_PoU_modifies exspec=cleanCacheRange_RAM_modifies) + apply (clarsimp simp: cap_tag_defs vm_page_size_defs mask_def) + done + lemma createObject_untyped_region_is_zero_bytes: "\\. \\\<^bsub>/UNIV\<^esub> {s. let tp = (object_type_to_H (t_' s)); sz = APIType_capBits tp (unat (userSize_' s)) @@ -8001,16 +8203,13 @@ lemma createObject_untyped_region_is_zero_bytes: {t. cap_get_tag (ret__struct_cap_C_' t) = scast cap_untyped_cap \ (case untypedZeroRange (cap_to_H (the (cap_lift (ret__struct_cap_C_' t)))) of None \ True | Some (a, b) \ region_actually_is_zero_bytes a (unat ((b + 1) - a)) t)}" - apply (rule allI, rule conseqPre, vcg exspec=copyGlobalMappings_modifies - exspec=Arch_initContext_modifies - exspec=cleanCacheRange_PoU_modifies) + apply (rule allI, rule conseqPre, vcg exspec=Arch_createObject_not_untyped) apply (clarsimp simp: cap_tag_defs Let_def) apply (simp add: cap_lift_untyped_cap cap_tag_defs cap_to_H_simps cap_untyped_cap_lift_def object_type_from_H_def) apply (simp add: untypedZeroRange_def split: if_split) apply (clarsimp simp: getFreeRef_def Let_def object_type_to_H_def untypedBits_defs) - apply (simp add: APIType_capBits_def - less_mask_eq word_less_nat_alt) + apply (simp add: APIType_capBits_def less_mask_eq word_less_nat_alt) done lemma createNewObjects_ccorres: diff --git a/proof/drefine/Untyped_DR.thy b/proof/drefine/Untyped_DR.thy index 9099119f27..514805544f 100644 --- a/proof/drefine/Untyped_DR.thy +++ b/proof/drefine/Untyped_DR.thy @@ -695,10 +695,25 @@ lemma clearMemory_unused_corres_noop: apply (clarsimp simp: word_size_def) apply (drule subsetD[OF upto_enum_step_subset]) apply simp - apply (rule dcorres_machine_op_noop, wp) + apply (rule corres_return_trivial; wp) apply (wp | simp)+ done +lemma dcorres_mapM_x_machine_op_noop: + "\ \m r. \\ms. underlying_memory ms = m\ mop r \\rv ms. underlying_memory ms = m\ \ + \ dcorres dc \ \ (return ()) (mapM_x (\r. do_machine_op (mop r)) xs)" + apply (induct xs) + apply (simp add: mapM_x_Nil) + apply (simp add: mapM_x_Cons) + apply (rule corres_guard_imp) + apply (rule corres_split_noop_rhs) + apply (rule dcorres_machine_op_noop, assumption) + apply assumption + apply wp + apply simp + apply simp + done + lemma init_arch_objects_corres_noop: notes [simp del] = atLeastAtMost_iff atLeastatMost_subset_iff shows @@ -712,27 +727,31 @@ lemma init_arch_objects_corres_noop: obj_refs cap \ {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} = {}) \ valid_objs s \ pspace_aligned s \ pspace_distinct s \ valid_idle s \ valid_etcbs s) (return ()) - (init_arch_objects ty ptr n obj_sz refs)" + (init_arch_objects ty dev ptr n obj_sz refs)" apply (simp add: init_arch_objects_def split: Structures_A.apiobject_type.split aobject_type.split) - apply (simp add: dcorres_machine_op_noop[THEN corres_guard_imp] - cleanCacheRange_PoU_def machine_op_lift) - apply safe - apply (simp add:mapM_x_mapM) + apply (subst dcorres_machine_op_noop[THEN corres_guard_imp] + dcorres_mapM_x_machine_op_noop[THEN corres_guard_imp] + | rule cleanCacheRange_PoU_mem cleanCacheRange_RAM_mem TrueI)+ + apply clarsimp + apply (rule conj_commute[THEN iffD1]) + apply (rule context_conjI) + prefer 2 + apply clarsimp apply (rule corres_guard_imp) apply (rule corres_split_noop_rhs) apply (rule corres_noop[where P=\ and P'=valid_idle]) apply simp - apply (rule hoare_strengthen_post, rule mapM_wp') + apply (rule hoare_strengthen_post, rule mapM_x_wp') apply (subst eq_commute, wp copy_global_mappings_dwp) apply (simp add: obj_bits_api_def arch_kobj_size_def default_arch_object_def pd_bits_def pageBits_def) apply (wp mapM_wp' dmo_dwp | simp)+ - apply (rule corres_noop[where P=\ and P'=valid_idle]) - apply (simp add: clearMemory_def do_machine_op_bind - cleanCacheRange_PoU_def ef_storeWord - mapM_x_mapM dom_mapM) - apply (wp mapM_wp' dmo_dwp | simp)+ + apply (rule dcorres_mapM_x_machine_op_noop) + apply (rule cleanCacheRange_PoU_mem) + apply wp + apply simp + apply simp done lemma monad_commute_set_cap_cdt: @@ -1200,11 +1219,8 @@ lemma clearMemory_corres_noop: apply (simp add: clearMemory_def freeMemory_def[symmetric] do_machine_op_bind empty_fail_freeMemory) apply (rule corres_guard_imp) - apply (rule corres_add_noop_lhs) - apply (rule corres_split_nor) - apply (rule freeMemory_dcorres; simp) - apply (rule dcorres_machine_op_noop) - apply (wp | simp)+ + apply (rule freeMemory_dcorres; simp) + apply (wp | simp)+ apply (clarsimp simp: field_simps) done diff --git a/proof/infoflow/ADT_IF.thy b/proof/infoflow/ADT_IF.thy index c05b611654..cfad4a99da 100644 --- a/proof/infoflow/ADT_IF.thy +++ b/proof/infoflow/ADT_IF.thy @@ -959,7 +959,7 @@ locale ADT_IF_1 = and arch_invoke_irq_control_noErr[wp]: "\Q. \\\ arch_invoke_irq_control ici -, \\rv s :: det_state. Q rv s\" and init_arch_objects_irq_state_of_state[wp]: - "\P. init_arch_objects new_type ptr num_objects obj_sz refs \\s. P (irq_state_of_state s)\" + "\P. init_arch_objects new_type dev ptr num_objects obj_sz refs \\s. P (irq_state_of_state s)\" and getActiveIRQ_None: "(None, s') \ fst (do_machine_op (getActiveIRQ in_kernel) (s :: det_state)) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = None" diff --git a/proof/infoflow/ARM/ArchADT_IF.thy b/proof/infoflow/ARM/ArchADT_IF.thy index 0f94f7ae05..48ab477666 100644 --- a/proof/infoflow/ARM/ArchADT_IF.thy +++ b/proof/infoflow/ARM/ArchADT_IF.thy @@ -148,9 +148,9 @@ lemma arch_invoke_irq_control_noErr[ADT_IF_assms, wp]: "\\\ arch_invoke_irq_control a -, \Q\" by (cases a; wpsimp) -crunch cleanCacheRange_PoU +crunch cleanCacheRange_PoU, cleanCacheRange_RAM for irq_state[wp]: "\s. P (irq_state s)" - (ignore_del: cleanCacheRange_PoU cleanByVA_PoU) + (ignore_del: cleanCacheRange_PoU cleanByVA_PoU cleanL2Range dsb cleanByVA) crunch init_arch_objects for irq_state_of_state[ADT_IF_assms, wp]: "\s. P (irq_state_of_state s)" diff --git a/proof/infoflow/ARM/ArchRetype_IF.thy b/proof/infoflow/ARM/ArchRetype_IF.thy index 4c50f20ad7..8a8060dc9d 100644 --- a/proof/infoflow/ARM/ArchRetype_IF.thy +++ b/proof/infoflow/ARM/ArchRetype_IF.thy @@ -51,12 +51,9 @@ lemma cleanCacheRange_RAM_ev: lemma clearMemory_ev[Retype_IF_assms]: "equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) (\_. True) (clearMemory ptr bits)" unfolding clearMemory_def - apply simp apply (rule equiv_valid_guard_imp) - apply (rule bind_ev) - apply (rule cleanCacheRange_RAM_ev) - apply (rule mapM_x_ev[OF storeWord_ev]) - apply (rule wp_post_taut | simp)+ + apply (rule mapM_x_ev[OF storeWord_ev]) + apply (rule wp_post_taut | simp)+ done lemma freeMemory_ev[Retype_IF_assms]: @@ -214,13 +211,33 @@ lemma dmo_cleanCacheRange_PoU_globals_equiv: unfolding cleanCacheRange_PoU_def by (wp dmo_mol_globals_equiv dmo_cacheRangeOp_lift | simp add: cleanByVA_PoU_def)+ -lemma dmo_cleanCacheRange_reads_respects_g: +lemma dmo_cleanCacheRange_PoU_reads_respects_g: "reads_respects_g aag l \ (do_machine_op (cleanCacheRange_PoU x y z))" apply (rule equiv_valid_guard_imp[OF reads_respects_g]) apply (rule dmo_cleanCacheRange_PoU_reads_respects) apply (rule doesnt_touch_globalsI[where P="\", simplified, OF dmo_cleanCacheRange_PoU_globals_equiv]) by simp +lemma dmo_cleanCacheRange_RAM_globals_equiv: + "do_machine_op (cleanCacheRange_RAM x y z) \globals_equiv s\" + unfolding cleanCacheRange_RAM_def + by (wpsimp wp: dmo_mol_globals_equiv dmo_cacheRangeOp_lift + simp: dmo_bind_valid dsb_def cleanCacheRange_PoC_def cleanByVA_def cleanL2Range_def) + +lemma dmo_cleanCacheRange_RAM_reads_respects: + "reads_respects aag l \ (do_machine_op (cleanCacheRange_RAM vsrat vend pstart))" + unfolding cleanCacheRange_RAM_def + by (wp dmo_cacheRangeOp_reads_respects dmo_mol_reads_respects empty_fail_cleanByVA empty_fail_cacheRangeOp + | simp add: cleanL2Range_def dsb_def cleanCacheRange_PoC_def cleanByVA_def + | subst do_machine_op_bind)+ + +lemma dmo_cleanCacheRange_RAM_reads_respects_g: + "reads_respects_g aag l \ (do_machine_op (cleanCacheRange_RAM x y z))" + apply (rule equiv_valid_guard_imp[OF reads_respects_g]) + apply (rule dmo_cleanCacheRange_RAM_reads_respects) + apply (rule doesnt_touch_globalsI[where P="\", simplified, OF dmo_cleanCacheRange_RAM_globals_equiv]) + by simp + lemma mol_globals_equiv: "machine_op_lift mop \\ms. globals_equiv st (s\machine_state := ms\)\" unfolding machine_op_lift_def @@ -264,15 +281,16 @@ lemma init_arch_objects_reads_respects_g: K (\x\set refs. new_type = ArchObject PageDirectoryObj \ is_aligned x pd_bits) and K ((0::obj_ref) < of_nat num_objects)) - (init_arch_objects new_type ptr num_objects obj_sz refs)" + (init_arch_objects new_type dev ptr num_objects obj_sz refs)" apply (unfold init_arch_objects_def fun_app_def) apply (rule gen_asm_ev)+ - apply (subst do_machine_op_mapM_x[OF empty_fail_cleanCacheRange_PoU])+ apply (rule equiv_valid_guard_imp) - apply (wp dmo_cleanCacheRange_reads_respects_g mapM_x_ev'' - equiv_valid_guard_imp[OF copy_global_mappings_reads_respects_g] - copy_global_mappings_valid_arch_state copy_global_mappings_pspace_aligned - hoare_vcg_ball_lift | wpc | simp)+ + apply (wp dmo_cleanCacheRange_RAM_reads_respects_g + dmo_cleanCacheRange_PoU_reads_respects_g + mapM_x_ev'' when_ev + equiv_valid_guard_imp[OF copy_global_mappings_reads_respects_g] + copy_global_mappings_valid_arch_state copy_global_mappings_pspace_aligned + hoare_vcg_ball_lift | wpc | simp)+ apply clarsimp done @@ -294,13 +312,13 @@ lemma init_arch_objects_globals_equiv: "\globals_equiv s and (\s. arm_global_pd (arch_state s) \ set refs \ pspace_aligned s \ valid_arch_state s) and K (\x\set refs. is_aligned x (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr num_objects obj_sz refs + init_arch_objects new_type dev ptr num_objects obj_sz refs \\_. globals_equiv s\" unfolding init_arch_objects_def fun_app_def apply (rule hoare_gen_asm)+ - apply (subst do_machine_op_mapM_x[OF empty_fail_cleanCacheRange_PoU])+ apply (rule hoare_pre) - apply (wpc | wp mapM_x_wp[OF dmo_cleanCacheRange_PoU_globals_equiv subset_refl])+ + apply (wpc | wp mapM_x_wp[OF dmo_cleanCacheRange_PoU_globals_equiv subset_refl] + mapM_x_wp[OF dmo_cleanCacheRange_RAM_globals_equiv subset_refl])+ apply (rule_tac Q'="\_. globals_equiv s and (\ s. arm_global_pd (arch_state s) \ set refs)" in hoare_strengthen_post) apply (wp mapM_x_wp[OF _ subset_refl] copy_global_mappings_globals_equiv diff --git a/proof/infoflow/FinalCaps.thy b/proof/infoflow/FinalCaps.thy index 3e9c3c0c8c..aac6f1fedf 100644 --- a/proof/infoflow/FinalCaps.thy +++ b/proof/infoflow/FinalCaps.thy @@ -347,9 +347,9 @@ locale FinalCaps_1 = and arch_switch_to_thread_silc_inv[wp]: "arch_switch_to_thread t \silc_inv aag st\" and init_arch_objects_silc_inv[wp]: - "init_arch_objects typ ptr num sz refs \silc_inv aag st\" + "init_arch_objects typ dev ptr num sz refs \silc_inv aag st\" and init_arch_objects_cte_wp_at[wp]: - "\P. init_arch_objects typ ptr num sz refs \\s :: det_state. P (cte_wp_at P' slot s)\" + "\P. init_arch_objects typ dev ptr num sz refs \\s :: det_state. P (cte_wp_at P' slot s)\" and finalise_cap_makes_halted: "\invs and valid_cap cap and (\s. ex = is_final_cap' cap s) and cte_wp_at ((=) cap) slot\ finalise_cap cap ex diff --git a/proof/infoflow/PasUpdates.thy b/proof/infoflow/PasUpdates.thy index b06cf8d206..b8c169437d 100644 --- a/proof/infoflow/PasUpdates.thy +++ b/proof/infoflow/PasUpdates.thy @@ -130,7 +130,7 @@ locale PasUpdates_2 = PasUpdates_1 + and handle_arch_fault_reply_domain_fields[wp]: "handle_arch_fault_reply vmf thread x y \domain_fields P\" and init_arch_objects_domain_fields[wp]: - "init_arch_objects typ ptr num sz refs \domain_fields P\" + "init_arch_objects typ dev ptr num sz refs \domain_fields P\" and state_asids_to_policy_pasSubject_update: "state_asids_to_policy (aag\pasSubject := subject\) s = state_asids_to_policy aag s" diff --git a/proof/invariant-abstract/AARCH64/ArchDetSchedAux_AI.thy b/proof/invariant-abstract/AARCH64/ArchDetSchedAux_AI.thy index 2439b153b8..637024ae11 100644 --- a/proof/invariant-abstract/AARCH64/ArchDetSchedAux_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchDetSchedAux_AI.thy @@ -19,6 +19,7 @@ crunch init_arch_objects and valid_queues[wp]: valid_queues and valid_sched_action[wp]: valid_sched_action and valid_sched[wp]: valid_sched + (wp: mapM_x_wp') (* already proved earlier *) declare invoke_untyped_cur_thread[DetSchedAux_AI_assms] diff --git a/proof/invariant-abstract/AARCH64/ArchRetype_AI.thy b/proof/invariant-abstract/AARCH64/ArchRetype_AI.thy index 1fb9559853..eaa296e016 100644 --- a/proof/invariant-abstract/AARCH64/ArchRetype_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchRetype_AI.thy @@ -147,13 +147,10 @@ lemma init_arch_objects_invs_from_restricted: "\post_retype_invs new_type refs and (\s. global_refs s \ set refs = {}) and K (\ref \ set refs. is_aligned ref (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr bits obj_sz refs + init_arch_objects new_type dev ptr bits obj_sz refs \\_. invs\" apply (simp add: init_arch_objects_def split del: if_split) - apply (rule hoare_pre) - apply (wp hoare_vcg_const_Ball_lift - valid_irq_node_typ - | wpc)+ + apply (wpsimp wp: dmo_invs_lift mapM_x_wp') apply (auto simp: post_retype_invs_def) done @@ -981,7 +978,7 @@ crunch init_arch_objects lemma init_arch_objects_excap: "\ex_cte_cap_wp_to P p\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. ex_cte_cap_wp_to P p s\" by (wp ex_cte_cap_to_pres) diff --git a/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy b/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy index 4c92fcba10..3a60b1f14a 100644 --- a/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy @@ -192,15 +192,17 @@ lemma cap_refs_in_kernel_windowD2: lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]: "\\(s::'state_ext::state_ext state). descendants_range x cref s \ - init_arch_objects ty ptr n us y + init_arch_objects ty dev ptr n us y \\rv s. descendants_range x cref s\" - unfolding init_arch_objects_def by wp + unfolding init_arch_objects_def descendants_range_def + by (wp mapM_x_wp' | wps)+ simp lemma init_arch_objects_caps_overlap_reserved[wp,Untyped_AI_assms]: "\\(s::'state_ext::state_ext state). caps_overlap_reserved S s\ - init_arch_objects ty ptr n us y + init_arch_objects ty dev ptr n us y \\rv s. caps_overlap_reserved S s\" - unfolding init_arch_objects_def by wp + unfolding init_arch_objects_def caps_overlap_reserved_def + by (wp mapM_x_wp' | wps)+ simp lemma set_untyped_cap_invs_simple[Untyped_AI_assms]: "\\s. descendants_range_in {ptr .. ptr+2^sz - 1} cref s \ pspace_no_overlap_range_cover ptr sz s \ invs s @@ -325,9 +327,9 @@ lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]: "\(\s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s) \ valid_global_objs s \ valid_arch_state s \ pspace_aligned s) and K (\ref\set refs. is_aligned ref (obj_bits_api tp us))\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\" - unfolding init_arch_objects_def by wpsimp + unfolding init_arch_objects_def by (wpsimp wp: mapM_x_wp') lemma nonempty_table_caps_of[Untyped_AI_assms]: "nonempty_table S ko \ caps_of ko = {}" @@ -344,6 +346,7 @@ lemma nonempty_default[simp, Untyped_AI_assms]: crunch init_arch_objects for cte_wp_at_iin[wp]: "\s. P (cte_wp_at (P' (interrupt_irq_node s)) p s)" + (wp: mapM_x_wp') lemmas init_arch_objects_ex_cte_cap_wp_to = init_arch_objects_excap diff --git a/proof/invariant-abstract/AARCH64/ArchVSpaceEntries_AI.thy b/proof/invariant-abstract/AARCH64/ArchVSpaceEntries_AI.thy index 816b92285f..738278552e 100644 --- a/proof/invariant-abstract/AARCH64/ArchVSpaceEntries_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchVSpaceEntries_AI.thy @@ -176,9 +176,9 @@ lemma init_arch_objects_valid_vspace: "\valid_vspace_objs' and pspace_aligned and valid_arch_state and K (orefs = retype_addrs ptr type n us) and K (range_cover ptr sz (obj_bits_api type us) n)\ - init_arch_objects type ptr n obj_sz orefs + init_arch_objects type dev ptr n obj_sz orefs \\rv. valid_vspace_objs'\" - unfolding init_arch_objects_def by wpsimp + unfolding init_arch_objects_def by (wpsimp wp: mapM_x_wp') lemma delete_objects_valid_vspace_objs'[wp]: "\valid_vspace_objs'\ delete_objects ptr bits \\rv. valid_vspace_objs'\" diff --git a/proof/invariant-abstract/ARM/ArchRetype_AI.thy b/proof/invariant-abstract/ARM/ArchRetype_AI.thy index 3ec0e8cc5c..0e191d2b36 100644 --- a/proof/invariant-abstract/ARM/ArchRetype_AI.thy +++ b/proof/invariant-abstract/ARM/ArchRetype_AI.thy @@ -599,14 +599,11 @@ lemma init_arch_objects_invs_from_restricted: "\post_retype_invs new_type refs and (\s. global_refs s \ set refs = {}) and K (\ref \ set refs. is_aligned ref (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr bits obj_sz refs + init_arch_objects new_type dev ptr bits obj_sz refs \\_. invs\" apply (simp add: init_arch_objects_def split del: if_split) - apply (rule hoare_pre) - apply (wp mapM_copy_global_invs_mappings_restricted - hoare_vcg_const_Ball_lift - valid_irq_node_typ - | wpc)+ + apply (wpsimp wp: mapM_copy_global_invs_mappings_restricted dmo_invs_lift + mapM_x_wp'[where f="\r. do_machine_op (m r)" for m]) apply (auto simp: post_retype_invs_def default_arch_object_def pd_bits_def pageBits_def obj_bits_api_def global_refs_def) @@ -1363,7 +1360,7 @@ crunch init_arch_objects lemma init_arch_objects_excap: "\ex_cte_cap_wp_to P p\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. ex_cte_cap_wp_to P p s\" by (wp ex_cte_cap_to_pres) diff --git a/proof/invariant-abstract/ARM/ArchUntyped_AI.thy b/proof/invariant-abstract/ARM/ArchUntyped_AI.thy index 16f220bce4..929f2e97a5 100644 --- a/proof/invariant-abstract/ARM/ArchUntyped_AI.thy +++ b/proof/invariant-abstract/ARM/ArchUntyped_AI.thy @@ -191,24 +191,13 @@ lemma copy_global_mappings_hoare_lift:(*FIXME: arch-split \ these d done lemma init_arch_objects_hoare_lift: - assumes wp: "\oper. \(P::'state_ext::state_ext state\bool)\ do_machine_op oper \\rv :: unit. Q\" - "\ptr val. \P\ store_pde ptr val \\rv. P\" - shows "\P and Q\ init_arch_objects tp ptr sz us adds \\rv. Q\" -proof - - have pres: "\oper. \P and Q\ do_machine_op oper \\rv :: unit. Q\" - "\P and Q\ return () \\rv. Q\" - by (wp wp | simp)+ - show ?thesis - apply (simp add: init_arch_objects_def - pres reserve_region_def unless_def when_def - split: Structures_A.apiobject_type.split - aobject_type.split) - apply clarsimp - apply (rule hoare_pre) - apply (wp mapM_x_wp' copy_global_mappings_hoare_lift wp) - apply simp - done -qed + assumes wp: "\oper. \(Q::'state_ext::state_ext state\bool)\ do_machine_op oper \\rv :: unit. Q\" + "\ptr val. \Q\ store_pde ptr val \\rv. Q\" + shows "\Q\ init_arch_objects tp dev ptr sz us adds \\rv. Q\" + supply if_split[split del] + apply (simp add: init_arch_objects_def reserve_region_def) + apply (wpsimp wp: mapM_x_wp' copy_global_mappings_hoare_lift wp) + done lemma cap_refs_in_kernel_windowD2: "\ cte_wp_at P p (s::'state_ext::state_ext state); cap_refs_in_kernel_window s \ @@ -219,30 +208,21 @@ lemma cap_refs_in_kernel_windowD2: done lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]: - "\\(s::'state_ext::state_ext state). descendants_range x cref s \ init_arch_objects ty ptr n us y - \\rv s. descendants_range x cref s\" - apply (simp add:descendants_range_def) - apply (rule hoare_pre) - apply (wp retype_region_mdb init_arch_objects_hoare_lift) - apply (wps do_machine_op_mdb) - apply (wp hoare_vcg_ball_lift) - apply (rule hoare_pre) - apply (wps store_pde_mdb_inv) - apply wp - apply simp - apply fastforce + "\\(s::'state_ext::state_ext state). descendants_range x cref s \ + init_arch_objects ty dev ptr n us y + \\rv s. descendants_range x cref s\" + apply (simp add: descendants_range_def) + apply (wp retype_region_mdb init_arch_objects_hoare_lift) + apply (wp_pre, wps do_machine_op_mdb, wp, simp)+ + apply simp done - - lemma init_arch_objects_caps_overlap_reserved[wp,Untyped_AI_assms]: "\\(s::'state_ext::state_ext state). caps_overlap_reserved S s\ - init_arch_objects ty ptr n us y + init_arch_objects ty dev ptr n us y \\rv s. caps_overlap_reserved S s\" apply (simp add:caps_overlap_reserved_def) - apply (rule hoare_pre) - apply (wp retype_region_mdb init_arch_objects_hoare_lift) - apply fastforce + apply (wp retype_region_mdb init_arch_objects_hoare_lift) done lemma set_untyped_cap_invs_simple[Untyped_AI_assms]: @@ -526,12 +506,11 @@ lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]: "\(\s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s) \ valid_global_objs s \ valid_arch_state s \ pspace_aligned s) and K (\ref\set refs. is_aligned ref (obj_bits_api tp us))\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\" - apply (rule hoare_gen_asm) - apply (simp add: init_arch_objects_def split del: if_split) - apply (rule hoare_pre) - apply (wp unless_wp | wpc | simp add: reserve_region_def second_level_tables_def)+ + unfolding init_arch_objects_def + apply (wpsimp wp: mapM_x_wp'[where f="\r. do_machine_op (m r)" for m] + mapM_copy_global_mappings_nonempty_table) apply (clarsimp simp: obj_bits_api_def default_arch_object_def pd_bits_def pageBits_def) done diff --git a/proof/invariant-abstract/ARM/ArchVSpaceEntries_AI.thy b/proof/invariant-abstract/ARM/ArchVSpaceEntries_AI.thy index e54d26d89a..f8c735edaa 100644 --- a/proof/invariant-abstract/ARM/ArchVSpaceEntries_AI.thy +++ b/proof/invariant-abstract/ARM/ArchVSpaceEntries_AI.thy @@ -668,26 +668,25 @@ lemma init_arch_objects_valid_pdpt: "\valid_pdpt_objs and pspace_aligned and valid_arch_state and K (\us sz. orefs = retype_addrs ptr type n us \ range_cover ptr sz (obj_bits_api type us) n)\ - init_arch_objects type ptr n obj_sz orefs + init_arch_objects type dev ptr n obj_sz orefs \\rv. valid_pdpt_objs\" apply (rule hoare_gen_asm)+ - apply (clarsimp simp: init_arch_objects_def - split del: if_split) - apply (rule hoare_pre) - apply (wp | wpc)+ - apply (rule_tac Q'="\rv. valid_pdpt_objs and pspace_aligned and valid_arch_state" - in hoare_post_imp, simp) - apply (rule mapM_x_wp') - apply (rule hoare_pre, wp copy_global_mappings_valid_pdpt_objs) - apply clarsimp - apply (drule_tac sz=sz in retype_addrs_aligned) - apply (simp add:range_cover_def) - apply (drule range_cover.sz,simp add:word_bits_def) - apply (simp add:range_cover_def) - apply (clarsimp simp:obj_bits_api_def pd_bits_def pageBits_def - arch_kobj_size_def default_arch_object_def range_cover_def)+ + apply (clarsimp simp: init_arch_objects_def split del: if_split) + apply (wp | wpc)+ + apply (wpsimp wp: mapM_x_wp' hoare_vcg_op_lift) + apply (wpsimp wp: mapM_x_wp' hoare_vcg_op_lift) + apply (rule_tac Q'="\rv. valid_pdpt_objs and pspace_aligned and valid_arch_state" + in hoare_post_imp, simp) apply wp - apply simp + apply (rule mapM_x_wp') + apply (wp copy_global_mappings_valid_pdpt_objs) + apply clarsimp + apply (drule_tac sz=sz in retype_addrs_aligned) + apply (simp add:range_cover_def) + apply (drule range_cover.sz,simp add:word_bits_def) + apply (simp add:range_cover_def) + apply (clarsimp simp: obj_bits_api_def pd_bits_def pageBits_def + arch_kobj_size_def default_arch_object_def range_cover_def)+ done lemma delete_objects_valid_pdpt: diff --git a/proof/invariant-abstract/ARM_HYP/ArchRetype_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchRetype_AI.thy index f9df43d8e2..3a47c1723b 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchRetype_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchRetype_AI.thy @@ -439,14 +439,11 @@ lemma init_arch_objects_invs_from_restricted: "\post_retype_invs new_type refs and (\s. global_refs s \ set refs = {}) and K (\ref \ set refs. is_aligned ref (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr bits obj_sz refs + init_arch_objects new_type dev ptr bits obj_sz refs \\_. invs\" apply (simp add: init_arch_objects_def split del: if_split) - apply (rule hoare_pre) - apply (wp mapM_copy_global_invs_mappings_restricted - hoare_vcg_const_Ball_lift - valid_irq_node_typ - | wpc)+ + apply (wpsimp wp: mapM_copy_global_invs_mappings_restricted dmo_invs_lift + mapM_x_wp'[where f="\r. do_machine_op (m r)" for m]) apply (auto simp: post_retype_invs_def default_arch_object_def pd_bits_def pageBits_def obj_bits_api_def global_refs_def) @@ -1213,7 +1210,7 @@ crunch init_arch_objects lemma init_arch_objects_excap: "\ex_cte_cap_wp_to P p\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. ex_cte_cap_wp_to P p s\" by (wp ex_cte_cap_to_pres) diff --git a/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy index 5a13e74107..900d27e25a 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy @@ -186,24 +186,13 @@ lemma copy_global_mappings_hoare_lift:(*FIXME: arch-split \ these d done lemma init_arch_objects_hoare_lift: - assumes wp: "\oper. \(P::'state_ext::state_ext state\bool)\ do_machine_op oper \\rv :: unit. Q\" - "\ptr val. \P\ store_pde ptr val \\rv. P\" - shows "\P and Q\ init_arch_objects tp ptr sz us adds \\rv. Q\" -proof - - have pres: "\oper. \P and Q\ do_machine_op oper \\rv :: unit. Q\" - "\P and Q\ return () \\rv. Q\" - by (wp wp | simp)+ - show ?thesis - apply (simp add: init_arch_objects_def - pres reserve_region_def - split: Structures_A.apiobject_type.split - aobject_type.split) - apply clarsimp - apply (rule hoare_pre) - apply (wp mapM_x_wp' copy_global_mappings_hoare_lift wp) - apply simp - done -qed + assumes wp: "\oper. \(Q::'state_ext::state_ext state\bool)\ do_machine_op oper \\rv :: unit. Q\" + "\ptr val. \Q\ store_pde ptr val \\rv. Q\" + shows "\Q\ init_arch_objects tp dev ptr sz us adds \\rv. Q\" + supply if_split[split del] + apply (simp add: init_arch_objects_def reserve_region_def) + apply (wpsimp wp: mapM_x_wp' copy_global_mappings_hoare_lift wp) + done lemma cap_refs_in_kernel_windowD2: @@ -215,28 +204,20 @@ lemma cap_refs_in_kernel_windowD2: done lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]: - "\\(s::'state_ext::state_ext state). descendants_range x cref s \ init_arch_objects ty ptr n us y + "\\(s::'state_ext::state_ext state). descendants_range x cref s \ init_arch_objects ty dev ptr n us y \\rv s. descendants_range x cref s\" - apply (simp add:descendants_range_def) - apply (rule hoare_pre) - apply (wp retype_region_mdb init_arch_objects_hoare_lift) - apply (wps do_machine_op_mdb) - apply (wp hoare_vcg_ball_lift) - apply (rule hoare_pre) - apply (wps store_pde_mdb_inv) - apply wp - apply simp - apply fastforce + apply (simp add: descendants_range_def) + apply (wp retype_region_mdb init_arch_objects_hoare_lift) + apply (wp_pre, wps do_machine_op_mdb, wp, simp)+ + apply simp done lemma init_arch_objects_caps_overlap_reserved[wp,Untyped_AI_assms]: "\\(s::'state_ext::state_ext state). caps_overlap_reserved S s\ - init_arch_objects ty ptr n us y + init_arch_objects ty dev ptr n us y \\rv s. caps_overlap_reserved S s\" apply (simp add:caps_overlap_reserved_def) - apply (rule hoare_pre) - apply (wp retype_region_mdb init_arch_objects_hoare_lift) - apply fastforce + apply (wp retype_region_mdb init_arch_objects_hoare_lift) done lemma set_untyped_cap_invs_simple[Untyped_AI_assms]: @@ -408,12 +389,10 @@ lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]: "\(\s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s) \ valid_global_objs s \ valid_arch_state s \ pspace_aligned s) and K (\ref\set refs. is_aligned ref (obj_bits_api tp us))\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\" - apply (rule hoare_gen_asm) apply (simp add: init_arch_objects_def split del: if_split) - apply (rule hoare_pre) - apply (wp unless_wp | wpc | simp add: reserve_region_def)+ + apply (wpsimp wp: mapM_x_wp'[where f="\r. do_machine_op (m r)" for m]) apply (clarsimp simp: obj_bits_api_def default_arch_object_def pd_bits_def pageBits_def) done diff --git a/proof/invariant-abstract/ARM_HYP/ArchVSpaceEntries_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchVSpaceEntries_AI.thy index 76704a98cc..d787685c14 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchVSpaceEntries_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchVSpaceEntries_AI.thy @@ -600,26 +600,25 @@ lemma init_arch_objects_valid_pdpt: "\valid_pdpt_objs and pspace_aligned and valid_arch_state and K (\us sz. orefs = retype_addrs ptr type n us \ range_cover ptr sz (obj_bits_api type us) n)\ - init_arch_objects type ptr n obj_sz orefs + init_arch_objects type dev ptr n obj_sz orefs \\rv. valid_pdpt_objs\" apply (rule hoare_gen_asm)+ - apply (clarsimp simp: init_arch_objects_def - split del: if_split) - apply (rule hoare_pre) - apply (wp | wpc)+ - apply (rule_tac Q'="\rv. valid_pdpt_objs and pspace_aligned and valid_arch_state" - in hoare_post_imp, simp) - apply (rule mapM_x_wp') - apply (rule hoare_pre, wp copy_global_mappings_valid_pdpt_objs) - apply clarsimp - apply (drule_tac sz=sz in retype_addrs_aligned) - apply (simp add:range_cover_def) - apply (drule range_cover.sz,simp add:word_bits_def) - apply (simp add:range_cover_def) - apply (clarsimp simp:obj_bits_api_def pd_bits_def pageBits_def - arch_kobj_size_def default_arch_object_def range_cover_def)+ + apply (clarsimp simp: init_arch_objects_def split del: if_split) + apply (wp | wpc)+ + apply (wpsimp wp: mapM_x_wp' hoare_vcg_op_lift) + apply (wpsimp wp: mapM_x_wp' hoare_vcg_op_lift) + apply (rule_tac Q'="\rv. valid_pdpt_objs and pspace_aligned and valid_arch_state" + in hoare_post_imp, simp) apply wp - apply simp + apply (rule mapM_x_wp') + apply (wp copy_global_mappings_valid_pdpt_objs) + apply clarsimp + apply (drule_tac sz=sz in retype_addrs_aligned) + apply (simp add:range_cover_def) + apply (drule range_cover.sz,simp add:word_bits_def) + apply (simp add:range_cover_def) + apply (clarsimp simp: obj_bits_api_def pd_bits_def pageBits_def + arch_kobj_size_def default_arch_object_def range_cover_def)+ done lemma delete_objects_valid_pdpt: diff --git a/proof/invariant-abstract/DetSchedAux_AI.thy b/proof/invariant-abstract/DetSchedAux_AI.thy index 5c3bedd1a5..8f1b4eb67b 100644 --- a/proof/invariant-abstract/DetSchedAux_AI.thy +++ b/proof/invariant-abstract/DetSchedAux_AI.thy @@ -146,9 +146,9 @@ locale DetSchedAux_AI_det_ext = DetSchedAux_AI "TYPE(det_ext)" + invoke_untyped ui \\r s. st_tcb_at (Not o inactive) t s \ etcb_at P t s\ " assumes init_arch_objects_valid_etcbs[wp]: - "\t r n sz refs. \valid_etcbs\ init_arch_objects t r n sz refs \\_. valid_etcbs\" + "\t d r n sz refs. \valid_etcbs\ init_arch_objects t d r n sz refs \\_. valid_etcbs\" assumes init_arch_objects_valid_blocked[wp]: - "\t r n sz refs. \valid_blocked\ init_arch_objects t r n sz refs \\_. valid_blocked\" + "\t d r n sz refs. \valid_blocked\ init_arch_objects t d r n sz refs \\_. valid_blocked\" assumes invoke_untyped_cur_domain[wp]: "\P i. \\s. P (cur_domain s)\ invoke_untyped i \\_ s. P (cur_domain s)\" assumes invoke_untyped_ready_queues[wp]: diff --git a/proof/invariant-abstract/DetSchedDomainTime_AI.thy b/proof/invariant-abstract/DetSchedDomainTime_AI.thy index 5a65db9c90..249d856540 100644 --- a/proof/invariant-abstract/DetSchedDomainTime_AI.thy +++ b/proof/invariant-abstract/DetSchedDomainTime_AI.thy @@ -49,7 +49,7 @@ locale DetSchedDomainTime_AI = assumes handle_arch_fault_reply_domain_list_inv'[wp]: "\P f t x y. \\s. P (domain_list s)\ handle_arch_fault_reply f t x y \\_ s. P (domain_list s)\" assumes init_arch_objects_domain_list_inv'[wp]: - "\P t p n s r. \\s. P (domain_list s)\ init_arch_objects t p n s r \\_ s. P (domain_list s)\" + "\P t d p n s r. \\s. P (domain_list s)\ init_arch_objects t d p n s r \\_ s. P (domain_list s)\" assumes arch_post_modify_registers_domain_list_inv'[wp]: "\P t p. \\s. P (domain_list s)\ arch_post_modify_registers t p \\_ s. P (domain_list s)\" assumes arch_invoke_irq_control_domain_list_inv'[wp]: @@ -71,7 +71,7 @@ locale DetSchedDomainTime_AI = assumes handle_arch_fault_reply_domain_time_inv'[wp]: "\P f t x y. \\s. P (domain_time s)\ handle_arch_fault_reply f t x y \\_ s. P (domain_time s)\" assumes init_arch_objects_domain_time_inv'[wp]: - "\P t p n s r. \\s. P (domain_time s)\ init_arch_objects t p n s r \\_ s. P (domain_time s)\" + "\P t d p n s r. \\s. P (domain_time s)\ init_arch_objects t d p n s r \\_ s. P (domain_time s)\" assumes arch_post_modify_registers_domain_time_inv'[wp]: "\P t p. \\s. P (domain_time s)\ arch_post_modify_registers t p \\_ s. P (domain_time s)\" assumes arch_invoke_irq_control_domain_time_inv'[wp]: diff --git a/proof/invariant-abstract/Untyped_AI.thy b/proof/invariant-abstract/Untyped_AI.thy index 8ba8f5ebef..8891a97681 100644 --- a/proof/invariant-abstract/Untyped_AI.thy +++ b/proof/invariant-abstract/Untyped_AI.thy @@ -279,12 +279,15 @@ locale Untyped_AI_arch = (kheap s)\ \ ArchObjectCap (arch_default_cap x6 (ptr_add ptr (y * 2 ^ obj_bits_api (ArchObject x6) us)) us dev)" assumes init_arch_objects_descendants_range[wp]: - "\x cref ty ptr n us y. \\(s::'state_ext state). descendants_range x cref s \ init_arch_objects ty ptr n us y - \\rv s. descendants_range x cref s\" + "\x cref ty dev ptr n us y. + \\(s::'state_ext state). descendants_range x cref s \ + init_arch_objects ty dev ptr n us y + \\rv s. descendants_range x cref s\" assumes init_arch_objects_caps_overlap_reserved[wp]: - "\S ty ptr n us y. \\(s::'state_ext state). caps_overlap_reserved S s\ - init_arch_objects ty ptr n us y - \\rv s. caps_overlap_reserved S s\" + "\S ty dev ptr n us y. + \\(s::'state_ext state). caps_overlap_reserved S s\ + init_arch_objects ty dev ptr n us y + \\rv s. caps_overlap_reserved S s\" assumes delete_objects_rewrite: "\sz ptr. \ word_size_bits \ sz; sz\ word_bits; ptr && ~~ mask sz = ptr \ \ delete_objects ptr sz = @@ -3026,7 +3029,7 @@ locale Untyped_AI_nonempty_table = "\(\s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s) \ valid_global_objs s \ valid_arch_state s \ pspace_aligned s) and K (\ref\set refs. is_aligned ref (obj_bits_api tp us))\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv. \s :: 'state_ext state. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\" assumes create_cap_ioports[wp]: "\tp oref sz dev cref p. \valid_ioports and cte_wp_at (\_. True) cref\ @@ -3607,13 +3610,13 @@ lemma invoke_untyp_invs': and K (cref \ set slots \ oref \ set (retype_addrs ptr tp (length slots) us)) and K (range_cover ptr sz (obj_bits_api tp us) (length slots))\ create_cap tp us slot dev (cref,oref) \\_. Q\" - assumes init_arch_Q: "\tp slot reset sz slots ptr n us refs dev. + assumes init_arch_Q: "\tp dev slot reset sz slots ptr n us refs dev. ui = Invocations_A.Retype slot reset (ptr && ~~ mask sz) ptr tp us slots dev \ \Q and post_retype_invs tp refs and cte_wp_at (\c. \idx. c = UntypedCap dev (ptr && ~~ mask sz) sz idx) slot and K (refs = retype_addrs ptr tp n us \ range_cover ptr sz (obj_bits_api tp us) n)\ - init_arch_objects tp ptr n us refs \\_. Q\" + init_arch_objects tp dev ptr n us refs \\_. Q\" assumes retype_region_Q: "\ptr us tp slot reset sz slots dev. ui = Invocations_A.Retype slot reset (ptr && ~~ mask sz) ptr tp us slots dev \ \\s. invs s \ Q s diff --git a/proof/refine/AARCH64/Detype_R.thy b/proof/refine/AARCH64/Detype_R.thy index 523a7a5423..cecc4b5bd0 100644 --- a/proof/refine/AARCH64/Detype_R.thy +++ b/proof/refine/AARCH64/Detype_R.thy @@ -2983,6 +2983,17 @@ lemma setCTE_doMachineOp_commute: apply (wp|clarsimp|fastforce)+ done +lemma setCTE_when_doMachineOp_commute: + assumes nf: "no_fail Q (doMachineOp x)" + shows "monad_commute (cte_at' dest and pspace_aligned' and pspace_distinct' and Q) + (setCTE dest cte) + (when P (doMachineOp x))" + apply (cases P; simp add: setCTE_doMachineOp_commute nf) + apply (rule monad_commute_guard_imp) + apply (rule return_commute[THEN commute_commute]) + apply simp + done + lemma placeNewObject_valid_arch_state: "\valid_arch_state' and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and @@ -3191,6 +3202,11 @@ lemma monad_commute_if_weak_r: apply (erule monad_commute_guard_imp,simp)+ done +crunch updatePTType + for cte_wp_at'[wp]: "\s. Q (cte_wp_at' P p s)" + and pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + lemma createObject_setCTE_commute: "monad_commute (cte_wp_at' (\_. True) src and @@ -3252,6 +3268,7 @@ lemma createObject_setCTE_commute: setCTE_modify_gsUserPages_commute[of \] modify_wp[of "%_. \"] setCTE_doMachineOp_commute + setCTE_when_doMachineOp_commute setCTE_placeNewObject_commute setCTE_updatePTType_commute monad_commute_if_weak_r @@ -3402,6 +3419,13 @@ lemma threadSet_gsUntypedZeroRanges_commute': apply (simp add: monad_commute_def exec_gets exec_modify) done +lemma dmo_gsUntypedZeroRanges_commute: + "monad_commute \ (modify (\s. s\gsUntypedZeroRanges := f (gsUntypedZeroRanges s)\)) + (doMachineOp m)" + apply (clarsimp simp: monad_commute_def doMachineOp_def) + apply monad_eq + by (auto simp: select_f_def) + lemma createObject_gsUntypedZeroRanges_commute: "monad_commute \ @@ -3420,7 +3444,7 @@ lemma createObject_gsUntypedZeroRanges_commute: createObjects_gsUntypedZeroRanges_commute'[THEN commute_commute] return_commute return_commute[THEN commute_commute] threadSet_gsUntypedZeroRanges_commute'[THEN commute_commute] - monad_commute_gsUntyped_updatePTType + monad_commute_gsUntyped_updatePTType dmo_gsUntypedZeroRanges_commute split: option.split prod.split cong: if_cong)+ apply (simp add: curDomain_def monad_commute_def exec_modify exec_gets) done @@ -4200,8 +4224,8 @@ lemma dmo'_when_fail_comm: (* FIXME: move *) lemma dmo'_gets_ksPSpace_comm: - "doMachineOp f >>= (\_. gets ksPSpace >>= m) = - gets ksPSpace >>= (\x. doMachineOp f >>= (\_. m x))" + "doMachineOp f >>= (\y. gets ksPSpace >>= m y) = + gets ksPSpace >>= (\x. doMachineOp f >>= (\y. m y x))" apply (rule ext) apply (clarsimp simp: doMachineOp_def simpler_modify_def simpler_gets_def return_def select_f_def bind_def split_def image_def) @@ -4235,14 +4259,15 @@ proof - done qed -lemma dmo'_createObjects'_comm: +lemma dmo'_createObjects'_commute: assumes ef: "empty_fail f" - shows "do _ \ doMachineOp f; x \ createObjects' ptr n obj us; m x od = - do x \ createObjects' ptr n obj us; _ \ doMachineOp f; m x od" - apply (simp add: createObjects'_def bind_assoc split_def unless_def - alignError_def dmo'_when_fail_comm[OF ef] - dmo'_gets_ksPSpace_comm - dmo'_ksPSpace_update_comm'[OF ef, symmetric]) + shows "monad_commute \ (doMachineOp f) (createObjects' ptr n obj us)" + apply (clarsimp simp: createObjects'_def bind_assoc split_def unless_def + alignError_def monad_commute_def + dmo'_when_fail_comm[OF ef] + dmo'_gets_ksPSpace_comm + dmo'_ksPSpace_update_comm'[OF ef, symmetric]) + apply (rule_tac x=s in fun_cong) apply (rule arg_cong_bind1) apply (rule arg_cong_bind1) apply (rename_tac u w) @@ -4251,27 +4276,25 @@ lemma dmo'_createObjects'_comm: apply (simp add: assert_into_when dmo'_when_fail_comm[OF ef]) done -lemma dmo'_gsUserPages_upd_comm: - assumes "empty_fail f" - shows "doMachineOp f >>= (\x. modify (gsUserPages_update g) >>= (\_. m x)) = - modify (gsUserPages_update g) >>= (\_. doMachineOp f >>= m)" -proof - - have ksMachineState_ksPSpace_update: - "\s. ksMachineState (gsUserPages_update g s) = ksMachineState s" - by simp - have updates_independent: - "\f. gsUserPages_update g \ ksMachineState_update f = - ksMachineState_update f \ gsUserPages_update g" - by (rule ext) simp - from assms - show ?thesis - apply (simp add: doMachineOp_def split_def bind_assoc) - apply (simp add: gets_modify_comm2[OF ksMachineState_ksPSpace_update]) - apply (rule arg_cong_bind1) - apply (simp add: empty_fail_def select_f_walk[OF empty_fail_modify] - modify_modify_bind updates_independent) - done -qed +lemmas map_dmo'_createObjects'_comm = dmo'_createObjects'_commute[THEN mapM_x_commute_T] + +lemma dmo'_ksArchState_upd_comm: + "monad_commute \ (doMachineOp m) (modify (\s. ksArchState_update (f (ksArchState s)) s))" + apply (clarsimp simp: monad_commute_def doMachineOp_def) + apply monad_eq + apply (auto simp add: select_f_def) + done + +lemmas map_dmo'_ksArchState_upd_comm = dmo'_ksArchState_upd_comm[THEN mapM_x_commute_T] + +lemma dmo'_gsUserPages_upd_commute: + "monad_commute \ (doMachineOp f) (modify (gsUserPages_update g))" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (auto simp: select_f_def) + done + +lemmas dmo'_gsUserPages_upd_map_commute = dmo'_gsUserPages_upd_commute[THEN mapM_x_commute_T] lemma rewrite_step: assumes rewrite: "\s. P s \ f s = f' s" @@ -4670,7 +4693,6 @@ proof - apply (rule arg_cong2[where f=gsCNodes_update, OF ext refl]) apply (rule ext) apply simp - apply (in_case "HugePageObject") apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc @@ -4682,20 +4704,23 @@ proof - getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def bit_simps - add.commute append) + add.commute append mapM_x_append mapM_x_singleton) apply ((subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+)[1] + apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def - pageBits_def add.commute append) + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ apply (in_case "VSpaceObject") @@ -4706,8 +4731,11 @@ proof - getObjectSize_def bit_simps objBits_simps ptBits_def)+)[6] apply (simp add: bind_assoc placeNewObject_def2) apply (simp add: field_simps updatePTType_def bind_assoc gets_modify_def - getObjectSize_def placeNewObject_def2 objBits_simps append) + getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + mapM_x_singleton) apply (subst ksArchState_update ksArchState_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF map_dmo'_ksArchState_upd_comm] | simp add: modify_modify_bind o_def | simp only: o_def cong: if_cong)+ apply (rule bind_apply_cong, simp) @@ -4731,20 +4759,22 @@ proof - apply (simp_all add: field_simps shiftl_t2n bit_simps getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps bit_simps - getObjectSize_def add.commute append) + getObjectSize_def add.commute append mapM_x_append mapM_x_singleton) apply ((subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+)[1] apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def AARCH64_H.getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps AARCH64_H.getObjectSize_def - pageBits_def add.commute append) + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ apply (in_case "LargePageObject") @@ -4756,19 +4786,21 @@ proof - apply (simp_all add: field_simps shiftl_t2n pageBits_def getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps bit_simps - getObjectSize_def add.commute append) + getObjectSize_def add.commute append mapM_x_append mapM_x_singleton) apply ((subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+)[1] apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def AARCH64_H.getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def bit_simps add.commute append) + getObjectSize_def bit_simps add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ apply (in_case "PageTableObject") @@ -4779,8 +4811,11 @@ proof - getObjectSize_def bit_simps objBits_simps ptBits_def)+)[6] apply (simp add: bind_assoc placeNewObject_def2) apply (simp add: field_simps updatePTType_def bind_assoc gets_modify_def - getObjectSize_def placeNewObject_def2 objBits_simps append) + getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + mapM_x_singleton) apply (subst ksArchState_update ksArchState_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF map_dmo'_ksArchState_upd_comm] | simp add: modify_modify_bind o_def | simp only: o_def cong: if_cong)+ apply (rule bind_apply_cong, simp) @@ -5029,19 +5064,20 @@ lemma ArchCreateObject_pspace_no_overlap': (ptr + (of_nat n << APIType_capBits ty userSize)) userSize d \\archCap. pspace_no_overlap' (ptr + (1 + of_nat n << APIType_capBits ty userSize)) sz\" - apply (rule hoare_pre) - apply (clarsimp simp:AARCH64_H.createObject_def) - apply wpc - apply (wp doMachineOp_psp_no_overlap - createObjects'_pspace_no_overlap2 hoare_when_weak_wp - createObjects'_psp_aligned[where sz = sz] - createObjects'_psp_distinct[where sz = sz] - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib - field_simps split del: if_split - | clarsimp simp add: add.assoc[symmetric],wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] - | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ + supply if_split[split del] + apply (clarsimp simp:AARCH64_H.createObject_def) + apply wpc + apply (wp doMachineOp_psp_no_overlap + createObjects'_pspace_no_overlap2 + createObjects'_psp_aligned[where sz = sz] + createObjects'_psp_distinct[where sz = sz] + | simp add: placeNewObject_def2 word_shiftl_add_distrib + | simp add: placeNewObject_def2 word_shiftl_add_distrib + | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib + field_simps + | clarsimp simp add: add.assoc[symmetric], + wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] + | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ apply (clarsimp simp: conj_comms) apply (frule(1) range_cover_no_0[where p = n]) apply simp @@ -5070,6 +5106,7 @@ lemma ArchCreateObject_pspace_no_overlap': apply (intro conjI allI) apply (clarsimp simp: field_simps word_bits_conv APIType_capBits_def shiftl_t2n objBits_simps bit_simps + split: if_split | rule conjI | erule range_cover_le,simp)+ done diff --git a/proof/refine/AARCH64/Retype_R.thy b/proof/refine/AARCH64/Retype_R.thy index 55db166073..725d4afa57 100644 --- a/proof/refine/AARCH64/Retype_R.thy +++ b/proof/refine/AARCH64/Retype_R.thy @@ -2436,14 +2436,17 @@ proof - split: AARCH64_H.object_type.splits) apply (in_case "HugePageObject") - apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) - apply (wp createObjects_aligned2 createObjects_nonzero' - cwo_ret'[where bs="2 * ptTranslationBits NormalPT_T", simplified] - | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb add.commute)+ + apply (subst doMachineOp_mapM_x[unfolded o_def, simplified, symmetric], simp) + apply (wp hoare_vcg_op_lift doMachineOp_typ_ats) + apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) + apply (wp createObjects_aligned2 createObjects_nonzero' + cwo_ret'[where bs="2 * ptTranslationBits NormalPT_T", simplified] + | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb add.commute)+ apply (simp add:pageBits_def ptr word_bits_def) apply (in_case "VSpaceObject") - apply wp + apply (subst doMachineOp_mapM_x[unfolded o_def, simplified, symmetric], simp) + apply (wp hoare_vcg_op_lift doMachineOp_typ_ats) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (rule hoare_chain) apply (rule hoare_vcg_conj_lift) @@ -2464,7 +2467,8 @@ proof - apply clarsimp apply (in_case "SmallPageObject") - apply wp + apply (subst doMachineOp_mapM_x[unfolded o_def, simplified, symmetric], simp) + apply (wp hoare_vcg_op_lift doMachineOp_typ_ats) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero' cwo_ret'[where bs=0, simplified] @@ -2472,7 +2476,8 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) apply (in_case \LargePageObject\) - apply wp + apply (subst doMachineOp_mapM_x[unfolded o_def, simplified, symmetric], simp) + apply (wp hoare_vcg_op_lift doMachineOp_typ_ats) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero' cwo_ret'[where bs="ptTranslationBits NormalPT_T", simplified] @@ -2480,7 +2485,8 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) apply (in_case \PageTableObject\) - apply wp + apply (subst doMachineOp_mapM_x[unfolded o_def, simplified, symmetric], simp) + apply (wp hoare_vcg_op_lift doMachineOp_typ_ats) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (rule hoare_chain) apply (rule hoare_vcg_conj_lift) @@ -2745,9 +2751,9 @@ lemma corres_retype: done lemma init_arch_objects_APIType_map2: - "init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs = + "init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs = (case ty of APIObjectType _ \ return () - | _ \ init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)" + | _ \ init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs)" apply (clarsimp split: AARCH64_H.object_type.split) apply (simp add: init_arch_objects_def APIType_map2_def split: apiobject_type.split) @@ -4643,6 +4649,9 @@ lemma createObjects_pspace_domain_valid: apply (simp add: objBits_def) done +crunch doMachineOp + for pspace_domain_valid[wp]: pspace_domain_valid + lemma createNewCaps_pspace_domain_valid[wp]: "\pspace_domain_valid and K ({ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \ kernel_data_refs = {} @@ -5372,11 +5381,6 @@ lemma createObjects_Not_tcbQueued: apply (auto simp: obj_at'_def project_inject objBitsKO_def objBits_def makeObject_tcb) done -lemma init_arch_objects_APIType_map2_noop: - "init_arch_objects (APIType_map2 tp) ptr n m addrs = return ()" - apply (simp add: init_arch_objects_def APIType_map2_def) - done - lemma data_page_relation_retype: "obj_relation_retype (ArchObj (DataPage False pgsz)) KOUserData" "obj_relation_retype (ArchObj (DataPage True pgsz)) KOUserDataDevice" @@ -5385,6 +5389,45 @@ lemma data_page_relation_retype: apply (clarsimp simp: image_def)+ done +lemma init_arch_objects_APIType_map2_VCPU_noop: + "init_arch_objects (APIType_map2 (Inr VCPUObject)) dev ptr n m addrs = return ()" + apply (simp add: init_arch_objects_def APIType_map2_def) + done + +lemma reorder_createObjects_dmo_userPages: + "(do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return (f addrs) + od) = (do + (addrs, faddrs) <- (do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + return (addrs, f addrs) + od); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return faddrs + od)" + by (simp add: bind_assoc) + +lemma reorder_createObjects_dmo_gsPTTypes: + "(do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\ksArchState := gsPTTypes_update (g ks addrs) (ksArchState ks)\); + _ <- mapM_x (\addr. doMachineOp (m addr)) addrs; + return (f addrs) + od) = (do + (addrs, faddrs) <- (do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\ksArchState := gsPTTypes_update (g ks addrs) (ksArchState ks)\); + return (addrs, f addrs) + od); + _ <- mapM_x (\addr. doMachineOp (m addr)) addrs; + return faddrs + od)" + by (simp add: bind_assoc) + lemma corres_retype_region_createNewCaps: "corres ((\r r'. length r = length r' \ list_all2 cap_relation r r') \ map (\ref. default_cap (APIType_map2 (Inr ty)) ref us dev)) @@ -5397,7 +5440,7 @@ lemma corres_retype_region_createNewCaps: \ valid_pspace' s \ valid_arch_state' s \ range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \ n\ 0) (do x \ retype_region y n us (APIType_map2 (Inr ty)) dev :: obj_ref list det_ext_monad; - init_arch_objects (APIType_map2 (Inr ty)) y n us x; + init_arch_objects (APIType_map2 (Inr ty)) dev y n us x; return x od) (createNewCaps ty y n us dev)" apply (rule_tac F="range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n @@ -5496,90 +5539,134 @@ lemma corres_retype_region_createNewCaps: apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI; - clarsimp simp: obj_bits_api_def3 APIType_map2_def objBits_simps ext - default_object_def default_arch_object_def makeObjectKO_def - data_page_relation_retype bit_simps - elim!: range_cover.aligned; - assumption) - apply fastforce+ - apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def - list_all2_map1 list_all2_map2 list_all2_same) + apply_trace (simp add: init_arch_objects_def split del: if_split) + apply (subst reorder_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI; + clarsimp simp: obj_bits_api_def3 APIType_map2_def objBits_simps ext + default_object_def default_arch_object_def makeObjectKO_def + data_page_relation_retype bit_simps + elim!: range_cover.aligned; + assumption) + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x') + apply corres + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] apply (in_case \VSpaceObject\) - apply (subst retype_region2_extra_ext_trivial, simp add: APIType_map2_def) - apply (simp add: corres_liftM2_simp[unfolded liftM_def]) + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) + apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst reorder_createObjects_dmo_gsPTTypes) apply (rule corres_guard_imp) - apply (simp add: init_arch_objects_APIType_map2_noop) - apply (rule corres_rel_imp) - apply (rule corres_retype_update_gsI; - (simp add: APIType_map2_def objBits_simps makeObjectKO_def obj_bits_api_def - range_cover.aligned default_arch_object_def pt_bits_def)?) - apply (rule vsroot_relation_retype) - apply (rule ext)+ - apply (rename_tac s, case_tac s, rename_tac arch machine, case_tac arch) - apply (fastforce simp: update_gs_def) - apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same - APIType_map2_def arch_default_cap_def) - apply fastforce+ + apply (rule corres_split) + apply (rule corres_retype_update_gsI; + (simp add: APIType_map2_def objBits_simps makeObjectKO_def obj_bits_api_def + range_cover.aligned default_arch_object_def pt_bits_def)?) + apply (rule vsroot_relation_retype) + apply (rule ext)+ + apply (rename_tac s, case_tac s, rename_tac arch machine, case_tac arch) + apply (fastforce simp: update_gs_def) + apply (simp add: APIType_map2_def vs_apiobj_size_def table_size_def pt_bits_def) + apply (rule corres_split, rule corres_mapM_x') + apply corres + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: arch_default_cap_def list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] apply (in_case \SmallPageObject\) apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI; - clarsimp simp: obj_bits_api_def3 APIType_map2_def objBits_simps ext - default_object_def default_arch_object_def makeObjectKO_def - data_page_relation_retype - elim!: range_cover.aligned; - assumption) - apply fastforce+ - apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def - list_all2_map1 list_all2_map2 list_all2_same) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst reorder_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI; + clarsimp simp: obj_bits_api_def3 APIType_map2_def objBits_simps ext + default_object_def default_arch_object_def makeObjectKO_def + data_page_relation_retype bit_simps + elim!: range_cover.aligned; + assumption) + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x') + apply corres + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] apply (in_case \LargePageObject\) apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI; - clarsimp simp: obj_bits_api_def3 APIType_map2_def objBits_simps ext - default_object_def default_arch_object_def makeObjectKO_def - data_page_relation_retype - elim!: range_cover.aligned; - assumption) - apply fastforce+ - apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def - list_all2_map1 list_all2_map2 list_all2_same) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst reorder_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI; + clarsimp simp: obj_bits_api_def3 APIType_map2_def objBits_simps ext + default_object_def default_arch_object_def makeObjectKO_def + data_page_relation_retype bit_simps + elim!: range_cover.aligned; + assumption) + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x') + apply corres + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] apply (in_case \PageTableObject\) apply (subst retype_region2_ext_retype_region) apply (subst retype_region2_extra_ext_trivial, simp add: APIType_map2_def) apply (simp_all add: corres_liftM2_simp[unfolded liftM_def]) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst reorder_createObjects_dmo_gsPTTypes) apply (rule corres_guard_imp) - apply (simp add: init_arch_objects_APIType_map2_noop) - apply (rule corres_rel_imp) - apply (rule corres_retype_update_gsI; - (simp add: APIType_map2_def objBits_simps makeObjectKO_def obj_bits_api_def - range_cover.aligned default_arch_object_def pt_bits_def)?) - apply (rule pagetable_relation_retype) - apply (rule ext)+ - apply (rename_tac s, case_tac s, rename_tac arch machine, case_tac arch) - apply (fastforce simp: update_gs_def) - apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same - APIType_map2_def arch_default_cap_def) - apply fastforce+ + apply (rule corres_split) + apply (rule corres_retype_update_gsI; + (simp add: APIType_map2_def objBits_simps makeObjectKO_def obj_bits_api_def + range_cover.aligned default_arch_object_def pt_bits_def)?) + apply (rule pagetable_relation_retype) + apply (rule ext)+ + apply (rename_tac s, case_tac s, rename_tac arch machine, case_tac arch) + apply (fastforce simp: update_gs_def) + apply (simp add: APIType_map2_def vs_apiobj_size_def table_size_def pt_bits_def) + apply (rule corres_split, rule corres_mapM_x') + apply corres + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same + APIType_map2_def arch_default_cap_def) + apply ((wpsimp split_del: if_split)+)[6] apply (in_case \VCPUObject\) apply (subst retype_region2_ext_retype_region) apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) + apply (simp add: init_arch_objects_APIType_map2_VCPU_noop split del: if_split) apply (rule corres_guard_imp) apply (rule corres_retype[where 'a = vcpu], simp_all add: obj_bits_api_def objBits_simps pageBits_def default_arch_object_def diff --git a/proof/refine/ARM/Detype_R.thy b/proof/refine/ARM/Detype_R.thy index a7260ec394..5953bf6341 100644 --- a/proof/refine/ARM/Detype_R.thy +++ b/proof/refine/ARM/Detype_R.thy @@ -3266,6 +3266,17 @@ lemma setCTE_doMachineOp_commute: apply (wp|clarsimp|fastforce)+ done +lemma setCTE_when_doMachineOp_commute: + assumes nf: "no_fail Q (doMachineOp x)" + shows "monad_commute (cte_at' dest and pspace_aligned' and pspace_distinct' and Q) + (setCTE dest cte) + (when P (doMachineOp x))" + apply (cases P; simp add: setCTE_doMachineOp_commute nf) + apply (rule monad_commute_guard_imp) + apply (rule return_commute[THEN commute_commute]) + apply simp + done + lemma placeNewObject_valid_arch_state: "\valid_arch_state' and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and @@ -3556,6 +3567,7 @@ lemma createObject_setCTE_commute: setCTE_modify_gsUserPages_commute[of \] modify_wp[of "%_. \"] setCTE_doMachineOp_commute + setCTE_when_doMachineOp_commute setCTE_placeNewObject_commute monad_commute_if_weak_r copyGlobalMappings_setCTE_commute[THEN commute_commute] @@ -3730,6 +3742,13 @@ lemma copyGlobalMappings_gsUntypedZeroRanges_commute': apply simp done +lemma dmo_gsUntypedZeroRanges_commute: + "monad_commute \ (modify (\s. s\gsUntypedZeroRanges := f (gsUntypedZeroRanges s)\)) + (doMachineOp m)" + apply (clarsimp simp: monad_commute_def doMachineOp_def) + apply monad_eq + by (auto simp: select_f_def) + lemma createObject_gsUntypedZeroRanges_commute: "monad_commute \ @@ -4533,26 +4552,97 @@ lemma doMachineOp_ksArchState_commute: apply clarsimp+ done +lemma doMachineOp_ksPSpace: + "monad_commute \ (doMachineOp f) (gets ksPSpace)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (auto simp add: select_f_def) + done + +lemma doMachineOp_assert_opt: + "empty_fail f \ monad_commute \ (doMachineOp f) (assert_opt m)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (force simp add: select_f_def empty_fail_def) + done + +lemma doMachineOp_assert: + "empty_fail f \ monad_commute \ (doMachineOp f) (assert P)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (force simp add: select_f_def empty_fail_def) + done + +lemma doMachineOp_projectKO_pde: + "empty_fail f \ monad_commute \ (doMachineOp f) (projectKO ko :: pde kernel)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc projectKO_def) + apply monad_eq + by (force split: option.splits simp: fail_def return_def select_f_def empty_fail_def) + +lemma doMachineOp_alignCheck: + "empty_fail f \ monad_commute \ (doMachineOp f) (alignCheck ko n)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc alignCheck_def split_def + alignError_def unless_def) + apply monad_eq + by (force simp: select_f_def empty_fail_def) + +lemma doMachineOp_magnitudeCheck: + "empty_fail f \ monad_commute \ (doMachineOp f) (magnitudeCheck x y n)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc magnitudeCheck_def split_def) + apply monad_eq + apply (force simp: select_f_def empty_fail_def return_def when_def fail_def split: option.splits) + done + +lemma doMachineOp_storePDE_commute_T: + "empty_fail f \ monad_commute \ (doMachineOp f) (storePDE src pde)" + apply (clarsimp simp: storePDE_def setObject_def updateObject_default_def bind_assoc split_def) + apply (rule monad_commute_guard_imp) + apply (rule monad_commute_split [OF _ doMachineOp_ksPSpace]) + apply (rule monad_commute_split [OF _ doMachineOp_assert_opt]) + apply (rule monad_commute_split [OF _ doMachineOp_assert]) + apply (rule monad_commute_split [OF _ doMachineOp_projectKO_pde]) + apply (rule monad_commute_split [OF _ doMachineOp_alignCheck]) + apply (rule monad_commute_split [OF _ doMachineOp_magnitudeCheck]) + apply (rule doMachineOp_upd_heap_commute) + apply (assumption | wp)+ + apply simp + done + +lemma getPDE_doMachineOp_commute_T: + "empty_fail f \ monad_commute \ (doMachineOp f) (getObject src :: pde kernel)" + apply (clarsimp simp: storePDE_def getObject_def loadObject_default_def bind_assoc split_def) + apply (rule monad_commute_guard_imp) + apply (rule monad_commute_split [OF _ doMachineOp_ksPSpace]) + apply (rule monad_commute_split [OF _ doMachineOp_assert_opt]) + apply (rule monad_commute_split [OF _ doMachineOp_assert]) + apply (rule monad_commute_split [OF _ doMachineOp_projectKO_pde]) + apply (rule monad_commute_split [OF _ doMachineOp_alignCheck]) + apply (rule monad_commute_split [OF _ doMachineOp_magnitudeCheck]) + apply (rule commute_commute, rule return_commute) + apply (assumption | wp)+ + apply simp + done + lemma doMachineOp_copyGlobalMapping_commute: - "monad_commute (valid_arch_state' and page_directory_at' r) - (doMachineOp f) (copyGlobalMappings r)" - apply (clarsimp simp:copyGlobalMappings_def) + "empty_fail f \ monad_commute \ (doMachineOp f) (copyGlobalMappings r)" + apply (clarsimp simp: copyGlobalMappings_def) apply (rule monad_commute_guard_imp) apply (rule monad_commute_split) - apply (rule mapM_x_commute[where f = id]) - apply (rule monad_commute_split[OF _ getPDE_doMachineOp_commute]) - apply (rule doMachineOp_storePDE_commute) - apply wp+ - apply clarsimp + apply (rule commute_commute, rule mapM_x_commute_T) + apply (rule commute_commute) + apply (rule monad_commute_guard_imp) + apply (rule monad_commute_split[OF _ getPDE_doMachineOp_commute_T]) + apply (rule doMachineOp_storePDE_commute_T) + apply (assumption | wp)+ + apply simp apply (rule doMachineOp_ksArchState_commute) apply wp apply clarsimp - apply (clarsimp simp: valid_arch_state'_def page_directory_at'_def objBits_simps archObjSize_def - pdBits_def pageBits_def) - apply (drule le_m1_iff_lt[where x = "(0x1000::word32)",simplified,THEN iffD1]) - apply (clarsimp simp: pdeBits_def) done +lemmas mapM_doMachineOp_copyGlobalMapping_commute = + doMachineOp_copyGlobalMapping_commute[THEN mapM_x_commute_T] + lemma createObjects'_page_directory_at': "\K (range_cover ptr sz 14 (Suc n)) and pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz\ @@ -4778,6 +4868,85 @@ proof - done qed +lemma dmo'_when_fail_comm: + assumes "empty_fail f" + shows "doMachineOp f >>= (\x. when P fail >>= (\_. m x)) = + when P fail >>= (\_. doMachineOp f >>= m)" + apply (rule ext) + apply (cut_tac ef_dmo'[OF assms]) + apply (auto simp add: empty_fail_def when_def fail_def return_def + bind_def split_def image_def, fastforce) + done + +lemma dmo'_gets_ksPSpace_comm: + "doMachineOp f >>= (\y. gets ksPSpace >>= m y) = + gets ksPSpace >>= (\x. doMachineOp f >>= (\y. m y x))" + apply (rule ext) + apply (clarsimp simp: doMachineOp_def simpler_modify_def simpler_gets_def + return_def select_f_def bind_def split_def image_def + cong: SUP_cong_simp) + apply (rule conjI; clarsimp) + apply (rule equalityI; clarsimp; + rule exI, rule conjI[rotated], assumption, + (rule exI)+, + rule conjI, rule bexI, rule refl, assumption, fastforce) + apply (rule iffI; clarsimp; + (rule exI)+, + rule conjI, + erule bexI[rotated], rule refl, + fastforce dest: prod_injects)+ + done + +lemma dmo'_ksPSpace_update_comm': + assumes "empty_fail f" + shows "doMachineOp f >>= (\x. modify (ksPSpace_update g) >>= (\_. m x)) = + modify (ksPSpace_update g) >>= (\_. doMachineOp f >>= m)" +proof - + have ksMachineState_ksPSpace_update: + "\s. ksMachineState (ksPSpace_update g s) = ksMachineState s" + by simp + have updates_independent: + "\f. ksPSpace_update g \ ksMachineState_update f = + ksMachineState_update f \ ksPSpace_update g" + by (rule ext) simp + from assms + show ?thesis + apply (simp add: doMachineOp_def split_def bind_assoc) + apply (simp add: gets_modify_comm2[OF ksMachineState_ksPSpace_update]) + apply (rule arg_cong_bind1) + apply (simp add: empty_fail_def select_f_walk[OF empty_fail_modify] + modify_modify_bind updates_independent) + done +qed + +lemma dmo'_createObjects'_commute: + assumes ef: "empty_fail f" + shows "monad_commute \ (doMachineOp f) (createObjects' ptr n obj us)" + apply (clarsimp simp: createObjects'_def bind_assoc split_def unless_def + alignError_def monad_commute_def + dmo'_when_fail_comm[OF ef] + dmo'_gets_ksPSpace_comm + dmo'_ksPSpace_update_comm'[OF ef, symmetric]) + apply (rule_tac x=s in fun_cong) + apply (rule arg_cong_bind1) + apply (rule arg_cong_bind1) + apply (rename_tac u w) + apply (case_tac "fst (lookupAround2 (ptr + of_nat (shiftL n (objBitsKO obj + + us) - Suc 0)) w)", clarsimp+) + apply (simp add: assert_into_when dmo'_when_fail_comm[OF ef]) + done + +lemmas map_dmo'_createObjects'_comm = dmo'_createObjects'_commute[THEN mapM_x_commute_T] + +lemma dmo'_gsUserPages_upd_commute: + "monad_commute \ (doMachineOp f) (modify (gsUserPages_update g))" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (auto simp: select_f_def) + done + +lemmas dmo'_gsUserPages_upd_map_commute = dmo'_gsUserPages_upd_commute[THEN mapM_x_commute_T] + lemma new_cap_addrs_def2: "n < 2 ^ 32 \ new_cap_addrs (Suc n) ptr obj @@ -5023,241 +5192,193 @@ proof - \ \SmallPageObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - ARM_H.toAPIType_def ARM_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def + apply (simp_all add: field_simps shiftl_t2n pageBits_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - | simp add: modify_modify_bind o_def)+)[1] - apply (subst monad_eq, rule createObjects_Cons) + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) + apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def - pageBits_def add.commute append) - apply (subst gsUserPages_update gsCNodes_update + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) + apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - | simp add: modify_modify_bind o_def)+ + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+ \ \LargePageObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - ARM_H.toAPIType_def ARM_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def + apply (simp_all add: field_simps shiftl_t2n pageBits_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - | simp add: modify_modify_bind o_def)+)[1] + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_H.getObjectSize_def objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - ARM_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ - \ \SectionObject\ + \ \SectionObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - toAPIType_def ARM_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def + apply (simp_all add: field_simps shiftl_t2n pageBits_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_H.getObjectSize_def objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - ARM_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ \ \SuperSectionObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - toAPIType_def ARM_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def + apply (simp_all add: field_simps shiftl_t2n pageBits_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - | simp add: modify_modify_bind o_def)+)[1] + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_H.getObjectSize_def objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - ARM_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ \ \PageTableObject\ - apply (simp add:Arch_createNewCaps_def Retype_H.createObject_def - createObjects_def bind_assoc ARM_H.toAPIType_def - ARM_H.createObject_def) - apply (subst monad_eq,rule createObjects_Cons) - apply ((simp add: field_simps shiftl_t2n pageBits_def archObjSize_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps ptBits_def)+)[6] - apply (simp add:bind_assoc placeNewObject_def2) - apply (simp add: pageBits_def field_simps - getObjectSize_def ptBits_def archObjSize_def - ARM_H.getObjectSize_def placeNewObject_def2 - objBits_simps append) - -\ \PageDirectoryObject\ - apply (simp add:Arch_createNewCaps_def Retype_H.createObject_def - createObjects_def bind_assoc ARM_H.toAPIType_def - ARM_H.createObject_def) - apply (subgoal_tac "distinct (map (\n. ptr + (n << 14)) [0.e.((of_nat n)::word32)])") - prefer 2 - apply (clarsimp simp: objBits_simps archObjSize_def pdBits_def pageBits_def - ARM_H.getObjectSize_def) - apply (subst upto_enum_word) - apply (clarsimp simp:distinct_map) - apply (frule range_cover.range_cover_n_le) - apply (frule range_cover.range_cover_n_less) - apply (rule conjI) - apply (clarsimp simp:inj_on_def) - apply (rule ccontr) - apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) - apply simp - apply (simp add:word_bits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add: word_of_nat_le word_bits_def pdeBits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add:word_of_nat_le word_bits_def pdeBits_def) - apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) - apply simp - apply (rule ccontr) - apply simp - apply (drule of_nat_inj32[THEN iffD1,rotated -1]) - apply (simp_all add: word_bits_def)[3] - apply (clarsimp) - apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) - apply simp - apply (simp add:word_bits_def) - apply (simp add:word_of_nat_less word_bits_def pdeBits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add:word_of_nat_le word_bits_def pdeBits_def) - apply (rule ccontr) - apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) - apply simp - apply simp - apply (drule of_nat_inj32[THEN iffD1,rotated -1]) - apply (simp_all add: word_bits_def)[3] - apply (subst monad_eq,rule createObjects_Cons) - apply ((simp add: field_simps shiftl_t2n pageBits_def archObjSize_def - ARM_H.getObjectSize_def pdBits_def - objBits_simps ptBits_def)+)[6] - apply (simp add:objBits_simps archObjSize_def pdBits_def pageBits_def ARM_H.getObjectSize_def) - apply (simp add:bind_assoc) - apply (simp add: placeNewObject_def2[where val = "makeObject::ARM_H.pde",simplified,symmetric]) - apply (rule_tac Q = "\r s. valid_arch_state' s \ - (\x\of_nat n. page_directory_at' (ptr + (x << 14)) s) \ Q s" for Q in monad_eq_split) - apply (rule sym) - apply (subst bind_assoc[symmetric]) - apply (subst monad_commute_simple) - apply (rule commute_commute[OF monad_commute_split]) - apply (rule placeNewObject_doMachineOp_commute) - apply (rule mapM_x_commute[where f = id]) - apply (rule placeNewObject_copyGlobalMapping_commute) - apply (rule hoare_pre) - apply (wp copyGlobalMappings_pspace_no_overlap' mapM_x_wp'| clarsimp simp: pdeBits_def)+ - apply (clarsimp simp:objBits_simps archObjSize_def pdBits_def pageBits_def word_bits_conv) - apply assumption (* resolve assumption , yuck *) - apply (simp add:append mapM_x_append bind_assoc pdeBits_def) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ (\r \ of_nat n. page_directory_at' (ptr + (r << 14)) s) - \ page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"]) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ (\r \ of_nat n. page_directory_at' (ptr + (r << 14)) s) - \ page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"]) - apply (subst monad_commute_simple) - apply (rule doMachineOp_copyGlobalMapping_commute) - apply (clarsimp simp:field_simps) - apply (simp add:field_simps mapM_x_singleton) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ page_directory_at' (ptr + (1 + of_nat n << 14)) s"]) - apply (subst doMachineOp_bind) - apply (wp empty_fail_mapM_x empty_fail_cleanCacheRange_PoU)+ - apply (simp add:bind_assoc objBits_simps field_simps archObjSize_def shiftL_nat) - apply wp - apply simp - apply (rule mapM_x_wp') - apply (rule hoare_pre) - apply (wp copyGlobalMappings_pspace_no_overlap' | clarsimp)+ - apply (clarsimp simp:page_directory_at'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift) - apply ((clarsimp simp:page_directory_at'_def)+)[2] - apply (wp placeNewObject_pspace_aligned' placeNewObject_pspace_distinct') - apply (simp add:placeNewObject_def2 field_simps) - apply (rule hoare_vcg_conj_lift) - apply (rule createObjects'_wp_subst) - apply (wp createObjects_valid_arch[where sz = 14]) - apply (rule hoare_vcg_conj_lift) - apply (clarsimp simp:page_directory_at'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift createObjects'_typ_at[where sz = 14]) - apply (rule hoare_strengthen_post[OF createObjects'_page_directory_at'[where sz = 14]]) - apply simp - apply (clarsimp simp:objBits_simps page_directory_at'_def pdeBits_def - field_simps archObjSize_def word_bits_conv range_cover_full - aligned_add_aligned range_cover.aligned is_aligned_shiftl_self) - apply (simp add: pdeBits_def) - apply (frule pspace_no_overlap'_le2[where ptr' = "(ptr + (1 + of_nat n << 14))"]) - apply (subst shiftl_t2n,subst mult.commute, subst suc_of_nat) - apply (rule order_trans[OF range_cover_bound,where n1 = "1 + n"]) - apply (erule range_cover_le,simp) - apply simp - apply (rule word_sub_1_le) - apply (drule(1) range_cover_no_0[where p = "n+1"]) - apply simp - apply simp - apply (erule(1) range_cover_tail_mask) - apply (rule hoare_vcg_conj_lift) - apply (rule createObjects'_wp_subst) - apply (wp createObjects_valid_arch[where sz = sz]) - apply (wp createObjects'_page_directory_at'[where sz = sz] - createObjects'_psp_aligned[where sz = sz] - createObjects'_psp_distinct[where sz = sz] hoare_vcg_imp_lift - createObjects'_pspace_no_overlap[where sz = sz] - | simp add:objBits_simps archObjSize_def field_simps pdeBits_def)+ - apply (drule range_cover_le[where n = "Suc n"]) - apply simp - apply (clarsimp simp:word_bits_def valid_pspace'_def) - apply (clarsimp simp:aligned_add_aligned[OF range_cover.aligned] is_aligned_shiftl_self word_bits_def)+ - done + apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc + ARM_H.toAPIType_def ARM_H.createObject_def) + apply (subst monad_eq, rule createObjects_Cons) + apply ((simp add: field_simps shiftl_t2n archObjSize_def + getObjectSize_def objBits_simps ptBits_def)+)[6] + apply (simp add: bind_assoc placeNewObject_def2) + apply (simp add: field_simps bind_assoc gets_modify_def + getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + mapM_x_singleton archObjSize_def) + apply (subst monad_commute_simple'[OF map_dmo'_createObjects'_comm] + | simp add: modify_modify_bind o_def + | simp only: o_def cong: if_cong)+ + apply (simp add: pteBits_def ptBits_def) + + \ \PageDirectoryObject\ + apply (simp add: Arch_createNewCaps_def toAPIType_def bind_assoc + createObjects_def createObject_def ARM_H.createObject_def) + apply (subst monad_eq, rule createObjects_Cons; simp?) + apply (simp add: objBits_simps getObjectSize_def archObjSize_def pdeBits_def pdBits_def) + apply (simp add: getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + mapM_x_singleton bind_assoc archObjSize_def pdBits_def pdeBits_def) + apply (subst monad_commute_simple'[OF map_dmo'_createObjects'_comm] + | simp add: modify_modify_bind o_def + | simp only: o_def cong: if_cong)+ + apply (simp add: placeNewObject_def2[where val = "makeObject::ARM_H.pde",simplified,symmetric]) + apply (rule_tac Q = "\r s. valid_arch_state' s \ + (\x\of_nat n. page_directory_at' (ptr + (x << 14)) s) \ Q s" for Q + in monad_eq_split) + apply (subst monad_commute_simple) + apply (rule mapM_x_commute[where f=id]) + apply (rule placeNewObject_copyGlobalMapping_commute) + apply (wp copyGlobalMappings_pspace_no_overlap') + apply clarsimp + apply (clarsimp simp:objBits_simps archObjSize_def pdBits_def pageBits_def word_bits_conv) + apply (erule TrueE) (* resolve schematic assumption P *) + apply assumption (* resolve schematic assumption Q *) + apply clarsimp + apply (subst monad_commute_simple'[OF mapM_doMachineOp_copyGlobalMapping_commute], simp) + apply (simp add: field_simps) + apply (wpsimp wp: createObjects'_wp_subst[OF createObjects_valid_arch] hoare_vcg_const_imp_lift + createObjects'_page_directory_at'[where sz=sz] + createObjects'_psp_aligned[where sz=sz] + createObjects'_psp_distinct[where sz=sz] + createObjects'_pspace_no_overlap[where sz=sz] + simp: field_simps pdeBits_def objBits_simps archObjSize_def) + apply clarsimp + apply (drule range_cover_le[where n = "Suc n"], simp) + apply (rule conjI, assumption) + apply (clarsimp simp: objBits_simps archObjSize_def pdeBits_def word_bits_def cong: conj_cong) + apply (clarsimp simp: aligned_add_aligned[OF range_cover.aligned] is_aligned_shiftl_self) + (* distinct (map (\n. ptr + (n << 14)) [0 .e. word_of_nat n]) *) + apply (subst upto_enum_word) + apply (clarsimp simp:distinct_map) + apply (frule range_cover.range_cover_n_le) + apply (frule range_cover.range_cover_n_less) + apply (rule conjI) + apply (clarsimp simp:inj_on_def) + apply (rule ccontr) + apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) + apply simp + apply (simp add:word_bits_def) + apply (erule less_le_trans[OF word_of_nat_less]) + apply (simp add: word_of_nat_le word_bits_def pdeBits_def) + apply (erule less_le_trans[OF word_of_nat_less]) + apply (simp add:word_of_nat_le word_bits_def pdeBits_def) + apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) + apply simp + apply (rule ccontr) + apply simp + apply (drule of_nat_inj32[THEN iffD1,rotated -1]) + apply (simp_all add: word_bits_def)[3] + apply (clarsimp) + apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) + apply simp + apply (simp add:word_bits_def) + apply (simp add:word_of_nat_less word_bits_def pdeBits_def) + apply (erule less_le_trans[OF word_of_nat_less]) + apply (simp add:word_of_nat_le word_bits_def pdeBits_def) + apply (rule ccontr) + apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) + apply simp + apply simp + apply (drule of_nat_inj32[THEN iffD1,rotated -1]; simp add: word_bits_def) + done qed lemma createObject_def2: @@ -5478,21 +5599,20 @@ lemma ArchCreateObject_pspace_no_overlap': (ptr + (of_nat n << APIType_capBits ty userSize)) userSize d \\archCap. pspace_no_overlap' (ptr + (1 + of_nat n << APIType_capBits ty userSize)) sz\" - apply (rule hoare_pre) - apply (clarsimp simp:ARM_H.createObject_def) - apply wpc - apply (wp doMachineOp_psp_no_overlap - createObjects'_pspace_no_overlap2 hoare_when_weak_wp - copyGlobalMappings_pspace_no_overlap' - createObjects'_psp_aligned[where sz = sz] - createObjects'_psp_distinct[where sz = sz] - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib - field_simps split del: if_splits - | clarsimp simp add: add.assoc[symmetric],wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] - | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ - + supply if_split[split del] + apply (clarsimp simp:ARM_H.createObject_def) + apply wpc + apply (wp doMachineOp_psp_no_overlap + createObjects'_pspace_no_overlap2 + createObjects'_psp_aligned[where sz = sz] + createObjects'_psp_distinct[where sz = sz] + copyGlobalMappings_pspace_no_overlap' + | simp add: placeNewObject_def2 word_shiftl_add_distrib + | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib + field_simps + | clarsimp simp add: add.assoc[symmetric], + wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] + | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ apply (clarsimp simp: conj_comms) apply (frule(1) range_cover_no_0[where p = n]) apply simp @@ -5508,7 +5628,7 @@ lemma ArchCreateObject_pspace_no_overlap': apply simp apply (frule pspace_no_overlap'_le2) apply (rule range_cover_compare_offset) - apply simp+ + apply simp+ apply (clarsimp simp:word_shiftl_add_distrib ,simp add:field_simps) apply (clarsimp simp:add.assoc[symmetric]) diff --git a/proof/refine/ARM/Retype_R.thy b/proof/refine/ARM/Retype_R.thy index dcb50f2bfd..47a3475248 100644 --- a/proof/refine/ARM/Retype_R.thy +++ b/proof/refine/ARM/Retype_R.thy @@ -2363,7 +2363,7 @@ proof - split: ARM_H.object_type.splits) \ \SmallPageObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2371,7 +2371,7 @@ proof - | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb)+ apply (simp add:pageBits_def ptr word_bits_def) \ \LargePageObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2380,7 +2380,7 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) \ \SectionObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2389,7 +2389,7 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) \ \SuperSectionObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2398,7 +2398,7 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) \ \PageTableObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (simp only: imp_conv_disj page_table_at'_def typ_at_to_obj_at_arches) @@ -2418,8 +2418,7 @@ proof - pdeBits_def pteBits_def) apply clarsimp \ \PageDirectoryObject\ - apply (wp hoare_vcg_const_Ball_lift) - apply (wp mapM_x_wp' ) + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (simp only: imp_conv_disj page_directory_at'_def typ_at_to_obj_at_arches) @@ -2669,9 +2668,9 @@ lemma corres_retype: done lemma init_arch_objects_APIType_map2: - "init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs = + "init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs = (case ty of APIObjectType _ \ return () - | _ \ init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)" + | _ \ init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs)" apply (clarsimp split: ARM_H.object_type.split) apply (simp add: init_arch_objects_def APIType_map2_def split: apiobject_type.split) @@ -4293,9 +4292,6 @@ lemma createNewCaps_idle'[wp]: crunch createNewCaps for ksArch[wp]: "\s. P (ksArchState s)" (simp: crunch_simps unless_def wp: crunch_wps) -crunch createNewCaps - for it[wp]: "\s. P (ksIdleThread s)" - (simp: crunch_simps unless_def wp: crunch_wps updateObject_default_inv) crunch createNewCaps for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" (simp: crunch_simps unless_def wp: crunch_wps updateObject_default_inv) @@ -4465,7 +4461,9 @@ lemma createNewCaps_pde_mappings'[wp]: split del: if_split cong: option.case_cong object_type.case_cong) apply (rule hoare_pre) - apply (wp mapM_x_copyGlobalMappings_pde_mappings' | wpc + apply (wp mapM_x_copyGlobalMappings_pde_mappings' + mapM_x_wp'[where f="\r. doMachineOp (m r)" for m] + | wpc | simp split del: if_split)+ apply (rule_tac P="range_cover ptr sz (APIType_capBits ty us) n \ n\ 0" in hoare_gen_asm) apply (rule hoare_strengthen_post) @@ -4776,6 +4774,9 @@ crunch copyGlobalMappings for pspace_domain_valid[wp]: "pspace_domain_valid" (wp: crunch_wps) +crunch doMachineOp + for pspace_domain_valid[wp]: pspace_domain_valid + lemma createNewCaps_pspace_domain_valid[wp]: "\pspace_domain_valid and K ({ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \ kernel_data_refs = {} @@ -5502,15 +5503,6 @@ lemma createObjects_Not_tcbQueued: apply (auto simp: obj_at'_def projectKOs project_inject objBitsKO_def objBits_def makeObject_tcb) done -lemma init_arch_objects_APIType_map2_noop: - "tp \ Inr PageDirectoryObject - \ init_arch_objects (APIType_map2 tp) ptr n m addrs - = return ()" - apply (simp add: init_arch_objects_def APIType_map2_def) - apply (cases tp, simp_all split: kernel_object.split arch_kernel_object.split - object_type.split apiobject_type.split) - done - lemma data_page_relation_retype: "obj_relation_retype (ArchObj (DataPage False pgsz)) KOUserData" "obj_relation_retype (ArchObj (DataPage True pgsz)) KOUserDataDevice" @@ -5520,6 +5512,23 @@ lemma data_page_relation_retype: apply (clarsimp simp: image_def)+ done +lemma reorder_createObjects_dmo_userPages: + "(do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return (f addrs) + od) = (do + (addrs, faddrs) <- (do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + return (addrs, f addrs) + od); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return faddrs + od)" + by (simp add: bind_assoc) + lemma corres_retype_region_createNewCaps: "corres ((\r r'. length r = length r' \ list_all2 cap_relation r r') \ map (\ref. default_cap (APIType_map2 (Inr ty)) ref us dev)) @@ -5532,7 +5541,7 @@ lemma corres_retype_region_createNewCaps: \ valid_pspace' s \ valid_arch_state' s \ range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \ n\ 0) (do x \ retype_region y n us (APIType_map2 (Inr ty)) dev :: obj_ref list det_ext_monad; - init_arch_objects (APIType_map2 (Inr ty)) y n us x; + init_arch_objects (APIType_map2 (Inr ty)) dev y n us x; return x od) (createNewCaps ty y n us dev)" apply (rule_tac F="range_cover y sz @@ -5635,89 +5644,137 @@ lemma corres_retype_region_createNewCaps: apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2 objBits_simps allRights_def APIType_map2_def split del: if_split) - \ \SmallPageObject\ + \ \SmallPageObject\ apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def3 - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) - \ \LargePageObject\ + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst reorder_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] + \ \LargePageObject\ apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def3 - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) - \ \SectionObject\ + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst reorder_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] + \ \SectionObject\ apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def3 - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst reorder_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] \ \SuperSectionObject\ apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def3 - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) - \ \PageTable\ + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst reorder_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] + \ \PageTable\ apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) - apply (simp_all add: corres_liftM2_simp[unfolded liftM_def]) + apply (simp add: corres_liftM2_simp[unfolded liftM_def]) + apply (simp add: init_arch_objects_def bind_assoc split del: if_split) apply (rule corres_guard_imp) - apply (simp add: init_arch_objects_APIType_map2_noop) - apply (rule corres_rel_imp) - apply (rule corres_retype[where 'a =pte], - simp_all add: APIType_map2_def obj_bits_api_def - default_arch_object_def objBits_simps - archObjSize_def ptBits_def pageBits_def - pteBits_def pdeBits_def - makeObjectKO_def range_cover.aligned)[1] - apply (rule pagetable_relation_retype) - apply (wp | simp)+ - apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same - APIType_map2_def arch_default_cap_def) - apply simp+ + apply (rule corres_split) + apply (rule corres_retype[where 'a =pte], + simp_all add: APIType_map2_def obj_bits_api_def + default_arch_object_def objBits_simps + archObjSize_def ptBits_def pteBits_def + makeObjectKO_def range_cover.aligned)[1] + apply (rule pagetable_relation_retype) + apply (clarsimp simp: APIType_map2_def vs_apiobj_size_def + pt_bits_def ptBits_def pageBits_def pteBits_def) + apply (rule corres_split) + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply corres + apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same + APIType_map2_def arch_default_cap_def) + apply ((wpsimp split_del: if_split)+)[6] \ \PageDirectory\ + apply (simp add: bind_assoc) apply (rule corres_guard_imp) apply (rule corres_split_eqr) apply (rule corres_retype[where ty = "Inr PageDirectoryObject" and 'a = pde @@ -5729,87 +5786,71 @@ lemma corres_retype_region_createNewCaps: makeObjectKO_def)[1] apply (simp add: range_cover_def)+ apply (rule pagedirectory_relation_retype) - apply (simp add: init_arch_objects_def APIType_map2_def - bind_assoc) - apply (rule corres_split_nor) - apply (simp add: mapM_x_mapM) - apply (rule corres_underlying_split[where r' = dc]) - apply (rule_tac Q="\xs s. (\x \ set xs. page_directory_at x s) - \ valid_arch_state s \ pspace_aligned s \ valid_etcbs s" - and Q'="\xs s. (\x \ set xs. page_directory_at' x s) \ valid_arch_state' s" - in corres_mapM_list_all2[where r'=dc and S="(=)"]) - apply simp+ - apply (rule corres_guard_imp, rule copyGlobalMappings_corres) - apply simp+ - apply (wp hoare_vcg_const_Ball_lift | simp)+ - apply (simp add: list_all2_same) - apply (rule corres_return[where P =\ and P'=\,THEN iffD2]) - apply simp - apply wp+ - apply (simp add: liftM_def[symmetric] o_def list_all2_map1 - list_all2_map2 list_all2_same - arch_default_cap_def mapM_x_mapM) - apply (simp add: dc_def[symmetric]) - apply (rule corres_machine_op) - apply (rule corres_Id) - apply (simp add: shiftl_t2n shiftL_nat - pdBits_def ptBits_def pageBits_def pt_bits_def) - defer - apply simp - apply (simp add: mapM_discarded[where g = "return ()",simplified,symmetric]) - apply (rule no_fail_pre) - apply (wp no_fail_mapM|clarsimp)+ + apply (rename_tac pds) + apply (simp add: init_arch_objects_def bind_assoc APIType_map2_def + vs_apiobj_size_def pdBits_eq + split del: if_split) + apply (rule corres_split) + apply (rule_tac P="valid_arch_state and valid_etcbs and pspace_aligned and + (\s. \pd \ set pds. typ_at (AArch APageDirectory) pd s)" and + P'="valid_arch_state' and (\s. \pd \ set pds. page_directory_at' pd s)" + in corres_mapM_x') + apply (clarsimp, rule corres_guard_imp, rule copyGlobalMappings_corres; simp) + apply (wpsimp wp: hoare_vcg_op_lift)+ + apply (rule corres_split, rule corres_mapM_x', rule corres_machine_op) + apply (clarsimp cong: corres_weak_cong) + apply (rule corres_underlying_trivial_dc) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: list_all2_map1 list_all2_map2 list_all2_same arch_default_cap_def) + apply (wpsimp wp: retype_region_valid_arch retype_region_aligned)+ + apply (rule hoare_post_imp) + prefer 2 apply (rule hoare_vcg_conj_lift) - apply (rule hoare_post_imp) - prefer 2 - apply (rule hoare_vcg_conj_lift) - apply (rule retype_region_obj_at) - apply (simp add: APIType_map2_def) - apply (subst APIType_map2_def, simp) - apply (rule retype_region_ret) - apply (clarsimp simp: retype_addrs_def obj_bits_api_def APIType_map2_def - default_arch_object_def default_object_def) - apply (clarsimp simp: obj_at_def a_type_def) - apply (wp retype_region_valid_arch retype_region_aligned|simp)+ - apply (clarsimp simp: objBits_simps retype_addrs_def obj_bits_api_def - APIType_map2_def default_arch_object_def default_object_def) + apply (rule retype_region_obj_at) + apply (simp add: APIType_map2_def) + apply (simp add: APIType_map2_def) + apply (rule retype_region_ret) + apply (clarsimp simp: retype_addrs_def obj_bits_api_def APIType_map2_def + default_arch_object_def default_object_def obj_at_def a_type_def) + apply (wpsimp wp: createObjects_valid_arch) + apply (rule hoare_post_imp) + prefer 2 apply (rule hoare_vcg_conj_lift) - apply (rule hoare_post_imp) - prefer 2 - apply (rule hoare_vcg_conj_lift) - apply (rule createObjects_ko_at[where sz = sz and 'a = pde]) - apply (simp add: objBits_simps archObjSize_def pdBits_def - pteBits_def pdeBits_def - pageBits_def page_directory_at'_def)+ - apply (simp add: projectKOs) - apply (rule createObjects_aligned) - apply (simp add: objBits_simps archObjSize_def pdBits_def - pageBits_def page_directory_at'_def)+ - apply (simp add: range_cover_def pteBits_def pdeBits_def) - apply (rule le_less_trans[OF range_cover.range_cover_n_le(2) power_strict_increasing]) - apply simp - apply (clarsimp simp: range_cover_def word_bits_def) - apply arith+ - apply (simp add: objBits_simps archObjSize_def pdBits_def - pageBits_def page_directory_at'_def)+ - apply (simp add: range_cover_def word_bits_def pteBits_def pdeBits_def) - apply clarsimp - apply (drule (1) bspec)+ - apply (simp add: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def - ptBits_def APIType_map2_def default_arch_object_def default_object_def - archObjSize_def) - apply (clarsimp simp: objBits_simps archObjSize_def pdBits_def - pageBits_def page_directory_at'_def - pteBits_def pdeBits_def) - apply (drule_tac x = ya in spec) - apply (clarsimp simp:typ_at'_def obj_at'_real_def) - apply (erule ko_wp_at'_weakenE) - apply (clarsimp simp: projectKOs) - apply (wp createObjects_valid_arch) - apply (auto simp: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def ptBits_def - APIType_map2_def default_arch_object_def default_object_def archObjSize_def - pteBits_def pdeBits_def - pd_bits_def fromIntegral_def toInteger_nat fromInteger_nat) + apply (rule createObjects_ko_at[where sz = sz and 'a = pde]) + apply (simp add: objBits_simps archObjSize_def pdBits_def + pteBits_def pdeBits_def APIType_map2_def + obj_bits_api_def default_arch_object_def projectKOs + pageBits_def page_directory_at'_def)+ + apply (rule createObjects_aligned) + apply (simp add: objBits_simps archObjSize_def pdBits_def + pageBits_def page_directory_at'_def)+ + apply (simp add: range_cover_def pteBits_def pdeBits_def) + apply (rule le_less_trans[OF range_cover.range_cover_n_le(2) power_strict_increasing]) + apply simp + apply (clarsimp simp: range_cover_def word_bits_def) + apply arith+ + apply (simp add: objBits_simps archObjSize_def pdBits_def + pageBits_def page_directory_at'_def)+ + apply (simp add: word_bits_def pteBits_def pdeBits_def) + apply clarsimp + apply (drule (1) bspec)+ + apply (simp add: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def + ptBits_def APIType_map2_def default_arch_object_def default_object_def + archObjSize_def) + apply (clarsimp simp: objBits_simps archObjSize_def pdBits_def + pageBits_def page_directory_at'_def + pteBits_def pdeBits_def) + apply (rename_tac offset) + apply (drule_tac x = offset in spec) + apply (clarsimp simp:typ_at'_def obj_at'_real_def) + apply (erule ko_wp_at'_weakenE) + apply (clarsimp simp: projectKOs) + apply (auto simp: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def + APIType_map2_def default_arch_object_def default_object_def archObjSize_def + pteBits_def pdeBits_def ptBits_def + pd_bits_def fromIntegral_def toInteger_nat fromInteger_nat) done end diff --git a/proof/refine/ARM_HYP/Detype_R.thy b/proof/refine/ARM_HYP/Detype_R.thy index 0b3331e35f..f59278435b 100644 --- a/proof/refine/ARM_HYP/Detype_R.thy +++ b/proof/refine/ARM_HYP/Detype_R.thy @@ -3230,6 +3230,17 @@ lemma setCTE_doMachineOp_commute: apply (wp|clarsimp|fastforce)+ done +lemma setCTE_when_doMachineOp_commute: + assumes nf: "no_fail Q (doMachineOp x)" + shows "monad_commute (cte_at' dest and pspace_aligned' and pspace_distinct' and Q) + (setCTE dest cte) + (when P (doMachineOp x))" + apply (cases P; simp add: setCTE_doMachineOp_commute nf) + apply (rule monad_commute_guard_imp) + apply (rule return_commute[THEN commute_commute]) + apply simp + done + lemma placeNewObject_valid_arch_state: "\valid_arch_state' and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and @@ -3520,6 +3531,7 @@ lemma createObject_setCTE_commute: setCTE_modify_gsUserPages_commute[of \] modify_wp[of "%_. \"] setCTE_doMachineOp_commute + setCTE_when_doMachineOp_commute setCTE_placeNewObject_commute monad_commute_if_weak_r copyGlobalMappings_setCTE_commute[THEN commute_commute] @@ -3677,6 +3689,13 @@ lemma copyGlobalMappings_gsUntypedZeroRanges_commute': (modify (\s. s \ gsUntypedZeroRanges := f (gsUntypedZeroRanges s) \ ))" by (simp add: copyGlobalMappings_def monad_commute_guard_imp return_commute) +lemma dmo_gsUntypedZeroRanges_commute: + "monad_commute \ (modify (\s. s\gsUntypedZeroRanges := f (gsUntypedZeroRanges s)\)) + (doMachineOp m)" + apply (clarsimp simp: monad_commute_def doMachineOp_def) + apply monad_eq + by (auto simp: select_f_def) + lemma createObject_gsUntypedZeroRanges_commute: "monad_commute \ @@ -4572,8 +4591,8 @@ lemma dmo'_when_fail_comm: (* FIXME: move *) lemma dmo'_gets_ksPSpace_comm: - "doMachineOp f >>= (\_. gets ksPSpace >>= m) = - gets ksPSpace >>= (\x. doMachineOp f >>= (\_. m x))" + "doMachineOp f >>= (\y. gets ksPSpace >>= m y) = + gets ksPSpace >>= (\x. doMachineOp f >>= (\y. m y x))" apply (rule ext) apply (clarsimp simp: doMachineOp_def simpler_modify_def simpler_gets_def return_def select_f_def bind_def split_def image_def @@ -4612,14 +4631,15 @@ proof - done qed -lemma dmo'_createObjects'_comm: +lemma dmo'_createObjects'_commute: assumes ef: "empty_fail f" - shows "do _ \ doMachineOp f; x \ createObjects' ptr n obj us; m x od = - do x \ createObjects' ptr n obj us; _ \ doMachineOp f; m x od" - apply (simp add: createObjects'_def bind_assoc split_def unless_def - alignError_def dmo'_when_fail_comm[OF ef] - dmo'_gets_ksPSpace_comm - dmo'_ksPSpace_update_comm'[OF ef, symmetric]) + shows "monad_commute \ (doMachineOp f) (createObjects' ptr n obj us)" + apply (clarsimp simp: createObjects'_def bind_assoc split_def unless_def + alignError_def monad_commute_def + dmo'_when_fail_comm[OF ef] + dmo'_gets_ksPSpace_comm + dmo'_ksPSpace_update_comm'[OF ef, symmetric]) + apply (rule_tac x=s in fun_cong) apply (rule arg_cong_bind1) apply (rule arg_cong_bind1) apply (rename_tac u w) @@ -4628,27 +4648,16 @@ lemma dmo'_createObjects'_comm: apply (simp add: assert_into_when dmo'_when_fail_comm[OF ef]) done -lemma dmo'_gsUserPages_upd_comm: - assumes "empty_fail f" - shows "doMachineOp f >>= (\x. modify (gsUserPages_update g) >>= (\_. m x)) = - modify (gsUserPages_update g) >>= (\_. doMachineOp f >>= m)" -proof - - have ksMachineState_ksPSpace_update: - "\s. ksMachineState (gsUserPages_update g s) = ksMachineState s" - by simp - have updates_independent: - "\f. gsUserPages_update g \ ksMachineState_update f = - ksMachineState_update f \ gsUserPages_update g" - by (rule ext) simp - from assms - show ?thesis - apply (simp add: doMachineOp_def split_def bind_assoc) - apply (simp add: gets_modify_comm2[OF ksMachineState_ksPSpace_update]) - apply (rule arg_cong_bind1) - apply (simp add: empty_fail_def select_f_walk[OF empty_fail_modify] - modify_modify_bind updates_independent) - done -qed +lemmas map_dmo'_createObjects'_comm = dmo'_createObjects'_commute[THEN mapM_x_commute_T] + +lemma dmo'_gsUserPages_upd_commute: + "monad_commute \ (doMachineOp f) (modify (gsUserPages_update g))" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (auto simp: select_f_def) + done + +lemmas dmo'_gsUserPages_upd_map_commute = dmo'_gsUserPages_upd_commute[THEN mapM_x_commute_T] lemma rewrite_step: assumes rewrite: "\s. P s \ f s = f' s" @@ -4843,6 +4852,13 @@ lemma createTCBs_tcb_at': apply (simp add: objBits_simps shiftl_t2n) done +lemma mapM_x_copyGlobalMappings_noop: + "mapM_x copyGlobalMappings xs = return ()" + apply (induct xs) + apply (simp add: mapM_x_Nil) + apply (simp add: mapM_x_Cons copyGlobalMappings_def) + done + lemma createNewCaps_Cons: assumes cover:"range_cover ptr sz (Types_H.getObjectSize ty us) (Suc (Suc n))" and "valid_pspace' s" "valid_arch_state' s" @@ -5052,259 +5068,141 @@ proof - \ \SmallPageObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - ARM_HYP_H.toAPIType_def ARM_HYP_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_HYP_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_HYP_H.getObjectSize_def - objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_HYP_H.getObjectSize_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) - apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm - | simp add: modify_modify_bind o_def)+)[1] + apply ((subst gsUserPages_update gsCNodes_update + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_HYP_H.getObjectSize_def - objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_HYP_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm - | simp add: modify_modify_bind o_def)+ + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+ \ \LargePageObject\ - apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - ARM_HYP_H.toAPIType_def ARM_HYP_H.toAPIType_def - ARM_HYP_H.createObject_def placeNewDataObject_def) + apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc + ARM_HYP_H.toAPIType_def ARM_HYP_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_HYP_H.getObjectSize_def - objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_HYP_H.getObjectSize_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm - | simp add: modify_modify_bind o_def)+)[1] + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_HYP_H.getObjectSize_def objBits_simps)[6] + ARM_HYP_H.getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps ARM_HYP_H.getObjectSize_def - pageBits_def add.commute append) + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ \ \SectionObject\ - apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - toAPIType_def ARM_HYP_H.toAPIType_def - ARM_HYP_H.createObject_def placeNewDataObject_def) + apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc + toAPIType_def ARM_HYP_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_HYP_H.getObjectSize_def - objBits_simps)[6] + getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_HYP_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_HYP_H.getObjectSize_def objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - ARM_HYP_H.getObjectSize_def - pageBits_def add.commute append) + ARM_HYP_H.getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps ARM_HYP_H.getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ \ \SuperSectionObject\ - apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - toAPIType_def ARM_HYP_H.toAPIType_def - ARM_HYP_H.createObject_def placeNewDataObject_def) + apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc + toAPIType_def ARM_HYP_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_HYP_H.getObjectSize_def - objBits_simps)[6] + getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_HYP_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm - | simp add: modify_modify_bind o_def)+)[1] + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_HYP_H.getObjectSize_def objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - ARM_HYP_H.getObjectSize_def - pageBits_def add.commute append) + ARM_HYP_H.getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps pageBits_def + ARM_HYP_H.getObjectSize_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ - \ \PageTableObject\ - apply (simp add:Arch_createNewCaps_def Retype_H.createObject_def - createObjects_def bind_assoc ARM_HYP_H.toAPIType_def - ARM_HYP_H.createObject_def) - apply (subst monad_eq,rule createObjects_Cons) - apply ((simp add: field_simps shiftl_t2n archObjSize_def - getObjectSize_def ARM_HYP_H.getObjectSize_def - objBits_simps vspace_bits_defs)+)[6] - apply (simp add:bind_assoc placeNewObject_def2) - apply (simp add: field_simps - getObjectSize_def vspace_bits_defs archObjSize_def - ARM_HYP_H.getObjectSize_def placeNewObject_def2 - objBits_simps append) - -\ \PageDirectoryObject\ - apply (simp add:Arch_createNewCaps_def Retype_H.createObject_def - createObjects_def bind_assoc ARM_HYP_H.toAPIType_def - ARM_HYP_H.createObject_def) - apply (subgoal_tac "distinct (map (\n. ptr + (n << 14)) [0.e.((of_nat n)::word32)])") - prefer 2 - apply (clarsimp simp: objBits_simps archObjSize_def vspace_bits_defs - ARM_HYP_H.getObjectSize_def) - apply (subst upto_enum_word) - apply (clarsimp simp:distinct_map) - apply (frule range_cover.range_cover_n_le) - apply (frule range_cover.range_cover_n_less) - apply (rule conjI) - apply (clarsimp simp:inj_on_def) - apply (rule ccontr) - apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) - apply simp - apply (simp add:word_bits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add: word_of_nat_le word_bits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add:word_of_nat_le word_bits_def) - apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) - apply simp - apply (rule ccontr) - apply simp - apply (drule of_nat_inj32[THEN iffD1,rotated -1]) - apply (simp_all add: word_bits_def)[3] - apply (clarsimp) - apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) - apply simp - apply (simp add:word_bits_def) - apply (simp add:word_of_nat_less word_bits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add:word_of_nat_le word_bits_def) - apply (rule ccontr) - apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) - apply simp - apply simp - apply (drule of_nat_inj32[THEN iffD1,rotated -1]) - apply (simp_all add: word_bits_def)[3] - apply (subst monad_eq,rule createObjects_Cons) - apply ((simp add: field_simps shiftl_t2n vspace_bits_defs archObjSize_def - ARM_HYP_H.getObjectSize_def - objBits_simps ptBits_def)+)[6] - apply (simp add:objBits_simps archObjSize_def vspace_bits_defs ARM_HYP_H.getObjectSize_def) - apply (simp add:bind_assoc) - apply (simp add: placeNewObject_def2[where val = "makeObject::ARM_HYP_H.pde",simplified,symmetric]) - apply (rule_tac Q = "\r s. valid_arch_state' s \ - (\x\of_nat n. page_directory_at' (ptr + (x << 14)) s) \ Q s" for Q in monad_eq_split) - apply (rule sym) - apply (subst bind_assoc[symmetric]) - apply (subst monad_commute_simple) - apply (rule commute_commute[OF monad_commute_split]) - apply (rule placeNewObject_doMachineOp_commute) - apply (rule mapM_x_commute[where f = id]) - apply (rule placeNewObject_copyGlobalMapping_commute) - apply (wp copyGlobalMappings_pspace_no_overlap' mapM_x_wp'| clarsimp)+ - apply (clarsimp simp:objBits_simps archObjSize_def vspace_bits_defs word_bits_conv) - apply assumption (* resolve assumption , yuck *) - apply (simp add:append mapM_x_append bind_assoc) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ (\r \ of_nat n. page_directory_at' (ptr + (r << 14)) s) - \ page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"]) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ (\r \ of_nat n. page_directory_at' (ptr + (r << 14)) s) - \ page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"]) - apply (subst monad_commute_simple) - apply (rule doMachineOp_copyGlobalMapping_commute) - apply (clarsimp simp:field_simps) - apply (simp add:field_simps mapM_x_singleton) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ page_directory_at' (ptr + (1 + of_nat n << 14)) s"]) - apply (subst doMachineOp_bind) - apply (wp empty_fail_mapM_x empty_fail_cleanCacheRange_PoU)+ - apply (simp add:bind_assoc objBits_simps field_simps archObjSize_def shiftL_nat) - apply wp - apply simp - apply (rule mapM_x_wp') - apply (rule hoare_pre) - apply (wp copyGlobalMappings_pspace_no_overlap' | clarsimp)+ - apply (clarsimp simp:page_directory_at'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift) - apply ((clarsimp simp:page_directory_at'_def)+)[2] - apply (wp placeNewObject_pspace_aligned' placeNewObject_pspace_distinct') - apply (simp add:placeNewObject_def2 field_simps) - apply (rule hoare_vcg_conj_lift) - apply (rule createObjects'_wp_subst) - apply (wp createObjects_valid_arch[where sz = 14]) - apply (rule hoare_vcg_conj_lift) - apply (clarsimp simp:page_directory_at'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift createObjects'_typ_at[where sz = 14]) - apply (rule hoare_strengthen_post[OF createObjects'_page_directory_at'[where sz = 14]]) - apply simp - apply (clarsimp simp:objBits_simps page_directory_at'_def vspace_bits_defs - field_simps archObjSize_def word_bits_conv range_cover_full - aligned_add_aligned range_cover.aligned is_aligned_shiftl_self) - apply (frule pspace_no_overlap'_le2[where ptr' = "(ptr + (1 + of_nat n << 14))"]) - apply (subst shiftl_t2n,subst mult.commute, subst suc_of_nat) - apply (rule order_trans[OF range_cover_bound,where n1 = "1 + n"]) - apply (erule range_cover_le,simp) - apply simp - apply (rule word_sub_1_le) - apply (drule(1) range_cover_no_0[where p = "n+1"]) - apply simp - apply simp - apply (erule(1) range_cover_tail_mask) - apply (rule hoare_vcg_conj_lift) - apply (rule createObjects'_wp_subst) - apply (wp createObjects_valid_arch[where sz = sz]) - apply (wp createObjects'_page_directory_at'[where sz = sz] - createObjects'_psp_aligned[where sz = sz] - createObjects'_psp_distinct[where sz = sz] hoare_vcg_imp_lift - createObjects'_pspace_no_overlap[where sz = sz] - | simp add:objBits_simps archObjSize_def vspace_bits_defs field_simps)+ - apply (drule range_cover_le[where n = "Suc n"]) - apply simp - apply (clarsimp simp:word_bits_def valid_pspace'_def vspace_bits_defs) - apply (clarsimp simp:aligned_add_aligned[OF range_cover.aligned] is_aligned_shiftl_self word_bits_def vspace_bits_defs)+ -\ \VCPUObject\ - apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - ARM_HYP_H.toAPIType_def ARM_HYP_H.toAPIType_def - ARM_HYP_H.createObject_def placeNewDataObject_def) - apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n vcpu_bits_def vspace_bits_defs - getObjectSize_def ARM_HYP_H.getObjectSize_def archObjSize_def - objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_HYP_H.getObjectSize_def - vcpu_bits_def pageBits_def add.commute append) - done + \ \PageTableObject\ + apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc + ARM_HYP_H.toAPIType_def ARM_HYP_H.createObject_def) + apply (subst monad_eq, rule createObjects_Cons) + apply ((simp add: field_simps shiftl_t2n vspace_bits_defs archObjSize_def + getObjectSize_def objBits_simps ptBits_def)+)[6] + apply (simp add: bind_assoc placeNewObject_def2) + apply (simp add: field_simps bind_assoc gets_modify_def + getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + mapM_x_singleton archObjSize_def) + apply (subst monad_commute_simple'[OF map_dmo'_createObjects'_comm] + | simp add: modify_modify_bind o_def + | simp only: o_def cong: if_cong)+ + apply (simp add: vspace_bits_defs) + \ \PageDirectoryObject\ + apply (simp add: Arch_createNewCaps_def toAPIType_def bind_assoc + createObjects_def createObject_def ARM_HYP_H.createObject_def) + apply (subst monad_eq, rule createObjects_Cons; simp?) + apply (simp add: objBits_simps getObjectSize_def archObjSize_def vspace_bits_defs) + apply (simp add: getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + bind_assoc mapM_x_singleton archObjSize_def) + apply (simp add: mapM_x_copyGlobalMappings_noop copyGlobalMappings_def) + apply (subst monad_commute_simple'[OF map_dmo'_createObjects'_comm] + | simp add: modify_modify_bind o_def + | simp only: o_def cong: if_cong)+ + apply (simp add: vspace_bits_defs field_simps) + \ \VCPUObject\ + apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc + ARM_HYP_H.toAPIType_def ARM_HYP_H.createObject_def placeNewDataObject_def) + apply (subst monad_eq, rule createObjects_Cons) + apply (simp_all add: field_simps shiftl_t2n vcpu_bits_def vspace_bits_defs + getObjectSize_def archObjSize_def objBits_simps)[7] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps + getObjectSize_def vcpu_bits_def pageBits_def add.commute append) + done qed lemma createObject_def2: @@ -5525,21 +5423,20 @@ lemma ArchCreateObject_pspace_no_overlap': (ptr + (of_nat n << APIType_capBits ty userSize)) userSize d \\archCap. pspace_no_overlap' (ptr + (1 + of_nat n << APIType_capBits ty userSize)) sz\" - apply (rule hoare_pre) - apply (clarsimp simp:ARM_HYP_H.createObject_def) - apply wpc + supply if_split[split del] + apply (clarsimp simp:ARM_HYP_H.createObject_def) + apply wpc apply (wp doMachineOp_psp_no_overlap - createObjects'_pspace_no_overlap2 hoare_when_weak_wp - copyGlobalMappings_pspace_no_overlap' - createObjects'_psp_aligned[where sz = sz] - createObjects'_psp_distinct[where sz = sz] - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib - field_simps split del: if_splits - | clarsimp simp add: add.assoc[symmetric],wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] - | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ - + createObjects'_pspace_no_overlap2 + createObjects'_psp_aligned[where sz = sz] + createObjects'_psp_distinct[where sz = sz] + | simp add: placeNewObject_def2 word_shiftl_add_distrib + | simp add: copyGlobalMappings_def + | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib + field_simps + | clarsimp simp add: add.assoc[symmetric], + wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] + | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ apply (clarsimp simp: conj_comms) apply (frule(1) range_cover_no_0[where p = n]) apply simp @@ -5555,7 +5452,7 @@ lemma ArchCreateObject_pspace_no_overlap': apply simp apply (frule pspace_no_overlap'_le2) apply (rule range_cover_compare_offset) - apply simp+ + apply simp+ apply (clarsimp simp:word_shiftl_add_distrib ,simp add:field_simps) apply (clarsimp simp:add.assoc[symmetric]) @@ -5566,9 +5463,9 @@ lemma ArchCreateObject_pspace_no_overlap': apply (metis numeral_2_eq_2) apply (simp add:shiftl_t2n field_simps) apply (intro conjI allI) - apply (clarsimp simp: field_simps word_bits_conv archObjSize_def vspace_bits_defs - APIType_capBits_def shiftl_t2n objBits_simps - | rule conjI | erule range_cover_le,simp)+ + apply (clarsimp simp: field_simps word_bits_conv archObjSize_def vspace_bits_defs + APIType_capBits_def shiftl_t2n objBits_simps + | rule conjI | erule range_cover_le,simp)+ done lemma to_from_apiTypeD: "toAPIType ty = Some x \ ty = fromAPIType x" diff --git a/proof/refine/ARM_HYP/Retype_R.thy b/proof/refine/ARM_HYP/Retype_R.thy index 78b42d61c0..4e1da51c4b 100644 --- a/proof/refine/ARM_HYP/Retype_R.thy +++ b/proof/refine/ARM_HYP/Retype_R.thy @@ -2375,7 +2375,7 @@ proof - apply (clarsimp simp: ARM_HYP_H.toAPIType_def APIType_capBits_def split: ARM_HYP_H.object_type.splits) \ \SmallPageObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply ((wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2383,7 +2383,7 @@ proof - | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb)+) apply (simp add:pageBits_def ptr word_bits_def) \ \LargePageObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2392,7 +2392,7 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) \ \SectionObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2401,7 +2401,7 @@ proof - apply (simp add: pageBits_def ptr word_bits_def) \ \SuperSectionObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2410,7 +2410,7 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) \ \PageTableObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (simp only: imp_conv_disj page_table_at'_def typ_at_to_obj_at_arches) @@ -2427,8 +2427,7 @@ proof - apply (clarsimp simp: objBits_simps archObjSize_def vspace_bits_defs) apply clarsimp \ \PageDirectoryObject\ - apply (wp hoare_vcg_const_Ball_lift) - apply (wp mapM_x_wp' ) + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (simp only: imp_conv_disj page_directory_at'_def typ_at_to_obj_at_arches) @@ -2692,9 +2691,9 @@ lemma corres_retype: done lemma init_arch_objects_APIType_map2: - "init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs = + "init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs = (case ty of APIObjectType _ \ return () - | _ \ init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)" + | _ \ init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs)" apply (clarsimp split: ARM_HYP_H.object_type.split) apply (simp add: init_arch_objects_def APIType_map2_def split: apiobject_type.split) @@ -4369,9 +4368,6 @@ lemma createNewCaps_idle'[wp]: crunch createNewCaps for ksArch[wp]: "\s. P (ksArchState s)" (simp: crunch_simps unless_def wp: crunch_wps) -crunch createNewCaps - for it[wp]: "\s. P (ksIdleThread s)" - (simp: crunch_simps unless_def wp: crunch_wps updateObject_default_inv) crunch createNewCaps for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" (simp: crunch_simps unless_def wp: crunch_wps updateObject_default_inv) @@ -4497,7 +4493,9 @@ lemma createNewCaps_pde_mappings'[wp]: split del: if_split cong: option.case_cong object_type.case_cong) apply (rule hoare_pre) - apply (wp mapM_x_copyGlobalMappings_pde_mappings' | wpc + apply (wp mapM_x_copyGlobalMappings_pde_mappings' + mapM_x_wp'[where f="\r. doMachineOp (m r)" for m] + | wpc | simp split del: if_split)+ apply (rule_tac P="range_cover ptr sz (APIType_capBits ty us) n \ n\ 0" in hoare_gen_asm) apply (rule hoare_strengthen_post) @@ -4801,6 +4799,9 @@ crunch copyGlobalMappings, doMachineOp for pspace_domain_valid[wp]: "pspace_domain_valid" (wp: crunch_wps) +crunch doMachineOp + for pspace_domain_valid[wp]: pspace_domain_valid + lemma createNewCaps_pspace_domain_valid[wp]: "\pspace_domain_valid and K ({ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \ kernel_data_refs = {} @@ -5543,15 +5544,6 @@ lemma createObjects_Not_tcbQueued: apply (auto simp: obj_at'_def projectKOs project_inject objBitsKO_def objBits_def makeObject_tcb) done -lemma init_arch_objects_APIType_map2_noop: - "tp \ Inr PageDirectoryObject - \ init_arch_objects (APIType_map2 tp) ptr n m addrs - = return ()" - apply (simp add: init_arch_objects_def APIType_map2_def) - apply (cases tp, simp_all split: kernel_object.split arch_kernel_object.split - object_type.split apiobject_type.split) - done - lemma data_page_relation_retype: "obj_relation_retype (ArchObj (DataPage False pgsz)) KOUserData" "obj_relation_retype (ArchObj (DataPage True pgsz)) KOUserDataDevice" @@ -5561,6 +5553,28 @@ lemma data_page_relation_retype: apply (clarsimp simp: image_def)+ done +lemma init_arch_objects_APIType_map2_VCPU_noop: + "init_arch_objects (APIType_map2 (Inr VCPUObject)) dev ptr n m addrs = return ()" + apply (simp add: init_arch_objects_def APIType_map2_def) + done + +lemma reorder_createObjects_dmo_userPages: + "(do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return (f addrs) + od) = (do + (addrs, faddrs) <- (do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + return (addrs, f addrs) + od); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return faddrs + od)" + by (simp add: bind_assoc) + lemma corres_retype_region_createNewCaps: "corres ((\r r'. length r = length r' \ list_all2 cap_relation r r') \ map (\ref. default_cap (APIType_map2 (Inr ty)) ref us dev)) @@ -5573,7 +5587,7 @@ lemma corres_retype_region_createNewCaps: \ valid_pspace' s \ valid_arch_state' s \ range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \ n\ 0) (do x \ retype_region y n us (APIType_map2 (Inr ty)) dev :: obj_ref list det_ext_monad; - init_arch_objects (APIType_map2 (Inr ty)) y n us x; + init_arch_objects (APIType_map2 (Inr ty)) dev y n us x; return x od) (createNewCaps ty y n us dev)" apply (rule_tac F="range_cover y sz @@ -5677,89 +5691,137 @@ lemma corres_retype_region_createNewCaps: apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2 objBits_simps allRights_def APIType_map2_def split del: if_split) - \ \SmallPageObject\ + \ \SmallPageObject\ + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) + apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst reorder_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] + \ \LargePageObject\ apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def3 - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) - \ \LargePageObject\ + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst reorder_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] + \ \SectionObject\ apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def3 - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) - \ \SectionObject\ + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst reorder_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] + \ \SuperSectionObject\ apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def3 - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) - \ \SuperSectionObject\ + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst reorder_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] + \ \PageTable\ apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) - apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def3 - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) - \ \PageTable\ - apply (subst retype_region2_extra_ext_trivial) - apply (simp add: APIType_map2_def) - apply (simp_all add: corres_liftM2_simp[unfolded liftM_def]) - apply (rule corres_guard_imp) - apply (simp add: init_arch_objects_APIType_map2_noop) - apply (rule corres_rel_imp) - apply (rule corres_retype[where 'a =pte], - simp_all add: APIType_map2_def obj_bits_api_def - default_arch_object_def objBits_simps - archObjSize_def vspace_bits_defs - makeObjectKO_def range_cover.aligned)[1] - apply (rule pagetable_relation_retype) - apply (wp | simp)+ - apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same - APIType_map2_def arch_default_cap_def) - apply simp+ + apply (simp add: corres_liftM2_simp[unfolded liftM_def]) + apply (simp add: init_arch_objects_def split del: if_split) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype[where 'a =pte], + simp_all add: APIType_map2_def obj_bits_api_def + default_arch_object_def objBits_simps + archObjSize_def vspace_bits_defs + makeObjectKO_def range_cover.aligned)[1] + apply (rule pagetable_relation_retype) + apply (clarsimp simp: APIType_map2_def vs_apiobj_size_def) + apply (rule corres_split) + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply corres + apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same + APIType_map2_def arch_default_cap_def) + apply ((wpsimp split_del: if_split)+)[6] defer - \ \PageDirectory\ + \ \PageDirectory\ + apply (simp only: bind_assoc) apply (rule corres_guard_imp) apply (rule corres_split_eqr) apply (rule corres_retype[where ty = "Inr PageDirectoryObject" and 'a = pde @@ -5787,18 +5849,14 @@ lemma corres_retype_region_createNewCaps: apply (rule corres_return[where P =\ and P'=\,THEN iffD2]) apply simp apply wp+ - apply (simp add: liftM_def[symmetric] o_def list_all2_map1 - list_all2_map2 list_all2_same - arch_default_cap_def mapM_x_mapM) - apply (simp add: dc_def[symmetric]) - apply (rule corres_machine_op) - apply (rule corres_Id) - apply (simp add: shiftl_t2n shiftL_nat - vspace_bits_defs) - apply simp - apply (simp add: mapM_discarded[where g = "return ()",simplified,symmetric]) - apply (rule no_fail_pre) - apply (wp no_fail_mapM|clarsimp)+ + apply (rule corres_split, rule corres_mapM_x', rule corres_machine_op) + apply (clarsimp simp: vs_apiobj_size_def) + apply (rule corres_underlying_trivial_dc, wp) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: list_all2_map1 list_all2_map2 list_all2_same arch_default_cap_def) + apply wp+ apply (rule hoare_vcg_conj_lift) apply (rule hoare_post_imp) prefer 2 @@ -5848,25 +5906,26 @@ lemma corres_retype_region_createNewCaps: APIType_map2_def default_arch_object_def default_object_def archObjSize_def vspace_bits_defs fromIntegral_def toInteger_nat fromInteger_nat)[2] \ \VCPUObject\ - apply (subst retype_region2_extra_ext_trivial) - apply (simp add: APIType_map2_def) - apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype[where 'a = vcpu], - simp_all add: obj_bits_api_def objBits_simps pageBits_def default_arch_object_def - APIType_map2_def makeObjectKO_def archObjSize_def vcpu_bits_def - other_objs_default_relation)[1] - apply (fastforce simp: range_cover_def) - apply (simp add: no_gs_types_def) - apply (auto simp add: obj_relation_retype_def range_cover_def objBitsKO_def arch_kobj_size_def default_object_def - archObjSize_def vcpu_bits_def pageBits_def obj_bits_def cte_level_bits_def default_arch_object_def - other_obj_relation_def vcpu_relation_def default_vcpu_def makeObject_vcpu - makeVCPUObject_def default_gic_vcpu_interface_def vgic_map_def)[1] - apply simp+ - apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2 - objBits_simps APIType_map2_def arch_default_cap_def) + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) + apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) + apply (rule corres_rel_imp) + apply (simp add: init_arch_objects_APIType_map2_VCPU_noop split del: if_split) + apply (rule corres_guard_imp) + apply (rule corres_retype[where 'a = vcpu], + simp_all add: obj_bits_api_def objBits_simps pageBits_def default_arch_object_def + APIType_map2_def makeObjectKO_def archObjSize_def vcpu_bits_def + other_objs_default_relation)[1] + apply (fastforce simp: range_cover_def) + apply (simp add: no_gs_types_def) + apply (auto simp: obj_relation_retype_def range_cover_def objBitsKO_def arch_kobj_size_def + default_object_def default_arch_object_def + archObjSize_def vcpu_bits_def pageBits_def obj_bits_def cte_level_bits_def + other_obj_relation_def vcpu_relation_def default_vcpu_def makeObject_vcpu + makeVCPUObject_def default_gic_vcpu_interface_def vgic_map_def)[1] + apply simp+ + apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2 + objBits_simps APIType_map2_def arch_default_cap_def) done end