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