1(* 2 * Copyright 2014, General Dynamics C4 Systems 3 * 4 * This software may be distributed and modified according to the terms of 5 * the GNU General Public License version 2. Note that NO WARRANTY is provided. 6 * See "LICENSE_GPLv2.txt" for details. 7 * 8 * @TAG(GD_GPL) 9 *) 10 11theory Detype_R 12imports Retype_R 13begin 14context begin interpretation Arch . (*FIXME: arch_split*) 15 16text {* Establishing that the invariants are maintained 17 when a region of memory is detyped, that is, 18 removed from the model. *} 19 20definition 21 "descendants_range_in' S p \<equiv> 22 \<lambda>m. \<forall>p' \<in> descendants_of' p m. \<forall>c n. m p' = Some (CTE c n) \<longrightarrow> capRange c \<inter> S = {}" 23 24lemma null_filter_simp'[simp]: 25 "null_filter' (null_filter' x) = null_filter' x" 26 apply (rule ext) 27 apply (auto simp:null_filter'_def split:if_splits) 28 done 29 30lemma descendants_range_in'_def2: 31 "descendants_range_in' S p = (\<lambda>m. \<forall>p'\<in>descendants_of' p (null_filter' m). 32 \<forall>c n. (null_filter' m) p' = Some (CTE c n) \<longrightarrow> capRange c \<inter> S = {})" 33 apply (clarsimp simp:descendants_range_in'_def 34 split:if_splits) 35 apply (rule ext) 36 apply (rule subst[OF null_filter_descendants_of']) 37 apply simp 38 apply (rule iffI) 39 apply (clarsimp simp:null_filter'_def)+ 40 apply (drule(1) bspec) 41 apply (elim allE impE ballE) 42 apply (rule ccontr) 43 apply (clarsimp split:if_splits simp:descendants_of'_def) 44 apply (erule(1) subtree_not_Null) 45 apply fastforce 46 apply simp 47 done 48 49definition 50 "descendants_range' cap p \<equiv> 51 \<lambda>m. \<forall>p' \<in> descendants_of' p m. \<forall>c n. m p' = Some (CTE c n) \<longrightarrow> capRange c \<inter> capRange cap = {}" 52 53lemma descendants_rangeD': 54 "\<lbrakk> descendants_range' cap p m; m \<turnstile> p \<rightarrow> p'; m p' = Some (CTE c n) \<rbrakk> 55 \<Longrightarrow> capRange c \<inter> capRange cap = {}" 56 by (simp add: descendants_range'_def descendants_of'_def) 57 58lemma descendants_range_in_lift': 59 assumes st: "\<And>P. \<lbrace>\<lambda>s. Q s \<and> P ((swp descendants_of') (null_filter' (ctes_of s)))\<rbrace> 60 f \<lbrace>\<lambda>r s. P ((swp descendants_of') (null_filter' (ctes_of s)))\<rbrace>" 61 assumes cap_range: 62 "\<And>P p. \<lbrace>\<lambda>s. Q' s \<and> cte_wp_at' (\<lambda>c. P (capRange (cteCap c))) p s\<rbrace> f \<lbrace>\<lambda>r s. cte_wp_at' (\<lambda>c. P (capRange (cteCap c))) p s\<rbrace>" 63 shows "\<lbrace>\<lambda>s. Q s \<and> Q' s \<and> descendants_range_in' S slot (ctes_of s)\<rbrace> f \<lbrace>\<lambda>r s. descendants_range_in' S slot (ctes_of s)\<rbrace>" 64 apply (clarsimp simp:descendants_range_in'_def2) 65 apply (subst swp_def[where f = descendants_of', THEN meta_eq_to_obj_eq, 66 THEN fun_cong, THEN fun_cong, symmetric])+ 67 apply (simp only: Ball_def[unfolded imp_conv_disj]) 68 apply (rule hoare_pre) 69 apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift st cap_range) 70 apply (rule_tac Q = "\<lambda>r s. cte_wp_at' (\<lambda>c. capRange (cteCap c) \<inter> S = {}) x s" 71 in hoare_strengthen_post) 72 apply (wp cap_range) 73 apply (clarsimp simp:cte_wp_at_ctes_of null_filter'_def) 74 apply clarsimp 75 apply (drule spec, drule(1) mp) 76 apply (subst (asm) null_filter_descendants_of') 77 apply simp 78 apply (case_tac "(ctes_of s) x") 79 apply (clarsimp simp:descendants_of'_def null_filter'_def subtree_target_Some) 80 apply (case_tac a) 81 apply (clarsimp simp:cte_wp_at_ctes_of null_filter'_def split:if_splits) 82 done 83 84lemma descendants_range_inD': 85 "\<lbrakk>descendants_range_in' S p ms; p'\<in>descendants_of' p ms; ms p' = Some cte\<rbrakk> 86 \<Longrightarrow> capRange (cteCap cte) \<inter> S = {}" 87 apply (case_tac cte) 88 apply (auto simp:descendants_range_in'_def cte_wp_at_ctes_of dest!:bspec) 89 done 90end 91 92interpretation clear_um: 93 p_arch_idle_update_int_eq "clear_um S" 94 by unfold_locales (simp_all add: clear_um_def) 95 96context begin interpretation Arch . (*FIXME: arch_split*) 97 98lemma descendants_range'_def2: 99 "descendants_range' cap p = descendants_range_in' (capRange cap) p" 100 by (simp add: descendants_range_in'_def descendants_range'_def) 101 102 103defs deletionIsSafe_def: 104 "deletionIsSafe \<equiv> \<lambda>ptr bits s. \<forall>p t m. 105 (cte_wp_at' (\<lambda>cte. cteCap cte = capability.ReplyCap t m) p s \<longrightarrow> 106 t \<notin> {ptr .. ptr + 2 ^ bits - 1}) \<and> 107 (\<forall>ko. ksPSpace s p = Some (KOArch ko) \<and> p \<in> {ptr .. ptr + 2 ^ bits - 1} 108 \<longrightarrow> 6 \<le> bits)" 109 110defs ksASIDMapSafe_def: 111 "ksASIDMapSafe \<equiv> \<lambda>s. \<forall>asid hw_asid pd. 112 armKSASIDMap (ksArchState s) asid = Some (hw_asid,pd) \<longrightarrow> page_directory_at' pd s" 113 114defs cNodePartialOverlap_def: 115 "cNodePartialOverlap \<equiv> \<lambda>cns inRange. \<exists>p n. cns p = Some n 116 \<and> (\<not> is_aligned p (cte_level_bits + n) 117 \<or> cte_level_bits + n \<ge> word_bits 118 \<or> (\<not> {p .. p + 2 ^ (cte_level_bits + n) - 1} \<subseteq> {p. inRange p} 119 \<and> \<not> {p .. p + 2 ^ (cte_level_bits + n) - 1} \<subseteq> {p. \<not> inRange p}))" 120 121(* FIXME: move *) 122lemma deleteObjects_def2: 123 "is_aligned ptr bits \<Longrightarrow> 124 deleteObjects ptr bits = do 125 stateAssert (deletionIsSafe ptr bits) []; 126 doMachineOp (freeMemory ptr bits); 127 stateAssert (\<lambda>s. \<not> cNodePartialOverlap (gsCNodes s) (\<lambda>x. x \<in> {ptr .. ptr + 2 ^ bits - 1})) []; 128 modify (\<lambda>s. s \<lparr> ksPSpace := \<lambda>x. if x \<in> {ptr .. ptr + 2 ^ bits - 1} 129 then None else ksPSpace s x, 130 gsUserPages := \<lambda>x. if x \<in> {ptr .. ptr + 2 ^ bits - 1} 131 then None else gsUserPages s x, 132 gsCNodes := \<lambda>x. if x \<in> {ptr .. ptr + 2 ^ bits - 1} 133 then None else gsCNodes s x \<rparr>); 134 stateAssert ksASIDMapSafe [] 135 od" 136 apply (simp add: deleteObjects_def is_aligned_mask[symmetric] unless_def) 137 apply (rule bind_eqI, rule ext) 138 apply (rule bind_eqI, rule ext) 139 apply (simp add: bind_assoc[symmetric]) 140 apply (rule bind_cong[rotated], rule refl) 141 apply (simp add: bind_assoc modify_modify deleteRange_def gets_modify_def) 142 apply (rule ext, simp add: exec_modify stateAssert_def assert_def bind_assoc exec_get 143 NOT_eq[symmetric] mask_in_range) 144 apply (clarsimp simp: simpler_modify_def) 145 apply (simp add: data_map_filterWithKey_def split: if_split_asm) 146 apply (rule arg_cong2[where f=gsCNodes_update]) 147 apply (simp add: NOT_eq[symmetric] mask_in_range ext) 148 apply (rule arg_cong2[where f=gsUserPages_update]) 149 apply (simp add: NOT_eq[symmetric] mask_in_range ext) 150 apply (rule arg_cong[where f="\<lambda>f. ksPSpace_update f s" for s]) 151 apply (simp add: NOT_eq[symmetric] mask_in_range ext split: option.split) 152 done 153 154lemma deleteObjects_def3: 155 "deleteObjects ptr bits = 156 do 157 assert (is_aligned ptr bits); 158 stateAssert (deletionIsSafe ptr bits) []; 159 doMachineOp (freeMemory ptr bits); 160 stateAssert (\<lambda>s. \<not> cNodePartialOverlap (gsCNodes s) (\<lambda>x. x \<in> {ptr .. ptr + 2 ^ bits - 1})) []; 161 modify (\<lambda>s. s \<lparr> ksPSpace := \<lambda>x. if x \<in> {ptr .. ptr + 2 ^ bits - 1} 162 then None else ksPSpace s x, 163 gsUserPages := \<lambda>x. if x \<in> {ptr .. ptr + 2 ^ bits - 1} 164 then None else gsUserPages s x, 165 gsCNodes := \<lambda>x. if x \<in> {ptr .. ptr + 2 ^ bits - 1} 166 then None else gsCNodes s x \<rparr>); 167 stateAssert ksASIDMapSafe [] 168 od" 169 apply (cases "is_aligned ptr bits") 170 apply (simp add: deleteObjects_def2) 171 apply (simp add: deleteObjects_def is_aligned_mask 172 unless_def alignError_def) 173 done 174 175lemma obj_relation_cuts_in_obj_range: 176 "\<lbrakk> (y, P) \<in> obj_relation_cuts ko x; x \<in> obj_range x ko; 177 kheap s x = Some ko; valid_objs s; pspace_aligned s \<rbrakk> \<Longrightarrow> y \<in> obj_range x ko" 178 apply (cases ko, simp_all) 179 apply (clarsimp split: if_split_asm) 180 apply (subgoal_tac "cte_at (x, ya) s") 181 apply (drule(2) cte_at_cte_map_in_obj_bits) 182 apply (simp add: obj_range_def) 183 apply (fastforce intro: cte_wp_at_cteI) 184 apply (frule(1) pspace_alignedD) 185 apply (frule valid_obj_sizes, erule ranI) 186 apply (rename_tac arch_kernel_obj) 187 apply (case_tac arch_kernel_obj, simp_all) 188 apply (clarsimp simp only: obj_range_def field_simps atLeastAtMost_iff 189 obj_bits.simps arch_kobj_size.simps) 190 apply (rule context_conjI) 191 apply (erule is_aligned_no_wrap') 192 apply simp 193 apply (simp add: ucast_less_shiftl_helper) 194 apply (subst add_diff_eq[symmetric]) 195 apply (rule word_plus_mono_right) 196 apply (subst word_less_sub_le, simp) 197 apply (simp add: ucast_less_shiftl_helper) 198 apply (simp add: field_simps) 199 apply (clarsimp simp only: obj_range_def field_simps atLeastAtMost_iff 200 obj_bits.simps arch_kobj_size.simps) 201 apply (rule context_conjI) 202 apply (erule is_aligned_no_wrap') 203 apply simp 204 apply (simp add: ucast_less_shiftl_helper) 205 apply (subst add_diff_eq[symmetric]) 206 apply (rule word_plus_mono_right) 207 apply (subst word_less_sub_le, simp) 208 apply (simp add: ucast_less_shiftl_helper) 209 apply (simp add: field_simps) 210 apply (rename_tac vmpage_size) 211 apply (clarsimp simp only: obj_range_def field_simps atLeastAtMost_iff 212 obj_bits.simps arch_kobj_size.simps) 213 apply (subgoal_tac "n * 2 ^ pageBits < 2 ^ pageBitsForSize vmpage_size") 214 apply (rule context_conjI) 215 apply (erule is_aligned_no_wrap') 216 apply assumption 217 apply (subst add_diff_eq[symmetric]) 218 apply (rule word_plus_mono_right) 219 apply (subst word_less_sub_le, simp add: word_bits_def) 220 apply assumption 221 apply (simp add: field_simps) 222 apply (erule word_less_power_trans2) 223 apply (case_tac vmpage_size, simp_all add: pageBits_def)[1] 224 apply (simp add: word_bits_def) 225 done 226 227lemma obj_relation_cuts_eqv_base_in_detype_range: 228 "\<lbrakk> (y, P) \<in> obj_relation_cuts ko x; kheap s x = Some ko; 229 valid_objs s; pspace_aligned s; 230 valid_untyped (cap.UntypedCap d base bits idx) s \<rbrakk> 231 \<Longrightarrow> (x \<in> {base .. base + 2 ^ bits - 1}) = (y \<in> {base .. base + 2 ^ bits - 1})" 232 apply (simp add: valid_untyped_def del: atLeastAtMost_iff) 233 apply (subgoal_tac "x \<in> obj_range x ko") 234 apply (subgoal_tac "y \<in> obj_range x ko") 235 apply blast 236 apply (erule(4) obj_relation_cuts_in_obj_range) 237 apply (simp add: obj_range_def) 238 apply (rule is_aligned_no_overflow) 239 apply (erule(1) pspace_alignedD) 240 done 241 242lemma detype_pspace_relation: 243 assumes psp: "pspace_relation (kheap s) (ksPSpace s')" 244 and bwb: "bits < word_bits" 245 and al: "is_aligned base bits" 246 and vs: "valid_pspace s" 247 and vu: "valid_untyped (cap.UntypedCap d base bits idx) s" 248 shows "pspace_relation (kheap (detype {base .. base + 2 ^ bits - 1} s)) 249 (\<lambda>x. if x \<in> {base .. base + 2 ^ bits - 1} then None else ksPSpace s' x)" 250 (is "pspace_relation ?ps ?ps'") 251proof - 252 let ?range = "{base .. base + 2 ^ bits - 1}" 253 let ?ps'' = "(kheap s |` (-?range))" 254 255 have pa: "pspace_aligned s" and vo: "valid_objs s" 256 using vs by (simp add: valid_pspace_def)+ 257 258 have pspace: 259 "\<And>x. \<lbrakk> x \<notin> ?range; x \<in> dom (kheap s) \<rbrakk> \<Longrightarrow> ?ps x = kheap s x" 260 by (clarsimp simp add: detype_def field_simps) 261 262 have pspace'': 263 "\<And>x. \<lbrakk> x \<notin> ?range; x \<in> dom (kheap s) \<rbrakk> \<Longrightarrow> ?ps'' x = kheap s x" 264 by (clarsimp simp add: detype_def) 265 266 have psdom_pre: "dom ?ps = (dom (kheap s) - ?range)" 267 by (fastforce simp:field_simps) 268 269 show ?thesis 270 unfolding pspace_relation_def 271 proof (intro conjI) 272 273 have domeq': "dom (ksPSpace s') = pspace_dom (kheap s)" 274 using psp by (simp add: pspace_relation_def) 275 276 note eqv_base_in = obj_relation_cuts_eqv_base_in_detype_range 277 [OF _ _ vo pa vu] 278 279 note atLeastAtMost_iff[simp del] 280 show domeq: "pspace_dom ?ps = dom ?ps'" 281 apply (simp add: dom_if_None domeq') 282 apply (simp add: pspace_dom_def detype_def dom_if_None) 283 apply (intro set_eqI iffI, simp_all) 284 apply (clarsimp simp: eqv_base_in field_simps) 285 apply (rule rev_bexI, erule domI) 286 apply (simp add: image_def, erule rev_bexI, simp) 287 apply (elim exE bexE DiffE conjE domE) 288 apply (rule bexI, assumption) 289 apply (clarsimp simp add: eqv_base_in field_simps) 290 done 291 292 show "\<forall>x\<in>dom ?ps. 293 \<forall>(y, P)\<in>obj_relation_cuts (the (?ps x)) x. 294 P (the (?ps x)) 295 (the (if y \<in> ?range then None else ksPSpace s' y))" 296 using psp 297 apply (simp add: pspace_relation_def psdom_pre split del: if_split) 298 apply (erule conjE, rule ballI, erule DiffE, drule(1) bspec) 299 apply (erule domE) 300 apply (simp add: field_simps detype_def cong: conj_cong) 301 apply (erule ballEI, clarsimp) 302 apply (simp add: eqv_base_in) 303 done 304 qed 305qed 306 307declare plus_Collect_helper2[simp] 308 309lemma cte_map_obj_range_helper: 310 "\<lbrakk> cte_at cref s; pspace_aligned s; valid_objs s \<rbrakk> 311 \<Longrightarrow> \<exists>ko. kheap s (fst cref) = Some ko \<and> cte_map cref \<in> obj_range (fst cref) ko" 312 apply (drule(2) cte_at_cte_map_in_obj_bits) 313 apply (clarsimp simp: obj_range_def) 314 done 315 316lemma cte_map_untyped_range: 317 "\<lbrakk> s \<turnstile> cap; cte_at cref s; pspace_aligned s; valid_objs s \<rbrakk> 318 \<Longrightarrow> (cte_map cref \<in> untyped_range cap) = (fst cref \<in> untyped_range cap)" 319 apply (cases cap, simp_all) 320 apply (drule(2) cte_map_obj_range_helper) 321 apply (clarsimp simp: valid_cap_def valid_untyped_def) 322 apply (elim allE, drule(1) mp) 323 apply (rule iffI) 324 apply (erule impE) 325 apply (rule notemptyI[where x="cte_map cref"]) 326 apply simp 327 apply clarsimp 328 apply (drule subsetD [OF _ p_in_obj_range]) 329 apply simp+ 330 apply (erule impE) 331 apply (rule notemptyI[where x="fst cref"]) 332 apply (simp add: p_in_obj_range) 333 apply clarsimp 334 apply (drule(1) subsetD) 335 apply simp 336 done 337 338lemma pspace_aligned'_cut: 339 "pspace_aligned' s \<Longrightarrow> 340 pspace_aligned' (s \<lparr> ksPSpace := \<lambda>x. if P x then None else ksPSpace s x\<rparr>)" 341 by (simp add: pspace_aligned'_def dom_if_None) 342 343lemma pspace_distinct'_cut: 344 "pspace_distinct' s \<Longrightarrow> 345 pspace_distinct' (s \<lparr> ksPSpace := \<lambda>x. if P x then None else ksPSpace s x\<rparr>)" 346 by (simp add: pspace_distinct'_def dom_if_None ps_clear_def 347 Diff_Int_distrib) 348 349lemma ko_wp_at_delete': 350 "pspace_distinct' s \<Longrightarrow> 351 ko_wp_at' P p (s \<lparr> ksPSpace := \<lambda>x. if base \<le> x \<and> x \<le> base + (2 ^ magnitude - 1) then None else ksPSpace s x \<rparr>) 352 = (\<not> (base \<le> p \<and> p \<le> base + (2 ^ magnitude - 1)) \<and> ko_wp_at' P p s)" 353 apply (simp add: ko_wp_at'_def projectKOs ps_clear_def dom_if_None) 354 apply (intro impI iffI) 355 apply clarsimp 356 apply (drule(1) pspace_distinctD') 357 apply (simp add: ps_clear_def) 358 apply (clarsimp simp: Diff_Int_distrib) 359 done 360 361lemma obj_at_delete': 362 "pspace_distinct' s \<Longrightarrow> 363 obj_at' P p (s \<lparr> ksPSpace := \<lambda>x. if base \<le> x \<and> x \<le> base + (2 ^ magnitude - 1) then None else ksPSpace s x \<rparr>) 364 = (\<not> (base \<le> p \<and> p \<le> base + (2 ^ magnitude - 1)) \<and> obj_at' P p s)" 365 unfolding obj_at'_real_def 366 by (rule ko_wp_at_delete') 367 368lemma cte_wp_at_delete': 369 "\<lbrakk> s \<turnstile>' UntypedCap d base magnitude idx; pspace_distinct' s \<rbrakk> \<Longrightarrow> 370 cte_wp_at' P p (s \<lparr> ksPSpace := \<lambda>x. if base \<le> x \<and> x \<le> base + (2 ^ magnitude - 1) then None else ksPSpace s x \<rparr>) 371 = (\<not> (base \<le> p \<and> p \<le> base + (2 ^ magnitude - 1)) \<and> cte_wp_at' P p s)" 372 apply (simp add: cte_wp_at_obj_cases' obj_at_delete') 373 apply (subgoal_tac "\<forall>Q n. obj_at' Q (p - n) s \<and> tcb_cte_cases n \<noteq> None \<longrightarrow> 374 ((p - n) \<in> {base .. base + (2 ^ magnitude - 1)}) 375 = (p \<in> {base .. base + (2 ^ magnitude - 1)})") 376 apply auto[1] 377 apply (clarsimp simp: obj_at'_real_def projectKOs valid_cap'_def 378 valid_untyped'_def 379 simp del: atLeastAtMost_iff) 380 apply (drule_tac x="p - n" in spec) 381 apply (clarsimp simp: ko_wp_at'_def capAligned_def 382 simp del: atLeastAtMost_iff) 383 apply (thin_tac "is_aligned x minUntypedSizeBits" for x) 384 apply (drule(1) aligned_ranges_subset_or_disjoint) 385 apply (subgoal_tac "{p, p - n} \<subseteq> obj_range' (p - n) (KOTCB obj)") 386 apply (clarsimp simp del: atLeastAtMost_iff 387 simp: field_simps objBits_simps obj_range'_def) 388 apply fastforce 389 apply (simp add: obj_range'_def mask_in_range[symmetric] 390 del: atLeastAtMost_iff) 391 apply (simp add: objBits_simps) 392 apply (frule(1) tcb_cte_cases_aligned_helpers) 393 apply (simp add: is_aligned_neg_mask_eq) 394 done 395 396lemma map_to_ctes_delete: 397 assumes vc: "s \<turnstile>' UntypedCap d base magnitude idx" 398 and vs: "pspace_distinct' s" 399 shows 400 "map_to_ctes (\<lambda>x. if base \<le> x \<and> x \<le> base + (2 ^ magnitude - 1) then None else ksPSpace s x) 401 = (\<lambda>x. if base \<le> x \<and> x \<le> base + (2 ^ magnitude - 1) then None else ctes_of s x)" 402 using cte_wp_at_delete' [where P="(=) cte" for cte, OF vc vs] 403 arg_cong [where f=Not, OF cte_wp_at_delete' [OF vc vs, where P="\<top>"]] 404 apply (simp (no_asm_use) add: cte_wp_at_ctes_of) 405 apply (rule ext) 406 apply (case_tac "map_to_ctes (\<lambda>x. if base \<le> x \<and> x \<le> base + (2 ^ magnitude - 1) then None else ksPSpace s x) x") 407 apply (fastforce split: if_split_asm) 408 apply simp 409 done 410 411lemma word_range_card: 412 "base \<le>base + h \<Longrightarrow> card {base..base + (h::word32)} = (unat h) + 1" 413proof (induct h) 414 case 1 show ?case by simp 415next 416 case (2 h) 417 have interval_plus_one_word32: 418 "\<And>base ceil. \<lbrakk>base \<le> ceil + 1;ceil \<le> ceil + 1\<rbrakk> \<Longrightarrow> 419 {base..ceil + 1} = {base .. ceil } \<union> {ceil + (1::word32)}" 420 by (auto intro:order_antisym simp:not_le inc_le) 421 show ?case 422 apply (subst add.commute[where a = 1]) 423 apply (subst add.assoc[symmetric]) 424 apply (subst interval_plus_one_word32) 425 using 2 426 apply (simp add: field_simps) 427 apply (subst add.assoc) 428 apply (rule word_plus_mono_right) 429 using 2 plus_one_helper2[where n = h and x = h,simplified] 430 apply (simp add: field_simps) 431 using 2 432 apply (simp add: field_simps) 433 apply (subst card_Un_disjoint,simp+) 434 using 2 435 apply (clarsimp simp: field_simps) 436 using 2 437 apply (subst 2) 438 apply (erule word_plus_mono_right2) 439 using 2 plus_one_helper2[where n = h and x = h,simplified] 440 apply (simp add: field_simps) 441 apply simp 442 apply (simp add: unatSuc) 443 done 444qed 445 446end 447locale detype_locale' = detype_locale + constrains s::"det_state" 448 449lemma (in detype_locale') deletionIsSafe: 450 assumes sr: "(s, s') \<in> state_relation" 451 and cap: "cap = cap.UntypedCap d base magnitude idx" 452 and vs: "valid_pspace s" 453 and al: "is_aligned base magnitude" 454 and vu: "valid_untyped (cap.UntypedCap d base magnitude idx) s" 455 shows "deletionIsSafe base magnitude s'" 456proof - 457 interpret Arch . (* FIXME: arch_split *) 458 note blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff 459 Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex 460 atLeastAtMost_iff 461 have "\<And>t m. \<exists>ptr. cte_wp_at ((=) (cap.ReplyCap t m)) ptr s 462 \<Longrightarrow> t \<notin> {base .. base + 2 ^ magnitude - 1}" 463 by (fastforce dest!: valid_cap2 simp: cap obj_reply_refs_def) 464 hence "\<forall>ptr t m. cte_wp_at ((=) (cap.ReplyCap t m)) ptr s 465 \<longrightarrow> t \<notin> {base .. base + 2 ^ magnitude - 1}" 466 by (fastforce simp del: split_paired_All) 467 hence "\<forall>t. t \<in> {base .. base + 2 ^ magnitude - 1} \<longrightarrow> 468 (\<forall>ptr m. \<not> cte_wp_at ((=) (cap.ReplyCap t m)) ptr s)" 469 by fastforce 470 hence cte: "\<forall>t. t \<in> {base .. base + 2 ^ magnitude - 1} \<longrightarrow> 471 (\<forall>ptr m. \<not> cte_wp_at' (\<lambda>cte. cteCap cte = ReplyCap t m) ptr s')" 472 unfolding deletionIsSafe_def 473 apply - 474 apply (erule allEI) 475 apply (rule impI, drule(1) mp) 476 apply (thin_tac "t \<in> S" for S) 477 apply (intro allI) 478 apply (clarsimp simp: cte_wp_at_neg2 cte_wp_at_ctes_of 479 simp del: split_paired_All) 480 apply (frule pspace_relation_cte_wp_atI [rotated]) 481 apply (rule invs_valid_objs [OF invs]) 482 apply (rule state_relation_pspace_relation [OF sr]) 483 apply (clarsimp simp: cte_wp_at_neg2 simp del: split_paired_All) 484 apply (drule_tac x="(a,b)" in spec) 485 apply (clarsimp simp: cte_wp_cte_at cte_wp_at_caps_of_state) 486 apply (case_tac c, simp_all) 487 apply fastforce 488 done 489 490 have arch: "\<And> ko p. \<lbrakk> ksPSpace s' p = Some (KOArch ko); p \<in> {base..base + 2 ^ magnitude - 1} \<rbrakk> 491 \<Longrightarrow> 6 \<le> magnitude" 492 using sr vs vu 493 apply (clarsimp simp: state_relation_def) 494 apply (erule(1) pspace_dom_relatedE) 495 apply (frule obj_relation_cuts_eqv_base_in_detype_range[symmetric]) 496 apply simp 497 apply (clarsimp simp:valid_pspace_def)+ 498 apply simp 499 apply (clarsimp simp:valid_untyped_def) 500 apply (drule spec)+ 501 apply (erule(1) impE) 502 apply (erule impE) 503 apply (drule p_in_obj_range) 504 apply (clarsimp)+ 505 apply blast 506 apply clarsimp 507 apply (drule card_mono[rotated]) 508 apply fastforce 509 apply (clarsimp simp:valid_pspace_def obj_range_def p_assoc_help) 510 apply (subst (asm) word_range_card) 511 apply (rule is_aligned_no_overflow') 512 apply (erule(1) pspace_alignedD) 513 apply (subst (asm) word_range_card) 514 apply (rule is_aligned_no_overflow'[OF al]) 515 apply (rule ccontr) 516 apply (simp add:not_le) 517 apply (subgoal_tac "obj_bits koa < 32") 518 prefer 2 519 apply (case_tac koa,simp_all add:objBits_simps word_bits_def) 520 apply (drule(1) valid_cs_size_objsI) 521 apply (clarsimp simp:valid_cs_size_def word_bits_def cte_level_bits_def) 522 apply (rename_tac arch_kernel_obj) 523 apply (case_tac arch_kernel_obj,simp_all add:pageBits_def word_bits_def) 524 apply (simp add:pageBitsForSize_def split:vmpage_size.splits) 525 apply (subgoal_tac "6 \<le> obj_bits koa") 526 apply simp 527 apply (case_tac koa, simp_all add: other_obj_relation_def 528 objBits_simps cte_relation_def 529 split: if_splits) 530 apply (rename_tac arch_kernel_obj, 531 case_tac arch_kernel_obj; 532 simp add: arch_kobj_size_def pageBits_def pageBitsForSize_def)+ 533 done 534 thus ?thesis using cte by (auto simp: deletionIsSafe_def) 535qed 536context begin interpretation Arch . (*FIXME: arch_split*) 537lemma ksASIDMapSafeI: 538 "\<lbrakk> (s,s') \<in> state_relation; invs s; pspace_aligned' s' \<and> pspace_distinct' s' \<rbrakk> 539 \<Longrightarrow> ksASIDMapSafe s'" 540 apply (clarsimp simp: ksASIDMapSafe_def) 541 apply (subgoal_tac "valid_asid_map s") 542 prefer 2 543 apply fastforce 544 apply (clarsimp simp: valid_asid_map_def graph_of_def) 545 apply (subgoal_tac "arm_asid_map (arch_state s) asid = Some (hw_asid, pd)") 546 prefer 2 547 apply (clarsimp simp: state_relation_def arch_state_relation_def) 548 apply (erule allE)+ 549 apply (erule (1) impE) 550 apply clarsimp 551 apply (drule find_pd_for_asid_eq_helper) 552 apply fastforce 553 apply assumption 554 apply fastforce 555 apply clarsimp 556 apply (rule pspace_relation_pd) 557 apply (fastforce simp: state_relation_def) 558 apply fastforce 559 apply assumption 560 apply assumption 561 apply simp 562 done 563 564(* FIXME: generalizes lemma SubMonadLib.corres_submonad *) 565(* FIXME: generalizes lemma SubMonad_R.corres_machine_op *) 566(* FIXME: move *) 567lemma corres_machine_op: 568 assumes P: "corres_underlying Id False True r P Q x x'" 569 shows "corres r (P \<circ> machine_state) (Q \<circ> ksMachineState) 570 (do_machine_op x) (doMachineOp x')" 571 apply (rule corres_submonad3 572 [OF submonad_do_machine_op submonad_doMachineOp _ _ _ _ P]) 573 apply (simp_all add: state_relation_def swp_def) 574 done 575 576lemma ekheap_relation_detype: 577 "ekheap_relation ekh kh \<Longrightarrow> 578 ekheap_relation (\<lambda>x. if P x then None else (ekh x)) (\<lambda>x. if P x then None else (kh x))" 579 by (fastforce simp add: ekheap_relation_def split: if_split_asm) 580 581lemma cap_table_at_gsCNodes_eq: 582 "(s, s') \<in> state_relation 583 \<Longrightarrow> (gsCNodes s' ptr = Some bits) = cap_table_at bits ptr s" 584 apply (clarsimp simp: state_relation_def ghost_relation_def 585 obj_at_def is_cap_table) 586 apply (drule_tac x = ptr in spec)+ 587 apply (drule_tac x = bits in spec)+ 588 apply fastforce 589 done 590 591lemma cNodeNoPartialOverlap: 592 "corres dc (\<lambda>s. \<exists>cref. cte_wp_at ((=) (cap.UntypedCap d base magnitude idx)) cref s 593 \<and> valid_objs s \<and> pspace_aligned s) 594 \<top> 595 (return x) (stateAssert (\<lambda>s. \<not> cNodePartialOverlap (gsCNodes s) 596 (\<lambda>x. base \<le> x \<and> x \<le> base + 2 ^ magnitude - 1)) [])" 597 apply (simp add: stateAssert_def assert_def) 598 apply (rule corres_symb_exec_r[OF _ get_sp]) 599 apply (rule corres_req[rotated], subst if_P, assumption) 600 apply simp 601 apply (clarsimp simp: cNodePartialOverlap_def) 602 apply (drule(1) cte_wp_valid_cap) 603 apply (clarsimp simp: valid_cap_def valid_untyped_def cap_table_at_gsCNodes_eq 604 obj_at_def is_cap_table) 605 apply (frule(1) pspace_alignedD) 606 apply simp 607 apply (elim allE, drule(1) mp, simp add: obj_range_def valid_obj_def cap_aligned_def) 608 apply (erule is_aligned_get_word_bits[where 'a=32, folded word_bits_def]) 609 apply (clarsimp simp: is_aligned_no_overflow) 610 apply (blast intro: order_trans) 611 apply (simp add: is_aligned_no_overflow power_overflow word_bits_def) 612 apply wp+ 613 done 614 615 616declare wrap_ext_det_ext_ext_def[simp] 617 618(* Just for ARM *) 619lemma sym_refs_hyp_refs_triv[simp]: "sym_refs (state_hyp_refs_of s)" 620 apply (auto simp: state_hyp_refs_of_def sym_refs_def) 621 apply (case_tac "kheap s x"; simp add: hyp_refs_of_def) 622 apply (rename_tac ko) 623 apply (case_tac ko; clarsimp) 624 done 625 626lemma detype_corres: 627 "is_aligned base magnitude \<Longrightarrow> magnitude \<ge> 2 \<Longrightarrow> 628 corres dc 629 (\<lambda>s. einvs s 630 \<and> s \<turnstile> (cap.UntypedCap d base magnitude idx) 631 \<and> (\<exists>cref. cte_wp_at ((=) (cap.UntypedCap d base magnitude idx)) cref s 632 \<and> descendants_range (cap.UntypedCap d base magnitude idx) cref s) 633 \<and> untyped_children_in_mdb s \<and> if_unsafe_then_cap s 634 \<and> valid_mdb s \<and> valid_global_refs s \<and> ct_active s) 635 (\<lambda>s. s \<turnstile>' (UntypedCap d base magnitude idx) 636 \<and> valid_pspace' s) 637 (delete_objects base magnitude) (deleteObjects base magnitude)" 638 apply (simp add: deleteObjects_def2) 639 apply (rule corres_stateAssert_implied[where P'=\<top>, simplified]) 640 prefer 2 641 apply clarsimp 642 apply (rule_tac cap="cap.UntypedCap d base magnitude idx" and ptr="(a,b)" and 643 s=s in detype_locale'.deletionIsSafe, 644 simp_all add: detype_locale'_def 645 detype_locale_def p_assoc_help invs_valid_pspace)[1] 646 apply (simp add:valid_cap_simps) 647 apply (simp add: bind_assoc[symmetric]) 648 apply (rule corres_stateAssert_implied2) 649 defer 650 apply (erule ksASIDMapSafeI, assumption, assumption) 651 apply (rule hoare_pre) 652 apply (rule delete_objects_invs) 653 apply fastforce 654 apply (simp add: doMachineOp_def split_def) 655 apply wp 656 apply (clarsimp simp: valid_pspace'_def pspace_distinct'_def 657 pspace_aligned'_def) 658 apply (rule conjI) 659 subgoal by fastforce 660 apply (clarsimp simp add: pspace_distinct'_def ps_clear_def 661 dom_if_None Diff_Int_distrib) 662 apply (simp add: delete_objects_def) 663 apply (rule_tac Q="\<lambda>_ s. valid_objs s \<and> valid_list s \<and> 664 (\<exists>cref. cte_wp_at ((=) (cap.UntypedCap d base magnitude idx)) cref s \<and> 665 descendants_range (cap.UntypedCap d base magnitude idx) cref s ) \<and> 666 s \<turnstile> cap.UntypedCap d base magnitude idx \<and> pspace_aligned s \<and> 667 valid_mdb s \<and> pspace_distinct s \<and> if_live_then_nonz_cap s \<and> 668 zombies_final s \<and> sym_refs (state_refs_of s) \<and> 669 untyped_children_in_mdb s \<and> if_unsafe_then_cap s \<and> 670 valid_global_refs s" and 671 Q'="\<lambda>_ s. s \<turnstile>' capability.UntypedCap d base magnitude idx \<and> 672 valid_pspace' s" in corres_split') 673 apply (rule corres_bind_return) 674 apply (rule corres_guard_imp[where r=dc]) 675 apply (rule corres_split[OF cNodeNoPartialOverlap]) 676 apply (rule corres_machine_op[OF corres_Id], simp+) 677 apply (rule no_fail_freeMemory, simp+) 678 apply (wp hoare_vcg_ex_lift)+ 679 apply auto[1] 680 apply (auto elim: is_aligned_weaken) 681 apply (rule corres_modify) 682 apply (simp add: valid_pspace'_def) 683 apply (rule state_relation_null_filterE, assumption, 684 simp_all add: pspace_aligned'_cut pspace_distinct'_cut)[1] 685 apply (simp add: detype_def, rule state.equality; simp add: detype_ext_def) 686 apply (intro exI, fastforce) 687 apply (rule ext, clarsimp simp add: null_filter_def) 688 apply (rule sym, rule ccontr, clarsimp) 689 apply (drule(4) cte_map_not_null_outside') 690 apply (fastforce simp add: cte_wp_at_caps_of_state) 691 apply simp 692 apply (rule ext, clarsimp simp add: null_filter'_def 693 map_to_ctes_delete[simplified field_simps]) 694 apply (rule sym, rule ccontr, clarsimp) 695 apply (frule(2) pspace_relation_cte_wp_atI 696 [OF state_relation_pspace_relation]) 697 apply (elim exE) 698 apply (frule(4) cte_map_not_null_outside') 699 apply (rule cte_wp_at_weakenE, erule conjunct1) 700 apply (case_tac y, clarsimp) 701 apply (clarsimp simp: valid_mdb'_def valid_mdb_ctes_def 702 valid_nullcaps_def) 703 apply clarsimp 704 apply (frule_tac cref="(aa, ba)" in cte_map_untyped_range, 705 erule cte_wp_at_weakenE[OF _ TrueI], assumption+) 706 apply simp 707 apply (rule detype_pspace_relation[simplified], 708 simp_all add: state_relation_pspace_relation valid_pspace_def)[1] 709 apply (simp add: valid_cap'_def capAligned_def) 710 apply (clarsimp simp: valid_cap_def, assumption) 711 apply (fastforce simp add: detype_def detype_ext_def intro!: ekheap_relation_detype) 712 apply (clarsimp simp: state_relation_def ghost_relation_of_heap 713 detype_def) 714 apply (drule_tac t="gsUserPages s'" in sym) 715 apply (drule_tac t="gsCNodes s'" in sym) 716 apply (auto simp add: ups_of_heap_def cns_of_heap_def ext 717 split: option.splits kernel_object.splits)[1] 718 apply (simp add: valid_mdb_def) 719 apply (wp hoare_vcg_ex_lift hoare_vcg_ball_lift | wps | 720 simp add: invs_def valid_state_def valid_pspace_def 721 descendants_range_def | wp_once hoare_drop_imps)+ 722 done 723 724 725text {* Invariant preservation across concrete deletion *} 726 727lemma caps_containedD': 728 "\<lbrakk> ctes_of s p = Some cte; ctes_of s p' = Some cte'; 729 \<not> isUntypedCap (cteCap cte); capRange (cteCap cte) \<inter> untypedRange (cteCap cte') \<noteq> {}; 730 caps_contained' (ctes_of s) \<rbrakk> \<Longrightarrow> 731 capRange (cteCap cte) \<subseteq> untypedRange (cteCap cte')" 732 apply (cases cte, cases cte') 733 apply (simp add: caps_contained'_def) 734 apply blast 735 done 736 737lemma untyped_mdbD': 738 "\<lbrakk> ctes p = Some cte; ctes p' = Some cte'; 739 isUntypedCap (cteCap cte); capRange (cteCap cte') \<inter> untypedRange (cteCap cte) \<noteq> {}; 740 \<not> isUntypedCap (cteCap cte'); 741 untyped_mdb' ctes \<rbrakk> \<Longrightarrow> p' \<in> descendants_of' p ctes" 742 by (cases cte, cases cte', simp add: untyped_mdb'_def) 743 744lemma ko_wp_at_state_refs_ofD: 745 "\<lbrakk> ko_wp_at' P p s \<rbrakk> \<Longrightarrow> (\<exists>ko. P ko \<and> state_refs_of' s p = refs_of' ko)" 746 by (fastforce simp: ko_wp_at'_def state_refs_of'_def) 747 748lemma sym_refs_ko_wp_atD: 749 "\<lbrakk> ko_wp_at' P p s; sym_refs (state_refs_of' s) \<rbrakk> 750 \<Longrightarrow> (\<exists>ko. P ko \<and> state_refs_of' s p = refs_of' ko 751 \<and> (\<forall>(x, tp) \<in> refs_of' ko. (p, symreftype tp) \<in> state_refs_of' s x))" 752 apply (clarsimp dest!: ko_wp_at_state_refs_ofD) 753 apply (rule exI, erule conjI) 754 apply (drule sym) 755 apply clarsimp 756 apply (erule(1) sym_refsD) 757 done 758 759lemma zobj_refs_capRange: 760 "capAligned c \<Longrightarrow> zobj_refs' c \<subseteq> capRange c" 761 by (cases c, simp_all add: capRange_def capAligned_def is_aligned_no_overflow) 762end 763locale delete_locale = 764 fixes s and base and bits and ptr and idx and d 765 assumes cap: "cte_wp_at' (\<lambda>cte. cteCap cte = UntypedCap d base bits idx) ptr s" 766 and nodesc: "descendants_range' (UntypedCap d base bits idx) ptr (ctes_of s)" 767 and invs: "invs' s" 768 and ct_act: "ct_active' s" 769 and sa_simp: "sch_act_simple s" 770 and bwb: "bits < word_bits" 771 and al: "is_aligned base bits" 772 and safe: "deletionIsSafe base bits s" 773 774context delete_locale 775begin 776interpretation Arch . (*FIXME: arch_split*) 777lemma valid_objs: "valid_objs' s" 778 and pa: "pspace_aligned' s" 779 and pd: "pspace_distinct' s" 780 and vq: "valid_queues s" 781 and vq': "valid_queues' s" 782 and sym_refs: "sym_refs (state_refs_of' s)" 783 and iflive: "if_live_then_nonz_cap' s" 784 and ifunsafe: "if_unsafe_then_cap' s" 785 and dlist: "valid_dlist (ctes_of s)" 786 and no_0: "no_0 (ctes_of s)" 787 and chain_0: "mdb_chain_0 (ctes_of s)" 788 and badges: "valid_badges (ctes_of s)" 789 and contained: "caps_contained' (ctes_of s)" 790 and chunked: "mdb_chunked (ctes_of s)" 791 and umdb: "untyped_mdb' (ctes_of s)" 792 and uinc: "untyped_inc' (ctes_of s)" 793 and nullcaps: "valid_nullcaps (ctes_of s)" 794 and ut_rev: "ut_revocable' (ctes_of s)" 795 and dist_z: "distinct_zombies (ctes_of s)" 796 and irq_ctrl: "irq_control (ctes_of s)" 797 and clinks: "class_links (ctes_of s)" 798 and rep_r_fb: "reply_masters_rvk_fb (ctes_of s)" 799 and idle: "valid_idle' s" 800 and refs: "valid_global_refs' s" 801 and arch: "valid_arch_state' s" 802 and virq: "valid_irq_node' (irq_node' s) s" 803 and virqh: "valid_irq_handlers' s" 804 and virqs: "valid_irq_states' s" 805 and no_0_objs: "no_0_obj' s" 806 and ctnotinQ: "ct_not_inQ s" 807 and pde_maps: "valid_pde_mappings' s" 808 and irqs_masked: "irqs_masked' s" 809 and ctcd: "ct_idle_or_in_cur_domain' s" 810 and cdm: "ksCurDomain s \<le> maxDomain" 811 and vds: "valid_dom_schedule' s" 812 using invs 813 by (auto simp add: invs'_def valid_state'_def valid_pspace'_def 814 valid_mdb'_def valid_mdb_ctes_def) 815 816abbreviation 817 "base_bits \<equiv> {base .. base + (2 ^ bits - 1)}" 818 819abbreviation 820 "state' \<equiv> (s \<lparr> ksPSpace := \<lambda>x. if base \<le> x \<and> x \<le> base + (2 ^ bits - 1) then None else ksPSpace s x \<rparr>)" 821 822lemma ko_wp_at'[simp]: 823 "\<And>P p. (ko_wp_at' P p state') = (ko_wp_at' P p s \<and> p \<notin> base_bits)" 824 by (fastforce simp add: ko_wp_at_delete'[OF pd]) 825 826lemma obj_at'[simp]: 827 "\<And>P p. (obj_at' P p state') = (obj_at' P p s \<and> p \<notin> base_bits)" 828 by (fastforce simp add: obj_at'_real_def) 829 830lemma typ_at'[simp]: 831 "\<And>T p. (typ_at' P p state') = (typ_at' P p s \<and> p \<notin> base_bits)" 832 by (simp add: typ_at'_def) 833 834lemma valid_untyped[simp]: 835 "s \<turnstile>' UntypedCap d base bits idx" 836 using cte_wp_at_valid_objs_valid_cap' [OF cap valid_objs] 837 by clarsimp 838 839lemma cte_wp_at'[simp]: 840 "\<And>P p. (cte_wp_at' P p state') = (cte_wp_at' P p s \<and> p \<notin> base_bits)" 841 by (fastforce simp:cte_wp_at_delete'[where idx = idx,OF valid_untyped pd ]) 842 843(* the bits of caps they need for validity argument are within their capRanges *) 844lemma valid_cap_ctes_pre: 845 "\<And>c. s \<turnstile>' c \<Longrightarrow> case c of CNodeCap ref bits g gs 846 \<Rightarrow> \<forall>x. ref + (x && mask bits) * 2^cteSizeBits \<in> capRange c 847 | Zombie ref (ZombieCNode bits) n 848 \<Rightarrow> \<forall>x. ref + (x && mask bits) * 2^cteSizeBits \<in> capRange c 849 | ArchObjectCap (PageTableCap ref data) 850 \<Rightarrow> \<forall>x < 0x100. ref + x * 2^pteBits \<in> capRange c (* number of entries in page table *) 851 | ArchObjectCap (PageDirectoryCap ref data) 852 \<Rightarrow> \<forall>x < 0x1000. ref + x * 2^pdeBits \<in> capRange c (* number of entries in page directory *) 853 | _ \<Rightarrow> True" 854 apply (drule valid_capAligned) 855 apply (simp split: capability.split zombie_type.split arch_capability.split, safe) 856 using pre_helper[where a=cteSizeBits] 857 apply (clarsimp simp add: capRange_def capAligned_def objBits_simps field_simps) 858 apply (clarsimp simp add: capRange_def capAligned_def 859 simp del: atLeastAtMost_iff capBits.simps) 860 apply (rule pre_helper2, simp_all add: word_bits_def pteBits_def)[1] 861 apply (clarsimp simp add: capRange_def capAligned_def 862 simp del: atLeastAtMost_iff capBits.simps) 863 apply (rule pre_helper2, simp_all add: word_bits_def pdeBits_def)[1] 864 using pre_helper[where a=cteSizeBits] 865 apply (clarsimp simp add: capRange_def capAligned_def objBits_simps field_simps) 866 done 867 868lemma replycap_argument: 869 "\<And>p t m. cte_wp_at' (\<lambda>cte. cteCap cte = ReplyCap t m) p s \<Longrightarrow> t \<notin> {base .. base + (2 ^ bits - 1)}" 870 using safe 871 by (fastforce simp add: deletionIsSafe_def cte_wp_at_ctes_of field_simps) 872 873lemma valid_cap': 874 "\<And>p c. \<lbrakk> s \<turnstile>' c; cte_wp_at' (\<lambda>cte. cteCap cte = c) p s; 875 capRange c \<inter> {base .. base + (2 ^ bits - 1)} = {} \<rbrakk> \<Longrightarrow> state' \<turnstile>' c" 876 apply (subgoal_tac "capClass c = PhysicalClass \<longrightarrow> capUntypedPtr c \<in> capRange c") 877 apply (subgoal_tac "capClass c = PhysicalClass \<longrightarrow> 878 capUntypedPtr c \<notin> {base .. base + (2 ^ bits - 1)}") 879 apply (frule valid_cap_ctes_pre) 880 apply (case_tac c, simp_all add: valid_cap'_def replycap_argument 881 del: atLeastAtMost_iff 882 split: zombie_type.split_asm) 883 apply (simp add: field_simps del: atLeastAtMost_iff) 884 apply blast 885 apply (rename_tac arch_capability) 886 apply (case_tac arch_capability, 887 simp_all add: ARM_H.capUntypedPtr_def 888 page_table_at'_def page_directory_at'_def 889 shiftl_t2n 890 del: atLeastAtMost_iff)[1] 891 apply (rename_tac word vmrights vmpage_size option) 892 apply (subgoal_tac "\<forall>p < 2 ^ (pageBitsForSize vmpage_size - pageBits). 893 word + p * 2 ^ pageBits \<in> capRange c") 894 apply blast 895 apply (clarsimp simp: capRange_def capAligned_def) 896 apply (frule word_less_power_trans2, 897 rule pbfs_atleast_pageBits, simp add: word_bits_def) 898 apply (rule context_conjI) 899 apply (erule(1) is_aligned_no_wrap') 900 apply (simp only: add_diff_eq[symmetric]) 901 apply (rule word_plus_mono_right) 902 apply simp 903 apply (erule is_aligned_no_overflow') 904 apply (simp add: field_simps pteBits_def del: atLeastAtMost_iff) 905 apply blast 906 apply (simp add: field_simps pdeBits_def del: atLeastAtMost_iff) 907 apply blast 908 apply (simp add: valid_untyped'_def) 909 apply (simp add: field_simps del: atLeastAtMost_iff) 910 apply blast 911 apply blast 912 apply (clarsimp simp: capAligned_capUntypedPtr) 913 done 914 915lemma objRefs_notrange: 916 assumes asms: "ctes_of s p = Some c" "\<not> isUntypedCap (cteCap c)" 917 shows "capRange (cteCap c) \<inter> base_bits = {}" 918proof - 919 from cap obtain node 920 where ctes_of: "ctes_of s ptr = Some (CTE (UntypedCap d base bits idx) node)" 921 apply (clarsimp simp: cte_wp_at_ctes_of) 922 apply (case_tac cte, simp) 923 done 924 925 show ?thesis using asms cap 926 apply - 927 apply (rule ccontr) 928 apply (drule untyped_mdbD' [OF ctes_of _ _ _ _ umdb]) 929 apply (simp add: isUntypedCap_def) 930 apply (simp add: field_simps) 931 apply assumption 932 using nodesc 933 apply (simp add:descendants_range'_def2) 934 apply (drule(1) descendants_range_inD') 935 apply (simp add:asms) 936 apply (simp add:p_assoc_help) 937 done 938qed 939 940lemma ctes_of_valid [elim!]: 941 "ctes_of s p = Some cte \<Longrightarrow> s \<turnstile>' cteCap cte" 942 by (case_tac cte, simp add: ctes_of_valid_cap' [OF _ valid_objs]) 943 944lemma valid_cap2: 945 "\<lbrakk> cte_wp_at' (\<lambda>cte. cteCap cte = c) p s \<rbrakk> \<Longrightarrow> state' \<turnstile>' c" 946 apply (case_tac "isUntypedCap c") 947 apply (drule cte_wp_at_valid_objs_valid_cap' [OF _ valid_objs]) 948 apply (clarsimp simp: valid_cap'_def isCap_simps valid_untyped'_def) 949 apply (rule valid_cap'[rotated], assumption) 950 apply (clarsimp simp: cte_wp_at_ctes_of dest!: objRefs_notrange) 951 apply (clarsimp simp: cte_wp_at_ctes_of) 952 done 953 954lemma ex_nonz_cap_notRange: 955 "ex_nonz_cap_to' p s \<Longrightarrow> p \<notin> base_bits" 956 apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of) 957 apply (case_tac "isUntypedCap (cteCap cte)") 958 apply (clarsimp simp: isCap_simps) 959 apply (drule subsetD[OF zobj_refs_capRange, rotated]) 960 apply (rule valid_capAligned, erule ctes_of_valid) 961 apply (drule(1) objRefs_notrange) 962 apply (drule_tac a=p in equals0D) 963 apply simp 964 done 965 966lemma live_notRange: 967 "\<lbrakk> ko_wp_at' P p s; \<And>ko. P ko \<Longrightarrow> live' ko \<rbrakk> \<Longrightarrow> p \<notin> base_bits" 968 apply (drule if_live_then_nonz_capE' [OF iflive ko_wp_at'_weakenE]) 969 apply simp 970 apply (erule ex_nonz_cap_notRange) 971 done 972 973lemma refs_notRange: 974 "(x, tp) \<in> state_refs_of' s y \<Longrightarrow> y \<notin> base_bits" 975 apply (drule state_refs_of'_elemD) 976 apply (erule live_notRange) 977 apply (rule refs_of_live') 978 apply clarsimp 979 done 980 981lemma valid_obj': 982 "\<lbrakk> valid_obj' obj s; ko_wp_at' ((=) obj) p s \<rbrakk> \<Longrightarrow> valid_obj' obj state'" 983 apply (case_tac obj, simp_all add: valid_obj'_def) 984 apply (rename_tac endpoint) 985 apply (case_tac endpoint, simp_all add: valid_ep'_def)[1] 986 apply (clarsimp dest!: sym_refs_ko_wp_atD [OF _ sym_refs]) 987 apply (drule(1) bspec)+ 988 apply (clarsimp dest!: refs_notRange) 989 apply (clarsimp dest!: sym_refs_ko_wp_atD [OF _ sym_refs]) 990 apply (drule(1) bspec)+ 991 apply (clarsimp dest!: refs_notRange) 992 apply (rename_tac notification) 993 apply (case_tac notification, simp_all add: valid_ntfn'_def valid_bound_tcb'_def)[1] 994 apply (rename_tac ntfn bound) 995 apply (case_tac ntfn, simp_all split:option.splits)[1] 996 apply ((clarsimp dest!: sym_refs_ko_wp_atD [OF _ sym_refs] refs_notRange)+)[4] 997 apply (drule(1) bspec)+ 998 apply (clarsimp dest!: refs_notRange) 999 apply (clarsimp dest!: sym_refs_ko_wp_atD [OF _ sym_refs] refs_notRange) 1000 apply (frule sym_refs_ko_wp_atD [OF _ sym_refs]) 1001 apply (clarsimp simp: valid_tcb'_def ko_wp_at'_def 1002 objBits_simps) 1003 apply (rule conjI) 1004 apply (erule ballEI, clarsimp elim!: ranE) 1005 apply (rule_tac p="p + x" in valid_cap2) 1006 apply (erule(2) cte_wp_at_tcbI') 1007 apply fastforce 1008 apply simp 1009 apply (rename_tac tcb) 1010 apply (case_tac "tcbState tcb"; 1011 clarsimp simp: valid_tcb_state'_def valid_bound_ntfn'_def 1012 dest!: refs_notRange split: option.splits) 1013 apply (clarsimp simp: valid_cte'_def) 1014 apply (rule_tac p=p in valid_cap2) 1015 apply (clarsimp simp: ko_wp_at'_def objBits_simps' cte_level_bits_def[symmetric]) 1016 apply (erule(2) cte_wp_at_cteI') 1017 apply simp 1018 apply (rename_tac arch_kernel_object) 1019 apply (case_tac "arch_kernel_object", simp_all) 1020 apply (rename_tac asidpool) 1021 apply (case_tac asidpool, clarsimp simp: page_directory_at'_def) 1022 apply (rename_tac pte) 1023 apply (case_tac pte, simp_all add: valid_mapping'_def) 1024 apply(rename_tac pde) 1025 apply (case_tac pde, simp_all add: valid_mapping'_def) 1026 done 1027 1028lemma st_tcb: 1029 "\<And>P p. \<lbrakk> st_tcb_at' P p s; \<not> P Inactive; \<not> P IdleThreadState \<rbrakk> \<Longrightarrow> st_tcb_at' P p state'" 1030 by (fastforce simp: pred_tcb_at'_def obj_at'_real_def 1031 projectKOs 1032 dest: live_notRange) 1033 1034lemma irq_nodes_global: 1035 "\<forall>irq :: 10 word. irq_node' s + (ucast irq) * 16 \<in> global_refs' s" 1036 by (simp add: global_refs'_def mult.commute mult.left_commute) 1037 1038lemma global_refs: 1039 "global_refs' s \<inter> base_bits = {}" 1040 using cap 1041 apply (clarsimp simp: cte_wp_at_ctes_of) 1042 apply (drule valid_global_refsD' [OF _ refs]) 1043 apply (fastforce simp add: field_simps) 1044 done 1045 1046lemma global_refs2: 1047 "global_refs' s \<subseteq> (- base_bits)" 1048 using global_refs by blast 1049 1050lemma irq_nodes_range: 1051 "\<forall>irq :: 10 word. irq_node' s + (ucast irq) * 16 \<notin> base_bits" 1052 using irq_nodes_global global_refs 1053 by blast 1054 1055lemma cte_refs_notRange: 1056 assumes asms: "ctes_of s p = Some c" 1057 shows "cte_refs' (cteCap c) (irq_node' s) \<inter> base_bits = {}" 1058proof - 1059 from cap obtain node 1060 where ctes_of: "ctes_of s ptr = Some (CTE (UntypedCap d base bits idx) node)" 1061 apply (clarsimp simp: cte_wp_at_ctes_of) 1062 apply (case_tac cte, simp) 1063 done 1064 1065 show ?thesis using asms 1066 apply - 1067 apply (rule ccontr) 1068 apply (clarsimp elim!: nonemptyE) 1069 apply (frule ctes_of_valid) 1070 apply (frule valid_capAligned) 1071 apply (case_tac "\<exists>irq. cteCap c = IRQHandlerCap irq") 1072 apply (insert irq_nodes_range)[1] 1073 apply clarsimp 1074 apply (frule subsetD [OF cte_refs_capRange]) 1075 apply simp 1076 apply assumption 1077 apply (frule caps_containedD' [OF _ ctes_of _ _ contained]) 1078 apply (clarsimp dest!: isCapDs) 1079 apply (rule_tac x=x in notemptyI) 1080 apply (simp add: field_simps) 1081 apply (simp add: add_diff_eq[symmetric]) 1082 apply (drule objRefs_notrange) 1083 apply (clarsimp simp: isCap_simps) 1084 apply blast 1085 done 1086qed 1087 1088lemma non_null_present: 1089 "cte_wp_at' (\<lambda>c. cteCap c \<noteq> NullCap) p s \<Longrightarrow> p \<notin> base_bits" 1090 apply (drule (1) if_unsafe_then_capD' [OF _ ifunsafe]) 1091 apply (clarsimp simp: ex_cte_cap_to'_def cte_wp_at_ctes_of 1092 dest!: cte_refs_notRange simp del: atLeastAtMost_iff) 1093 apply blast 1094 done 1095 1096lemma cte_cap: 1097 "ex_cte_cap_to' p s \<Longrightarrow> ex_cte_cap_to' p state'" 1098 apply (clarsimp simp: ex_cte_cap_to'_def) 1099 apply (frule non_null_present [OF cte_wp_at_weakenE']) 1100 apply clarsimp 1101 apply fastforce 1102 done 1103 1104lemma idle_notRange: 1105 "\<forall>cref. \<not> cte_wp_at' (\<lambda>c. ksIdleThread s \<in> capRange (cteCap c)) cref s 1106 \<Longrightarrow> ksIdleThread s \<notin> base_bits" 1107 apply (insert cap) 1108 apply (clarsimp simp: cte_wp_at_ctes_of) 1109 apply (erule_tac x=ptr in allE, clarsimp simp: field_simps) 1110 done 1111 1112abbreviation 1113 "ctes' \<equiv> map_to_ctes (\<lambda>x. if base \<le> x \<and> x \<le> base + (2 ^ bits - 1) then None else ksPSpace s x)" 1114 1115lemmas tree_to_ctes = map_to_ctes_delete [OF valid_untyped pd] 1116 1117lemma map_to_ctesE[elim!]: 1118 "\<lbrakk> ctes' x = Some cte; \<lbrakk> ctes_of s x = Some cte; x \<notin> base_bits \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P" 1119 by (clarsimp simp: tree_to_ctes split: if_split_asm) 1120 1121lemma not_nullMDBNode: 1122 "\<lbrakk> ctes_of s x = Some cte; cteCap cte = NullCap; cteMDBNode cte = nullMDBNode \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P" 1123 using nullcaps 1124 apply (cases cte) 1125 apply (simp add: valid_nullcaps_def) 1126 done 1127 1128lemma mdb_src: "\<lbrakk> ctes_of s \<turnstile> x \<leadsto> y; y \<noteq> 0 \<rbrakk> \<Longrightarrow> x \<notin> base_bits" 1129 apply (rule non_null_present) 1130 apply (clarsimp simp: next_unfold' cte_wp_at_ctes_of) 1131 apply (erule(1) not_nullMDBNode) 1132 apply (simp add: nullMDBNode_def nullPointer_def) 1133 done 1134 1135lemma mdb_dest: "\<lbrakk> ctes_of s \<turnstile> x \<leadsto> y; y \<noteq> 0 \<rbrakk> \<Longrightarrow> y \<notin> base_bits" 1136 apply (case_tac "x = 0") 1137 apply (insert no_0, simp add: next_unfold')[1] 1138 apply (drule(1) vdlist_nextD0 [OF _ _ dlist]) 1139 apply (rule non_null_present) 1140 apply (clarsimp simp: next_unfold' cte_wp_at_ctes_of mdb_prev_def) 1141 apply (erule(1) not_nullMDBNode) 1142 apply (simp add: nullMDBNode_def nullPointer_def) 1143 done 1144 1145lemma trancl_next[elim]: 1146 "\<lbrakk> ctes_of s \<turnstile> x \<leadsto>\<^sup>+ y; x \<notin> base_bits \<rbrakk> \<Longrightarrow> ctes' \<turnstile> x \<leadsto>\<^sup>+ y" 1147 apply (erule rev_mp, erule converse_trancl_induct) 1148 apply clarsimp 1149 apply (rule r_into_trancl) 1150 apply (simp add: next_unfold' tree_to_ctes) 1151 apply clarsimp 1152 apply (rule_tac b=z in trancl_into_trancl2) 1153 apply (simp add: next_unfold' tree_to_ctes) 1154 apply (case_tac "z = 0") 1155 apply (insert no_0)[1] 1156 apply (erule tranclE2) 1157 apply (simp add: next_unfold') 1158 apply (simp add: next_unfold') 1159 apply (drule(1) mdb_dest) 1160 apply (simp add: next_unfold') 1161 done 1162 1163lemma mdb_parent_notrange: 1164 "ctes_of s \<turnstile> x \<rightarrow> y \<Longrightarrow> x \<notin> base_bits \<and> y \<notin> base_bits" 1165 apply (erule subtree.induct) 1166 apply (frule(1) mdb_src, drule(1) mdb_dest, simp) 1167 apply (drule(1) mdb_dest, simp) 1168 done 1169 1170lemma mdb_parent: 1171 "ctes_of s \<turnstile> x \<rightarrow> y \<Longrightarrow> ctes' \<turnstile> x \<rightarrow> y" 1172 apply (erule subtree.induct) 1173 apply (frule(1) mdb_src, frule(1) mdb_dest) 1174 apply (rule subtree.direct_parent) 1175 apply (simp add: next_unfold' tree_to_ctes) 1176 apply assumption 1177 apply (simp add: parentOf_def tree_to_ctes) 1178 apply (frule(1) mdb_src, frule(1) mdb_dest) 1179 apply (erule subtree.trans_parent) 1180 apply (simp add: next_unfold' tree_to_ctes) 1181 apply assumption 1182 apply (frule mdb_parent_notrange) 1183 apply (simp add: parentOf_def tree_to_ctes) 1184 done 1185 1186lemma trancl_next_rev: 1187 "ctes' \<turnstile> x \<leadsto>\<^sup>+ y \<Longrightarrow> ctes_of s \<turnstile> x \<leadsto>\<^sup>+ y" 1188 apply (erule converse_trancl_induct) 1189 apply (rule r_into_trancl) 1190 apply (clarsimp simp: next_unfold') 1191 apply (rule_tac b=z in trancl_into_trancl2) 1192 apply (clarsimp simp: next_unfold') 1193 apply assumption 1194 done 1195 1196lemma is_chunk[elim!]: 1197 "is_chunk (ctes_of s) cap x y \<Longrightarrow> is_chunk ctes' cap x y" 1198 apply (simp add: is_chunk_def) 1199 apply (erule allEI) 1200 apply (clarsimp dest!: trancl_next_rev) 1201 apply (drule rtranclD, erule disjE) 1202 apply (clarsimp simp: tree_to_ctes) 1203 apply (cut_tac p=y in non_null_present) 1204 apply (clarsimp simp: cte_wp_at_ctes_of) 1205 apply simp 1206 apply (clarsimp dest!: trancl_next_rev simp: trancl_into_rtrancl) 1207 apply (clarsimp simp: tree_to_ctes) 1208 apply (cut_tac p=p'' in non_null_present) 1209 apply (clarsimp simp add: cte_wp_at_ctes_of) 1210 apply simp 1211 done 1212 1213lemma mdb_parent_rev: 1214 "ctes' \<turnstile> x \<rightarrow> y \<Longrightarrow> ctes_of s \<turnstile> x \<rightarrow> y" 1215 apply (erule subtree.induct) 1216 apply (rule subtree.direct_parent) 1217 apply (clarsimp simp: next_unfold' tree_to_ctes split: if_split_asm) 1218 apply assumption 1219 apply (clarsimp simp: parentOf_def tree_to_ctes split: if_split_asm) 1220 apply (erule subtree.trans_parent) 1221 apply (clarsimp simp: next_unfold' tree_to_ctes split: if_split_asm) 1222 apply assumption 1223 apply (clarsimp simp: parentOf_def tree_to_ctes split: if_split_asm) 1224 done 1225 1226end 1227 1228lemma exists_disj: 1229 "((\<exists>a. P a \<and> Q a)\<or>(\<exists>a. P a \<and> Q' a)) 1230 = (\<exists>a. P a \<and> (Q a \<or> Q' a))" 1231 by auto 1232 1233lemma (in delete_locale) delete_invs': 1234 "invs' (ksMachineState_update 1235 (\<lambda>ms. underlying_memory_update 1236 (\<lambda>m x. if base \<le> x \<and> x \<le> base + (2 ^ bits - 1) then 0 else m x) ms) 1237 state')" (is "invs' (?state'')") 1238using vds 1239proof (simp add: invs'_def valid_state'_def valid_pspace'_def 1240 valid_mdb'_def valid_mdb_ctes_def, 1241 safe) 1242 interpret Arch . (*FIXME: arch_split*) 1243 let ?s = state' 1244 let ?ran = base_bits 1245 1246 show "pspace_aligned' ?s" using pa 1247 by (simp add: pspace_aligned'_def dom_def) 1248 1249 show "pspace_distinct' ?s" using pd 1250 by (clarsimp simp add: pspace_distinct'_def ps_clear_def 1251 dom_if_None Diff_Int_distrib) 1252 1253 show "valid_objs' ?s" using valid_objs 1254 apply (clarsimp simp: valid_objs'_def ran_def) 1255 apply (rule_tac p=a in valid_obj') 1256 apply fastforce 1257 apply (frule pspace_alignedD'[OF _ pa]) 1258 apply (frule pspace_distinctD'[OF _ pd]) 1259 apply (clarsimp simp: ko_wp_at'_def) 1260 done 1261 1262 from sym_refs show "sym_refs (state_refs_of' ?s)" 1263 apply - 1264 apply (clarsimp simp: state_refs_ko_wp_at_eq 1265 elim!: rsubst[where P=sym_refs]) 1266 apply (rule ext) 1267 apply safe 1268 apply (simp add: refs_notRange[simplified] state_refs_ko_wp_at_eq) 1269 done 1270 1271 from vq show "valid_queues ?s" 1272 apply (clarsimp simp: valid_queues_def bitmapQ_defs) 1273 apply (clarsimp simp: valid_queues_no_bitmap_def) 1274 apply (drule spec, drule spec, drule conjunct1, drule(1) bspec) 1275 apply (clarsimp simp: obj_at'_real_def) 1276 apply (frule if_live_then_nonz_capE'[OF iflive, OF ko_wp_at'_weakenE]) 1277 apply (clarsimp simp: projectKOs inQ_def) 1278 apply (clarsimp dest!: ex_nonz_cap_notRange) 1279 done 1280 1281 from vq' show "valid_queues' ?s" 1282 by (simp add: valid_queues'_def) 1283 1284 show "if_live_then_nonz_cap' ?s" using iflive 1285 apply (clarsimp simp: if_live_then_nonz_cap'_def) 1286 apply (drule spec, drule(1) mp) 1287 apply (clarsimp simp: ex_nonz_cap_to'_def) 1288 apply (rule exI, rule conjI, assumption) 1289 apply (drule non_null_present [OF cte_wp_at_weakenE']) 1290 apply clarsimp 1291 apply simp 1292 done 1293 1294 from ifunsafe show "if_unsafe_then_cap' ?s" 1295 by (clarsimp simp: if_unsafe_then_cap'_def 1296 intro!: cte_cap) 1297 1298 from idle_notRange refs 1299 have "ksIdleThread s \<notin> ?ran" 1300 apply (simp add: cte_wp_at_ctes_of valid_global_refs'_def valid_refs'_def) 1301 apply blast 1302 done 1303 with idle show "valid_idle' ?s" 1304 apply (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def projectKOs) 1305 apply (clarsimp simp add: ps_clear_def dom_if_None Diff_Int_distrib) 1306 done 1307 1308 from tcb_at_invs' [OF invs] ct_act 1309 show "cur_tcb' ?s" unfolding cur_tcb'_def 1310 apply (clarsimp simp: cur_tcb'_def ct_in_state'_def) 1311 apply (drule st_tcb) 1312 apply simp 1313 apply simp 1314 apply (simp add: pred_tcb_at'_def) 1315 done 1316 1317 let ?ctes' = ctes' 1318 1319 from no_0 show no_0': "no_0 ?ctes'" 1320 by (simp add: no_0_def tree_to_ctes) 1321 1322 from dlist show "valid_dlist ?ctes'" 1323 apply (simp only: valid_dlist_def3) 1324 apply (rule conjI) 1325 apply (drule conjunct1) 1326 apply (elim allEI) 1327 apply (clarsimp simp: mdb_prev_def next_unfold' 1328 tree_to_ctes) 1329 apply (rule ccontr, clarsimp) 1330 apply (cut_tac p="mdbNext (cteMDBNode cte)" in non_null_present) 1331 apply (clarsimp simp: cte_wp_at_ctes_of) 1332 apply (erule(1) not_nullMDBNode) 1333 apply (simp add: nullMDBNode_def nullPointer_def no_0) 1334 apply simp 1335 apply (drule conjunct2) 1336 apply (elim allEI) 1337 apply (clarsimp simp: mdb_prev_def next_unfold' 1338 tree_to_ctes) 1339 apply (rule ccontr, clarsimp) 1340 apply (cut_tac p="mdbPrev (cteMDBNode z)" in non_null_present) 1341 apply (clarsimp simp: cte_wp_at_ctes_of) 1342 apply (erule(1) not_nullMDBNode) 1343 apply (simp add: nullMDBNode_def nullPointer_def no_0) 1344 apply simp 1345 done 1346 1347 from chain_0 show "mdb_chain_0 ?ctes'" 1348 by (fastforce simp: mdb_chain_0_def Ball_def) 1349 1350 from umdb show "untyped_mdb' ?ctes'" 1351 apply (simp add: untyped_mdb'_def) 1352 apply (erule allEI)+ 1353 apply (clarsimp simp: descendants_of'_def) 1354 apply (rule mdb_parent) 1355 apply (clarsimp simp: tree_to_ctes split: if_split_asm) 1356 done 1357 1358 from badges show "valid_badges ?ctes'" 1359 by (simp add: valid_badges_def tree_to_ctes next_unfold') 1360 1361 from contained show "caps_contained' ?ctes'" 1362 by (simp add: caps_contained'_def tree_to_ctes) 1363 1364 from chunked show "mdb_chunked ?ctes'" 1365 apply (simp add: mdb_chunked_def) 1366 apply (elim allEI) 1367 apply clarsimp 1368 apply (intro conjI impI) 1369 apply (erule disjEI) 1370 apply fastforce 1371 apply fastforce 1372 apply (clarsimp dest!: trancl_next_rev) 1373 apply (clarsimp dest!: trancl_next_rev) 1374 done 1375 1376 from uinc show "untyped_inc' ?ctes'" 1377 apply (simp add: untyped_inc'_def) 1378 apply (elim allEI) 1379 apply clarsimp 1380 apply (safe del: impCE, simp_all add: descendants_of'_def 1381 mdb_parent) 1382 done 1383 1384 from nullcaps show "valid_nullcaps ?ctes'" 1385 by (clarsimp simp: valid_nullcaps_def) 1386 1387 from ut_rev 1388 show "ut_revocable' ?ctes'" 1389 by (clarsimp simp: ut_revocable'_def) 1390 1391 show "class_links ?ctes'" using clinks 1392 by (simp add: class_links_def tree_to_ctes mdb_next_unfold) 1393 1394 show "valid_global_refs' ?s" using refs 1395 by (simp add: valid_global_refs'_def tree_to_ctes valid_cap_sizes'_def 1396 global_refs'_def valid_refs'_def ball_ran_eq) 1397 1398 show "valid_arch_state' ?s" 1399 using arch global_refs2 1400 apply (simp add: valid_arch_state'_def 1401 global_refs'_def) 1402 apply (intro conjI) 1403 apply (simp add: valid_asid_table'_def) 1404 apply (simp add: page_directory_at'_def 1405 page_directory_refs'_def 1406 subset_iff) 1407 apply (simp add: valid_global_pts'_def 1408 subset_iff 1409 page_table_at'_def 1410 page_table_refs'_def 1411 page_directory_at'_def) 1412 by fastforce 1413 1414 show "valid_irq_node' (irq_node' s) ?s" 1415 using virq irq_nodes_range 1416 by (simp add: valid_irq_node'_def mult.commute mult.left_commute ucast_ucast_mask_8) 1417 1418 show "valid_irq_handlers' ?s" using virqh 1419 apply (simp add: valid_irq_handlers'_def irq_issued'_def 1420 cteCaps_of_def tree_to_ctes Ball_def) 1421 apply (erule allEI) 1422 apply (clarsimp simp: ran_def) 1423 done 1424 1425 from irq_ctrl 1426 show "irq_control ?ctes'" 1427 by (clarsimp simp: irq_control_def) 1428 1429 from dist_z 1430 show "distinct_zombies ?ctes'" 1431 apply (simp add: tree_to_ctes distinct_zombies_def 1432 distinct_zombie_caps_def 1433 split del: if_split) 1434 apply (erule allEI, erule allEI) 1435 apply clarsimp 1436 done 1437 1438 show "reply_masters_rvk_fb ?ctes'" 1439 using rep_r_fb 1440 by (simp add: tree_to_ctes reply_masters_rvk_fb_def 1441 ball_ran_eq) 1442 1443 from virqs 1444 show "valid_irq_states' s" . 1445 1446 from no_0_objs 1447 show "no_0_obj' state'" 1448 by (simp add: no_0_obj'_def) 1449 1450 from pde_maps 1451 show "valid_pde_mappings' state'" 1452 by (simp add: valid_pde_mappings'_def) 1453 1454 from irqs_masked 1455 show "irqs_masked' state'" 1456 by (simp add: irqs_masked'_def) 1457 1458 from sa_simp ct_act 1459 show "sch_act_wf (ksSchedulerAction s) state'" 1460 apply (simp add: sch_act_simple_def) 1461 apply (case_tac "ksSchedulerAction s", simp_all add: ct_in_state'_def) 1462 apply (fastforce dest!: st_tcb elim!: pred_tcb'_weakenE) 1463 done 1464 1465 from invs 1466 have "pspace_domain_valid s" by (simp add: invs'_def valid_state'_def) 1467 thus "pspace_domain_valid state'" 1468 by (simp add: pspace_domain_valid_def) 1469 1470 from invs 1471 have "valid_machine_state' s" by (simp add: invs'_def valid_state'_def) 1472 thus "valid_machine_state' ?state''" 1473 apply (clarsimp simp: valid_machine_state'_def) 1474 apply (drule_tac x=p in spec) 1475 apply (simp add: pointerInUserData_def pointerInDeviceData_def typ_at'_def) 1476 apply (simp add: ko_wp_at'_def exists_disj) 1477 apply (elim exE conjE) 1478 apply (cut_tac ptr'=p in mask_in_range) 1479 apply fastforce 1480 using valid_untyped[simplified valid_cap'_def capability.simps] 1481 apply (simp add: valid_untyped'_def capAligned_def) 1482 apply (elim conjE) 1483 apply (drule_tac x="p && ~~ mask pageBits" in spec) 1484 apply (cut_tac x=p in is_aligned_neg_mask[OF order_refl]) 1485 apply (clarsimp simp: mask_2pm1 ko_wp_at'_def obj_range'_def objBitsKO_def) 1486 apply (frule is_aligned_no_overflow'[of base bits]) 1487 apply (frule is_aligned_no_overflow'[of _ pageBits]) 1488 apply (frule (1) aligned_ranges_subset_or_disjoint 1489 [where n=bits and n'=pageBits]) 1490 apply (case_tac ko, simp_all add: objBits_simps) 1491 apply (auto simp add: x_power_minus_1) 1492 done 1493 1494 from sa_simp ctnotinQ 1495 show "ct_not_inQ ?state''" 1496 apply (clarsimp simp: ct_not_inQ_def pred_tcb_at'_def) 1497 apply (drule obj_at'_and 1498 [THEN iffD2, OF conjI, 1499 OF ct_act [unfolded ct_in_state'_def pred_tcb_at'_def]]) 1500 apply (clarsimp simp: obj_at'_real_def) 1501 apply (frule if_live_then_nonz_capE'[OF iflive, OF ko_wp_at'_weakenE]) 1502 apply (clarsimp simp: projectKOs) 1503 apply (case_tac "tcbState obj") 1504 apply (clarsimp simp: projectKOs)+ 1505 apply (clarsimp dest!: ex_nonz_cap_notRange) 1506 done 1507 1508 from ctcd show "ct_idle_or_in_cur_domain' ?state''" 1509 apply (simp add: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) 1510 apply (intro impI) 1511 apply (elim disjE impE) 1512 apply simp+ 1513 apply (intro impI) 1514 apply (rule disjI2) 1515 apply (drule obj_at'_and 1516 [THEN iffD2, OF conjI, 1517 OF ct_act [unfolded ct_in_state'_def st_tcb_at'_def]]) 1518 apply (clarsimp simp: obj_at'_real_def) 1519 apply (frule if_live_then_nonz_capE'[OF iflive, OF ko_wp_at'_weakenE]) 1520 apply (clarsimp simp: projectKOs) 1521 apply (case_tac "tcbState obj") 1522 apply (clarsimp simp: projectKOs)+ 1523 apply (clarsimp dest!: ex_nonz_cap_notRange elim!: ko_wp_at'_weakenE) 1524 done 1525 1526 from cdm show "ksCurDomain s \<le> maxDomain" . 1527 1528 from invs 1529 have urz: "untyped_ranges_zero' s" by (simp add: invs'_def valid_state'_def) 1530 show "untyped_ranges_zero_inv (cteCaps_of state') 1531 (gsUntypedZeroRanges s)" 1532 apply (simp add: untyped_zero_ranges_cte_def 1533 urz[unfolded untyped_zero_ranges_cte_def, rule_format, symmetric]) 1534 apply (clarsimp simp: fun_eq_iff intro!: arg_cong[where f=Ex]) 1535 apply safe 1536 apply (drule non_null_present[OF cte_wp_at_weakenE']) 1537 apply (clarsimp simp: untypedZeroRange_def) 1538 apply simp 1539 done 1540 1541qed (clarsimp) 1542 1543lemma (in delete_locale) delete_ko_wp_at': 1544 assumes objs: "ko_wp_at' P p s \<and> ex_nonz_cap_to' p s" 1545 shows "ko_wp_at' P p state'" 1546 using objs 1547 by (clarsimp simp: ko_wp_at'_def ps_clear_def dom_if_None Diff_Int_distrib 1548 dest!: ex_nonz_cap_notRange) 1549 1550lemma (in delete_locale) null_filter': 1551 assumes descs: "Q (null_filter' (ctes_of s))" 1552 shows "Q (null_filter' (ctes_of state'))" 1553 using descs ifunsafe 1554 apply (clarsimp elim!: rsubst[where P=Q]) 1555 apply (rule ext) 1556 apply (clarsimp simp:null_filter'_def tree_to_ctes) 1557 apply (rule ccontr) 1558 apply (clarsimp) 1559 apply (cut_tac p = x in non_null_present) 1560 apply (simp add:cte_wp_at_ctes_of) 1561 apply (rule ccontr) 1562 apply simp 1563 apply (erule(1) not_nullMDBNode) 1564 apply (case_tac y,simp) 1565 apply simp 1566 done 1567 1568lemma (in delete_locale) delete_ex_cte_cap_to': 1569 assumes exc: "ex_cte_cap_to' p s" 1570 shows "ex_cte_cap_to' p state'" 1571 using exc 1572 by (clarsimp elim!: cte_cap) 1573 1574 1575lemma deleteObjects_null_filter: 1576 "\<lbrace>cte_wp_at' (\<lambda>c. cteCap c = UntypedCap d ptr bits idx) p 1577 and invs' and ct_active' and sch_act_simple 1578 and (\<lambda>s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) 1579 and (\<lambda>s. P (null_filter' (ctes_of s))) 1580 and K (bits < word_bits \<and> is_aligned ptr bits)\<rbrace> 1581 deleteObjects ptr bits 1582 \<lbrace>\<lambda>rv s. P (null_filter' (ctes_of s))\<rbrace>" 1583 apply (simp add: deleteObjects_def3) 1584 apply (simp add: deleteObjects_def3 doMachineOp_def split_def) 1585 apply wp 1586 apply clarsimp 1587 apply (subgoal_tac "delete_locale s ptr bits p idx d") 1588 apply (drule_tac Q = P in delete_locale.null_filter') 1589 apply assumption 1590 apply (clarsimp simp:p_assoc_help) 1591 apply (simp add: eq_commute field_simps) 1592 apply (subgoal_tac "ksPSpace (s\<lparr>ksMachineState := snd ((), b)\<rparr>) = 1593 ksPSpace s", simp only:, simp) 1594 apply (unfold_locales, simp_all) 1595 done 1596 1597lemma deleteObjects_descendants: 1598 "\<lbrace>cte_wp_at' (\<lambda>c. cteCap c = UntypedCap d ptr bits idx) p 1599 and invs' and ct_active' and sch_act_simple 1600 and (\<lambda>s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) 1601 and (\<lambda>s. descendants_range_in' H p (ctes_of s)) 1602 and K (bits < word_bits \<and> is_aligned ptr bits)\<rbrace> 1603 deleteObjects ptr bits 1604 \<lbrace>\<lambda>rv s. descendants_range_in' H p (ctes_of s)\<rbrace>" 1605 apply (simp add:descendants_range_in'_def2) 1606 apply (wp deleteObjects_null_filter) 1607 apply fastforce 1608 done 1609 1610lemma dmo'_ksPSpace_update_comm: 1611 assumes "empty_fail f" 1612 shows "doMachineOp f >>= (\<lambda>s. modify (ksPSpace_update g)) = 1613 modify (ksPSpace_update g) >>= (\<lambda>s. doMachineOp f)" 1614proof - 1615 have ksMachineState_ksPSpace_update: 1616 "\<forall>s. ksMachineState (ksPSpace_update g s) = ksMachineState s" 1617 by simp 1618 have updates_independent: 1619 "\<And>f. ksPSpace_update g \<circ> ksMachineState_update f = 1620 ksMachineState_update f \<circ> ksPSpace_update g" 1621 by (rule ext) simp 1622 from assms 1623 show ?thesis 1624 apply (simp add: doMachineOp_def split_def bind_assoc) 1625 apply (simp add: gets_modify_comm2[OF ksMachineState_ksPSpace_update]) 1626 apply (rule arg_cong_bind1) 1627 apply (simp add: empty_fail_def select_f_walk[OF empty_fail_modify] 1628 modify_modify updates_independent) 1629 done 1630qed 1631 1632lemma doMachineOp_modify: 1633 "doMachineOp (modify g) = modify (ksMachineState_update g)" 1634 apply (simp add: doMachineOp_def split_def select_f_returns) 1635 apply (rule ext) 1636 apply (simp add: simpler_gets_def simpler_modify_def bind_def) 1637 done 1638context begin interpretation Arch . (*FIXME: arch_split*) 1639lemma deleteObjects_invs': 1640 "\<lbrace>cte_wp_at' (\<lambda>c. cteCap c = UntypedCap d ptr bits idx) p 1641 and invs' and ct_active' and sch_act_simple 1642 and (\<lambda>s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) 1643 and K (bits < word_bits \<and> is_aligned ptr bits)\<rbrace> 1644 deleteObjects ptr bits 1645 \<lbrace>\<lambda>rv. invs'\<rbrace>" 1646proof - 1647 show ?thesis 1648 apply (rule hoare_pre) 1649 apply (rule_tac G="is_aligned ptr bits \<and> 2 \<le> bits \<and> bits \<le> word_bits" in hoare_grab_asm) 1650 apply (clarsimp simp add: deleteObjects_def2) 1651 apply (simp add: freeMemory_def bind_assoc doMachineOp_bind ef_storeWord) 1652 apply (simp add: bind_assoc[where f="\<lambda>_. modify f" for f, symmetric]) 1653 apply (simp add: mapM_x_storeWord_step[simplified word_size_bits_def] 1654 doMachineOp_modify modify_modify) 1655 apply (simp add: bind_assoc intvl_range_conv'[where 'a=32, folded word_bits_def] mask_def field_simps) 1656 apply (wp) 1657 apply (simp cong: if_cong) 1658 apply (subgoal_tac "is_aligned ptr bits \<and> 2 \<le> bits \<and> bits < word_bits",simp) 1659 apply clarsimp 1660 apply (frule(2) delete_locale.intro, simp_all)[1] 1661 apply (rule subst[rotated, where P=invs'], erule delete_locale.delete_invs') 1662 apply (simp add: field_simps) 1663 apply clarsimp 1664 apply (drule invs_valid_objs') 1665 apply (drule (1) cte_wp_at_valid_objs_valid_cap') 1666 apply (clarsimp simp add: valid_cap'_def capAligned_def minUntypedSizeBits_def) 1667 done 1668qed 1669 1670lemma deleteObjects_st_tcb_at': 1671 "\<lbrace>cte_wp_at' (\<lambda>c. cteCap c = UntypedCap d ptr bits idx) p 1672 and invs' and ct_active' and sch_act_simple 1673 and (\<lambda>s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) 1674 and st_tcb_at' (P and (\<noteq>) Inactive and (\<noteq>) IdleThreadState) t 1675 and K (bits < word_bits \<and> is_aligned ptr bits)\<rbrace> 1676 deleteObjects ptr bits 1677 \<lbrace>\<lambda>rv. st_tcb_at' P t\<rbrace>" 1678 apply (simp add: deleteObjects_def3 doMachineOp_def split_def) 1679 apply wp 1680 apply clarsimp 1681 apply (subgoal_tac "delete_locale s ptr bits p idx d") 1682 apply (drule delete_locale.delete_ko_wp_at' 1683 [where p = t and 1684 P="case_option False (P \<circ> tcbState) \<circ> projectKO_opt", 1685 simplified eq_commute]) 1686 apply (simp add: pred_tcb_at'_def obj_at'_real_def) 1687 apply (rule conjI) 1688 apply (fastforce elim: ko_wp_at'_weakenE) 1689 apply (erule if_live_then_nonz_capD' [rotated]) 1690 apply (clarsimp simp: projectKOs) 1691 apply (clarsimp simp: invs'_def valid_state'_def) 1692 apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def 1693 field_simps ko_wp_at'_def ps_clear_def 1694 cong:if_cong 1695 split: option.splits) 1696 apply (simp add: delete_locale_def) 1697 done 1698 1699lemma ex_cte_cap_wp_to'_gsCNodes_update[simp]: 1700 "ex_cte_cap_wp_to' P p (gsCNodes_update f s') = ex_cte_cap_wp_to' P p s'" 1701 by (simp add: ex_cte_cap_wp_to'_def) 1702lemma ex_cte_cap_wp_to'_gsUserPages_update[simp]: 1703 "ex_cte_cap_wp_to' P p (gsUserPages_update f s') = ex_cte_cap_wp_to' P p s'" 1704 by (simp add: ex_cte_cap_wp_to'_def) 1705 1706lemma deleteObjects_cap_to': 1707 "\<lbrace>cte_wp_at' (\<lambda>c. cteCap c = UntypedCap d ptr bits idx) p 1708 and invs' and ct_active' and sch_act_simple 1709 and (\<lambda>s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) 1710 and ex_cte_cap_to' p' 1711 and K (bits < word_bits \<and> is_aligned ptr bits)\<rbrace> 1712 deleteObjects ptr bits 1713 \<lbrace>\<lambda>rv. ex_cte_cap_to' p'\<rbrace>" 1714 apply (simp add: deleteObjects_def3 doMachineOp_def split_def) 1715 apply wp 1716 apply clarsimp 1717 apply (subgoal_tac "delete_locale s ptr bits p idx d") 1718 apply (drule delete_locale.delete_ex_cte_cap_to', assumption) 1719 apply (simp cong:if_cong) 1720 apply (subgoal_tac 1721 "s\<lparr>ksMachineState := b, 1722 ksPSpace := \<lambda>x. if ptr \<le> x \<and> x \<le> ptr + 2 ^ bits - 1 then None 1723 else ksPSpace s x\<rparr> = 1724 ksMachineState_update (\<lambda>_. b) 1725 (s\<lparr>ksPSpace := \<lambda>x. if ptr \<le> x \<and> x \<le> ptr + 2 ^ bits - 1 then None 1726 else ksPSpace s x\<rparr>)",erule ssubst) 1727 apply (simp add: field_simps ex_cte_cap_wp_to'_def cong:if_cong) 1728 apply simp 1729 apply (simp add: delete_locale_def) 1730 done 1731 1732lemma valid_untyped_no_overlap: 1733 "\<lbrakk> valid_untyped' d ptr bits idx s; is_aligned ptr bits; valid_pspace' s \<rbrakk> 1734 \<Longrightarrow> pspace_no_overlap' ptr bits (s\<lparr>ksPSpace := ksPSpace s |` (- {ptr .. ptr + 2 ^ bits - 1})\<rparr>)" 1735 apply (clarsimp simp del: atLeastAtMost_iff 1736 simp: pspace_no_overlap'_def valid_cap'_def valid_untyped'_def is_aligned_neg_mask_eq) 1737 apply (drule_tac x=x in spec) 1738 apply (drule restrict_map_Some_iff[THEN iffD1]) 1739 apply clarsimp 1740 apply (frule pspace_alignedD') 1741 apply (simp add: valid_pspace'_def) 1742 apply (frule pspace_distinctD') 1743 apply (simp add: valid_pspace'_def) 1744 apply (unfold ko_wp_at'_def obj_range'_def) 1745 apply (drule (1) aligned_ranges_subset_or_disjoint) 1746 apply (clarsimp simp del: Int_atLeastAtMost atLeastAtMost_iff atLeastatMost_subset_iff) 1747 apply (elim disjE) 1748 apply (subgoal_tac "ptr \<in> {x..x + 2 ^ objBitsKO ko - 1}") 1749 apply (clarsimp simp:p_assoc_help) 1750 apply (clarsimp simp:p_assoc_help) 1751 apply fastforce+ 1752 done 1753 1754lemma pspace_no_overlap'_gsCNodes_update[simp]: 1755 "pspace_no_overlap' p b (gsCNodes_update f s') = pspace_no_overlap' p b s'" 1756 by (simp add: pspace_no_overlap'_def) 1757 1758lemma pspace_no_overlap'_gsUserPages_update[simp]: 1759 "pspace_no_overlap' p b (gsUserPages_update f s') = pspace_no_overlap' p b s'" 1760 by (simp add: pspace_no_overlap'_def) 1761 1762lemma pspace_no_overlap'_ksMachineState_update[simp]: 1763 "pspace_no_overlap' p n (ksMachineState_update f s) = 1764 pspace_no_overlap' p n s" 1765 by (simp add: pspace_no_overlap'_def) 1766 1767lemma deleteObject_no_overlap[wp]: 1768 "\<lbrace>valid_cap' (UntypedCap d ptr bits idx) and valid_pspace'\<rbrace> 1769 deleteObjects ptr bits 1770 \<lbrace>\<lambda>rv s. pspace_no_overlap' ptr bits s\<rbrace>" 1771 apply (simp add: deleteObjects_def3 doMachineOp_def split_def) 1772 apply wp 1773 apply (clarsimp simp: valid_cap'_def cong:if_cong) 1774 apply (drule (2) valid_untyped_no_overlap) 1775 apply (subgoal_tac 1776 "s\<lparr>ksMachineState := b, 1777 ksPSpace := \<lambda>x. if ptr \<le> x \<and> x \<le> ptr + 2 ^ bits - 1 then None 1778 else ksPSpace s x\<rparr> = 1779 ksMachineState_update (\<lambda>_. b) 1780 (s\<lparr>ksPSpace := ksPSpace s |` (- {ptr..ptr + 2 ^ bits - 1})\<rparr>)", simp) 1781 apply (case_tac s, simp) 1782 apply (rule ext) 1783 apply simp 1784 done 1785 1786lemma deleteObjects_cte_wp_at': 1787 "\<lbrace>\<lambda>s. cte_wp_at' P p s \<and> p \<notin> {ptr .. ptr + 2 ^ bits - 1} 1788 \<and> s \<turnstile>' (UntypedCap d ptr bits idx) \<and> valid_pspace' s\<rbrace> 1789 deleteObjects ptr bits 1790 \<lbrace>\<lambda>rv s. cte_wp_at' P p s\<rbrace>" 1791 apply (simp add: deleteObjects_def3 doMachineOp_def split_def) 1792 apply wp 1793 apply (clarsimp simp: valid_pspace'_def cong:if_cong) 1794 apply (subgoal_tac 1795 "s\<lparr>ksMachineState := b, 1796 ksPSpace := \<lambda>x. if ptr \<le> x \<and> x \<le> ptr + 2 ^ bits - 1 then None 1797 else ksPSpace s x\<rparr> = 1798 ksMachineState_update (\<lambda>_. b) 1799 (s\<lparr>ksPSpace := \<lambda>x. if ptr \<le> x \<and> x \<le> ptr + 2 ^ bits - 1 then None 1800 else ksPSpace s x\<rparr>)", erule ssubst) 1801 apply (simp add: cte_wp_at_delete' x_power_minus_1) 1802 apply (case_tac s, simp) 1803 done 1804 1805lemma deleteObjects_invs_derivatives: 1806 "\<lbrace>cte_wp_at' (\<lambda>c. cteCap c = UntypedCap d ptr bits idx) p 1807 and invs' and ct_active' and sch_act_simple 1808 and (\<lambda>s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) 1809 and K (bits < word_bits \<and> is_aligned ptr bits)\<rbrace> 1810 deleteObjects ptr bits 1811 \<lbrace>\<lambda>rv. valid_pspace'\<rbrace>" 1812 "\<lbrace>cte_wp_at' (\<lambda>c. cteCap c = UntypedCap d ptr bits idx) p 1813 and invs' and ct_active' and sch_act_simple 1814 and (\<lambda>s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) 1815 and K (bits < word_bits \<and> is_aligned ptr bits)\<rbrace> 1816 deleteObjects ptr bits 1817 \<lbrace>\<lambda>rv. valid_mdb'\<rbrace>" 1818 "\<lbrace>cte_wp_at' (\<lambda>c. cteCap c = UntypedCap d ptr bits idx) p 1819 and invs' and ct_active' and sch_act_simple 1820 and (\<lambda>s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) 1821 and K (bits < word_bits \<and> is_aligned ptr bits)\<rbrace> 1822 deleteObjects ptr bits 1823 \<lbrace>\<lambda>rv. pspace_aligned'\<rbrace>" 1824 "\<lbrace>cte_wp_at' (\<lambda>c. cteCap c = UntypedCap d ptr bits idx) p 1825 and invs' and ct_active' and sch_act_simple 1826 and (\<lambda>s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) 1827 and K (bits < word_bits \<and> is_aligned ptr bits)\<rbrace> 1828 deleteObjects ptr bits 1829 \<lbrace>\<lambda>rv. pspace_distinct'\<rbrace>" 1830 by (safe intro!: hoare_strengthen_post [OF deleteObjects_invs']) 1831 1832lemma deleteObjects_nosch: 1833 "\<lbrace>\<lambda>s. P (ksSchedulerAction s)\<rbrace> 1834 deleteObjects ptr sz 1835 \<lbrace>\<lambda>rv s. P (ksSchedulerAction s)\<rbrace>" 1836 by (simp add: deleteObjects_def3 | wp hoare_drop_imp)+ 1837 1838lemma deleteObjects_valid_arch_state': 1839 "\<lbrace>cte_wp_at' (\<lambda>c. cteCap c = UntypedCap d ptr bits idx) p 1840 and invs' and ct_active' and sch_act_simple 1841 and (\<lambda>s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) 1842 and K (bits < word_bits \<and> is_aligned ptr bits)\<rbrace> 1843 deleteObjects ptr bits 1844 \<lbrace>\<lambda>rv. valid_arch_state'\<rbrace>" 1845 by (safe intro!: hoare_strengthen_post [OF deleteObjects_invs']) 1846 1847 1848(* Prooving the reordering here *) 1849 1850lemma createObjects'_wp_subst: 1851 "\<lbrakk>\<lbrace>P\<rbrace>createObjects a b c d\<lbrace>\<lambda>r. Q\<rbrace>\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace>createObjects' a b c d\<lbrace>\<lambda>r. Q\<rbrace>" 1852 apply (clarsimp simp:createObjects_def valid_def return_def bind_def) 1853 apply (drule_tac x = s in spec) 1854 apply (clarsimp simp:split_def) 1855 apply auto 1856 done 1857 1858definition pspace_no_overlap_cell' where 1859 "pspace_no_overlap_cell' p \<equiv> \<lambda>kh. 1860 \<forall>x ko. kh x = Some ko \<longrightarrow> p \<notin> {x..x + (2 ^ objBitsKO ko - 1)}" 1861 1862lemma pspace_no_overlap_cellD': 1863 "\<lbrakk>ksPSpace s x = Some ko; pspace_no_overlap_cell' p (ksPSpace s)\<rbrakk> 1864 \<Longrightarrow> p \<notin> {x..x + (2 ^ objBitsKO ko - 1)}" 1865 by(auto simp:pspace_no_overlap_cell'_def) 1866 1867 1868lemma pspace_no_overlap'_lift: 1869 assumes typ_at:"\<And>slot P Q. \<lbrace>\<lambda>s. P (typ_at' Q slot s)\<rbrace> f \<lbrace>\<lambda>r s. P (typ_at' Q slot s) \<rbrace>" 1870 assumes ps :"\<lbrace>Q\<rbrace> f \<lbrace>\<lambda>r s. pspace_aligned' s \<and> pspace_distinct' s \<rbrace>" 1871 shows "\<lbrace>Q and pspace_no_overlap' ptr sz \<rbrace> f \<lbrace>\<lambda>r. pspace_no_overlap' ptr sz\<rbrace>" 1872proof - 1873 note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff 1874 Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex 1875 show ?thesis 1876 apply (clarsimp simp:valid_def pspace_no_overlap'_def) 1877 apply (drule_tac x = x in spec) 1878 apply (subgoal_tac "\<exists>ko'. ksPSpace s x = Some ko' \<and> koTypeOf ko = koTypeOf ko'") 1879 apply (clarsimp dest!:objBits_type) 1880 apply (rule ccontr) 1881 apply clarsimp 1882 apply (frule_tac slot1 = x and Q1 = "koTypeOf ko" and P1 = "\<lambda>a. \<not> a" in use_valid[OF _ typ_at]) 1883 apply (clarsimp simp:typ_at'_def ko_wp_at'_def)+ 1884 apply (frule(1) use_valid[OF _ ps]) 1885 apply (clarsimp simp:valid_pspace'_def) 1886 apply (frule(1) pspace_alignedD') 1887 apply (drule(1) pspace_distinctD') 1888 apply simp 1889 done 1890qed 1891 1892lemma setCTE_pspace_no_overlap': 1893 "\<lbrace>pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz\<rbrace> 1894 setCTE cte src 1895 \<lbrace>\<lambda>r. pspace_no_overlap' ptr sz\<rbrace>" 1896 apply (rule pspace_no_overlap'_lift; wp setCTE_typ_at') 1897 apply auto 1898 done 1899 1900lemma getCTE_commute: 1901 assumes cte_at_modify: 1902 "\<And>Q. \<lbrace>\<lambda>s. P s \<and> cte_wp_at' Q dest s \<rbrace> f \<lbrace>\<lambda>a s. cte_wp_at' Q dest s\<rbrace>" 1903 shows "monad_commute (P and cte_at' dest) (getCTE dest) f" 1904 proof - 1905 have getsame: "\<And>x y s. (x,y)\<in> fst (getCTE dest s) \<Longrightarrow> y = s" 1906 apply (drule use_valid) 1907 prefer 3 1908 apply (simp|wp)+ 1909 done 1910 show ?thesis 1911 apply (simp add:monad_commute_def bind_assoc getCTE_def split_def cte_at'_def) 1912 apply (clarsimp simp:bind_def split_def return_def) 1913 apply (rule conjI) 1914 apply (rule set_eqI) 1915 apply (rule iffI) 1916 apply clarsimp 1917 apply (rule bexI[rotated], assumption) 1918 apply (drule_tac Q1 ="(=) cte" in use_valid[OF _ cte_at_modify]) 1919 apply (simp add:cte_wp_at'_def) 1920 apply (simp add:cte_wp_at'_def) 1921 apply clarsimp 1922 apply (rule conjI) 1923 apply (frule_tac Q1 = "(=) cte" in use_valid[OF _ cte_at_modify]) 1924 apply (clarsimp simp:cte_wp_at'_def ko_wp_at'_def) 1925 apply (clarsimp simp:cte_wp_at'_def) 1926 apply (rule bexI[rotated], assumption) 1927 apply (metis fst_eqD getObject_cte_det snd_eqD) 1928 apply (cut_tac no_failD[OF no_fail_getCTE[unfolded getCTE_def]]) 1929 prefer 2 1930 apply (simp add:cte_wp_at'_def) 1931 apply fastforce 1932 apply simp 1933 apply (rule iffI) 1934 apply clarsimp+ 1935 apply (cut_tac s = b in no_failD[OF no_fail_getCTE[unfolded getCTE_def]]) 1936 prefer 2 1937 apply fastforce 1938 apply (drule_tac Q1 = "(=) cte" in use_valid[OF _ cte_at_modify]) 1939 apply (simp add:cte_wp_at'_def) 1940 apply (simp add:cte_wp_at_ctes_of) 1941 done 1942qed 1943 1944definition "cte_check \<equiv> \<lambda>b src a next. (case b of 1945 KOTCB tcb \<Rightarrow> (is_aligned a (objBits tcb) 1946 \<and> (case next of None \<Rightarrow> True | Some z \<Rightarrow> 2^(objBits tcb) \<le> z - a)) \<and> 1947 (src - a = tcbVTableSlot << cteSizeBits 1948 \<or> src - a = tcbCTableSlot << cteSizeBits 1949 \<or> src - a = tcbReplySlot << cteSizeBits 1950 \<or> src - a = tcbCallerSlot << cteSizeBits 1951 \<or> src - a = tcbIPCBufferSlot << cteSizeBits ) 1952 | KOCTE v1 \<Rightarrow> ( src = a \<and> (is_aligned a (objBits (makeObject::cte))) 1953 \<and> (case next of None \<Rightarrow> True | Some z \<Rightarrow> 2^(objBits (makeObject::cte)) \<le> z - a)) 1954 | _ \<Rightarrow> False)" 1955 1956definition locateCTE where 1957 "locateCTE src \<equiv> 1958 (do ps \<leftarrow> gets ksPSpace; 1959 (before, after) \<leftarrow> return (lookupAround2 src ps); 1960 (ptr,val) \<leftarrow> maybeToMonad before; 1961 assert (cte_check val src ptr after); 1962 return ptr 1963 od)" 1964 1965definition cte_update where 1966 "cte_update \<equiv> \<lambda>cte b src a. (case b of 1967 KOTCB tcb \<Rightarrow> if (src - a = tcbVTableSlot << cteSizeBits) then KOTCB (tcbVTable_update (\<lambda>_. cte) tcb) 1968 else if (src - a = tcbCTableSlot << cteSizeBits) then KOTCB (tcbCTable_update (\<lambda>_. cte) tcb) 1969 else if (src - a = tcbReplySlot << cteSizeBits) then KOTCB (tcbReply_update (\<lambda>_. cte) tcb) 1970 else if (src - a = tcbCallerSlot << cteSizeBits) then KOTCB (tcbCaller_update (\<lambda>_. cte) tcb) 1971 else if (src - a = tcbIPCBufferSlot << cteSizeBits) then KOTCB (tcbIPCBufferFrame_update (\<lambda>_. cte) tcb) 1972 else KOTCB tcb 1973 | KOCTE v1 \<Rightarrow> KOCTE cte 1974 | x \<Rightarrow> x)" 1975 1976lemma cte_check_range: 1977 "cte_check val src ptr (snd (lookupAround2 src (ksPSpace s))) \<Longrightarrow> 1978 src \<in> {ptr .. ptr + 2^objBitsKO val - 1}" 1979 apply (case_tac val) 1980 apply (simp_all add:cte_check_def) 1981 apply (clarsimp simp: 1982 tcbVTableSlot_def cteSizeBits_def 1983 tcbCTableSlot_def tcbReplySlot_def 1984 tcbCallerSlot_def tcbIPCBufferSlot_def) 1985 apply (intro conjI) 1986 apply (elim disjE) 1987 apply (clarsimp simp:field_simps objBits_simps' 1988 |erule is_aligned_no_wrap')+ 1989 apply (elim disjE) 1990 apply (clarsimp simp:field_simps objBits_simps' 1991 |erule is_aligned_no_wrap' | rule word_plus_mono_right)+ 1992 done 1993 1994lemma simpler_updateObject_def: 1995 "updateObject (cte::cte) b src a next = 1996 (\<lambda>s. (if (cte_check b src a next) then ({(cte_update cte b src a,s)}, False) 1997 else fail s))" 1998 apply (rule ext) 1999 apply (clarsimp simp:ObjectInstances_H.updateObject_cte objBits_simps) 2000 apply (case_tac b) 2001 apply (simp_all add:cte_check_def typeError_def fail_def 2002 tcbIPCBufferSlot_def 2003 tcbCallerSlot_def tcbReplySlot_def 2004 tcbCTableSlot_def tcbVTableSlot_def) 2005 by (intro conjI impI; 2006 clarsimp simp:alignCheck_def unless_def when_def not_less[symmetric] 2007 alignError_def is_aligned_mask magnitudeCheck_def 2008 cte_update_def return_def tcbIPCBufferSlot_def 2009 tcbCallerSlot_def tcbReplySlot_def 2010 tcbCTableSlot_def tcbVTableSlot_def objBits_simps 2011 cteSizeBits_def split:option.splits; 2012 fastforce simp:return_def fail_def bind_def)+ 2013 2014 2015lemma setCTE_def2: 2016 "(setCTE src cte) = 2017 (do ptr \<leftarrow> locateCTE src; 2018 modify (ksPSpace_update (\<lambda>ps. ps(ptr \<mapsto> (cte_update cte (the (ps ptr)) src ptr )))) od)" 2019 apply (clarsimp simp:setCTE_def setObject_def split_def locateCTE_def bind_assoc) 2020 apply (rule ext) 2021 apply (rule_tac Q = "\<lambda>r s'. s'= x \<and> r = ksPSpace x " in monad_eq_split) 2022 apply (rule_tac Q = "\<lambda>ptr s'. s' = x \<and> snd ptr = the ((ksPSpace x) (fst ptr) ) " in monad_eq_split) 2023 apply (clarsimp simp:assert_def return_def fail_def bind_def simpler_modify_def) 2024 apply (clarsimp simp:simpler_updateObject_def fail_def) 2025 apply (wp|clarsimp simp:)+ 2026 apply (simp add:lookupAround2_char1) 2027 apply wp 2028 apply simp 2029 done 2030 2031lemma pspace_distinctD2': 2032 "\<lbrakk>ksPSpace s a = Some b; z \<in> obj_range' a b; 2033 pspace_distinct' s \<rbrakk> 2034 \<Longrightarrow> ksPSpace s z = (if (z = a) then Some b else None)" 2035 apply (clarsimp simp: pspace_distinct'_def ps_clear_def) 2036 apply (rule ccontr) 2037 apply (clarsimp) 2038 apply (drule_tac x = a in bspec) 2039 apply fastforce 2040 apply (erule_tac x = z in in_empty_interE) 2041 apply (clarsimp simp:obj_range'_def) 2042 apply clarsimp 2043 done 2044 2045lemma pspace_no_overlapD3': 2046 "\<lbrakk>pspace_no_overlap' ptr sz s;ksPSpace s p = Some obj;is_aligned ptr sz\<rbrakk> 2047 \<Longrightarrow> obj_range' p obj \<inter> {ptr..ptr + 2 ^ sz - 1} = {}" 2048 apply (unfold pspace_no_overlap'_def) 2049 apply (drule spec)+ 2050 apply (erule(1) impE) 2051 apply (simp only:is_aligned_neg_mask_eq obj_range'_def p_assoc_help) 2052 done 2053 2054lemma singleton_locateCTE: 2055 "a \<in> fst (locateCTE src s) = ({a} = fst (locateCTE src s))" 2056 apply (clarsimp simp:locateCTE_def assert_opt_def assert_def 2057 gets_def get_def bind_def return_def split_def) 2058 apply (clarsimp simp:return_def fail_def 2059 split:if_splits option.splits)+ 2060 done 2061 2062lemma locateCTE_inv: 2063 "\<lbrace>P\<rbrace>locateCTE s\<lbrace>\<lambda>r. P\<rbrace>" 2064 apply (simp add:locateCTE_def split_def) 2065 apply wp 2066 apply clarsimp 2067 done 2068 2069lemma locateCTE_case: 2070 "\<lbrace>\<top>\<rbrace> locateCTE src 2071 \<lbrace>\<lambda>r s. \<exists>obj. ksPSpace s r = Some obj \<and> 2072 (case obj of KOTCB tcb \<Rightarrow> True | KOCTE v \<Rightarrow> True | _ \<Rightarrow> False)\<rbrace>" 2073 apply (clarsimp simp:locateCTE_def split_def | wp)+ 2074 apply (clarsimp simp: lookupAround2_char1) 2075 apply (case_tac b) 2076 apply (simp_all add:cte_check_def) 2077 done 2078 2079lemma cte_wp_at_top: 2080 "(cte_wp_at' \<top> src s) 2081 = (\<exists>a b. ( fst (lookupAround2 src (ksPSpace s)) = Some (a, b) \<and> 2082 cte_check b src a (snd (lookupAround2 src (ksPSpace s)))))" 2083 apply (simp add:cte_wp_at'_def getObject_def gets_def 2084 get_def bind_def return_def split_def 2085 assert_opt_def fail_def 2086 split:option.splits) 2087 apply (clarsimp simp:loadObject_cte) 2088 apply (case_tac b,simp_all) 2089 apply ((simp add: typeError_def fail_def cte_check_def 2090 split: Structures_H.kernel_object.splits)+)[5] 2091 apply (simp add:loadObject_cte cte_check_def 2092 tcbIPCBufferSlot_def tcbCallerSlot_def 2093 tcbReplySlot_def tcbCTableSlot_def 2094 tcbVTableSlot_def objBits_simps cteSizeBits_def) 2095 apply (simp add:alignCheck_def bind_def 2096 alignError_def fail_def return_def objBits_simps 2097 magnitudeCheck_def in_monad is_aligned_mask 2098 when_def split:option.splits) 2099 apply (intro conjI impI allI,simp_all add:not_le) 2100 apply (clarsimp simp:cte_check_def) 2101 apply (simp add:alignCheck_def bind_def 2102 alignError_def fail_def return_def objBits_simps 2103 magnitudeCheck_def in_monad is_aligned_mask 2104 when_def split:option.splits) 2105 apply (intro conjI impI allI,simp_all add:not_le) 2106 apply (simp add:typeError_def fail_def 2107 cte_check_def split:Structures_H.kernel_object.splits)+ 2108 done 2109 2110 2111lemma neq_out_intv: 2112 "\<lbrakk>a \<noteq> b; b \<notin> {a..a + c - 1} - {a} \<rbrakk> \<Longrightarrow> b \<notin> {a..a + c - 1}" 2113 by simp 2114 2115lemma rule_out_intv: 2116 "\<lbrakk> ksPSpace s a = Some obj; ksPSpace s b = Some obj'; pspace_distinct' s; a\<noteq>b \<rbrakk> 2117 \<Longrightarrow> b \<notin> {a..a + 2 ^ objBitsKO obj - 1}" 2118 apply (drule(1) pspace_distinctD') 2119 apply (subst (asm) ps_clear_def) 2120 apply (drule_tac x = b in orthD2) 2121 apply fastforce 2122 apply (drule neq_out_intv) 2123 apply simp 2124 apply simp 2125 done 2126 2127lemma locateCTE_monad: 2128 assumes ko_wp_at: "\<And>Q dest. 2129 \<lbrace>\<lambda>s. P1 s \<and> ko_wp_at' (\<lambda>obj. Q (objBitsKO obj)) dest s \<rbrace> f 2130 \<lbrace>\<lambda>a s. ko_wp_at' (\<lambda>obj. Q (objBitsKO obj)) dest s\<rbrace>" 2131 assumes cte_wp_at: "\<And> dest. 2132 \<lbrace>\<lambda>s. P2 s \<and> cte_wp_at' \<top> dest s \<rbrace> f 2133 \<lbrace>\<lambda>a s. cte_wp_at' \<top> dest s\<rbrace>" 2134 assumes psp_distinct: 2135 "\<lbrace>\<lambda>s. P3 s \<rbrace> f \<lbrace>\<lambda>a s. pspace_distinct' s\<rbrace>" 2136 assumes psp_aligned: 2137 "\<lbrace>\<lambda>s. P4 s \<rbrace> f \<lbrace>\<lambda>a s. pspace_aligned' s\<rbrace>" 2138 shows 2139 "\<lbrakk>{(ptr, s)} = fst (locateCTE src s); 2140 (r, s') \<in> fst (f s);pspace_aligned' s;pspace_distinct' s;(P1 and P2 and P3 and P4) s\<rbrakk> 2141 \<Longrightarrow> {(ptr,s')} = fst (locateCTE src s')" 2142proof - 2143 have src_in_range: 2144 "\<And>obj src a m s'. \<lbrakk>cte_check obj src a m;ksPSpace s' a = Some obj\<rbrakk> \<Longrightarrow> src \<in> {a..a + 2 ^ objBitsKO obj - 1}" 2145 proof - 2146 fix obj src a m 2147 show "\<And>s'. \<lbrakk>cte_check obj src a m; ksPSpace s' a = Some obj\<rbrakk> \<Longrightarrow> src \<in> {a..a + 2 ^ objBitsKO obj - 1}" 2148 by (case_tac obj) 2149 (auto simp add: cte_check_def objBits_simps' field_simps 2150 word_plus_mono_right is_aligned_no_wrap' 2151 tcbVTableSlot_def tcbCTableSlot_def tcbReplySlot_def 2152 tcbCallerSlot_def tcbIPCBufferSlot_def ) 2153 qed 2154 2155 note blah[simp del] = usableUntypedRange.simps atLeastAtMost_iff 2156 atLeastatMost_subset_iff atLeastLessThan_iff 2157 Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex 2158 2159 have step1: 2160 "\<lbrakk>(ptr, s) \<in> fst (locateCTE src s); 2161 (r, s') \<in> fst (f s); pspace_aligned' s; pspace_distinct' s; (P1 and P2 and P3 and P4) s\<rbrakk> 2162 \<Longrightarrow> (ptr,s') \<in> fst (locateCTE src s')" 2163 apply (frule use_valid[OF _ locateCTE_case]) 2164 apply simp 2165 apply (clarsimp simp: locateCTE_def gets_def split_def 2166 get_def bind_def return_def assert_opt_def fail_def assert_def 2167 split: option.splits if_split_asm) 2168 apply (frule_tac dest1 = src in use_valid[OF _ cte_wp_at]) 2169 apply simp 2170 apply (subst cte_wp_at_top) 2171 apply simp 2172 apply (clarsimp simp add:cte_wp_at_top) 2173 apply (clarsimp simp:lookupAround2_char1) 2174 apply (frule_tac dest1 = ptr and Q1 = "\<lambda>x. x = objBitsKO b" in use_valid[OF _ ko_wp_at]) 2175 apply (frule(1) pspace_alignedD') 2176 apply (frule(1) pspace_distinctD') 2177 apply (auto simp add:ko_wp_at'_def)[1] 2178 apply (clarsimp simp add:ko_wp_at'_def) 2179 apply (rule ccontr) 2180 apply (frule use_valid[OF _ psp_distinct]) 2181 apply simp 2182 apply (frule use_valid[OF _ psp_aligned]) 2183 apply simp 2184 apply (frule_tac x = a in pspace_distinctD') 2185 apply simp 2186 apply (frule_tac s = s' and a = ptr in rule_out_intv[rotated]) 2187 apply simp+ 2188 apply (frule_tac s = s' and b = ptr and a = a in rule_out_intv) 2189 apply simp+ 2190 apply (thin_tac "\<forall>x. P x \<longrightarrow> Q x" for P Q)+ 2191 apply (drule_tac p = ptr and p' = a in aligned_ranges_subset_or_disjoint) 2192 apply (erule(1) pspace_alignedD') 2193 apply (drule(1) src_in_range)+ 2194 apply (drule base_member_set[OF pspace_alignedD']) 2195 apply simp 2196 apply (simp add:objBitsKO_bounded2[unfolded word_bits_def,simplified]) 2197 apply (drule base_member_set[OF pspace_alignedD']) 2198 apply simp 2199 apply (simp add:objBitsKO_bounded2[unfolded word_bits_def,simplified]) 2200 apply (clarsimp simp:field_simps) 2201 apply blast 2202 done 2203 assume 2204 "{(ptr, s)} = fst (locateCTE src s)" 2205 "(r, s') \<in> fst (f s)" 2206 "pspace_aligned' s" 2207 "pspace_distinct' s" 2208 "(P1 and P2 and P3 and P4) s" 2209 thus ?thesis 2210 using assms step1 2211 by (clarsimp simp:singleton_locateCTE) 2212qed 2213 2214lemma empty_fail_locateCTE: 2215 "empty_fail (locateCTE src)" 2216 by (simp add:locateCTE_def bind_assoc split_def) 2217 2218lemma fail_empty_locateCTE: 2219 "snd (locateCTE src s) \<Longrightarrow> fst (locateCTE src s) = {}" 2220 by (auto simp: assert_def fail_def locateCTE_def bind_assoc return_def split_def gets_def 2221 get_def bind_def assert_opt_def image_def 2222 split:option.splits if_split_asm)+ 2223 2224lemma locateCTE_commute: 2225 assumes nf: "no_fail P0 f" "no_fail P1 (locateCTE src)" 2226 and psp_distinct: "\<lbrace>\<lambda>s. P2 s \<rbrace> f \<lbrace>\<lambda>a s. pspace_distinct' s\<rbrace>" 2227 and psp_aligned: "\<lbrace>\<lambda>s. P3 s \<rbrace> f \<lbrace>\<lambda>a s. pspace_aligned' s\<rbrace>" 2228 assumes ko_wp_at: "\<And>Q dest. 2229 \<lbrace>\<lambda>s. (P0 and P1 and P2 and P3) s \<and> ko_wp_at' (\<lambda>obj. Q (objBitsKO obj)) dest s \<rbrace> f 2230 \<lbrace>\<lambda>a s. ko_wp_at' (\<lambda>obj. Q (objBitsKO obj)) dest s\<rbrace>" 2231 and cte_wp_at: "\<And> dest. 2232 \<lbrace>\<lambda>s. (P0 and P1 and P2 and P3) s \<and> cte_wp_at' \<top> dest s \<rbrace> f 2233 \<lbrace>\<lambda>a s. cte_wp_at' \<top> dest s\<rbrace>" 2234 shows "monad_commute (P0 and P1 and P2 and P3 and P4 and P5 and pspace_aligned' and pspace_distinct') 2235 (locateCTE src) f" 2236proof - 2237 have same: 2238 "\<And>ptr val next s s'. (ptr, s') \<in> fst (locateCTE src s) 2239 \<Longrightarrow> s' = s" 2240 by (erule use_valid[OF _ locateCTE_inv],simp) 2241 show ?thesis 2242 apply (clarsimp simp:monad_commute_def) 2243 apply (clarsimp simp:bind_def return_def) 2244 apply (intro conjI iffI set_eqI) 2245 apply (clarsimp) 2246 apply (frule same) 2247 apply (clarsimp) 2248 apply (rule bexI[rotated], assumption) 2249 apply (frule singleton_locateCTE[THEN iffD1]) 2250 apply (frule locateCTE_monad [OF ko_wp_at cte_wp_at psp_distinct psp_aligned]) 2251 apply assumption+ 2252 apply simp 2253 apply (clarsimp) 2254 apply (rule bexI[rotated]) 2255 apply (fastforce) 2256 apply clarsimp 2257 apply clarsimp 2258 apply (frule empty_failD2[OF empty_fail_locateCTE no_failD[OF nf(2)]]) 2259 apply clarsimp 2260 apply (rule bexI[rotated],assumption) 2261 apply (clarsimp) 2262 apply (frule_tac s = bb in same) 2263 apply (frule_tac s = s in same) 2264 apply clarsimp 2265 apply (frule_tac s1 = s in singleton_locateCTE[THEN iffD1]) 2266 apply (frule locateCTE_monad [OF ko_wp_at cte_wp_at psp_distinct psp_aligned]) 2267 apply assumption+ 2268 apply simp 2269 apply (rule bexI[rotated],assumption) 2270 apply (drule sym) 2271 apply (clarsimp simp:singleton_locateCTE singleton_iff) 2272 apply fastforce 2273 apply (clarsimp simp:split_def image_def) 2274 apply (elim disjE) 2275 apply clarsimp 2276 apply (drule same) 2277 apply simp 2278 apply (frule no_failD[OF nf(2)]) 2279 apply simp 2280 apply (clarsimp simp:split_def image_def) 2281 apply (elim disjE) 2282 apply clarsimp 2283 apply (frule empty_failD2[OF empty_fail_locateCTE no_failD[OF nf(2)]]) 2284 apply clarsimp 2285 apply (frule same) 2286 apply simp 2287 apply (frule singleton_locateCTE[THEN iffD1]) 2288 apply (frule locateCTE_monad [OF ko_wp_at cte_wp_at psp_distinct psp_aligned]) 2289 apply assumption+ 2290 apply simp 2291 apply (clarsimp) 2292 apply (simp add: fail_empty_locateCTE) 2293 apply (simp add: no_failD[OF nf(1)]) 2294 done 2295qed 2296 2297lemmas getObjSize_simps = ARM_H.getObjectSize_def[split_simps ARM_H.object_type.split apiobject_type.split] 2298 2299lemma arch_toAPIType_simps: 2300 "ARM_H.toAPIType ty = Some a \<Longrightarrow> ty = APIObjectType a" 2301 by (case_tac ty,auto simp:ARM_H.toAPIType_def) 2302 2303lemma createObject_cte_wp_at': 2304 "\<lbrace>\<lambda>s. Types_H.getObjectSize ty us < word_bits \<and> 2305 is_aligned ptr (Types_H.getObjectSize ty us) \<and> 2306 pspace_no_overlap' ptr (Types_H.getObjectSize ty us) s \<and> 2307 cte_wp_at' (\<lambda>c. P c) slot s \<and> pspace_aligned' s \<and> 2308 pspace_distinct' s\<rbrace> 2309 RetypeDecls_H.createObject ty ptr us d 2310 \<lbrace>\<lambda>r s. cte_wp_at' (\<lambda>c. P c) slot s \<rbrace>" 2311 apply (simp add:createObject_def) 2312 apply (rule hoare_pre) 2313 apply (wpc 2314 | wp createObjects_orig_cte_wp_at'[where sz = "(Types_H.getObjectSize ty us)"] 2315 threadSet_cte_wp_at' 2316 | simp add: ARM_H.createObject_def placeNewDataObject_def 2317 unless_def placeNewObject_def2 objBits_simps range_cover_full 2318 curDomain_def pageBits_def ptBits_def 2319 pdBits_def getObjSize_simps archObjSize_def 2320 apiGetObjectSize_def tcbBlockSizeBits_def 2321 epSizeBits_def ntfnSizeBits_def 2322 cteSizeBits_def pteBits_def pdeBits_def 2323 | intro conjI impI | clarsimp dest!: arch_toAPIType_simps)+ 2324 done 2325 2326lemma createObject_getCTE_commute: 2327 "monad_commute 2328 (cte_wp_at' (\<lambda>_. True) dests and pspace_aligned' and pspace_distinct' and 2329 pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and 2330 K (ptr \<noteq> dests) and K (Types_H.getObjectSize ty us < word_bits) and 2331 K (is_aligned ptr (Types_H.getObjectSize ty us))) 2332 (RetypeDecls_H.createObject ty ptr us d) (getCTE dests)" 2333 apply (rule monad_commute_guard_imp[OF commute_commute]) 2334 apply (rule getCTE_commute) 2335 apply (rule hoare_pre) 2336 apply (wp createObject_cte_wp_at') 2337 apply (clarsimp simp:cte_wp_at_ctes_of) 2338 apply assumption 2339 apply (clarsimp simp:cte_wp_at_ctes_of) 2340 done 2341 2342lemma simpler_placeNewObject_def: 2343 "\<lbrakk>us < word_bits;is_aligned ptr (objBitsKO (injectKOS val) + us); 2344 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) s; pspace_aligned' s \<rbrakk> \<Longrightarrow> placeNewObject ptr val us s = 2345 modify (ksPSpace_update 2346 (\<lambda>_. foldr (\<lambda>addr map. map(addr \<mapsto> injectKOS val)) (new_cap_addrs (2 ^ us) ptr (injectKOS val)) 2347 (ksPSpace s))) s" 2348 apply (clarsimp simp:placeNewObject_def2) 2349 apply (clarsimp simp:createObjects'_def) 2350 apply (simp add:bind_def in_monad when_def is_aligned_mask[THEN iffD1]) 2351 apply (clarsimp simp:return_def bind_def gets_def assert_def fail_def get_def split_def 2352 split:option.splits) 2353 apply (clarsimp simp: new_cap_addrs_fold' word_1_le_power[where 'a=32, folded word_bits_def] lookupAround2_char1 not_less) 2354 apply (drule(1) pspace_no_overlapD'[rotated]) 2355 apply (drule_tac x = a in in_empty_interE) 2356 apply clarsimp 2357 apply (drule(1) pspace_alignedD') 2358 apply (simp add:is_aligned_no_overflow) 2359 apply (clarsimp simp: is_aligned_neg_mask_eq shiftL_nat p_assoc_help) 2360 apply simp 2361 done 2362 2363lemma fail_set: "fst (fail s) = {}" 2364 by (clarsimp simp: fail_def) 2365 2366lemma locateCTE_cte_no_fail: 2367 "no_fail (cte_at' src) (locateCTE src)" 2368 apply (clarsimp simp:no_fail_def cte_wp_at'_def getObject_def 2369 locateCTE_def return_def gets_def get_def bind_def split_def 2370 assert_opt_def assert_def in_fail fail_set split:option.splits) 2371 apply (clarsimp simp:cte_check_def ObjectInstances_H.loadObject_cte) 2372 apply (drule in_singleton) 2373 by (auto simp: objBits_simps cteSizeBits_def alignError_def 2374 alignCheck_def in_monad is_aligned_mask magnitudeCheck_def 2375 typeError_def 2376 cong: if_cong split: if_splits option.splits kernel_object.splits) 2377 2378lemma not_in_new_cap_addrs: 2379 "\<lbrakk>is_aligned ptr (objBitsKO obj + us); 2380 objBitsKO obj + us < word_bits; 2381 pspace_no_overlap' ptr (objBitsKO obj + us) s; 2382 ksPSpace s dest = Some ko;pspace_aligned' s\<rbrakk> 2383 \<Longrightarrow> dest \<notin> set (new_cap_addrs (2 ^ us) ptr obj)" 2384 supply 2385 is_aligned_neg_mask_eq[simp del] 2386 is_aligned_neg_mask_weaken[simp del] 2387 apply (rule ccontr) 2388 apply simp 2389 apply (drule(1) pspace_no_overlapD'[rotated]) 2390 apply (erule_tac x = dest in in_empty_interE) 2391 apply (clarsimp) 2392 apply (erule(1) is_aligned_no_overflow[OF pspace_alignedD']) 2393 apply (erule subsetD[rotated]) 2394 apply (simp add:p_assoc_help) 2395 apply (rule new_cap_addrs_subset[unfolded ptr_add_def,simplified]) 2396 apply (rule range_cover_rel[OF range_cover_full]) 2397 apply simp+ 2398 done 2399 2400lemma placeNewObject_pspace_aligned': 2401 "\<lbrace>K (is_aligned ptr (objBitsKO (injectKOS val) + us) \<and> 2402 objBitsKO (injectKOS val) + us < word_bits) and 2403 pspace_aligned' and pspace_distinct' and 2404 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us)\<rbrace> 2405 placeNewObject ptr val us 2406 \<lbrace>\<lambda>r s. pspace_aligned' s\<rbrace>" 2407 apply (clarsimp simp:valid_def) 2408 apply (simp add:simpler_placeNewObject_def simpler_modify_def) 2409 apply (subst data_map_insert_def[symmetric])+ 2410 apply (erule(2) Retype_R.retype_aligned_distinct' [unfolded data_map_insert_def[symmetric]]) 2411 apply (rule range_cover_rel[OF range_cover_full]) 2412 apply simp+ 2413 done 2414 2415lemma placeNewObject_pspace_distinct': 2416 "\<lbrace>\<lambda>s. objBitsKO (injectKOS val) + us < word_bits \<and> 2417 is_aligned ptr (objBitsKO (injectKOS val) + us) \<and> 2418 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) s \<and> 2419 pspace_aligned' s \<and> pspace_distinct' s\<rbrace> 2420 placeNewObject ptr val us 2421 \<lbrace>\<lambda>a. pspace_distinct'\<rbrace>" 2422 apply (clarsimp simp:valid_def) 2423 apply (simp add:simpler_placeNewObject_def simpler_modify_def) 2424 apply (subst data_map_insert_def[symmetric])+ 2425 apply (erule(2) Retype_R.retype_aligned_distinct' 2426 [unfolded data_map_insert_def[symmetric]]) 2427 apply (rule range_cover_rel[OF range_cover_full]) 2428 apply simp+ 2429 done 2430 2431lemma placeNewObject_ko_wp_at': 2432 "\<lbrace>\<lambda>s. (if slot \<in> set (new_cap_addrs (2 ^ us) ptr (injectKOS val)) 2433 then P (injectKOS val) 2434 else ko_wp_at' P slot s) \<and> 2435 objBitsKO (injectKOS val) + us < word_bits \<and> 2436 is_aligned ptr (objBitsKO (injectKOS val) + us) \<and> 2437 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) s \<and> 2438 pspace_aligned' s \<and> pspace_distinct' s\<rbrace> 2439 placeNewObject ptr val us 2440 \<lbrace>\<lambda>a. ko_wp_at' P slot\<rbrace>" 2441 apply (clarsimp simp:valid_def split del:if_split) 2442 apply (simp add:simpler_placeNewObject_def simpler_modify_def) 2443 apply (subst data_map_insert_def[symmetric])+ 2444 apply (subst retype_ko_wp_at') 2445 apply simp+ 2446 apply (rule range_cover_rel[OF range_cover_full]) 2447 apply simp+ 2448 done 2449 2450lemma cte_wp_at_cases_mask': 2451 "cte_wp_at' P p = (\<lambda>s. 2452 (obj_at' P p s 2453 \<or> p && mask tcbBlockSizeBits \<in> dom tcb_cte_cases 2454 \<and> obj_at' (P \<circ> fst (the (tcb_cte_cases (p && mask tcbBlockSizeBits)))) 2455 (p && ~~ mask tcbBlockSizeBits) s))" 2456 apply (rule ext) 2457 apply (simp add:cte_wp_at_obj_cases_mask) 2458 done 2459 2460lemma not_in_new_cap_addrs': 2461 "\<lbrakk>dest \<in> set (new_cap_addrs (2 ^ us) ptr obj); 2462 is_aligned ptr (objBitsKO obj + us); 2463 objBitsKO obj + us < word_bits; 2464 pspace_no_overlap' ptr (objBitsKO obj + us) s; 2465 pspace_aligned' s \<rbrakk> 2466 \<Longrightarrow> ksPSpace s dest = None" 2467 apply (rule ccontr) 2468 apply clarsimp 2469 apply (drule not_in_new_cap_addrs) 2470 apply simp+ 2471 done 2472 2473lemma placeNewObject_cte_wp_at': 2474 "\<lbrace>K (is_aligned ptr (objBitsKO (injectKOS val) + us) \<and> 2475 objBitsKO (injectKOS val) + us < word_bits) and 2476 K (ptr \<noteq> src) and cte_wp_at' P src and 2477 pspace_aligned' and pspace_distinct' and 2478 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us)\<rbrace> 2479 placeNewObject ptr val us 2480 \<lbrace>\<lambda>r s. cte_wp_at' P src s\<rbrace>" 2481 apply (clarsimp simp:placeNewObject_def2) 2482 apply (wp createObjects_orig_cte_wp_at') 2483 apply (auto simp:range_cover_full) 2484 done 2485 2486 2487lemma placeNewObject_cte_wp_at'': 2488 "\<lbrace>\<lambda>s. cte_wp_at' P slot s \<and> 2489 objBitsKO (injectKOS val) + us < word_bits \<and> 2490 is_aligned ptr (objBitsKO (injectKOS val) + us) \<and> 2491 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) s \<and> 2492 pspace_aligned' s \<and> pspace_distinct' s\<rbrace> 2493 placeNewObject ptr val us \<lbrace>\<lambda>a s. cte_wp_at' P slot s\<rbrace>" 2494 apply (simp add:cte_wp_at_cases_mask' obj_at'_real_def) 2495 apply (wp hoare_vcg_disj_lift placeNewObject_ko_wp_at') 2496 apply (clarsimp simp:conj_comms) 2497 apply (intro conjI impI allI impI) 2498 apply (drule(4) not_in_new_cap_addrs') 2499 apply (clarsimp simp:ko_wp_at'_def) 2500 apply (drule (4)not_in_new_cap_addrs')+ 2501 apply (clarsimp simp:ko_wp_at'_def) 2502 apply (elim disjE) 2503 apply simp 2504 apply clarsimp 2505 apply (drule (4)not_in_new_cap_addrs')+ 2506 apply (clarsimp simp:ko_wp_at'_def) 2507 done 2508 2509lemma no_fail_placeNewObject: 2510 "no_fail (\<lambda>s. us < word_bits \<and> 2511 is_aligned ptr (objBitsKO (injectKOS val) + us) \<and> 2512 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) s \<and> 2513 pspace_aligned' s) 2514 (placeNewObject ptr val us)" 2515 by (clarsimp simp:no_fail_def simpler_modify_def simpler_placeNewObject_def) 2516 2517lemma placeNewObject_locateCTE_commute: 2518 "monad_commute 2519 (K (is_aligned ptr (objBitsKO (injectKOS val) + us) \<and> 2520 (objBitsKO (injectKOS val) + us) < word_bits \<and> ptr \<noteq> src) and 2521 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and 2522 pspace_aligned' and pspace_distinct' and cte_at' src) 2523 (placeNewObject ptr val us) (locateCTE src)" 2524 apply (rule monad_commute_guard_imp) 2525 apply (rule commute_commute[OF locateCTE_commute]) 2526 apply (wp no_fail_placeNewObject locateCTE_cte_no_fail 2527 placeNewObject_pspace_aligned' 2528 placeNewObject_pspace_distinct' 2529 placeNewObject_ko_wp_at' | simp)+ 2530 apply (clarsimp simp:ko_wp_at'_def) 2531 apply (drule(3) not_in_new_cap_addrs) 2532 apply fastforce+ 2533 apply (wp placeNewObject_cte_wp_at'') 2534 apply clarsimp 2535 apply fastforce 2536 done 2537 2538lemma update_ksPSpaceI: 2539 "kh = kh' \<Longrightarrow> s\<lparr>ksPSpace := kh\<rparr> = s\<lparr>ksPSpace := kh'\<rparr>" 2540 by simp 2541 2542lemma placeNewObject_modify_commute: 2543 "monad_commute 2544 (K (is_aligned ptr (objBitsKO (injectKOS val) + us) \<and> 2545 objBitsKO (injectKOS val) + us < word_bits) and 2546 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and 2547 pspace_aligned' and ko_wp_at' (\<lambda>a. objBitsKO (f (Some a)) = objBitsKO a) ptr') 2548 (placeNewObject ptr val us) 2549 (modify (ksPSpace_update (\<lambda>ps. ps(ptr' \<mapsto> f (ps ptr')))))" 2550 apply (clarsimp simp:monad_commute_def simpler_modify_def 2551 bind_def split_def return_def) 2552 apply (subst simpler_placeNewObject_def) 2553 apply ((simp add:range_cover_def)+)[4] 2554 apply (clarsimp simp: simpler_modify_def) 2555 apply (frule(1) range_cover_full) 2556 apply (simp add: simpler_placeNewObject_def) 2557 apply (subgoal_tac "pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) 2558 (ksPSpace_update (\<lambda>ps. ps(ptr' \<mapsto> f (ps ptr'))) s)") 2559 prefer 2 2560 apply (clarsimp simp:ko_wp_at'_def) 2561 apply (subst pspace_no_overlap'_def) 2562 apply (intro allI impI) 2563 apply (case_tac "x = ptr'") 2564 apply (subgoal_tac "objBitsKO koa = objBitsKO ko") 2565 apply (drule(1) pspace_no_overlapD') 2566 apply (clarsimp simp:field_simps) 2567 apply (clarsimp) 2568 apply (drule_tac x = x and s = s in pspace_no_overlapD'[rotated]) 2569 apply (simp) 2570 apply (clarsimp simp:field_simps) 2571 apply (subgoal_tac "pspace_aligned' 2572 (ksPSpace_update (\<lambda>ps. ps(ptr' \<mapsto> f (ps ptr'))) s)") 2573 prefer 2 2574 apply (subst pspace_aligned'_def) 2575 apply (rule ballI) 2576 apply (erule domE) 2577 apply (clarsimp simp:ko_wp_at'_def split:if_split_asm) 2578 apply (drule(1) pspace_alignedD')+ 2579 apply simp 2580 apply (simp add:simpler_placeNewObject_def) 2581 apply (clarsimp simp:simpler_modify_def Fun.comp_def 2582 singleton_iff image_def) 2583 apply (intro conjI update_ksPSpaceI ext) 2584 apply (clarsimp simp:ko_wp_at'_def foldr_upd_app_if) 2585 apply (frule(1) pspace_no_overlapD') 2586 apply (drule subsetD[rotated]) 2587 apply (rule new_cap_addrs_subset) 2588 apply (erule range_cover_rel) 2589 apply simp 2590 apply simp 2591 apply (drule_tac x = ptr' in in_empty_interE) 2592 apply (clarsimp simp:is_aligned_no_overflow) 2593 apply (clarsimp simp:range_cover_def ptr_add_def 2594 is_aligned_neg_mask_eq obj_range'_def p_assoc_help) 2595 apply simp 2596 done 2597 2598lemma cte_update_objBits[simp]: 2599 "(objBitsKO (cte_update cte b src a)) = objBitsKO b" 2600 by (case_tac b, 2601 (simp add:objBits_simps cte_update_def)+) 2602 2603lemma locateCTE_ret_neq: 2604 "\<lbrace>ko_wp_at' (\<lambda>x. koTypeOf x \<noteq> TCBT \<and> koTypeOf x \<noteq> CTET) ptr\<rbrace> 2605 locateCTE src \<lbrace>\<lambda>r s. ptr \<noteq> r\<rbrace>" 2606 apply (clarsimp simp add:valid_def) 2607 apply (frule use_valid[OF _ locateCTE_case]) 2608 apply simp 2609 apply (frule(1) use_valid[OF _ locateCTE_inv]) 2610 apply (clarsimp simp:ko_wp_at'_def koTypeOf_def) 2611 apply (auto split:Structures_H.kernel_object.split_asm) 2612 done 2613 2614lemma locateCTE_ko_wp_at': 2615 "\<lbrace>cte_at' src and pspace_distinct' \<rbrace> 2616 locateCTE src 2617 \<lbrace>\<lambda>rv. ko_wp_at' \<top> rv \<rbrace>" 2618 apply (clarsimp simp:locateCTE_def split_def) 2619 apply wp 2620 apply (clarsimp simp:cte_wp_at'_def getObject_def 2621 gets_def split_def get_def bind_def return_def 2622 ko_wp_at'_def lookupAround2_char1 assert_opt_def) 2623 apply (clarsimp split:option.splits 2624 simp:fail_def return_def lookupAround2_char1) 2625 apply (case_tac ba) 2626 apply (simp_all add:cte_check_def) 2627 apply (clarsimp simp:lookupAround2_char1 2628 objBits_simps cte_update_def) 2629 apply (drule(1) pspace_distinctD')+ 2630 apply (simp add:objBits_simps) 2631 apply (clarsimp simp:objBits_simps cte_update_def) 2632 apply (drule(1) pspace_distinctD')+ 2633 apply (simp add:objBits_simps) 2634 done 2635 2636 2637lemma setCTE_placeNewObject_commute: 2638 "monad_commute 2639 (K (is_aligned ptr (objBitsKO (injectKOS val) + us) \<and> 2640 objBitsKO (injectKOS val) + us < word_bits) and 2641 K(ptr \<noteq> src) and cte_wp_at' (\<lambda>_. True) src and 2642 pspace_aligned' and pspace_distinct' and 2643 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us)) 2644 (setCTE src cte) (placeNewObject ptr val us)" 2645 apply (clarsimp simp: setCTE_def2 split_def) 2646 apply (rule commute_commute) 2647 apply (rule monad_commute_guard_imp) 2648 apply (rule monad_commute_split[OF placeNewObject_modify_commute]) 2649 apply (rule placeNewObject_locateCTE_commute) 2650 apply (wp locateCTE_inv locateCTE_ko_wp_at' | simp)+ 2651 done 2652 2653lemma getCTE_doMachineOp_commute: 2654 "monad_commute (cte_wp_at' (\<lambda>_. True) dest) (getCTE dest) (doMachineOp x)" 2655 apply (rule monad_commute_guard_imp) 2656 apply (rule getCTE_commute) 2657 apply wp 2658 apply fastforce+ 2659 done 2660 2661lemma doMachineOp_upd_heap_commute: 2662 "monad_commute \<top> (doMachineOp x) (modify (ksPSpace_update P))" 2663 apply (clarsimp simp:doMachineOp_def split_def simpler_modify_def 2664 gets_def get_def return_def bind_def select_f_def) 2665 apply (clarsimp simp:monad_commute_def bind_def return_def) 2666 apply fastforce 2667 done 2668 2669lemma magnitudeCheck_det: 2670 "\<lbrakk>ksPSpace s ptr = Some ko; is_aligned ptr (objBitsKO ko); 2671 ps_clear ptr (objBitsKO ko) s\<rbrakk> 2672 \<Longrightarrow> magnitudeCheck ptr (snd (lookupAround2 ptr (ksPSpace s))) 2673 (objBitsKO ko) s = 2674 ({((), s)},False)" 2675 apply (frule in_magnitude_check'[THEN iffD2]) 2676 apply (case_tac ko) 2677 apply (simp add: objBits_simps' pageBits_def)+ 2678 apply (rename_tac arch_kernel_object) 2679 apply (case_tac arch_kernel_object) 2680 apply (simp add:archObjSize_def pageBits_def pteBits_def pdeBits_def)+ 2681 apply (subgoal_tac 2682 "\<not> snd (magnitudeCheck ptr (snd (lookupAround2 ptr (ksPSpace s))) (objBitsKO ko) s)") 2683 apply (drule singleton_in_magnitude_check) 2684 apply (drule_tac x = s in spec) 2685 apply (case_tac 2686 "(magnitudeCheck ptr (snd (lookupAround2 ptr (ksPSpace s))) (objBitsKO ko) s)") 2687 apply simp 2688 apply (rule ccontr) 2689 apply (clarsimp simp:magnitudeCheck_assert assert_def fail_def return_def 2690 split:if_splits option.splits) 2691 done 2692 2693lemma getPDE_det: 2694 "ko_wp_at' ((=) (KOArch (KOPDE pde))) p s 2695 \<Longrightarrow> getObject p s = ({((pde::ARM_H.pde),s)},False)" 2696 apply (clarsimp simp:ko_wp_at'_def getObject_def split_def 2697 bind_def gets_def return_def get_def 2698 assert_opt_def split:if_splits) 2699 2700 apply (clarsimp simp: fail_def return_def lookupAround2_known1) 2701 apply (simp add: loadObject_default_def) 2702 apply (clarsimp simp:projectKO_def projectKO_opt_pde alignCheck_def 2703 is_aligned_mask objBits_simps unless_def) 2704 apply (clarsimp simp:bind_def return_def) 2705 apply (intro conjI) 2706 apply (intro set_eqI iffI) 2707 apply clarsimp 2708 apply (subst (asm) in_magnitude_check') 2709 apply (simp add:archObjSize_def is_aligned_mask pteBits_def pdeBits_def)+ 2710 apply (rule bexI[rotated]) 2711 apply (rule in_magnitude_check'[THEN iffD2]) 2712 apply (simp add:is_aligned_mask)+ 2713 apply (clarsimp simp:image_def) 2714 apply (clarsimp simp:magnitudeCheck_assert assert_def 2715 objBits_def archObjSize_def 2716 return_def fail_def lookupAround2_char2 split:option.splits if_split_asm) 2717 apply (rule ccontr) 2718 apply (simp add:ps_clear_def field_simps pteBits_def pdeBits_def) 2719 apply (erule_tac x = x2 in in_empty_interE) 2720 apply (clarsimp simp:less_imp_le) 2721 apply (rule conjI) 2722 apply (subst add.commute) 2723 apply (rule word_diff_ls') 2724 apply (clarsimp simp:field_simps not_le plus_one_helper) 2725 apply (simp add:field_simps is_aligned_no_wrap' is_aligned_mask) 2726 apply simp 2727 apply auto 2728 done 2729 2730lemma pde_at_obj_at': 2731 "ko_wp_at' ((=) (KOArch (KOPDE (pde::pde)))) ptr s = 2732 obj_at' ((=) pde) ptr s" 2733 by(clarsimp simp:obj_at'_real_def ko_wp_at'_def projectKO_PDE) 2734 2735lemma in_dom_eq: 2736 "m a = Some obj \<Longrightarrow> dom (\<lambda>b. if b = a then Some g else m b) = dom m" 2737 by (rule set_eqI,clarsimp simp:dom_def) 2738 2739lemma setCTE_pde_at': 2740 "\<lbrace>ko_wp_at' ((=) (KOArch (KOPDE pde))) ptr and 2741 cte_wp_at' (\<lambda>_. True) src and pspace_distinct'\<rbrace> 2742 setCTE src cte 2743 \<lbrace>\<lambda>x s. ko_wp_at' ((=) (KOArch (KOPDE pde))) ptr s\<rbrace>" 2744 apply (clarsimp simp:setCTE_def2) 2745 including no_pre apply wp 2746 apply (simp add:split_def) 2747 apply (clarsimp simp:valid_def) 2748 apply (subgoal_tac "b = s") 2749 prefer 2 2750 apply (erule use_valid[OF _ locateCTE_inv]) 2751 apply simp 2752 apply (subgoal_tac "ptr \<noteq> a") 2753 apply (frule use_valid[OF _ locateCTE_ko_wp_at']) 2754 apply simp 2755 apply (clarsimp simp:ko_wp_at'_def ps_clear_def) 2756 apply (simp add:in_dom_eq) 2757 apply (drule use_valid[OF _ locateCTE_case]) 2758 apply simp 2759 apply (clarsimp simp:ko_wp_at'_def objBits_simps archObjSize_def) 2760 done 2761 2762lemma getPDE_setCTE_commute: 2763 "monad_commute 2764 (pde_at' ptr and pspace_distinct' and cte_wp_at' (\<lambda>_. True) src) 2765 (setCTE src cte) 2766 (getObject ptr :: KernelStateData_H.kernel_state \<Rightarrow> 2767 (pde \<times> KernelStateData_H.kernel_state) set \<times> bool)" 2768 apply (rule commute_name_pre_state) 2769 apply (clarsimp simp:typ_at'_def ko_wp_at'_def) 2770 apply (case_tac ko,simp_all) 2771 apply (rename_tac arch_kernel_object) 2772 apply (case_tac arch_kernel_object,simp_all) 2773 apply clarsimp 2774 apply (rename_tac pde) 2775 apply (subgoal_tac "ko_wp_at' ((=) (KOArch (KOPDE pde))) ptr s") 2776 prefer 2 2777 apply (clarsimp simp:ko_wp_at'_def) 2778 apply (rule monad_commute_guard_imp) 2779 apply (rule commute_commute) 2780 apply (rule commute_rewrite[OF getPDE_det,where R = \<top>]) 2781 apply assumption 2782 apply (wp setCTE_pde_at') 2783 apply (simp add:monad_commute_def bind_def) 2784 apply (auto simp:ko_wp_at'_def) 2785 done 2786 2787lemma getPDE_doMachineOp_commute: 2788 "monad_commute (pde_at' ptr) (doMachineOp f) 2789 ((getObject ptr) :: KernelStateData_H.kernel_state \<Rightarrow> 2790 (pde \<times> KernelStateData_H.kernel_state) set \<times> bool)" 2791 apply (rule commute_name_pre_state) 2792 apply (clarsimp simp:typ_at'_def ko_wp_at'_def) 2793 apply (case_tac ko,simp_all) 2794 apply (rename_tac arch_kernel_object) 2795 apply (case_tac arch_kernel_object,simp_all) 2796 apply clarsimp 2797 apply (rename_tac pde) 2798 apply (subgoal_tac "ko_wp_at' ((=) (KOArch (KOPDE pde))) ptr s") 2799 prefer 2 2800 apply (clarsimp simp:ko_wp_at'_def) 2801 apply (rule monad_commute_guard_imp) 2802 apply (rule commute_commute) 2803 apply (rule commute_rewrite[OF getPDE_det,where R = \<top>]) 2804 apply assumption 2805 apply (wp setCTE_pde_at') 2806 apply (simp add:monad_commute_def bind_def) 2807 apply auto 2808 done 2809 2810lemma getPDE_placeNewObject_commute: 2811 "monad_commute 2812 (pde_at' src and pspace_distinct' and pspace_aligned' and 2813 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + sz) and 2814 K (is_aligned ptr (objBitsKO (injectKOS val) + sz) \<and> 2815 objBitsKO (injectKOS val) + sz < word_bits) ) 2816 (placeNewObject ptr val sz) 2817 ((getObject src) :: KernelStateData_H.kernel_state \<Rightarrow> 2818 (pde \<times> KernelStateData_H.kernel_state) set \<times> bool)" 2819 apply (rule commute_name_pre_state) 2820 apply (subgoal_tac "range_cover ptr (objBitsKO (injectKOS val) + sz) (objBitsKO (injectKOS val) + sz) (Suc 0)") 2821 prefer 2 2822 apply (rule range_cover_full) 2823 apply simp+ 2824 apply (clarsimp simp:typ_at'_def ko_wp_at'_def) 2825 apply (case_tac ko,simp_all) 2826 apply (rename_tac arch_kernel_object) 2827 apply (case_tac arch_kernel_object,simp_all) 2828 apply clarsimp 2829 apply (rename_tac pde) 2830 apply (subgoal_tac "ko_wp_at' ((=) (KOArch (KOPDE pde))) src s") 2831 prefer 2 2832 apply (clarsimp simp:ko_wp_at'_def) 2833 apply (rule monad_commute_guard_imp) 2834 apply (rule commute_commute) 2835 apply (rule commute_rewrite[OF getPDE_det,where R = \<top>]) 2836 apply assumption 2837 apply (simp add:placeNewObject_def2) 2838 apply (wp createObjects_orig_ko_wp_at2') 2839 apply (simp add:monad_commute_def bind_def) 2840 apply (auto simp:ko_wp_at'_def) 2841 done 2842 2843lemma storePDE_det: 2844 "ko_wp_at' ((=) (KOArch (KOPDE pde))) ptr s 2845 \<Longrightarrow> storePDE ptr (new_pde::ARM_H.pde) s = 2846 modify 2847 (ksPSpace_update (\<lambda>_. ksPSpace s(ptr \<mapsto> KOArch (KOPDE new_pde)))) s" 2848 apply (clarsimp simp:ko_wp_at'_def storePDE_def split_def 2849 bind_def gets_def return_def 2850 get_def setObject_def 2851 assert_opt_def split:if_splits) 2852 apply (clarsimp simp:lookupAround2_known1 return_def alignCheck_def 2853 updateObject_default_def split_def 2854 archObjSize_def unless_def projectKO_def 2855 projectKO_opt_pde bind_def when_def 2856 is_aligned_mask[symmetric] objBits_simps) 2857 apply (drule magnitudeCheck_det) 2858 apply (simp add:objBits_simps archObjSize_def)+ 2859 apply (simp add:simpler_modify_def) 2860 done 2861 2862lemma modify_obj_commute: 2863 "monad_commute (K (ptr\<noteq> ptr')) 2864 (modify (ksPSpace_update (\<lambda>ps. ps(ptr \<mapsto> ko)))) 2865 (modify (ksPSpace_update (\<lambda>ps. ps(ptr' \<mapsto> ko'))))" 2866 apply (clarsimp simp:monad_commute_def return_def bind_def simpler_modify_def) 2867 apply (case_tac s) 2868 apply auto 2869 done 2870 2871lemma modify_specify: 2872 "(\<lambda>s. modify (ksPSpace_update (\<lambda>_. P (ksPSpace s))) s) = 2873 modify (ksPSpace_update (\<lambda>ps. P ps))" 2874 by (auto simp: simpler_modify_def) 2875 2876lemma modify_specify2: 2877 "(modify (ksPSpace_update (\<lambda>_. P (ksPSpace s))) >>= g) s = 2878 (modify (ksPSpace_update (\<lambda>ps. P ps)) >>=g) s" 2879 apply (clarsimp simp:simpler_modify_def bind_def) 2880 apply (rule arg_cong[where f = "\<lambda>x. g () x"],simp) 2881 done 2882 2883lemma modify_pde_pde_at': 2884 "\<lbrace>pde_at' ptr\<rbrace> 2885 modify (ksPSpace_update (\<lambda>ps. ps(ptr \<mapsto> KOArch (KOPDE new_pde)))) 2886 \<lbrace>\<lambda>a. pde_at' ptr\<rbrace>" 2887 apply wp 2888 apply (clarsimp simp del: fun_upd_apply 2889 simp: typ_at'_def ko_wp_at'_def objBits_simps archObjSize_def) 2890 apply (clarsimp simp:ps_clear_def) 2891 apply (case_tac ko,simp_all) 2892 apply (rename_tac arch_kernel_object) 2893 apply (case_tac arch_kernel_object,simp_all) 2894 apply (clarsimp simp:archObjSize_def) 2895 done 2896 2897lemma modify_pde_pspace_distinct': 2898 "\<lbrace>pde_at' ptr and pspace_distinct'\<rbrace> 2899 modify (ksPSpace_update (\<lambda>ps. ps(ptr \<mapsto> KOArch (KOPDE new_pde)))) 2900 \<lbrace>\<lambda>a. pspace_distinct'\<rbrace>" 2901 apply (clarsimp simp: simpler_modify_def ko_wp_at'_def valid_def typ_at'_def) 2902 apply (case_tac ko; simp) 2903 apply (rename_tac arch_kernel_object) 2904 apply (case_tac arch_kernel_object,simp_all) 2905 apply (subst pspace_distinct'_def) 2906 apply (intro ballI) 2907 apply (erule domE) 2908 apply (clarsimp split:if_splits) 2909 apply (drule(1) pspace_distinctD') 2910 apply (simp add:objBits_simps archObjSize_def) 2911 apply (simp add:ps_clear_def) 2912 apply (drule_tac x = x in pspace_distinctD') 2913 apply simp 2914 unfolding ps_clear_def 2915 apply (erule disjoint_subset2[rotated]) 2916 apply clarsimp 2917 done 2918 2919lemma modify_pde_pspace_aligned': 2920 "\<lbrace>pde_at' ptr and pspace_aligned'\<rbrace> 2921 modify (ksPSpace_update (\<lambda>ps. ps(ptr \<mapsto> KOArch (KOPDE new_pde)))) 2922 \<lbrace>\<lambda>a. pspace_aligned'\<rbrace>" 2923 apply (clarsimp simp: simpler_modify_def ko_wp_at'_def valid_def typ_at'_def) 2924 apply (case_tac ko,simp_all) 2925 apply (rename_tac arch_kernel_object) 2926 apply (case_tac arch_kernel_object,simp_all) 2927 apply (subst pspace_aligned'_def) 2928 apply (intro ballI) 2929 apply (erule domE) 2930 apply (clarsimp split:if_splits) 2931 apply (drule(1) pspace_alignedD') 2932 apply (simp add:objBits_simps archObjSize_def) 2933 apply (simp add:ps_clear_def) 2934 apply (drule_tac x = x in pspace_alignedD') 2935 apply simp 2936 apply simp 2937 done 2938 2939lemma modify_pde_psp_no_overlap': 2940 "\<lbrace>pde_at' ptr and pspace_no_overlap' ptr' sz\<rbrace> 2941 modify (ksPSpace_update (\<lambda>ps. ps(ptr \<mapsto> KOArch (KOPDE new_pde)))) 2942 \<lbrace>\<lambda>a. pspace_no_overlap' ptr' sz\<rbrace>" 2943 proof - 2944 note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff 2945 Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex 2946 show ?thesis 2947 apply (clarsimp simp:simpler_modify_def ko_wp_at'_def 2948 valid_def typ_at'_def) 2949 apply (case_tac ko,simp_all) 2950 apply (rename_tac arch_kernel_object) 2951 apply (case_tac arch_kernel_object,simp_all) 2952 apply (subst pspace_no_overlap'_def) 2953 apply (intro allI impI) 2954 apply (clarsimp split:if_splits) 2955 apply (drule(1) pspace_no_overlapD') 2956 apply (simp add:objBits_simps archObjSize_def field_simps) 2957 apply (drule(1) pspace_no_overlapD')+ 2958 apply (simp add:field_simps) 2959 done 2960 qed 2961 2962lemma koTypeOf_pde: 2963 "koTypeOf ko = ArchT PDET \<Longrightarrow> \<exists>pde. ko = KOArch (KOPDE pde)" 2964 apply (case_tac ko,simp_all) 2965 apply (rename_tac arch_kernel_object) 2966 apply (case_tac arch_kernel_object,simp_all) 2967 done 2968 2969lemma modify_mapM_x: 2970 "(modify (ksPSpace_update (foldr (\<lambda>addr map. map(addr \<mapsto> obj)) list))) = 2971 (mapM_x (\<lambda>x. modify (ksPSpace_update (\<lambda>m. m(x\<mapsto> obj)))) (rev list))" 2972 apply (induct list) 2973 apply (clarsimp simp:mapM_x_Nil) 2974 apply (rule ext) 2975 apply (simp add:simpler_modify_def return_def) 2976 apply (clarsimp simp:mapM_x_append mapM_x_singleton simpler_modify_def) 2977 apply (drule sym) 2978 apply (rule ext) 2979 apply (simp add:Fun.comp_def bind_def) 2980 done 2981 2982lemma doMachineOp_storePDE_commute: 2983 "monad_commute (pde_at' src) (doMachineOp f) 2984 (storePDE src (new_pde::ARM_H.pde))" 2985 proof - 2986 have eq_fail: "\<And>sa ks. snd (doMachineOp f (sa\<lparr>ksPSpace := ks\<rparr>)) = snd (doMachineOp f sa)" 2987 apply (clarsimp simp:doMachineOp_def bind_def return_def gets_def 2988 get_def simpler_modify_def select_def) 2989 apply (intro iffI) 2990 apply (elim disjE) 2991 apply (clarsimp simp:image_def select_f_def)+ 2992 done 2993 show ?thesis 2994 apply (rule commute_name_pre_state) 2995 apply (clarsimp simp:typ_at'_def ko_wp_at'_def) 2996 apply (case_tac ko,simp_all) 2997 apply (rename_tac arch_kernel_object) 2998 apply (case_tac arch_kernel_object,simp_all) 2999 apply clarsimp 3000 apply (rename_tac pde) 3001 apply (subgoal_tac "ko_wp_at' ((=) (KOArch (KOPDE pde))) src s") 3002 prefer 2 3003 apply (clarsimp simp:ko_wp_at'_def) 3004 apply (rule monad_commute_guard_imp) 3005 apply (rule commute_commute) 3006 apply (rule commute_rewrite[OF storePDE_det,where R = "\<top>"]) 3007 apply assumption 3008 apply wp 3009 apply (clarsimp simp:monad_commute_def simpler_modify_def return_def bind_def) 3010 apply (intro conjI iffI set_eqI) 3011 apply (clarsimp simp:doMachineOp_def gets_def bind_def get_def select_f_def return_def) 3012 apply (erule bexI[rotated]) 3013 apply (clarsimp simp:simpler_modify_def) 3014 apply (clarsimp simp:doMachineOp_def gets_def bind_def get_def select_f_def return_def) 3015 apply (erule bexI[rotated]) 3016 apply (clarsimp simp:simpler_modify_def) 3017 apply (simp add:eq_fail image_def) 3018 apply (elim disjE) 3019 apply clarsimp 3020 apply (clarsimp simp:doMachineOp_def gets_def bind_def get_def select_f_def return_def) 3021 apply (clarsimp simp:eq_fail) 3022 apply auto 3023 done 3024 qed 3025 3026lemma storePDE_placeNewObject_commute: 3027 "monad_commute 3028 (pde_at' src and pspace_distinct' and pspace_aligned' and 3029 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + sz) and 3030 K (is_aligned ptr (objBitsKO (injectKOS val) + sz) \<and> 3031 objBitsKO (injectKOS val) + sz < word_bits) ) 3032 (placeNewObject ptr val sz) (storePDE src (new_pde::ARM_H.pde))" 3033 apply (rule commute_name_pre_state) 3034 apply (clarsimp simp:typ_at'_def ko_wp_at'_def) 3035 apply (case_tac ko,simp_all) 3036 apply (rename_tac arch_kernel_object) 3037 apply (case_tac arch_kernel_object,simp_all) 3038 apply clarsimp 3039 apply (rename_tac pde) 3040 apply (subgoal_tac "ko_wp_at' ((=) (KOArch (KOPDE pde))) src s") 3041 prefer 2 3042 apply (clarsimp simp:ko_wp_at'_def) 3043 apply (subgoal_tac "range_cover ptr (objBitsKO (injectKOS val) + sz) (objBitsKO (injectKOS val) + sz) (Suc 0)") 3044 prefer 2 3045 apply (rule range_cover_full) 3046 apply simp+ 3047 apply (rule monad_commute_guard_imp) 3048 apply (rule commute_commute) 3049 apply (rule commute_rewrite[OF storePDE_det]) 3050 apply assumption 3051 apply (simp add:placeNewObject_def2) 3052 apply (wp createObjects_orig_ko_wp_at2') 3053 apply (rule commute_commute) 3054 apply (subst modify_specify2[where g = "return",simplified]) 3055 apply (rule_tac commute_rewrite[where Q = "\<lambda>s. 3056 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + sz) s \<and> pde_at' src s 3057 \<and> pspace_distinct' s \<and> pspace_aligned' s"]) 3058 apply (rule simpler_placeNewObject_def) 3059 apply simp+ 3060 apply (wp modify_pde_psp_no_overlap' modify_pde_pspace_distinct' 3061 modify_pde_pspace_aligned' modify_pde_pde_at') 3062 apply (simp add: modify_specify modify_mapM_x) 3063 apply (rule commute_commute[OF mapM_x_commute[where f = id]]) 3064 apply (rule modify_obj_commute) 3065 apply wp 3066 apply simp 3067 apply clarsimp 3068 apply (intro conjI,simp_all) 3069 apply (clarsimp simp:typ_at'_def ko_wp_at'_def objBits_simps archObjSize_def) 3070 apply (rule new_cap_addrs_distinct) 3071 apply (erule range_cover_rel) 3072 apply simp+ 3073 apply clarsimp 3074 apply (simp add:not_in_new_cap_addrs) 3075 done 3076 3077lemma modify_obj_commute': 3078 "monad_commute (K (ptr\<noteq> ptr') and ko_wp_at' \<top> ptr') 3079 (modify (ksPSpace_update (\<lambda>ps. ps(ptr \<mapsto> ko)))) 3080 (modify (ksPSpace_update (\<lambda>ps. ps(ptr' \<mapsto> f (the (ps ptr'))))))" 3081 apply (clarsimp simp:monad_commute_def return_def 3082 bind_def simpler_modify_def ko_wp_at'_def) 3083 apply (case_tac s) 3084 apply clarsimp 3085 apply (rule ext) 3086 apply clarsimp 3087 done 3088 3089lemma cte_wp_at_modify_pde: 3090 notes blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff 3091 Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex 3092 atLeastAtMost_iff 3093 shows 3094 "\<lbrakk>ksPSpace s ptr' = Some (KOArch (KOPDE pde)); pspace_aligned' s;cte_wp_at' \<top> ptr s\<rbrakk> 3095 \<Longrightarrow> cte_wp_at' \<top> ptr (s\<lparr>ksPSpace := ksPSpace s(ptr' \<mapsto> (KOArch (KOPDE pde')))\<rparr>)" 3096 apply (simp add:cte_wp_at_obj_cases_mask obj_at'_real_def) 3097 apply (frule(1) pspace_alignedD') 3098 apply (elim disjE) 3099 apply (rule disjI1) 3100 apply (clarsimp simp add:ko_wp_at'_def) 3101 apply (intro conjI impI) 3102 apply (simp add:objBits_simps archObjSize_def) 3103 apply (clarsimp simp:projectKO_opt_cte) 3104 apply (simp add:ps_clear_def)+ 3105 apply (clarsimp simp:objBits_simps archObjSize_def) 3106 apply (simp add:ps_clear_def) 3107 apply (rule ccontr) 3108 apply simp 3109 apply (erule in_emptyE, blast) 3110 apply simp 3111 apply (rule disjI2) 3112 apply (clarsimp simp:ko_wp_at'_def) 3113 apply (intro conjI impI) 3114 apply (simp add:objBits_simps archObjSize_def)+ 3115 apply (clarsimp simp:projectKO_opt_cte projectKO_opt_tcb) 3116 apply (simp add:ps_clear_def)+ 3117 apply (clarsimp simp:objBits_simps archObjSize_def) 3118 apply (simp add:ps_clear_def) 3119 apply (rule ccontr) 3120 apply simp 3121 apply (erule in_emptyE) 3122 apply blast 3123 done 3124 3125lemma storePDE_setCTE_commute: 3126 notes blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff 3127 Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex 3128 atLeastAtMost_iff 3129 shows "monad_commute 3130 (pde_at' ptr and pspace_distinct' and pspace_aligned' and 3131 cte_wp_at' (\<lambda>_. True) src) 3132 (setCTE src cte) (storePDE ptr (new_pde::ARM_H.pde))" 3133 apply (rule commute_name_pre_state) 3134 apply (clarsimp simp:typ_at'_def ko_wp_at'_def) 3135 apply (case_tac ko,simp_all) 3136 apply (rename_tac arch_kernel_object) 3137 apply (case_tac arch_kernel_object,simp_all) 3138 apply clarsimp 3139 apply (rename_tac pde) 3140 apply (subgoal_tac "ko_wp_at' ((=) (KOArch (KOPDE pde))) ptr s") 3141 prefer 2 3142 apply (clarsimp simp:ko_wp_at'_def) 3143 apply (rule monad_commute_guard_imp) 3144 apply (rule commute_commute) 3145 apply (rule commute_rewrite[OF storePDE_det]) 3146 apply assumption 3147 apply (wp setCTE_pde_at') 3148 apply (simp add:setCTE_def2) 3149 apply (rule monad_commute_split) 3150 apply (subst modify_specify) 3151 apply (rule modify_obj_commute') 3152 apply (rule commute_commute[OF locateCTE_commute]) 3153 apply (wp locateCTE_cte_no_fail non_fail_modify 3154 modify_pde_pspace_distinct' 3155 modify_pde_pspace_aligned'| subst modify_specify)+ 3156 apply (clarsimp simp:simpler_modify_def valid_def typ_at'_def) 3157 apply (clarsimp simp:ko_wp_at'_def dest!: koTypeOf_pde) 3158 apply (intro conjI impI) 3159 apply (clarsimp simp:objBits_simps archObjSize_def)+ 3160 apply (simp add:ps_clear_def in_dom_eq) 3161 apply (simp add:ps_clear_def in_dom_eq) 3162 apply (clarsimp simp:simpler_modify_def valid_def) 3163 apply (clarsimp simp:typ_at'_def ko_wp_at'_def) 3164 apply (case_tac ko,simp_all add:koTypeOf_def )[1] 3165 apply (rename_tac arch_kernel_object) 3166 apply (case_tac arch_kernel_object,simp_all add:archTypeOf_def)[1] 3167 apply (erule(2) cte_wp_at_modify_pde) 3168 apply wp 3169 apply (thin_tac "cte_wp_at' P src s" for P s)+ 3170 apply (clarsimp simp: typ_at'_def cte_wp_at_obj_cases_mask obj_at'_real_def) 3171 apply (wp locateCTE_ret_neq locateCTE_ko_wp_at') 3172 apply (clarsimp simp:ko_wp_at'_def objBits_simps archObjSize_def typ_at'_def) 3173 apply fastforce 3174 done 3175 3176lemma setCTE_gets_globalPD_commute: 3177 "monad_commute 3178 (cte_wp_at' (\<lambda>_. True) src and pspace_distinct' and pspace_aligned') 3179 (setCTE src cte) (gets (armKSGlobalPD \<circ> ksArchState))" 3180 apply (simp add:setCTE_def2) 3181 apply (rule monad_commute_guard_imp) 3182 apply (rule commute_commute[OF monad_commute_split[where Q = "\<lambda>r. \<top>"]]) 3183 apply (clarsimp simp:monad_commute_def gets_def simpler_modify_def bind_def get_def return_def) 3184 apply (rule commute_commute[OF locateCTE_commute]) 3185 apply (wp locateCTE_cte_no_fail)+ 3186 apply clarsimp 3187 apply (wp|clarsimp)+ 3188 apply fastforce 3189 done 3190 3191lemma placeNewObject_gets_globalPD_commute: 3192 "monad_commute 3193 (pspace_distinct' and pspace_aligned' and 3194 K (us < word_bits \<and> is_aligned ptr (objBitsKO (injectKOS val) + us)) and 3195 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) ) 3196 (placeNewObject ptr val us) (gets (armKSGlobalPD \<circ> ksArchState))" 3197 apply (rule commute_name_pre_state) 3198 apply (rule monad_commute_guard_imp) 3199 apply (rule_tac commute_rewrite[where Q = "\<lambda>s. 3200 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) s 3201 \<and> pspace_distinct' s \<and> pspace_aligned' s" and R = "\<top>"]) 3202 apply (rule simpler_placeNewObject_def) 3203 apply simp+ 3204 apply wp 3205 apply (simp add:monad_commute_def gets_def get_def 3206 return_def bind_def simpler_modify_def) 3207 apply clarsimp 3208 done 3209 3210(* FIXME: move *) 3211lemmas of_nat_inj32 = of_nat_inj[where 'a=32, folded word_bits_def] 3212 3213lemma copyGlobalMappings_setCTE_commute: 3214 "monad_commute 3215 (valid_arch_state' and pspace_distinct' and pspace_aligned' and 3216 cte_wp_at' (\<lambda>_. True) src and page_directory_at' ptr) 3217 (copyGlobalMappings ptr) (setCTE src cte)" 3218 apply (clarsimp simp:copyGlobalMappings_def) 3219 apply (rule monad_commute_guard_imp) 3220 apply (rule commute_commute[OF monad_commute_split]) 3221 apply (rule mapM_x_commute[where f = id]) 3222 apply (rule monad_commute_split[OF _ getPDE_setCTE_commute]) 3223 apply (rule storePDE_setCTE_commute) 3224 apply wp+ 3225 apply clarsimp 3226 apply (rule setCTE_gets_globalPD_commute) 3227 apply wp 3228 apply (clarsimp simp:valid_arch_state'_def page_directory_at'_def 3229 objBits_simps archObjSize_def pdBits_def pageBits_def) 3230 apply (drule le_m1_iff_lt[where x = "(0x1000::word32)",simplified,THEN iffD1]) 3231 apply (clarsimp simp: pteBits_def pdeBits_def) 3232 done 3233 3234lemma setCTE_doMachineOp_commute: 3235 assumes nf: "no_fail Q (doMachineOp x)" 3236 shows "monad_commute (cte_at' dest and pspace_aligned' and pspace_distinct' and Q) 3237 (setCTE dest cte) 3238 (doMachineOp x)" 3239 apply (simp add:setCTE_def2 split_def) 3240 apply (rule monad_commute_guard_imp) 3241 apply (rule commute_commute[OF monad_commute_split]) 3242 apply (rule doMachineOp_upd_heap_commute) 3243 apply (rule commute_commute[OF locateCTE_commute]) 3244 apply (wp nf locateCTE_cte_no_fail)+ 3245 apply clarsimp 3246 apply (wp|clarsimp|fastforce)+ 3247 done 3248 3249lemma setCTE_unless_doMachineOp_commute: 3250 assumes nf: "no_fail Q (doMachineOp x)" 3251 shows "monad_commute (cte_at' dest and pspace_aligned' and pspace_distinct' and Q) 3252 (setCTE dest cte) 3253 (unless d (doMachineOp x))" 3254 apply (simp add: unless_def when_def) 3255 apply safe 3256 apply (wp nf setCTE_doMachineOp_commute) 3257 apply (rule commute_commute) 3258 apply (rule monad_commute_guard_imp) 3259 apply (rule return_commute) 3260 apply simp 3261 done 3262 3263 3264lemma placeNewObject_valid_arch_state: 3265 "\<lbrace>valid_arch_state' and 3266 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and 3267 pspace_aligned' and pspace_distinct' and 3268 K (is_aligned ptr (objBitsKO (injectKOS val) + us)) and 3269 K ( (objBitsKO (injectKOS val)+ us)< word_bits)\<rbrace> 3270 placeNewObject ptr val us 3271 \<lbrace>\<lambda>rv s. valid_arch_state' s\<rbrace>" 3272 apply (simp add:placeNewObject_def2 split_def) 3273 apply (rule createObjects'_wp_subst) 3274 apply (wp createObjects_valid_arch) 3275 apply clarsimp 3276 apply (intro conjI,simp) 3277 apply (erule(1) range_cover_full) 3278 done 3279 3280lemma placeNewObject_pd_at': 3281 "\<lbrace>K (is_aligned ptr pdBits) and pspace_no_overlap' ptr pdBits and 3282 pspace_aligned' and pspace_distinct'\<rbrace> 3283 placeNewObject ptr (makeObject::ARM_H.pde) 3284 (pdBits - objBits (makeObject::ARM_H.pde)) 3285 \<lbrace>\<lambda>rv s. page_directory_at' ptr s\<rbrace>" 3286 apply (simp add:page_directory_at'_def typ_at'_def) 3287 apply (rule hoare_pre) 3288 apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift placeNewObject_ko_wp_at') 3289 apply (clarsimp simp:objBits_simps archObjSize_def pteBits_def pdeBits_def pdBits_def) 3290 apply (intro conjI) 3291 apply (clarsimp simp:pdBits_def pageBits_def word_bits_def)+ 3292 apply (clarsimp simp:pdBits_def pageBits_def new_cap_addrs_def objBits_simps archObjSize_def image_def) 3293 apply (drule_tac x = "unat x" in bspec) 3294 apply clarsimp 3295 apply (rule unat_less_helper) 3296 apply simp 3297 apply (simp add: pdeBits_def) 3298 done 3299 3300lemma setCTE_modify_gsCNode_commute: 3301 "monad_commute P (setCTE src (cte::cte)) 3302 (modify (%ks. ks\<lparr>gsCNodes := f (gsCNodes ks)\<rparr>))" 3303 by (auto simp: monad_commute_def setCTE_def setObject_def split_def bind_def 3304 return_def simpler_modify_def simpler_gets_def assert_opt_def 3305 fail_def simpler_updateObject_def 3306 split: option.splits if_split_asm) 3307 3308lemma setCTE_modify_gsUserPages_commute: 3309 "monad_commute P (setCTE src (cte::cte)) 3310 (modify (%ks. ks\<lparr>gsUserPages := f (gsUserPages ks)\<rparr>))" 3311 by (auto simp: monad_commute_def setCTE_def setObject_def split_def bind_def 3312 return_def simpler_modify_def simpler_gets_def assert_opt_def 3313 fail_def simpler_updateObject_def 3314 split: option.splits if_split_asm) 3315 3316lemma getTCB_det: 3317 "ko_wp_at' ((=) (KOTCB tcb)) p s 3318 \<Longrightarrow> getObject p s = ({(tcb,s)},False)" 3319 apply (clarsimp simp:ko_wp_at'_def getObject_def split_def 3320 bind_def gets_def return_def get_def 3321 assert_opt_def split:if_splits) 3322 apply (clarsimp simp: fail_def return_def lookupAround2_known1) 3323 apply (simp add:loadObject_default_def) 3324 apply (clarsimp simp:projectKO_def projectKO_opt_tcb alignCheck_def 3325 is_aligned_mask objBits_simps' unless_def) 3326 apply (clarsimp simp:bind_def return_def) 3327 apply (intro conjI) 3328 apply (intro set_eqI iffI) 3329 apply clarsimp 3330 apply (subst (asm) in_magnitude_check') 3331 apply (simp add:archObjSize_def is_aligned_mask)+ 3332 apply (rule bexI[rotated]) 3333 apply (rule in_magnitude_check'[THEN iffD2]) 3334 apply (simp add:is_aligned_mask)+ 3335 apply (clarsimp simp:image_def) 3336 apply (clarsimp simp:magnitudeCheck_assert assert_def 3337 objBits_def archObjSize_def 3338 return_def fail_def lookupAround2_char2 split:option.splits if_split_asm) 3339 apply (rule ccontr) 3340 apply (simp add:ps_clear_def field_simps) 3341 apply (erule_tac x = x2 in in_empty_interE) 3342 apply (clarsimp simp:less_imp_le) 3343 apply (rule conjI) 3344 apply (subst add.commute) 3345 apply (rule word_diff_ls') 3346 apply (clarsimp simp:field_simps not_le plus_one_helper) 3347 apply (simp add:field_simps is_aligned_no_wrap' is_aligned_mask) 3348 apply simp 3349 apply auto 3350 done 3351 3352lemma threadSet_det: 3353 "tcb_at' ptr s 3354 \<Longrightarrow> threadSet f ptr s = 3355 modify (ksPSpace_update (\<lambda>ps. ps(ptr \<mapsto> 3356 (\<lambda>t. case t of Some (KOTCB tcb) \<Rightarrow> KOTCB (f tcb)) (ps ptr)))) s" 3357 apply (clarsimp simp add:threadSet_def bind_def obj_at'_def) 3358 apply (clarsimp simp:projectKO_eq projectKO_opt_tcb 3359 split: Structures_H.kernel_object.splits) 3360 apply (subst getTCB_det,simp add:ko_wp_at'_def)+ 3361 apply (clarsimp simp:setObject_def gets_def get_def) 3362 apply (subst bind_def) 3363 apply (clarsimp simp:split_def) 3364 apply (simp add:lookupAround2_known1 bind_assoc projectKO_def 3365 assert_opt_def updateObject_default_def projectKO_opt_tcb) 3366 apply (clarsimp simp add: 3367 alignCheck_def unless_def when_def 3368 is_aligned_mask objBits_simps) 3369 apply (clarsimp simp:magnitudeCheck_det bind_def) 3370 apply (cut_tac ko = "KOTCB obj" in magnitudeCheck_det) 3371 apply (simp add:objBits_simps is_aligned_mask)+ 3372 apply (clarsimp simp:modify_def get_def put_def bind_def) 3373 done 3374 3375 3376lemma setCTE_modify_tcbDomain_commute: 3377 " monad_commute 3378 (tcb_at' ptr and cte_wp_at' (\<lambda>_. True) src and pspace_distinct' and pspace_aligned') (setCTE src cte) 3379 (threadSet (tcbDomain_update (\<lambda>_. ra)) ptr)" 3380 proof - 3381 note blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff 3382 Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex 3383 atLeastAtMost_iff 3384 3385 have hint: 3386 "\<And>P ptr a cte b src ra. monad_commute (tcb_at' ptr and ko_wp_at' P a ) 3387 (threadSet (tcbDomain_update (\<lambda>_. ra)) ptr) 3388 (modify (ksPSpace_update (\<lambda>ps. ps(a \<mapsto> cte_update cte (the (ps a)) src a))))" 3389 apply (clarsimp simp add: monad_commute_def 3390 bind_def simpler_modify_def return_def) 3391 apply (clarsimp simp:threadSet_det simpler_modify_def) 3392 apply (subgoal_tac "tcb_at' ptr (ksPSpace_update (\<lambda>ps. ps(a \<mapsto> cte_update cte (the (ps a)) src a)) s)") 3393 prefer 2 3394 apply (clarsimp simp:obj_at'_def) 3395 apply (intro conjI impI) 3396 apply simp 3397 apply (clarsimp simp:projectKO_eq 3398 projectKO_opt_tcb split:Structures_H.kernel_object.split_asm) 3399 apply (simp add:cte_update_def) 3400 apply (clarsimp simp:projectKO_eq 3401 projectKO_opt_tcb split:Structures_H.kernel_object.split_asm) 3402 apply (simp add:ps_clear_def) 3403 apply (clarsimp simp:projectKO_eq 3404 projectKO_opt_tcb split:Structures_H.kernel_object.split_asm) 3405 apply (simp add:ps_clear_def) 3406 apply (rule ccontr,simp) 3407 apply (erule in_emptyE) 3408 apply (clarsimp simp:ko_wp_at'_def) 3409 apply blast 3410 apply (simp add:threadSet_det simpler_modify_def) 3411 apply (subst (asm) obj_at'_def) 3412 apply (thin_tac "tcb_at' ptr P" for P) 3413 apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_opt_tcb, 3414 simp split: Structures_H.kernel_object.split_asm) 3415 apply (case_tac s,clarsimp) 3416 apply (intro conjI) 3417 apply clarsimp 3418 apply (rule ext,clarsimp) 3419 apply (case_tac obj) 3420 apply (simp add:cte_update_def) 3421 apply clarsimp 3422 apply (rule ext) 3423 apply simp 3424 done 3425 3426 show ?thesis 3427 apply (rule commute_name_pre_state) 3428 apply (clarsimp simp add: setCTE_def2) 3429 apply (rule monad_commute_guard_imp) 3430 apply (rule commute_commute[OF monad_commute_split]) 3431 apply (rule hint) 3432 apply (rule commute_commute) 3433 apply (rule locateCTE_commute) 3434 apply (wp locateCTE_cte_no_fail)+ 3435 apply (wp threadSet_ko_wp_at2') 3436 apply (clarsimp simp:objBits_simps) 3437 apply (wp|simp)+ 3438 apply (wp locateCTE_inv locateCTE_ko_wp_at') 3439 apply clarsimp 3440 apply fastforce 3441 done 3442qed 3443 3444lemma curDomain_commute: 3445 assumes cur:"\<And>P. \<lbrace>\<lambda>s. P (ksCurDomain s)\<rbrace> f \<lbrace>\<lambda>r s. P (ksCurDomain s)\<rbrace>" 3446 shows "monad_commute \<top> f curDomain" 3447 apply (clarsimp simp add:monad_commute_def curDomain_def get_def return_def 3448 gets_def bind_def) 3449 apply (rule conjI) 3450 apply (rule set_eqI) 3451 apply (rule iffI) 3452 apply clarsimp 3453 apply (rule bexI[rotated], assumption) 3454 apply clarsimp 3455 apply (frule_tac P1 = "\<lambda>x. x = ksCurDomain s" in use_valid[OF _ cur]) 3456 apply simp+ 3457 apply clarsimp 3458 apply (rule bexI[rotated], assumption) 3459 apply clarsimp 3460 apply (frule_tac P1 = "\<lambda>x. x = ksCurDomain s" in use_valid[OF _ cur]) 3461 apply simp+ 3462 apply auto 3463 done 3464 3465crunch inv[wp]: curDomain P 3466 3467lemma placeNewObject_tcb_at': 3468 notes blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff 3469 Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex 3470 atLeastAtMost_iff 3471 shows 3472 "\<lbrace>pspace_aligned' and pspace_distinct' 3473 and pspace_no_overlap' ptr (objBits (makeObject::tcb)) 3474 and K(is_aligned ptr (objBits (makeObject::tcb))) 3475 \<rbrace> placeNewObject ptr (makeObject::tcb) 0 3476 \<lbrace>\<lambda>rv s. tcb_at' ptr s \<rbrace>" 3477 apply (simp add:placeNewObject_def placeNewObject'_def split_def) 3478 apply (wp hoare_unless_wp |wpc | simp add:alignError_def)+ 3479 apply (auto simp:obj_at'_def is_aligned_mask lookupAround2_None1 3480 lookupAround2_char1 field_simps is_aligned_neg_mask_eq 3481 projectKO_opt_tcb projectKO_def return_def ps_clear_def 3482 split:if_splits 3483 dest!:pspace_no_overlap_disjoint' 3484 )[1] 3485 apply (drule_tac m = "ksPSpace s" in domI) 3486 apply (erule in_emptyE) 3487 apply (fastforce simp:objBits_simps) 3488 done 3489 3490(* Some times the weak if version of monad_commute is enough *) 3491lemma monad_commute_if_weak_l: 3492"\<lbrakk>monad_commute P1 f1 h; monad_commute P2 f2 h\<rbrakk> \<Longrightarrow> 3493 monad_commute (P1 and P2) (if d then f1 else f2) h" 3494 apply (clarsimp) 3495 apply (intro conjI impI) 3496 apply (erule monad_commute_guard_imp,simp)+ 3497 done 3498 3499lemma monad_commute_if_weak_r: 3500"\<lbrakk>monad_commute P1 f h1; monad_commute P2 f h2\<rbrakk> \<Longrightarrow> 3501 monad_commute (P1 and P2) f (if d then h1 else h2)" 3502 apply (clarsimp) 3503 apply (intro conjI impI) 3504 apply (erule monad_commute_guard_imp,simp)+ 3505 done 3506 3507lemma createObject_setCTE_commute: 3508 "monad_commute 3509 (cte_wp_at' (\<lambda>_. True) src and 3510 pspace_aligned' and pspace_distinct' and 3511 pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and 3512 valid_arch_state' and K (ptr \<noteq> src) and 3513 K (is_aligned ptr (Types_H.getObjectSize ty us)) and 3514 K (Types_H.getObjectSize ty us < word_bits)) 3515 (RetypeDecls_H.createObject ty ptr us d) 3516 (setCTE src cte)" 3517 apply (rule commute_grab_asm)+ 3518 apply (subgoal_tac "ptr && mask (Types_H.getObjectSize ty us) = 0") 3519 prefer 2 3520 apply (clarsimp simp: range_cover_def is_aligned_mask) 3521 apply (clarsimp simp: createObject_def) 3522 apply (case_tac ty, 3523 simp_all add: ARM_H.toAPIType_def) 3524 apply (rename_tac apiobject_type) 3525 apply (case_tac apiobject_type) 3526 apply (simp_all add: 3527 ARM_H.getObjectSize_def apiGetObjectSize_def 3528 tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def 3529 cteSizeBits_def) 3530 \<comment> \<open>Untyped\<close> 3531 apply (simp add: monad_commute_guard_imp[OF return_commute]) 3532 \<comment> \<open>TCB, EP, NTFN\<close> 3533 apply (rule monad_commute_guard_imp[OF commute_commute]) 3534 apply (rule monad_commute_split[OF monad_commute_split]) 3535 apply (rule monad_commute_split[OF commute_commute[OF return_commute]]) 3536 apply (rule setCTE_modify_tcbDomain_commute) 3537 apply wp 3538 apply (rule curDomain_commute) 3539 apply wp+ 3540 apply (rule setCTE_placeNewObject_commute) 3541 apply (wp placeNewObject_tcb_at' placeNewObject_cte_wp_at' 3542 placeNewObject_pspace_distinct' 3543 placeNewObject_pspace_aligned' 3544 | clarsimp simp: objBits_simps')+ 3545 apply (rule monad_commute_guard_imp[OF commute_commute] 3546 ,rule monad_commute_split[OF commute_commute[OF return_commute]] 3547 ,rule setCTE_placeNewObject_commute 3548 ,(wp|clarsimp simp: objBits_simps')+)+ 3549 \<comment> \<open>CNode\<close> 3550 apply (rule monad_commute_guard_imp[OF commute_commute]) 3551 apply (rule monad_commute_split)+ 3552 apply (rule return_commute[THEN commute_commute]) 3553 apply (rule setCTE_modify_gsCNode_commute[of \<top>]) 3554 apply (rule hoare_triv[of \<top>]) 3555 apply wp 3556 apply (rule setCTE_placeNewObject_commute) 3557 apply (wp|clarsimp simp: objBits_simps')+ 3558 \<comment> \<open>Arch Objects\<close> 3559 apply ((rule monad_commute_guard_imp[OF commute_commute] 3560 , rule monad_commute_split[OF commute_commute[OF return_commute]] 3561 , clarsimp simp: ARM_H.createObject_def 3562 placeNewDataObject_def bind_assoc split 3563 del: if_splits 3564 ,(rule monad_commute_split return_commute[THEN commute_commute] 3565 setCTE_modify_gsUserPages_commute[of \<top>] 3566 modify_wp[of "%_. \<top>"] 3567 setCTE_unless_doMachineOp_commute 3568 setCTE_doMachineOp_commute 3569 setCTE_placeNewObject_commute 3570 monad_commute_if_weak_r 3571 copyGlobalMappings_setCTE_commute[THEN commute_commute] 3572 | wp placeNewObject_pspace_distinct' 3573 placeNewObject_pspace_aligned' 3574 placeNewObject_cte_wp_at' 3575 placeNewObject_valid_arch_state placeNewObject_pd_at' 3576 | erule is_aligned_weaken 3577 | simp add: objBits_simps pageBits_def ptBits_def pdBits_def 3578 pdeBits_def pdBits_def pteBits_def 3579 archObjSize_def split del: if_splits)+)+) 3580 done 3581 3582 3583lemma createObject_updateMDB_commute: 3584 "monad_commute 3585 ((\<lambda>s. src \<noteq> 0 \<longrightarrow> cte_wp_at' (\<lambda>_. True) src s) and 3586 pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and 3587 pspace_aligned' and pspace_distinct' and valid_arch_state' and 3588 K (ptr \<noteq> src) and 3589 K (is_aligned ptr (Types_H.getObjectSize ty us)) and 3590 K ((Types_H.getObjectSize ty us)< word_bits)) 3591 (updateMDB src f) (RetypeDecls_H.createObject ty ptr us d)" 3592 apply (clarsimp simp:updateMDB_def split:if_split_asm) 3593 apply (intro conjI impI) 3594 apply (simp add: monad_commute_guard_imp[OF return_commute]) 3595 apply (rule monad_commute_guard_imp) 3596 apply (rule commute_commute[OF monad_commute_split]) 3597 apply (rule createObject_setCTE_commute) 3598 apply (rule createObject_getCTE_commute) 3599 apply wp 3600 apply (auto simp:range_cover_full) 3601 done 3602 3603lemma updateMDB_pspace_no_overlap': 3604 "\<lbrace>pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz\<rbrace> 3605 updateMDB slot f 3606 \<lbrace>\<lambda>rv s. pspace_no_overlap' ptr sz s\<rbrace>" 3607 apply (rule hoare_pre) 3608 apply (clarsimp simp: updateMDB_def split del: if_split) 3609 apply (wp setCTE_pspace_no_overlap') 3610 apply clarsimp 3611 done 3612 3613lemma ctes_of_ko_at: 3614 "ctes_of s p = Some a \<Longrightarrow> 3615 (\<exists>ptr ko. (ksPSpace s ptr = Some ko \<and> p \<in> obj_range' ptr ko))" 3616 apply (clarsimp simp: map_to_ctes_def Let_def split: if_split_asm) 3617 apply (intro exI conjI, assumption) 3618 apply (simp add: obj_range'_def objBits_simps' is_aligned_no_wrap' field_simps) 3619 apply (intro exI conjI, assumption) 3620 apply (clarsimp simp: objBits_simps' obj_range'_def word_and_le2) 3621 apply (thin_tac "P" for P)+ 3622 apply (simp add: mask_def) 3623 apply word_bitwise 3624 done 3625 3626lemma pspace_no_overlapD2': 3627 "\<lbrakk>is_aligned ptr sz; pspace_no_overlap' ptr sz s;sz < word_bits; 3628 ctes_of s slot = Some cte\<rbrakk> 3629 \<Longrightarrow> slot \<noteq> ptr" 3630 apply (drule ctes_of_ko_at) 3631 apply clarsimp 3632 apply (drule(1) pspace_no_overlapD') 3633 apply (erule in_empty_interE) 3634 apply (simp add:obj_range'_def) 3635 apply clarsimp 3636 apply (subst is_aligned_neg_mask_eq[symmetric]) 3637 apply simp 3638 apply (simp add: is_aligned_neg_mask is_aligned_no_overflow) 3639 done 3640 3641lemma caps_overlap_reserved'_subseteq: 3642 "\<lbrakk>caps_overlap_reserved' B s; A\<subseteq> B\<rbrakk> \<Longrightarrow> caps_overlap_reserved' A s" 3643 apply (clarsimp simp:caps_overlap_reserved'_def) 3644 apply (drule(1) bspec) 3645 apply (erule disjoint_subset2) 3646 apply simp 3647 done 3648 3649definition weak_valid_dlist where 3650 "weak_valid_dlist \<equiv> \<lambda>m. 3651 (\<forall>p cte. 3652 m p = Some cte \<longrightarrow> 3653 (let next = mdbNext (cteMDBNode cte) 3654 in (next \<noteq> 0 \<longrightarrow> (\<exists>cte'. m next = Some cte' \<and> cteCap cte'\<noteq> capability.NullCap))))" 3655 3656lemma valid_arch_state'_updateMDB: 3657 "\<lbrace>valid_arch_state' \<rbrace> updateMDB a b \<lbrace>\<lambda>rv. valid_arch_state'\<rbrace>" 3658 by (clarsimp simp:updateMDB_def valid_arch_state_def,wp) 3659 3660lemma fail_commute: 3661 "monad_commute \<top> fail f = empty_fail f" 3662 apply (simp add: monad_commute_def empty_fail_def) 3663 apply (simp add: fail_def bind_def del: split_paired_Ex) 3664 apply blast 3665 done 3666 3667lemma modify_commute: 3668 "monad_commute P (modify f) (modify g) 3669 = (\<forall>s. P s \<longrightarrow> f (g s) = g (f s))" 3670 apply (simp add: monad_commute_def exec_modify) 3671 apply (simp add: return_def eq_commute) 3672 done 3673 3674lemma createObjects_gsUntypedZeroRanges_commute': 3675 "monad_commute \<top> 3676 (createObjects' ptr n ko us) 3677 (modify (\<lambda>s. s \<lparr> gsUntypedZeroRanges := f (gsUntypedZeroRanges s) \<rparr> ))" 3678 apply (simp add: createObjects'_def unless_def when_def alignError_def 3679 fail_commute) 3680 apply clarsimp 3681 apply (rule commute_commute) 3682 apply (strengthen monad_commute_guard_imp[OF monad_commute_split[where P="\<top>" and Q="\<top>\<top>"], OF _ _ hoare_vcg_prop] 3683 | simp add: modify_commute split: option.split prod.split)+ 3684 apply (simp add: monad_commute_def exec_modify exec_gets assert_def) 3685 done 3686 3687lemma assert_commute2: "empty_fail f 3688 \<Longrightarrow> monad_commute \<top> (assert G) f" 3689 apply (clarsimp simp:assert_def monad_commute_def) 3690 apply (simp add: fail_def bind_def empty_fail_def del: split_paired_Ex) 3691 apply blast 3692 done 3693 3694lemma threadSet_gsUntypedZeroRanges_commute': 3695 "monad_commute \<top> 3696 (threadSet fn ptr) 3697 (modify (\<lambda>s. s \<lparr> gsUntypedZeroRanges := f (gsUntypedZeroRanges s) \<rparr> ))" 3698 apply (simp add: threadSet_def getObject_def setObject_def) 3699 apply (rule commute_commute) 3700 apply (strengthen monad_commute_guard_imp[OF monad_commute_split[where P="\<top>" and Q="\<top>\<top>"], OF _ _ hoare_vcg_prop] 3701 | simp add: modify_commute updateObject_default_def alignCheck_assert 3702 magnitudeCheck_assert return_commute return_commute[THEN commute_commute] 3703 projectKO_def2 assert_commute2 assert_commute2[THEN commute_commute] 3704 assert_opt_def2 loadObject_default_def 3705 split: option.split prod.split)+ 3706 apply (simp add: monad_commute_def exec_gets exec_modify) 3707 done 3708 3709lemma doMachineOp_modify_commute: 3710 "\<lbrakk> \<forall>s. P s \<longrightarrow> ksMachineState (f s) = ksMachineState s; 3711 \<forall>s. P s \<longrightarrow> (\<forall>(rv, ms') \<in> fst (oper (ksMachineState s)). 3712 f (ksMachineState_update (\<lambda>_. ms') s) = ksMachineState_update (\<lambda>_. ms') (f s)) \<rbrakk> 3713 \<Longrightarrow> monad_commute P (doMachineOp oper) (modify (f))" 3714 apply (clarsimp simp: monad_commute_def doMachineOp_def 3715 exec_gets bind_assoc exec_modify) 3716 apply (simp add: bind_def[where f="select_f v" for v], 3717 simp add: select_f_def split_def exec_modify cart_singleton_image) 3718 done 3719 3720lemma copyGlobalMappings_gsUntypedZeroRanges_commute': 3721 "monad_commute \<top> 3722 (copyGlobalMappings ptr) 3723 (modify (\<lambda>s. s \<lparr> gsUntypedZeroRanges := f (gsUntypedZeroRanges s) \<rparr> ))" 3724 apply (simp add: copyGlobalMappings_def) 3725 apply (rule monad_commute_guard_imp) 3726 apply (rule commute_commute[OF monad_commute_split[where P="\<top>"]]) 3727 apply (rule mapM_x_commute[where f = id and P="\<top>\<top>"]) 3728 apply (simp add: storePDE_def getObject_def setObject_def cong: bind_cong) 3729 apply (strengthen monad_commute_guard_imp[OF monad_commute_split[where P="\<top>" and Q="\<top>\<top>"], OF _ _ hoare_vcg_prop] 3730 | simp add: modify_commute updateObject_default_def alignCheck_assert 3731 magnitudeCheck_assert return_commute return_commute[THEN commute_commute] 3732 projectKO_def2 assert_commute2 assert_commute2[THEN commute_commute] 3733 assert_opt_def2 loadObject_default_def 3734 split: option.split prod.split)+ 3735 apply (simp add: monad_commute_def exec_gets exec_modify) 3736 apply wp 3737 apply (simp add: monad_commute_def exec_gets exec_modify) 3738 apply wp 3739 apply simp 3740 done 3741 3742lemma createObject_gsUntypedZeroRanges_commute: 3743 "monad_commute 3744 \<top> 3745 (RetypeDecls_H.createObject ty ptr us dev) 3746 (modify (\<lambda>s. s \<lparr> gsUntypedZeroRanges := f (gsUntypedZeroRanges s) \<rparr> ))" 3747 apply (simp add: createObject_def ARM_H.createObject_def 3748 placeNewDataObject_def 3749 placeNewObject_def2 bind_assoc fail_commute 3750 return_commute toAPIType_def 3751 split: option.split apiobject_type.split object_type.split) 3752 apply (strengthen monad_commute_guard_imp[OF monad_commute_split[where P="\<top>" and Q="\<top>\<top>"], 3753 OF _ _ hoare_vcg_prop, THEN commute_commute] 3754 monad_commute_guard_imp[OF monad_commute_split[where P="\<top>" and Q="\<top>\<top>"], 3755 OF _ _ hoare_vcg_prop] 3756 | simp add: modify_commute createObjects_gsUntypedZeroRanges_commute' 3757 createObjects_gsUntypedZeroRanges_commute'[THEN commute_commute] 3758 return_commute return_commute[THEN commute_commute] 3759 threadSet_gsUntypedZeroRanges_commute'[THEN commute_commute] 3760 doMachineOp_modify_commute[THEN commute_commute] 3761 copyGlobalMappings_gsUntypedZeroRanges_commute'[THEN commute_commute] 3762 split: option.split prod.split cong: if_cong)+ 3763 apply (simp add: curDomain_def monad_commute_def exec_modify exec_gets) 3764 done 3765 3766lemma monad_commute_If_rhs: 3767 "monad_commute P a b \<Longrightarrow> monad_commute Q a c 3768 \<Longrightarrow> monad_commute (\<lambda>s. (R \<longrightarrow> P s) \<and> (\<not> R \<longrightarrow> Q s)) a (if R then b else c)" 3769 by simp 3770 3771lemma case_eq_if_isUntypedCap: 3772 "(case c of UntypedCap _ _ _ _ \<Rightarrow> x | _ \<Rightarrow> y) 3773 = (if isUntypedCap c then x else y)" 3774 by (cases c, simp_all add: isCap_simps) 3775 3776lemma createObject_updateTrackedFreeIndex_commute: 3777 "monad_commute 3778 (cte_wp_at' (\<lambda>_. True) slot and pspace_aligned' and pspace_distinct' and 3779 pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and 3780 valid_arch_state' and 3781 K (ptr \<noteq> slot) and K (Types_H.getObjectSize ty us < word_bits) and 3782 K (is_aligned ptr (Types_H.getObjectSize ty us))) 3783 (RetypeDecls_H.createObject ty ptr us dev) (updateTrackedFreeIndex slot idx)" 3784 apply (simp add: updateTrackedFreeIndex_def getSlotCap_def updateCap_def) 3785 apply (rule monad_commute_guard_imp) 3786 apply (rule monad_commute_split[OF _ createObject_getCTE_commute] 3787 monad_commute_split[OF _ createObject_gsUntypedZeroRanges_commute] 3788 createObject_gsUntypedZeroRanges_commute)+ 3789 apply (wp getCTE_wp')+ 3790 apply (clarsimp simp: pspace_no_overlap'_def) 3791 done 3792 3793lemma createObject_updateNewFreeIndex_commute: 3794 "monad_commute 3795 (cte_wp_at' (\<lambda>_. True) slot and pspace_aligned' and pspace_distinct' and 3796 pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and 3797 valid_arch_state' and 3798 K (ptr \<noteq> slot) and K (Types_H.getObjectSize ty us < word_bits) and 3799 K (is_aligned ptr (Types_H.getObjectSize ty us))) 3800 (RetypeDecls_H.createObject ty ptr us dev) (updateNewFreeIndex slot)" 3801 apply (simp add: updateNewFreeIndex_def getSlotCap_def case_eq_if_isUntypedCap 3802 updateTrackedFreeIndex_def) 3803 apply (rule monad_commute_guard_imp) 3804 apply (rule monad_commute_split[OF _ createObject_getCTE_commute]) 3805 apply (rule monad_commute_If_rhs) 3806 apply (rule createObject_updateTrackedFreeIndex_commute) 3807 apply (rule commute_commute[OF return_commute]) 3808 apply (wp getCTE_wp') 3809 apply clarsimp 3810 done 3811 3812lemma new_cap_object_comm_helper: 3813 "monad_commute 3814 (pspace_aligned' and pspace_distinct' and (\<lambda>s. no_0 (ctes_of s)) and 3815 (\<lambda>s. weak_valid_dlist (ctes_of s)) and 3816 (\<lambda>s. valid_nullcaps (ctes_of s)) and 3817 cte_wp_at' (\<lambda>c. isUntypedCap (cteCap c)) parent and 3818 cte_wp_at' (\<lambda>c. cteCap c = capability.NullCap) slot and 3819 pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and 3820 valid_arch_state' and 3821 K (Types_H.getObjectSize ty us<word_bits) and 3822 K (cap \<noteq> capability.NullCap) and 3823 K (is_aligned ptr (Types_H.getObjectSize ty us) \<and> ptr \<noteq> 0 \<and> parent \<noteq> 0)) 3824 (RetypeDecls_H.createObject ty ptr us d) (insertNewCap parent slot cap)" 3825 apply (clarsimp simp:insertNewCap_def bind_assoc liftM_def) 3826 apply (rule monad_commute_guard_imp) 3827 apply (rule monad_commute_split[OF _ createObject_getCTE_commute])+ 3828 apply (rule monad_commute_split[OF _ commute_commute[OF assert_commute]]) 3829 apply (rule monad_commute_split[OF _ createObject_setCTE_commute]) 3830 apply (rule monad_commute_split[OF _ commute_commute[OF createObject_updateMDB_commute]]) 3831 apply (rule monad_commute_split[OF _ commute_commute[OF createObject_updateMDB_commute]]) 3832 apply (rule createObject_updateNewFreeIndex_commute) 3833 apply (wp getCTE_wp hoare_vcg_imp_lift hoare_vcg_disj_lift valid_arch_state'_updateMDB 3834 updateMDB_pspace_no_overlap' setCTE_pspace_no_overlap' 3835 | clarsimp simp:conj_comms)+ 3836 apply (clarsimp simp:cte_wp_at_ctes_of) 3837 apply (frule_tac slot = slot in pspace_no_overlapD2') 3838 apply simp+ 3839 apply (frule_tac slot = parent in pspace_no_overlapD2') 3840 apply simp+ 3841 apply (case_tac ctea,clarsimp) 3842 apply (frule_tac p = slot in nullcapsD') 3843 apply simp+ 3844 apply (subgoal_tac "(mdbNext (cteMDBNode cte) = 0 \<or> 3845 (\<exists>ctea. ctes_of s (mdbNext (cteMDBNode cte)) = Some ctea))") 3846 apply (elim disjE) 3847 apply clarsimp+ 3848 apply (frule_tac slot = "(mdbNext (cteMDBNode cte))" 3849 in pspace_no_overlapD2') 3850 apply simp+ 3851 apply (clarsimp simp:weak_valid_dlist_def) 3852 apply (drule_tac x = "parent " in spec) 3853 apply clarsimp 3854 done 3855 3856lemma pspace_no_overlap_gsUntypedZeroRanges[simp]: 3857 "pspace_no_overlap' ptr n (gsUntypedZeroRanges_update f s) 3858 = pspace_no_overlap' ptr n s" 3859 by (simp add: pspace_no_overlap'_def) 3860 3861crunch pspace_aligned'[wp]: updateNewFreeIndex "pspace_aligned'" 3862crunch pspace_distinct'[wp]: updateNewFreeIndex "pspace_distinct'" 3863crunch valid_arch_state'[wp]: updateNewFreeIndex "valid_arch_state'" 3864crunch pspace_no_overlap'[wp]: updateNewFreeIndex "pspace_no_overlap' ptr n" 3865crunch ctes_of[wp]: updateNewFreeIndex "\<lambda>s. P (ctes_of s)" 3866 3867lemma updateNewFreeIndex_cte_wp_at[wp]: 3868 "\<lbrace>\<lambda>s. P (cte_wp_at' P' p s)\<rbrace> updateNewFreeIndex slot \<lbrace>\<lambda>rv s. P (cte_wp_at' P' p s)\<rbrace>" 3869 by (simp add: cte_wp_at_ctes_of, wp) 3870 3871lemma new_cap_object_commute: 3872 "monad_commute 3873 (cte_wp_at' (\<lambda>c. isUntypedCap (cteCap c)) parent and 3874 (\<lambda>s. \<forall>slot\<in>set list. cte_wp_at' (\<lambda>c. cteCap c = capability.NullCap) slot s) and 3875 pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and 3876 valid_pspace' and valid_arch_state' and 3877 K (distinct (map fst (zip list caps))) and 3878 K (\<forall>cap \<in> set caps. cap \<noteq> capability.NullCap) and 3879 K (Types_H.getObjectSize ty us <word_bits) and 3880 K (is_aligned ptr (Types_H.getObjectSize ty us) \<and> ptr \<noteq> 0)) 3881 (RetypeDecls_H.createObject ty ptr us d) 3882 (zipWithM_x (insertNewCap parent) list caps)" 3883 apply (clarsimp simp:zipWithM_x_mapM_x) 3884 apply (rule monad_commute_guard_imp) 3885 apply (rule mapM_x_commute[where f = fst]) 3886 apply (simp add:split_def) 3887 apply (rule new_cap_object_comm_helper) 3888 apply (clarsimp simp:insertNewCap_def split_def) 3889 apply (wp updateMDB_weak_cte_wp_at updateMDB_pspace_no_overlap' 3890 getCTE_wp valid_arch_state'_updateMDB 3891 setCTE_weak_cte_wp_at setCTE_pspace_no_overlap') 3892 apply (clarsimp simp:cte_wp_at_ctes_of simp del:fun_upd_apply) 3893 apply (case_tac "parent \<noteq> aa") 3894 prefer 2 3895 apply simp 3896 apply (clarsimp simp: conj_comms) 3897 apply (intro conjI exI) 3898 apply (clarsimp simp: no_0_def) 3899 apply (clarsimp simp: weak_valid_dlist_def modify_map_def Let_def) 3900 subgoal by (intro conjI impI; fastforce) 3901 apply (clarsimp simp:valid_nullcaps_def) 3902 apply (frule_tac x = "p" in spec) 3903 apply (case_tac ctec) 3904 apply (case_tac cte) 3905 apply (rename_tac cap' node') 3906 apply (case_tac node') 3907 apply (rename_tac word1 word2 bool1 bool2) 3908 apply (clarsimp simp:modify_map_def split:if_split_asm) 3909 apply (case_tac z) 3910 apply (drule_tac x = word1 in spec) 3911 apply (clarsimp simp:weak_valid_dlist_def) 3912 apply (drule_tac x = parent in spec) 3913 apply clarsimp 3914 apply (clarsimp simp:valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def) 3915 apply (intro conjI) 3916 apply (clarsimp simp:weak_valid_dlist_def Let_def) 3917 apply (frule(2) valid_dlist_nextD) 3918 apply clarsimp 3919 apply (case_tac cte') 3920 apply clarsimp 3921 apply (drule_tac m = "ctes_of s" in nullcapsD') 3922 apply simp 3923 apply (clarsimp simp: no_0_def nullPointer_def) 3924 apply (erule in_set_zipE) 3925 apply clarsimp 3926 apply (erule in_set_zipE) 3927 apply clarsimp 3928 apply (clarsimp simp:cte_wp_at_ctes_of) 3929 done 3930 3931lemma createObjects'_pspace_no_overlap: 3932 "gz = (objBitsKO val) + us \<Longrightarrow> 3933 \<lbrace>pspace_no_overlap' (ptr + (1 + of_nat n << gz)) gz and 3934 K (range_cover ptr sz gz (Suc (Suc n)) \<and> ptr \<noteq> 0)\<rbrace> 3935 createObjects' ptr (Suc n) val us 3936 \<lbrace>\<lambda>addrs s. pspace_no_overlap' (ptr + (1 + of_nat n << gz)) gz s\<rbrace>" 3937proof - 3938 note simps [simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff 3939 atLeastatMost_subset_iff atLeastLessThan_iff 3940 Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex 3941 assume "gz = (objBitsKO val) + us" 3942 thus ?thesis 3943 apply - 3944 apply (rule hoare_gen_asm) 3945 apply (clarsimp simp:createObjects'_def split_def new_cap_addrs_fold') 3946 apply (subst new_cap_addrs_fold') 3947 apply clarsimp 3948 apply (drule range_cover_le[where n = "Suc n"]) 3949 apply simp 3950 apply (drule_tac gbits = us in range_cover_not_zero_shift[rotated]) 3951 apply simp+ 3952 apply (simp add:word_le_sub1) 3953 apply (wp haskell_assert_wp hoare_unless_wp | wpc |simp add:alignError_def del:fun_upd_apply)+ 3954 apply (rule conjI) 3955 apply (rule impI) 3956 apply (subgoal_tac 3957 "pspace_no_overlap' (ptr + (1 + of_nat n << objBitsKO val + us)) 3958 (objBitsKO val + us) 3959 (s\<lparr>ksPSpace := foldr (\<lambda>addr map. map(addr \<mapsto> val)) 3960 (new_cap_addrs (unat (1 + of_nat n << us)) ptr val) (ksPSpace s)\<rparr>)") 3961 apply (intro conjI impI allI) 3962 apply assumption+ 3963 apply (subst pspace_no_overlap'_def) 3964 apply (intro allI impI) 3965 apply (subst (asm) foldr_upd_app_if) 3966 apply (subst is_aligned_neg_mask_eq) 3967 apply (rule aligned_add_aligned[OF range_cover.aligned],assumption) 3968 apply (rule is_aligned_shiftl_self) 3969 apply (simp add:range_cover_def) 3970 apply simp 3971 apply (clarsimp split:if_splits) 3972 apply (drule obj_range'_subset_strong[rotated]) 3973 apply (rule range_cover_rel[OF range_cover_le[where n = "Suc n"]],assumption) 3974 apply simp 3975 apply simp 3976 apply (drule range_cover.unat_of_nat_n_shift 3977 [OF range_cover_le[where n = "Suc n"],where gbits = us]) 3978 apply simp 3979 apply (simp add:shiftl_t2n field_simps)+ 3980 apply (simp add:obj_range'_def) 3981 apply (erule disjoint_subset) 3982 apply (clarsimp simp: simps) 3983 apply (thin_tac "x \<le> y" for x y) 3984 apply (subst (asm) le_m1_iff_lt[THEN iffD1]) 3985 apply (drule_tac range_cover_no_0[rotated,where p = "Suc n"]) 3986 apply simp 3987 apply simp 3988 apply (simp add:field_simps) 3989 apply (simp add: power_add[symmetric]) 3990 apply (simp add: word_neq_0_conv) 3991 apply (simp add: power_add[symmetric] field_simps) 3992 apply (frule range_cover_subset[where p = "Suc n"]) 3993 apply simp 3994 apply simp 3995 apply (drule(1) pspace_no_overlapD') 3996 apply (subst (asm) is_aligned_neg_mask_eq) 3997 apply (rule aligned_add_aligned[OF range_cover.aligned],assumption) 3998 apply (rule is_aligned_shiftl_self) 3999 apply (simp add:range_cover_def) 4000 apply simp 4001 apply (simp add:word_le_sub1 shiftl_t2n field_simps) 4002 apply auto 4003 done 4004qed 4005 4006lemma createNewCaps_not_nc: 4007 "\<lbrace>\<top>\<rbrace> 4008 createNewCaps ty ptr (Suc (length as)) us d 4009 \<lbrace>\<lambda>r s. (\<forall>cap\<in>set r. cap \<noteq> capability.NullCap)\<rbrace>" 4010 apply (clarsimp simp:simp:createNewCaps_def Arch_createNewCaps_def ) 4011 apply (rule hoare_pre) 4012 apply wpc 4013 apply wp 4014 apply (simp add:Arch_createNewCaps_def split del: if_split) 4015 apply (wpc|wp|clarsimp)+ 4016done 4017 4018lemma doMachineOp_psp_no_overlap: 4019 "\<lbrace>\<lambda>s. pspace_no_overlap' ptr sz s \<and> pspace_aligned' s \<and> pspace_distinct' s \<rbrace> 4020 doMachineOp f 4021 \<lbrace>\<lambda>y s. pspace_no_overlap' ptr sz s\<rbrace>" 4022 by (wp pspace_no_overlap'_lift,simp) 4023 4024lemma unless_doMachineOp_psp_no_overlap: 4025 "\<lbrace>\<lambda>s. pspace_no_overlap' ptr sz s \<and> pspace_aligned' s \<and> pspace_distinct' s \<rbrace> 4026 unless d $ doMachineOp f 4027 \<lbrace>\<lambda>y s. pspace_no_overlap' ptr sz s\<rbrace>" 4028 by (wp hoare_unless_wp doMachineOp_psp_no_overlap, simp) 4029 4030lemma createObjects'_psp_distinct: 4031 "\<lbrace>pspace_aligned' and pspace_distinct' and 4032 pspace_no_overlap' ptr sz and 4033 K (range_cover ptr sz ((objBitsKO ko) + us) n \<and> n \<noteq> 0 4034 \<and> is_aligned ptr (objBitsKO ko + us) \<and> objBitsKO ko + us < word_bits)\<rbrace> 4035 createObjects' ptr n ko us 4036 \<lbrace>\<lambda>rv s. pspace_distinct' s\<rbrace>" 4037 apply (rule hoare_name_pre_state) 4038 apply (clarsimp simp:createObjects'_def split_def) 4039 apply (subst new_cap_addrs_fold') 4040 apply (drule range_cover_not_zero_shift[where gbits = us,rotated]) 4041 apply simp+ 4042 apply unat_arith 4043 apply (rule hoare_pre) 4044 apply (wpc|wp|simp add: unless_def alignError_def del: hoare_fail_any fun_upd_apply)+ 4045 apply clarsimp 4046 apply (subst data_map_insert_def[symmetric])+ 4047 apply (simp add: range_cover.unat_of_nat_n_shift) 4048 apply (drule(2) retype_aligned_distinct'(1)[where ko = ko and n= "n*2^us" ]) 4049 apply (erule range_cover_rel) 4050 apply simp 4051 apply clarsimp 4052 apply (simp add: range_cover.unat_of_nat_n_shift) 4053 done 4054 4055lemma createObjects'_psp_aligned: 4056 "\<lbrace>pspace_aligned' and pspace_distinct' and 4057 pspace_no_overlap' ptr sz and 4058 K (range_cover ptr sz ((objBitsKO ko) + us) n \<and> n \<noteq> 0 4059 \<and> is_aligned ptr (objBitsKO ko + us) \<and> objBitsKO ko + us < word_bits)\<rbrace> 4060 createObjects' ptr n ko us 4061 \<lbrace>\<lambda>rv s. pspace_aligned' s\<rbrace>" 4062 apply (rule hoare_name_pre_state) 4063 apply (clarsimp simp: createObjects'_def split_def) 4064 apply (subst new_cap_addrs_fold') 4065 apply (drule range_cover_not_zero_shift[where gbits = us,rotated]) 4066 apply simp+ 4067 apply unat_arith 4068 apply (rule hoare_pre) 4069 apply (wpc|wp|simp add: unless_def alignError_def del: fun_upd_apply hoare_fail_any)+ 4070 apply clarsimp 4071 apply (frule(2) retype_aligned_distinct'(2)[where ko = ko and n= "n*2^us" ]) 4072 apply (erule range_cover_rel) 4073 apply simp 4074 apply clarsimp 4075 apply (subst data_map_insert_def[symmetric])+ 4076 apply (simp add: range_cover.unat_of_nat_n_shift) 4077 done 4078 4079lemma copyGlobalMappings_pspace_no_overlap': 4080 "\<lbrace>pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz\<rbrace> 4081 copyGlobalMappings xa 4082 \<lbrace>\<lambda>ya. pspace_no_overlap' ptr sz\<rbrace>" 4083 apply (rule hoare_pre) 4084 apply (clarsimp simp:copyGlobalMappings_def) 4085 apply (wp mapM_x_wp_inv pspace_no_overlap'_lift) 4086 apply clarsimp 4087 done 4088 4089lemma pspace_no_overlap'_le: 4090 assumes psp: "pspace_no_overlap' ptr sz s" "sz'\<le> sz" 4091 assumes b: "sz < word_bits" 4092 shows "pspace_no_overlap' ptr sz' s" 4093 proof - 4094 note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff 4095 Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex 4096 have diff_cancel: "\<And>a b c. (a::word32) + b - c = b + (a - c)" 4097 by simp 4098 have bound :"(ptr && ~~ mask sz') - (ptr && ~~ mask sz) \<le> 2 ^ sz - 2 ^ sz'" 4099 by (rule neg_mask_diff_bound[OF psp(2)]) 4100 show ?thesis 4101 using psp 4102 apply (clarsimp simp:pspace_no_overlap'_def) 4103 apply (drule_tac x = x in spec) 4104 apply clarsimp 4105 apply (erule disjoint_subset2[rotated]) 4106 apply (clarsimp simp:blah) 4107 apply (rule word_plus_mcs[OF _ is_aligned_no_overflow']) 4108 apply (simp add:diff_cancel p_assoc_help) 4109 apply (rule le_plus) 4110 apply (simp add:field_simps) 4111 apply (rule bound) 4112 apply (rule word_le_minus_mono_left) 4113 apply (erule two_power_increasing[OF _ b[unfolded word_bits_def]]) 4114 apply (rule word_1_le_power) 4115 using b[unfolded word_bits_def] apply simp 4116 apply (simp add:is_aligned_neg_mask) 4117 done 4118qed 4119 4120lemma pspace_no_overlap'_le2: 4121 assumes "pspace_no_overlap' ptr sz s" "ptr \<le> ptr'" "ptr' &&~~ mask sz = ptr && ~~ mask sz" 4122 shows "pspace_no_overlap' ptr' sz s" 4123 proof - 4124 note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff 4125 Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex 4126 show ?thesis 4127 using assms 4128 apply (clarsimp simp:pspace_no_overlap'_def) 4129 apply (drule_tac x = x in spec) 4130 apply clarsimp 4131 apply (erule disjoint_subset2[rotated]) 4132 apply (clarsimp simp:blah) 4133 done 4134qed 4135 4136lemma pspace_no_overlap'_tail: 4137 "\<lbrakk>range_cover ptr sz us (Suc (Suc n)); pspace_aligned' s; pspace_distinct' s; 4138 pspace_no_overlap' ptr sz s; ptr \<noteq> 0\<rbrakk> 4139 \<Longrightarrow> pspace_no_overlap' (ptr + (1 + of_nat n << us)) sz s" 4140 apply (erule pspace_no_overlap'_le2) 4141 apply (erule(1) range_cover_ptr_le) 4142 apply (erule(1) range_cover_tail_mask) 4143 done 4144 4145lemma createNewCaps_pspace_no_overlap': 4146 "\<lbrace>\<lambda>s. range_cover ptr sz (Types_H.getObjectSize ty us) (Suc (Suc n)) \<and> 4147 pspace_aligned' s \<and> pspace_distinct' s \<and> pspace_no_overlap' ptr sz s \<and> 4148 ptr \<noteq> 0\<rbrace> 4149 createNewCaps ty ptr (Suc n) us d 4150 \<lbrace>\<lambda>r s. pspace_no_overlap' 4151 (ptr + (1 + of_nat n << Types_H.getObjectSize ty us)) 4152 (Types_H.getObjectSize ty us) s\<rbrace>" 4153 apply (rule hoare_name_pre_state) 4154 apply (clarsimp simp: createNewCaps_def) 4155 apply (subgoal_tac "pspace_no_overlap' (ptr + (1 + of_nat n << (Types_H.getObjectSize ty us))) 4156 (Types_H.getObjectSize ty us) s") 4157 prefer 2 4158 apply (rule pspace_no_overlap'_le[where sz = sz]) 4159 apply (rule pspace_no_overlap'_tail) 4160 apply simp+ 4161 apply (simp add:range_cover_def) 4162 apply (simp add:range_cover.sz(1)[where 'a=32, folded word_bits_def]) 4163 apply (rule_tac Q = "\<lambda>r. pspace_no_overlap' (ptr + (1 + of_nat n << Types_H.getObjectSize ty us)) 4164 (Types_H.getObjectSize ty us) and 4165 pspace_aligned' and pspace_distinct'" in hoare_strengthen_post) 4166 apply (case_tac ty) 4167 apply (simp_all add: apiGetObjectSize_def 4168 ARM_H.toAPIType_def tcbBlockSizeBits_def 4169 ARM_H.getObjectSize_def objBits_simps epSizeBits_def ntfnSizeBits_def 4170 cteSizeBits_def pageBits_def ptBits_def archObjSize_def pdBits_def 4171 createObjects_def) 4172 apply (rule hoare_pre) 4173 apply wpc 4174 apply (clarsimp simp: apiGetObjectSize_def curDomain_def 4175 ARM_H.toAPIType_def tcbBlockSizeBits_def 4176 ARM_H.getObjectSize_def objBits_simps epSizeBits_def ntfnSizeBits_def 4177 cteSizeBits_def pageBits_def ptBits_def archObjSize_def pdBits_def 4178 createObjects_def Arch_createNewCaps_def 4179 split: apiobject_type.splits 4180 | wp doMachineOp_psp_no_overlap createObjects'_pspace_no_overlap[where sz = sz] 4181 createObjects'_psp_aligned[where sz = sz] createObjects'_psp_distinct[where sz = sz] 4182 copyGlobalMappings_pspace_aligned' mapM_x_wp_inv 4183 copyGlobalMappings_pspace_no_overlap'[where sz = sz] | assumption)+ 4184 apply (intro conjI range_cover_le[where n = "Suc n"] | simp)+ 4185 apply ((simp add:objBits_simps pageBits_def range_cover_def word_bits_def)+)[5] 4186 by ((clarsimp simp: apiGetObjectSize_def 4187 ARM_H.toAPIType_def tcbBlockSizeBits_def 4188 ARM_H.getObjectSize_def objBits_simps epSizeBits_def ntfnSizeBits_def 4189 cteSizeBits_def pageBits_def ptBits_def archObjSize_def pdBits_def 4190 createObjects_def Arch_createNewCaps_def 4191 pteBits_def pdeBits_def 4192 unless_def 4193 split: apiobject_type.splits 4194 | wp doMachineOp_psp_no_overlap createObjects'_pspace_no_overlap 4195 createObjects'_psp_aligned createObjects'_psp_distinct 4196 copyGlobalMappings_pspace_aligned' mapM_x_wp_inv 4197 copyGlobalMappings_pspace_no_overlap' 4198 | assumption | clarsimp simp: word_bits_def 4199 | intro conjI range_cover_le[where n = "Suc n"] range_cover.aligned)+)[6] 4200 4201lemma objSize_eq_capBits: 4202 "Types_H.getObjectSize ty us = APIType_capBits ty us" 4203 apply (case_tac ty) 4204 apply (clarsimp simp:ARM_H.getObjectSize_def objBits_simps 4205 APIType_capBits_def apiGetObjectSize_def ptBits_def 4206 tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def cteSizeBits_def 4207 pageBits_def pdBits_def pteBits_def pdeBits_def 4208 split : apiobject_type.splits)+ 4209 done 4210 4211lemma createNewCaps_ret_len: 4212 "\<lbrace>K (n < 2 ^ word_bits \<and> n \<noteq> 0)\<rbrace> 4213 createNewCaps ty ptr n us d 4214 \<lbrace>\<lambda>rv s. n = length rv\<rbrace>" 4215 including no_pre 4216 apply (rule hoare_name_pre_state) 4217 apply clarsimp 4218 apply (case_tac ty) 4219 apply (simp_all add:createNewCaps_def ARM_H.toAPIType_def) 4220 apply (rule hoare_pre) 4221 apply wpc 4222 apply ((wp+)|simp add:Arch_createNewCaps_def ARM_H.toAPIType_def 4223 unat_of_nat_minus_1 4224 [where 'a=32, folded word_bits_def] | 4225 erule hoare_strengthen_post[OF createObjects_ret],clarsimp+ | intro conjI impI)+ 4226 apply (rule hoare_pre, 4227 ((wp+) 4228 | simp add: Arch_createNewCaps_def toAPIType_def 4229 ARM_H.toAPIType_def unat_of_nat_minus_1 4230 | erule hoare_strengthen_post[OF createObjects_ret],clarsimp+ 4231 | intro conjI impI)+)+ 4232 done 4233 4234lemma no_overlap_check: 4235 "\<lbrakk>range_cover ptr sz bits n; pspace_no_overlap' ptr sz s; 4236 pspace_aligned' s;n\<noteq> 0\<rbrakk> 4237 \<Longrightarrow> case_option (return ()) 4238 (case_prod (\<lambda>x xa. haskell_assert (x < fromPPtr ptr) [])) 4239 (fst (lookupAround2 (ptr + of_nat (shiftL n bits - Suc 0)) 4240 (ksPSpace s))) s = 4241 return () s" 4242 apply (clarsimp split:option.splits simp:assert_def lookupAround2_char1 not_less) 4243 apply (rule ccontr) 4244 apply (frule(1) pspace_no_overlapD') 4245 apply (erule_tac x = a in in_empty_interE) 4246 apply clarsimp 4247 apply (drule(1) pspace_alignedD') 4248 apply (erule is_aligned_no_overflow) 4249 apply clarsimp 4250 apply (erule order_trans) 4251 apply (frule range_cover_cell_subset[where x = "of_nat n - 1"]) 4252 apply (rule gt0_iff_gem1[THEN iffD1]) 4253 apply (simp add:word_gt_0) 4254 apply (rule range_cover_not_zero) 4255 apply simp 4256 apply assumption 4257 apply (clarsimp simp:shiftL_nat field_simps) 4258 apply (erule impE) 4259 apply (frule range_cover_subset_not_empty[rotated,where x = "of_nat n - 1"]) 4260 apply (rule gt0_iff_gem1[THEN iffD1]) 4261 apply (simp add:word_gt_0) 4262 apply (rule range_cover_not_zero) 4263 apply simp 4264 apply assumption 4265 apply (clarsimp simp:field_simps) 4266 apply simp 4267 done 4268 4269lemma new_caps_addrs_append: 4270 "\<lbrakk>range_cover ptr sz (objBitsKO va + us) (Suc n)\<rbrakk> \<Longrightarrow> 4271 new_cap_addrs (unat (of_nat n + (1::word32) << us)) ptr val = 4272 new_cap_addrs (unat (((of_nat n)::word32) << us)) ptr val @ 4273 new_cap_addrs (unat ((2::word32) ^ us)) 4274 ((((of_nat n)::word32) << objBitsKO val + us) + ptr) val" 4275 apply (subst add.commute) 4276 apply (clarsimp simp:new_cap_addrs_def) 4277 apply (subst upt_add_eq_append'[where j="unat (((of_nat n)::word32) << us)"]) 4278 prefer 3 4279 apply simp 4280 apply (subst upt_lhs_sub_map) 4281 apply (simp add:Fun.comp_def field_simps) 4282 apply (subst unat_sub[symmetric]) 4283 apply (simp add:shiftl_t2n) 4284 apply (subst mult.commute) 4285 apply (subst mult.commute[where a = "2 ^ us"])+ 4286 apply (rule word_mult_le_mono1) 4287 apply (simp add:word_le_nat_alt) 4288 apply (subst of_nat_Suc[symmetric]) 4289 apply (frule range_cover.unat_of_nat_n) 4290 apply (drule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) 4291 apply simp 4292 apply simp 4293 apply (simp add: p2_gt_0) 4294 apply (simp add:range_cover_def word_bits_def) 4295 apply (subst word_bits_def[symmetric]) 4296 apply (subst of_nat_Suc[symmetric]) 4297 apply (subst range_cover.unat_of_nat_n) 4298 apply simp 4299 apply (subst unat_power_lower) 4300 apply (simp add:range_cover_def) 4301 apply (frule range_cover.range_cover_n_le(2)) 4302 apply (subst mult.commute) 4303 apply (rule le_less_trans[OF nat_le_power_trans[where m = sz]]) 4304 apply (erule le_trans) 4305 apply simp 4306 apply (simp add:range_cover_def) 4307 apply (simp add:range_cover_def[where 'a=32, folded word_bits_def]) 4308 apply (clarsimp simp: power_add [symmetric] shiftl_t2n field_simps) 4309 apply simp 4310 apply (frule range_cover_le[where n = n]) 4311 apply simp 4312 apply (drule range_cover_rel[where sbit'= "objBitsKO va"]) 4313 apply simp+ 4314 apply (drule range_cover_rel[where sbit'= "objBitsKO va"]) 4315 apply simp+ 4316 apply (drule range_cover.unat_of_nat_n)+ 4317 apply (simp add:shiftl_t2n) 4318 apply (clarsimp simp: power_add[symmetric] shiftl_t2n field_simps ) 4319 done 4320 4321lemma modify_comp: 4322 "modify (ksPSpace_update (\<lambda>a. f (g a))) = 4323 (do modify (ksPSpace_update (\<lambda>a. (g a))); 4324 modify (ksPSpace_update (\<lambda>a. f a)) 4325 od)" 4326 by (clarsimp simp:simpler_modify_def bind_def Fun.comp_def) 4327 4328lemma modify_objs_commute: 4329 "monad_commute (K ((set lst1) \<inter> (set lst2) = {})) 4330 (modify (ksPSpace_update (foldr (\<lambda>addr map. map(addr \<mapsto> val)) lst1))) 4331 (modify (ksPSpace_update (foldr (\<lambda>addr map. map(addr \<mapsto> val)) lst2)))" 4332 apply (clarsimp simp:monad_commute_def simpler_modify_def bind_def return_def) 4333 apply (case_tac s,simp) 4334 apply (rule ext) 4335 apply (clarsimp simp:foldr_upd_app_if) 4336 done 4337 4338lemma new_cap_addrs_disjoint: 4339 "\<lbrakk>range_cover ptr sz (objBitsKO val + us) (Suc (Suc n))\<rbrakk> 4340 \<Longrightarrow> set (new_cap_addrs (2^us) 4341 (((1::word32) + of_nat n << objBitsKO val + us) + ptr) val) \<inter> 4342 set (new_cap_addrs (unat ((1::word32) + of_nat n << us)) ptr val) = {}" 4343 apply (frule range_cover.unat_of_nat_n_shift[where gbits = us,symmetric]) 4344 apply simp 4345 apply (frule range_cover_rel[where sbit' = "objBitsKO val"]) 4346 apply (simp add:field_simps)+ 4347 apply (frule new_cap_addrs_distinct) 4348 apply (subst (asm) add.commute[where b = 2])+ 4349 apply (subst (asm) new_caps_addrs_append[where n = "Suc n",simplified]) 4350 apply (simp add:field_simps) 4351 apply (clarsimp simp:field_simps Int_ac range_cover_def) 4352 done 4353 4354lemma pspace_no_overlap'_modify: 4355 "\<lbrace>K (range_cover ptr sz (objBitsKO val + us) (Suc (Suc n)) \<and> ptr \<noteq> 0) and 4356 pspace_no_overlap' (((1::word32) + of_nat n << objBitsKO val + us) + ptr) 4357 (objBitsKO val + us)\<rbrace> 4358 modify (ksPSpace_update 4359 (foldr (\<lambda>addr map. map(addr \<mapsto> val)) 4360 (new_cap_addrs (unat ((1::word32) + of_nat n << us)) ptr val))) 4361 \<lbrace>\<lambda>r. pspace_no_overlap' 4362 (((1::word32) + of_nat n << objBitsKO val + us) + ptr) 4363 (objBitsKO val + us)\<rbrace>" 4364 proof - 4365 note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff 4366 Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex 4367 show ?thesis 4368 apply (clarsimp simp:simpler_modify_def valid_def pspace_no_overlap'_def) 4369 apply (frule(1) range_cover_tail_mask) 4370 apply (simp add:field_simps) 4371 apply (drule_tac x = x in spec) 4372 apply (clarsimp simp:foldr_upd_app_if split:if_splits) 4373 apply (frule obj_range'_subset_strong[rotated]) 4374 apply (drule range_cover_le[where n = "Suc n"]) 4375 apply simp 4376 apply (rule range_cover_rel,assumption) 4377 apply simp 4378 apply clarsimp 4379 apply (frule range_cover.unat_of_nat_n_shift[where gbits = us,symmetric]) 4380 apply simp+ 4381 apply (simp add:field_simps) 4382 apply (simp add:obj_range'_def) 4383 apply (erule disjoint_subset) 4384 apply (frule(1) range_cover_ptr_le) 4385 apply (subgoal_tac 4386 "\<not> ptr + (1 + of_nat n << us + objBitsKO val) \<le> ptr + (1 + of_nat n << us) * 2 ^ objBitsKO val - 1") 4387 apply (clarsimp simp:blah field_simps) 4388 apply (clarsimp simp: not_le) 4389 apply (rule minus_one_helper) 4390 apply (clarsimp simp: power_add[symmetric] shiftl_t2n field_simps objSize_eq_capBits ) 4391 apply (rule neq_0_no_wrap) 4392 apply (clarsimp simp: power_add[symmetric] shiftl_t2n field_simps objSize_eq_capBits ) 4393 apply simp 4394 done 4395qed 4396 4397lemma placeNewObject_copyGlobalMapping_commute: 4398 "monad_commute 4399 (valid_arch_state' and pspace_distinct' and pspace_aligned' and 4400 page_directory_at' r and 4401 pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and 4402 K (objBitsKO (injectKOS val) + us < word_bits \<and> 4403 is_aligned ptr (objBitsKO (injectKOS val) + us)) ) 4404 (placeNewObject ptr val us) (copyGlobalMappings r)" 4405 apply (clarsimp simp:copyGlobalMappings_def) 4406 apply (rule monad_commute_guard_imp) 4407 apply (rule monad_commute_split) 4408 apply (rule mapM_x_commute[where f = id]) 4409 apply (rule monad_commute_split[OF _ getPDE_placeNewObject_commute]) 4410 apply (rule storePDE_placeNewObject_commute) 4411 apply wp 4412 apply (wp pspace_no_overlap'_lift | clarsimp)+ 4413 apply (rule placeNewObject_gets_globalPD_commute) 4414 apply wp 4415 apply clarsimp 4416 apply (clarsimp simp: valid_arch_state'_def page_directory_at'_def 4417 objBits_simps archObjSize_def pdBits_def pageBits_def) 4418 apply (drule le_m1_iff_lt[where x = "(0x1000::word32)",simplified,THEN iffD1]) 4419 apply (clarsimp simp: pdeBits_def) 4420 done 4421 4422lemma createObjects_Cons: 4423 "\<lbrakk>range_cover ptr sz (objBitsKO val + us) (Suc (Suc n)); 4424 pspace_distinct' s;pspace_aligned' s; 4425 pspace_no_overlap' ptr sz s;pspace_aligned' s; ptr \<noteq> 0\<rbrakk> 4426 \<Longrightarrow> createObjects' ptr (Suc (Suc n)) val us s = 4427 (do createObjects' ptr (Suc n) val us; 4428 createObjects' (((1 + of_nat n) << (objBitsKO val + us)) + ptr) 4429 (Suc 0) val us 4430 od) s" 4431 apply (clarsimp simp:createObjects'_def split_def bind_assoc) 4432 apply (subgoal_tac "is_aligned (((1::word32) + of_nat n << objBitsKO val + us) + ptr) (objBitsKO val + us)") 4433 prefer 2 4434 apply (clarsimp simp:field_simps) 4435 apply (rule aligned_add_aligned[OF range_cover.aligned],assumption) 4436 apply (rule is_aligned_shiftl_self) 4437 apply (simp add:range_cover_def) 4438 apply (rule monad_eq_split[where Q ="\<lambda>x s'. s' = s \<and> ptr && mask (objBitsKO val + us) = 0"]) 4439 apply (clarsimp simp:is_aligned_mask[symmetric]) 4440 apply (subst new_cap_addrs_fold') 4441 apply (drule range_cover_not_zero_shift[rotated,where gbits = us]) 4442 apply simp+ 4443 apply (simp add:word_le_sub1) 4444 apply (subst new_cap_addrs_fold') 4445 apply (drule range_cover_le[where n = "Suc n"]) 4446 apply simp 4447 apply (drule range_cover_not_zero_shift[rotated,where gbits = us]) 4448 apply simp+ 4449 apply (simp add:word_le_sub1) 4450 apply (subst new_cap_addrs_fold') 4451 apply (rule word_1_le_power) 4452 apply (simp add:range_cover_def) 4453 apply (rule monad_eq_split[where Q ="\<lambda>r s'. r = ksPSpace s \<and> s' = s"]) 4454 apply (rule monad_eq_split2[where Q = "\<lambda>r s'. s' = s"]) 4455 apply (simp add:field_simps) 4456 apply (subst no_overlap_check) 4457 apply (erule range_cover_le) 4458 apply simp+ 4459 apply (subst no_overlap_check) 4460 apply (erule range_cover_le) 4461 apply simp+ 4462 apply clarsimp 4463 apply (simp add:new_caps_addrs_append[where n = "Suc n",simplified]) 4464 apply (subst modify_specify2[where g = return,simplified]) 4465 apply (subst modify_specify2) 4466 apply (subst modify_specify) 4467 apply (simp add:modify_comp) 4468 apply (subst monad_commute_simple[OF modify_objs_commute,where g= "\<lambda>x y. return ()",simplified]) 4469 apply (frule range_cover.sz(1)) 4470 apply (frule range_cover.sz(2)) 4471 apply clarsimp 4472 apply (erule new_cap_addrs_disjoint) 4473 apply (rule monad_eq_split2[where Q = 4474 "\<lambda>r. pspace_no_overlap' (((1::word32) + of_nat n << objBitsKO val + us) + ptr) 4475 (objBitsKO val + us) and pspace_aligned'"]) 4476 apply (simp add:shiftl_t2n field_simps) 4477 apply (clarsimp simp:unless_True) 4478 apply (rule sym) 4479 apply (clarsimp simp:gets_def get_def) 4480 apply (subst bind_def,simp) 4481 apply (subst monad_eq) 4482 apply (rule no_overlap_check) 4483 apply (erule range_cover_full) 4484 apply (simp add:range_cover_def word_bits_def) 4485 apply (simp add:field_simps) 4486 apply simp+ 4487 apply (clarsimp simp:simpler_modify_def) 4488 apply wp 4489 apply (clarsimp simp del:fun_upd_apply) 4490 apply (rule conjI) 4491 apply (rule use_valid[OF _ pspace_no_overlap'_modify[where sz = sz]]) 4492 apply (simp add:simpler_modify_def) 4493 apply (clarsimp simp:field_simps) 4494 apply (rule pspace_no_overlap'_le) 4495 apply (erule pspace_no_overlap'_tail) 4496 apply simp+ 4497 apply (simp add:range_cover_def) 4498 apply (erule range_cover.sz(1)[where 'a=32, folded word_bits_def]) 4499 apply (subst data_map_insert_def[symmetric]) 4500 apply (drule(2) retype_aligned_distinct'(2)) 4501 prefer 2 4502 apply (simp cong: kernel_state.fold_congs) 4503 apply (drule range_cover_le[where n = "Suc n"]) 4504 apply simp 4505 apply (rule range_cover_le[OF range_cover_rel,OF _ _ _ le_refl]) 4506 apply simp+ 4507 apply (drule range_cover.unat_of_nat_n_shift[where gbits = us]) 4508 apply simp 4509 apply simp 4510 apply (wp haskell_assert_wp | wpc)+ 4511 apply simp 4512 apply (wp hoare_unless_wp |clarsimp)+ 4513 apply (drule range_cover.aligned) 4514 apply (simp add:is_aligned_mask) 4515 done 4516 4517lemma placeNewObject_doMachineOp_commute: 4518 "monad_commute 4519 (K (us < word_bits \<and> is_aligned ptr (objBitsKO (injectKOS ty) + us) \<and> 4520 objBitsKO (injectKOS ty) + us < word_bits) and 4521 pspace_aligned' and pspace_distinct' and 4522 pspace_no_overlap' ptr ((objBitsKO (injectKOS ty)) + us)) 4523 (placeNewObject ptr ty us) (doMachineOp f)" 4524 apply (rule commute_name_pre_state) 4525 apply (rule monad_commute_guard_imp) 4526 apply (rule commute_rewrite [where Q = 4527 "pspace_no_overlap' ptr ((objBitsKO (injectKOS ty)) + us) and pspace_aligned'"]) 4528 apply (rule simpler_placeNewObject_def; simp) 4529 apply (wp doMachineOp_psp_no_overlap) 4530 apply (simp add: modify_specify modify_mapM_x) 4531 apply (rule commute_commute) 4532 apply (rule mapM_x_commute[where f = id]) 4533 apply (rule doMachineOp_upd_heap_commute) 4534 apply wp 4535 apply clarsimp 4536 apply (rule new_cap_addrs_distinct[OF range_cover_rel]) 4537 apply (erule(1) range_cover_full) 4538 apply simp 4539 apply simp 4540 done 4541 4542lemma doMachineOp_ksArchState_commute: 4543 "monad_commute \<top> (doMachineOp f) (gets (g \<circ> ksArchState))" 4544 apply (clarsimp simp:monad_commute_def gets_def return_def get_def bind_def) 4545 apply (intro conjI set_eqI iffI) 4546 apply (clarsimp simp: doMachineOp_def select_f_def gets_def get_def bind_def 4547 return_def simpler_modify_def) 4548 apply (erule bexI[rotated]) 4549 apply clarsimp 4550 apply (clarsimp simp: doMachineOp_def select_f_def gets_def get_def bind_def return_def 4551 simpler_modify_def) 4552 apply (erule bexI[rotated]) 4553 apply clarsimp+ 4554 done 4555 4556lemma doMachineOp_copyGlobalMapping_commute: 4557 "monad_commute (valid_arch_state' and page_directory_at' r) 4558 (doMachineOp f) (copyGlobalMappings r)" 4559 apply (clarsimp simp:copyGlobalMappings_def) 4560 apply (rule monad_commute_guard_imp) 4561 apply (rule monad_commute_split) 4562 apply (rule mapM_x_commute[where f = id]) 4563 apply (rule monad_commute_split[OF _ getPDE_doMachineOp_commute]) 4564 apply (rule doMachineOp_storePDE_commute) 4565 apply wp+ 4566 apply clarsimp 4567 apply (rule doMachineOp_ksArchState_commute) 4568 apply wp 4569 apply clarsimp 4570 apply (clarsimp simp: valid_arch_state'_def page_directory_at'_def objBits_simps archObjSize_def 4571 pdBits_def pageBits_def) 4572 apply (drule le_m1_iff_lt[where x = "(0x1000::word32)",simplified,THEN iffD1]) 4573 apply (clarsimp simp: pdeBits_def) 4574 done 4575 4576lemma placeNewObject_old_pd_at': 4577 "\<lbrace>page_directory_at' ptr and pspace_aligned' and pspace_distinct' and 4578 pspace_no_overlap' ptr' (objBitsKO (injectKOS val) + sz) and 4579 K (is_aligned ptr' (objBitsKO (injectKOS val) + sz) \<and> 4580 objBitsKO (injectKOS val) + sz < word_bits)\<rbrace> 4581 placeNewObject ptr' val sz 4582 \<lbrace>\<lambda>rv. page_directory_at' ptr\<rbrace>" 4583 apply (clarsimp simp:placeNewObject_def2 page_directory_at'_def) 4584 apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift) 4585 apply (wp createObjects'_typ_at) 4586 apply clarsimp 4587 apply (intro conjI) 4588 apply (rule range_cover_full; simp) 4589 apply simp+ 4590 done 4591 4592lemma createObjects'_page_directory_at': 4593 "\<lbrace>K (range_cover ptr sz 14 (Suc n)) and 4594 pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz\<rbrace> 4595 createObjects' ptr (Suc n) (KOArch (KOPDE makeObject)) 12 4596 \<lbrace>\<lambda>rv s. (\<forall>x\<le>of_nat n. page_directory_at' (ptr + (x << 14)) s)\<rbrace>" 4597 apply (rule createObjects'_wp_subst) 4598 apply simp 4599 apply (clarsimp simp:valid_def) 4600 apply (frule use_valid[OF _ createObjects_ko_at_strg[where 'b = pde]]) 4601 apply (simp add:objBits_simps archObjSize_def pdeBits_def) 4602 apply simp 4603 apply (simp add:projectKO_def projectKO_opt_pde return_def) 4604 apply simp 4605 apply (clarsimp simp:page_directory_at'_def pdBits_def pageBits_def pdeBits_def) 4606 apply (intro conjI) 4607 apply (rule aligned_add_aligned[OF range_cover.aligned],simp) 4608 apply (rule is_aligned_shiftl_self) 4609 apply (simp add:range_cover_def) 4610 apply (drule_tac x = "ptr + (x << 14)" in bspec) 4611 apply (simp add:createObjects_def bind_def return_def) 4612 apply (clarsimp simp:objBits_simps archObjSize_def pdeBits_def) 4613 apply (clarsimp simp:typ_at'_def) 4614 apply (drule_tac x = y in spec) 4615 apply (simp add:obj_at'_real_def objBits_simps archObjSize_def pdeBits_def) 4616 apply (erule ko_wp_at'_weakenE) 4617 apply (simp add: projectKO_opt_pde) 4618 apply (case_tac ko; simp) 4619 apply (rename_tac arch_kernel_object) 4620 apply (case_tac arch_kernel_object; simp) 4621 done 4622 4623lemma gsCNodes_upd_createObjects'_comm: 4624 "do _ \<leftarrow> modify (gsCNodes_update f); 4625 x \<leftarrow> createObjects' ptr n obj us; 4626 m x 4627 od = 4628 do x \<leftarrow> createObjects' ptr n obj us; 4629 _ \<leftarrow> modify (gsCNodes_update f); 4630 m x 4631 od" 4632 apply (rule ext) 4633 apply (case_tac x) 4634 by (auto simp: createObjects'_def split_def bind_assoc return_def unless_def 4635 when_def simpler_gets_def alignError_def fail_def assert_def 4636 simpler_modify_def bind_def 4637 split: option.splits) 4638 4639lemma gsUserPages_upd_createObjects'_comm: 4640 "do _ \<leftarrow> modify (gsUserPages_update f); 4641 x \<leftarrow> createObjects' ptr n obj us; 4642 m x 4643 od = 4644 do x \<leftarrow> createObjects' ptr n obj us; 4645 _ \<leftarrow> modify (gsUserPages_update f); 4646 m x 4647 od" 4648 apply (rule ext) 4649 apply (case_tac x) 4650 by (auto simp: createObjects'_def split_def bind_assoc return_def unless_def 4651 when_def simpler_gets_def alignError_def fail_def assert_def 4652 simpler_modify_def bind_def 4653 split: option.splits) 4654 4655(* FIXME: move *) 4656lemma ef_dmo': 4657 "empty_fail f \<Longrightarrow> empty_fail (doMachineOp f)" 4658 by (auto simp: empty_fail_def doMachineOp_def split_def select_f_def 4659 simpler_modify_def simpler_gets_def return_def bind_def image_def) 4660 4661(* FIXME: move *) 4662lemma dmo'_when_fail_comm: 4663 assumes "empty_fail f" 4664 shows "doMachineOp f >>= (\<lambda>x. when P fail >>= (\<lambda>_. m x)) = 4665 when P fail >>= (\<lambda>_. doMachineOp f >>= m)" 4666 apply (rule ext) 4667 apply (cut_tac ef_dmo'[OF assms]) 4668 apply (auto simp add: empty_fail_def when_def fail_def return_def 4669 bind_def split_def image_def, fastforce) 4670 done 4671 4672(* FIXME: move *) 4673lemma dmo'_gets_ksPSpace_comm: 4674 "doMachineOp f >>= (\<lambda>_. gets ksPSpace >>= m) = 4675 gets ksPSpace >>= (\<lambda>x. doMachineOp f >>= (\<lambda>_. m x))" 4676 apply (rule ext) 4677 apply (auto simp add: doMachineOp_def simpler_modify_def simpler_gets_def 4678 return_def select_f_def bind_def split_def image_def) 4679 apply (rule_tac x=aa in exI; drule prod_injects; clarsimp) 4680 apply (rule_tac x="snd (m (ksPSpace x) (x\<lparr>ksMachineState := bb\<rparr>))" in exI, clarsimp) 4681 apply (rule_tac x="{(ab, x\<lparr>ksMachineState := bb\<rparr>)}" in exI, simp) 4682 apply (rule bexI[rotated], assumption, simp) 4683 apply (rule_tac x="fst (m (ksPSpace x) (x\<lparr>ksMachineState := bb\<rparr>))" in exI, clarsimp) 4684 apply (rule_tac x="snd (m (ksPSpace x) (x\<lparr>ksMachineState := bb\<rparr>))" in exI, clarsimp) 4685 apply (rule_tac x="{(ab, x\<lparr>ksMachineState := bb\<rparr>)}" in exI, simp) 4686 apply (rule bexI[rotated], assumption, simp) 4687 apply (rule_tac x=a in exI, clarsimp) 4688 apply (rule_tac x="{(aa, x\<lparr>ksMachineState := b\<rparr>)}" in exI, simp) 4689 apply (rule bexI[rotated], assumption, simp) 4690 apply (rule_tac x=a in exI, clarsimp) 4691 apply (rule_tac x="{(aa, x\<lparr>ksMachineState := b\<rparr>)}" in exI, simp) 4692 apply (rule bexI[rotated], assumption, simp) 4693 done 4694 4695lemma dmo'_ksPSpace_update_comm': 4696 assumes "empty_fail f" 4697 shows "doMachineOp f >>= (\<lambda>x. modify (ksPSpace_update g) >>= (\<lambda>_. m x)) = 4698 modify (ksPSpace_update g) >>= (\<lambda>_. doMachineOp f >>= m)" 4699proof - 4700 have ksMachineState_ksPSpace_update: 4701 "\<forall>s. ksMachineState (ksPSpace_update g s) = ksMachineState s" 4702 by simp 4703 have updates_independent: 4704 "\<And>f. ksPSpace_update g \<circ> ksMachineState_update f = 4705 ksMachineState_update f \<circ> ksPSpace_update g" 4706 by (rule ext) simp 4707 from assms 4708 show ?thesis 4709 apply (simp add: doMachineOp_def split_def bind_assoc) 4710 apply (simp add: gets_modify_comm2[OF ksMachineState_ksPSpace_update]) 4711 apply (rule arg_cong_bind1) 4712 apply (simp add: empty_fail_def select_f_walk[OF empty_fail_modify] 4713 modify_modify_bind updates_independent) 4714 done 4715qed 4716 4717lemma dmo'_createObjects'_comm: 4718 assumes ef: "empty_fail f" 4719 shows "do _ \<leftarrow> doMachineOp f; x \<leftarrow> createObjects' ptr n obj us; m x od = 4720 do x \<leftarrow> createObjects' ptr n obj us; _ \<leftarrow> doMachineOp f; m x od" 4721 apply (simp add: createObjects'_def bind_assoc split_def unless_def 4722 alignError_def dmo'_when_fail_comm[OF ef] 4723 dmo'_gets_ksPSpace_comm 4724 dmo'_ksPSpace_update_comm'[OF ef, symmetric]) 4725 apply (rule arg_cong_bind1) 4726 apply (rule arg_cong_bind1) 4727 apply (rename_tac u w) 4728 apply (case_tac "fst (lookupAround2 (ptr + of_nat (shiftL n (objBitsKO obj + 4729 us) - Suc 0)) w)", clarsimp+) 4730 apply (simp add: assert_into_when dmo'_when_fail_comm[OF ef]) 4731 done 4732 4733lemma unless_dmo'_createObjects'_comm: 4734 assumes ef: "empty_fail f" 4735 shows "do _ \<leftarrow> unless d (doMachineOp f); x \<leftarrow> createObjects' ptr n obj us; m x od = 4736 do x \<leftarrow> createObjects' ptr n obj us; _ \<leftarrow> unless d (doMachineOp f); m x od" 4737 apply (case_tac d, simp) 4738 apply (simp only: unless_False) 4739 apply (rule dmo'_createObjects'_comm[OF ef]) 4740 done 4741 4742lemma dmo'_gsUserPages_upd_comm: 4743 assumes "empty_fail f" 4744 shows "doMachineOp f >>= (\<lambda>x. modify (gsUserPages_update g) >>= (\<lambda>_. m x)) = 4745 modify (gsUserPages_update g) >>= (\<lambda>_. doMachineOp f >>= m)" 4746proof - 4747 have ksMachineState_ksPSpace_update: 4748 "\<forall>s. ksMachineState (gsUserPages_update g s) = ksMachineState s" 4749 by simp 4750 have updates_independent: 4751 "\<And>f. gsUserPages_update g \<circ> ksMachineState_update f = 4752 ksMachineState_update f \<circ> gsUserPages_update g" 4753 by (rule ext) simp 4754 from assms 4755 show ?thesis 4756 apply (simp add: doMachineOp_def split_def bind_assoc) 4757 apply (simp add: gets_modify_comm2[OF ksMachineState_ksPSpace_update]) 4758 apply (rule arg_cong_bind1) 4759 apply (simp add: empty_fail_def select_f_walk[OF empty_fail_modify] 4760 modify_modify_bind updates_independent) 4761 done 4762qed 4763 4764lemma unless_dmo'_gsUserPages_upd_comm: 4765 assumes "empty_fail f" 4766 shows "(unless d (doMachineOp f) >>= (\<lambda>x. modify (gsUserPages_update g) >>= (\<lambda>_. m x))) = 4767 modify (gsUserPages_update g) >>= (\<lambda>_. unless d (doMachineOp f) >>= m)" 4768 apply (case_tac d, simp) 4769 apply (simp only: unless_False) 4770 apply (rule dmo'_gsUserPages_upd_comm[OF assms]) 4771 done 4772 4773lemma rewrite_step: 4774 assumes rewrite: "\<And>s. P s \<Longrightarrow> f s = f' s" 4775 shows "P s \<Longrightarrow> ( f >>= g ) s = (f' >>= g ) s" 4776 by (simp add:bind_def rewrite) 4777 4778lemma rewrite_through_step: 4779 assumes rewrite: "\<And>s r. P s \<Longrightarrow> f r s = f' r s" 4780 assumes hoare: "\<lbrace>Q\<rbrace> g \<lbrace>\<lambda>r. P\<rbrace>" 4781 shows "Q s \<Longrightarrow> 4782 (do x \<leftarrow> g; 4783 y \<leftarrow> f x; 4784 h x y od) s = 4785 (do x \<leftarrow> g; 4786 y \<leftarrow> f' x; 4787 h x y od) s" 4788 apply (rule monad_eq_split[where Q = "\<lambda>r. P"]) 4789 apply (simp add:bind_def rewrite) 4790 apply (rule hoare) 4791 apply simp 4792 done 4793 4794lemma threadSet_commute: 4795 assumes preserve: "\<lbrace>P and tcb_at' ptr \<rbrace> f \<lbrace>\<lambda>r. tcb_at' ptr\<rbrace>" 4796 assumes commute: "monad_commute P' f 4797 ( modify (ksPSpace_update 4798 (\<lambda>ps. ps(ptr \<mapsto> 4799 case ps ptr of Some (KOTCB tcb) \<Rightarrow> KOTCB (tcbDomain_update (\<lambda>_. r) tcb)))))" 4800 shows "monad_commute (tcb_at' ptr and P and P') f (threadSet (tcbDomain_update (\<lambda>_. r)) ptr)" 4801 apply (clarsimp simp add: monad_commute_def) 4802 apply (subst rewrite_through_step[where h = "\<lambda>x y. return (x,())",simplified bind_assoc]) 4803 apply (erule threadSet_det) 4804 apply (rule preserve) 4805 apply simp 4806 apply (subst rewrite_step[OF threadSet_det]) 4807 apply assumption 4808 apply simp 4809 using commute 4810 apply (simp add:monad_commute_def) 4811 done 4812 4813lemma createObjects_setDomain_commute: 4814 "monad_commute 4815 (\<lambda>s. range_cover ptr' (objBitsKO (KOTCB makeObject)) 4816 (objBitsKO (KOTCB makeObject) + 0) (Suc 0) \<and> 4817 pspace_aligned' s \<and> pspace_distinct' s \<and> 4818 pspace_no_overlap' ptr' (objBitsKO (KOTCB makeObject)) s \<and> 4819 tcb_at' ptr s \<and> is_aligned ptr' (objBitsKO (KOTCB makeObject))) 4820 (createObjects' ptr' (Suc 0) (KOTCB makeObject) 0) 4821 (threadSet (tcbDomain_update (\<lambda>_. r)) ptr)" 4822 apply (rule monad_commute_guard_imp) 4823 apply (rule threadSet_commute) 4824 apply (wp createObjects_orig_obj_at'[where sz = "(objBitsKO (KOTCB makeObject))"]) 4825 apply clarsimp 4826 apply assumption 4827 apply (simp add:placeNewObject_def2[where val = "makeObject::tcb",simplified,symmetric]) 4828 apply (rule placeNewObject_modify_commute) 4829 apply (clarsimp simp: objBits_simps' typ_at'_def word_bits_def 4830 obj_at'_def ko_wp_at'_def projectKO_eq projectKO_opt_tcb) 4831 apply (clarsimp split:Structures_H.kernel_object.splits) 4832 done 4833 4834 4835lemma createObjects_setDomains_commute: 4836 "monad_commute 4837 (\<lambda>s. \<forall>x\<in> set xs. tcb_at' (f x) s \<and> 4838 range_cover ptr (objBitsKO (KOTCB makeObject)) (objBitsKO (KOTCB makeObject)) (Suc 0) \<and> 4839 pspace_aligned' s \<and> 4840 pspace_distinct' s \<and> 4841 pspace_no_overlap' ptr (objBitsKO (KOTCB makeObject)) s \<and> 4842 is_aligned ptr (objBitsKO (KOTCB makeObject))) 4843 (mapM_x (threadSet (tcbDomain_update (\<lambda>_. r))) (map f xs)) 4844 (createObjects' ptr (Suc 0) (KOTCB makeObject) 0)" 4845 proof (induct xs) 4846 case Nil 4847 show ?case 4848 apply (simp add:monad_commute_def mapM_x_Nil) 4849 done 4850 next 4851 case (Cons x xs) 4852 show ?case 4853 apply (simp add:mapM_x_Cons) 4854 apply (rule monad_commute_guard_imp) 4855 apply (rule commute_commute[OF monad_commute_split]) 4856 apply (rule commute_commute[OF Cons.hyps]) 4857 apply (rule createObjects_setDomain_commute) 4858 apply (wp hoare_vcg_ball_lift) 4859 apply clarsimp 4860 done 4861 qed 4862 4863lemma createObjects'_pspace_no_overlap2: 4864 "\<lbrace>pspace_no_overlap' (ptr + (1 + of_nat n << gz)) sz 4865 and K (gz = (objBitsKO val) + us) 4866 and K (range_cover ptr sz gz (Suc (Suc n)) \<and> ptr \<noteq> 0)\<rbrace> 4867 createObjects' ptr (Suc n) val us 4868 \<lbrace>\<lambda>addrs s. pspace_no_overlap' (ptr + (1 + of_nat n << gz)) sz s\<rbrace>" 4869proof - 4870 note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff 4871 Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex 4872 show ?thesis 4873 apply (rule hoare_gen_asm)+ 4874 apply (clarsimp simp:createObjects'_def split_def new_cap_addrs_fold') 4875 apply (subst new_cap_addrs_fold') 4876 apply clarsimp 4877 apply (drule range_cover_le[where n = "Suc n"]) 4878 apply simp 4879 apply (drule_tac gbits = us in range_cover_not_zero_shift[rotated]) 4880 apply simp+ 4881 apply (simp add:word_le_sub1) 4882 apply (wp haskell_assert_wp hoare_unless_wp |wpc 4883 |simp add:alignError_def del:fun_upd_apply)+ 4884 apply (rule conjI) 4885 apply (rule impI) 4886 apply (subgoal_tac 4887 "pspace_no_overlap' (ptr + (1 + of_nat n << objBitsKO val + us)) 4888 sz 4889 (s\<lparr>ksPSpace := foldr (\<lambda>addr map. map(addr \<mapsto> val)) 4890 (new_cap_addrs (unat (1 + of_nat n << us)) ptr val) (ksPSpace s)\<rparr>)") 4891 apply (intro conjI impI allI) 4892 apply assumption+ 4893 apply (subst pspace_no_overlap'_def) 4894 apply (intro allI impI) 4895 apply (subst (asm) foldr_upd_app_if) 4896 apply (subst range_cover_tail_mask) 4897 apply simp+ 4898 apply (clarsimp split:if_splits) 4899 apply (drule obj_range'_subset_strong[rotated]) 4900 apply (rule range_cover_rel[OF range_cover_le[where n = "Suc n"]],assumption) 4901 apply simp+ 4902 apply (drule range_cover.unat_of_nat_n_shift 4903 [OF range_cover_le[where n = "Suc n"],where gbits = us]) 4904 apply simp+ 4905 apply (simp add:shiftl_t2n field_simps)+ 4906 apply (simp add:obj_range'_def) 4907 apply (erule disjoint_subset) 4908 apply (clarsimp simp:blah) 4909 apply (thin_tac "x \<le> y" for x y) 4910 apply (subst (asm) le_m1_iff_lt[THEN iffD1]) 4911 apply (drule_tac range_cover_no_0[rotated,where p = "Suc n"]) 4912 apply simp 4913 apply simp 4914 apply (simp add:field_simps) 4915 apply (simp add: power_add[symmetric]) 4916 apply (simp add: word_neq_0_conv) 4917 apply (simp add: power_add[symmetric] field_simps) 4918 apply (frule range_cover_subset[where p = "Suc n"]) 4919 apply simp 4920 apply simp 4921 apply (drule(1) pspace_no_overlapD') 4922 apply (subst (asm) range_cover_tail_mask) 4923 apply simp+ 4924 apply (simp add:word_le_sub1 shiftl_t2n field_simps) 4925 apply auto 4926 done 4927qed 4928 4929lemma new_cap_addrs_def2: 4930 "n < 2 ^ 32 4931 \<Longrightarrow> new_cap_addrs (Suc n) ptr obj 4932 = map (\<lambda>n. ptr + (n << objBitsKO obj)) [0.e.of_nat n]" 4933 by (simp add:new_cap_addrs_def upto_enum_word unat_of_nat 4934 Fun.comp_def) 4935 4936lemma createTCBs_tcb_at': 4937 "\<lbrace>\<lambda>s. pspace_aligned' s \<and> pspace_distinct' s \<and> 4938 pspace_no_overlap' ptr sz s \<and> 4939 range_cover ptr sz 4940 (objBitsKO (KOTCB makeObject)) (Suc n) \<rbrace> 4941 createObjects' ptr (Suc n) (KOTCB makeObject) 0 4942 \<lbrace>\<lambda>rv s. 4943 (\<forall>x\<in>set [0.e.of_nat n]. tcb_at' (ptr + x * 2^tcbBlockSizeBits) s)\<rbrace>" 4944 apply (simp add:createObjects'_def split_def alignError_def) 4945 apply (wp hoare_unless_wp |wpc)+ 4946 apply (subst data_map_insert_def[symmetric])+ 4947 apply clarsimp 4948 apply (subgoal_tac "(\<forall>x\<le>of_nat n. 4949 tcb_at' (ptr + x * 2^tcbBlockSizeBits) (s\<lparr>ksPSpace := 4950 foldr (\<lambda>addr. data_map_insert addr (KOTCB makeObject)) 4951 (new_cap_addrs (Suc n) ptr (KOTCB makeObject)) 4952 (ksPSpace s)\<rparr>))") 4953 apply (subst (asm) new_cap_addrs_def2) 4954 apply (drule range_cover.weak) 4955 apply simp 4956 apply simp 4957 apply (clarsimp simp: retype_obj_at_disj') 4958 apply (clarsimp simp: projectKO_opt_tcb) 4959 apply (clarsimp simp: new_cap_addrs_def image_def) 4960 apply (drule_tac x = "unat x" in bspec) 4961 apply (simp add:objBits_simps' shiftl_t2n) 4962 apply (rule unat_less_helper) 4963 apply (rule ccontr) 4964 apply simp 4965 apply (simp add: objBits_simps shiftl_t2n) 4966 done 4967 4968lemma createNewCaps_Cons: 4969 assumes cover:"range_cover ptr sz (Types_H.getObjectSize ty us) (Suc (Suc n))" 4970 and "valid_pspace' s" "valid_arch_state' s" 4971 and "pspace_no_overlap' ptr sz s" 4972 and "ptr \<noteq> 0" 4973 shows "createNewCaps ty ptr (Suc (Suc n)) us d s 4974 = (do x \<leftarrow> createNewCaps ty ptr (Suc n) us d; 4975 r \<leftarrow> RetypeDecls_H.createObject ty 4976 (((1 + of_nat n) << Types_H.getObjectSize ty us) + ptr) us d; 4977 return (x @ [r]) 4978 od) s" 4979proof - 4980 have append :"[0.e.(1::word32) + of_nat n] = [0.e.of_nat n] @ [1 + of_nat n]" 4981 using cover 4982 apply - 4983 apply (frule range_cover_not_zero[rotated]) 4984 apply simp 4985 apply (frule range_cover.unat_of_nat_n) 4986 apply (drule range_cover_le[where n = "Suc n"]) 4987 apply simp 4988 apply (frule range_cover_not_zero[rotated]) 4989 apply simp 4990 apply (frule range_cover.unat_of_nat_n) 4991 apply (subst upto_enum_red'[where X = "2 + of_nat n",simplified]) 4992 apply (simp add:field_simps word_le_sub1) 4993 apply clarsimp 4994 apply (subst upto_enum_red'[where X = "1 + of_nat n",simplified]) 4995 apply (simp add:field_simps word_le_sub1) 4996 apply simp 4997 done 4998 4999 have conj_impI: 5000 "\<And>A B C. \<lbrakk>C;C\<Longrightarrow>B\<rbrakk> \<Longrightarrow> B \<and> C" 5001 by simp 5002 5003 have suc_of_nat: "(1::word32) + of_nat n = of_nat (1 + n)" 5004 by simp 5005 5006 have gsUserPages_update[simp]: 5007 "\<And>f. (\<lambda>ks. ks \<lparr>gsUserPages := f (gsUserPages ks)\<rparr>) = gsUserPages_update f" 5008 by (rule ext) simp 5009 have gsCNodes_update[simp]: 5010 "\<And>f. (\<lambda>ks. ks \<lparr>gsCNodes := f (gsCNodes ks)\<rparr>) = gsCNodes_update f" 5011 by (rule ext) simp 5012 5013 have if_eq[simp]: 5014 "!!x a b pgsz. (if a = ptr + (1 + of_nat n << b) then Some pgsz 5015 else if a \<in> (\<lambda>n. ptr + (n << b)) ` {x. x \<le> of_nat n} 5016 then Just pgsz else x a) = 5017 (if a \<in> (\<lambda>n. ptr + (n << b)) ` {x. x \<le> 1 + of_nat n} 5018 then Just pgsz else x a)" 5019 apply (simp only: Just_def if3_fold2) 5020 apply (rule_tac x="x a" in fun_cong) 5021 apply (rule arg_cong2[where f=If, OF _ refl]) 5022 apply (subgoal_tac "{x. x \<le> (1::word32) + of_nat n} = 5023 {1 + of_nat n} \<union> {x. x \<le> of_nat n}") 5024 apply (simp add: add.commute) 5025 apply safe 5026 apply (clarsimp simp: word_le_less_eq[of _ "1 + of_nat n"]) 5027 apply (metis plus_one_helper add.commute) 5028 using cover 5029 apply - 5030 apply (drule range_cover_le[where n = "Suc n"], simp) 5031 apply (simp only: suc_of_nat word_le_nat_alt Suc_eq_plus1) 5032 apply (frule range_cover.unat_of_nat_n) 5033 apply simp 5034 apply (drule range_cover_le[where n=n], simp) 5035 apply (frule range_cover.unat_of_nat_n, simp) 5036 done 5037 5038 show ?thesis 5039 using assms 5040 apply (clarsimp simp:valid_pspace'_def) 5041 apply (frule range_cover.aligned) 5042 apply (frule(3) pspace_no_overlap'_tail) 5043 apply simp 5044 apply (drule_tac ptr = "ptr + x" for x 5045 in pspace_no_overlap'_le[where sz' = "Types_H.getObjectSize ty us"]) 5046 apply (simp add:range_cover_def word_bits_def) 5047 apply (erule range_cover.sz(1)[where 'a=32, folded word_bits_def]) 5048 apply (simp add: createNewCaps_def) 5049 apply (case_tac ty) 5050 apply (simp add: ARM_H.toAPIType_def 5051 Arch_createNewCaps_def) 5052 apply (rename_tac apiobject_type) 5053 apply (case_tac apiobject_type) 5054 apply (simp_all add: bind_assoc ARM_H.toAPIType_def 5055 ) 5056 \<comment> \<open>Untyped\<close> 5057 apply (simp add: 5058 bind_assoc ARM_H.getObjectSize_def 5059 mapM_def sequence_def Retype_H.createObject_def 5060 ARM_H.toAPIType_def 5061 createObjects_def ARM_H.createObject_def 5062 Arch_createNewCaps_def comp_def 5063 apiGetObjectSize_def shiftl_t2n field_simps 5064 shiftL_nat mapM_x_def sequence_x_def append 5065 fromIntegral_def integral_inv[unfolded Fun.comp_def]) 5066 \<comment> \<open>TCB, EP, NTFN\<close> 5067 apply (simp add: bind_assoc 5068 ARM_H.getObjectSize_def 5069 sequence_def Retype_H.createObject_def 5070 ARM_H.toAPIType_def 5071 createObjects_def ARM_H.createObject_def 5072 Arch_createNewCaps_def comp_def 5073 apiGetObjectSize_def shiftl_t2n field_simps 5074 shiftL_nat append mapM_x_append2 5075 fromIntegral_def integral_inv[unfolded Fun.comp_def])+ 5076 apply (subst monad_eq) 5077 apply (rule createObjects_Cons) 5078 apply (simp add: field_simps shiftl_t2n bind_assoc pageBits_def 5079 objBits_simps placeNewObject_def2)+ 5080 apply (rule_tac Q = "\<lambda>r s. pspace_aligned' s \<and> 5081 pspace_distinct' s \<and> 5082 pspace_no_overlap' (ptr + (2^tcbBlockSizeBits + of_nat n * 2^tcbBlockSizeBits)) (objBitsKO (KOTCB makeObject)) s \<and> 5083 range_cover (ptr + 2^tcbBlockSizeBits) sz 5084 (objBitsKO (KOTCB makeObject)) (Suc n) 5085 \<and> (\<forall>x\<in>set [0.e.of_nat n]. tcb_at' (ptr + x * 2^tcbBlockSizeBits) s)" 5086 in monad_eq_split2) 5087 apply simp 5088 apply (subst monad_commute_simple[symmetric]) 5089 apply (rule commute_commute[OF curDomain_commute]) 5090 apply (wpsimp+)[2] 5091 apply (rule_tac Q = "\<lambda>r s. r = (ksCurDomain s) \<and> 5092 pspace_aligned' s \<and> 5093 pspace_distinct' s \<and> 5094 pspace_no_overlap' (ptr + (2^tcbBlockSizeBits + of_nat n * 2^tcbBlockSizeBits)) (objBitsKO (KOTCB makeObject)) s \<and> 5095 range_cover (ptr + 2^tcbBlockSizeBits) sz 5096 (objBitsKO (KOTCB makeObject)) (Suc n) 5097 \<and> (\<forall>x\<in>set [0.e.of_nat n]. tcb_at' (ptr + x * 2^tcbBlockSizeBits) s) 5098 " in monad_eq_split) 5099 apply (subst monad_commute_simple[symmetric]) 5100 apply (rule createObjects_setDomains_commute) 5101 apply (clarsimp simp:objBits_simps) 5102 apply (rule conj_impI) 5103 apply (erule aligned_add_aligned) 5104 apply (rule aligned_add_aligned[where n = tcbBlockSizeBits]) 5105 apply (simp add:is_aligned_def objBits_defs) 5106 apply (cut_tac is_aligned_shift[where m = tcbBlockSizeBits and k = "of_nat n", 5107 unfolded shiftl_t2n,simplified]) 5108 apply (simp add:field_simps)+ 5109 apply (erule range_cover_full) 5110 apply (simp add: word_bits_conv objBits_defs) 5111 apply (rule_tac Q = "\<lambda>x s. (ksCurDomain s) = ra" in monad_eq_split2) 5112 apply simp 5113 apply (rule_tac Q = "\<lambda>x s. (ksCurDomain s) = ra" in monad_eq_split) 5114 apply (subst rewrite_step[where f = curDomain and 5115 P ="\<lambda>s. ksCurDomain s = ra" and f' = "return ra"]) 5116 apply (simp add:curDomain_def bind_def gets_def get_def) 5117 apply simp 5118 apply (simp add:mapM_x_singleton) 5119 apply wp 5120 apply simp 5121 apply (wp mapM_x_wp') 5122 apply simp 5123 apply (simp add:curDomain_def,wp) 5124 apply simp 5125 apply (wp createObjects'_psp_aligned[where sz = sz] 5126 createObjects'_psp_distinct[where sz = sz]) 5127 apply (rule hoare_vcg_conj_lift) 5128 apply (rule hoare_post_imp[OF _ createObjects'_pspace_no_overlap 5129 [unfolded shiftl_t2n,where gz = tcbBlockSizeBits and sz = sz,simplified]]) 5130 apply (simp add:objBits_simps field_simps) 5131 apply (simp add: objBits_simps) 5132 apply (wp createTCBs_tcb_at') 5133 apply (clarsimp simp:objBits_simps word_bits_def field_simps) 5134 apply (frule range_cover_le[where n = "Suc n"],simp+) 5135 apply (drule range_cover_offset[where p = 1,rotated]) 5136 apply simp 5137 apply (simp add: objBits_defs) 5138 apply (((simp add: 5139 ARM_H.getObjectSize_def 5140 mapM_def sequence_def Retype_H.createObject_def 5141 ARM_H.toAPIType_def 5142 createObjects_def ARM_H.createObject_def 5143 Arch_createNewCaps_def comp_def 5144 apiGetObjectSize_def shiftl_t2n field_simps 5145 shiftL_nat mapM_x_def sequence_x_def append 5146 fromIntegral_def integral_inv[unfolded Fun.comp_def])+ 5147 , subst monad_eq, rule createObjects_Cons 5148 , (simp add: field_simps shiftl_t2n bind_assoc pageBits_def 5149 objBits_simps' placeNewObject_def2)+)+)[2] 5150 \<comment> \<open>CNode\<close> 5151 apply (simp add: cteSizeBits_def pageBits_def tcbBlockSizeBits_def 5152 epSizeBits_def ntfnSizeBits_def pdBits_def bind_assoc 5153 ARM_H.getObjectSize_def 5154 mapM_def sequence_def Retype_H.createObject_def 5155 ARM_H.toAPIType_def 5156 createObjects_def ARM_H.createObject_def 5157 Arch_createNewCaps_def comp_def 5158 apiGetObjectSize_def shiftl_t2n field_simps 5159 shiftL_nat mapM_x_def sequence_x_def append 5160 fromIntegral_def integral_inv[unfolded Fun.comp_def])+ 5161 apply (subst monad_eq, rule createObjects_Cons) 5162 apply (simp add: field_simps shiftl_t2n bind_assoc pageBits_def 5163 objBits_simps' placeNewObject_def2)+ 5164 apply (subst gsCNodes_update gsCNodes_upd_createObjects'_comm)+ 5165 apply (simp add: modify_modify_bind) 5166 apply (rule fun_cong[where x=s]) 5167 apply (rule arg_cong_bind[OF refl ext])+ 5168 apply (rule arg_cong_bind[OF _ refl]) 5169 apply (rule arg_cong[where f=modify, OF ext], simp) 5170 apply (rule arg_cong2[where f=gsCNodes_update, OF ext refl]) 5171 apply (rule ext) 5172 apply simp 5173 5174 \<comment> \<open>SmallPageObject\<close> 5175 apply (simp add: Arch_createNewCaps_def 5176 Retype_H.createObject_def createObjects_def bind_assoc 5177 ARM_H.toAPIType_def ARM_H.toAPIType_def 5178 ARM_H.createObject_def placeNewDataObject_def) 5179 apply (intro conjI impI) 5180 apply (subst monad_eq, rule createObjects_Cons) 5181 apply (simp_all add: field_simps shiftl_t2n pageBits_def 5182 getObjectSize_def ARM_H.getObjectSize_def 5183 objBits_simps)[6] 5184 apply (simp add: bind_assoc placeNewObject_def2 objBits_simps 5185 getObjectSize_def ARM_H.getObjectSize_def 5186 pageBits_def add.commute append) 5187 apply ((subst gsUserPages_update gsCNodes_update 5188 gsUserPages_upd_createObjects'_comm 5189 unless_dmo'_gsUserPages_upd_comm 5190 unless_dmo'_createObjects'_comm 5191 dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm 5192 | simp add: modify_modify_bind o_def)+)[1] 5193 apply (subst monad_eq, rule createObjects_Cons) 5194 apply (simp_all add: field_simps shiftl_t2n pageBits_def 5195 getObjectSize_def ARM_H.getObjectSize_def 5196 objBits_simps)[6] 5197 apply (simp add: bind_assoc placeNewObject_def2 objBits_simps 5198 getObjectSize_def ARM_H.getObjectSize_def 5199 pageBits_def add.commute append) 5200 apply (subst gsUserPages_update gsCNodes_update 5201 gsUserPages_upd_createObjects'_comm 5202 unless_dmo'_gsUserPages_upd_comm 5203 unless_dmo'_createObjects'_comm 5204 dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm 5205 | simp add: modify_modify_bind o_def)+ 5206 \<comment> \<open>LargePageObject\<close> 5207 apply (simp add: Arch_createNewCaps_def 5208 Retype_H.createObject_def createObjects_def bind_assoc 5209 ARM_H.toAPIType_def ARM_H.toAPIType_def 5210 ARM_H.createObject_def placeNewDataObject_def) 5211 apply (intro conjI impI) 5212 apply (subst monad_eq, rule createObjects_Cons) 5213 apply (simp_all add: field_simps shiftl_t2n pageBits_def 5214 getObjectSize_def ARM_H.getObjectSize_def 5215 objBits_simps)[6] 5216 apply (simp add: bind_assoc placeNewObject_def2 objBits_simps 5217 getObjectSize_def ARM_H.getObjectSize_def 5218 pageBits_def add.commute append) 5219 apply ((subst gsUserPages_update gsCNodes_update 5220 gsUserPages_upd_createObjects'_comm 5221 unless_dmo'_gsUserPages_upd_comm 5222 unless_dmo'_createObjects'_comm 5223 dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm 5224 | simp add: modify_modify_bind o_def)+)[1] 5225 apply (subst monad_eq, rule createObjects_Cons) 5226 apply (simp_all add: field_simps shiftl_t2n pageBits_def 5227 ARM_H.getObjectSize_def objBits_simps)[6] 5228 apply (simp add: bind_assoc placeNewObject_def2 objBits_simps 5229 ARM_H.getObjectSize_def 5230 pageBits_def add.commute append) 5231 apply (subst gsUserPages_update gsCNodes_update 5232 gsUserPages_upd_createObjects'_comm 5233 unless_dmo'_gsUserPages_upd_comm 5234 unless_dmo'_createObjects'_comm 5235 dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm 5236 | simp add: modify_modify_bind o_def)+ 5237 \<comment> \<open>SectionObject\<close> 5238 apply (simp add: Arch_createNewCaps_def 5239 Retype_H.createObject_def createObjects_def bind_assoc 5240 toAPIType_def ARM_H.toAPIType_def 5241 ARM_H.createObject_def placeNewDataObject_def) 5242 apply (intro conjI impI) 5243 apply (subst monad_eq, rule createObjects_Cons) 5244 apply (simp_all add: field_simps shiftl_t2n pageBits_def 5245 getObjectSize_def ARM_H.getObjectSize_def 5246 objBits_simps)[6] 5247 apply (simp add: bind_assoc placeNewObject_def2 objBits_simps 5248 getObjectSize_def ARM_H.getObjectSize_def 5249 pageBits_def add.commute append) 5250 apply ((subst gsUserPages_update gsCNodes_update 5251 gsUserPages_upd_createObjects'_comm 5252 unless_dmo'_gsUserPages_upd_comm 5253 unless_dmo'_createObjects'_comm 5254 dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm 5255 | simp add: modify_modify_bind o_def)+)[1] 5256 apply (subst monad_eq, rule createObjects_Cons) 5257 apply (simp_all add: field_simps shiftl_t2n pageBits_def 5258 ARM_H.getObjectSize_def objBits_simps)[6] 5259 apply (simp add: bind_assoc placeNewObject_def2 objBits_simps 5260 ARM_H.getObjectSize_def 5261 pageBits_def add.commute append) 5262 apply (subst gsUserPages_update gsCNodes_update 5263 gsUserPages_upd_createObjects'_comm 5264 unless_dmo'_gsUserPages_upd_comm 5265 unless_dmo'_createObjects'_comm 5266 dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm 5267 | simp add: modify_modify_bind o_def)+ 5268 \<comment> \<open>SuperSectionObject\<close> 5269 apply (simp add: Arch_createNewCaps_def 5270 Retype_H.createObject_def createObjects_def bind_assoc 5271 toAPIType_def ARM_H.toAPIType_def 5272 ARM_H.createObject_def placeNewDataObject_def) 5273 apply (intro conjI impI) 5274 apply (subst monad_eq, rule createObjects_Cons) 5275 apply (simp_all add: field_simps shiftl_t2n pageBits_def 5276 getObjectSize_def ARM_H.getObjectSize_def 5277 objBits_simps)[6] 5278 apply (simp add: bind_assoc placeNewObject_def2 objBits_simps 5279 getObjectSize_def ARM_H.getObjectSize_def 5280 pageBits_def add.commute append) 5281 apply ((subst gsUserPages_update gsCNodes_update 5282 gsUserPages_upd_createObjects'_comm 5283 unless_dmo'_gsUserPages_upd_comm 5284 unless_dmo'_createObjects'_comm 5285 dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm 5286 | simp add: modify_modify_bind o_def)+)[1] 5287 apply (subst monad_eq, rule createObjects_Cons) 5288 apply (simp_all add: field_simps shiftl_t2n pageBits_def 5289 ARM_H.getObjectSize_def objBits_simps)[6] 5290 apply (simp add: bind_assoc placeNewObject_def2 objBits_simps 5291 ARM_H.getObjectSize_def 5292 pageBits_def add.commute append) 5293 apply (subst gsUserPages_update gsCNodes_update 5294 gsUserPages_upd_createObjects'_comm 5295 unless_dmo'_gsUserPages_upd_comm 5296 unless_dmo'_createObjects'_comm 5297 dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm 5298 | simp add: modify_modify_bind o_def)+ 5299 \<comment> \<open>PageTableObject\<close> 5300 apply (simp add:Arch_createNewCaps_def Retype_H.createObject_def 5301 createObjects_def bind_assoc ARM_H.toAPIType_def 5302 ARM_H.createObject_def) 5303 apply (subst monad_eq,rule createObjects_Cons) 5304 apply ((simp add: field_simps shiftl_t2n pageBits_def archObjSize_def 5305 getObjectSize_def ARM_H.getObjectSize_def 5306 objBits_simps ptBits_def)+)[6] 5307 apply (simp add:bind_assoc placeNewObject_def2) 5308 apply (simp add: pageBits_def field_simps 5309 getObjectSize_def ptBits_def archObjSize_def 5310 ARM_H.getObjectSize_def placeNewObject_def2 5311 objBits_simps append) 5312 5313\<comment> \<open>PageDirectoryObject\<close> 5314 apply (simp add:Arch_createNewCaps_def Retype_H.createObject_def 5315 createObjects_def bind_assoc ARM_H.toAPIType_def 5316 ARM_H.createObject_def) 5317 apply (subgoal_tac "distinct (map (\<lambda>n. ptr + (n << 14)) [0.e.((of_nat n)::word32)])") 5318 prefer 2 5319 apply (clarsimp simp: objBits_simps archObjSize_def pdBits_def pageBits_def 5320 ARM_H.getObjectSize_def) 5321 apply (subst upto_enum_word) 5322 apply (clarsimp simp:distinct_map) 5323 apply (frule range_cover.range_cover_n_le) 5324 apply (frule range_cover.range_cover_n_less) 5325 apply (rule conjI) 5326 apply (clarsimp simp:inj_on_def) 5327 apply (rule ccontr) 5328 apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) 5329 apply simp 5330 apply (simp add:word_bits_def) 5331 apply (erule less_le_trans[OF word_of_nat_less]) 5332 apply (simp add: word_of_nat_le word_bits_def pdeBits_def) 5333 apply (erule less_le_trans[OF word_of_nat_less]) 5334 apply (simp add:word_of_nat_le word_bits_def pdeBits_def) 5335 apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) 5336 apply simp 5337 apply (rule ccontr) 5338 apply simp 5339 apply (drule of_nat_inj32[THEN iffD1,rotated -1]) 5340 apply (simp_all add: word_bits_def)[3] 5341 apply (clarsimp) 5342 apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) 5343 apply simp 5344 apply (simp add:word_bits_def) 5345 apply (simp add:word_of_nat_less word_bits_def pdeBits_def) 5346 apply (erule less_le_trans[OF word_of_nat_less]) 5347 apply (simp add:word_of_nat_le word_bits_def pdeBits_def) 5348 apply (rule ccontr) 5349 apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) 5350 apply simp 5351 apply simp 5352 apply (drule of_nat_inj32[THEN iffD1,rotated -1]) 5353 apply (simp_all add: word_bits_def)[3] 5354 apply (subst monad_eq,rule createObjects_Cons) 5355 apply ((simp add: field_simps shiftl_t2n pageBits_def archObjSize_def 5356 ARM_H.getObjectSize_def pdBits_def 5357 objBits_simps ptBits_def)+)[6] 5358 apply (simp add:objBits_simps archObjSize_def pdBits_def pageBits_def ARM_H.getObjectSize_def) 5359 apply (simp add:bind_assoc) 5360 apply (simp add: placeNewObject_def2[where val = "makeObject::ARM_H.pde",simplified,symmetric]) 5361 apply (rule_tac Q = "\<lambda>r s. valid_arch_state' s \<and> 5362 (\<forall>x\<le>of_nat n. page_directory_at' (ptr + (x << 14)) s) \<and> Q s" for Q in monad_eq_split) 5363 apply (rule sym) 5364 apply (subst bind_assoc[symmetric]) 5365 apply (subst monad_commute_simple) 5366 apply (rule commute_commute[OF monad_commute_split]) 5367 apply (rule placeNewObject_doMachineOp_commute) 5368 apply (rule mapM_x_commute[where f = id]) 5369 apply (rule placeNewObject_copyGlobalMapping_commute) 5370 apply (rule hoare_pre) 5371 apply (wp copyGlobalMappings_pspace_no_overlap' mapM_x_wp'| clarsimp simp: pdeBits_def)+ 5372 apply (clarsimp simp:objBits_simps archObjSize_def pdBits_def pageBits_def word_bits_conv) 5373 apply assumption (* resolve assumption , yuck *) 5374 apply (simp add:append mapM_x_append bind_assoc pdeBits_def) 5375 apply (rule monad_eq_split[where Q = "\<lambda> r s. pspace_aligned' s \<and> pspace_distinct' s 5376 \<and> valid_arch_state' s \<and> (\<forall>r \<le> of_nat n. page_directory_at' (ptr + (r << 14)) s) 5377 \<and> page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"]) 5378 apply (rule monad_eq_split[where Q = "\<lambda> r s. pspace_aligned' s \<and> pspace_distinct' s 5379 \<and> valid_arch_state' s \<and> (\<forall>r \<le> of_nat n. page_directory_at' (ptr + (r << 14)) s) 5380 \<and> page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"]) 5381 apply (subst monad_commute_simple) 5382 apply (rule doMachineOp_copyGlobalMapping_commute) 5383 apply (clarsimp simp:field_simps) 5384 apply (simp add:field_simps mapM_x_singleton) 5385 apply (rule monad_eq_split[where Q = "\<lambda> r s. pspace_aligned' s \<and> pspace_distinct' s 5386 \<and> valid_arch_state' s \<and> page_directory_at' (ptr + (1 + of_nat n << 14)) s"]) 5387 apply (subst doMachineOp_bind) 5388 apply (wp empty_fail_mapM_x empty_fail_cleanCacheRange_PoU)+ 5389 apply (simp add:bind_assoc objBits_simps field_simps archObjSize_def shiftL_nat) 5390 apply wp 5391 apply simp 5392 apply (rule mapM_x_wp') 5393 apply (rule hoare_pre) 5394 apply (wp copyGlobalMappings_pspace_no_overlap' | clarsimp)+ 5395 apply (clarsimp simp:page_directory_at'_def) 5396 apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift) 5397 apply ((clarsimp simp:page_directory_at'_def)+)[2] 5398 apply (wp placeNewObject_pspace_aligned' placeNewObject_pspace_distinct') 5399 apply (simp add:placeNewObject_def2 field_simps) 5400 apply (rule hoare_vcg_conj_lift) 5401 apply (rule createObjects'_wp_subst) 5402 apply (wp createObjects_valid_arch[where sz = 14]) 5403 apply (rule hoare_vcg_conj_lift) 5404 apply (clarsimp simp:page_directory_at'_def) 5405 apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift createObjects'_typ_at[where sz = 14]) 5406 apply (rule hoare_strengthen_post[OF createObjects'_page_directory_at'[where sz = 14]]) 5407 apply simp 5408 apply (clarsimp simp:objBits_simps page_directory_at'_def pdeBits_def 5409 field_simps archObjSize_def word_bits_conv range_cover_full 5410 aligned_add_aligned range_cover.aligned is_aligned_shiftl_self) 5411 apply (simp add: pdeBits_def) 5412 apply (frule pspace_no_overlap'_le2[where ptr' = "(ptr + (1 + of_nat n << 14))"]) 5413 apply (subst shiftl_t2n,subst mult.commute, subst suc_of_nat) 5414 apply (rule order_trans[OF range_cover_bound,where n1 = "1 + n"]) 5415 apply (erule range_cover_le,simp) 5416 apply simp 5417 apply (rule word_sub_1_le) 5418 apply (drule(1) range_cover_no_0[where p = "n+1"]) 5419 apply simp 5420 apply simp 5421 apply (erule(1) range_cover_tail_mask) 5422 apply (rule hoare_vcg_conj_lift) 5423 apply (rule createObjects'_wp_subst) 5424 apply (wp createObjects_valid_arch[where sz = sz]) 5425 apply (wp createObjects'_page_directory_at'[where sz = sz] 5426 createObjects'_psp_aligned[where sz = sz] 5427 createObjects'_psp_distinct[where sz = sz] hoare_vcg_imp_lift 5428 createObjects'_pspace_no_overlap[where sz = sz] 5429 | simp add:objBits_simps archObjSize_def field_simps pdeBits_def)+ 5430 apply (drule range_cover_le[where n = "Suc n"]) 5431 apply simp 5432 apply (clarsimp simp:word_bits_def valid_pspace'_def) 5433 apply (clarsimp simp:aligned_add_aligned[OF range_cover.aligned] is_aligned_shiftl_self word_bits_def)+ 5434 done 5435qed 5436 5437lemma createObject_def2: 5438 "(RetypeDecls_H.createObject ty ptr us dev >>= (\<lambda>x. return [x])) = 5439 createNewCaps ty ptr (Suc 0) us dev" 5440 apply (clarsimp simp:createObject_def createNewCaps_def placeNewObject_def2) 5441 apply (case_tac ty) 5442 apply (simp_all add: toAPIType_def) 5443 defer 5444 apply ((clarsimp simp: Arch_createNewCaps_def 5445 createObjects_def shiftL_nat 5446 ARM_H.createObject_def placeNewDataObject_def 5447 placeNewObject_def2 objBits_simps bind_assoc 5448 clearMemory_def clearMemoryVM_def fun_upd_def[symmetric] 5449 word_size mapM_x_singleton storeWordVM_def)+)[6] 5450 apply (rename_tac apiobject_type) 5451 apply (case_tac apiobject_type) 5452 apply (clarsimp simp: Arch_createNewCaps_def 5453 createObjects_def shiftL_nat 5454 ARM_H.createObject_def 5455 placeNewObject_def2 objBits_simps bind_assoc 5456 clearMemory_def clearMemoryVM_def 5457 word_size mapM_x_singleton storeWordVM_def)+ 5458 done 5459 5460 5461lemma createNewObjects_def2: 5462 "\<lbrakk>dslots \<noteq> []; length ( dslots ) < 2^word_bits; 5463 cte_wp_at' (\<lambda>c. isUntypedCap (cteCap c)) parent s; 5464 \<forall>slot \<in> set dslots. cte_wp_at' (\<lambda>c. cteCap c = capability.NullCap) slot s; 5465 pspace_no_overlap' ptr sz s; 5466 caps_no_overlap'' ptr sz s; 5467 caps_overlap_reserved' 5468 {ptr..ptr + of_nat (length dslots) * 2 ^ Types_H.getObjectSize ty us - 1} s; 5469 valid_pspace' s; 5470 distinct dslots; 5471 valid_arch_state' s; 5472 range_cover ptr sz (Types_H.getObjectSize ty us) (length dslots); 5473 ptr \<noteq> 0; 5474 ksCurDomain s \<le> maxDomain\<rbrakk> 5475 \<Longrightarrow> createNewObjects ty parent dslots ptr us d s = 5476 insertNewCaps ty parent dslots ptr us d s" 5477 apply (clarsimp simp:insertNewCaps_def createNewObjects_def neq_Nil_conv) 5478 proof - 5479 fix y ys 5480 have list_inc: "\<And>n. [0.e.Suc n] = [0 .e. n] @ [n+1]" 5481 by simp 5482 assume le: "Suc (length (ys::word32 list)) < 2 ^ word_bits" 5483 assume list_nc: "\<forall>slot \<in> set ys. cte_wp_at' (\<lambda>c. cteCap c = capability.NullCap) slot s" 5484 assume dist: "distinct ys" 5485 assume extra: "y\<notin> set ys" "cte_wp_at' (\<lambda>c. cteCap c = capability.NullCap) y s" 5486 assume not_0: "ptr \<noteq> 0" 5487 assume kscd: "ksCurDomain s \<le> maxDomain" 5488 assume valid_psp: "valid_pspace' s" 5489 assume valid_arch_state: "valid_arch_state' s" 5490 assume psp_no_overlap: "pspace_no_overlap' ptr sz s" 5491 assume caps_no_overlap: "caps_no_overlap'' ptr sz s" 5492 assume caps_reserved: "caps_overlap_reserved' 5493 {ptr..ptr + (1 + of_nat (length ys)) * 2 ^ (Types_H.getObjectSize ty us) - 1} s" 5494 assume range_cover: "range_cover ptr sz (Types_H.getObjectSize ty us) (Suc (length ys))" 5495 assume unt_at: "cte_wp_at' (\<lambda>c. isUntypedCap (cteCap c)) parent s" 5496 show "zipWithM_x 5497 (\<lambda>num slot. 5498 RetypeDecls_H.createObject ty ((num << Types_H.getObjectSize ty us) + ptr) us d >>= 5499 insertNewCap parent slot) 5500 [0.e.of_nat (length ys)] (y # ys) s = 5501 (createNewCaps ty ptr (Suc (length ys)) us d >>= zipWithM_x (insertNewCap parent) (y # ys)) s" 5502 using le list_nc dist extra range_cover not_0 caps_reserved 5503 proof (induct ys arbitrary: y rule:rev_induct) 5504 case Nil 5505 show ?case 5506 by (clarsimp simp:zipWithM_x_def zipWith_def 5507 sequence_x_def createObject_def2[symmetric]) 5508 next 5509 case (snoc a as b) 5510 have caps_r:"caps_overlap_reserved' 5511 {ptr..ptr + (1 + of_nat (length as)) * 2 ^ Types_H.getObjectSize ty us - 1} s" 5512 using snoc.prems 5513 apply - 5514 apply (erule caps_overlap_reserved'_subseteq) 5515 apply (cut_tac is_aligned_no_overflow 5516 [where ptr = "ptr + ((1 + of_nat (length as)) << APIType_capBits ty us)" 5517 and sz = " Types_H.getObjectSize ty us"]) 5518 apply (clarsimp simp: power_add[symmetric] shiftl_t2n field_simps objSize_eq_capBits ) 5519 apply (rule order_trans[OF word_sub_1_le]) 5520 apply (drule(1) range_cover_no_0[where p = "Suc (length as)"]) 5521 apply simp 5522 apply (simp add:word_arith_nat_Suc power_add[symmetric] field_simps) 5523 apply (simp add:shiftl_t2n) 5524 apply (rule aligned_add_aligned[OF range_cover.aligned]) 5525 apply (simp add:objSize_eq_capBits)+ 5526 apply (rule is_aligned_shiftl_self) 5527 apply (simp add:range_cover_def objSize_eq_capBits)+ 5528 done 5529 show ?case 5530 apply simp 5531 using snoc.prems 5532 apply (subst upto_enum_inc_1) 5533 apply (rule word_of_nat_less) 5534 apply (simp add:word_bits_def minus_one_norm) 5535 apply (subst append_Cons[symmetric]) 5536 apply (subst zipWithM_x_append1) 5537 apply (clarsimp simp:unat_of_nat32 bind_assoc) 5538 apply (subst monad_eq) 5539 apply (rule snoc.hyps) 5540 apply (simp add:caps_r | rule range_cover_le)+ 5541 apply (simp add:snoc.hyps bind_assoc) 5542 apply (rule sym) 5543 apply (subst monad_eq) 5544 apply (erule createNewCaps_Cons[OF _ valid_psp valid_arch_state psp_no_overlap not_0]) 5545 apply (rule sym) 5546 apply (simp add:bind_assoc del:upto_enum_nat) 5547 apply (rule_tac Q = "(\<lambda>r s. (\<forall>cap\<in>set r. cap \<noteq> capability.NullCap) \<and> 5548 cte_wp_at' (\<lambda>c. isUntypedCap (cteCap c)) parent s \<and> 5549 cte_wp_at' (\<lambda>c. cteCap c = capability.NullCap) b s \<and> 5550 (\<forall>slot\<in>set as. cte_wp_at' (\<lambda>c. cteCap c = capability.NullCap) slot s) \<and> 5551 pspace_no_overlap' (ptr + (1 + of_nat (length as) << Types_H.getObjectSize ty us)) 5552 (Types_H.getObjectSize ty us) s 5553 \<and> valid_pspace' s \<and> valid_arch_state' s \<and> Q r s)" for Q in monad_eq_split) 5554 apply (subst append_Cons[symmetric]) 5555 apply (subst zipWithM_x_append1) 5556 apply clarsimp 5557 apply assumption 5558 apply (clarsimp simp:field_simps) 5559 apply (subst monad_commute_simple[OF commute_commute]) 5560 apply (rule new_cap_object_commute) 5561 apply (clarsimp) 5562 apply (frule_tac p = "1 + length as" in range_cover_no_0[rotated]) 5563 apply clarsimp 5564 apply simp 5565 apply (subst (asm) Abs_fnat_hom_add[symmetric]) 5566 apply (intro conjI) 5567 apply (simp add:range_cover_def word_bits_def) 5568 apply (rule aligned_add_aligned[OF range_cover.aligned],simp) 5569 apply (rule is_aligned_shiftl_self) 5570 apply (simp add:range_cover_def) 5571 apply (simp add:range_cover_def) 5572 apply (clarsimp simp:field_simps shiftl_t2n) 5573 apply (clarsimp simp:createNewCaps_def) 5574 apply (wp createNewCaps_not_nc createNewCaps_pspace_no_overlap'[where sz = sz] 5575 createNewCaps_cte_wp_at'[where sz = sz] hoare_vcg_ball_lift 5576 createNewCaps_valid_pspace[where sz = sz] 5577 createNewCaps_obj_at'[where sz=sz]) 5578 apply simp 5579 apply (rule range_cover_le) 5580 apply (simp add:objSize_eq_capBits caps_r)+ 5581 apply (wp createNewCaps_ret_len createNewCaps_valid_arch_state) 5582 apply (frule range_cover_le[where n = "Suc (length as)"]) 5583 apply simp+ 5584 using psp_no_overlap caps_r valid_psp unt_at caps_no_overlap valid_arch_state 5585 apply (clarsimp simp: valid_pspace'_def objSize_eq_capBits) 5586 apply (auto simp: kscd) 5587 done 5588 qed 5589qed 5590 5591lemma createNewObjects_corres_helper: 5592assumes check: "distinct dslots" 5593 and cover: "range_cover ptr sz (Types_H.getObjectSize ty us) (length dslots)" 5594 and not_0: "ptr \<noteq> 0" "length dslots \<noteq> 0" 5595 and c: "corres r P P' f (insertNewCaps ty parent dslots ptr us d)" 5596 and imp: "\<And>s. P' s \<Longrightarrow> (cte_wp_at' (\<lambda>c. isUntypedCap (cteCap c)) parent s 5597 \<and> (\<forall>slot \<in> set dslots. cte_wp_at' (\<lambda>c. cteCap c = capability.NullCap) slot s) 5598 \<and> pspace_no_overlap' ptr sz s 5599 \<and> caps_no_overlap'' ptr sz s 5600 \<and> caps_overlap_reserved' 5601 {ptr..ptr + of_nat (length dslots) * 2^ (Types_H.getObjectSize ty us) - 1} s 5602 \<and> valid_pspace' s \<and> valid_arch_state' s \<and> ksCurDomain s \<le> maxDomain)" 5603shows "corres r P P' f (createNewObjects ty parent dslots ptr us d)" 5604 using check cover not_0 5605 apply (clarsimp simp:corres_underlying_def) 5606 apply (frule imp) 5607 apply (frule range_cover.range_cover_le_n_less(1)[where 'a=32, folded word_bits_def, OF _ le_refl]) 5608 apply clarsimp 5609 apply (simp add:createNewObjects_def2) 5610 using c 5611 apply (clarsimp simp:corres_underlying_def) 5612 apply (drule(1) bspec) 5613 apply clarsimp 5614 done 5615 5616lemma createNewObjects_wp_helper: 5617 assumes check: "distinct dslots" 5618 and cover: "range_cover ptr sz (Types_H.getObjectSize ty us) (length dslots)" 5619 and not_0: "ptr \<noteq> 0" "length dslots \<noteq> 0" 5620 shows "\<lbrace>P\<rbrace> insertNewCaps ty parent dslots ptr us d \<lbrace>Q\<rbrace> 5621 \<Longrightarrow> \<lbrace>P and (cte_wp_at' (\<lambda>c. isUntypedCap (cteCap c)) parent 5622 and (\<lambda>s. \<forall>slot \<in> set dslots. cte_wp_at' (\<lambda>c. cteCap c = capability.NullCap) slot s) 5623 and pspace_no_overlap' ptr sz 5624 and caps_no_overlap'' ptr sz 5625 and valid_pspace' 5626 and valid_arch_state' 5627 and caps_overlap_reserved' 5628 {ptr..ptr + of_nat (length dslots) * 2^ (Types_H.getObjectSize ty us) - 1} and (\<lambda>s. ksCurDomain s \<le> maxDomain)) 5629 \<rbrace> (createNewObjects ty parent dslots ptr us d) \<lbrace>Q\<rbrace>" 5630 using assms 5631 apply (clarsimp simp:valid_def) 5632 apply (drule_tac x = s in spec) 5633 apply (frule range_cover.range_cover_le_n_less(1)[where 'a=32, folded word_bits_def, OF _ le_refl]) 5634 apply (simp add:createNewObjects_def2[symmetric]) 5635 apply (drule(1) bspec) 5636 apply clarsimp 5637 done 5638 5639lemma createObject_def3: 5640 "createObject = 5641 (\<lambda>ty ptr us d. createNewCaps ty ptr (Suc 0) us d >>= (\<lambda>m. return (hd m)))" 5642 apply (rule ext)+ 5643 apply (simp add:createObject_def2[symmetric]) 5644 done 5645 5646lemma ArchCreateObject_pspace_no_overlap': 5647 "\<lbrace>\<lambda>s. pspace_no_overlap' 5648 (ptr + (of_nat n << APIType_capBits ty userSize)) sz s \<and> 5649 pspace_aligned' s \<and> pspace_distinct' s \<and> 5650 range_cover ptr sz (APIType_capBits ty userSize) (n + 2) \<and> ptr \<noteq> 0\<rbrace> 5651 ARM_H.createObject ty 5652 (ptr + (of_nat n << APIType_capBits ty userSize)) userSize d 5653 \<lbrace>\<lambda>archCap. pspace_no_overlap' 5654 (ptr + (1 + of_nat n << APIType_capBits ty userSize)) sz\<rbrace>" 5655 apply (rule hoare_pre) 5656 apply (clarsimp simp:ARM_H.createObject_def) 5657 apply wpc 5658 apply (wp doMachineOp_psp_no_overlap unless_doMachineOp_psp_no_overlap[simplified] 5659 createObjects'_pspace_no_overlap2 hoare_when_weak_wp 5660 copyGlobalMappings_pspace_no_overlap' 5661 createObjects'_psp_aligned[where sz = sz] 5662 createObjects'_psp_distinct[where sz = sz] 5663 | simp add: placeNewObject_def2 word_shiftl_add_distrib 5664 | simp add: placeNewObject_def2 word_shiftl_add_distrib 5665 | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib 5666 field_simps split del: if_splits 5667 | clarsimp simp add: add.assoc[symmetric],wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] 5668 | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ 5669 5670 apply (clarsimp simp: conj_comms) 5671 apply (frule(1) range_cover_no_0[where p = n]) 5672 apply simp 5673 apply (subgoal_tac "is_aligned (ptr + (of_nat n << APIType_capBits ty userSize)) 5674 (APIType_capBits ty userSize) ") 5675 prefer 2 5676 apply (rule aligned_add_aligned[OF range_cover.aligned],assumption) 5677 apply (simp add:is_aligned_shiftl_self range_cover_sz') 5678 apply (simp add: APIType_capBits_def) 5679 apply (frule range_cover_offset[rotated,where p = n]) 5680 apply simp+ 5681 apply (frule range_cover_le[where n = "Suc (Suc 0)"]) 5682 apply simp 5683 apply (frule pspace_no_overlap'_le2) 5684 apply (rule range_cover_compare_offset) 5685 apply simp+ 5686 apply (clarsimp simp:word_shiftl_add_distrib 5687 ,simp add:field_simps) 5688 apply (clarsimp simp:add.assoc[symmetric]) 5689 apply (rule range_cover_tail_mask[where n =0,simplified]) 5690 apply (drule range_cover_offset[rotated,where p = n]) 5691 apply simp 5692 apply (clarsimp simp:shiftl_t2n field_simps) 5693 apply (metis numeral_2_eq_2) 5694 apply (simp add:shiftl_t2n field_simps) 5695 apply (intro conjI allI) 5696 apply (clarsimp simp: field_simps pageBits_def pdBits_def word_bits_conv archObjSize_def ptBits_def 5697 APIType_capBits_def shiftl_t2n objBits_simps pdeBits_def pteBits_def 5698 | rule conjI | erule range_cover_le,simp)+ 5699 done 5700 5701lemma to_from_apiTypeD: "toAPIType ty = Some x \<Longrightarrow> ty = fromAPIType x" 5702 by (cases ty) (auto simp add: fromAPIType_def 5703 toAPIType_def) 5704 5705lemma createObject_pspace_no_overlap': 5706 "\<lbrace>\<lambda>s. pspace_no_overlap' 5707 (ptr + (of_nat n << APIType_capBits ty userSize)) sz s \<and> 5708 pspace_aligned' s \<and> pspace_distinct' s 5709 \<and> range_cover ptr sz (APIType_capBits ty userSize) (n + 2) 5710 \<and> ptr \<noteq> 0\<rbrace> 5711 createObject ty (ptr + (of_nat n << APIType_capBits ty userSize)) userSize d 5712 \<lbrace>\<lambda>rv s. pspace_no_overlap' 5713 (ptr + (1 + of_nat n << APIType_capBits ty userSize)) sz s\<rbrace>" 5714 apply (rule hoare_pre) 5715 apply (clarsimp simp:createObject_def) 5716 apply wpc 5717 apply (wp ArchCreateObject_pspace_no_overlap') 5718 apply wpc 5719 apply wp 5720 apply (simp add:placeNewObject_def2) 5721 apply (wp doMachineOp_psp_no_overlap createObjects'_pspace_no_overlap2 unless_doMachineOp_psp_no_overlap[simplified] 5722 | simp add: placeNewObject_def2 curDomain_def word_shiftl_add_distrib 5723 field_simps)+ 5724 apply (simp add:add.assoc[symmetric]) 5725 apply (wp createObjects'_pspace_no_overlap2 5726 [where n =0 and sz = sz,simplified]) 5727 apply (simp add:placeNewObject_def2) 5728 apply (wp doMachineOp_psp_no_overlap createObjects'_pspace_no_overlap2 unless_doMachineOp_psp_no_overlap[simplified] 5729 | simp add: placeNewObject_def2 word_shiftl_add_distrib 5730 field_simps)+ 5731 apply (simp add:add.assoc[symmetric]) 5732 apply (wp createObjects'_pspace_no_overlap2 5733 [where n =0 and sz = sz,simplified]) 5734 apply (simp add:placeNewObject_def2) 5735 apply (wp doMachineOp_psp_no_overlap createObjects'_pspace_no_overlap2 unless_doMachineOp_psp_no_overlap[simplified] 5736 | simp add: placeNewObject_def2 word_shiftl_add_distrib 5737 field_simps)+ 5738 apply (simp add:add.assoc[symmetric]) 5739 apply (wp createObjects'_pspace_no_overlap2 5740 [where n =0 and sz = sz,simplified]) 5741 apply (simp add:placeNewObject_def2) 5742 apply (wp doMachineOp_psp_no_overlap createObjects'_pspace_no_overlap2 unless_doMachineOp_psp_no_overlap[simplified] 5743 | simp add: placeNewObject_def2 word_shiftl_add_distrib 5744 field_simps)+ 5745 apply (simp add:add.assoc[symmetric]) 5746 apply (wp createObjects'_pspace_no_overlap2 5747 [where n =0 and sz = sz,simplified]) 5748 apply clarsimp 5749 apply (frule(1) range_cover_no_0[where p = n]) 5750 apply simp 5751 apply (frule pspace_no_overlap'_le2) 5752 apply (rule range_cover_compare_offset) 5753 apply simp+ 5754 apply (clarsimp simp:word_shiftl_add_distrib 5755 ,simp add:field_simps) 5756 apply (clarsimp simp:add.assoc[symmetric]) 5757 apply (rule range_cover_tail_mask[where n =0,simplified]) 5758 apply (drule range_cover_offset[rotated,where p = n]) 5759 apply simp 5760 apply (clarsimp simp:shiftl_t2n field_simps) 5761 apply (metis numeral_2_eq_2) 5762 apply (simp add:shiftl_t2n field_simps) 5763 apply (frule range_cover_offset[rotated,where p = n]) 5764 apply simp+ 5765 apply (auto simp: word_shiftl_add_distrib field_simps shiftl_t2n elim: range_cover_le, 5766 auto simp add: APIType_capBits_def fromAPIType_def objBits_def 5767 dest!: to_from_apiTypeD) 5768 done 5769 5770lemma createObject_pspace_aligned_distinct': 5771 "\<lbrace>pspace_aligned' and K (is_aligned ptr (APIType_capBits ty us)) 5772 and pspace_distinct' and pspace_no_overlap' ptr (APIType_capBits ty us) 5773 and K (ty = APIObjectType apiobject_type.CapTableObject \<longrightarrow> us < 28)\<rbrace> 5774 createObject ty ptr us d 5775 \<lbrace>\<lambda>xa s. pspace_aligned' s \<and> pspace_distinct' s\<rbrace>" 5776 apply (rule hoare_pre) 5777 apply (wp placeNewObject_pspace_aligned' hoare_unless_wp 5778 placeNewObject_pspace_distinct' 5779 | simp add:ARM_H.createObject_def 5780 Retype_H.createObject_def objBits_simps 5781 curDomain_def placeNewDataObject_def 5782 split del: if_split 5783 | wpc | intro conjI impI)+ 5784 apply (auto simp:APIType_capBits_def pdBits_def objBits_simps' pteBits_def pdeBits_def 5785 pageBits_def word_bits_def archObjSize_def ptBits_def ARM_H.toAPIType_def 5786 split:ARM_H.object_type.splits apiobject_type.splits) 5787 done 5788 5789declare objSize_eq_capBits [simp] 5790 5791lemma createNewObjects_Cons: 5792 assumes dlength: "length dest < 2 ^ word_bits" 5793 shows "createNewObjects ty src (dest @ [lt]) ptr us d = 5794 do createNewObjects ty src dest ptr us d; 5795 (RetypeDecls_H.createObject ty ((of_nat (length dest) << APIType_capBits ty us) + ptr) us d 5796 >>= insertNewCap src lt) 5797 od" 5798 proof - 5799 from dlength 5800 have expand:"dest\<noteq>[] \<longrightarrow> [(0::word32) .e. of_nat (length dest)] 5801 = [0.e.of_nat (length dest - 1)] @ [of_nat (length dest)]" 5802 apply (cases dest) 5803 apply clarsimp+ 5804 apply (rule upto_enum_inc_1) 5805 apply (rule word_of_nat_less) 5806 apply (simp add: word_bits_conv minus_one_norm) 5807 done 5808 5809 have length:"\<lbrakk>length dest < 2 ^ word_bits;dest \<noteq> []\<rbrakk> 5810 \<Longrightarrow> length [(0::word32) .e. of_nat (length dest - 1)] = length dest" 5811 proof (induct dest) 5812 case Nil thus ?case by simp 5813 next 5814 case (Cons x xs) 5815 thus ?case by (simp add:unat_of_nat32) 5816 qed 5817 5818 show ?thesis 5819 using dlength 5820 apply (case_tac "dest = []") 5821 apply (simp add: zipWithM_x_def createNewObjects_def 5822 sequence_x_def zipWith_def) 5823 apply (clarsimp simp:createNewObjects_def) 5824 apply (subst expand) 5825 apply simp 5826 apply (subst zipWithM_x_append1) 5827 apply (rule length) 5828 apply (simp add:field_simps)+ 5829 done 5830qed 5831 5832lemma updateNewFreeIndex_cteCaps_of[wp]: 5833 "\<lbrace>\<lambda>s. P (cteCaps_of s)\<rbrace> updateNewFreeIndex slot \<lbrace>\<lambda>rv s. P (cteCaps_of s)\<rbrace>" 5834 by (simp add: cteCaps_of_def, wp) 5835 5836lemma insertNewCap_wps[wp]: 5837 "\<lbrace>pspace_aligned'\<rbrace> insertNewCap parent slot cap \<lbrace>\<lambda>rv. pspace_aligned'\<rbrace>" 5838 "\<lbrace>pspace_distinct'\<rbrace> insertNewCap parent slot cap \<lbrace>\<lambda>rv. pspace_distinct'\<rbrace>" 5839 "\<lbrace>\<lambda>s. P ((cteCaps_of s)(slot \<mapsto> cap))\<rbrace> 5840 insertNewCap parent slot cap 5841 \<lbrace>\<lambda>rv s. P (cteCaps_of s)\<rbrace>" 5842 apply (simp_all add: insertNewCap_def) 5843 apply (wp hoare_drop_imps 5844 | simp add: o_def)+ 5845 apply (fastforce elim!: rsubst[where P=P]) 5846 done 5847 5848crunch typ_at'[wp]: insertNewCap "\<lambda>s. P (typ_at' T p s)" 5849 (wp: crunch_wps) 5850 5851lemma createNewObjects_pspace_no_overlap': 5852 "\<lbrace>pspace_no_overlap' ptr sz and pspace_aligned' and pspace_distinct' 5853 and K (range_cover ptr sz (Types_H.getObjectSize ty us) (Suc (length dests))) 5854 and K (ptr \<noteq> 0) 5855 and K (ty = APIObjectType apiobject_type.CapTableObject \<longrightarrow> us < 28)\<rbrace> 5856 createNewObjects ty src dests ptr us d 5857 \<lbrace>\<lambda>rv s. pspace_aligned' s \<and> pspace_distinct' s \<and> 5858 pspace_no_overlap' ((of_nat (length dests) << APIType_capBits ty us) + ptr) sz s\<rbrace>" 5859 apply (rule hoare_gen_asm)+ 5860 proof (induct rule:rev_induct ) 5861 case Nil 5862 show ?case 5863 by (simp add:createNewObjects_def zipWithM_x_mapM mapM_Nil | wp)+ 5864 next 5865 case (snoc dest dests) 5866 have rc:"range_cover ptr sz (Types_H.getObjectSize ty us) (Suc (length dests))" 5867 apply (rule range_cover_le) 5868 apply (rule snoc) 5869 apply simp 5870 done 5871 show ?case 5872 using rc 5873 apply (subst createNewObjects_Cons) 5874 apply (drule range_cover.weak) 5875 apply (simp add: word_bits_def) 5876 apply (wp pspace_no_overlap'_lift) 5877 apply (simp add: conj_comms) 5878 apply (rule hoare_vcg_conj_lift) 5879 apply (rule hoare_post_imp[OF _ createObject_pspace_aligned_distinct']) 5880 apply simp 5881 apply (rule hoare_vcg_conj_lift) 5882 apply (rule hoare_post_imp[OF _ createObject_pspace_aligned_distinct']) 5883 apply simp 5884 apply (simp add:field_simps) 5885 apply (wp createObject_pspace_no_overlap') 5886 apply (clarsimp simp: conj_comms) 5887 apply (rule hoare_pre) 5888 apply (rule hoare_vcg_conj_lift) 5889 apply (rule hoare_post_imp[OF _ snoc.hyps]) 5890 apply (simp add:snoc)+ 5891 apply (rule hoare_vcg_conj_lift) 5892 apply (rule hoare_post_imp[OF _ snoc.hyps]) 5893 apply (simp add:snoc)+ 5894 apply wp 5895 apply (simp add: conj_comms field_simps) 5896 apply (rule hoare_post_imp) 5897 apply (erule context_conjI) 5898 apply (intro conjI) 5899 apply (rule aligned_add_aligned[OF range_cover.aligned 5900 is_aligned_shiftl_self]) 5901 apply simp 5902 apply simp 5903 apply simp 5904 apply (erule pspace_no_overlap'_le) 5905 apply (simp add: range_cover.sz[where 'a=32, folded word_bits_def])+ 5906 apply (rule hoare_post_imp[OF _ snoc.hyps]) 5907 apply (simp add:field_simps snoc)+ 5908 using snoc 5909 apply simp 5910 done 5911qed 5912 5913end 5914end 5915