1223 lines
51 KiB
Plaintext
1223 lines
51 KiB
Plaintext
(*
|
|
* Copyright 2023, Proofcraft Pty Ltd
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
|
*
|
|
* SPDX-License-Identifier: GPL-2.0-only
|
|
*)
|
|
|
|
(*
|
|
Lemmas on arch get/set object etc
|
|
*)
|
|
|
|
theory ArchAcc_R
|
|
imports SubMonad_R
|
|
begin
|
|
|
|
unbundle l4v_word_context
|
|
|
|
context begin interpretation Arch . (*FIXME: arch_split*)
|
|
|
|
declare if_cong[cong] (* FIXME: if_cong *)
|
|
|
|
lemma asid_pool_at_ko:
|
|
"asid_pool_at p s \<Longrightarrow> \<exists>pool. ko_at (ArchObj (AARCH64_A.ASIDPool pool)) p s"
|
|
by (clarsimp simp: asid_pools_at_eq obj_at_def elim!: opt_mapE)
|
|
|
|
lemma corres_gets_asid:
|
|
"corres (\<lambda>a c. a = c o ucast) \<top> \<top> (gets asid_table) (gets (armKSASIDTable \<circ> ksArchState))"
|
|
by (simp add: state_relation_def arch_state_relation_def)
|
|
|
|
lemma asid_low_bits [simp]:
|
|
"asidLowBits = asid_low_bits"
|
|
by (simp add: asid_low_bits_def asidLowBits_def)
|
|
|
|
lemma pteBits_pte_bits[simp]:
|
|
"pteBits = pte_bits"
|
|
by (simp add: bit_simps pteBits_def)
|
|
|
|
lemma cte_map_in_cnode1:
|
|
"\<lbrakk> x \<le> x + 2 ^ (cte_level_bits + length y) - 1 \<rbrakk> \<Longrightarrow> x \<le> cte_map (x, y)"
|
|
apply (simp add: cte_map_def)
|
|
apply (rule word_plus_mono_right2[where b="mask (cte_level_bits + length y)"])
|
|
apply (simp add: mask_def add_diff_eq)
|
|
apply (rule leq_high_bits_shiftr_low_bits_leq_bits)
|
|
apply (rule of_bl_max)
|
|
done
|
|
|
|
lemma pspace_aligned_cross:
|
|
"\<lbrakk> pspace_aligned s; pspace_relation (kheap s) (ksPSpace s') \<rbrakk> \<Longrightarrow> pspace_aligned' s'"
|
|
apply (clarsimp simp: pspace_aligned'_def pspace_aligned_def pspace_relation_def)
|
|
apply (rename_tac p' ko')
|
|
apply (prop_tac "p' \<in> pspace_dom (kheap s)", fastforce)
|
|
apply (thin_tac "pspace_dom k = p" for k p)
|
|
apply (clarsimp simp: pspace_dom_def)
|
|
apply (drule bspec, fastforce)+
|
|
apply clarsimp
|
|
apply (erule (1) obj_relation_cutsE; clarsimp simp: objBits_simps)
|
|
apply (clarsimp simp: cte_map_def)
|
|
apply (simp add: cteSizeBits_def cte_level_bits_def)
|
|
apply (rule is_aligned_add)
|
|
apply (erule is_aligned_weaken)
|
|
apply simp
|
|
apply (rule is_aligned_shift)
|
|
apply (rule is_aligned_add)
|
|
apply (erule is_aligned_weaken)
|
|
apply (simp add: bit_simps)
|
|
apply (rule is_aligned_shift)
|
|
apply (rule is_aligned_add)
|
|
apply (erule is_aligned_weaken)
|
|
apply (rule pbfs_atleast_pageBits)
|
|
apply (rule is_aligned_shift)
|
|
apply (simp add: other_obj_relation_def)
|
|
apply (clarsimp simp: bit_simps' tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def
|
|
split: kernel_object.splits Structures_A.kernel_object.splits)
|
|
apply (clarsimp simp: archObjSize_def bit_simps
|
|
split: arch_kernel_object.splits arch_kernel_obj.splits)
|
|
apply (erule is_aligned_weaken, simp add: bit_simps)+
|
|
done
|
|
|
|
lemma of_bl_shift_cte_level_bits:
|
|
"(of_bl z :: machine_word) << cte_level_bits \<le> mask (cte_level_bits + length z)"
|
|
by word_bitwise
|
|
(simp add: test_bit_of_bl bit_simps word_size cte_level_bits_def rev_bl_order_simps)
|
|
|
|
lemma obj_relation_cuts_range_limit:
|
|
"\<lbrakk> (p', P) \<in> obj_relation_cuts ko p; P ko ko' \<rbrakk>
|
|
\<Longrightarrow> \<exists>x n. p' = p + x \<and> is_aligned x n \<and> n \<le> obj_bits ko \<and> x \<le> mask (obj_bits ko)"
|
|
apply (erule (1) obj_relation_cutsE; clarsimp)
|
|
apply (drule (1) wf_cs_nD)
|
|
apply (clarsimp simp: cte_map_def)
|
|
apply (rule_tac x=cte_level_bits in exI)
|
|
apply (simp add: is_aligned_shift of_bl_shift_cte_level_bits)
|
|
apply (rule_tac x=pte_bits in exI)
|
|
apply (simp add: is_aligned_shift mask_def)
|
|
apply (rule shiftl_less_t2n)
|
|
apply (simp add: table_size_def)
|
|
apply (simp add: bit_simps)
|
|
apply (rule_tac x=pageBits in exI)
|
|
apply (simp add: is_aligned_shift pbfs_atleast_pageBits)
|
|
apply (simp add: mask_def shiftl_t2n mult_ac)
|
|
apply (erule word_less_power_trans2, rule pbfs_atleast_pageBits)
|
|
apply (simp add: pbfs_less_wb'[unfolded word_bits_def, simplified])
|
|
apply fastforce
|
|
done
|
|
|
|
lemma obj_relation_cuts_range_mask_range:
|
|
"\<lbrakk> (p', P) \<in> obj_relation_cuts ko p; P ko ko'; is_aligned p (obj_bits ko) \<rbrakk>
|
|
\<Longrightarrow> p' \<in> mask_range p (obj_bits ko)"
|
|
apply (drule (1) obj_relation_cuts_range_limit, clarsimp)
|
|
apply (rule conjI)
|
|
apply (rule word_plus_mono_right2; assumption?)
|
|
apply (simp add: is_aligned_no_overflow_mask)
|
|
apply (erule word_plus_mono_right)
|
|
apply (simp add: is_aligned_no_overflow_mask)
|
|
done
|
|
|
|
lemma obj_relation_cuts_obj_bits:
|
|
"\<lbrakk> (p', P) \<in> obj_relation_cuts ko p; P ko ko' \<rbrakk> \<Longrightarrow> objBitsKO ko' \<le> obj_bits ko"
|
|
apply (erule (1) obj_relation_cutsE;
|
|
clarsimp simp: objBits_simps objBits_defs bit_simps cte_level_bits_def
|
|
pbfs_atleast_pageBits[simplified bit_simps])
|
|
apply (cases ko; simp add: other_obj_relation_def objBits_defs split: kernel_object.splits)
|
|
apply (rename_tac ako, case_tac ako; clarsimp;
|
|
rename_tac ako', case_tac ako'; clarsimp simp: archObjSize_def)
|
|
done
|
|
|
|
lemmas is_aligned_add_step_le' = is_aligned_add_step_le[simplified mask_2pm1 add_diff_eq]
|
|
|
|
lemma pspace_distinct_cross:
|
|
"\<lbrakk> pspace_distinct s; pspace_aligned s; pspace_relation (kheap s) (ksPSpace s') \<rbrakk> \<Longrightarrow>
|
|
pspace_distinct' s'"
|
|
apply (frule (1) pspace_aligned_cross)
|
|
apply (clarsimp simp: pspace_distinct'_def)
|
|
apply (rename_tac p' ko')
|
|
apply (rule pspace_dom_relatedE; assumption?)
|
|
apply (rename_tac p ko P)
|
|
apply (frule (1) pspace_alignedD')
|
|
apply (frule (1) pspace_alignedD)
|
|
apply (rule ps_clearI, assumption)
|
|
apply (case_tac ko'; simp add: objBits_simps objBits_defs bit_simps')
|
|
apply (simp split: arch_kernel_object.splits add: bit_simps')
|
|
apply (rule ccontr, clarsimp)
|
|
apply (rename_tac x' ko_x')
|
|
apply (frule_tac x=x' in pspace_alignedD', assumption)
|
|
apply (rule_tac x=x' in pspace_dom_relatedE; assumption?)
|
|
apply (rename_tac x ko_x P')
|
|
apply (frule_tac p=x in pspace_alignedD, assumption)
|
|
apply (case_tac "p = x")
|
|
apply clarsimp
|
|
apply (erule (1) obj_relation_cutsE; clarsimp)
|
|
apply (clarsimp simp: cte_relation_def cte_map_def objBits_simps)
|
|
apply (rule_tac n=cte_level_bits in is_aligned_add_step_le'; assumption?)
|
|
apply (rule is_aligned_add; (rule is_aligned_shift)?)
|
|
apply (erule is_aligned_weaken, simp add: cte_level_bits_def)
|
|
apply (rule is_aligned_add; (rule is_aligned_shift)?)
|
|
apply (erule is_aligned_weaken, simp add: cte_level_bits_def)
|
|
apply (simp add: cte_level_bits_def cteSizeBits_def)
|
|
apply (clarsimp simp: pte_relation_def objBits_simps)
|
|
apply (rule_tac n=pte_bits in is_aligned_add_step_le'; assumption?)
|
|
apply (simp add: objBitsKO_Data)
|
|
apply (rule_tac n=pageBits in is_aligned_add_step_le'; assumption?)
|
|
apply (case_tac ko; simp split: if_split_asm add: is_other_obj_relation_type_CapTable)
|
|
apply (rename_tac ako, case_tac ako; simp add: is_other_obj_relation_type_def split: if_split_asm)
|
|
apply (frule (1) obj_relation_cuts_obj_bits)
|
|
apply (drule (2) obj_relation_cuts_range_mask_range)+
|
|
apply (prop_tac "x' \<in> mask_range p' (objBitsKO ko')", simp add: mask_def add_diff_eq)
|
|
apply (frule_tac x=p and y=x in pspace_distinctD; assumption?)
|
|
apply (drule (4) mask_range_subsetD)
|
|
apply (erule (2) in_empty_interE)
|
|
done
|
|
|
|
lemma asid_pool_at_cross:
|
|
"\<lbrakk> asid_pool_at p s; pspace_relation (kheap s) (ksPSpace s');
|
|
pspace_aligned s; pspace_distinct s \<rbrakk>
|
|
\<Longrightarrow> asid_pool_at' p s'"
|
|
apply (drule (2) pspace_distinct_cross)
|
|
apply (clarsimp simp: obj_at_def typ_at'_def ko_wp_at'_def)
|
|
apply (prop_tac "p \<in> pspace_dom (kheap s)")
|
|
apply (clarsimp simp: pspace_dom_def)
|
|
apply (rule bexI)
|
|
prefer 2
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (clarsimp simp: pspace_relation_def)
|
|
apply (drule bspec, fastforce)
|
|
apply (clarsimp simp: other_obj_relation_def split: kernel_object.splits arch_kernel_object.splits)
|
|
apply (clarsimp simp: objBits_simps)
|
|
apply (frule (1) pspace_alignedD)
|
|
apply (rule conjI, simp add: bit_simps)
|
|
apply (clarsimp simp: pspace_distinct'_def)
|
|
apply (drule bspec, fastforce)
|
|
apply (simp add: objBits_simps)
|
|
done
|
|
|
|
lemma corres_cross_over_asid_pool_at:
|
|
"\<lbrakk> \<And>s. P s \<Longrightarrow> asid_pool_at p s \<and> pspace_distinct s \<and> pspace_aligned s;
|
|
corres r P (Q and asid_pool_at' p) f g \<rbrakk> \<Longrightarrow>
|
|
corres r P Q f g"
|
|
apply (rule corres_cross_over_guard[where Q="Q and asid_pool_at' p"])
|
|
apply (drule meta_spec, drule (1) meta_mp, clarsimp)
|
|
apply (erule asid_pool_at_cross, clarsimp simp: state_relation_def; assumption)
|
|
apply assumption
|
|
done
|
|
|
|
lemma getObject_ASIDPool_corres:
|
|
"p' = p \<Longrightarrow>
|
|
corres asid_pool_relation
|
|
(asid_pool_at p and pspace_aligned and pspace_distinct) \<top>
|
|
(get_asid_pool p) (getObject p')"
|
|
apply (rule corres_cross_over_asid_pool_at, fastforce)
|
|
apply (simp add: getObject_def gets_map_def split_def)
|
|
apply (rule corres_no_failI)
|
|
apply (rule no_fail_pre, wp)
|
|
apply (clarsimp simp: typ_at'_def ko_wp_at'_def)
|
|
apply (case_tac ko; simp)
|
|
apply (rename_tac arch_kernel_object)
|
|
apply (case_tac arch_kernel_object, simp_all)[1]
|
|
apply (clarsimp simp: lookupAround2_known1)
|
|
apply (clarsimp simp: obj_at'_def objBits_simps)
|
|
apply (erule (1) ps_clear_lookupAround2)
|
|
apply simp
|
|
apply (erule is_aligned_no_overflow)
|
|
apply simp
|
|
apply (clarsimp simp add: objBits_simps
|
|
split: option.split)
|
|
apply (clarsimp simp: in_monad loadObject_default_def)
|
|
apply (simp add: bind_assoc exec_gets)
|
|
apply (drule asid_pool_at_ko)
|
|
apply (clarsimp simp: obj_at_def assert_opt_def fail_def return_def in_omonad
|
|
split: option.split)
|
|
apply (simp add: in_magnitude_check objBits_simps pageBits_def)
|
|
apply (clarsimp simp: state_relation_def pspace_relation_def)
|
|
apply (drule bspec, blast)
|
|
apply (clarsimp simp: other_obj_relation_def)
|
|
done
|
|
|
|
lemma aligned_distinct_obj_atI':
|
|
"\<lbrakk> ksPSpace s x = Some ko; pspace_aligned' s; pspace_distinct' s; ko = injectKO v \<rbrakk>
|
|
\<Longrightarrow> ko_at' v x s"
|
|
apply (simp add: obj_at'_def project_inject pspace_distinct'_def pspace_aligned'_def)
|
|
apply (drule bspec, erule domI)+
|
|
apply simp
|
|
done
|
|
|
|
lemma storePTE_cte_wp_at'[wp]:
|
|
"storePTE ptr val \<lbrace>\<lambda>s. P (cte_wp_at' P' p s)\<rbrace>"
|
|
apply (simp add: storePTE_def)
|
|
apply (wp setObject_cte_wp_at2'[where Q="\<top>"])
|
|
apply (clarsimp simp: updateObject_default_def in_monad projectKO_opts_defs)
|
|
apply (rule equals0I)
|
|
apply (clarsimp simp: updateObject_default_def in_monad projectKO_opts_defs)
|
|
apply simp
|
|
done
|
|
|
|
lemma storePTE_state_refs_of[wp]:
|
|
"storePTE ptr val \<lbrace>\<lambda>s. P (state_refs_of' s)\<rbrace>"
|
|
unfolding storePTE_def
|
|
apply (wp setObject_state_refs_of_eq;
|
|
clarsimp simp: updateObject_default_def in_monad)
|
|
done
|
|
|
|
lemma storePTE_state_hyp_refs_of[wp]:
|
|
"\<lbrace>\<lambda>s. P (state_hyp_refs_of' s)\<rbrace>
|
|
storePTE ptr val
|
|
\<lbrace>\<lambda>rv s. P (state_hyp_refs_of' s)\<rbrace>"
|
|
by (wpsimp wp: hoare_drop_imps setObject_state_hyp_refs_of_eq
|
|
simp: storePTE_def updateObject_default_def in_monad)
|
|
|
|
crunch cte_wp_at'[wp]: setIRQState "\<lambda>s. P (cte_wp_at' P' p s)"
|
|
crunch inv[wp]: getIRQSlot "P"
|
|
|
|
lemma setObject_ASIDPool_corres[corres]:
|
|
"\<lbrakk> p = p'; a = map_option abs_asid_entry o inv ASIDPool a' o ucast \<rbrakk> \<Longrightarrow>
|
|
corres dc (asid_pool_at p and pspace_aligned and pspace_distinct) \<top>
|
|
(set_asid_pool p a) (setObject p' a')"
|
|
apply (simp add: set_asid_pool_def)
|
|
apply (rule corres_underlying_symb_exec_l[where P=P and Q="\<lambda>_. P" for P])
|
|
apply (rule corres_no_failI; clarsimp)
|
|
apply (clarsimp simp: gets_map_def bind_def simpler_gets_def assert_opt_def fail_def return_def
|
|
obj_at_def in_omonad
|
|
split: option.splits)
|
|
prefer 2
|
|
apply wpsimp
|
|
apply (rule corres_cross_over_asid_pool_at, fastforce)
|
|
apply (rule corres_guard_imp)
|
|
apply (rule setObject_other_corres [where P="\<lambda>ko::asidpool. True"])
|
|
apply simp
|
|
apply (clarsimp simp: obj_at'_def)
|
|
apply (erule map_to_ctes_upd_other, simp, simp)
|
|
apply (simp add: a_type_def is_other_obj_relation_type_def)
|
|
apply (simp add: objBits_simps)
|
|
apply simp
|
|
apply (simp add: objBits_simps pageBits_def)
|
|
apply (simp add: other_obj_relation_def asid_pool_relation_def)
|
|
apply (simp add: typ_at'_def obj_at'_def ko_wp_at'_def)
|
|
apply clarsimp
|
|
apply (rename_tac arch_kernel_object)
|
|
apply (case_tac arch_kernel_object; simp)
|
|
apply (clarsimp simp: obj_at_def exs_valid_def assert_def a_type_def return_def fail_def)
|
|
apply (auto split: Structures_A.kernel_object.split_asm arch_kernel_obj.split_asm if_split_asm)[1]
|
|
apply (simp add: typ_at_to_obj_at_arches)
|
|
done
|
|
|
|
lemma p_le_table_base:
|
|
"is_aligned p pte_bits \<Longrightarrow> p + mask pte_bits \<le> table_base pt_t p + mask (table_size pt_t)"
|
|
apply (simp add: is_aligned_mask word_plus_and_or_coroll table_size_def pt_bits_def)
|
|
apply (subst word_plus_and_or_coroll, word_eqI_solve)
|
|
apply word_bitwise
|
|
apply (simp add: word_size bit_simps)
|
|
done
|
|
|
|
lemma table_index_in_table:
|
|
"table_index pt_t p \<le> mask (ptTranslationBits pt_t)"
|
|
by (simp add: pt_bits_def table_size_def word_bool_le_funs flip: shiftr_then_mask_commute)
|
|
|
|
lemma pte_at_cross:
|
|
"\<lbrakk> pte_at pt_t p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s; pspace_distinct s \<rbrakk>
|
|
\<Longrightarrow> pte_at' p s'"
|
|
apply (drule (2) pspace_distinct_cross)
|
|
apply (clarsimp simp: pte_at_def ptes_of_def in_omonad obj_at_def typ_at'_def ko_wp_at'_def)
|
|
apply (simp split: if_split_asm)
|
|
apply (prop_tac "p \<in> pspace_dom (kheap s)")
|
|
apply (clarsimp simp: pspace_dom_def)
|
|
apply (rule bexI)
|
|
prefer 2
|
|
apply fastforce
|
|
apply (clarsimp simp: ran_def image_iff)
|
|
apply (rule_tac x="table_index pt_t p" in bexI)
|
|
apply (simp add: table_base_index_eq)
|
|
apply (simp add: table_index_in_table)
|
|
apply (clarsimp simp: pspace_relation_def)
|
|
apply (drule bspec, fastforce)
|
|
apply clarsimp
|
|
apply (drule_tac x="table_index pt_t p" in bspec)
|
|
apply (simp add: table_index_in_table)
|
|
apply (simp add: table_base_index_eq)
|
|
apply (clarsimp simp: pte_relation_def)
|
|
apply (clarsimp simp: objBits_simps)
|
|
apply (clarsimp simp: pspace_distinct'_def)
|
|
apply (drule bspec, fastforce)
|
|
apply (simp add: objBits_simps)
|
|
done
|
|
|
|
lemma corres_cross_over_pte_at:
|
|
"\<lbrakk> \<And>s. P s \<Longrightarrow> pte_at pt_t p s \<and> pspace_distinct s \<and> pspace_aligned s;
|
|
corres r P (P' and pte_at' p) f g\<rbrakk> \<Longrightarrow>
|
|
corres r P P' f g"
|
|
apply (rule corres_cross_over_guard[where Q="P' and pte_at' p"])
|
|
apply (drule meta_spec, drule (1) meta_mp, clarsimp)
|
|
apply (erule pte_at_cross; assumption?)
|
|
apply (simp add: state_relation_def)
|
|
apply assumption
|
|
done
|
|
|
|
lemma getObject_PTE_corres:
|
|
"corres pte_relation' (pte_at pt_t p and pspace_aligned and pspace_distinct) \<top>
|
|
(get_pte pt_t p) (getObject p)"
|
|
apply (rule corres_cross_over_pte_at, fastforce)
|
|
apply (simp add: getObject_def gets_map_def split_def bind_assoc)
|
|
apply (rule corres_no_failI)
|
|
apply (rule no_fail_pre, wp)
|
|
apply (clarsimp simp: ko_wp_at'_def typ_at'_def lookupAround2_known1)
|
|
apply (case_tac ko, simp_all)[1]
|
|
apply (rename_tac arch_kernel_object)
|
|
apply (case_tac arch_kernel_object; simp)
|
|
apply (clarsimp simp: objBits_def cong: option.case_cong)
|
|
apply (erule (1) ps_clear_lookupAround2)
|
|
apply simp
|
|
apply (erule is_aligned_no_overflow)
|
|
apply (simp add: objBits_simps word_bits_def)
|
|
apply simp
|
|
apply (clarsimp simp: in_monad loadObject_default_def)
|
|
apply (simp add: bind_assoc exec_gets fst_assert_opt)
|
|
apply (clarsimp simp: pte_at_eq)
|
|
apply (clarsimp simp: ptes_of_def)
|
|
apply (clarsimp simp: typ_at'_def ko_wp_at'_def in_magnitude_check objBits_simps pte_bits_def word_size_bits_def)
|
|
apply (clarsimp simp: state_relation_def pspace_relation_def elim!: opt_mapE)
|
|
apply (drule bspec, blast)
|
|
apply (clarsimp simp: other_obj_relation_def pte_relation_def)
|
|
apply (drule_tac x="table_index pt_t p" in bspec)
|
|
apply (simp add: table_index_in_table)
|
|
apply (clarsimp simp: table_base_index_eq[simplified bit_simps] bit_simps)
|
|
done
|
|
|
|
lemmas aligned_distinct_pte_atI'
|
|
= aligned_distinct_obj_atI'[where 'a=pte,
|
|
simplified, OF _ _ _ refl]
|
|
|
|
lemma one_less_2p_pte_bits[simp]:
|
|
"(1::machine_word) < 2 ^ pte_bits"
|
|
by (simp add: bit_simps)
|
|
|
|
lemma pt_apply_upd_eq':
|
|
"idx \<le> mask (ptTranslationBits (pt_type pt)) \<Longrightarrow>
|
|
pt_apply (pt_upd pt (table_index (pt_type pt) p) pte) idx =
|
|
(if table_index (pt_type pt) p = idx then pte else pt_apply pt idx)"
|
|
unfolding pt_apply_def pt_upd_def
|
|
using table_index_mask_eq[where pt_t=NormalPT_T] table_index_mask_eq[where pt_t=VSRootPT_T]
|
|
by (cases pt; clarsimp simp: ucast_eq_mask vs_index_ptTranslationBits pt_index_ptTranslationBits
|
|
word_le_mask_eq)
|
|
|
|
\<comment> \<open>setObject_other_corres unfortunately doesn't work here\<close>
|
|
lemma setObject_PT_corres:
|
|
"pte_relation' pte pte' \<Longrightarrow>
|
|
corres dc ((\<lambda>s. pts_of s (table_base pt_t p) = Some pt) and K (is_aligned p pte_bits \<and> pt_type pt = pt_t) and
|
|
pspace_aligned and pspace_distinct) \<top>
|
|
(set_pt (table_base pt_t p) (pt_upd pt (table_index pt_t p) pte))
|
|
(setObject p pte')"
|
|
apply (rule corres_cross_over_pte_at[where p=p])
|
|
apply (fastforce simp: pte_at_eq ptes_of_def in_omonad)
|
|
apply (simp add: set_pt_def get_object_def bind_assoc set_object_def gets_map_def)
|
|
apply (rule corres_no_failI)
|
|
apply (rule no_fail_pre, wp)
|
|
apply simp
|
|
apply (clarsimp simp: obj_at'_def ko_wp_at'_def typ_at'_def lookupAround2_known1)
|
|
apply (case_tac ko; simp)
|
|
apply (rename_tac arch_kernel_object)
|
|
apply (case_tac arch_kernel_object; simp)
|
|
apply (simp add: objBits_simps word_bits_def)
|
|
apply (clarsimp simp: setObject_def in_monad split_def updateObject_default_def)
|
|
apply (simp add: in_magnitude_check objBits_simps a_type_simps)
|
|
apply (clarsimp simp: obj_at_def exec_gets)
|
|
apply (clarsimp simp: exec_get put_def elim!: opt_mapE)
|
|
apply (clarsimp simp: state_relation_def)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: pspace_relation_def split del: if_split)
|
|
apply (rule conjI)
|
|
apply (subst pspace_dom_update, assumption)
|
|
apply (simp add: a_type_def)
|
|
apply (auto simp: dom_def)[1]
|
|
apply (rule conjI)
|
|
apply (drule bspec, blast)
|
|
apply clarsimp
|
|
apply (drule_tac x = x in bspec)
|
|
apply simp
|
|
apply (rule conjI; clarsimp)
|
|
apply (clarsimp simp: pte_relation_def pt_apply_upd_eq')
|
|
apply (metis more_pt_inner_beauty)
|
|
apply (clarsimp simp: pte_relation_def table_base_index_eq pt_apply_upd_eq'
|
|
dest!: more_pt_inner_beauty)
|
|
apply (rule ballI)
|
|
apply (drule (1) bspec)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: pte_relation_def pt_apply_upd_eq')
|
|
apply (metis more_pt_inner_beauty table_base_index_eq)
|
|
apply clarsimp
|
|
apply (drule bspec, assumption)
|
|
apply clarsimp
|
|
apply (erule (1) obj_relation_cutsE)
|
|
apply simp
|
|
apply clarsimp
|
|
apply (smt (verit, best) pspace_aligned_pts_ofD pts_of_Some pts_of_type_unique aobjs_of_Some
|
|
table_base_plus)
|
|
apply ((simp split: if_split_asm)+)[2]
|
|
apply (simp add: other_obj_relation_def
|
|
split: Structures_A.kernel_object.splits arch_kernel_obj.splits)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: ekheap_relation_def pspace_relation_def)
|
|
apply (drule_tac x=p in bspec, erule domI)
|
|
apply (simp add: other_obj_relation_def
|
|
split: Structures_A.kernel_object.splits)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp add: ghost_relation_def)
|
|
apply (erule_tac x="p && ~~ mask (pt_bits (pt_type pt))" in allE)+
|
|
apply fastforce
|
|
apply (simp add: map_to_ctes_upd_other)
|
|
apply (simp add: fun_upd_def)
|
|
apply (simp add: caps_of_state_after_update obj_at_def swp_cte_at_caps_of)
|
|
done
|
|
|
|
lemma storePTE_corres:
|
|
"pte_relation' pte pte' \<Longrightarrow>
|
|
corres dc (pte_at pt_t p and pspace_aligned and pspace_distinct) \<top> (store_pte pt_t p pte) (storePTE p pte')"
|
|
apply (simp add: store_pte_def storePTE_def)
|
|
apply (rule corres_assume_pre)
|
|
apply (rule corres_symb_exec_l)
|
|
apply (rule corres_symb_exec_l[where P="pte_at pt_t p and pspace_aligned and pspace_distinct"])
|
|
apply (rule corres_symb_exec_l)
|
|
apply (erule setObject_PT_corres)
|
|
prefer 2
|
|
apply (rule assert_inv)
|
|
apply wpsimp
|
|
apply wpsimp
|
|
prefer 2
|
|
apply (wpsimp simp: ptes_of_def in_omonad obj_at_def pte_at_def split: if_split_asm)
|
|
apply (clarsimp simp: exs_valid_def gets_map_def fst_assert_opt in_omonad ptes_of_def
|
|
exec_gets pte_at_def)
|
|
apply (wpsimp simp: pte_at_def ptes_of_def in_omonad)
|
|
apply (wpsimp simp: pte_at_def2)
|
|
apply wpsimp
|
|
apply (wpsimp simp: pte_at_def2)
|
|
done
|
|
|
|
lemmas tableBitSimps[simplified bit_simps pteBits_pte_bits, simplified] = ptBits_def
|
|
lemmas bitSimps = tableBitSimps
|
|
|
|
lemma bit_simps_corres[simp]:
|
|
"ptBits pt_t = pt_bits pt_t"
|
|
by (simp add: bit_simps bitSimps)
|
|
|
|
defs checkPTAt_def:
|
|
"checkPTAt p \<equiv> stateAssert (\<lambda>s. \<exists>pt. page_table_at' pt p s) []"
|
|
|
|
lemma pte_relation_must_pte:
|
|
"pte_relation m (ArchObj (PageTable pt)) ko \<Longrightarrow> \<exists>pte. ko = (KOArch (KOPTE pte))"
|
|
apply (case_tac ko)
|
|
apply (simp_all add:pte_relation_def)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma page_table_at_cross:
|
|
"\<lbrakk> pt_at pt_t p s; pspace_aligned s; pspace_distinct s; pspace_relation (kheap s) (ksPSpace s') \<rbrakk> \<Longrightarrow>
|
|
page_table_at' pt_t p s'"
|
|
apply (clarsimp simp: page_table_at'_def)
|
|
apply (rule context_conjI)
|
|
apply (clarsimp simp: obj_at_def)
|
|
apply (frule (1) pspace_alignedD)
|
|
apply (clarsimp simp: bit_simps split: if_splits)
|
|
apply clarsimp
|
|
apply (rule pte_at_cross; assumption?)
|
|
apply (erule (2) page_table_pte_atI_nicer)
|
|
done
|
|
|
|
lemma getPTE_wp:
|
|
"\<lbrace>\<lambda>s. \<forall>ko. ko_at' (ko::pte) p s \<longrightarrow> Q ko s\<rbrace> getObject p \<lbrace>Q\<rbrace>"
|
|
by (clarsimp simp: getObject_def split_def loadObject_default_def in_magnitude_check
|
|
in_monad valid_def obj_at'_def objBits_simps)
|
|
|
|
lemma pt_at_lift:
|
|
"corres_inst_eq ptr ptr' \<Longrightarrow> \<forall>s s'. (s, s') \<in> state_relation \<longrightarrow> True \<longrightarrow>
|
|
(pspace_aligned s \<and> pspace_distinct s \<and> pt_at pt_t ptr s \<and> ptr = ptr') \<longrightarrow>
|
|
\<top> s' \<longrightarrow> page_table_at' pt_t ptr' s'"
|
|
by ( fastforce intro!: page_table_at_cross)
|
|
|
|
lemmas checkPTAt_corres[corresK] =
|
|
corres_stateAssert_implied_frame[OF pt_at_lift, folded checkPTAt_def]
|
|
|
|
lemma lookupPTSlotFromLevel_inv:
|
|
"lookupPTSlotFromLevel level pt_ptr vptr \<lbrace>P\<rbrace>"
|
|
apply (induct level arbitrary: pt_ptr)
|
|
apply (subst lookupPTSlotFromLevel.simps)
|
|
apply (wpsimp simp: pteAtIndex_def wp: getPTE_wp)
|
|
apply (subst lookupPTSlotFromLevel.simps)
|
|
apply (wpsimp simp: pteAtIndex_def checkPTAt_def wp: getPTE_wp|assumption)+
|
|
done
|
|
|
|
declare lookupPTSlotFromLevel_inv[wp]
|
|
|
|
lemma lookupPTFromLevel_inv[wp]:
|
|
"lookupPTFromLevel level pt vptr target_pt \<lbrace>P\<rbrace>"
|
|
proof (induct level arbitrary: pt)
|
|
case 0 show ?case
|
|
by (subst lookupPTFromLevel.simps, simp add: checkPTAt_def, wpsimp)
|
|
next
|
|
case (Suc level)
|
|
show ?case
|
|
by (subst lookupPTFromLevel.simps, simp add: checkPTAt_def)
|
|
(wpsimp wp: Suc getPTE_wp simp: pteAtIndex_def)
|
|
qed
|
|
|
|
lemma size_maxPTLevel[simp]:
|
|
"size max_pt_level = maxPTLevel"
|
|
by (simp add: maxPTLevel_def level_defs)
|
|
|
|
lemma ptBitsLeft_0[simp]:
|
|
"ptBitsLeft 0 = pageBits"
|
|
by (simp add: ptBitsLeft_def)
|
|
|
|
lemma ptBitsLeft_eq[simp]:
|
|
"ptBitsLeft (size level) = pt_bits_left level"
|
|
unfolding ptBitsLeft_def pt_bits_left_def
|
|
by (clarsimp simp flip: vm_level.size_less_eq
|
|
simp: asid_pool_level_size ptTranslationBits_def maxPTLevel_def
|
|
split: if_splits)
|
|
|
|
lemma ptIndex_eq[simp]:
|
|
"ptIndex (size level) p = pt_index level p"
|
|
by (clarsimp simp: ptIndex_def pt_index_def levelType_def
|
|
simp flip: size_maxPTLevel level_type_eq(1))
|
|
|
|
lemma ptSlotIndex_eq[simp]:
|
|
"ptSlotIndex (size level) = pt_slot_offset level"
|
|
by (clarsimp intro!: ext simp: ptSlotIndex_def pt_slot_offset_def)
|
|
|
|
lemmas ptSlotIndex_0[simp] = ptSlotIndex_eq[where level=0, simplified]
|
|
|
|
lemma pteAtIndex_corres:
|
|
"level' = size level \<Longrightarrow>
|
|
corres pte_relation'
|
|
(pte_at pt_t (pt_slot_offset level pt vptr) and pspace_aligned and pspace_distinct)
|
|
\<top>
|
|
(get_pte pt_t (pt_slot_offset level pt vptr))
|
|
(pteAtIndex level' pt vptr)"
|
|
by (simp add: pteAtIndex_def) (rule getObject_PTE_corres)
|
|
|
|
lemma user_region_or:
|
|
"\<lbrakk> vref \<in> user_region; vref' \<in> user_region \<rbrakk> \<Longrightarrow> vref || vref' \<in> user_region"
|
|
by (simp add: user_region_def canonical_user_def le_mask_high_bits word_size)
|
|
|
|
lemma lookupPTSlotFromLevel_corres:
|
|
"\<lbrakk> level' = size level; pt' = pt; level \<le> max_pt_level \<rbrakk> \<Longrightarrow>
|
|
corres (\<lambda>(level, p) (bits, p'). bits = pt_bits_left level \<and> p' = p)
|
|
(pspace_aligned and pspace_distinct and valid_vspace_objs and valid_asid_table and
|
|
\<exists>\<rhd> (level, pt) and K (vptr \<in> user_region \<and> level \<le> max_pt_level))
|
|
\<top>
|
|
(gets_the (pt_lookup_slot_from_level level 0 pt vptr \<circ> ptes_of))
|
|
(lookupPTSlotFromLevel level' pt' vptr)"
|
|
proof (induct level arbitrary: pt pt' level')
|
|
case 0
|
|
thus ?case by (simp add: lookupPTSlotFromLevel.simps pt_bits_left_def)
|
|
next
|
|
case (minus level)
|
|
from `0 < level`
|
|
obtain nlevel where nlevel: "level = nlevel + 1" by (auto intro: that[of "level-1"])
|
|
with `0 < level`
|
|
have nlevel1: "nlevel < nlevel + 1" using bit1.pred by fastforce
|
|
with nlevel
|
|
have level: "size level = Suc (size nlevel)" by simp
|
|
|
|
from `0 < level` `level \<le> max_pt_level`
|
|
have level_m1: "level - 1 \<le> max_pt_level"
|
|
by blast
|
|
|
|
from level
|
|
have levelType[simp]:
|
|
"levelType (Suc (size nlevel)) = level_type level"
|
|
unfolding levelType_def using vm_level.size_inj
|
|
by fastforce
|
|
|
|
define vref_step where
|
|
"vref_step vref \<equiv> vref_for_level vref (level+1) || (pt_index level vptr << pt_bits_left level)"
|
|
for vref
|
|
|
|
from `level \<le> max_pt_level`
|
|
have vref_for_level_step[simp]:
|
|
"vref_for_level (vref_step vref) (level + 1) = vref_for_level vref (level + 1)"
|
|
for vref
|
|
unfolding vref_step_def
|
|
using vref_for_level_pt_index_idem[of level level level vref vptr] by simp
|
|
|
|
from `level \<le> max_pt_level`
|
|
have pt_walk_vref[simp]:
|
|
"pt_walk max_pt_level level pt (vref_step vref) =
|
|
pt_walk max_pt_level level pt vref" for pt vref
|
|
by - (rule pt_walk_vref_for_level_eq; simp)
|
|
|
|
from `level \<le> max_pt_level`
|
|
have vref_step_user_region[simp]:
|
|
"\<lbrakk> vref \<in> user_region; vptr \<in> user_region \<rbrakk> \<Longrightarrow> vref_step vref \<in> user_region"
|
|
for vref
|
|
unfolding vref_step_def
|
|
using nlevel1 nlevel
|
|
by (auto intro!: user_region_or vref_for_level_user_region
|
|
simp: pt_bits_left_def bit_simps user_region_def
|
|
pt_index_def canonical_user_def word_eqI_simps
|
|
dest!: max_pt_level_enum)
|
|
|
|
have pt_slot_offset_step[simp]:
|
|
"\<lbrakk> is_aligned pt (pt_bits level); vref \<in> user_region \<rbrakk> \<Longrightarrow>
|
|
pt_slot_offset level pt (vref_step vref) = pt_slot_offset level pt vptr" for vref
|
|
unfolding vref_step_def using nlevel1 nlevel
|
|
apply simp
|
|
apply (clarsimp simp: pt_slot_offset_or_def user_region_def canonical_user_def)
|
|
apply (simp add: pt_index_def pt_bits_left_def)
|
|
apply (rule conjI; clarsimp)
|
|
apply (simp add: plus_one_eq_asid_pool vref_for_level_def pt_bits_left_def)
|
|
apply (rule conjI, simp add: max_pt_level_def)
|
|
apply (clarsimp simp: level_defs bit_simps maxPTLevel_def)
|
|
apply word_eqI_solve
|
|
apply (clarsimp simp: vref_for_level_def pt_bits_left_def)
|
|
apply (rule conjI; clarsimp)
|
|
apply (subgoal_tac "nlevel = max_pt_level - 1")
|
|
apply (clarsimp simp: level_defs bit_simps maxPTLevel_def split: if_split_asm)
|
|
apply word_eqI_solve
|
|
apply (subst (asm) add.commute[where a=2])
|
|
apply (drule add_implies_diff)
|
|
apply (simp add: max_pt_level_def)
|
|
apply (simp add: pt_bits_def)
|
|
apply (prop_tac "level_type (nlevel + 1) = NormalPT_T")
|
|
apply (drule max_pt_level_enum)
|
|
apply (auto simp: level_defs split: if_split_asm)[1]
|
|
apply (simp add: bit_simps)
|
|
apply word_eqI
|
|
apply (drule max_pt_level_enum)
|
|
by (auto split: if_split_asm)
|
|
|
|
from `0 < level` `level' = size level` `pt' = pt` level `level \<le> max_pt_level` level_m1
|
|
show ?case
|
|
apply (subst pt_lookup_slot_from_level_rec)
|
|
apply (simp add: lookupPTSlotFromLevel.simps Let_def obind_comp_dist if_comp_dist
|
|
gets_the_if_distrib checkPTAt_def gets_the_oapply2_comp)
|
|
apply (rule corres_guard_imp, rule corres_split[where r'=pte_relation'])
|
|
apply (rule pteAtIndex_corres, simp)
|
|
apply (rule corres_if3)
|
|
apply (rename_tac pte pte', case_tac pte; (simp add: isPageTablePTE_def))
|
|
apply (rule corres_stateAssert_implied)
|
|
apply (rule minus(1))
|
|
apply (simp add: nlevel)
|
|
apply (clarsimp simp: AARCH64_A.is_PageTablePTE_def pptr_from_pte_def getPPtrFromPTE_def
|
|
paddr_from_ppn_def isPagePTE_def)
|
|
apply simp
|
|
apply clarsimp
|
|
apply (rule_tac x=NormalPT_T in exI)
|
|
apply (rule page_table_at_cross; assumption?)
|
|
apply (drule (2) valid_vspace_objs_strongD; assumption?)
|
|
apply simp
|
|
apply (clarsimp simp: pt_at_eq in_omonad AARCH64_A.is_PageTablePTE_def pptr_from_pte_def
|
|
getPPtrFromPTE_def isPagePTE_def paddr_from_ppn_def)
|
|
apply (simp add: state_relation_def)
|
|
apply (rule corres_inst[where P=\<top> and P'=\<top>])
|
|
apply (clarsimp simp: ptSlotIndex_def pt_slot_offset_def pt_index_def pt_bits_left_def
|
|
ptIndex_def ptBitsLeft_def)
|
|
apply (rule conjI; clarsimp)
|
|
apply (metis vm_level.size_less_eq size_maxPTLevel)
|
|
apply wpsimp+
|
|
apply (frule (5) vs_lookup_table_is_aligned)
|
|
apply (rule conjI)
|
|
apply (drule (5) valid_vspace_objs_strongD)
|
|
apply (clarsimp simp: pte_at_def obj_at_def ptes_of_def in_omonad)
|
|
apply (simp add: pt_slot_offset_def)
|
|
apply (rule conjI, fastforce)
|
|
apply (rule is_aligned_add)
|
|
apply (erule is_aligned_weaken)
|
|
apply (simp add: bit_simps)
|
|
apply (rule is_aligned_shiftl, simp)
|
|
apply clarsimp
|
|
apply (rule_tac x=asid in exI)
|
|
apply (rule_tac x="vref_step vref" in exI)
|
|
apply (clarsimp simp: vs_lookup_table_def in_omonad split: if_split_asm)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: level_defs)
|
|
apply (subst pt_walk_split_Some[where level'=level]; simp?)
|
|
apply (drule vm_level.pred)
|
|
apply simp
|
|
apply (subst pt_walk.simps)
|
|
apply (simp add: in_omonad)
|
|
apply simp
|
|
done
|
|
qed
|
|
|
|
lemma lookupPTSlot_corres:
|
|
"corres (\<lambda>(level, p) (bits, p'). bits = pt_bits_left level \<and> p' = p)
|
|
(pspace_aligned and pspace_distinct and valid_vspace_objs
|
|
and valid_asid_table and \<exists>\<rhd>(max_pt_level,pt)
|
|
and K (vptr \<in> user_region))
|
|
\<top>
|
|
(gets_the (pt_lookup_slot pt vptr \<circ> ptes_of)) (lookupPTSlot pt vptr)"
|
|
unfolding lookupPTSlot_def pt_lookup_slot_def
|
|
by (corresKsimp corres: lookupPTSlotFromLevel_corres)
|
|
|
|
lemma lookupPTFromLevel_corres:
|
|
"\<lbrakk> level' = size level; pt' = pt \<rbrakk> \<Longrightarrow>
|
|
corres (lfr \<oplus> ((=) \<circ> fst))
|
|
(pspace_aligned and pspace_distinct and valid_vspace_objs
|
|
and valid_asid_table and \<exists>\<rhd>(level,pt)
|
|
and K (vptr \<in> user_region \<and> level \<le> max_pt_level \<and> pt \<noteq> target))
|
|
\<top>
|
|
(pt_lookup_from_level level pt vptr target)
|
|
(lookupPTFromLevel level' pt' vptr target)"
|
|
proof (induct level arbitrary: level' pt pt')
|
|
case 0
|
|
then show ?case
|
|
apply (subst lookupPTFromLevel.simps, subst pt_lookup_from_level_simps)
|
|
apply simp
|
|
apply (rule corres_gen_asm)
|
|
apply (simp add: lookup_failure_map_def)
|
|
done
|
|
next
|
|
case (minus level)
|
|
|
|
(* FIXME: unfortunate duplication from lookupPTSlotFromLevel_corres *)
|
|
from `0 < level`
|
|
obtain nlevel where nlevel: "level = nlevel + 1" by (auto intro: that[of "level-1"])
|
|
with `0 < level`
|
|
have nlevel1: "nlevel < nlevel + 1" using vm_level.pred by fastforce
|
|
with nlevel
|
|
have level: "size level = Suc (size nlevel)" by simp
|
|
|
|
define vref_step where
|
|
"vref_step vref \<equiv>
|
|
vref_for_level vref (level+1) || (pt_index level vptr << pt_bits_left level)"
|
|
for vref
|
|
|
|
have vref_for_level_step[simp]:
|
|
"level \<le> max_pt_level \<Longrightarrow>
|
|
vref_for_level (vref_step vref) (level + 1) = vref_for_level vref (level + 1)"
|
|
for vref
|
|
unfolding vref_step_def
|
|
using vref_for_level_pt_index_idem[of level level level vref vptr] by simp
|
|
|
|
have pt_walk_vref[simp]:
|
|
"level \<le> max_pt_level \<Longrightarrow>
|
|
pt_walk max_pt_level level pt (vref_step vref) =
|
|
pt_walk max_pt_level level pt vref" for pt vref
|
|
by (rule pt_walk_vref_for_level_eq; simp)
|
|
|
|
have vref_step_user_region[simp]:
|
|
"\<lbrakk> vref \<in> user_region; vptr \<in> user_region; level \<le> max_pt_level \<rbrakk>
|
|
\<Longrightarrow> vref_step vref \<in> user_region"
|
|
for vref
|
|
unfolding vref_step_def
|
|
using nlevel1 nlevel
|
|
by (auto intro!: user_region_or vref_for_level_user_region
|
|
simp: pt_bits_left_def bit_simps user_region_def
|
|
pt_index_def canonical_user_def word_eqI_simps
|
|
dest!: max_pt_level_enum)
|
|
|
|
have pt_slot_offset_step[simp]:
|
|
"\<lbrakk> is_aligned pt (pt_bits level); vref \<in> user_region \<rbrakk> \<Longrightarrow>
|
|
pt_slot_offset level pt (vref_step vref) = pt_slot_offset level pt vptr" for vref
|
|
unfolding vref_step_def using nlevel1 nlevel
|
|
apply simp
|
|
apply (clarsimp simp: pt_slot_offset_or_def user_region_def canonical_user_def)
|
|
apply (simp add: pt_index_def pt_bits_left_def)
|
|
apply (rule conjI; clarsimp)
|
|
apply (simp add: plus_one_eq_asid_pool vref_for_level_def pt_bits_left_def)
|
|
apply (rule conjI, simp add: max_pt_level_def)
|
|
apply (clarsimp simp: level_defs bit_simps maxPTLevel_def)
|
|
apply word_eqI_solve
|
|
apply (clarsimp simp: vref_for_level_def pt_bits_left_def)
|
|
apply (rule conjI; clarsimp)
|
|
apply (subgoal_tac "nlevel = max_pt_level - 1")
|
|
apply (clarsimp simp: level_defs bit_simps maxPTLevel_def split: if_split_asm)
|
|
apply word_eqI_solve
|
|
apply (subst (asm) add.commute[where a=2])
|
|
apply (drule add_implies_diff)
|
|
apply (simp add: max_pt_level_def)
|
|
apply (simp add: pt_bits_def)
|
|
apply (prop_tac "level_type (nlevel + 1) = NormalPT_T")
|
|
apply (drule max_pt_level_enum)
|
|
apply (auto simp: level_defs split: if_split_asm)[1]
|
|
apply (simp add: bit_simps)
|
|
apply word_eqI
|
|
apply (drule max_pt_level_enum)
|
|
by (auto split: if_split_asm)
|
|
|
|
note vm_level.size_minus_one[simp]
|
|
from minus.prems
|
|
show ?case
|
|
apply (subst lookupPTFromLevel.simps, subst pt_lookup_from_level_simps)
|
|
apply (simp add: unlessE_whenE not_less)
|
|
apply (rule corres_gen_asm, simp)
|
|
apply (rule corres_initial_splitE[where r'=dc])
|
|
apply (corresKsimp simp: lookup_failure_map_def)
|
|
apply (rule corres_splitEE[where r'=pte_relation'])
|
|
apply (simp, rule getObject_PTE_corres)
|
|
apply (rule whenE_throwError_corres)
|
|
apply (simp add: lookup_failure_map_def)
|
|
apply (rename_tac pte pte', case_tac pte; simp add: isPageTablePTE_def)
|
|
apply (rule corres_if)
|
|
apply (clarsimp simp: AARCH64_A.is_PageTablePTE_def pptr_from_pte_def getPPtrFromPTE_def
|
|
paddr_from_ppn_def isPagePTE_def)
|
|
apply (rule corres_returnOk[where P=\<top> and P'=\<top>], simp)
|
|
apply (clarsimp simp: checkPTAt_def)
|
|
apply (subst liftE_bindE, rule corres_stateAssert_implied)
|
|
apply (rule minus.hyps)
|
|
apply (simp add: minus.hyps(2))
|
|
apply (clarsimp simp: AARCH64_A.is_PageTablePTE_def pptr_from_pte_def getPPtrFromPTE_def
|
|
paddr_from_ppn_def isPagePTE_def)
|
|
apply clarsimp
|
|
apply (rule_tac x=NormalPT_T in exI)
|
|
apply (rule page_table_at_cross; assumption?)
|
|
apply (drule vs_lookup_table_pt_at; simp?)
|
|
apply (clarsimp simp: AARCH64_A.is_PageTablePTE_def pptr_from_pte_def getPPtrFromPTE_def
|
|
paddr_from_ppn_def isPagePTE_def)
|
|
apply (simp add: level_type_def split: if_split_asm)
|
|
apply (simp add: state_relation_def)
|
|
apply wpsimp+
|
|
apply (simp add: vm_level.neq_0_conv)
|
|
apply (frule (5) vs_lookup_table_is_aligned)
|
|
apply (rule conjI)
|
|
apply (drule (5) valid_vspace_objs_strongD)
|
|
apply (clarsimp simp: pte_at_def obj_at_def ptes_of_def in_omonad)
|
|
apply (rule conjI, fastforce)
|
|
apply (simp add: pt_slot_offset_def)
|
|
apply (rule is_aligned_add)
|
|
apply (erule is_aligned_weaken)
|
|
apply (simp add: bit_simps)
|
|
apply (rule is_aligned_shiftl, simp)
|
|
apply clarsimp
|
|
apply (rule_tac x=asid in exI)
|
|
apply (rule_tac x="vref_step vref" in exI)
|
|
apply (clarsimp simp: vs_lookup_table_def in_omonad split: if_split_asm)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: level_defs)
|
|
apply (subst pt_walk_split_Some[where level'=level]; simp?)
|
|
apply (drule vm_level.pred)
|
|
apply simp
|
|
apply (subst pt_walk.simps)
|
|
apply (simp add: in_omonad)
|
|
apply wpsimp
|
|
done
|
|
qed
|
|
|
|
declare in_set_zip_refl[simp]
|
|
|
|
crunch typ_at' [wp]: storePTE "\<lambda>s. P (typ_at' T p s)"
|
|
(wp: crunch_wps mapM_x_wp' simp: crunch_simps ignore_del: setObject)
|
|
|
|
lemmas storePTE_typ_ats[wp] = typ_at_lifts [OF storePTE_typ_at']
|
|
|
|
lemma setObject_asid_typ_at' [wp]:
|
|
"\<lbrace>\<lambda>s. P (typ_at' T p s)\<rbrace> setObject p' (v::asidpool) \<lbrace>\<lambda>_ s. P (typ_at' T p s)\<rbrace>"
|
|
by (wp setObject_typ_at')
|
|
|
|
lemmas setObject_asid_typ_ats' [wp] = typ_at_lifts [OF setObject_asid_typ_at']
|
|
|
|
lemma getObject_pte_inv[wp]:
|
|
"\<lbrace>P\<rbrace> getObject p \<lbrace>\<lambda>rv :: pte. P\<rbrace>"
|
|
by (simp add: getObject_inv loadObject_default_inv)
|
|
|
|
lemma corres_gets_global_pt [corres]:
|
|
"corres (=) valid_global_arch_objs \<top>
|
|
(gets global_pt) (gets (armKSGlobalUserVSpace \<circ> ksArchState))"
|
|
by (clarsimp simp add: state_relation_def arch_state_relation_def)
|
|
|
|
lemmas getObject_PTE_corres'[corres] = getObject_PTE_corres[@lift_corres_args]
|
|
lemmas storePTE_corres'[corres] = storePTE_corres[@lift_corres_args]
|
|
|
|
lemma arch_cap_rights_update:
|
|
"acap_relation c c' \<Longrightarrow>
|
|
cap_relation (cap.ArchObjectCap (acap_rights_update (acap_rights c \<inter> msk) c))
|
|
(Arch.maskCapRights (rights_mask_map msk) c')"
|
|
apply (cases c, simp_all add: AARCH64_H.maskCapRights_def
|
|
acap_rights_update_def Let_def isCap_simps)
|
|
apply (simp add: maskVMRights_def vmrights_map_def rights_mask_map_def
|
|
validate_vm_rights_def vm_read_write_def vm_read_only_def
|
|
vm_kernel_only_def )
|
|
done
|
|
|
|
lemma arch_deriveCap_inv:
|
|
"\<lbrace>P\<rbrace> Arch.deriveCap arch_cap u \<lbrace>\<lambda>rv. P\<rbrace>"
|
|
apply (simp add: AARCH64_H.deriveCap_def
|
|
cong: if_cong
|
|
split del: if_split)
|
|
apply (wp undefined_valid)
|
|
apply (cases u; simp add: isCap_defs)
|
|
done
|
|
|
|
lemma arch_deriveCap_valid:
|
|
"\<lbrace>valid_cap' (ArchObjectCap arch_cap)\<rbrace>
|
|
Arch.deriveCap u arch_cap
|
|
\<lbrace>\<lambda>rv. valid_cap' rv\<rbrace>,-"
|
|
apply (simp add: AARCH64_H.deriveCap_def split del: if_split)
|
|
apply (wp undefined_validE_R)
|
|
apply (cases arch_cap; simp add: isCap_defs)
|
|
apply (simp add: valid_cap'_def capAligned_def capUntypedPtr_def AARCH64_H.capUntypedPtr_def)
|
|
done
|
|
|
|
lemma mdata_map_simps[simp]:
|
|
"mdata_map None = None"
|
|
"mdata_map (Some (asid, ref)) = Some (ucast asid, ref)"
|
|
by (auto simp add: mdata_map_def)
|
|
|
|
lemma arch_deriveCap_corres:
|
|
"cap_relation (cap.ArchObjectCap c) (ArchObjectCap c') \<Longrightarrow>
|
|
corres (ser \<oplus> (\<lambda>c c'. cap_relation c c'))
|
|
\<top> \<top>
|
|
(arch_derive_cap c)
|
|
(Arch.deriveCap slot c')"
|
|
unfolding arch_derive_cap_def AARCH64_H.deriveCap_def Let_def
|
|
apply (cases c, simp_all add: isCap_simps split: option.splits split del: if_split)
|
|
apply (clarify?, rule corres_noopE; wpsimp)+
|
|
done
|
|
|
|
definition
|
|
"vmattributes_map \<equiv> \<lambda>R. VMAttributes (Execute \<notin> R) (Device \<notin> R)"
|
|
|
|
lemma pte_relation'_Invalid_inv [simp]:
|
|
"pte_relation' x AARCH64_H.pte.InvalidPTE = (x = AARCH64_A.pte.InvalidPTE)"
|
|
by (cases x) auto
|
|
|
|
lemma asidHighBitsOf [simp]:
|
|
"asidHighBitsOf asid = ucast (asid_high_bits_of (ucast asid))"
|
|
by (word_eqI_solve simp: asidHighBitsOf_def asid_high_bits_of_def asidHighBits_def asid_low_bits_def)
|
|
|
|
lemma le_mask_asidBits_asid_wf:
|
|
"asid_wf asid \<longleftrightarrow> asid \<le> mask asidBits"
|
|
by (simp add: asidBits_def asidHighBits_def asid_wf_def asid_bits_defs mask_def)
|
|
|
|
lemma asid_le_mask_asidBits[simp]:
|
|
"UCAST(asid_len \<rightarrow> machine_word_len) asid \<le> mask asidBits"
|
|
by (rule ucast_leq_mask, simp add: asidBits_def asidHighBits_def asid_low_bits_def)
|
|
|
|
lemma asid_case_zero[simp]:
|
|
"0 < asid \<Longrightarrow> 0 < UCAST(asid_len \<rightarrow> machine_word_len) asid"
|
|
by word_bitwise
|
|
|
|
lemma find_vspace_for_asid_rewite:
|
|
"find_vspace_for_asid asid =
|
|
doE
|
|
unlessE (0 < asid) $ throwError ExceptionTypes_A.InvalidRoot;
|
|
entry_opt \<leftarrow> liftE $ gets (entry_for_asid asid);
|
|
case entry_opt of
|
|
Some entry \<Rightarrow> returnOk (ap_vspace entry)
|
|
| None \<Rightarrow> throwError ExceptionTypes_A.InvalidRoot
|
|
odE"
|
|
unfolding find_vspace_for_asid_def vspace_for_asid_def
|
|
apply (cases "0 < asid")
|
|
apply simp (* rewrite unlessE before unfolding things *)
|
|
apply (fastforce simp: bindE_def throw_opt_def liftE_def simpler_gets_def bind_def return_def
|
|
obind_None_eq
|
|
split: option.splits)
|
|
apply (simp add: liftE_def simpler_gets_def bindE_def bind_def return_def throw_opt_def
|
|
throwError_def)
|
|
done
|
|
|
|
lemma getPoolPtr_corres:
|
|
"corres (=) (K (0 < asid)) \<top> (gets (pool_for_asid asid)) (getPoolPtr (ucast asid))"
|
|
unfolding pool_for_asid_def getPoolPtr_def asidRange_def
|
|
apply simp
|
|
apply corres_pre
|
|
apply (rule corres_assert_gen_asm)
|
|
apply (rule corres_assert_gen_asm)
|
|
apply (rule corres_trivial)
|
|
apply (clarsimp simp: gets_return_gets_eq state_relation_def arch_state_relation_def
|
|
ucast_up_ucast_id is_up)
|
|
apply (simp flip: mask_eq_exp_minus_1)
|
|
apply simp
|
|
done
|
|
|
|
lemma getASIDPoolEntry_corres:
|
|
"corres (\<lambda>r r'. r = map_option abs_asid_entry r')
|
|
(valid_vspace_objs and valid_asid_table and pspace_aligned and pspace_distinct
|
|
and K (0 < asid))
|
|
(no_0_obj')
|
|
(gets (entry_for_asid asid))
|
|
(getASIDPoolEntry (ucast asid))"
|
|
unfolding entry_for_asid_def getASIDPoolEntry_def K_def
|
|
apply (rule corres_gen_asm)
|
|
apply (clarsimp simp: gets_obind_bind_eq entry_for_pool_def obind_comp_dist
|
|
cong: option.case_cong)
|
|
apply (rule corres_guard_imp)
|
|
apply (rule corres_split[where r'="(=)"])
|
|
apply (rule getPoolPtr_corres)
|
|
apply (rule_tac x=pool_ptr and x'=poolPtr in option_corres)
|
|
apply (rule corres_trivial, simp)
|
|
apply clarsimp
|
|
apply (rule monadic_rewrite_corres_l)
|
|
apply (monadic_rewrite_l gets_oapply_liftM_rewrite)
|
|
apply (rule monadic_rewrite_refl)
|
|
apply (clarsimp simp: liftM_def)
|
|
apply (rule corres_split[OF getObject_ASIDPool_corres[OF refl]])
|
|
apply (rule corres_trivial)
|
|
apply (case_tac rv', clarsimp)
|
|
apply (clarsimp simp: asid_pool_relation_def asid_low_bits_of_def ucast_ucast_mask2
|
|
is_down asid_low_bits_def ucast_and_mask)
|
|
apply wpsimp+
|
|
apply (drule (1) pool_for_asid_validD)
|
|
apply (simp add: asid_pools_at_eq)
|
|
apply simp
|
|
done
|
|
|
|
lemma no_0_page_table:
|
|
"\<lbrakk> no_0_obj' s; page_table_at' pt_t 0 s \<rbrakk> \<Longrightarrow> False"
|
|
apply (clarsimp simp: page_table_at'_def)
|
|
apply (erule_tac x=0 in allE)
|
|
apply simp
|
|
done
|
|
|
|
crunches getASIDPoolEntry
|
|
for no_0_obj'[wp]: no_0_obj'
|
|
(wp: getObject_inv simp: loadObject_default_def)
|
|
|
|
lemma findVSpaceForASID_corres:
|
|
assumes "asid' = ucast asid"
|
|
shows "corres (lfr \<oplus> (=))
|
|
(valid_vspace_objs and valid_asid_table
|
|
and pspace_aligned and pspace_distinct
|
|
and K (0 < asid))
|
|
(no_0_obj')
|
|
(find_vspace_for_asid asid) (findVSpaceForASID asid')" (is "corres _ ?P ?Q _ _")
|
|
using assms
|
|
apply (simp add: findVSpaceForASID_def)
|
|
apply (rule corres_gen_asm)
|
|
apply (subst find_vspace_for_asid_rewite)
|
|
apply clarsimp
|
|
apply (rule corres_guard_imp)
|
|
apply (rule corres_initial_splitE[where r'="\<lambda>r r'. r = map_option abs_asid_entry r'"])
|
|
apply simp
|
|
apply (rule getASIDPoolEntry_corres)
|
|
apply (rule_tac Q="\<lambda>entry s. pspace_aligned s \<and> pspace_distinct s \<and>
|
|
vspace_pt_at (ap_vspace entry) s"
|
|
in option_corres[where P=\<top> and P'=\<top> and Q'="\<lambda>_. no_0_obj'"])
|
|
apply (clarsimp simp: lookup_failure_map_def)
|
|
apply (rename_tac entry entry')
|
|
apply (case_tac entry')
|
|
apply (clarsimp simp: checkPTAt_def abs_asid_entry_def)
|
|
apply (rename_tac p)
|
|
apply (rule_tac Q="\<lambda>s. \<exists>pt_t. page_table_at' pt_t p s \<and> no_0_obj' s" in corres_cross_over_guard)
|
|
apply clarsimp
|
|
apply (rule_tac x=VSRootPT_T in exI)
|
|
apply (erule (2) page_table_at_cross, simp add: state_relation_def)
|
|
apply (simp add: liftE_bindE assertE_liftE)
|
|
apply (rule corres_assert_assume)
|
|
apply (rule corres_stateAssert_assume)
|
|
apply (rule corres_returnOk, simp)
|
|
apply clarsimp
|
|
apply (fastforce dest: no_0_page_table)
|
|
apply simp
|
|
apply wpsimp
|
|
apply (clarsimp simp: entry_for_asid_def)
|
|
apply (drule (2) pool_for_asid_valid_vspace_objs)
|
|
apply (fastforce simp: entry_for_pool_def)
|
|
apply (wpsimp wp: hoare_drop_imps)+
|
|
done
|
|
|
|
lemma setObject_arch:
|
|
assumes X: "\<And>p q n ko. \<lbrace>\<lambda>s. P (ksArchState s)\<rbrace> updateObject val p q n ko \<lbrace>\<lambda>rv s. P (ksArchState s)\<rbrace>"
|
|
shows "\<lbrace>\<lambda>s. P (ksArchState s)\<rbrace> setObject t val \<lbrace>\<lambda>rv s. P (ksArchState s)\<rbrace>"
|
|
apply (simp add: setObject_def split_def)
|
|
apply (wp X | simp)+
|
|
done
|
|
|
|
lemma setObject_ASID_arch [wp]:
|
|
"\<lbrace>\<lambda>s. P (ksArchState s)\<rbrace> setObject p (v::asidpool) \<lbrace>\<lambda>_ s. P (ksArchState s)\<rbrace>"
|
|
apply (rule setObject_arch)
|
|
apply (simp add: updateObject_default_def)
|
|
apply wp
|
|
apply simp
|
|
done
|
|
|
|
lemma setObject_PTE_arch [wp]:
|
|
"\<lbrace>\<lambda>s. P (ksArchState s)\<rbrace> setObject p (v::pte) \<lbrace>\<lambda>_ s. P (ksArchState s)\<rbrace>"
|
|
apply (rule setObject_arch)
|
|
apply (simp add: updateObject_default_def)
|
|
apply wp
|
|
apply simp
|
|
done
|
|
|
|
lemma setObject_ASID_valid_arch [wp]:
|
|
"setObject p (v::asidpool) \<lbrace>valid_arch_state'\<rbrace>"
|
|
by (wpsimp wp: valid_arch_state_lift' setObject_ko_wp_at)
|
|
(auto simp: objBits_simps pageBits_def is_vcpu'_def ko_wp_at'_def obj_at'_def)
|
|
|
|
lemma setObject_PTE_valid_arch [wp]:
|
|
"\<lbrace>valid_arch_state'\<rbrace> setObject p (v::pte) \<lbrace>\<lambda>_. valid_arch_state'\<rbrace>"
|
|
by (wpsimp wp: valid_arch_state_lift' setObject_typ_at' setObject_ko_wp_at)
|
|
(auto simp: objBits_simps pageBits_def is_vcpu'_def ko_wp_at'_def obj_at'_def)
|
|
|
|
lemma setObject_ASID_ct [wp]:
|
|
"\<lbrace>\<lambda>s. P (ksCurThread s)\<rbrace> setObject p (e::asidpool) \<lbrace>\<lambda>_ s. P (ksCurThread s)\<rbrace>"
|
|
apply (simp add: setObject_def updateObject_default_def split_def)
|
|
apply (wp updateObject_default_inv | simp)+
|
|
done
|
|
|
|
lemma setObject_pte_ct [wp]:
|
|
"\<lbrace>\<lambda>s. P (ksCurThread s)\<rbrace> setObject p (e::pte) \<lbrace>\<lambda>_ s. P (ksCurThread s)\<rbrace>"
|
|
apply (simp add: setObject_def updateObject_default_def split_def)
|
|
apply (wp updateObject_default_inv | simp)+
|
|
done
|
|
|
|
lemma setObject_ASID_cur_tcb' [wp]:
|
|
"\<lbrace>\<lambda>s. cur_tcb' s\<rbrace> setObject p (e::asidpool) \<lbrace>\<lambda>_ s. cur_tcb' s\<rbrace>"
|
|
apply (simp add: cur_tcb'_def)
|
|
apply (rule hoare_lift_Pf [where f=ksCurThread])
|
|
apply wp+
|
|
done
|
|
|
|
lemma setObject_pte_cur_tcb' [wp]:
|
|
"\<lbrace>\<lambda>s. cur_tcb' s\<rbrace> setObject p (e::pte) \<lbrace>\<lambda>_ s. cur_tcb' s\<rbrace>"
|
|
apply (simp add: cur_tcb'_def)
|
|
apply (rule hoare_lift_Pf [where f=ksCurThread])
|
|
apply wp+
|
|
done
|
|
|
|
lemma getASID_wp:
|
|
"\<lbrace>\<lambda>s. \<forall>ko. ko_at' (ko::asidpool) p s \<longrightarrow> Q ko s\<rbrace> getObject p \<lbrace>Q\<rbrace>"
|
|
by (clarsimp simp: getObject_def split_def loadObject_default_def
|
|
in_magnitude_check pageBits_def in_monad valid_def obj_at'_def objBits_simps)
|
|
|
|
lemma storePTE_ctes [wp]:
|
|
"\<lbrace>\<lambda>s. P (ctes_of s)\<rbrace> storePTE p pte \<lbrace>\<lambda>_ s. P (ctes_of s)\<rbrace>"
|
|
apply (rule ctes_of_from_cte_wp_at [where Q=\<top>, simplified])
|
|
apply (rule storePTE_cte_wp_at')
|
|
done
|
|
|
|
lemma setObject_ASID_cte_wp_at'[wp]:
|
|
"\<lbrace>\<lambda>s. P (cte_wp_at' P' p s)\<rbrace>
|
|
setObject ptr (asid::asidpool)
|
|
\<lbrace>\<lambda>rv s. P (cte_wp_at' P' p s)\<rbrace>"
|
|
apply (wp setObject_cte_wp_at2'[where Q="\<top>"])
|
|
apply (clarsimp simp: updateObject_default_def in_monad projectKO_opts_defs)
|
|
apply (rule equals0I)
|
|
apply (clarsimp simp: updateObject_default_def in_monad projectKO_opts_defs)
|
|
apply simp
|
|
done
|
|
|
|
lemma setObject_ASID_ctes_of'[wp]:
|
|
"\<lbrace>\<lambda>s. P (ctes_of s)\<rbrace>
|
|
setObject ptr (asid::asidpool)
|
|
\<lbrace>\<lambda>rv s. P (ctes_of s)\<rbrace>"
|
|
by (rule ctes_of_from_cte_wp_at [where Q=\<top>, simplified]) wp
|
|
|
|
lemma clearMemory_vms':
|
|
"valid_machine_state' s \<Longrightarrow>
|
|
\<forall>x\<in>fst (clearMemory ptr bits (ksMachineState s)).
|
|
valid_machine_state' (s\<lparr>ksMachineState := snd x\<rparr>)"
|
|
apply (clarsimp simp: valid_machine_state'_def
|
|
disj_commute[of "pointerInUserData p s" for p s])
|
|
apply (drule_tac x=p in spec, simp)
|
|
apply (drule_tac P4="\<lambda>m'. underlying_memory m' p = 0"
|
|
in use_valid[where P=P and Q="\<lambda>_. P" for P], simp_all)
|
|
apply (rule clearMemory_um_eq_0)
|
|
done
|
|
|
|
lemma dmo_clearMemory_invs'[wp]:
|
|
"\<lbrace>invs'\<rbrace> doMachineOp (clearMemory w sz) \<lbrace>\<lambda>_. invs'\<rbrace>"
|
|
apply (simp add: doMachineOp_def split_def)
|
|
apply wp
|
|
apply (clarsimp simp: invs'_def valid_state'_def)
|
|
apply (rule conjI)
|
|
apply (simp add: valid_irq_masks'_def, elim allEI, clarsimp)
|
|
apply (drule use_valid)
|
|
apply (rule no_irq_clearMemory[simplified no_irq_def, rule_format])
|
|
apply simp_all
|
|
apply (drule clearMemory_vms')
|
|
apply fastforce
|
|
done
|
|
|
|
end
|
|
end
|