6353 lines
243 KiB
Plaintext
6353 lines
243 KiB
Plaintext
(*
|
|
* Copyright 2014, General Dynamics C4 Systems
|
|
*
|
|
* This software may be distributed and modified according to the terms of
|
|
* the GNU General Public License version 2. Note that NO WARRANTY is provided.
|
|
* See "LICENSE_GPLv2.txt" for details.
|
|
*
|
|
* @TAG(GD_GPL)
|
|
*)
|
|
|
|
(*
|
|
CSpace refinement
|
|
*)
|
|
|
|
theory CSpace_R
|
|
imports CSpace1_R
|
|
begin
|
|
|
|
lemma setCTE_pred_tcb_at':
|
|
"\<lbrace>pred_tcb_at' proj P t\<rbrace>
|
|
setCTE c cte
|
|
\<lbrace>\<lambda>rv. pred_tcb_at' proj P t\<rbrace>"
|
|
unfolding pred_tcb_at'_def setCTE_def
|
|
apply (rule setObject_cte_obj_at_tcb')
|
|
apply (simp add: tcb_to_itcb'_def)+
|
|
done
|
|
|
|
locale mdb_move =
|
|
mdb_ptr m _ _ src src_cap src_node
|
|
for m src src_cap src_node +
|
|
|
|
fixes dest cap'
|
|
|
|
fixes old_dest_node
|
|
assumes dest: "m dest = Some (CTE NullCap old_dest_node)"
|
|
assumes prev: "mdbPrev old_dest_node = 0"
|
|
assumes nxt: "mdbNext old_dest_node = 0"
|
|
|
|
assumes parency: "weak_derived' src_cap cap'"
|
|
assumes not_null: "src_cap \<noteq> NullCap"
|
|
assumes neq: "src \<noteq> dest"
|
|
|
|
fixes n
|
|
defines "n \<equiv>
|
|
modify_map
|
|
(modify_map
|
|
(modify_map
|
|
(modify_map
|
|
(modify_map m dest (cteCap_update (\<lambda>_. cap')))
|
|
src (cteCap_update (\<lambda>_. NullCap)))
|
|
dest (cteMDBNode_update (\<lambda>m. src_node)))
|
|
src (cteMDBNode_update (\<lambda>m. nullMDBNode)))
|
|
(mdbPrev src_node) (cteMDBNode_update (mdbNext_update (\<lambda>_. dest)))"
|
|
|
|
fixes m'
|
|
defines "m' \<equiv>
|
|
modify_map n (mdbNext src_node)
|
|
(cteMDBNode_update (mdbPrev_update (\<lambda>_. dest)))"
|
|
begin
|
|
|
|
lemmas src = m_p
|
|
|
|
lemma [intro?]:
|
|
shows src_0: "src \<noteq> 0"
|
|
and dest_0: "dest \<noteq> 0"
|
|
using no_0 src dest
|
|
by (auto simp: no_0_def)
|
|
|
|
lemma src_prev:
|
|
"mdbPrev src_node \<noteq> dest"
|
|
proof (cases "mdbPrev src_node = 0")
|
|
case True thus ?thesis using dest_0 by simp
|
|
next
|
|
case False
|
|
with src dlist
|
|
obtain cte' where
|
|
"m (mdbPrev src_node) = Some cte'"
|
|
"mdbNext (cteMDBNode cte') = src"
|
|
by (auto elim: valid_dlistE)
|
|
with dest nxt src_0
|
|
show ?thesis
|
|
apply -
|
|
apply (rule notI)
|
|
apply hypsubst
|
|
apply simp
|
|
done
|
|
qed
|
|
|
|
lemma src_neq_next:
|
|
"src \<noteq> mdbNext src_node"
|
|
by simp
|
|
|
|
lemma src_neq_prev:
|
|
"src \<noteq> mdbPrev src_node"
|
|
by simp
|
|
|
|
lemmas src_neq_next2 = src_neq_next [symmetric]
|
|
lemmas src_neq_prev2 = src_neq_prev [symmetric]
|
|
|
|
lemma n:
|
|
"n = modify_map (m(dest \<mapsto> CTE cap' src_node,
|
|
src \<mapsto> CTE capability.NullCap nullMDBNode))
|
|
(mdbPrev src_node)
|
|
(cteMDBNode_update (mdbNext_update (\<lambda>_. dest)))"
|
|
using neq src dest no_0
|
|
by (simp add: n_def modify_map_apply)
|
|
|
|
lemma dest_no_parent [iff]:
|
|
"m \<turnstile> dest \<rightarrow> x = False" using dest nxt
|
|
by (auto dest: subtree_next_0)
|
|
|
|
lemma dest_no_child [iff]:
|
|
"m \<turnstile> x \<rightarrow> dest = False" using dest prev
|
|
by (auto dest: subtree_prev_0)
|
|
|
|
lemma src_no_parent [iff]:
|
|
"n \<turnstile> src \<rightarrow> x = False"
|
|
apply clarsimp
|
|
apply (erule subtree_next_0)
|
|
apply (auto simp add: n modify_map_def nullPointer_def)
|
|
done
|
|
|
|
lemma no_0_n: "no_0 n" by (simp add: n_def no_0)
|
|
lemma no_0': "no_0 m'" by (simp add: m'_def no_0_n)
|
|
|
|
lemma next_neq_dest [simp]:
|
|
"mdbNext src_node \<noteq> dest"
|
|
using dlist src dest prev dest_0 no_0
|
|
by (fastforce simp add: valid_dlist_def no_0_def Let_def)
|
|
|
|
lemma prev_neq_dest [simp]:
|
|
"mdbPrev src_node \<noteq> dest"
|
|
using dlist src dest nxt dest_0 no_0
|
|
by (fastforce simp add: valid_dlist_def no_0_def Let_def)
|
|
|
|
lemmas next_neq_dest2 [simp] = next_neq_dest [symmetric]
|
|
lemmas prev_neq_dest2 [simp] = prev_neq_dest [symmetric]
|
|
|
|
lemma prev_next_0:
|
|
"(mdbPrev src_node = mdbNext src_node) =
|
|
(mdbPrev src_node = 0 \<and> mdbNext src_node = 0)"
|
|
proof -
|
|
{ assume "mdbPrev src_node = mdbNext src_node"
|
|
moreover
|
|
assume "mdbNext src_node \<noteq> 0"
|
|
ultimately
|
|
obtain cte where
|
|
"m (mdbNext src_node) = Some cte"
|
|
"mdbNext (cteMDBNode cte) = src"
|
|
using src dlist
|
|
by (fastforce simp add: valid_dlist_def Let_def)
|
|
hence "m \<turnstile> src \<leadsto>\<^sup>+ src" using src
|
|
apply -
|
|
apply (rule trancl_trans)
|
|
apply (rule r_into_trancl)
|
|
apply (simp add: next_unfold')
|
|
apply (rule r_into_trancl)
|
|
apply (simp add: next_unfold')
|
|
done
|
|
with no_loops
|
|
have False by (simp add: no_loops_def)
|
|
}
|
|
thus ?thesis by auto
|
|
qed
|
|
|
|
lemma next_prev_0:
|
|
"(mdbNext src_node = mdbPrev src_node) =
|
|
(mdbPrev src_node = 0 \<and> mdbNext src_node = 0)"
|
|
by auto
|
|
|
|
lemma dlist':
|
|
"valid_dlist m'"
|
|
using src dest prev neq nxt dlist no_0
|
|
apply (simp add: m'_def n no_0_def)
|
|
apply (simp add: valid_dlist_def Let_def)
|
|
apply clarsimp
|
|
apply (case_tac cte)
|
|
apply (rename_tac cap node)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: modify_map_def nullPointer_def split: split_if_asm)
|
|
apply (case_tac z)
|
|
apply fastforce
|
|
apply (case_tac z)
|
|
apply (rename_tac capability mdbnode)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (rule conjI, fastforce)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (subgoal_tac "mdbNext mdbnode = mdbPrev src_node")
|
|
prefer 2
|
|
apply fastforce
|
|
apply (subgoal_tac "mdbNext mdbnode = src")
|
|
prefer 2
|
|
apply fastforce
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (frule_tac x=src in spec, erule allE, erule (1) impE)
|
|
apply fastforce
|
|
subgoal by fastforce
|
|
subgoal by fastforce
|
|
apply (rule conjI, clarsimp)
|
|
apply fastforce
|
|
apply (clarsimp, rule conjI, fastforce)
|
|
apply (clarsimp, rule conjI)
|
|
apply clarsimp
|
|
apply (frule_tac x=src in spec, erule allE, erule (1) impE)
|
|
subgoal by fastforce
|
|
subgoal by fastforce
|
|
apply (clarsimp simp: modify_map_def nullPointer_def split: split_if_asm)
|
|
apply (case_tac z)
|
|
apply (clarsimp, rule conjI, fastforce)
|
|
apply (clarsimp, rule conjI, fastforce)
|
|
apply (clarsimp, rule conjI)
|
|
apply clarsimp
|
|
apply (frule_tac x=src in spec, erule allE, erule (1) impE)
|
|
subgoal by fastforce
|
|
apply (clarsimp, rule conjI)
|
|
apply clarsimp
|
|
apply (frule_tac x=src in spec, erule allE, erule (1) impE)
|
|
subgoal by fastforce
|
|
subgoal by fastforce
|
|
apply (case_tac z)
|
|
subgoal by fastforce
|
|
subgoal by fastforce
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: next_prev_0)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (rule conjI, fastforce)
|
|
apply (clarsimp, rule conjI)
|
|
apply clarsimp
|
|
apply (frule_tac x=src in spec, erule allE, erule (1) impE)
|
|
subgoal by fastforce
|
|
apply (clarsimp, rule conjI)
|
|
apply clarsimp
|
|
apply (frule_tac x=src in spec, erule allE, erule (1) impE)
|
|
subgoal by fastforce
|
|
subgoal by fastforce
|
|
done
|
|
|
|
lemma src_no_child [iff]:
|
|
"n \<turnstile> x \<rightarrow> src = False"
|
|
proof -
|
|
from src_neq_next
|
|
have "m' src = Some (CTE capability.NullCap nullMDBNode)"
|
|
by (simp add: m'_def n modify_map_def)
|
|
hence "m' \<turnstile> x \<rightarrow> src = False" using dlist' no_0'
|
|
by (auto elim!: subtree_prev_0 simp: nullPointer_def)
|
|
thus ?thesis by (simp add: m'_def)
|
|
qed
|
|
|
|
lemma [iff]:
|
|
"m \<turnstile> dest parentOf c = False"
|
|
using dest by (simp add: parentOf_def)
|
|
|
|
lemma [iff]:
|
|
"mdbNext src_node \<noteq> dest"
|
|
proof
|
|
assume "mdbNext src_node = dest"
|
|
moreover have "dest \<noteq> 0" ..
|
|
ultimately
|
|
have "mdbPrev old_dest_node = src"
|
|
using src dest dlist
|
|
by (fastforce elim: valid_dlistEn)
|
|
with prev
|
|
show False by (simp add: src_0)
|
|
qed
|
|
|
|
lemmas no_loops_simps [simp] =
|
|
no_loops_direct_simp [OF no_loops] no_loops_trancl_simp [OF no_loops]
|
|
|
|
lemma dest_source [iff]:
|
|
"(m \<turnstile> dest \<leadsto> x) = (x = 0)"
|
|
using dest nxt by (simp add: next_unfold')
|
|
|
|
lemma dest_no_target [iff]:
|
|
"m \<turnstile> p \<leadsto> dest = False"
|
|
using dlist no_0 prev dest
|
|
by (fastforce simp: valid_dlist_def Let_def no_0_def next_unfold')
|
|
|
|
lemma no_src_subtree_m_n:
|
|
assumes no_src: "\<not> m \<turnstile> p \<rightarrow> src" "p \<noteq> src"
|
|
assumes px: "m \<turnstile> p \<rightarrow> x"
|
|
assumes xs: "x \<noteq> src"
|
|
shows "n \<turnstile> p \<rightarrow> x" using px xs
|
|
proof induct
|
|
case (direct_parent c)
|
|
thus ?case using neq no_src no_loops
|
|
apply -
|
|
apply (rule subtree.direct_parent)
|
|
apply (clarsimp simp add: n mdb_next_update simp del: fun_upd_apply)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst modify_map_None)
|
|
apply simp
|
|
apply (clarsimp simp add: mdb_next_update simp del: fun_upd_apply)
|
|
apply (subst modify_map_apply)
|
|
apply simp
|
|
apply (clarsimp simp add: mdb_next_update simp del: fun_upd_apply)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (clarsimp)
|
|
apply (drule prev_leadstoD)
|
|
apply (rule src)
|
|
apply (rule dlist)
|
|
apply (rule no_0)
|
|
apply simp
|
|
apply assumption
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst modify_map_None)
|
|
apply simp
|
|
apply (clarsimp simp add: parentOf_def n)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (fastforce simp add: parentOf_def n)
|
|
apply (subst modify_map_apply)
|
|
apply simp
|
|
apply (fastforce simp add: parentOf_def n)
|
|
done
|
|
next
|
|
case (trans_parent c c')
|
|
thus ?case using no_src
|
|
apply (cases "c = src")
|
|
apply simp
|
|
apply clarsimp
|
|
apply (erule subtree.trans_parent)
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst modify_map_None)
|
|
apply simp
|
|
apply (clarsimp simp add: n mdb_next_update)
|
|
apply (subst modify_map_apply)
|
|
apply simp
|
|
apply (clarsimp simp add: n mdb_next_update)
|
|
apply (rule conjI, fastforce)
|
|
apply clarsimp
|
|
apply (drule prev_leadstoD)
|
|
apply (rule src)
|
|
apply (rule dlist)
|
|
apply (rule no_0)
|
|
apply simp
|
|
apply assumption
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst modify_map_None)
|
|
apply simp
|
|
apply (clarsimp simp: parentOf_def n)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (clarsimp simp: dest)
|
|
apply (subst modify_map_apply)
|
|
apply simp
|
|
apply (fastforce simp: parentOf_def n)
|
|
done
|
|
qed
|
|
|
|
lemma capMaster_isReply_eq:
|
|
"capMasterCap c = capMasterCap c' \<Longrightarrow>
|
|
isReplyCap c = isReplyCap c'"
|
|
by (clarsimp simp: capMasterCap_def isCap_simps split: capability.split_asm)
|
|
|
|
lemma parent_preserved:
|
|
"isMDBParentOf cte' (CTE cap' src_node) =
|
|
isMDBParentOf cte' (CTE src_cap src_node)"
|
|
using parency unfolding weak_derived'_def
|
|
apply (cases cte')
|
|
apply (simp add: isMDBParentOf_CTE sameRegionAs_def2)
|
|
done
|
|
|
|
lemma children_preserved:
|
|
"isMDBParentOf (CTE cap' src_node) cte' =
|
|
isMDBParentOf (CTE src_cap src_node) cte'"
|
|
using parency unfolding weak_derived'_def
|
|
apply (cases cte')
|
|
apply (simp add: isMDBParentOf_CTE sameRegionAs_def2)
|
|
done
|
|
|
|
lemma no_src_subtree_n_m:
|
|
assumes no_src: "\<not> m \<turnstile> p \<rightarrow> src" "p \<noteq> src" "p \<noteq> dest"
|
|
assumes px: "n \<turnstile> p \<rightarrow> x"
|
|
shows "m \<turnstile> p \<rightarrow> x" using px
|
|
proof induct
|
|
case (direct_parent c)
|
|
thus ?case using neq no_src no_loops
|
|
apply -
|
|
apply (case_tac "c=dest")
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (unfold n)[1]
|
|
apply (subst (asm) modify_map_None, simp)+
|
|
apply (clarsimp simp: mdb_next_update)
|
|
apply (rename_tac cte')
|
|
apply clarsimp
|
|
apply (subgoal_tac "p = mdbPrev src_node")
|
|
prefer 2
|
|
apply (simp add: n)
|
|
apply (subst (asm) modify_map_apply, simp)
|
|
apply (clarsimp simp:_mdb_next_update split: split_if_asm)
|
|
apply clarsimp
|
|
apply (simp add: n)
|
|
apply (subst (asm) modify_map_apply, simp)+
|
|
apply (insert dest)[1]
|
|
apply (clarsimp simp add: parentOf_def mdb_next_unfold)
|
|
apply (subgoal_tac "m \<turnstile> mdbPrev src_node \<rightarrow> src")
|
|
apply simp
|
|
apply (rule subtree.direct_parent)
|
|
apply (rule prev_leadstoI)
|
|
apply (rule src)
|
|
apply (insert no_0, clarsimp simp: no_0_def)[1]
|
|
apply (rule dlist)
|
|
apply (rule src_0)
|
|
apply (simp add: parentOf_def src parent_preserved)
|
|
apply (rule subtree.direct_parent)
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst (asm) modify_map_None, simp)+
|
|
apply (simp add: mdb_next_update)
|
|
apply (subst (asm) modify_map_apply, simp)+
|
|
apply (simp add: mdb_next_update split: split_if_asm)
|
|
apply assumption
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst (asm) modify_map_None, simp)+
|
|
apply (clarsimp simp add: parentOf_def split: split_if_asm)
|
|
apply (subst (asm) modify_map_apply, simp)+
|
|
apply (clarsimp simp add: parentOf_def split: split_if_asm)
|
|
done
|
|
next
|
|
case (trans_parent c c')
|
|
thus ?case using neq no_src
|
|
apply -
|
|
apply (case_tac "c' = dest")
|
|
apply clarsimp
|
|
apply (subgoal_tac "c = mdbPrev src_node")
|
|
prefer 2
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst (asm) modify_map_None, simp)+
|
|
apply (clarsimp simp: mdb_next_update split: split_if_asm)
|
|
apply (subst (asm) modify_map_apply, simp)+
|
|
apply (clarsimp simp: mdb_next_update split: split_if_asm)
|
|
apply clarsimp
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (unfold n)[1]
|
|
apply (subst (asm) modify_map_None, simp)+
|
|
apply (clarsimp simp: mdb_next_update)
|
|
apply (subgoal_tac "m \<turnstile> p \<rightarrow> src")
|
|
apply simp
|
|
apply (rule subtree.trans_parent, assumption)
|
|
apply (rule prev_leadstoI)
|
|
apply (rule src)
|
|
apply (insert no_0, clarsimp simp: no_0_def)[1]
|
|
apply (rule dlist)
|
|
apply (rule src_0)
|
|
apply (clarsimp simp: n)
|
|
apply (subst (asm) modify_map_apply, simp)+
|
|
apply (clarsimp simp: parentOf_def src parent_preserved
|
|
split: split_if_asm)
|
|
apply (rule subtree.trans_parent, assumption)
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst (asm) modify_map_None, simp)+
|
|
apply (simp add: mdb_next_update split: split_if_asm)
|
|
apply (subst (asm) modify_map_apply, simp)+
|
|
apply (simp add: mdb_next_update split: split_if_asm)
|
|
apply assumption
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst (asm) modify_map_None, simp)+
|
|
apply (clarsimp simp: parentOf_def split: split_if_asm)
|
|
apply (subst (asm) modify_map_apply, simp)+
|
|
apply (clarsimp simp: parentOf_def split: split_if_asm)
|
|
done
|
|
qed
|
|
|
|
lemma subtree_m_n:
|
|
assumes p_neq: "p \<noteq> dest" "p \<noteq> src"
|
|
assumes px: "m \<turnstile> p \<rightarrow> x"
|
|
shows "if x = src then n \<turnstile> p \<rightarrow> dest else n \<turnstile> p \<rightarrow> x" using px
|
|
proof induct
|
|
case (direct_parent c)
|
|
thus ?case using p_neq
|
|
apply -
|
|
apply simp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (drule leadsto_is_prev)
|
|
apply (rule src)
|
|
apply (rule dlist)
|
|
apply (rule no_0)
|
|
apply (clarsimp simp: parentOf_def)
|
|
apply (rule subtree.direct_parent)
|
|
apply (simp add: n modify_map_apply mdb_next_update)
|
|
apply (rule dest_0)
|
|
apply (clarsimp simp: n modify_map_apply parentOf_def
|
|
neq [symmetric] src parent_preserved)
|
|
apply clarsimp
|
|
apply (rule subtree.direct_parent)
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst modify_map_None, simp)
|
|
apply (simp add: mdb_next_update)
|
|
apply (subst modify_map_apply, simp)
|
|
apply (clarsimp simp: mdb_next_update)
|
|
apply (drule prev_leadstoD)
|
|
apply (rule src)
|
|
apply (rule dlist)
|
|
apply (rule no_0)
|
|
apply simp
|
|
apply assumption
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst modify_map_None, simp)
|
|
apply (clarsimp simp add: parentOf_def)
|
|
apply (subst modify_map_apply, simp)
|
|
apply (clarsimp simp add: parentOf_def)
|
|
apply fastforce
|
|
done
|
|
next
|
|
case (trans_parent c c')
|
|
thus ?case using p_neq
|
|
apply -
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (erule subtree.trans_parent)
|
|
apply (clarsimp simp: next_unfold' src n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst modify_map_None, simp)
|
|
apply (clarsimp simp add: neq [symmetric] src split: option.splits)
|
|
apply (subst modify_map_apply, simp)
|
|
apply (clarsimp simp add: neq [symmetric] src split: option.splits)
|
|
apply assumption
|
|
apply (clarsimp simp: mdb_next_unfold src n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst modify_map_None, simp)
|
|
apply (simp add: parentOf_def)
|
|
apply (subst modify_map_apply, simp)
|
|
apply (fastforce simp add: parentOf_def)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (cases "m c", simp add: mdb_next_unfold)
|
|
apply (drule leadsto_is_prev)
|
|
apply (rule src)
|
|
apply (rule dlist)
|
|
apply (rule no_0)
|
|
apply clarsimp
|
|
apply (erule subtree.trans_parent)
|
|
apply (simp add: n modify_map_apply mdb_next_update)
|
|
apply (rule dest_0)
|
|
apply (clarsimp simp: n modify_map_apply parentOf_def neq [symmetric] src)
|
|
apply (rule conjI, clarsimp)
|
|
apply (clarsimp simp: parent_preserved)
|
|
apply clarsimp
|
|
apply (erule subtree.trans_parent)
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst modify_map_None, simp)
|
|
apply (clarsimp simp add: mdb_next_update)
|
|
apply (subst modify_map_apply, simp)
|
|
apply (clarsimp simp add: mdb_next_update)
|
|
apply (rule conjI, clarsimp)
|
|
apply clarsimp
|
|
apply (drule prev_leadstoD, rule src, rule dlist, rule no_0)
|
|
apply simp
|
|
apply assumption
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst modify_map_None, simp)
|
|
apply (clarsimp simp add: parentOf_def)
|
|
apply (subst modify_map_apply, simp)
|
|
apply (fastforce simp add: parentOf_def)
|
|
done
|
|
qed
|
|
|
|
lemmas neq_sym [simp] = neq [symmetric]
|
|
|
|
lemma sub_tree_loop [simp]:
|
|
"m \<turnstile> x \<rightarrow> x = False"
|
|
by (clarsimp dest!: subtree_mdb_next)
|
|
|
|
lemmas src_prev_loop [simp] =
|
|
subtree_prev_loop [OF src no_loops dlist no_0]
|
|
|
|
lemma subtree_src_dest:
|
|
"m \<turnstile> src \<rightarrow> x \<Longrightarrow> n \<turnstile> dest \<rightarrow> x"
|
|
apply (erule subtree.induct)
|
|
apply (clarsimp simp: mdb_next_unfold src)
|
|
apply (rule subtree.direct_parent)
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst modify_map_None, simp)
|
|
apply (simp add: mdb_next_update)
|
|
apply (subst modify_map_apply, simp)
|
|
apply (simp add: mdb_next_update)
|
|
apply assumption
|
|
apply (simp add: n)
|
|
apply (clarsimp simp add: modify_map_def parentOf_def src children_preserved)
|
|
apply (subgoal_tac "c'' \<noteq> src")
|
|
prefer 2
|
|
apply (drule (3) subtree.trans_parent)
|
|
apply clarsimp
|
|
apply (erule subtree.trans_parent)
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst modify_map_None, simp)
|
|
apply (simp add: mdb_next_update)
|
|
apply fastforce
|
|
apply (subst modify_map_apply, simp)
|
|
apply (simp add: mdb_next_update)
|
|
apply fastforce
|
|
apply assumption
|
|
apply (fastforce simp: n modify_map_def parentOf_def src children_preserved)
|
|
done
|
|
|
|
lemma src_next [simp]:
|
|
"m \<turnstile> src \<leadsto> mdbNext src_node"
|
|
by (simp add: next_unfold' src)
|
|
|
|
lemma dest_no_trancl_target [simp]:
|
|
"m \<turnstile> x \<leadsto>\<^sup>+ dest = False"
|
|
by (clarsimp dest!: tranclD2)
|
|
|
|
lemma m'_next:
|
|
"\<lbrakk>m' p = Some (CTE cte' node'); m p = Some (CTE cte node)\<rbrakk>
|
|
\<Longrightarrow> mdbNext node'
|
|
= (if p = src then 0
|
|
else if p = dest then mdbNext src_node
|
|
else if mdbNext node = src then dest
|
|
else mdbNext node)"
|
|
apply(simp, intro conjI impI)
|
|
apply(clarsimp simp: n m'_def modify_map_def split: split_if_asm)
|
|
apply(clarsimp simp: n m'_def modify_map_def nullPointer_def)
|
|
apply(subgoal_tac "mdbPrev src_node = p")
|
|
prefer 2
|
|
apply(erule dlistEn)
|
|
apply(simp)
|
|
apply(case_tac "cte'a")
|
|
apply(clarsimp simp: src)
|
|
apply(clarsimp simp: n m'_def modify_map_def split: split_if_asm)
|
|
apply(clarsimp simp: dest n m'_def modify_map_def)
|
|
apply(clarsimp simp: n m'_def modify_map_def nullPointer_def)
|
|
apply(clarsimp simp: n m'_def modify_map_def split: split_if_asm)
|
|
apply(insert m_p no_0)
|
|
apply(erule_tac p=src in dlistEp)
|
|
apply(clarsimp simp: no_0_def)
|
|
apply(clarsimp)
|
|
done
|
|
|
|
|
|
lemma mdb_next_from_dest:
|
|
"n \<turnstile> dest \<leadsto>\<^sup>+ x \<Longrightarrow> m \<turnstile> src \<leadsto>\<^sup>+ x"
|
|
apply (erule trancl_induct)
|
|
apply (rule r_into_trancl)
|
|
apply (simp add: n modify_map_def next_unfold' src)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (simp add: n)
|
|
apply (subst (asm) modify_map_None, simp)+
|
|
apply (clarsimp simp: mdb_next_update split: split_if_asm)
|
|
apply (fastforce intro: trancl_into_trancl)
|
|
apply (simp add: n)
|
|
apply (subst (asm) modify_map_apply, simp)+
|
|
apply (clarsimp simp: mdb_next_update split: split_if_asm)
|
|
apply (subgoal_tac "m \<turnstile> src \<leadsto>\<^sup>+ src")
|
|
apply simp
|
|
apply (erule trancl_into_trancl)
|
|
apply (rule prev_leadstoI, rule src)
|
|
apply (insert no_0)[1]
|
|
apply (clarsimp simp add: no_0_def)
|
|
apply (rule dlist)
|
|
apply (fastforce intro: trancl_into_trancl)
|
|
done
|
|
|
|
lemma dest_loop:
|
|
"n \<turnstile> dest \<rightarrow> dest = False"
|
|
apply clarsimp
|
|
apply (drule subtree_mdb_next)
|
|
apply (drule mdb_next_from_dest)
|
|
apply simp
|
|
done
|
|
|
|
|
|
lemma subtree_dest_src:
|
|
"n \<turnstile> dest \<rightarrow> x \<Longrightarrow> m \<turnstile> src \<rightarrow> x"
|
|
apply (erule subtree.induct)
|
|
apply (clarsimp simp: mdb_next_unfold src)
|
|
apply (rule subtree.direct_parent)
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst (asm) modify_map_None, simp)+
|
|
apply (clarsimp simp add: mdb_next_update next_unfold src)
|
|
apply (subst (asm) modify_map_apply, simp)+
|
|
apply (clarsimp simp add: mdb_next_update next_unfold src)
|
|
apply assumption
|
|
apply (simp add: n)
|
|
apply (simp add: modify_map_def parentOf_def)
|
|
apply (clarsimp simp: next_prev_0 src children_preserved)
|
|
apply (subgoal_tac "c' \<noteq> dest")
|
|
prefer 2
|
|
apply clarsimp
|
|
apply (subgoal_tac "c'' \<noteq> dest")
|
|
prefer 2
|
|
apply clarsimp
|
|
apply (drule (3) trans_parent)
|
|
apply (simp add: dest_loop)
|
|
apply (subgoal_tac "c' \<noteq> mdbPrev src_node")
|
|
prefer 2
|
|
apply clarsimp
|
|
apply (erule subtree.trans_parent)
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst (asm) modify_map_None, simp)+
|
|
apply (simp add: mdb_next_update nullPointer_def split: split_if_asm)
|
|
apply (subst (asm) modify_map_apply, simp)+
|
|
apply (simp add: mdb_next_update nullPointer_def split: split_if_asm)
|
|
apply assumption
|
|
apply (clarsimp simp add: n modify_map_def parentOf_def src children_preserved
|
|
split: split_if_asm)
|
|
done
|
|
|
|
lemma subtree_n_m:
|
|
assumes p_neq: "p \<noteq> dest" "p \<noteq> src"
|
|
assumes px: "n \<turnstile> p \<rightarrow> x"
|
|
shows "if x = dest then m \<turnstile> p \<rightarrow> src else m \<turnstile> p \<rightarrow> x" using px
|
|
proof induct
|
|
case (direct_parent c)
|
|
thus ?case using p_neq
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (subgoal_tac "p = mdbPrev src_node")
|
|
prefer 2
|
|
apply (drule mdb_next_modify_prev [where x="mdbNext src_node" and f="\<lambda>_. dest", THEN iffD2])
|
|
apply (fold m'_def)
|
|
apply (drule leadsto_is_prev)
|
|
apply (fastforce simp: n m'_def modify_map_def)
|
|
apply (rule dlist')
|
|
apply (rule no_0')
|
|
apply simp
|
|
apply clarsimp
|
|
apply (rule subtree.direct_parent)
|
|
apply (rule prev_leadstoI)
|
|
apply (rule src)
|
|
apply (insert no_0)[1]
|
|
apply (clarsimp simp add: next_unfold' n modify_map_def no_0_def split: split_if_asm)
|
|
apply (rule dlist)
|
|
apply (rule src_0)
|
|
apply (clarsimp simp: parentOf_def n modify_map_def src parent_preserved)
|
|
apply clarsimp
|
|
apply (rule subtree.direct_parent)
|
|
apply (simp add: n)
|
|
apply (cases "m (mdbPrev src_node)")
|
|
apply (subst (asm) modify_map_None, simp)+
|
|
apply (simp add: next_unfold' mdb_next_unfold)
|
|
apply (subst (asm) modify_map_apply, simp)+
|
|
apply (simp add: mdb_next_update split: split_if_asm)
|
|
apply assumption
|
|
apply (simp add: n)
|
|
apply (clarsimp simp add: parentOf_def modify_map_def split: split_if_asm)
|
|
done
|
|
next
|
|
case (trans_parent c c')
|
|
thus ?case using p_neq
|
|
apply -
|
|
apply (simp split: split_if_asm)
|
|
apply clarsimp
|
|
apply (subgoal_tac "c' = mdbNext src_node")
|
|
prefer 2
|
|
apply (clarsimp simp add: mdb_next_unfold n modify_map_def)
|
|
apply clarsimp
|
|
apply (erule subtree.trans_parent)
|
|
apply (simp add: mdb_next_unfold src)
|
|
apply assumption
|
|
apply (clarsimp simp add: parentOf_def modify_map_def n split: split_if_asm)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (subgoal_tac "c = mdbPrev src_node")
|
|
prefer 2
|
|
apply (drule mdb_next_modify_prev [where x="mdbNext src_node" and f="\<lambda>_. dest", THEN iffD2])
|
|
apply (fold m'_def)
|
|
apply (drule leadsto_is_prev)
|
|
apply (fastforce simp: n m'_def modify_map_def)
|
|
apply (rule dlist')
|
|
apply (rule no_0')
|
|
apply simp
|
|
apply clarsimp
|
|
apply (erule subtree.trans_parent)
|
|
apply (rule prev_leadstoI)
|
|
apply (rule src)
|
|
apply (insert no_0)[1]
|
|
apply (clarsimp simp: next_unfold' no_0_def n modify_map_def)
|
|
apply (rule dlist)
|
|
apply (rule src_0)
|
|
apply (clarsimp simp: parentOf_def n modify_map_def src
|
|
parent_preserved split: split_if_asm)
|
|
apply clarsimp
|
|
apply (erule subtree.trans_parent)
|
|
apply (clarsimp simp add: n modify_map_def mdb_next_unfold nullPointer_def split: split_if_asm)
|
|
apply assumption
|
|
apply (clarsimp simp add: n modify_map_def parentOf_def split: split_if_asm)
|
|
done
|
|
qed
|
|
|
|
lemma descendants:
|
|
"descendants_of' p m' =
|
|
(if p = src
|
|
then {}
|
|
else if p = dest
|
|
then descendants_of' src m
|
|
else descendants_of' p m - {src} \<union>
|
|
(if src \<in> descendants_of' p m then {dest} else {}))"
|
|
apply (rule set_eqI)
|
|
apply (simp add: descendants_of'_def m'_def)
|
|
apply (auto simp: subtree_m_n intro: subtree_src_dest subtree_dest_src no_src_subtree_n_m)
|
|
apply (auto simp: subtree_n_m)
|
|
done
|
|
end
|
|
|
|
context mdb_move_abs
|
|
begin
|
|
|
|
end
|
|
|
|
context mdb_move
|
|
begin
|
|
|
|
lemma descendants_dest:
|
|
"descendants_of' dest m = {}"
|
|
by (simp add: descendants_of'_def)
|
|
|
|
lemma dest_descendants:
|
|
"dest \<notin> descendants_of' x m"
|
|
by (simp add: descendants_of'_def)
|
|
|
|
end
|
|
|
|
lemma updateCap_dynamic_duo:
|
|
"\<lbrakk> (rv, s') \<in> fst (updateCap x cap s); pspace_aligned' s; pspace_distinct' s \<rbrakk>
|
|
\<Longrightarrow> pspace_aligned' s' \<and> pspace_distinct' s'"
|
|
unfolding updateCap_def
|
|
apply (rule conjI)
|
|
apply (erule use_valid | wp | assumption)+
|
|
done
|
|
|
|
declare const_apply[simp]
|
|
|
|
lemma next_slot_eq2:
|
|
"\<lbrakk>case n q of None \<Rightarrow> next_slot p t' m' = x | Some q' \<Rightarrow> next_slot p (t'' q') (m'' q') = x;
|
|
case n q of None \<Rightarrow> (t' = t \<and> m' = m) | Some q' \<Rightarrow> t'' q' = t \<and> m'' q' = m\<rbrakk>
|
|
\<Longrightarrow> next_slot p t m = x"
|
|
apply(simp split: option.splits)
|
|
done
|
|
|
|
abbreviation "einvs \<equiv> (invs and valid_list and valid_sched)"
|
|
|
|
lemma set_cap_not_quite_corres':
|
|
assumes cr:
|
|
"pspace_relations (ekheap (a)) (kheap s) (ksPSpace s')"
|
|
"ekheap (s) = ekheap (a)"
|
|
"cur_thread s = ksCurThread s'"
|
|
"idle_thread s = ksIdleThread s'"
|
|
"machine_state s = ksMachineState s'"
|
|
"work_units_completed s = ksWorkUnitsCompleted s'"
|
|
"domain_index s = ksDomScheduleIdx s'"
|
|
"domain_list s = ksDomSchedule s'"
|
|
"cur_domain s = ksCurDomain s'"
|
|
"domain_time s = ksDomainTime s'"
|
|
"(x,t') \<in> fst (updateCap p' c' s')"
|
|
"valid_objs s" "pspace_aligned s" "pspace_distinct s" "cte_at p s"
|
|
"pspace_aligned' s'" "pspace_distinct' s'"
|
|
"interrupt_state_relation (interrupt_irq_node s) (interrupt_states s) (ksInterruptState s')"
|
|
"(arch_state s, ksArchState s') \<in> arch_state_relation"
|
|
assumes c: "cap_relation c c'"
|
|
assumes p: "p' = cte_map p"
|
|
shows "\<exists>t. ((),t) \<in> fst (set_cap c p s) \<and>
|
|
pspace_relations (ekheap t) (kheap t) (ksPSpace t') \<and>
|
|
cdt t = cdt s \<and>
|
|
cdt_list t = cdt_list (s) \<and>
|
|
ekheap t = ekheap (s) \<and>
|
|
scheduler_action t = scheduler_action (s) \<and>
|
|
ready_queues t = ready_queues (s) \<and>
|
|
is_original_cap t = is_original_cap s \<and>
|
|
interrupt_state_relation (interrupt_irq_node t) (interrupt_states t)
|
|
(ksInterruptState t') \<and>
|
|
(arch_state t, ksArchState t') \<in> arch_state_relation \<and>
|
|
cur_thread t = ksCurThread t' \<and>
|
|
idle_thread t = ksIdleThread t' \<and>
|
|
machine_state t = ksMachineState t' \<and>
|
|
work_units_completed t = ksWorkUnitsCompleted t' \<and>
|
|
domain_index t = ksDomScheduleIdx t' \<and>
|
|
domain_list t = ksDomSchedule t' \<and>
|
|
cur_domain t = ksCurDomain t' \<and>
|
|
domain_time t = ksDomainTime t'"
|
|
apply (rule set_cap_not_quite_corres)
|
|
using cr
|
|
apply (fastforce simp: c p pspace_relations_def)+
|
|
done
|
|
|
|
lemma cap_move_corres:
|
|
assumes cr: "cap_relation cap cap'"
|
|
notes trans_state_update'[symmetric,simp]
|
|
shows
|
|
"corres dc (einvs and
|
|
cte_at ptr and
|
|
cte_wp_at (\<lambda>c. c = cap.NullCap) ptr' and
|
|
valid_cap cap and tcb_cap_valid cap ptr' and K (ptr \<noteq> ptr'))
|
|
(invs' and
|
|
cte_wp_at' (\<lambda>c. weak_derived' cap' (cteCap c) \<and> cteCap c \<noteq> NullCap) (cte_map ptr) and
|
|
cte_wp_at' (\<lambda>c. cteCap c = NullCap) (cte_map ptr'))
|
|
(cap_move cap ptr ptr') (cteMove cap' (cte_map ptr) (cte_map ptr'))"
|
|
(is "corres _ ?P ?P' _ _")
|
|
apply (simp add: cap_move_def cteMove_def const_def)
|
|
apply (rule corres_symb_exec_r)
|
|
defer
|
|
apply (rule getCTE_sp)
|
|
apply wp
|
|
apply (rule no_fail_pre, wp)
|
|
apply (clarsimp simp add: cte_wp_at_ctes_of)
|
|
apply (rule corres_assert_assume)
|
|
prefer 2
|
|
apply (clarsimp simp: cte_wp_at_ctes_of)
|
|
apply (rule corres_assert_assume)
|
|
prefer 2
|
|
apply clarsimp
|
|
apply (drule invs_mdb')
|
|
apply (clarsimp simp: cte_wp_at_ctes_of valid_mdb'_def valid_mdb_ctes_def)
|
|
apply (case_tac oldCTE)
|
|
apply (clarsimp simp: valid_nullcaps_def initMDBNode_def)
|
|
apply (erule allE)+
|
|
apply (erule (1) impE)
|
|
apply (clarsimp simp: nullPointer_def)
|
|
apply (rule corres_symb_exec_r)
|
|
defer
|
|
apply (rule getCTE_sp)
|
|
apply wp
|
|
apply (rule no_fail_pre, wp)
|
|
apply (clarsimp simp add: cte_wp_at_ctes_of)
|
|
apply (rule corres_no_failI)
|
|
apply (rule no_fail_pre, wp hoare_weak_lift_imp)
|
|
apply (clarsimp simp add: cte_wp_at_ctes_of)
|
|
apply (drule invs_mdb')
|
|
apply (clarsimp simp: valid_mdb'_def valid_mdb_ctes_def)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (erule (2) valid_dlistEp, simp)
|
|
apply clarsimp
|
|
apply (erule (2) valid_dlistEn, simp)
|
|
apply (clarsimp simp: in_monad state_relation_def)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of)
|
|
apply (case_tac oldCTE)
|
|
apply (rename_tac x old_dest_node)
|
|
apply (case_tac cte)
|
|
apply (rename_tac src_cap src_node)
|
|
apply clarsimp
|
|
apply (subgoal_tac "\<exists>c. caps_of_state a ptr = Some c")
|
|
prefer 2
|
|
apply (clarsimp simp: cte_wp_at_caps_of_state)
|
|
apply clarsimp
|
|
apply (subgoal_tac "cap_relation c src_cap")
|
|
prefer 2
|
|
apply (drule caps_of_state_cteD)
|
|
apply (drule (1) pspace_relation_ctes_ofI)
|
|
apply fastforce
|
|
apply fastforce
|
|
apply fastforce
|
|
apply (drule (1) pspace_relationsD)
|
|
apply (drule_tac p=ptr' in set_cap_not_quite_corres, assumption+)
|
|
apply fastforce
|
|
apply fastforce
|
|
apply fastforce
|
|
apply (erule cte_wp_at_weakenE, rule TrueI)
|
|
apply fastforce
|
|
apply fastforce
|
|
apply assumption
|
|
apply fastforce
|
|
apply (rule cr)
|
|
apply (rule refl)
|
|
apply (clarsimp simp: split_def)
|
|
apply (rule bind_execI, assumption)
|
|
apply (drule_tac p=ptr and c="cap.NullCap" in set_cap_not_quite_corres')
|
|
apply assumption+
|
|
apply (frule use_valid [OF _ set_cap_valid_objs])
|
|
apply fastforce
|
|
apply assumption
|
|
apply (frule use_valid [OF _ set_cap_aligned])
|
|
apply fastforce
|
|
apply assumption
|
|
apply (frule use_valid [OF _ set_cap_distinct])
|
|
apply fastforce
|
|
apply assumption
|
|
apply (frule use_valid [OF _ set_cap_cte_at])
|
|
prefer 2
|
|
apply assumption
|
|
apply assumption
|
|
apply (drule updateCap_stuff)
|
|
apply (elim conjE mp, fastforce)
|
|
apply (drule updateCap_stuff)
|
|
apply (elim conjE mp, fastforce)
|
|
apply assumption
|
|
apply simp
|
|
apply simp
|
|
apply (rule refl)
|
|
apply clarsimp
|
|
apply (rule bind_execI, assumption)
|
|
apply(subgoal_tac "mdb_move_abs ptr ptr' (cdt a) a")
|
|
apply (frule mdb_move_abs'.intro)
|
|
prefer 2
|
|
apply(rule mdb_move_abs.intro)
|
|
apply(clarsimp)
|
|
apply(fastforce elim!: cte_wp_at_weakenE)
|
|
apply(simp)
|
|
apply(simp)
|
|
apply (clarsimp simp: exec_gets exec_get exec_put set_cdt_def
|
|
set_original_def bind_assoc modify_def
|
|
|(rule bind_execI[where f="cap_move_ext x y z x'" for x y z x'], clarsimp simp: mdb_move_abs'.cap_move_ext_det_def2 update_cdt_list_def set_cdt_list_def put_def) | rule refl )+
|
|
apply (clarsimp simp: put_def)
|
|
apply (clarsimp simp: invs'_def valid_state'_def)
|
|
apply (frule updateCap_dynamic_duo, fastforce, fastforce)
|
|
apply (frule(2) updateCap_dynamic_duo [OF _ conjunct1 conjunct2])
|
|
apply (subgoal_tac "no_0 (ctes_of b)")
|
|
prefer 2
|
|
apply fastforce
|
|
apply (frule(1) use_valid [OF _ updateCap_no_0])
|
|
apply (frule(2) use_valid [OF _ updateCap_no_0, OF _ use_valid [OF _ updateCap_no_0]])
|
|
apply (elim conjE)
|
|
apply (drule (5) updateMDB_the_lot', elim conjE)
|
|
apply (drule (4) updateMDB_the_lot, elim conjE)
|
|
apply (drule (4) updateMDB_the_lot, elim conjE)
|
|
apply (drule (4) updateMDB_the_lot, elim conjE)
|
|
apply (drule updateCap_stuff, elim conjE, erule (1) impE)
|
|
apply (drule updateCap_stuff, clarsimp)
|
|
apply (subgoal_tac "pspace_distinct' b \<and> pspace_aligned' b")
|
|
prefer 2
|
|
subgoal by fastforce
|
|
apply (thin_tac "ctes_of t = s" for t s)+
|
|
apply (thin_tac "ksMachineState t = p" for t p)+
|
|
apply (thin_tac "ksCurThread t = p" for t p)+
|
|
apply (thin_tac "ksIdleThread t = p" for t p)+
|
|
apply (thin_tac "ksReadyQueues t = p" for t p)+
|
|
apply (thin_tac "ksSchedulerAction t = p" for t p)+
|
|
apply (subgoal_tac "\<forall>p. cte_at p ta = cte_at p a")
|
|
prefer 2
|
|
apply (simp add: set_cap_cte_eq)
|
|
apply (clarsimp simp add: swp_def cte_wp_at_ctes_of simp del: split_paired_All)
|
|
apply (subgoal_tac "cte_at ptr' a")
|
|
prefer 2
|
|
apply (erule cte_wp_at_weakenE, rule TrueI)
|
|
apply (subgoal_tac "cte_map ptr \<noteq> cte_map ptr'")
|
|
prefer 2
|
|
apply (erule (2) cte_map_inj)
|
|
apply fastforce
|
|
apply fastforce
|
|
apply fastforce
|
|
apply (clarsimp simp: pspace_relations_def)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv)
|
|
apply (subst conj_assoc[symmetric])
|
|
apply (rule conjI)
|
|
defer
|
|
apply (drule set_cap_caps_of_state_monad)+
|
|
apply (simp add: modify_map_mdb_cap)
|
|
apply (simp add: modify_map_apply)
|
|
apply (clarsimp simp add: revokable_relation_def simp del: fun_upd_apply)
|
|
apply simp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (erule_tac x="fst ptr" in allE)
|
|
apply (erule_tac x="snd ptr" in allE)
|
|
apply simp
|
|
apply (erule impE)
|
|
subgoal by (clarsimp simp: cte_wp_at_caps_of_state null_filter_def split: split_if_asm)
|
|
apply simp
|
|
apply clarsimp
|
|
apply (subgoal_tac "null_filter (caps_of_state a) (aa,bb) \<noteq> None")
|
|
prefer 2
|
|
subgoal by (clarsimp simp: null_filter_def split: if_splits)
|
|
apply clarsimp
|
|
apply (subgoal_tac "cte_at (aa,bb) a")
|
|
prefer 2
|
|
apply (drule null_filter_caps_of_stateD)
|
|
apply (erule cte_wp_cte_at)
|
|
apply (frule_tac p="(aa,bb)" and p'="ptr'" in cte_map_inj, assumption+)
|
|
apply fastforce
|
|
apply fastforce
|
|
apply fastforce
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (subgoal_tac "(aa,bb) \<noteq> ptr")
|
|
apply (frule_tac p="(aa,bb)" and p'="ptr" in cte_map_inj, assumption+)
|
|
apply fastforce
|
|
apply fastforce
|
|
apply fastforce
|
|
apply clarsimp
|
|
subgoal by (simp add: null_filter_def split: if_splits)
|
|
apply (subgoal_tac "mdb_move (ctes_of b) (cte_map ptr) src_cap src_node (cte_map ptr') cap' old_dest_node")
|
|
prefer 2
|
|
apply (rule mdb_move.intro)
|
|
apply (rule mdb_ptr.intro)
|
|
apply (rule vmdb.intro)
|
|
apply (simp add: valid_pspace'_def valid_mdb'_def)
|
|
apply (erule mdb_ptr_axioms.intro)
|
|
apply (rule mdb_move_axioms.intro)
|
|
apply assumption
|
|
apply (simp add: nullPointer_def)
|
|
apply (simp add: nullPointer_def)
|
|
apply (erule weak_derived_sym')
|
|
apply clarsimp
|
|
apply assumption
|
|
apply (rule conjI)
|
|
apply (simp (no_asm) add: cdt_relation_def)
|
|
apply clarsimp
|
|
apply (subst mdb_move.descendants, assumption)
|
|
apply (subst mdb_move_abs.descendants[simplified fun_upd_apply])
|
|
apply (rule mdb_move_abs.intro)
|
|
apply fastforce
|
|
apply (fastforce elim!: cte_wp_at_weakenE)
|
|
apply simp
|
|
apply simp
|
|
apply (case_tac "(aa,bb) = ptr", simp)
|
|
apply (subgoal_tac "cte_map (aa,bb) \<noteq> cte_map ptr")
|
|
prefer 2
|
|
apply (erule (2) cte_map_inj, fastforce, fastforce, fastforce)
|
|
apply (case_tac "(aa,bb) = ptr'")
|
|
apply (simp add: cdt_relation_def del: split_paired_All)
|
|
apply (subgoal_tac "cte_map (aa,bb) \<noteq> cte_map ptr'")
|
|
prefer 2
|
|
apply (erule (2) cte_map_inj, fastforce, fastforce, fastforce)
|
|
apply (simp only: if_False)
|
|
apply simp
|
|
apply (subgoal_tac "descendants_of' (cte_map (aa, bb)) (ctes_of b) =
|
|
cte_map ` descendants_of (aa, bb) (cdt a)")
|
|
prefer 2
|
|
apply (simp add: cdt_relation_def del: split_paired_All)
|
|
apply simp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (subst inj_on_image_set_diff15)
|
|
apply (rule inj_on_descendants_cte_map)
|
|
apply fastforce
|
|
apply fastforce
|
|
apply fastforce
|
|
apply fastforce
|
|
apply (rule subset_refl)
|
|
apply simp
|
|
apply simp
|
|
apply clarsimp
|
|
apply (drule (1) cte_map_inj_eq)
|
|
apply (erule descendants_of_cte_at)
|
|
apply fastforce
|
|
apply fastforce
|
|
apply fastforce
|
|
apply fastforce
|
|
subgoal by clarsimp
|
|
apply(clarsimp simp: cdt_list_relation_def)
|
|
|
|
apply(subst next_slot_eq2)
|
|
apply(simp split: option.splits)
|
|
apply(intro conjI impI)
|
|
apply(rule mdb_move_abs'.next_slot_no_parent)
|
|
apply(simp, fastforce, simp)
|
|
apply(intro allI impI)
|
|
apply(rule mdb_move_abs'.next_slot)
|
|
apply(simp, fastforce, simp)
|
|
apply(fastforce split: option.splits)
|
|
apply(case_tac "ctes_of b (cte_map (aa, bb))")
|
|
subgoal by (clarsimp simp: modify_map_def split: split_if_asm)
|
|
apply(case_tac ab)
|
|
apply(frule mdb_move.m'_next)
|
|
apply(simp, fastforce)
|
|
apply(case_tac "(aa, bb) = ptr")
|
|
apply(simp)
|
|
apply(case_tac "(aa, bb) = ptr'")
|
|
apply(case_tac "next_slot ptr (cdt_list (a)) (cdt a)")
|
|
subgoal by(simp)
|
|
apply(simp)
|
|
apply(erule_tac x="fst ptr" in allE)
|
|
apply(erule_tac x="snd ptr" in allE)
|
|
subgoal by(clarsimp split: split_if_asm)
|
|
apply(frule invs_mdb, frule invs_valid_pspace)
|
|
apply(frule finite_depth)
|
|
apply simp
|
|
apply(case_tac "next_slot (aa, bb) (cdt_list (a)) (cdt a) = Some ptr")
|
|
apply(frule(3) cte_at_next_slot)
|
|
apply(erule_tac x=aa in allE, erule_tac x=bb in allE)
|
|
subgoal by (clarsimp simp: cte_map_inj_eq valid_pspace_def split: split_if_asm)
|
|
apply(simp)
|
|
apply(case_tac "next_slot (aa, bb) (cdt_list (a)) (cdt a)")
|
|
subgoal by(simp)
|
|
apply(frule(3) cte_at_next_slot)
|
|
apply(frule(3) cte_at_next_slot')
|
|
apply(erule_tac x=aa in allE, erule_tac x=bb in allE)
|
|
by(clarsimp simp: cte_map_inj_eq valid_pspace_def split: split_if_asm)
|
|
|
|
lemmas cur_tcb_lift =
|
|
hoare_lift_Pf [where f = ksCurThread and P = tcb_at', folded cur_tcb'_def]
|
|
|
|
lemma valid_bitmapQ_lift:
|
|
assumes prq: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueues s) \<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueues s)\<rbrace>"
|
|
and prqL1: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueuesL1Bitmap s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueuesL1Bitmap s)\<rbrace>"
|
|
and prqL2: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueuesL2Bitmap s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueuesL2Bitmap s)\<rbrace>"
|
|
shows "\<lbrace>Invariants_H.valid_bitmapQ\<rbrace> f \<lbrace>\<lambda>_. Invariants_H.valid_bitmapQ\<rbrace>"
|
|
unfolding valid_bitmapQ_def bitmapQ_def
|
|
apply (wp hoare_vcg_all_lift)
|
|
apply (rule hoare_pre)
|
|
apply (wps prq prqL1 prqL2)
|
|
apply (rule hoare_vcg_prop, assumption)
|
|
done
|
|
|
|
lemma bitmapQ_no_L1_orphans_lift:
|
|
assumes prq: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueues s) \<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueues s)\<rbrace>"
|
|
and prqL1: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueuesL1Bitmap s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueuesL1Bitmap s)\<rbrace>"
|
|
and prqL2: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueuesL2Bitmap s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueuesL2Bitmap s)\<rbrace>"
|
|
shows "\<lbrace> bitmapQ_no_L1_orphans \<rbrace> f \<lbrace>\<lambda>_. bitmapQ_no_L1_orphans \<rbrace>"
|
|
unfolding valid_bitmapQ_def bitmapQ_def bitmapQ_no_L1_orphans_def
|
|
apply (wp hoare_vcg_all_lift)
|
|
apply (rule hoare_pre)
|
|
apply (wps prq prqL1 prqL2)
|
|
apply (rule hoare_vcg_prop, assumption)
|
|
done
|
|
|
|
lemma bitmapQ_no_L2_orphans_lift:
|
|
assumes prq: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueues s) \<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueues s)\<rbrace>"
|
|
and prqL1: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueuesL1Bitmap s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueuesL1Bitmap s)\<rbrace>"
|
|
and prqL2: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueuesL2Bitmap s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueuesL2Bitmap s)\<rbrace>"
|
|
shows "\<lbrace> bitmapQ_no_L2_orphans \<rbrace> f \<lbrace>\<lambda>_. bitmapQ_no_L2_orphans \<rbrace>"
|
|
unfolding valid_bitmapQ_def bitmapQ_def bitmapQ_no_L2_orphans_def
|
|
apply (wp hoare_vcg_all_lift)
|
|
apply (rule hoare_pre)
|
|
apply (wps prq prqL1 prqL2)
|
|
apply (rule hoare_vcg_prop, assumption)
|
|
done
|
|
|
|
lemma valid_queues_lift_asm:
|
|
assumes tat1: "\<And>d p tcb. \<lbrace>obj_at' (inQ d p) tcb and Q \<rbrace> f \<lbrace>\<lambda>_. obj_at' (inQ d p) tcb\<rbrace>"
|
|
and tat2: "\<And>tcb. \<lbrace>st_tcb_at' runnable' tcb and Q \<rbrace> f \<lbrace>\<lambda>_. st_tcb_at' runnable' tcb\<rbrace>"
|
|
and prq: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueues s) \<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueues s)\<rbrace>"
|
|
and prqL1: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueuesL1Bitmap s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueuesL1Bitmap s)\<rbrace>"
|
|
and prqL2: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueuesL2Bitmap s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueuesL2Bitmap s)\<rbrace>"
|
|
shows "\<lbrace>Invariants_H.valid_queues and Q\<rbrace> f \<lbrace>\<lambda>_. Invariants_H.valid_queues\<rbrace>"
|
|
proof -
|
|
have tat: "\<And>d p tcb. \<lbrace>obj_at' (inQ d p) tcb and st_tcb_at' runnable' tcb and Q\<rbrace> f
|
|
\<lbrace>\<lambda>_. obj_at' (inQ d p) tcb and st_tcb_at' runnable' tcb\<rbrace>"
|
|
apply (rule hoare_chain [OF hoare_vcg_conj_lift [OF tat1 tat2]])
|
|
apply (fastforce)+
|
|
done
|
|
have tat_combined: "\<And>d p tcb. \<lbrace>obj_at' (inQ d p and runnable' \<circ> tcbState) tcb and Q\<rbrace> f
|
|
\<lbrace>\<lambda>_. obj_at' (inQ d p and runnable' \<circ> tcbState) tcb\<rbrace>"
|
|
apply (rule hoare_chain [OF tat])
|
|
apply (fastforce simp add: obj_at'_and pred_tcb_at'_def o_def)+
|
|
done
|
|
show ?thesis unfolding valid_queues_def valid_queues_no_bitmap_def
|
|
by (wp tat_combined prq prqL1 prqL2 valid_bitmapQ_lift bitmapQ_no_L2_orphans_lift
|
|
bitmapQ_no_L1_orphans_lift hoare_vcg_all_lift hoare_vcg_conj_lift hoare_Ball_helper)
|
|
simp_all
|
|
qed
|
|
|
|
lemmas valid_queues_lift = valid_queues_lift_asm[where Q="\<lambda>_. True", simplified]
|
|
|
|
lemma valid_queues_lift':
|
|
assumes tat: "\<And>d p tcb. \<lbrace>\<lambda>s. \<not> obj_at' (inQ d p) tcb s\<rbrace> f \<lbrace>\<lambda>_ s. \<not> obj_at' (inQ d p) tcb s\<rbrace>"
|
|
and prq: "\<And>P. \<lbrace>\<lambda>s. P (ksReadyQueues s)\<rbrace> f \<lbrace>\<lambda>_ s. P (ksReadyQueues s)\<rbrace>"
|
|
shows "\<lbrace>valid_queues'\<rbrace> f \<lbrace>\<lambda>_. valid_queues'\<rbrace>"
|
|
unfolding valid_queues'_def imp_conv_disj
|
|
by (wp hoare_vcg_all_lift hoare_vcg_disj_lift tat prq)
|
|
|
|
lemma setCTE_norq [wp]:
|
|
"\<lbrace>\<lambda>s. P (ksReadyQueues s)\<rbrace> setCTE ptr cte \<lbrace>\<lambda>r s. P (ksReadyQueues s) \<rbrace>"
|
|
by (clarsimp simp: valid_def dest!: setCTE_pspace_only)
|
|
|
|
lemma setCTE_norqL1 [wp]:
|
|
"\<lbrace>\<lambda>s. P (ksReadyQueuesL1Bitmap s)\<rbrace> setCTE ptr cte \<lbrace>\<lambda>r s. P (ksReadyQueuesL1Bitmap s) \<rbrace>"
|
|
by (clarsimp simp: valid_def dest!: setCTE_pspace_only)
|
|
|
|
lemma setCTE_norqL2 [wp]:
|
|
"\<lbrace>\<lambda>s. P (ksReadyQueuesL2Bitmap s)\<rbrace> setCTE ptr cte \<lbrace>\<lambda>r s. P (ksReadyQueuesL2Bitmap s) \<rbrace>"
|
|
by (clarsimp simp: valid_def dest!: setCTE_pspace_only)
|
|
|
|
crunch nosch[wp]: cteInsert "\<lambda>s. P (ksSchedulerAction s)"
|
|
(wp: updateObject_cte_inv hoare_drop_imps)
|
|
|
|
crunch norq[wp]: cteInsert "\<lambda>s. P (ksReadyQueues s)"
|
|
(wp: updateObject_cte_inv hoare_drop_imps)
|
|
|
|
crunch norqL1[wp]: cteInsert "\<lambda>s. P (ksReadyQueuesL1Bitmap s)"
|
|
(wp: updateObject_cte_inv hoare_drop_imps)
|
|
|
|
crunch norqL2[wp]: cteInsert "\<lambda>s. P (ksReadyQueuesL2Bitmap s)"
|
|
(wp: updateObject_cte_inv hoare_drop_imps)
|
|
|
|
crunch typ_at'[wp]: cteInsert "\<lambda>s. P (typ_at' T p s)"
|
|
(wp: hoare_drop_imps setCTE_typ_at')
|
|
|
|
lemmas updateMDB_typ_ats [wp] = typ_at_lifts [OF updateMDB_typ_at']
|
|
lemmas updateCap_typ_ats [wp] = typ_at_lifts [OF updateCap_typ_at']
|
|
lemmas cteInsert_typ_ats [wp] = typ_at_lifts [OF cteInsert_typ_at']
|
|
|
|
lemma setObject_cte_ct:
|
|
"\<lbrace>\<lambda>s. P (ksCurThread s)\<rbrace> setObject t (v::cte) \<lbrace>\<lambda>rv s. P (ksCurThread s)\<rbrace>"
|
|
by (clarsimp simp: valid_def setCTE_def[symmetric] dest!: setCTE_pspace_only)
|
|
|
|
crunch ct[wp]: cteInsert "\<lambda>s. P (ksCurThread s)"
|
|
(wp: setObject_cte_ct hoare_drop_imps ignore: setObject)
|
|
|
|
context mdb_insert
|
|
begin
|
|
|
|
lemma n_src_dest:
|
|
"n \<turnstile> src \<leadsto> dest"
|
|
by (simp add: n_direct_eq)
|
|
|
|
lemma dest_chain_0 [simp, intro!]:
|
|
"n \<turnstile> dest \<leadsto>\<^sup>+ 0"
|
|
using chain_n n_dest
|
|
by (simp add: mdb_chain_0_def) blast
|
|
|
|
lemma m_tranclD:
|
|
"m \<turnstile> p \<leadsto>\<^sup>+ p' \<Longrightarrow> p' \<noteq> dest \<and> (p = dest \<longrightarrow> p' = 0) \<and> n \<turnstile> p \<leadsto>\<^sup>+ p'"
|
|
apply (erule trancl_induct)
|
|
apply (rule context_conjI, clarsimp)
|
|
apply (rule context_conjI, clarsimp)
|
|
apply (cases "p = src")
|
|
apply simp
|
|
apply (rule trancl_trans)
|
|
apply (rule r_into_trancl)
|
|
apply (rule n_src_dest)
|
|
apply (rule r_into_trancl)
|
|
apply (simp add: n_direct_eq)
|
|
apply (cases "p = dest", simp)
|
|
apply (rule r_into_trancl)
|
|
apply (simp add: n_direct_eq)
|
|
apply clarsimp
|
|
apply (rule context_conjI, clarsimp)
|
|
apply (rule context_conjI, clarsimp simp: mdb_next_unfold)
|
|
apply (case_tac "y = src")
|
|
apply clarsimp
|
|
apply (erule trancl_trans)
|
|
apply (rule trancl_trans)
|
|
apply (rule r_into_trancl)
|
|
apply (rule n_src_dest)
|
|
apply (rule r_into_trancl)
|
|
apply (simp add: n_direct_eq)
|
|
apply (case_tac "y = dest", simp)
|
|
apply (erule trancl_trans)
|
|
apply (rule r_into_trancl)
|
|
apply (simp add: n_direct_eq)
|
|
done
|
|
|
|
lemma n_trancl_eq':
|
|
"n \<turnstile> p \<leadsto>\<^sup>+ p' =
|
|
(if p' = dest then m \<turnstile> p \<leadsto>\<^sup>* src
|
|
else if p = dest then m \<turnstile> src \<leadsto>\<^sup>+ p'
|
|
else m \<turnstile> p \<leadsto>\<^sup>+ p')"
|
|
apply (rule iffI)
|
|
apply (erule trancl_induct)
|
|
apply (clarsimp simp: n_direct_eq)
|
|
apply (fastforce split: split_if_asm)
|
|
apply (clarsimp simp: n_direct_eq split: split_if_asm)
|
|
apply fastforce
|
|
apply fastforce
|
|
apply (fastforce intro: trancl_trans)
|
|
apply (fastforce intro: trancl_trans)
|
|
apply (simp split: split_if_asm)
|
|
apply (drule rtranclD)
|
|
apply (erule disjE)
|
|
apply (fastforce intro: n_src_dest)
|
|
apply (clarsimp dest!: m_tranclD)
|
|
apply (erule trancl_trans)
|
|
apply (fastforce intro: n_src_dest)
|
|
apply (drule m_tranclD, clarsimp)
|
|
apply (drule tranclD)
|
|
apply clarsimp
|
|
apply (insert n_src_dest)[1]
|
|
apply (drule (1) next_single_value)
|
|
apply (clarsimp simp: rtrancl_eq_or_trancl)
|
|
apply (drule m_tranclD)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma n_trancl_eq:
|
|
"n \<turnstile> p \<leadsto>\<^sup>+ p' =
|
|
(if p' = dest then p = src \<or> m \<turnstile> p \<leadsto>\<^sup>+ src
|
|
else if p = dest then m \<turnstile> src \<leadsto>\<^sup>+ p'
|
|
else m \<turnstile> p \<leadsto>\<^sup>+ p')"
|
|
by (auto simp add: n_trancl_eq' rtrancl_eq_or_trancl)
|
|
|
|
lemma n_rtrancl_eq:
|
|
"n \<turnstile> p \<leadsto>\<^sup>* p' =
|
|
(if p' = dest then p = dest \<or> p \<noteq> dest \<and> m \<turnstile> p \<leadsto>\<^sup>* src
|
|
else if p = dest then p' \<noteq> src \<and> m \<turnstile> src \<leadsto>\<^sup>* p'
|
|
else m \<turnstile> p \<leadsto>\<^sup>* p')"
|
|
by (auto simp: n_trancl_eq rtrancl_eq_or_trancl)
|
|
|
|
|
|
lemma n_cap:
|
|
"n p = Some (CTE cap node) \<Longrightarrow>
|
|
\<exists>node'. if p = dest then cap = c' \<and> m p = Some (CTE dest_cap node')
|
|
else m p = Some (CTE cap node')"
|
|
by (simp add: n src dest new_src_def new_dest_def split: split_if_asm)
|
|
|
|
lemma m_cap:
|
|
"m p = Some (CTE cap node) \<Longrightarrow>
|
|
\<exists>node'. if p = dest then cap = dest_cap \<and> n p = Some (CTE c' node')
|
|
else n p = Some (CTE cap node')"
|
|
apply (simp add: n new_src_def new_dest_def)
|
|
apply (cases "p=dest")
|
|
apply (auto simp: src dest)
|
|
done
|
|
|
|
lemma chunked_m:
|
|
"mdb_chunked m"
|
|
using valid by (simp add: valid_mdb_ctes_def)
|
|
|
|
lemma derived_region1 [simp]:
|
|
"badge_derived' c' src_cap \<Longrightarrow>
|
|
sameRegionAs c' cap = sameRegionAs src_cap cap"
|
|
by (clarsimp simp add: badge_derived'_def sameRegionAs_def2)
|
|
|
|
lemma derived_region2 [simp]:
|
|
"badge_derived' c' src_cap \<Longrightarrow>
|
|
sameRegionAs cap c' = sameRegionAs cap src_cap"
|
|
by (clarsimp simp add: badge_derived'_def sameRegionAs_def2)
|
|
|
|
lemma chunked_n:
|
|
assumes b: "badge_derived' c' src_cap"
|
|
shows "mdb_chunked n"
|
|
using chunked_m src b
|
|
apply (clarsimp simp: mdb_chunked_def)
|
|
apply (drule n_cap)+
|
|
apply clarsimp
|
|
apply (simp split: split_if_asm)
|
|
apply clarsimp
|
|
apply (erule_tac x=src in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply simp
|
|
apply (case_tac "src=p'")
|
|
apply (clarsimp simp: n_trancl_eq)
|
|
apply (clarsimp simp: is_chunk_def n_trancl_eq n_rtrancl_eq n_dest new_dest_def)
|
|
apply (drule (1) trancl_rtrancl_trancl)
|
|
apply simp
|
|
apply (clarsimp simp: n_trancl_eq)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: is_chunk_def n_trancl_eq n_rtrancl_eq)
|
|
apply (erule_tac x=p'' in allE)
|
|
apply clarsimp
|
|
apply (drule_tac p=p'' in m_cap)
|
|
apply (clarsimp split: split_if_asm)
|
|
apply clarsimp
|
|
apply (clarsimp simp: is_chunk_def n_trancl_eq n_rtrancl_eq n_dest new_dest_def)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (erule_tac x=src in allE)
|
|
apply simp
|
|
apply clarsimp
|
|
apply (erule_tac x=p'' in allE)
|
|
apply clarsimp
|
|
apply (drule_tac p=p'' in m_cap)
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (clarsimp simp: n_trancl_eq)
|
|
apply (case_tac "p=src")
|
|
apply (clarsimp simp: is_chunk_def n_trancl_eq n_rtrancl_eq n_dest new_dest_def)
|
|
apply (drule (1) trancl_rtrancl_trancl)
|
|
apply simp
|
|
apply simp
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule_tac x=src in allE)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (clarsimp simp: is_chunk_def n_trancl_eq n_rtrancl_eq n_dest new_dest_def)
|
|
apply (erule_tac x=p'' in allE)
|
|
apply clarsimp
|
|
apply (drule_tac p=p'' in m_cap)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (clarsimp simp: is_chunk_def n_trancl_eq n_rtrancl_eq n_dest new_dest_def)
|
|
apply (erule_tac x=p'' in allE)
|
|
apply clarsimp
|
|
apply (drule_tac p=p'' in m_cap)
|
|
apply clarsimp
|
|
apply (clarsimp simp: n_trancl_eq)
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (simp add: is_chunk_def n_trancl_eq n_rtrancl_eq n_dest new_dest_def)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (erule sameRegionAsE, simp_all add: sameRegionAs_def3)[1]
|
|
apply blast
|
|
apply blast
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule_tac x=p'' in allE)
|
|
apply clarsimp
|
|
apply (drule_tac p=p'' in m_cap)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (simp add: is_chunk_def n_trancl_eq n_rtrancl_eq n_dest new_dest_def)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (erule_tac x=p in allE, simp, erule(1) sameRegionAs_trans)
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule_tac x=p'' in allE)
|
|
apply clarsimp
|
|
apply (drule_tac p=p'' in m_cap)
|
|
apply clarsimp
|
|
done
|
|
|
|
end
|
|
|
|
context mdb_insert_der
|
|
begin
|
|
|
|
lemma untyped_c':
|
|
"untypedRange c' = untypedRange src_cap"
|
|
"isUntypedCap c' = isUntypedCap src_cap"
|
|
using partial_is_derived'
|
|
apply -
|
|
apply (case_tac "isUntypedCap src_cap")
|
|
by (clarsimp simp:isCap_simps freeIndex_update_def is_derived'_def
|
|
badge_derived'_def capMasterCap_def split:if_splits capability.splits)+
|
|
|
|
lemma capRange_c':
|
|
"capRange c' = capRange src_cap"
|
|
using partial_is_derived' untyped_c'
|
|
apply -
|
|
apply (case_tac "isUntypedCap src_cap")
|
|
apply (clarsimp simp:untypedCapRange)
|
|
apply (rule master_eqI, rule capRange_Master)
|
|
apply simp
|
|
apply (rule arg_cong)
|
|
apply (auto simp:isCap_simps freeIndex_update_def is_derived'_def
|
|
badge_derived'_def capMasterCap_def split:if_splits capability.splits)
|
|
done
|
|
|
|
lemma untyped_no_parent:
|
|
"isUntypedCap src_cap \<Longrightarrow> \<not> m \<turnstile> src \<rightarrow> p"
|
|
using partial_is_derived' untyped_c'
|
|
by (clarsimp simp: is_derived'_def isCap_simps freeIndex_update_def descendants_of'_def)
|
|
|
|
end
|
|
|
|
lemma (in mdb_insert) n_revocable:
|
|
"n p = Some (CTE cap node) \<Longrightarrow>
|
|
\<exists>node'. if p = dest then mdbRevocable node = revokable' src_cap c'
|
|
else mdbRevocable node = mdbRevocable node' \<and> m p = Some (CTE cap node')"
|
|
using src dest
|
|
by (clarsimp simp: n new_src_def new_dest_def split: split_if_asm)
|
|
|
|
lemma (in mdb_insert_der) irq_control_n:
|
|
"irq_control n"
|
|
using src dest partial_is_derived'
|
|
apply (clarsimp simp: irq_control_def)
|
|
apply (frule n_cap)
|
|
apply (drule n_revocable)
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (simp add: is_derived'_def isCap_simps)
|
|
apply (frule irq_revocable, rule irq_control)
|
|
apply clarsimp
|
|
apply (drule n_cap)
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (erule disjE)
|
|
apply (clarsimp simp: is_derived'_def isCap_simps)
|
|
apply (erule (1) irq_controlD, rule irq_control)
|
|
done
|
|
|
|
context mdb_insert_child
|
|
begin
|
|
|
|
lemma untyped_mdb_n:
|
|
shows "untyped_mdb' n"
|
|
using untyped_mdb
|
|
apply (clarsimp simp add: untyped_mdb'_def descendants split del: split_if)
|
|
apply (drule n_cap)+
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (erule disjE, clarsimp)
|
|
apply (simp add: descendants_of'_def)
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule_tac x=src in allE)
|
|
apply (simp add: src untyped_c' capRange_c')
|
|
apply (erule disjE)
|
|
apply clarsimp
|
|
apply (simp add: descendants_of'_def untyped_c')
|
|
apply (erule_tac x=src in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply (fastforce simp: src dest: untyped_no_parent)
|
|
apply (case_tac "p=src", simp)
|
|
apply simp
|
|
done
|
|
|
|
lemma parent_untyped_must_not_usable:
|
|
"\<lbrakk>ptr \<noteq> src; m ptr = Some (CTE ccap node');
|
|
untypedRange ccap = untypedRange src_cap; capAligned src_cap;
|
|
isUntypedCap src_cap \<rbrakk>
|
|
\<Longrightarrow> usableUntypedRange ccap = {}"
|
|
using untyped_inc src
|
|
apply (clarsimp simp:untyped_inc'_def)
|
|
apply (erule_tac x = ptr in allE)
|
|
apply (erule_tac x = src in allE)
|
|
apply clarsimp
|
|
apply (subgoal_tac "isUntypedCap ccap")
|
|
apply clarsimp
|
|
apply (drule_tac p = ptr in untyped_no_parent)
|
|
apply (simp add:descendants_of'_def)
|
|
apply (drule (1) aligned_untypedRange_non_empty)
|
|
apply (case_tac ccap,simp_all add:isCap_simps)
|
|
done
|
|
|
|
lemma untyped_inc_n:
|
|
"\<lbrakk>capAligned src_cap;isUntypedCap src_cap \<longrightarrow> usableUntypedRange src_cap = {}\<rbrakk>
|
|
\<Longrightarrow> untyped_inc' n"
|
|
using untyped_inc
|
|
apply (clarsimp simp add: untyped_inc'_def descendants split del: split_if)
|
|
apply (drule n_cap)+
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (case_tac "p=dest", simp)
|
|
apply (simp add: descendants_of'_def untyped_c')
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule_tac x=src in allE)
|
|
apply (simp add: src)
|
|
apply (frule_tac p=p in untyped_no_parent)
|
|
apply clarsimp
|
|
apply (erule disjE)
|
|
apply clarsimp
|
|
apply (case_tac "p = src")
|
|
using src
|
|
apply clarsimp
|
|
apply (drule(4) parent_untyped_must_not_usable)
|
|
apply simp
|
|
apply (intro conjI)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
using src
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (case_tac "p=dest")
|
|
apply (simp add: descendants_of'_def untyped_c')
|
|
apply (erule_tac x=p' in allE)
|
|
apply (erule_tac x=src in allE)
|
|
apply (clarsimp simp:src)
|
|
apply (frule_tac p=p' in untyped_no_parent)
|
|
apply (case_tac "p' = src")
|
|
apply (clarsimp simp:src)
|
|
apply (elim disjE)
|
|
apply (erule disjE[OF iffD1[OF subset_iff_psubset_eq]])
|
|
apply simp+
|
|
apply (erule disjE[OF iffD1[OF subset_iff_psubset_eq]])
|
|
apply simp+
|
|
apply (clarsimp simp:Int_ac)
|
|
apply (erule_tac x=p' in allE)
|
|
apply (erule_tac x=p in allE)
|
|
apply (case_tac "p' = src")
|
|
apply (clarsimp simp:src descendants_of'_def untyped_c')
|
|
apply (elim disjE)
|
|
apply (erule disjE[OF iffD1[OF subset_iff_psubset_eq]])
|
|
apply (simp,intro conjI,clarsimp+)
|
|
apply (intro conjI)
|
|
apply clarsimp+
|
|
apply (erule disjE[OF iffD1[OF subset_iff_psubset_eq]])
|
|
apply (simp,intro conjI,clarsimp+)
|
|
apply (intro conjI)
|
|
apply clarsimp+
|
|
apply (clarsimp simp:Int_ac,intro conjI,clarsimp+)
|
|
apply (clarsimp simp:descendants_of'_def)
|
|
apply (case_tac "p = src")
|
|
apply simp
|
|
apply (elim disjE)
|
|
apply (erule disjE[OF iffD1[OF subset_iff_psubset_eq]])
|
|
apply (simp,intro conjI,clarsimp+)
|
|
apply (intro conjI)
|
|
apply clarsimp+
|
|
apply (erule disjE[OF iffD1[OF subset_iff_psubset_eq]])
|
|
apply clarsimp+
|
|
apply fastforce
|
|
apply (clarsimp simp:Int_ac,intro conjI,clarsimp+)
|
|
apply (intro conjI)
|
|
apply (elim disjE)
|
|
apply (simp add:Int_ac)+
|
|
apply clarsimp
|
|
done
|
|
|
|
end
|
|
|
|
context mdb_insert_sib
|
|
begin
|
|
|
|
lemma untyped_mdb_n:
|
|
shows "untyped_mdb' n"
|
|
using untyped_mdb
|
|
apply (clarsimp simp add: untyped_mdb'_def descendants split del: split_if)
|
|
apply (drule n_cap)+
|
|
apply (clarsimp split: split_if_asm simp: descendants_of'_def capRange_c' untyped_c')
|
|
apply (erule_tac x=src in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply (fastforce simp: src dest: untyped_no_parent)
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule_tac x=src in allE)
|
|
apply (simp add: src)
|
|
done
|
|
|
|
lemma not_untyped: "capAligned c' \<Longrightarrow> \<not>isUntypedCap src_cap"
|
|
using no_child partial_is_derived' ut_rev src
|
|
apply (clarsimp simp: ut_revocable'_def isMDBParentOf_CTE)
|
|
apply (erule_tac x=src in allE)
|
|
apply simp
|
|
apply (clarsimp simp: is_derived'_def freeIndex_update_def isCap_simps capAligned_def
|
|
badge_derived'_def)
|
|
apply (clarsimp simp: sameRegionAs_def3 capMasterCap_def isCap_simps interval_empty
|
|
is_aligned_no_overflow split:capability.splits)
|
|
done
|
|
|
|
lemma untyped_inc_n:
|
|
assumes c': "capAligned c'"
|
|
shows "untyped_inc' n"
|
|
using untyped_inc not_untyped [OF c']
|
|
apply (clarsimp simp add: untyped_inc'_def descendants split del: split_if)
|
|
apply (drule n_cap)+
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (simp add: descendants_of'_def untyped_c')
|
|
apply (case_tac "p = dest")
|
|
apply (clarsimp simp: untyped_c')
|
|
apply simp
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply simp
|
|
done
|
|
|
|
end
|
|
|
|
lemma trancl_prev_update:
|
|
"modify_map m ptr (cteMDBNode_update (mdbPrev_update z)) \<turnstile> x \<leadsto>\<^sup>+ y = m \<turnstile> x \<leadsto>\<^sup>+ y"
|
|
apply (rule iffI)
|
|
apply (erule update_prev_next_trancl2)
|
|
apply (erule update_prev_next_trancl)
|
|
done
|
|
|
|
lemma rtrancl_prev_update:
|
|
"modify_map m ptr (cteMDBNode_update (mdbPrev_update z)) \<turnstile> x \<leadsto>\<^sup>* y = m \<turnstile> x \<leadsto>\<^sup>* y"
|
|
by (simp add: trancl_prev_update rtrancl_eq_or_trancl)
|
|
|
|
lemma mdb_chunked_prev_update:
|
|
"mdb_chunked (modify_map m x (cteMDBNode_update (mdbPrev_update f))) = mdb_chunked m"
|
|
apply (simp add: mdb_chunked_def trancl_prev_update rtrancl_prev_update is_chunk_def)
|
|
apply (rule iffI)
|
|
apply clarsimp
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply (erule_tac x=cap in allE)
|
|
apply (simp add: modify_map_if split: split_if_asm)
|
|
apply (erule impE, blast)
|
|
apply (erule allE, erule impE, blast)
|
|
apply clarsimp
|
|
apply blast
|
|
apply clarsimp
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply (erule_tac x=cap in allE)
|
|
apply (simp add: modify_map_if split: split_if_asm)
|
|
apply (erule impE, blast)
|
|
apply clarsimp
|
|
apply blast
|
|
apply (erule allE, erule impE, blast)
|
|
apply clarsimp
|
|
apply blast
|
|
apply clarsimp
|
|
apply blast
|
|
done
|
|
|
|
lemma descendants_of_prev_update:
|
|
"descendants_of' p (modify_map m x (cteMDBNode_update (mdbPrev_update f))) =
|
|
descendants_of' p m"
|
|
by (simp add: descendants_of'_def)
|
|
|
|
lemma untyped_mdb_prev_update:
|
|
"untyped_mdb' (modify_map m x (cteMDBNode_update (mdbPrev_update f))) = untyped_mdb' m"
|
|
apply (simp add: untyped_mdb'_def descendants_of_prev_update)
|
|
apply (rule iffI)
|
|
apply clarsimp
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply (erule_tac x=c in allE)
|
|
apply (simp add: modify_map_if split: split_if_asm)
|
|
apply (erule impE, blast)
|
|
apply (erule allE, erule impE, blast)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply (erule_tac x=c in allE)
|
|
apply (simp add: modify_map_if split: split_if_asm)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma untyped_inc_prev_update:
|
|
"untyped_inc' (modify_map m x (cteMDBNode_update (mdbPrev_update f))) = untyped_inc' m"
|
|
apply (simp add: untyped_inc'_def descendants_of_prev_update)
|
|
apply (rule iffI)
|
|
apply clarsimp
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply (erule_tac x=c in allE)
|
|
apply (simp add: modify_map_if split: split_if_asm)
|
|
apply (erule impE, blast)
|
|
apply (erule allE, erule impE, blast)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply (erule_tac x=c in allE)
|
|
apply (simp add: modify_map_if split: split_if_asm)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma is_derived_badge_derived':
|
|
"is_derived' m src cap cap' \<Longrightarrow> badge_derived' cap cap'"
|
|
by (simp add: is_derived'_def)
|
|
|
|
lemma cteInsert_mdb_chain_0:
|
|
"\<lbrace>valid_mdb' and pspace_aligned' and pspace_distinct' and (\<lambda>s. src \<noteq> dest) and
|
|
(\<lambda>s. cte_wp_at' (is_derived' (ctes_of s) src cap \<circ> cteCap) src s)\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>_ s. mdb_chain_0 (ctes_of s)\<rbrace>"
|
|
apply (unfold cteInsert_def updateCap_def)
|
|
apply (fold revokable'_fold)
|
|
apply (simp add: valid_mdb'_def split del: split_if)
|
|
apply (wp updateMDB_ctes_of_no_0 getCTE_wp')
|
|
apply (clarsimp simp: cte_wp_at_ctes_of simp del: fun_upd_apply)
|
|
apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift setUntypedCapAsFull_ctes_of
|
|
setUntypedCapAsFull_ctes_of_no_0 mdb_inv_preserve_modify_map
|
|
setUntypedCapAsFull_mdb_chain_0 mdb_inv_preserve_fun_upd | simp del:fun_upd_apply)+
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of simp del:fun_upd_apply)
|
|
apply (subgoal_tac "src \<noteq> 0")
|
|
prefer 2
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (subgoal_tac "dest \<noteq> 0")
|
|
prefer 2
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (rule conjI)
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (case_tac cte)
|
|
apply (rename_tac s_cap s_node)
|
|
apply (case_tac x)
|
|
apply (simp add: nullPointer_def)
|
|
apply (subgoal_tac "mdb_insert (ctes_of s) src s_cap s_node dest NullCap node" for node)
|
|
apply (drule mdb_insert.chain_n)
|
|
apply (rule mdb_chain_0_modify_map_prev)
|
|
apply (simp add:modify_map_apply)
|
|
apply (clarsimp simp: valid_badges_def)
|
|
apply unfold_locales
|
|
apply (assumption|rule refl)+
|
|
apply (simp add: valid_mdb_ctes_def)
|
|
apply (simp add: valid_mdb_ctes_def)
|
|
apply assumption
|
|
done
|
|
|
|
lemma cteInsert_mdb_chunked:
|
|
"\<lbrace>valid_mdb' and pspace_aligned' and pspace_distinct' and (\<lambda>s. src \<noteq> dest) and
|
|
(\<lambda>s. cte_wp_at' (is_derived' (ctes_of s) src cap \<circ> cteCap) src s)\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>_ s. mdb_chunked (ctes_of s)\<rbrace>"
|
|
apply (unfold cteInsert_def updateCap_def)
|
|
apply (fold revokable'_fold)
|
|
apply (simp add: valid_mdb'_def split del: split_if)
|
|
apply (wp updateMDB_ctes_of_no_0 getCTE_wp')
|
|
apply (clarsimp simp: cte_wp_at_ctes_of simp del: fun_upd_apply)
|
|
apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift setUntypedCapAsFull_ctes_of
|
|
setUntypedCapAsFull_ctes_of_no_0 mdb_inv_preserve_modify_map
|
|
setUntypedCapAsFull_mdb_chunked mdb_inv_preserve_fun_upd,simp)
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of simp del:fun_upd_apply)
|
|
apply (subgoal_tac "src \<noteq> 0")
|
|
prefer 2
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (subgoal_tac "dest \<noteq> 0")
|
|
prefer 2
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (rule conjI)
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (case_tac cte)
|
|
apply (rename_tac s_cap s_node)
|
|
apply (case_tac cteb)
|
|
apply (rename_tac d_cap d_node)
|
|
apply (simp add: nullPointer_def)
|
|
apply (subgoal_tac "mdb_insert (ctes_of s) src s_cap s_node dest NullCap d_node")
|
|
apply (drule mdb_insert.chunked_n, erule is_derived_badge_derived')
|
|
apply (clarsimp simp: modify_map_apply mdb_chunked_prev_update)
|
|
apply unfold_locales
|
|
apply (assumption|rule refl)+
|
|
apply (simp add: valid_mdb_ctes_def)
|
|
apply (simp add: valid_mdb_ctes_def)
|
|
apply assumption
|
|
done
|
|
|
|
lemma cteInsert_untyped_mdb:
|
|
"\<lbrace>valid_mdb' and pspace_distinct' and pspace_aligned' and (\<lambda>s. src \<noteq> dest) and
|
|
(\<lambda>s. cte_wp_at' (is_derived' (ctes_of s) src cap \<circ> cteCap) src s)\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>_ s. untyped_mdb' (ctes_of s)\<rbrace>"
|
|
apply (unfold cteInsert_def updateCap_def)
|
|
apply (simp add: valid_mdb'_def split del: split_if)
|
|
apply (fold revokable'_fold)
|
|
apply (wp updateMDB_ctes_of_no_0 getCTE_wp')
|
|
apply (clarsimp simp: cte_wp_at_ctes_of simp del: fun_upd_apply)
|
|
apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift setUntypedCapAsFull_ctes_of
|
|
setUntypedCapAsFull_ctes_of_no_0 mdb_inv_preserve_modify_map
|
|
setUntypedCapAsFull_untyped_mdb' mdb_inv_preserve_fun_upd,simp)
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of simp del:fun_upd_apply)
|
|
apply (subgoal_tac "src \<noteq> 0")
|
|
prefer 2
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (subgoal_tac "dest \<noteq> 0")
|
|
prefer 2
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (rule conjI)
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (case_tac cte)
|
|
apply (rename_tac s_cap s_node)
|
|
apply (case_tac cteb)
|
|
apply (rename_tac d_cap d_node)
|
|
apply (simp add: nullPointer_def)
|
|
apply (subgoal_tac "mdb_insert_der (ctes_of s) src s_cap s_node dest NullCap d_node cap")
|
|
prefer 2
|
|
apply unfold_locales[1]
|
|
apply (assumption|rule refl)+
|
|
apply (simp add: valid_mdb_ctes_def)
|
|
apply (simp add: valid_mdb_ctes_def)
|
|
apply assumption
|
|
apply assumption
|
|
apply (case_tac "isMDBParentOf (CTE s_cap s_node) (CTE cap
|
|
(mdbFirstBadged_update (\<lambda>a. revokable' s_cap cap)
|
|
(mdbRevocable_update (\<lambda>a. revokable' s_cap cap) (mdbPrev_update (\<lambda>a. src) s_node))))")
|
|
apply (subgoal_tac "mdb_insert_child (ctes_of s) src s_cap s_node dest NullCap d_node cap")
|
|
prefer 2
|
|
apply (simp add: mdb_insert_child_def mdb_insert_child_axioms_def)
|
|
apply (drule mdb_insert_child.untyped_mdb_n)
|
|
apply (clarsimp simp: modify_map_apply untyped_mdb_prev_update
|
|
descendants_of_prev_update)
|
|
apply (subgoal_tac "mdb_insert_sib (ctes_of s) src s_cap s_node dest NullCap d_node cap")
|
|
prefer 2
|
|
apply (simp add: mdb_insert_sib_def mdb_insert_sib_axioms_def)
|
|
apply (drule mdb_insert_sib.untyped_mdb_n)
|
|
apply (clarsimp simp: modify_map_apply untyped_mdb_prev_update
|
|
descendants_of_prev_update)
|
|
done
|
|
|
|
lemma valid_mdb_ctes_maskedAsFull:
|
|
"\<lbrakk>valid_mdb_ctes m;m src = Some (CTE s_cap s_node)\<rbrakk>
|
|
\<Longrightarrow> valid_mdb_ctes (m(src \<mapsto> CTE (maskedAsFull s_cap cap) s_node))"
|
|
apply (clarsimp simp:fun_upd_apply maskedAsFull_def)
|
|
apply (intro conjI impI)
|
|
apply (frule mdb_inv_preserve_updateCap
|
|
[where m = m and slot = src and index = "max_free_index (capBlockSize cap)"])
|
|
apply simp
|
|
apply (drule mdb_inv_preserve_sym)
|
|
apply (clarsimp simp:valid_mdb_ctes_def modify_map_def)
|
|
apply (frule mdb_inv_preserve.preserve_stuff,simp)
|
|
apply (frule mdb_inv_preserve.by_products,simp)
|
|
apply (rule mdb_inv_preserve.untyped_inc')
|
|
apply (erule mdb_inv_preserve_sym)
|
|
apply (clarsimp split:split_if_asm simp: isCap_simps max_free_index_def)
|
|
apply simp
|
|
apply (subgoal_tac "m = m(src \<mapsto> CTE s_cap s_node)")
|
|
apply simp
|
|
apply (rule ext)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma capAligned_maskedAsFull:
|
|
"capAligned s_cap \<Longrightarrow> capAligned (maskedAsFull s_cap cap)"
|
|
apply (case_tac s_cap)
|
|
apply (clarsimp simp:isCap_simps capAligned_def maskedAsFull_def max_free_index_def)+
|
|
done
|
|
|
|
lemma maskedAsFull_derived':
|
|
"\<lbrakk>m src = Some (CTE s_cap s_node); is_derived' m ptr b c\<rbrakk>
|
|
\<Longrightarrow> is_derived' (m(src \<mapsto> CTE (maskedAsFull s_cap cap) s_node)) ptr b c"
|
|
apply (subgoal_tac "m(src \<mapsto> CTE (maskedAsFull s_cap cap) s_node)
|
|
= (modify_map m src (cteCap_update (\<lambda>_. maskedAsFull s_cap cap)))")
|
|
apply simp
|
|
apply (clarsimp simp:maskedAsFull_def is_derived'_def)
|
|
apply (intro conjI impI)
|
|
apply (simp add:modify_map_def del:cteCap_update.simps)
|
|
apply (subst same_master_descendants)
|
|
apply simp
|
|
apply (clarsimp simp:isCap_simps capASID_def )+
|
|
apply (clarsimp simp:modify_map_def)
|
|
done
|
|
|
|
lemma maskedAsFull_usable_empty:
|
|
"\<lbrakk>capMasterCap cap = capMasterCap s_cap;
|
|
isUntypedCap (maskedAsFull s_cap cap)\<rbrakk>
|
|
\<Longrightarrow> usableUntypedRange (maskedAsFull s_cap cap) = {}"
|
|
apply (simp add:isCap_simps maskedAsFull_def max_free_index_def split:split_if_asm)
|
|
apply fastforce+
|
|
done
|
|
|
|
lemma capAligned_master:
|
|
"\<lbrakk>capAligned cap; capMasterCap cap = capMasterCap ncap\<rbrakk> \<Longrightarrow> capAligned ncap"
|
|
apply (case_tac cap)
|
|
apply (clarsimp simp:capAligned_def)+
|
|
apply (rename_tac arch_capability)
|
|
apply (case_tac arch_capability)
|
|
apply (clarsimp simp:capAligned_def)+
|
|
done
|
|
|
|
lemma cteInsert_untyped_inc':
|
|
"\<lbrace>valid_mdb' and pspace_distinct' and pspace_aligned' and valid_objs' and (\<lambda>s. src \<noteq> dest) and
|
|
(\<lambda>s. cte_wp_at' (is_derived' (ctes_of s) src cap \<circ> cteCap) src s)\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>_ s. untyped_inc' (ctes_of s)\<rbrace>"
|
|
apply (unfold cteInsert_def updateCap_def)
|
|
apply (simp add: valid_mdb'_def split del: split_if)
|
|
apply (fold revokable'_fold)
|
|
apply (wp updateMDB_ctes_of_no_0 getCTE_wp')
|
|
apply (clarsimp simp: cte_wp_at_ctes_of simp del: fun_upd_apply)
|
|
apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift setUntypedCapAsFull_ctes_of
|
|
setUntypedCapAsFull_ctes_of_no_0 mdb_inv_preserve_modify_map
|
|
setUntypedCapAsFull_untyped_mdb' mdb_inv_preserve_fun_upd)
|
|
apply (wp getCTE_wp setUntypedCapAsFull_ctes)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of simp del:fun_upd_apply)
|
|
apply (subgoal_tac "src \<noteq> 0")
|
|
prefer 2
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (subgoal_tac "dest \<noteq> 0")
|
|
prefer 2
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (rule conjI)
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (case_tac cte)
|
|
apply (rename_tac s_cap s_node)
|
|
apply (case_tac cteb)
|
|
apply (rename_tac d_cap d_node)
|
|
apply (simp add: nullPointer_def)
|
|
apply (subgoal_tac "mdb_insert_der
|
|
(modify_map (ctes_of s) src (cteCap_update (\<lambda>_. maskedAsFull s_cap cap)))
|
|
src (maskedAsFull s_cap cap) s_node dest NullCap d_node cap")
|
|
prefer 2
|
|
apply unfold_locales[1]
|
|
apply (clarsimp simp:modify_map_def valid_mdb_ctes_maskedAsFull)+
|
|
apply (erule(2) valid_mdb_ctesE[OF valid_mdb_ctes_maskedAsFull])
|
|
apply (clarsimp simp:modify_map_def)
|
|
apply (erule(2) valid_mdb_ctesE[OF valid_mdb_ctes_maskedAsFull])
|
|
apply simp
|
|
apply (clarsimp simp:modify_map_def maskedAsFull_derived')
|
|
apply (case_tac "isMDBParentOf (CTE (maskedAsFull s_cap cap) s_node) (CTE cap
|
|
(mdbFirstBadged_update (\<lambda>a. revokable' (maskedAsFull s_cap cap) cap)
|
|
(mdbRevocable_update (\<lambda>a. revokable' (maskedAsFull s_cap cap) cap)
|
|
(mdbPrev_update (\<lambda>a. src) s_node))))")
|
|
apply (subgoal_tac "mdb_insert_child
|
|
(modify_map (ctes_of s) src (cteCap_update (\<lambda>_. maskedAsFull s_cap cap)))
|
|
src (maskedAsFull s_cap cap) s_node dest NullCap d_node cap")
|
|
prefer 2
|
|
apply (simp add: mdb_insert_child_def mdb_insert_child_axioms_def)
|
|
apply (drule mdb_insert_child.untyped_inc_n)
|
|
apply (rule capAligned_maskedAsFull[OF valid_capAligned])
|
|
apply (erule(1) ctes_of_valid_cap')
|
|
apply (intro impI maskedAsFull_usable_empty)
|
|
apply (clarsimp simp:is_derived'_def badge_derived'_def)
|
|
apply simp
|
|
apply (clarsimp simp: modify_map_apply untyped_inc_prev_update maskedAsFull_revokable
|
|
descendants_of_prev_update)
|
|
apply (subgoal_tac "mdb_insert_sib
|
|
(modify_map (ctes_of s) src (cteCap_update (\<lambda>_. maskedAsFull s_cap cap)))
|
|
src (maskedAsFull s_cap cap) s_node dest NullCap d_node cap")
|
|
prefer 2
|
|
apply (simp add: mdb_insert_sib_def mdb_insert_sib_axioms_def)
|
|
apply (drule mdb_insert_sib.untyped_inc_n)
|
|
apply (rule capAligned_master[OF valid_capAligned])
|
|
apply (erule(1) ctes_of_valid_cap')
|
|
apply (clarsimp simp:is_derived'_def badge_derived'_def)
|
|
apply (clarsimp simp: modify_map_apply untyped_inc_prev_update maskedAsFull_revokable
|
|
descendants_of_prev_update)
|
|
done
|
|
|
|
lemma irq_control_prev_update:
|
|
"irq_control (modify_map m x (cteMDBNode_update (mdbPrev_update f))) = irq_control m"
|
|
apply (simp add: irq_control_def)
|
|
apply (rule iffI)
|
|
apply clarsimp
|
|
apply (simp only: modify_map_if)
|
|
apply (erule_tac x=p in allE)
|
|
apply (simp (no_asm_use) split: split_if_asm)
|
|
apply (case_tac "x=p")
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule_tac x=p' in allE)
|
|
apply simp
|
|
apply (case_tac "x=p'")
|
|
apply simp
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (erule_tac x=p in allE)
|
|
apply (simp add: modify_map_if split: split_if_asm)
|
|
apply clarsimp
|
|
apply (case_tac "x=p'")
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (case_tac "x=p'")
|
|
apply clarsimp
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma cteInsert_irq_control:
|
|
"\<lbrace>valid_mdb' and pspace_distinct' and pspace_aligned' and (\<lambda>s. src \<noteq> dest) and
|
|
(\<lambda>s. cte_wp_at' (is_derived' (ctes_of s) src cap \<circ> cteCap) src s)\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>_ s. irq_control (ctes_of s)\<rbrace>"
|
|
apply (unfold cteInsert_def updateCap_def)
|
|
apply (simp add: valid_mdb'_def split del: split_if)
|
|
apply (fold revokable'_fold)
|
|
apply (wp updateMDB_ctes_of_no_0 getCTE_wp')
|
|
apply (clarsimp simp: cte_wp_at_ctes_of simp del: fun_upd_apply)
|
|
apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift setUntypedCapAsFull_ctes_of
|
|
setUntypedCapAsFull_ctes_of_no_0 setUntypedCapAsFull_irq_control mdb_inv_preserve_fun_upd
|
|
mdb_inv_preserve_modify_map,simp)
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of simp del:fun_upd_apply)
|
|
apply (subgoal_tac "src \<noteq> 0")
|
|
prefer 2
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (subgoal_tac "dest \<noteq> 0")
|
|
prefer 2
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (rule conjI)
|
|
apply (fastforce simp: valid_mdb_ctes_def no_0_def)
|
|
apply (case_tac cte)
|
|
apply (rename_tac s_cap s_node)
|
|
apply (case_tac cteb)
|
|
apply (rename_tac d_cap d_node)
|
|
apply (simp add: nullPointer_def)
|
|
apply (subgoal_tac "mdb_insert_der (ctes_of s) src s_cap s_node dest NullCap d_node cap")
|
|
prefer 2
|
|
apply unfold_locales[1]
|
|
apply (assumption|rule refl)+
|
|
apply (simp add: valid_mdb_ctes_def)
|
|
apply (simp add: valid_mdb_ctes_def)
|
|
apply assumption+
|
|
apply (drule mdb_insert_der.irq_control_n)
|
|
apply (clarsimp simp: modify_map_apply irq_control_prev_update)
|
|
done
|
|
|
|
lemma capMaster_isUntyped:
|
|
"capMasterCap c = capMasterCap c' \<Longrightarrow> isUntypedCap c = isUntypedCap c'"
|
|
by (simp add: capMasterCap_def isCap_simps split: capability.splits)
|
|
|
|
lemma capMaster_capRange:
|
|
"capMasterCap c = capMasterCap c' \<Longrightarrow> capRange c = capRange c'"
|
|
by (simp add: capMasterCap_def capRange_def split: capability.splits arch_capability.splits)
|
|
|
|
lemma capMaster_untypedRange:
|
|
"capMasterCap c = capMasterCap c' \<Longrightarrow> untypedRange c = untypedRange c'"
|
|
by (simp add: capMasterCap_def capRange_def split: capability.splits arch_capability.splits)
|
|
|
|
lemma capMaster_capClass:
|
|
"capMasterCap c = capMasterCap c' \<Longrightarrow> capClass c = capClass c'"
|
|
by (simp add: capMasterCap_def split: capability.splits arch_capability.splits)
|
|
|
|
lemma valid_dlist_no_0_prev:
|
|
"\<lbrakk> m p = Some (CTE c n); m (mdbNext n) = Some (CTE c' (MDB x 0 b1 b2)); valid_dlist m; no_0 m \<rbrakk> \<Longrightarrow> False"
|
|
apply (erule (1) valid_dlistE)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma distinct_zombies_nonCTE_modify_map:
|
|
"\<And>m x f. \<lbrakk> \<And>cte. cteCap (f cte) = cteCap cte \<rbrakk>
|
|
\<Longrightarrow> distinct_zombies (modify_map m x f) = distinct_zombies m"
|
|
apply (simp add: distinct_zombies_def modify_map_def o_def)
|
|
apply (rule_tac f=distinct_zombie_caps in arg_cong)
|
|
apply (rule ext)
|
|
apply simp
|
|
apply (simp add: map_option.compositionality o_def)
|
|
done
|
|
|
|
lemma setUntypedCapAsFull_ctes_of_no_0':
|
|
"\<lbrace>\<lambda>s. no_0 (ctes_of s) \<and> cte_wp_at' (op = srcCTE) src s\<rbrace>
|
|
setUntypedCapAsFull (cteCap srcCTE) cap src
|
|
\<lbrace>\<lambda>r s. no_0 (ctes_of s)\<rbrace>"
|
|
apply (clarsimp simp:no_0_def split:if_splits)
|
|
apply (wp hoare_vcg_imp_lift setUntypedCapAsFull_ctes_of[where dest = 0])
|
|
apply (auto simp:cte_wp_at_ctes_of)
|
|
done
|
|
|
|
(* FIXME: move *)
|
|
lemma mdb_inv_preserve_update_cap_same:
|
|
"mdb_inv_preserve m m'
|
|
\<Longrightarrow> mdb_inv_preserve (modify_map m dest (cteCap_update (\<lambda>_. cap)))
|
|
(modify_map m' dest (cteCap_update (\<lambda>_. cap)))"
|
|
apply (simp (no_asm) add:mdb_inv_preserve_def)
|
|
apply (intro conjI allI)
|
|
apply (drule mdb_inv_preserve.dom)
|
|
apply (simp add:modify_map_dom)
|
|
apply (clarsimp simp:modify_map_def split del:if_splits split:split_if_asm)
|
|
apply (drule(2) mdb_inv_preserve.misc,simp)+
|
|
apply (clarsimp simp:mdb_inv_preserve.sameRegion
|
|
modify_map_def split:if_splits)+
|
|
apply (case_tac "p = dest")
|
|
apply (clarsimp simp:mdb_next_def option_map_def split:option.splits )
|
|
apply (intro conjI allI impI)
|
|
apply (rule ccontr,clarify)
|
|
apply (fastforce dest!:iffD2[OF mdb_inv_preserve.dom,OF _ domI])
|
|
apply (rule ccontr,simp)
|
|
apply (fastforce dest!:iffD1[OF mdb_inv_preserve.dom,OF _ domI])
|
|
apply (drule mdb_inv_preserve.mdb_next[where p = dest])
|
|
apply (clarsimp simp:mdb_next_def option_map_def split:option.splits)+
|
|
apply (intro conjI allI impI)
|
|
apply (rule ccontr,clarify)
|
|
apply (fastforce dest!:iffD2[OF mdb_inv_preserve.dom,OF _ domI])
|
|
apply (rule ccontr,simp)
|
|
apply (fastforce dest!:iffD1[OF mdb_inv_preserve.dom,OF _ domI])
|
|
apply (drule_tac p = p in mdb_inv_preserve.mdb_next)
|
|
apply (clarsimp simp:mdb_next_def option_map_def split:option.splits)
|
|
done
|
|
|
|
lemma updateCapFreeIndex_dlist:
|
|
assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
|
|
shows
|
|
"\<lbrace>\<lambda>s. P (valid_dlist (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE \<and> isUntypedCap (cteCap c)) src s\<rbrace>
|
|
updateCap src (capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE))
|
|
\<lbrace>\<lambda>r s. P (valid_dlist (Q (ctes_of s)))\<rbrace>"
|
|
apply (wp updateCap_ctes_of_wp)
|
|
apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
|
|
(cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE)))))")
|
|
apply (drule mdb_inv_preserve.preserve_stuff)
|
|
apply simp
|
|
apply (rule preserve)
|
|
apply (rule mdb_inv_preserve_updateCap)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of)+
|
|
done
|
|
|
|
lemma setUntypedCapAsFull_valid_dlist:
|
|
assumes preserve:
|
|
"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
|
|
shows
|
|
"\<lbrace>\<lambda>s. P (valid_dlist (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE) src s\<rbrace>
|
|
setUntypedCapAsFull (cteCap srcCTE) cap src
|
|
\<lbrace>\<lambda>r s. P (valid_dlist (Q (ctes_of s)))\<rbrace>"
|
|
apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
|
|
apply (wp updateCapFreeIndex_dlist)
|
|
apply (clarsimp simp:preserve cte_wp_at_ctes_of)+
|
|
apply wp
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma valid_dlist_prevD:
|
|
"\<lbrakk>m p = Some cte;valid_dlist m;mdbPrev (cteMDBNode cte) \<noteq> 0\<rbrakk>
|
|
\<Longrightarrow> (\<exists>cte'. m (mdbPrev (cteMDBNode cte)) = Some cte' \<and>
|
|
mdbNext (cteMDBNode cte') = p)"
|
|
by (clarsimp simp:valid_dlist_def Let_def)
|
|
|
|
lemma valid_dlist_nextD:
|
|
"\<lbrakk>m p = Some cte;valid_dlist m;mdbNext (cteMDBNode cte) \<noteq> 0\<rbrakk>
|
|
\<Longrightarrow> (\<exists>cte'. m (mdbNext (cteMDBNode cte)) = Some cte' \<and>
|
|
mdbPrev (cteMDBNode cte') = p)"
|
|
by (clarsimp simp:valid_dlist_def Let_def)
|
|
|
|
lemma no_loops_no_l2_loop:
|
|
"\<lbrakk>valid_dlist m; no_loops m; m p = Some cte;mdbPrev (cteMDBNode cte) = mdbNext (cteMDBNode cte)\<rbrakk>
|
|
\<Longrightarrow> mdbNext (cteMDBNode cte) = 0"
|
|
apply (rule ccontr)
|
|
apply (subgoal_tac "m \<turnstile> p \<leadsto> (mdbNext (cteMDBNode cte))")
|
|
prefer 2
|
|
apply (clarsimp simp:mdb_next_rel_def mdb_next_def)
|
|
apply (subgoal_tac "m \<turnstile> (mdbNext (cteMDBNode cte)) \<leadsto> p")
|
|
prefer 2
|
|
apply (clarsimp simp:mdb_next_rel_def mdb_next_def)
|
|
apply (frule(2) valid_dlist_nextD)
|
|
apply clarsimp
|
|
apply (frule(1) valid_dlist_prevD)
|
|
apply simp+
|
|
apply (drule(1) transitive_closure_trans)
|
|
apply (simp add:no_loops_def)
|
|
done
|
|
|
|
lemma cteInsert_no_0:
|
|
"\<lbrace>valid_mdb' and pspace_aligned' and pspace_distinct' and
|
|
(\<lambda>s. src \<noteq> dest) and K (capAligned cap) and valid_objs' and
|
|
(\<lambda>s. cte_wp_at' (is_derived' (ctes_of s) src cap \<circ> cteCap) src s)\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>_ s. no_0 (ctes_of s) \<rbrace>"
|
|
apply (rule hoare_name_pre_state)
|
|
apply clarsimp
|
|
apply (unfold cteInsert_def updateCap_def)
|
|
apply (simp add: valid_mdb'_def split del: split_if)
|
|
apply (fold revokable'_fold)
|
|
apply (wp updateMDB_ctes_of_no_0 getCTE_wp')
|
|
apply (clarsimp simp: cte_wp_at_ctes_of simp del: fun_upd_apply)
|
|
apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift setUntypedCapAsFull_ctes_of
|
|
setUntypedCapAsFull_ctes_of_no_0 mdb_inv_preserve_modify_map getCTE_wp
|
|
setUntypedCapAsFull_valid_dlist mdb_inv_preserve_fun_upd | simp)+
|
|
apply (intro conjI impI)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of)
|
|
apply (clarsimp simp:valid_mdb_ctes_def no_0_def)
|
|
done
|
|
|
|
lemma cteInsert_valid_dlist:
|
|
"\<lbrace>valid_mdb' and pspace_aligned' and pspace_distinct' and
|
|
(\<lambda>s. src \<noteq> dest) and K (capAligned cap) and valid_objs' and
|
|
(\<lambda>s. cte_wp_at' (is_derived' (ctes_of s) src cap \<circ> cteCap) src s)\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>_ s. valid_dlist (ctes_of s) \<rbrace>"
|
|
apply (rule hoare_name_pre_state)
|
|
apply clarsimp
|
|
apply (unfold cteInsert_def updateCap_def)
|
|
apply (simp add: valid_mdb'_def split del: split_if)
|
|
apply (fold revokable'_fold)
|
|
apply (wp updateMDB_ctes_of_no_0 getCTE_wp')
|
|
apply (clarsimp simp: cte_wp_at_ctes_of simp del: fun_upd_apply)
|
|
apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift setUntypedCapAsFull_ctes_of
|
|
setUntypedCapAsFull_ctes_of_no_0 mdb_inv_preserve_modify_map getCTE_wp
|
|
setUntypedCapAsFull_valid_dlist mdb_inv_preserve_fun_upd | simp)+
|
|
apply (intro conjI impI)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of)
|
|
apply (intro conjI)
|
|
apply (clarsimp simp:valid_mdb_ctes_def no_0_def)+
|
|
apply (frule mdb_chain_0_no_loops)
|
|
apply (simp add:no_0_def)
|
|
apply (rule valid_dlistI)
|
|
apply (case_tac "p = dest")
|
|
apply (clarsimp simp:modify_map_def nullPointer_def split:split_if_asm)+
|
|
apply (frule(2) valid_dlist_prevD)
|
|
apply simp
|
|
apply (subgoal_tac "mdbPrev (cteMDBNode ctea) \<noteq> mdbNext (cteMDBNode ctea)")
|
|
prefer 2
|
|
apply (clarsimp)
|
|
apply (drule(3) no_loops_no_l2_loop[rotated -1],simp)
|
|
apply (subgoal_tac "mdbPrev (cteMDBNode ctea) \<noteq> dest")
|
|
apply clarsimp+
|
|
apply (frule_tac p = p and m = "ctes_of sa" in valid_dlist_prevD)
|
|
apply simp+
|
|
apply fastforce
|
|
apply (case_tac "p = dest")
|
|
apply (clarsimp simp:modify_map_def nullPointer_def split:split_if_asm)+
|
|
apply (frule(2) valid_dlist_nextD,clarsimp)
|
|
apply (clarsimp simp:modify_map_def nullPointer_def split:split_if_asm)
|
|
apply (frule(2) valid_dlist_nextD)
|
|
apply simp
|
|
apply (subgoal_tac "mdbPrev (cteMDBNode ctea) \<noteq> mdbNext (cteMDBNode ctea)")
|
|
prefer 2
|
|
apply (clarsimp)
|
|
apply (drule(3) no_loops_no_l2_loop[rotated -1],simp)
|
|
apply clarsimp
|
|
apply (intro conjI impI)
|
|
apply clarsimp+
|
|
apply (drule_tac cte = cte' in no_loops_no_l2_loop,simp)
|
|
apply simp+
|
|
apply (frule(2) valid_dlist_nextD)
|
|
apply clarsimp
|
|
apply (frule_tac p = p and m = "ctes_of sa" in valid_dlist_nextD)
|
|
apply clarsimp+
|
|
apply (rule conjI)
|
|
apply fastforce
|
|
apply (intro conjI impI,clarsimp+)
|
|
apply (frule_tac valid_dlist_nextD)
|
|
apply clarsimp+
|
|
apply (frule_tac valid_dlist_nextD)
|
|
apply clarsimp+
|
|
done
|
|
|
|
lemma cteInsert_mdb' [wp]:
|
|
"\<lbrace>valid_mdb' and pspace_aligned' and pspace_distinct' and (\<lambda>s. src \<noteq> dest) and K (capAligned cap) and valid_objs' and
|
|
(\<lambda>s. cte_wp_at' (is_derived' (ctes_of s) src cap \<circ> cteCap) src s) \<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>_. valid_mdb'\<rbrace>"
|
|
apply (simp add:valid_mdb'_def valid_mdb_ctes_def revokable'_fold[symmetric])
|
|
apply (rule_tac Q = "\<lambda>r s. valid_dlist (ctes_of s) \<and> irq_control (ctes_of s) \<and>
|
|
no_0 (ctes_of s) \<and> mdb_chain_0 (ctes_of s) \<and>
|
|
mdb_chunked (ctes_of s) \<and> untyped_mdb' (ctes_of s) \<and> untyped_inc' (ctes_of s) \<and>
|
|
Q s" for Q
|
|
in hoare_strengthen_post)
|
|
prefer 2
|
|
apply clarsimp
|
|
apply assumption
|
|
apply (rule hoare_name_pre_state)
|
|
apply (wp cteInsert_no_0 cteInsert_valid_dlist cteInsert_mdb_chain_0 cteInsert_untyped_inc'
|
|
cteInsert_mdb_chunked cteInsert_untyped_mdb cteInsert_irq_control)
|
|
apply (unfold cteInsert_def)
|
|
apply (unfold cteInsert_def updateCap_def)
|
|
apply (simp add: valid_mdb'_def split del: split_if)
|
|
apply (fold revokable'_fold)
|
|
apply (wp updateMDB_ctes_of_no_0 getCTE_wp')
|
|
apply (clarsimp simp: cte_wp_at_ctes_of simp del: fun_upd_apply)
|
|
apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift setUntypedCapAsFull_ctes_of
|
|
setUntypedCapAsFull_ctes_of_no_0
|
|
setUntypedCapAsFull_valid_dlist setUntypedCapAsFull_distinct_zombies
|
|
setUntypedCapAsFull_valid_badges setUntypedCapAsFull_caps_contained
|
|
setUntypedCapAsFull_valid_nullcaps setUntypedCapAsFull_ut_revocable
|
|
setUntypedCapAsFull_class_links setUntypedCapAsFull_reply_masters_rvk_fb
|
|
mdb_inv_preserve_fun_upd
|
|
mdb_inv_preserve_modify_map getCTE_wp| simp del:fun_upd_apply)+
|
|
apply (clarsimp simp:cte_wp_at_ctes_of simp del:fun_upd_apply)
|
|
defer
|
|
apply (clarsimp simp:valid_mdb_ctes_def valid_mdb'_def simp del:fun_upd_apply)+
|
|
apply (case_tac cte)
|
|
apply (rename_tac cap1 node1)
|
|
apply (case_tac x)
|
|
apply (rename_tac cap2 node2)
|
|
apply (case_tac node1)
|
|
apply (case_tac node2)
|
|
apply (clarsimp simp:valid_mdb_ctes_def no_0_def nullPointer_def)
|
|
apply (intro conjI impI)
|
|
apply clarsimp
|
|
apply (rename_tac s src_cap word1 word2 bool1a bool2a bool1 bool2)
|
|
proof -
|
|
fix s :: kernel_state
|
|
fix bool1 bool2 src_cap word1 word2 bool1a bool2a
|
|
let ?c1 = "(CTE src_cap (MDB word1 word2 bool1a bool2a))"
|
|
let ?c2 = "(CTE capability.NullCap (MDB 0 0 bool1 bool2))"
|
|
let ?C = "(modify_map
|
|
(modify_map
|
|
(modify_map (ctes_of s(dest \<mapsto> CTE cap (MDB 0 0 bool1 bool2))) dest
|
|
(cteMDBNode_update (\<lambda>a. MDB word1 src (revokable' src_cap cap) (revokable' src_cap cap))))
|
|
src (cteMDBNode_update (mdbNext_update (\<lambda>_. dest))))
|
|
word1 (cteMDBNode_update (mdbPrev_update (\<lambda>_. dest))))"
|
|
let ?m = "ctes_of s"
|
|
let ?prv = "\<lambda>cte. mdbPrev (cteMDBNode cte)"
|
|
let ?nxt = "\<lambda>cte. mdbNext (cteMDBNode cte)"
|
|
|
|
assume "pspace_distinct' s" and "pspace_aligned' s" and srcdest: "src \<noteq> dest"
|
|
and dest0: "dest \<noteq> 0"
|
|
and cofs: "ctes_of s src = Some ?c1" and cofd: "ctes_of s dest = Some ?c2"
|
|
and is_der: "is_derived' (ctes_of s) src cap src_cap"
|
|
and aligned: "capAligned cap"
|
|
and vd: "valid_dlist ?m"
|
|
and no0: "?m 0 = None"
|
|
and chain: "mdb_chain_0 ?m"
|
|
and badges: "valid_badges ?m"
|
|
and chunk: "mdb_chunked ?m"
|
|
and contained: "caps_contained' ?m"
|
|
and untyped_mdb: "untyped_mdb' ?m"
|
|
and untyped_inc: "untyped_inc' ?m"
|
|
and class_links: "class_links ?m"
|
|
and distinct_zombies: "distinct_zombies ?m"
|
|
and irq: "irq_control ?m"
|
|
and reply_masters_rvk_fb: "reply_masters_rvk_fb ?m"
|
|
and vn: "valid_nullcaps ?m"
|
|
and ut_rev:"ut_revocable' ?m"
|
|
|
|
have no_loop: "no_loops ?m"
|
|
apply (rule mdb_chain_0_no_loops[OF chain])
|
|
apply (simp add:no_0_def no0)
|
|
done
|
|
|
|
have badge: "badge_derived' cap src_cap"
|
|
using is_der
|
|
by (clarsimp simp:is_derived'_def)
|
|
|
|
have vmdb: "valid_mdb_ctes ?m"
|
|
by (auto simp: vmdb_def valid_mdb_ctes_def no_0_def, fact+)
|
|
|
|
have src0: "src \<noteq> 0"
|
|
using cofs no0 by clarsimp
|
|
|
|
have destnull:
|
|
"cte_mdb_prop ?m dest (\<lambda>m. mdbPrev m = 0 \<and> mdbNext m = 0)"
|
|
using cofd unfolding cte_mdb_prop_def
|
|
by auto
|
|
|
|
have srcwd: "?m \<turnstile> src \<leadsto> word1"
|
|
using cofs by (simp add: next_unfold')
|
|
|
|
have w1ned[simp]: "word1 \<noteq> dest"
|
|
proof (cases "word1 = 0")
|
|
case True thus ?thesis using dest0 by auto
|
|
next
|
|
case False
|
|
thus ?thesis using cofs cofd src0 dest0 False vd
|
|
by - (erule (1) valid_dlistEn, (clarsimp simp: nullPointer_def)+)
|
|
qed
|
|
|
|
have w2ned[simp]: "word2 \<noteq> dest"
|
|
proof (cases "word2 = 0")
|
|
case True thus ?thesis using dest0 by auto
|
|
next
|
|
case False
|
|
thus ?thesis using cofs cofd src0 dest0 False vd
|
|
by - (erule (1) valid_dlistEp, (clarsimp simp: nullPointer_def)+)
|
|
qed
|
|
|
|
have w1nes[simp]: "word1 \<noteq> src" using vmdb cofs
|
|
by - (drule (1) no_self_loop_next, simp)
|
|
|
|
have w2nes[simp]: "word2 \<noteq> src" using vmdb cofs
|
|
by - (drule (1) no_self_loop_prev, simp)
|
|
|
|
from is_der have notZomb1: "\<not> isZombie cap"
|
|
by (clarsimp simp: isCap_simps is_derived'_def badge_derived'_def)
|
|
|
|
from is_der have notZomb2: "\<not> isZombie src_cap"
|
|
by (clarsimp simp: isCap_simps is_derived'_def)
|
|
|
|
from badge have masters: "capMasterCap cap = capMasterCap src_cap"
|
|
by (clarsimp simp: badge_derived'_def)
|
|
|
|
note blah[simp] = w2nes[symmetric] w1nes[symmetric] w1ned[symmetric]
|
|
w2ned[symmetric] srcdest srcdest[symmetric]
|
|
|
|
have mdb_next_disj:
|
|
"\<And>p p'. (?C \<turnstile> p \<leadsto> p' \<Longrightarrow>
|
|
?m \<turnstile> p \<leadsto> p' \<and> p \<noteq> src \<and> p'\<noteq> dest \<and> (p' = word1 \<longrightarrow> p' = 0)
|
|
\<or> p = src \<and> p' = dest \<or> p = dest \<and> p' = word1)"
|
|
apply (case_tac "p = src")
|
|
apply (clarsimp simp:mdb_next_unfold modify_map_cases)
|
|
apply (case_tac "p = dest")
|
|
apply (clarsimp simp:mdb_next_unfold modify_map_cases)+
|
|
using cofs cofd vd no0
|
|
apply -
|
|
apply (case_tac "p = word1")
|
|
apply clarsimp
|
|
apply (intro conjI)
|
|
apply clarsimp
|
|
apply (frule_tac p = "word1" and m = "?m" in valid_dlist_nextD)
|
|
apply clarsimp+
|
|
apply (frule_tac p = "mdbNext node" and m = "?m" in valid_dlist_nextD)
|
|
apply clarsimp+
|
|
apply (frule_tac p = "mdbNext node" in no_loops_no_l2_loop[OF _ no_loop])
|
|
apply simp+
|
|
apply (intro conjI)
|
|
apply clarsimp
|
|
apply (frule_tac p = p and m = "?m" in valid_dlist_nextD)
|
|
apply (clarsimp+)[3]
|
|
apply (intro impI)
|
|
apply (rule ccontr)
|
|
apply clarsimp
|
|
apply (frule_tac p = src and m = "?m" in valid_dlist_nextD)
|
|
apply clarsimp+
|
|
apply (frule_tac p = p and m = "?m" in valid_dlist_nextD)
|
|
apply clarsimp+
|
|
done
|
|
|
|
have ctes_ofD:
|
|
"\<And>p cte. \<lbrakk>?C p = Some cte; p\<noteq> dest; p\<noteq> src\<rbrakk> \<Longrightarrow> \<exists>cteb. (?m p = Some cteb \<and> cteCap cte = cteCap cteb)"
|
|
by (clarsimp simp:modify_map_def split:if_splits)
|
|
|
|
|
|
show "valid_badges ?C"
|
|
using srcdest badge cofs badges cofd
|
|
unfolding valid_badges_def
|
|
apply (intro impI allI)
|
|
apply (drule mdb_next_disj)
|
|
apply (elim disjE)
|
|
defer
|
|
apply (clarsimp simp:modify_map_cases dest0 src0)
|
|
apply (clarsimp simp:revokable'_def badge_derived'_def)
|
|
subgoal by (case_tac src_cap,auto simp:isCap_simps sameRegionAs_def)
|
|
apply (clarsimp simp:modify_map_cases valid_badges_def)
|
|
apply (frule_tac x=src in spec, erule_tac x=word1 in allE, erule allE, erule impE)
|
|
apply fastforce
|
|
apply simp
|
|
apply (clarsimp simp:mdb_next_unfold badge_derived'_def split: split_if_asm)
|
|
apply (thin_tac "All P" for P)
|
|
subgoal by (cases src_cap,
|
|
auto simp:mdb_next_unfold isCap_simps sameRegionAs_def Let_def split: if_splits)
|
|
apply (case_tac "word1 = p'")
|
|
apply (clarsimp simp:modify_map_cases valid_badges_def mdb_next_unfold src0 dest0 no0)+
|
|
apply (case_tac "p = dest")
|
|
apply (clarsimp simp:dest0 src0 no0)+
|
|
apply (case_tac z)
|
|
apply (rename_tac capability mdbnode)
|
|
apply clarsimp
|
|
apply (drule_tac x = p in spec,drule_tac x = "mdbNext mdbnode" in spec)
|
|
by (auto simp:isCap_simps sameRegionAs_def)
|
|
|
|
from badge
|
|
have isUntyped_eq: "isUntypedCap cap = isUntypedCap src_cap"
|
|
apply (clarsimp simp:badge_derived'_def)
|
|
apply (case_tac cap,auto simp:isCap_simps)
|
|
done
|
|
|
|
from badge
|
|
have [simp]: "capRange cap = capRange src_cap"
|
|
apply (clarsimp simp:badge_derived'_def)
|
|
apply (case_tac cap)
|
|
apply (clarsimp simp:isCap_simps capRange_def)+
|
|
(* 5 subgoals *)
|
|
apply (rename_tac arch_capability)
|
|
apply (case_tac arch_capability)
|
|
(* 9 subgoals *)
|
|
apply (clarsimp simp:isCap_simps capRange_def)+
|
|
done
|
|
|
|
have [simp]: "untypedRange cap = untypedRange src_cap"
|
|
using badge
|
|
apply (clarsimp simp:badge_derived'_def dest!:capMaster_untypedRange)
|
|
done
|
|
|
|
from contained badge srcdest cofs cofd is_der no0
|
|
show "caps_contained' ?C"
|
|
apply (clarsimp simp add: caps_contained'_def)
|
|
apply (case_tac "p = dest")
|
|
apply (case_tac "p' = dest")
|
|
apply (clarsimp simp:modify_map_def split:if_splits)
|
|
apply (case_tac src_cap,auto)[1]
|
|
apply (case_tac "p' = src")
|
|
apply (clarsimp simp:modify_map_def split:if_splits)
|
|
apply (clarsimp simp:badge_derived'_def)
|
|
apply (case_tac src_cap,auto)[1]
|
|
apply (drule(2) ctes_ofD)
|
|
apply (clarsimp simp:modify_map_def split:if_splits)
|
|
apply (frule capRange_untyped)
|
|
apply (erule_tac x=src in allE, erule_tac x=p' in allE, simp)
|
|
apply (case_tac cteb)
|
|
apply (clarsimp)
|
|
apply blast
|
|
apply (case_tac "p' = dest")
|
|
apply (case_tac "p = src")
|
|
apply (clarsimp simp:modify_map_def split:if_splits)
|
|
apply (drule capRange_untyped)
|
|
subgoal by (case_tac cap,auto simp:isCap_simps badge_derived'_def)
|
|
apply (clarsimp simp:modify_map_def split:if_splits)
|
|
apply (drule_tac x = word1 in spec)
|
|
apply (drule_tac x = src in spec)
|
|
apply (case_tac z)
|
|
apply (clarsimp simp:isUntyped_eq)
|
|
apply blast
|
|
apply (drule_tac x = p in spec)
|
|
apply (drule_tac x = src in spec)
|
|
apply (frule capRange_untyped)
|
|
apply (clarsimp simp:isUntyped_eq)
|
|
apply blast
|
|
apply (drule_tac x = p in spec)
|
|
apply (drule_tac x = p' in spec)
|
|
apply (clarsimp simp:modify_map_def split:if_splits)
|
|
apply ((case_tac z,fastforce)+)[5]
|
|
by fastforce+
|
|
|
|
show "valid_nullcaps ?C"
|
|
using is_der vn cofs vd no0
|
|
apply (simp add: valid_nullcaps_def srcdest [symmetric])
|
|
apply (clarsimp simp:modify_map_def is_derived'_def)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: is_derived'_def badge_derived'_def)+
|
|
apply (drule_tac x = word1 in spec)
|
|
apply (case_tac z)
|
|
apply (clarsimp simp:nullMDBNode_def)
|
|
apply (drule(1) valid_dlist_nextD)
|
|
apply simp
|
|
apply clarsimp
|
|
apply (simp add:nullPointer_def src0)
|
|
done
|
|
|
|
from vmdb srcdest cofs ut_rev
|
|
show "ut_revocable' ?C"
|
|
apply (clarsimp simp: valid_mdb_ctes_def ut_revocable'_def modify_map_def)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (clarsimp simp: revokable'_def isCap_simps)+
|
|
apply auto
|
|
apply (drule_tac x= src in spec)
|
|
apply clarsimp
|
|
apply (case_tac z)
|
|
apply clarsimp
|
|
done
|
|
|
|
from class_links srcdest badge cofs cofd no0 vd
|
|
show "class_links ?C"
|
|
unfolding class_links_def
|
|
apply (intro allI impI)
|
|
apply (drule mdb_next_disj)
|
|
apply (elim disjE)
|
|
apply (clarsimp simp:modify_map_def mdb_next_unfold split:split_if_asm)
|
|
apply (clarsimp simp: badge_derived'_def modify_map_def
|
|
split: split_if_asm)
|
|
apply (erule capMaster_capClass)
|
|
apply (clarsimp simp:modify_map_def split:if_splits)
|
|
apply (drule_tac x = src in spec)
|
|
apply (drule_tac x = word1 in spec)
|
|
apply (clarsimp simp:mdb_next_unfold)
|
|
apply (case_tac z)
|
|
apply (clarsimp simp:badge_derived'_def)
|
|
apply (drule capMaster_capClass)
|
|
apply simp
|
|
done
|
|
|
|
from distinct_zombies badge
|
|
show "distinct_zombies ?C"
|
|
apply (simp add:distinct_zombies_nonCTE_modify_map)
|
|
apply (erule_tac distinct_zombies_copyMasterE[where x=src])
|
|
apply (rule cofs)
|
|
apply (simp add: masters)
|
|
apply (simp add: notZomb1 notZomb2)
|
|
done
|
|
|
|
from reply_masters_rvk_fb is_der
|
|
show "reply_masters_rvk_fb ?C"
|
|
apply (clarsimp simp:reply_masters_rvk_fb_def)
|
|
apply (erule ranE)
|
|
apply (clarsimp simp:modify_map_def split:split_if_asm)
|
|
apply fastforce+
|
|
apply (clarsimp simp:is_derived'_def isCap_simps)
|
|
apply fastforce
|
|
done
|
|
qed
|
|
|
|
crunch state_refs_of'[wp]: cteInsert "\<lambda>s. P (state_refs_of' s)"
|
|
(wp: crunch_wps)
|
|
|
|
crunch aligned'[wp]: cteInsert pspace_aligned'
|
|
(wp: crunch_wps)
|
|
|
|
crunch distinct'[wp]: cteInsert pspace_distinct'
|
|
(wp: crunch_wps)
|
|
|
|
crunch no_0_obj' [wp]: cteInsert no_0_obj'
|
|
(wp: crunch_wps)
|
|
|
|
lemma cteInsert_valid_pspace:
|
|
"\<lbrace>valid_pspace' and valid_cap' cap and (\<lambda>s. src \<noteq> dest) and valid_objs' and
|
|
(\<lambda>s. cte_wp_at' (is_derived' (ctes_of s) src cap \<circ> cteCap) src s)\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>_. valid_pspace'\<rbrace>"
|
|
unfolding valid_pspace'_def
|
|
apply (rule hoare_pre)
|
|
apply (wp cteInsert_valid_objs)
|
|
apply (fastforce elim: valid_capAligned)
|
|
done
|
|
|
|
lemma setCTE_ko_wp_at_live[wp]:
|
|
"\<lbrace>\<lambda>s. P (ko_wp_at' live' p' s)\<rbrace>
|
|
setCTE p v
|
|
\<lbrace>\<lambda>rv s. P (ko_wp_at' live' p' s)\<rbrace>"
|
|
apply (clarsimp simp: setCTE_def setObject_def split_def
|
|
valid_def in_monad ko_wp_at'_def
|
|
split del: split_if
|
|
elim!: rsubst[where P=P])
|
|
apply (drule(1) updateObject_cte_is_tcb_or_cte [OF _ refl, rotated])
|
|
apply (elim exE conjE disjE)
|
|
apply (clarsimp simp: ps_clear_upd' objBits_simps
|
|
lookupAround2_char1)
|
|
apply (simp add: tcb_cte_cases_def split: split_if_asm)
|
|
apply (clarsimp simp: ps_clear_upd' objBits_simps)
|
|
done
|
|
|
|
lemma setCTE_iflive':
|
|
"\<lbrace>\<lambda>s. cte_wp_at' (\<lambda>cte'. \<forall>p'\<in>zobj_refs' (cteCap cte')
|
|
- zobj_refs' (cteCap cte).
|
|
ko_wp_at' (Not \<circ> live') p' s) p s
|
|
\<and> if_live_then_nonz_cap' s\<rbrace>
|
|
setCTE p cte
|
|
\<lbrace>\<lambda>rv s. if_live_then_nonz_cap' s\<rbrace>"
|
|
unfolding if_live_then_nonz_cap'_def ex_nonz_cap_to'_def
|
|
apply (rule hoare_pre)
|
|
apply (simp only: imp_conv_disj)
|
|
apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift
|
|
hoare_vcg_ex_lift setCTE_weak_cte_wp_at)
|
|
apply clarsimp
|
|
apply (drule spec, drule(1) mp)
|
|
apply clarsimp
|
|
apply (rule_tac x=cref in exI)
|
|
apply (clarsimp simp: cte_wp_at'_def)
|
|
apply (rule ccontr)
|
|
apply (drule bspec, fastforce)
|
|
apply (clarsimp simp: ko_wp_at'_def)
|
|
done
|
|
|
|
lemma updateMDB_iflive'[wp]:
|
|
"\<lbrace>\<lambda>s. if_live_then_nonz_cap' s\<rbrace>
|
|
updateMDB p m
|
|
\<lbrace>\<lambda>rv s. if_live_then_nonz_cap' s\<rbrace>"
|
|
apply (clarsimp simp: updateMDB_def)
|
|
apply (rule hoare_seq_ext [OF _ getCTE_sp])
|
|
apply (wp setCTE_iflive')
|
|
apply (clarsimp elim!: cte_wp_at_weakenE')
|
|
done
|
|
|
|
lemma updateCap_iflive':
|
|
"\<lbrace>\<lambda>s. cte_wp_at' (\<lambda>cte'. \<forall>p'\<in>zobj_refs' (cteCap cte')
|
|
- zobj_refs' cap.
|
|
ko_wp_at' (Not \<circ> live') p' s) p s
|
|
\<and> if_live_then_nonz_cap' s\<rbrace>
|
|
updateCap p cap
|
|
\<lbrace>\<lambda>rv s. if_live_then_nonz_cap' s\<rbrace>"
|
|
apply (simp add: updateCap_def)
|
|
apply (rule hoare_seq_ext [OF _ getCTE_sp])
|
|
apply (wp setCTE_iflive')
|
|
apply (clarsimp elim!: cte_wp_at_weakenE')
|
|
done
|
|
|
|
lemma setCTE_ko_wp_at_not_live[wp]:
|
|
"\<lbrace>\<lambda>s. P (ko_wp_at' (Not \<circ> live') p' s)\<rbrace>
|
|
setCTE p v
|
|
\<lbrace>\<lambda>rv s. P (ko_wp_at' (Not \<circ> live') p' s)\<rbrace>"
|
|
apply (clarsimp simp: setCTE_def setObject_def split_def
|
|
valid_def in_monad ko_wp_at'_def
|
|
split del: split_if
|
|
elim!: rsubst[where P=P])
|
|
apply (drule(1) updateObject_cte_is_tcb_or_cte [OF _ refl, rotated])
|
|
apply (elim exE conjE disjE)
|
|
apply (clarsimp simp: ps_clear_upd' objBits_simps
|
|
lookupAround2_char1)
|
|
apply (simp add: tcb_cte_cases_def split: split_if_asm)
|
|
apply (clarsimp simp: ps_clear_upd' objBits_simps)
|
|
done
|
|
|
|
lemma setUntypedCapAsFull_ko_wp_not_at'[wp]:
|
|
"\<lbrace>\<lambda>s. P (ko_wp_at' (Not \<circ> live') p' s)\<rbrace>
|
|
setUntypedCapAsFull (cteCap srcCTE) cap src
|
|
\<lbrace>\<lambda>r s. P ( ko_wp_at' (Not \<circ> live') p' s)\<rbrace>"
|
|
apply (clarsimp simp:setUntypedCapAsFull_def updateCap_def)
|
|
apply (wp setCTE_ko_wp_at_live setCTE_ko_wp_at_not_live)
|
|
done
|
|
|
|
lemma setUntypedCapAsFull_ko_wp_at'[wp]:
|
|
"\<lbrace>\<lambda>s. P (ko_wp_at' live' p' s)\<rbrace>
|
|
setUntypedCapAsFull (cteCap srcCTE) cap src
|
|
\<lbrace>\<lambda>r s. P ( ko_wp_at' live' p' s)\<rbrace>"
|
|
apply (clarsimp simp:setUntypedCapAsFull_def updateCap_def)
|
|
apply (wp setCTE_ko_wp_at_live setCTE_ko_wp_at_live)
|
|
done
|
|
|
|
(*FIXME:MOVE*)
|
|
lemma zobj_refs'_capFreeIndex_update[simp]:
|
|
"isUntypedCap ctecap \<Longrightarrow>
|
|
zobj_refs' (capFreeIndex_update f (ctecap)) = zobj_refs' ctecap"
|
|
by (case_tac ctecap,auto simp:isCap_simps)
|
|
|
|
lemma setUntypedCapAsFull_if_live_then_nonz_cap':
|
|
"\<lbrace>\<lambda>s. if_live_then_nonz_cap' s \<and> cte_wp_at' (op = srcCTE) src s\<rbrace>
|
|
setUntypedCapAsFull (cteCap srcCTE) cap src
|
|
\<lbrace>\<lambda>rv s. if_live_then_nonz_cap' s\<rbrace>"
|
|
apply (clarsimp simp:if_live_then_nonz_cap'_def)
|
|
apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift)
|
|
apply (clarsimp simp:setUntypedCapAsFull_def split del:if_splits)
|
|
apply (wp hoare_vcg_split_if)
|
|
apply (clarsimp simp:ex_nonz_cap_to'_def cte_wp_at_ctes_of)
|
|
apply (wp updateCap_ctes_of_wp)
|
|
apply clarsimp
|
|
apply (elim allE impE)
|
|
apply (assumption)
|
|
apply (clarsimp simp:ex_nonz_cap_to'_def cte_wp_at_ctes_of modify_map_def split:if_splits)
|
|
apply (rule_tac x = cref in exI)
|
|
apply (intro conjI impI)
|
|
apply clarsimp+
|
|
done
|
|
|
|
|
|
lemma maskedAsFull_simps[simp]:
|
|
"maskedAsFull capability.NullCap cap = capability.NullCap"
|
|
by (auto simp:maskedAsFull_def)
|
|
|
|
lemma cteInsert_iflive'[wp]:
|
|
"\<lbrace>\<lambda>s. if_live_then_nonz_cap' s
|
|
\<and> cte_wp_at' (\<lambda>c. cteCap c = NullCap) dest s\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>rv. if_live_then_nonz_cap'\<rbrace>"
|
|
apply (rule hoare_pre)
|
|
apply (simp add: cteInsert_def split del: split_if)
|
|
apply (wp updateCap_iflive' hoare_drop_imps)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of)
|
|
apply (wp hoare_vcg_conj_lift hoare_vcg_ex_lift hoare_vcg_ball_lift getCTE_wp
|
|
setUntypedCapAsFull_ctes_of setUntypedCapAsFull_if_live_then_nonz_cap')
|
|
apply (clarsimp simp:cte_wp_at_ctes_of)
|
|
apply (intro conjI)
|
|
apply (rule_tac x = "case (ctes_of s dest) of Some a \<Rightarrow>a" in exI)
|
|
apply (intro conjI impI)
|
|
apply (clarsimp)
|
|
apply (case_tac cte,simp)
|
|
apply clarsimp+
|
|
done
|
|
|
|
lemma ifunsafe'_def2:
|
|
"if_unsafe_then_cap' =
|
|
(\<lambda>s. \<forall>cref cte. ctes_of s cref = Some cte \<and> cteCap cte \<noteq> NullCap
|
|
\<longrightarrow> (\<exists>cref' cte'. ctes_of s cref' = Some cte'
|
|
\<and> cref \<in> cte_refs' (cteCap cte') (irq_node' s)))"
|
|
by (clarsimp intro!: ext
|
|
simp: if_unsafe_then_cap'_def cte_wp_at_ctes_of
|
|
ex_cte_cap_to'_def)
|
|
|
|
lemma ifunsafe'_def3:
|
|
"if_unsafe_then_cap' =
|
|
(\<lambda>s. \<forall>cref cap. cteCaps_of s cref = Some cap \<and> cap \<noteq> NullCap
|
|
\<longrightarrow> (\<exists>cref' cap'. cteCaps_of s cref' = Some cap'
|
|
\<and> cref \<in> cte_refs' cap' (irq_node' s)))"
|
|
apply (simp add: cteCaps_of_def o_def ifunsafe'_def2)
|
|
apply (fastforce intro!: ext)
|
|
done
|
|
|
|
lemma tree_cte_cteCap_eq:
|
|
"cte_wp_at' (P \<circ> cteCap) p s = (case_option False P (cteCaps_of s p))"
|
|
apply (simp add: cte_wp_at_ctes_of cteCaps_of_def)
|
|
apply (cases "ctes_of s p", simp_all)
|
|
done
|
|
|
|
lemma updateMDB_cteCaps_of:
|
|
"\<lbrace>\<lambda>s. P (cteCaps_of s)\<rbrace> updateMDB ptr f \<lbrace>\<lambda>rv s. P (cteCaps_of s)\<rbrace>"
|
|
apply (simp add: cteCaps_of_def)
|
|
apply (wp updateMDB_ctes_of_wp)
|
|
apply (safe elim!: rsubst [where P=P] intro!: ext)
|
|
apply (case_tac "ctes_of s x")
|
|
apply (clarsimp simp: modify_map_def)+
|
|
done
|
|
|
|
lemma setCTE_ksInterruptState[wp]:
|
|
"\<lbrace>\<lambda>s. P (ksInterruptState s)\<rbrace> setCTE param_a param_b \<lbrace>\<lambda>_ s. P (ksInterruptState s)\<rbrace>"
|
|
by (wp setObject_ksInterrupt updateObject_cte_inv | simp add: setCTE_def)+
|
|
|
|
crunch ksInterruptState[wp]: cteInsert "\<lambda>s. P (ksInterruptState s)"
|
|
(ignore: setObject wp: crunch_wps)
|
|
|
|
lemmas updateMDB_cteCaps_of_ksInt[wp]
|
|
= hoare_use_eq [where f=ksInterruptState, OF updateMDB_ksInterruptState updateMDB_cteCaps_of]
|
|
|
|
lemma updateCap_cteCaps_of:
|
|
"\<lbrace>\<lambda>s. P (modify_map (cteCaps_of s) ptr (K cap))\<rbrace> updateCap ptr cap \<lbrace>\<lambda>rv s. P (cteCaps_of s)\<rbrace>"
|
|
apply (simp add: cteCaps_of_def)
|
|
apply (wp updateCap_ctes_of_wp)
|
|
apply (erule rsubst [where P=P])
|
|
apply (case_tac "ctes_of s ptr")
|
|
apply (clarsimp intro!: ext simp: modify_map_def)+
|
|
done
|
|
|
|
lemmas updateCap_cteCaps_of_int[wp]
|
|
= hoare_use_eq[where f=ksInterruptState, OF updateCap_ksInterruptState updateCap_cteCaps_of]
|
|
|
|
lemma getCTE_cteCap_wp:
|
|
"\<lbrace>\<lambda>s. case (cteCaps_of s ptr) of None \<Rightarrow> True | Some cap \<Rightarrow> Q cap s\<rbrace> getCTE ptr \<lbrace>\<lambda>rv. Q (cteCap rv)\<rbrace>"
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of)
|
|
done
|
|
|
|
lemma capFreeIndex_update_cte_refs'[simp]:
|
|
"isUntypedCap a \<Longrightarrow> cte_refs' (capFreeIndex_update f a) = cte_refs' a "
|
|
apply (rule ext)
|
|
apply (clarsimp simp:isCap_simps)
|
|
done
|
|
|
|
lemma cteInsert_ifunsafe'[wp]:
|
|
"\<lbrace>if_unsafe_then_cap' and cte_wp_at' (\<lambda>c. cteCap c = NullCap) dest
|
|
and ex_cte_cap_to' dest\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>rv s. if_unsafe_then_cap' s\<rbrace>"
|
|
apply (simp add: ifunsafe'_def3 cteInsert_def setUntypedCapAsFull_def
|
|
split del: split_if)
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of ex_cte_cap_to'_def
|
|
cteCaps_of_def
|
|
dest!: modify_map_K_D
|
|
split: split_if_asm)
|
|
apply (intro conjI)
|
|
apply clarsimp
|
|
apply (erule_tac x = crefa in allE)
|
|
apply (clarsimp simp:modify_map_def split:split_if_asm)
|
|
apply (rule_tac x = cref in exI)
|
|
apply fastforce
|
|
apply (clarsimp simp:isCap_simps)
|
|
apply (rule_tac x = cref' in exI)
|
|
apply fastforce
|
|
apply (intro conjI impI)
|
|
apply clarsimp
|
|
apply (rule_tac x = cref' in exI)
|
|
apply fastforce
|
|
apply (clarsimp simp:modify_map_def)
|
|
apply (erule_tac x = crefa in allE)
|
|
apply (intro conjI impI)
|
|
apply clarsimp
|
|
apply (rule_tac x = cref in exI)
|
|
apply fastforce
|
|
apply (clarsimp simp:isCap_simps)
|
|
apply (rule_tac x = cref' in exI)
|
|
apply fastforce
|
|
done
|
|
|
|
lemma setCTE_inQ[wp]:
|
|
"\<lbrace>\<lambda>s. P (obj_at' (inQ d p) t s)\<rbrace> setCTE ptr v \<lbrace>\<lambda>rv s. P (obj_at' (inQ d p) t s)\<rbrace>"
|
|
apply (simp add: setCTE_def)
|
|
apply (rule setObject_cte_obj_at_tcb')
|
|
apply (simp_all add: inQ_def)
|
|
done
|
|
|
|
lemma setCTE_valid_queues'[wp]:
|
|
"\<lbrace>valid_queues'\<rbrace> setCTE p cte \<lbrace>\<lambda>rv. valid_queues'\<rbrace>"
|
|
apply (simp only: valid_queues'_def imp_conv_disj)
|
|
apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift)
|
|
done
|
|
|
|
crunch inQ[wp]: cteInsert "\<lambda>s. P (obj_at' (inQ d p) t s)"
|
|
(wp: crunch_wps)
|
|
|
|
lemma setCTE_it'[wp]:
|
|
"\<lbrace>\<lambda>s. P (ksIdleThread s)\<rbrace> setCTE c p \<lbrace>\<lambda>_ s. P (ksIdleThread s)\<rbrace>"
|
|
apply (simp add: setCTE_def setObject_def split_def updateObject_cte)
|
|
apply (wp|wpc|simp add: unless_def)+
|
|
done
|
|
|
|
lemma setCTE_idle [wp]:
|
|
"\<lbrace>valid_idle'\<rbrace> setCTE p cte \<lbrace>\<lambda>rv. valid_idle'\<rbrace>"
|
|
apply (simp add: valid_idle'_def)
|
|
apply (rule hoare_lift_Pf [where f="ksIdleThread"])
|
|
apply (wp setCTE_pred_tcb_at')
|
|
done
|
|
|
|
crunch it[wp]: getCTE "\<lambda>s. P (ksIdleThread s)"
|
|
|
|
lemma getCTE_no_idle_cap:
|
|
"\<lbrace>valid_global_refs'\<rbrace>
|
|
getCTE p
|
|
\<lbrace>\<lambda>rv s. ksIdleThread s \<notin> capRange (cteCap rv)\<rbrace>"
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp: valid_global_refs'_def valid_refs'_def cte_wp_at_ctes_of)
|
|
apply blast
|
|
done
|
|
|
|
lemma updateMDB_idle'[wp]:
|
|
"\<lbrace>valid_idle'\<rbrace> updateMDB p m \<lbrace>\<lambda>rv. valid_idle'\<rbrace>"
|
|
apply (clarsimp simp add: updateMDB_def)
|
|
apply (rule hoare_pre)
|
|
apply (wp | simp add: valid_idle'_def)+
|
|
done
|
|
|
|
lemma updateCap_idle':
|
|
"\<lbrace>valid_idle'\<rbrace> updateCap p c \<lbrace>\<lambda>rv. valid_idle'\<rbrace>"
|
|
apply (simp add: updateCap_def)
|
|
apply (wp | simp)+
|
|
done
|
|
|
|
crunch idle [wp]: setUntypedCapAsFull "valid_idle'"
|
|
(wp: crunch_wps simp: cte_wp_at_ctes_of)
|
|
|
|
lemma cteInsert_idle'[wp]:
|
|
"\<lbrace>valid_idle'\<rbrace> cteInsert cap src dest \<lbrace>\<lambda>rv. valid_idle'\<rbrace>"
|
|
apply (simp add: cteInsert_def)
|
|
apply (wp updateMDB_idle' updateCap_idle' | rule hoare_drop_imp | simp)+
|
|
done
|
|
|
|
lemma setCTE_arch [wp]:
|
|
"\<lbrace>\<lambda>s. P (ksArchState s)\<rbrace> setCTE p c \<lbrace>\<lambda>_ s. P (ksArchState s)\<rbrace>"
|
|
apply (simp add: setCTE_def setObject_def split_def updateObject_cte)
|
|
apply (wp|wpc|simp add: unless_def)+
|
|
done
|
|
|
|
lemma setCTE_valid_arch[wp]:
|
|
"\<lbrace>valid_arch_state'\<rbrace> setCTE p c \<lbrace>\<lambda>_. valid_arch_state'\<rbrace>"
|
|
by (wp valid_arch_state_lift' setCTE_typ_at')
|
|
|
|
lemma setCTE_global_refs[wp]:
|
|
"\<lbrace>\<lambda>s. P (global_refs' s)\<rbrace> setCTE p c \<lbrace>\<lambda>_ s. P (global_refs' s)\<rbrace>"
|
|
apply (simp add: setCTE_def setObject_def split_def updateObject_cte global_refs'_def)
|
|
apply (wp|wpc|simp add: unless_def)+
|
|
done
|
|
|
|
lemma setCTE_gsMaxObjectSize[wp]:
|
|
"\<lbrace>\<lambda>s. P (gsMaxObjectSize s)\<rbrace> setCTE p c \<lbrace>\<lambda>_ s. P (gsMaxObjectSize s)\<rbrace>"
|
|
apply (simp add: setCTE_def setObject_def split_def updateObject_cte)
|
|
apply (wp|wpc|simp add: unless_def)+
|
|
done
|
|
|
|
lemma setCTE_valid_globals[wp]:
|
|
"\<lbrace>valid_global_refs' and (\<lambda>s. kernel_data_refs \<inter> capRange (cteCap c) = {})
|
|
and (\<lambda>s. 2 ^ capBits (cteCap c) \<le> gsMaxObjectSize s)\<rbrace>
|
|
setCTE p c
|
|
\<lbrace>\<lambda>_. valid_global_refs'\<rbrace>"
|
|
apply (simp add: valid_global_refs'_def valid_refs'_def pred_conj_def)
|
|
apply (rule hoare_lift_Pf2 [where f=global_refs'])
|
|
apply (rule hoare_lift_Pf2 [where f=gsMaxObjectSize])
|
|
apply wp
|
|
apply (clarsimp simp: ran_def valid_cap_sizes'_def)
|
|
apply metis
|
|
apply wp
|
|
done
|
|
|
|
lemma updateMDB_global_refs [wp]:
|
|
"\<lbrace>valid_global_refs'\<rbrace> updateMDB p m \<lbrace>\<lambda>rv. valid_global_refs'\<rbrace>"
|
|
apply (clarsimp simp add: updateMDB_def)
|
|
apply (rule hoare_pre)
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of valid_global_refs'_def valid_refs'_def valid_cap_sizes'_def)
|
|
apply blast
|
|
done
|
|
|
|
lemma updateCap_global_refs [wp]:
|
|
"\<lbrace>valid_global_refs' and (\<lambda>s. kernel_data_refs \<inter> capRange cap = {})
|
|
and (\<lambda>s. 2 ^ capBits cap \<le> gsMaxObjectSize s)\<rbrace>
|
|
updateCap p cap
|
|
\<lbrace>\<lambda>rv. valid_global_refs'\<rbrace>"
|
|
apply (clarsimp simp add: updateCap_def)
|
|
apply (rule hoare_pre)
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of)
|
|
done
|
|
|
|
crunch arch [wp]: cteInsert "\<lambda>s. P (ksArchState s)"
|
|
(wp: crunch_wps simp: cte_wp_at_ctes_of)
|
|
|
|
lemma cteInsert_valid_arch [wp]:
|
|
"\<lbrace>valid_arch_state'\<rbrace> cteInsert cap src dest \<lbrace>\<lambda>rv. valid_arch_state'\<rbrace>"
|
|
by (rule valid_arch_state_lift') wp
|
|
|
|
lemma cteInsert_valid_irq_handlers'[wp]:
|
|
"\<lbrace>\<lambda>s. valid_irq_handlers' s \<and> (\<forall>irq. cap = IRQHandlerCap irq \<longrightarrow> irq_issued' irq s)\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>rv. valid_irq_handlers'\<rbrace>"
|
|
apply (simp add: valid_irq_handlers'_def cteInsert_def
|
|
irq_issued'_def setUntypedCapAsFull_def)
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of)
|
|
apply (intro conjI impI)
|
|
apply (clarsimp simp:ran_dom modify_map_dom)
|
|
apply (drule bspec)
|
|
apply fastforce
|
|
apply (clarsimp simp:isCap_simps modify_map_def split:if_splits)
|
|
apply (clarsimp simp:ran_dom modify_map_dom)
|
|
apply (drule bspec)
|
|
apply fastforce
|
|
apply (clarsimp simp:modify_map_def split:if_splits)
|
|
done
|
|
|
|
lemma setCTE_valid_mappings'[wp]:
|
|
"\<lbrace>valid_pde_mappings'\<rbrace> setCTE x y \<lbrace>\<lambda>rv. valid_pde_mappings'\<rbrace>"
|
|
apply (wp valid_pde_mappings_lift' setCTE_typ_at')
|
|
apply (simp add: setCTE_def)
|
|
apply (rule obj_at_setObject2)
|
|
apply (clarsimp simp: updateObject_cte typeError_def in_monad
|
|
split: Structures_H.kernel_object.split_asm split_if_asm)
|
|
done
|
|
|
|
crunch pde_mappings' [wp]: cteInsert valid_pde_mappings'
|
|
(wp: crunch_wps)
|
|
|
|
lemma setCTE_irq_states' [wp]:
|
|
"\<lbrace>valid_irq_states'\<rbrace> setCTE x y \<lbrace>\<lambda>_. valid_irq_states'\<rbrace>"
|
|
apply (rule valid_irq_states_lift')
|
|
apply wp
|
|
apply (simp add: setCTE_def)
|
|
apply (wp setObject_ksMachine)
|
|
apply (simp add: updateObject_cte)
|
|
apply (rule hoare_pre)
|
|
apply (wp hoare_unless_wp|wpc|simp)+
|
|
apply fastforce
|
|
done
|
|
|
|
crunch irq_states' [wp]: cteInsert valid_irq_states'
|
|
(wp: crunch_wps)
|
|
|
|
crunch pred_tcb_at'[wp]: cteInsert "pred_tcb_at' proj P t"
|
|
(wp: crunch_wps)
|
|
|
|
lemma setCTE_cteCaps_of[wp]:
|
|
"\<lbrace>\<lambda>s. P ((cteCaps_of s)(p \<mapsto> cteCap cte))\<rbrace>
|
|
setCTE p cte
|
|
\<lbrace>\<lambda>rv s. P (cteCaps_of s)\<rbrace>"
|
|
apply (simp add: cteCaps_of_def)
|
|
apply wp
|
|
apply (clarsimp elim!: rsubst[where P=P] intro!: ext)
|
|
done
|
|
|
|
crunch inQ[wp]: setupReplyMaster "\<lambda>s. P (obj_at' (inQ d p) t s)"
|
|
(wp: crunch_wps)
|
|
crunch norq[wp]: setupReplyMaster "\<lambda>s. P (ksReadyQueues s)"
|
|
(wp: crunch_wps)
|
|
crunch ct[wp]: setupReplyMaster "\<lambda>s. P (ksCurThread s)"
|
|
(wp: crunch_wps)
|
|
crunch state_refs_of'[wp]: setupReplyMaster "\<lambda>s. P (state_refs_of' s)"
|
|
(wp: crunch_wps)
|
|
crunch it[wp]: setupReplyMaster "\<lambda>s. P (ksIdleThread s)"
|
|
(wp: setCTE_it')
|
|
crunch nosch[wp]: setupReplyMaster "\<lambda>s. P (ksSchedulerAction s)"
|
|
crunch irq_node'[wp]: setupReplyMaster "\<lambda>s. P (irq_node' s)"
|
|
(ignore: updateObject)
|
|
|
|
lemmas setCTE_cteCap_wp_irq[wp] =
|
|
hoare_use_eq_irq_node' [OF setCTE_irq_node' setCTE_cteCaps_of]
|
|
|
|
crunch global_refs'[wp]: setUntypedCapAsFull "\<lambda>s. P (global_refs' s) "
|
|
(simp: crunch_simps)
|
|
|
|
|
|
lemma setUntypedCapAsFull_valid_refs'[wp]:
|
|
"\<lbrace>\<lambda>s. valid_refs' R (ctes_of s) \<and> cte_wp_at' (op = srcCTE) src s\<rbrace>
|
|
setUntypedCapAsFull (cteCap srcCTE) cap src
|
|
\<lbrace>\<lambda>yb s. valid_refs' R (ctes_of s)\<rbrace>"
|
|
apply (clarsimp simp:valid_refs'_def setUntypedCapAsFull_def split del:if_splits)
|
|
apply (rule hoare_pre)
|
|
apply (wp updateCap_ctes_of_wp)
|
|
apply (clarsimp simp:ran_dom)
|
|
apply (drule_tac x = y in bspec)
|
|
apply (drule_tac a = y in domI)
|
|
apply (simp add:modify_map_dom)
|
|
apply (clarsimp simp:modify_map_def cte_wp_at_ctes_of
|
|
isCap_simps split:if_splits)
|
|
done
|
|
|
|
crunch gsMaxObjectSize[wp]: setUntypedCapAsFull "\<lambda>s. P (gsMaxObjectSize s)"
|
|
|
|
lemma setUntypedCapAsFull_sizes[wp]:
|
|
"\<lbrace>\<lambda>s. valid_cap_sizes' sz (ctes_of s) \<and> cte_wp_at' (op = srcCTE) src s\<rbrace>
|
|
setUntypedCapAsFull (cteCap srcCTE) cap src
|
|
\<lbrace>\<lambda>rv s. valid_cap_sizes' sz (ctes_of s)\<rbrace>"
|
|
apply (clarsimp simp:valid_cap_sizes'_def setUntypedCapAsFull_def split del:if_splits)
|
|
apply (rule hoare_pre)
|
|
apply (wp updateCap_ctes_of_wp | wps)+
|
|
apply (clarsimp simp:ran_dom)
|
|
apply (drule_tac x = y in bspec)
|
|
apply (drule_tac a = y in domI)
|
|
apply (simp add:modify_map_dom)
|
|
apply (clarsimp simp:modify_map_def cte_wp_at_ctes_of
|
|
isCap_simps split:if_splits)
|
|
done
|
|
|
|
lemma setUntypedCapAsFull_valid_global_refs'[wp]:
|
|
"\<lbrace>\<lambda>s. valid_global_refs' s \<and> cte_wp_at' (op = srcCTE) src s\<rbrace>
|
|
setUntypedCapAsFull (cteCap srcCTE) cap src
|
|
\<lbrace>\<lambda>yb s. valid_global_refs' s\<rbrace>"
|
|
apply (clarsimp simp: valid_global_refs'_def)
|
|
apply (rule hoare_pre,wps)
|
|
apply wp
|
|
apply simp
|
|
done
|
|
|
|
lemma capMaster_eq_capBits_eq:
|
|
"capMasterCap cap = capMasterCap cap' \<Longrightarrow> capBits cap = capBits cap'"
|
|
by (metis capBits_Master)
|
|
|
|
lemma valid_global_refsD_with_objSize:
|
|
"\<lbrakk> ctes_of s p = Some cte; valid_global_refs' s \<rbrakk> \<Longrightarrow>
|
|
kernel_data_refs \<inter> capRange (cteCap cte) = {} \<and> global_refs' s \<subseteq> kernel_data_refs
|
|
\<and> 2 ^ capBits (cteCap cte) \<le> gsMaxObjectSize s"
|
|
by (clarsimp simp: valid_global_refs'_def valid_refs'_def valid_cap_sizes'_def ran_def) blast
|
|
|
|
lemma cteInsert_valid_globals [wp]:
|
|
"\<lbrace>valid_global_refs' and (\<lambda>s. cte_wp_at' (is_derived' (ctes_of s) src cap \<circ> cteCap) src s)\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>rv. valid_global_refs'\<rbrace>"
|
|
apply (simp add: cteInsert_def)
|
|
apply (rule hoare_pre)
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of is_derived'_def badge_derived'_def)
|
|
apply (frule capMaster_eq_capBits_eq)
|
|
apply (drule capMaster_capRange)
|
|
apply (drule (1) valid_global_refsD_with_objSize)
|
|
apply simp
|
|
done
|
|
|
|
crunch arch [wp]: cteInsert "\<lambda>s. P (ksArchState s)"
|
|
(wp: crunch_wps simp: cte_wp_at_ctes_of)
|
|
|
|
crunch pde_mappings' [wp]: cteInsert valid_pde_mappings'
|
|
(wp: crunch_wps)
|
|
|
|
lemma setCTE_ksMachine[wp]:
|
|
"\<lbrace>\<lambda>s. P (ksMachineState s)\<rbrace> setCTE x y \<lbrace>\<lambda>_ s. P (ksMachineState s)\<rbrace>"
|
|
apply (clarsimp simp: setCTE_def)
|
|
apply (wp setObject_ksMachine)
|
|
apply (clarsimp simp: updateObject_cte
|
|
split: Structures_H.kernel_object.splits)
|
|
apply (safe, (wp hoare_unless_wp | simp)+)
|
|
done
|
|
|
|
crunch ksMachine[wp]: cteInsert "\<lambda>s. P (ksMachineState s)"
|
|
(wp: crunch_wps)
|
|
|
|
lemma cteInsert_vms'[wp]:
|
|
"\<lbrace>valid_machine_state'\<rbrace> cteInsert cap src dest \<lbrace>\<lambda>rv. valid_machine_state'\<rbrace>"
|
|
apply (simp add: cteInsert_def valid_machine_state'_def pointerInUserData_def)
|
|
apply (intro hoare_vcg_all_lift hoare_vcg_disj_lift)
|
|
apply (wp setObject_typ_at_inv setObject_ksMachine updateObject_default_inv |
|
|
intro hoare_drop_imp)+
|
|
done
|
|
|
|
crunch pspace_domain_valid[wp]: cteInsert "pspace_domain_valid"
|
|
(wp: crunch_wps)
|
|
|
|
lemma setCTE_ct_not_inQ[wp]:
|
|
"\<lbrace>ct_not_inQ\<rbrace> setCTE ptr cte \<lbrace>\<lambda>_. ct_not_inQ\<rbrace>"
|
|
apply (rule ct_not_inQ_lift [OF setCTE_nosch])
|
|
apply (simp add: setCTE_def ct_not_inQ_def)
|
|
apply (rule hoare_weaken_pre)
|
|
apply (wps setObject_cte_ct)
|
|
apply (rule setObject_cte_obj_at_tcb')
|
|
apply (clarsimp simp add: obj_at'_def)+
|
|
done
|
|
|
|
crunch ct_not_inQ[wp]: cteInsert "ct_not_inQ"
|
|
(simp: crunch_simps wp: hoare_drop_imp)
|
|
|
|
lemma setCTE_ksCurDomain[wp]:
|
|
"\<lbrace>\<lambda>s. P (ksCurDomain s)\<rbrace>
|
|
setCTE p cte
|
|
\<lbrace>\<lambda>rv s. P (ksCurDomain s)\<rbrace>"
|
|
apply (simp add: setCTE_def)
|
|
apply wp
|
|
done
|
|
|
|
lemma setObject_cte_ksDomSchedule[wp]: "\<lbrace> \<lambda>s. P (ksDomSchedule s) \<rbrace> setObject ptr (v::cte) \<lbrace> \<lambda>_ s. P (ksDomSchedule s) \<rbrace>"
|
|
apply (simp add: setObject_def split_def)
|
|
apply (wp updateObject_cte_inv | simp)+
|
|
done
|
|
|
|
lemma setCTE_ksDomSchedule[wp]:
|
|
"\<lbrace>\<lambda>s. P (ksDomSchedule s)\<rbrace>
|
|
setCTE p cte
|
|
\<lbrace>\<lambda>rv s. P (ksDomSchedule s)\<rbrace>"
|
|
apply (simp add: setCTE_def)
|
|
apply wp
|
|
done
|
|
|
|
crunch ksCurDomain[wp]: cteInsert "\<lambda>s. P (ksCurDomain s)"
|
|
(wp: crunch_wps )
|
|
|
|
crunch ksIdleThread[wp]: cteInsert "\<lambda>s. P (ksIdleThread s)"
|
|
(wp: crunch_wps)
|
|
|
|
crunch ksDomSchedule[wp]: cteInsert "\<lambda>s. P (ksDomSchedule s)"
|
|
(wp: crunch_wps)
|
|
|
|
lemma setCTE_tcbDomain_inv[wp]:
|
|
"\<lbrace>obj_at' (\<lambda>tcb. P (tcbDomain tcb)) t\<rbrace> setCTE ptr v \<lbrace>\<lambda>_. obj_at' (\<lambda>tcb. P (tcbDomain tcb)) t\<rbrace>"
|
|
apply (simp add: setCTE_def)
|
|
apply (rule setObject_cte_obj_at_tcb', simp_all)
|
|
done
|
|
|
|
crunch tcbDomain_inv[wp]: cteInsert "obj_at' (\<lambda>tcb. P (tcbDomain tcb)) t"
|
|
(wp: crunch_simps hoare_drop_imps)
|
|
|
|
lemma setCTE_tcbPriority_inv[wp]:
|
|
"\<lbrace>obj_at' (\<lambda>tcb. P (tcbPriority tcb)) t\<rbrace> setCTE ptr v \<lbrace>\<lambda>_. obj_at' (\<lambda>tcb. P (tcbPriority tcb)) t\<rbrace>"
|
|
apply (simp add: setCTE_def)
|
|
apply (rule setObject_cte_obj_at_tcb', simp_all)
|
|
done
|
|
|
|
crunch tcbPriority_inv[wp]: cteInsert "obj_at' (\<lambda>tcb. P (tcbPriority tcb)) t"
|
|
(wp: crunch_simps hoare_drop_imps)
|
|
|
|
|
|
lemma cteInsert_ct_idle_or_in_cur_domain'[wp]: "\<lbrace> ct_idle_or_in_cur_domain' \<rbrace> cteInsert a b c \<lbrace> \<lambda>_. ct_idle_or_in_cur_domain' \<rbrace>"
|
|
apply (rule ct_idle_or_in_cur_domain'_lift)
|
|
apply (wp hoare_vcg_disj_lift)
|
|
done
|
|
|
|
lemma setObject_cte_domIdx:
|
|
"\<lbrace>\<lambda>s. P (ksDomScheduleIdx s)\<rbrace> setObject t (v::cte) \<lbrace>\<lambda>rv s. P (ksDomScheduleIdx s)\<rbrace>"
|
|
by (clarsimp simp: valid_def setCTE_def[symmetric] dest!: setCTE_pspace_only)
|
|
|
|
crunch ksDomScheduleIdx[wp]: cteInsert "\<lambda>s. P (ksDomScheduleIdx s)"
|
|
(wp: setObject_cte_domIdx hoare_drop_imps ignore: setObject)
|
|
|
|
lemma cteInsert_invs:
|
|
"\<lbrace>invs' and cte_wp_at' (\<lambda>c. cteCap c=NullCap) dest and valid_cap' cap and
|
|
(\<lambda>s. src \<noteq> dest) and (\<lambda>s. cte_wp_at' (is_derived' (ctes_of s) src cap \<circ> cteCap) src s)
|
|
and ex_cte_cap_to' dest and (\<lambda>s. \<forall>irq. cap = IRQHandlerCap irq \<longrightarrow> irq_issued' irq s)\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>rv. invs'\<rbrace>"
|
|
apply (rule hoare_pre)
|
|
apply (simp add: invs'_def valid_state'_def valid_pspace'_def)
|
|
apply (wp cur_tcb_lift tcb_in_cur_domain'_lift sch_act_wf_lift
|
|
valid_irq_node_lift valid_queues_lift' irqs_masked_lift
|
|
cteInsert_norq | simp add: st_tcb_at'_def)+
|
|
apply (wp cur_tcb_lift tcb_in_cur_domain'_lift sch_act_wf_lift CSpace_R.valid_queues_lift
|
|
valid_irq_node_lift valid_queues_lift' irqs_masked_lift
|
|
cteInsert_norq | simp add: pred_tcb_at'_def)+
|
|
apply (auto simp: invs'_def valid_state'_def valid_pspace'_def elim:
|
|
valid_capAligned)
|
|
done
|
|
|
|
lemma derive_cap_corres:
|
|
"\<lbrakk>cap_relation c c'; cte = cte_map slot \<rbrakk> \<Longrightarrow>
|
|
corres (ser \<oplus> cap_relation)
|
|
(cte_at slot)
|
|
(pspace_aligned' and pspace_distinct' and cte_at' cte and valid_mdb')
|
|
(derive_cap slot c) (deriveCap cte c')"
|
|
apply (unfold derive_cap_def deriveCap_def)
|
|
apply (case_tac c)
|
|
apply (simp_all add: returnOk_def Let_def is_zombie_def isCap_simps
|
|
split: sum.splits)
|
|
apply (rule corres_initial_splitE [OF ensure_no_children_corres])
|
|
apply simp
|
|
apply clarsimp
|
|
apply wp
|
|
apply clarsimp
|
|
apply (rule corres_rel_imp)
|
|
apply (rule corres_guard_imp)
|
|
apply (rule arch_derive_corres)
|
|
apply (clarsimp simp: o_def)+
|
|
done
|
|
|
|
lemma deriveCap_inv[wp]:
|
|
"\<lbrace>P\<rbrace> deriveCap cte c \<lbrace>\<lambda>rv. P\<rbrace>"
|
|
apply (case_tac c, simp_all add: deriveCap_def ensureNoChildren_def whenE_def
|
|
isCap_simps Let_def, wp)
|
|
apply clarsimp
|
|
apply (wp arch_deriveCap_inv | simp)+
|
|
done
|
|
|
|
lemma lookup_cap_valid':
|
|
"\<lbrace>valid_objs'\<rbrace> lookupCap t c \<lbrace>valid_cap'\<rbrace>, -"
|
|
apply (simp add: lookupCap_def lookupCapAndSlot_def
|
|
lookupSlotForThread_def split_def)
|
|
apply (wp | simp)+
|
|
done
|
|
|
|
lemma capAligned_Null [simp]:
|
|
"capAligned NullCap"
|
|
by (simp add: capAligned_def is_aligned_def word_bits_def)
|
|
|
|
lemma guarded_lookup_valid_cap':
|
|
"\<lbrace> valid_objs' \<rbrace> nullCapOnFailure (lookupCap t c) \<lbrace>\<lambda>rv. valid_cap' rv \<rbrace>"
|
|
apply (simp add: nullCapOnFailure_def)
|
|
apply wp
|
|
apply (simp add: valid_cap'_def)
|
|
apply (fold validE_R_def)
|
|
apply (rule lookup_cap_valid')
|
|
done
|
|
|
|
lemma setObject_tcb_tcb':
|
|
"\<lbrace>tcb_at' p\<rbrace> setObject p (t::tcb) \<lbrace>\<lambda>rv. tcb_at' p\<rbrace>"
|
|
apply (rule obj_at_setObject1)
|
|
apply (simp add: updateObject_default_def in_monad)
|
|
apply (simp add: projectKOs)
|
|
apply (simp add: objBits_simps)
|
|
done
|
|
|
|
lemma cte_wp_at'_conjI:
|
|
"\<lbrakk> cte_wp_at' P p s; cte_wp_at' Q p s \<rbrakk> \<Longrightarrow> cte_wp_at' (\<lambda>c. P c \<and> Q c) p s"
|
|
by (auto simp add: cte_wp_at'_def)
|
|
|
|
crunch inv'[wp]: rangeCheck "P"
|
|
(simp: crunch_simps)
|
|
|
|
lemma lookupSlotForCNodeOp_inv'[wp]:
|
|
"\<lbrace>P\<rbrace> lookupSlotForCNodeOp src root ptr depth \<lbrace>\<lambda>rv. P\<rbrace>"
|
|
apply (simp add: lookupSlotForCNodeOp_def split_def unlessE_def
|
|
cong: if_cong split del: split_if)
|
|
apply (rule hoare_pre)
|
|
apply (wp hoare_drop_imps)
|
|
apply simp
|
|
done
|
|
|
|
lemma unifyFailure_inv [wp]:
|
|
"\<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. P\<rbrace>, \<lbrace>\<lambda>_. P\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> unifyFailure f \<lbrace>\<lambda>_. P\<rbrace>, \<lbrace>\<lambda>_. P\<rbrace>"
|
|
unfolding unifyFailure_def
|
|
apply (simp add: rethrowFailure_def const_def o_def)
|
|
apply wp
|
|
apply simp
|
|
done
|
|
|
|
(* FIXME: move *)
|
|
lemma loadWordUser_inv [wp]:
|
|
"\<lbrace>P\<rbrace> loadWordUser p \<lbrace>\<lambda>rv. P\<rbrace>"
|
|
unfolding loadWordUser_def
|
|
by (wp dmo_inv' loadWord_inv)
|
|
|
|
lemma capTransferFromWords_inv:
|
|
"\<lbrace>P\<rbrace> capTransferFromWords buffer \<lbrace>\<lambda>_. P\<rbrace>"
|
|
apply (simp add: capTransferFromWords_def)
|
|
apply wp
|
|
done
|
|
|
|
lemma lct_inv' [wp]:
|
|
"\<lbrace>P\<rbrace> loadCapTransfer b \<lbrace>\<lambda>rv. P\<rbrace>"
|
|
unfolding loadCapTransfer_def
|
|
apply (wp capTransferFromWords_inv)
|
|
done
|
|
|
|
lemma maskCapRightsNull [simp]:
|
|
"maskCapRights R NullCap = NullCap"
|
|
by (simp add: maskCapRights_def isCap_defs)
|
|
|
|
lemma maskCapRightsUntyped [simp]:
|
|
"maskCapRights R (UntypedCap r n f) = UntypedCap r n f"
|
|
by (simp add: maskCapRights_def isCap_defs Let_def)
|
|
|
|
lemma maskCapRightsZombie [simp]:
|
|
"maskCapRights R (Zombie p b n) = Zombie p b n"
|
|
by (simp add: maskCapRights_def isCap_defs Let_def)
|
|
|
|
(* FIXME: move *)
|
|
lemma cap_relation_update_masks:
|
|
"cap_relation a c'
|
|
\<Longrightarrow> cap_relation
|
|
(cap_rights_update (cap_rights a - {AllowWrite}) a)
|
|
(maskCapRights (capAllowWrite_update (\<lambda>_. False) allRights) c')"
|
|
apply (drule_tac rmask="UNIV - {AllowWrite}" in cap_relation_masks)
|
|
by (simp add: rights_mask_map_def allRights_def)
|
|
|
|
declare if_option_Some[simp]
|
|
|
|
lemma lookup_cap_corres:
|
|
"\<lbrakk> epcptr = to_bl epcptr' \<rbrakk> \<Longrightarrow>
|
|
corres (lfr \<oplus> cap_relation)
|
|
(valid_objs and pspace_aligned and tcb_at thread)
|
|
(valid_objs' and pspace_distinct' and pspace_aligned' and tcb_at' thread)
|
|
(lookup_cap thread epcptr)
|
|
(lookupCap thread epcptr')"
|
|
apply (simp add: lookup_cap_def lookupCap_def lookupCapAndSlot_def)
|
|
apply (rule corres_guard_imp)
|
|
apply (rule corres_splitEE [OF _ lookup_slot_corres])
|
|
apply (simp add: split_def)
|
|
apply (subst bindE_returnOk[symmetric])
|
|
apply (rule corres_splitEE)
|
|
prefer 2
|
|
apply simp
|
|
apply (rule getSlotCap_corres, rule refl)
|
|
apply (rule corres_returnOk [of _ \<top> \<top>])
|
|
apply simp
|
|
apply wp
|
|
apply auto
|
|
done
|
|
|
|
lemma ensureNoChildren_inv[wp]:
|
|
"\<lbrace>P\<rbrace> ensureNoChildren ptr \<lbrace>\<lambda>rv. P\<rbrace>"
|
|
apply (simp add: ensureNoChildren_def whenE_def)
|
|
apply (wp hoare_drop_imps)
|
|
apply auto
|
|
done
|
|
|
|
lemma ensure_empty_corres:
|
|
"q = cte_map p \<Longrightarrow>
|
|
corres (ser \<oplus> dc) (invs and cte_at p) invs'
|
|
(ensure_empty p) (ensureEmptySlot q)"
|
|
apply (clarsimp simp add: ensure_empty_def ensureEmptySlot_def unlessE_whenE liftE_bindE)
|
|
apply (rule corres_guard_imp)
|
|
apply (rule corres_split [OF _ get_cap_corres])
|
|
apply (rule corres_trivial)
|
|
apply (case_tac cap, auto simp add: whenE_def returnOk_def)[1]
|
|
apply wp
|
|
apply (clarsimp simp: invs_valid_objs invs_psp_aligned)
|
|
apply fastforce
|
|
done
|
|
|
|
lemma ensureEmpty_inv[wp]:
|
|
"\<lbrace>P\<rbrace> ensureEmptySlot p \<lbrace>\<lambda>rv. P\<rbrace>"
|
|
by (simp add: ensureEmptySlot_def unlessE_whenE whenE_def | wp)+
|
|
|
|
lemma lsfc_corres:
|
|
"\<lbrakk>cap_relation c c'; ptr = to_bl ptr'\<rbrakk>
|
|
\<Longrightarrow> corres (ser \<oplus> (\<lambda>cref cref'. cref' = cte_map cref))
|
|
(valid_objs and pspace_aligned and valid_cap c)
|
|
(valid_objs' and pspace_aligned' and pspace_distinct' and valid_cap' c')
|
|
(lookup_slot_for_cnode_op s c ptr depth)
|
|
(lookupSlotForCNodeOp s c' ptr' depth)"
|
|
apply (simp add: lookup_slot_for_cnode_op_def lookupSlotForCNodeOp_def)
|
|
apply (clarsimp simp: lookup_failure_map_def split_def word_size)
|
|
apply (clarsimp simp: rangeCheck_def[unfolded fun_app_def unlessE_def] whenE_def
|
|
word_bits_def toInteger_nat fromIntegral_def fromInteger_nat)
|
|
apply (rule corres_lookup_error)
|
|
apply (rule corres_guard_imp)
|
|
apply (rule corres_splitEE [OF _ rab_corres'])
|
|
apply (rule corres_trivial)
|
|
apply (clarsimp simp: returnOk_def lookup_failure_map_def
|
|
split: list.split)
|
|
apply simp+
|
|
apply wp
|
|
apply clarsimp
|
|
apply clarsimp
|
|
done
|
|
|
|
(* this helper characterisation of ctes_of
|
|
is needed in CNodeInv and Untyped *)
|
|
|
|
lemma ensureNoChildren_wp:
|
|
"\<lbrace>\<lambda>s. Q s \<and> (descendants_of' p (ctes_of s) = {} \<longrightarrow> P () s)\<rbrace> ensureNoChildren p \<lbrace>P\<rbrace>,\<lbrace>\<lambda>_. Q\<rbrace>"
|
|
apply (simp add: ensureNoChildren_def whenE_def)
|
|
apply (wp getCTE_wp')
|
|
apply (clarsimp simp: cte_wp_at_ctes_of nullPointer_def descendants_of'_def)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (erule (4) subtree_no_parent)
|
|
apply clarsimp
|
|
apply (erule (2) subtree_next_0)
|
|
done
|
|
|
|
lemma set_cap_pspace_corres:
|
|
"cap_relation cap (cteCap cte) \<Longrightarrow>
|
|
corres_underlying {(s, s'). pspace_relations (ekheap (s)) (kheap s) (ksPSpace s')} True dc
|
|
(pspace_distinct and pspace_aligned and valid_objs and cte_at p)
|
|
(pspace_aligned' and pspace_distinct' and cte_at' (cte_map p))
|
|
(set_cap cap p)
|
|
(setCTE (cte_map p) cte)"
|
|
apply (rule corres_no_failI)
|
|
apply (rule no_fail_pre, wp)
|
|
apply simp
|
|
apply clarsimp
|
|
apply (drule(8) set_cap_not_quite_corres_prequel)
|
|
apply simp
|
|
apply fastforce
|
|
done
|
|
|
|
(* FIXME: move to StateRelation *)
|
|
lemma ghost_relation_of_heap:
|
|
"ghost_relation h ups cns \<longleftrightarrow> ups_of_heap h = ups \<and> cns_of_heap h = cns"
|
|
apply (rule iffI)
|
|
apply (rule conjI)
|
|
apply (rule ext)
|
|
apply (clarsimp simp add: ghost_relation_def ups_of_heap_def)
|
|
apply (drule_tac x=x in spec)
|
|
apply (auto simp add: ghost_relation_def ups_of_heap_def
|
|
split: option.splits Structures_A.kernel_object.splits
|
|
arch_kernel_obj.splits)[1]
|
|
apply (rule ext)
|
|
apply (clarsimp simp add: ghost_relation_def cns_of_heap_def)
|
|
apply (drule_tac x=x in spec)+
|
|
apply (rule ccontr)
|
|
apply (simp split: option.splits Structures_A.kernel_object.splits
|
|
arch_kernel_obj.splits)[1]
|
|
apply (simp split: split_if_asm)
|
|
apply force
|
|
apply (drule not_sym)
|
|
apply clarsimp
|
|
apply (erule_tac x=y in allE)
|
|
apply simp
|
|
apply (auto simp add: ghost_relation_def ups_of_heap_def cns_of_heap_def
|
|
split: option.splits Structures_A.kernel_object.splits
|
|
arch_kernel_obj.splits split_if_asm)
|
|
done
|
|
|
|
lemma corres_caps_decomposition:
|
|
assumes x: "corres_underlying {(s, s'). pspace_relations (ekheap (s)) (kheap s) (ksPSpace s')} True r P P' f g"
|
|
assumes u: "\<And>P. \<lbrace>\<lambda>s. P (new_caps s)\<rbrace> f \<lbrace>\<lambda>rv s. P (caps_of_state s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_mdb s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cdt s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_list s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cdt_list (s))\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_rvk s)\<rbrace> f \<lbrace>\<lambda>rv s. P (is_original_cap s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_ctes s)\<rbrace> g \<lbrace>\<lambda>rv s. P (ctes_of s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_ms s)\<rbrace> f \<lbrace>\<lambda>rv s. P (machine_state s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_ms' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (ksMachineState s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_wuc s)\<rbrace> f \<lbrace>\<lambda>rv s. P (work_units_completed s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_wuc' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (ksWorkUnitsCompleted s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_ct s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cur_thread s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_ct' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (ksCurThread s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_as s)\<rbrace> f \<lbrace>\<lambda>rv s. P (arch_state s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_as' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (ksArchState s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_id s)\<rbrace> f \<lbrace>\<lambda>rv s. P (idle_thread s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_id' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (ksIdleThread s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_irqn s)\<rbrace> f \<lbrace>\<lambda>rv s. P (interrupt_irq_node s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_irqs s)\<rbrace> f \<lbrace>\<lambda>rv s. P (interrupt_states s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_irqs' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (ksInterruptState s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_ups s)\<rbrace> f \<lbrace>\<lambda>rv s. P (ups_of_heap (kheap s))\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_ups' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (gsUserPages s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_cns s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cns_of_heap (kheap s))\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_cns' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (gsCNodes s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_queues s)\<rbrace> f \<lbrace>\<lambda>rv s. P (ready_queues s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_action s)\<rbrace> f \<lbrace>\<lambda>rv s. P (scheduler_action s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_sa' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (ksSchedulerAction s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_rqs' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (ksReadyQueues s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_di s)\<rbrace> f \<lbrace>\<lambda>rv s. P (domain_index s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_dl s)\<rbrace> f \<lbrace>\<lambda>rv s. P (domain_list s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_cd s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cur_domain s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_dt s)\<rbrace> f \<lbrace>\<lambda>rv s. P (domain_time s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_dsi' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (ksDomScheduleIdx s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_ds' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (ksDomSchedule s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_cd' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (ksCurDomain s)\<rbrace>"
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_dt' s)\<rbrace> g \<lbrace>\<lambda>rv s. P (ksDomainTime s)\<rbrace>"
|
|
assumes z: "\<And>s s'. \<lbrakk> P s; P' s'; (s, s') \<in> state_relation \<rbrakk>
|
|
\<Longrightarrow> cdt_relation (op \<noteq> None \<circ> new_caps s) (new_mdb s) (new_ctes s')"
|
|
"\<And>s s'. \<lbrakk> P s; P' s'; (s, s') \<in> state_relation \<rbrakk>
|
|
\<Longrightarrow> cdt_list_relation (new_list s) (new_mdb s) (new_ctes s')"
|
|
"\<And>s s'. \<lbrakk> P s; P' s'; (s, s') \<in> state_relation \<rbrakk>
|
|
\<Longrightarrow> sched_act_relation (new_action s) (new_sa' s')"
|
|
"\<And>s s'. \<lbrakk> P s; P' s'; (s, s') \<in> state_relation \<rbrakk>
|
|
\<Longrightarrow> ready_queues_relation (new_queues s) (new_rqs' s')"
|
|
"\<And>s s'. \<lbrakk> P s; P' s'; (s, s') \<in> state_relation \<rbrakk>
|
|
\<Longrightarrow> revokable_relation (new_rvk s) (null_filter (new_caps s)) (new_ctes s')"
|
|
"\<And>s s'. \<lbrakk> P s; P' s'; (s, s') \<in> state_relation \<rbrakk>
|
|
\<Longrightarrow> (new_as s, new_as' s') \<in> arch_state_relation
|
|
\<and> interrupt_state_relation (new_irqn s) (new_irqs s) (new_irqs' s')
|
|
\<and> new_ct s = new_ct' s' \<and> new_id s = new_id' s'
|
|
\<and> new_ms s = new_ms' s' \<and> new_di s = new_dsi' s'
|
|
\<and> new_dl s = new_ds' s' \<and> new_cd s = new_cd' s' \<and> new_dt s = new_dt' s' \<and> new_wuc s = new_wuc' s'"
|
|
"\<And>s s'. \<lbrakk> P s; P' s'; (s, s') \<in> state_relation \<rbrakk>
|
|
\<Longrightarrow> new_ups s = new_ups' s'"
|
|
"\<And>s s'. \<lbrakk> P s; P' s'; (s, s') \<in> state_relation \<rbrakk>
|
|
\<Longrightarrow> new_cns s = new_cns' s'"
|
|
shows "corres r P P' f g"
|
|
proof -
|
|
have all_ext: "\<And>f f'. (\<forall>p. f p = f' p) = (f = f')"
|
|
by (fastforce intro!: ext)
|
|
have mdb_wp':
|
|
"\<And>ctes. \<lbrace>\<lambda>s. cdt_relation (op \<noteq> None \<circ> new_caps s) (new_mdb s) ctes\<rbrace>
|
|
f
|
|
\<lbrace>\<lambda>rv s. \<exists>m ca. (\<forall>p. ca p = (op \<noteq> None \<circ> caps_of_state s) p) \<and> m = cdt s
|
|
\<and> cdt_relation ca m ctes\<rbrace>"
|
|
apply (wp hoare_vcg_ex_lift hoare_vcg_all_lift u)
|
|
apply (subst all_ext)
|
|
apply (simp add: o_def)
|
|
done
|
|
note mdb_wp = mdb_wp' [simplified all_ext simp_thms]
|
|
have list_wp':
|
|
"\<And>ctes. \<lbrace>\<lambda>s. cdt_list_relation (new_list s) (new_mdb s) ctes\<rbrace>
|
|
f
|
|
\<lbrace>\<lambda>rv s. \<exists>m t. t = cdt_list s \<and> m = cdt s
|
|
\<and> cdt_list_relation t m ctes\<rbrace>"
|
|
apply (wp hoare_vcg_ex_lift hoare_vcg_all_lift u)
|
|
apply (simp add: o_def)
|
|
done
|
|
note list_wp = list_wp' [simplified all_ext simp_thms]
|
|
have rvk_wp':
|
|
"\<And>ctes. \<lbrace>\<lambda>s. revokable_relation (new_rvk s) (null_filter (new_caps s)) ctes\<rbrace>
|
|
f
|
|
\<lbrace>\<lambda>rv s. revokable_relation (is_original_cap s) (null_filter (caps_of_state s)) ctes\<rbrace>"
|
|
unfolding revokable_relation_def
|
|
apply (simp only: imp_conv_disj)
|
|
apply (wp hoare_vcg_ex_lift hoare_vcg_all_lift hoare_vcg_disj_lift u)
|
|
done
|
|
have exs_wp':
|
|
"\<And>ctes. \<lbrace>\<lambda>s. revokable_relation (new_rvk s) (null_filter (new_caps s)) ctes\<rbrace>
|
|
f
|
|
\<lbrace>\<lambda>rv s. revokable_relation (is_original_cap s) (null_filter (caps_of_state s)) ctes\<rbrace>"
|
|
unfolding revokable_relation_def
|
|
apply (simp only: imp_conv_disj)
|
|
apply (wp hoare_vcg_ex_lift hoare_vcg_all_lift hoare_vcg_disj_lift u)
|
|
done
|
|
note rvk_wp = rvk_wp' [simplified all_ext simp_thms]
|
|
have swp_cte_at:
|
|
"\<And>s. swp cte_at s = (op \<noteq> None \<circ> caps_of_state s)"
|
|
by (rule ext, simp, subst neq_commute, simp add: cte_wp_at_caps_of_state)
|
|
have abs_irq_together':
|
|
"\<And>P. \<lbrace>\<lambda>s. P (new_irqn s) (new_irqs s)\<rbrace> f
|
|
\<lbrace>\<lambda>rv s. \<exists>irn. interrupt_irq_node s = irn \<and> P irn (interrupt_states s)\<rbrace>"
|
|
by (wp hoare_vcg_ex_lift u, simp)
|
|
note abs_irq_together = abs_irq_together'[simplified]
|
|
show ?thesis
|
|
unfolding state_relation_def swp_cte_at
|
|
apply (subst conj_assoc[symmetric])
|
|
apply (subst pspace_relations_def[symmetric])
|
|
apply (rule corres_underlying_decomposition [OF x])
|
|
apply (simp add: ghost_relation_of_heap)
|
|
apply (wp hoare_vcg_conj_lift mdb_wp rvk_wp list_wp u abs_irq_together)
|
|
apply (intro z[simplified o_def] conjI | simp add: state_relation_def pspace_relations_def swp_cte_at
|
|
| (clarsimp, drule (1) z(6), simp add: state_relation_def pspace_relations_def swp_cte_at))+
|
|
done
|
|
qed
|
|
|
|
lemma getCTE_symb_exec_r:
|
|
"corres_underlying sr nf dc \<top> (cte_at' p) (return ()) (getCTE p)"
|
|
apply (rule corres_no_failI, wp)
|
|
apply (clarsimp simp: return_def
|
|
elim!: use_valid [OF _ getCTE_inv])
|
|
done
|
|
|
|
lemma updateMDB_symb_exec_r:
|
|
"corres_underlying {(s, s'). pspace_relations (ekheap s) (kheap s) (ksPSpace s')} nf dc
|
|
\<top> (pspace_aligned' and pspace_distinct' and (no_0 \<circ> ctes_of) and (\<lambda>s. p \<noteq> 0 \<longrightarrow> cte_at' p s))
|
|
(return ()) (updateMDB p m)"
|
|
using no_fail_updateMDB [of p m]
|
|
apply (clarsimp simp: corres_underlying_def return_def no_fail_def)
|
|
apply (drule(1) updateMDB_the_lot, simp, assumption+)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma updateMDB_ctes_of_cases:
|
|
"\<lbrace>\<lambda>s. P (modify_map (ctes_of s) p (if p = 0 then id else cteMDBNode_update f))\<rbrace>
|
|
updateMDB p f \<lbrace>\<lambda>rv s. P (ctes_of s)\<rbrace>"
|
|
apply (simp add: updateMDB_def split del: split_if)
|
|
apply (rule hoare_pre, wp getCTE_ctes_of)
|
|
apply (clarsimp simp: modify_map_def map_option_case
|
|
split: option.split
|
|
| rule conjI ext | erule rsubst[where P=P])+
|
|
apply (case_tac y, simp)
|
|
done
|
|
|
|
crunch ct[wp]: updateMDB "\<lambda>s. P (ksCurThread s)"
|
|
|
|
lemma setCTE_state_bits[wp]:
|
|
"\<lbrace>\<lambda>s. P (ksMachineState s)\<rbrace> setCTE p v \<lbrace>\<lambda>rv s. P (ksMachineState s)\<rbrace>"
|
|
"\<lbrace>\<lambda>s. Q (ksIdleThread s)\<rbrace> setCTE p v \<lbrace>\<lambda>rv s. Q (ksIdleThread s)\<rbrace>"
|
|
"\<lbrace>\<lambda>s. R (ksArchState s)\<rbrace> setCTE p v \<lbrace>\<lambda>rv s. R (ksArchState s)\<rbrace>"
|
|
"\<lbrace>\<lambda>s. S (ksInterruptState s)\<rbrace> setCTE p v \<lbrace>\<lambda>rv s. S (ksInterruptState s)\<rbrace>"
|
|
apply (simp_all add: setCTE_def setObject_def split_def)
|
|
apply (wp updateObject_cte_inv | simp)+
|
|
done
|
|
|
|
crunch ms'[wp]: updateMDB "\<lambda>s. P (ksMachineState s)"
|
|
crunch idle'[wp]: updateMDB "\<lambda>s. P (ksIdleThread s)"
|
|
crunch arch'[wp]: updateMDB "\<lambda>s. P (ksArchState s)"
|
|
crunch int'[wp]: updateMDB "\<lambda>s. P (ksInterruptState s)"
|
|
|
|
lemma cte_map_eq_subst:
|
|
"\<lbrakk> cte_at p s; cte_at p' s; valid_objs s; pspace_aligned s; pspace_distinct s \<rbrakk>
|
|
\<Longrightarrow> (cte_map p = cte_map p') = (p = p')"
|
|
by (fastforce elim!: cte_map_inj_eq)
|
|
|
|
lemma revokable_relation_simp:
|
|
"\<lbrakk> (s, s') \<in> state_relation; null_filter (caps_of_state s) p = Some c; ctes_of s' (cte_map p) = Some (CTE cap node) \<rbrakk>
|
|
\<Longrightarrow> mdbRevocable node = is_original_cap s p"
|
|
by (cases p, clarsimp simp: state_relation_def revokable_relation_def)
|
|
|
|
lemma setCTE_gsUserPages[wp]:
|
|
"\<lbrace>\<lambda>s. P (gsUserPages s)\<rbrace> setCTE p v \<lbrace>\<lambda>rv s. P (gsUserPages s)\<rbrace>"
|
|
apply (simp add: setCTE_def setObject_def split_def)
|
|
apply (wp updateObject_cte_inv crunch_wps | simp)+
|
|
done
|
|
|
|
lemma setCTE_gsCNodes[wp]:
|
|
"\<lbrace>\<lambda>s. P (gsCNodes s)\<rbrace> setCTE p v \<lbrace>\<lambda>rv s. P (gsCNodes s)\<rbrace>"
|
|
apply (simp add: setCTE_def setObject_def split_def)
|
|
apply (wp updateObject_cte_inv crunch_wps | simp)+
|
|
done
|
|
|
|
lemma set_original_symb_exec_l':
|
|
"corres_underlying {(s, s'). f (ekheap s) (kheap s) s'} nf dc P P' (set_original p b) (return x)"
|
|
by (simp add: corres_underlying_def return_def set_original_def in_monad Bex_def)
|
|
|
|
lemma setCTE_schedule_index[wp]:
|
|
"\<lbrace>\<lambda>s. P (ksDomScheduleIdx s)\<rbrace> setCTE p v \<lbrace>\<lambda>rv s. P (ksDomScheduleIdx s)\<rbrace>"
|
|
apply (simp add: setCTE_def setObject_def split_def)
|
|
apply (wp updateObject_cte_inv crunch_wps | simp)+
|
|
done
|
|
|
|
lemma setCTE_schedule[wp]:
|
|
"\<lbrace>\<lambda>s. P (ksDomSchedule s)\<rbrace> setCTE p v \<lbrace>\<lambda>rv s. P (ksDomSchedule s)\<rbrace>"
|
|
apply (simp add: setCTE_def setObject_def split_def)
|
|
apply (wp updateObject_cte_inv crunch_wps | simp)+
|
|
done
|
|
|
|
lemma setCTE_domain_time[wp]:
|
|
"\<lbrace>\<lambda>s. P (ksDomainTime s)\<rbrace> setCTE p v \<lbrace>\<lambda>rv s. P (ksDomainTime s)\<rbrace>"
|
|
apply (simp add: setCTE_def setObject_def split_def)
|
|
apply (wp updateObject_cte_inv crunch_wps | simp)+
|
|
done
|
|
|
|
lemma setCTE_work_units_completed[wp]:
|
|
"\<lbrace>\<lambda>s. P (ksWorkUnitsCompleted s)\<rbrace> setCTE p v \<lbrace>\<lambda>_ s. P (ksWorkUnitsCompleted s)\<rbrace>"
|
|
apply (simp add: setCTE_def setObject_def split_def)
|
|
apply (wp updateObject_cte_inv crunch_wps | simp)+
|
|
done
|
|
|
|
lemma create_reply_master_corres:
|
|
"sl' = cte_map sl \<Longrightarrow>
|
|
corres dc
|
|
(cte_wp_at (op = cap.NullCap) sl and valid_pspace and valid_mdb and valid_list)
|
|
(cte_wp_at' (\<lambda>c. cteCap c = NullCap \<and> mdbPrev (cteMDBNode c) = 0) sl'
|
|
and valid_mdb' and valid_pspace')
|
|
(do
|
|
y \<leftarrow> set_original sl True;
|
|
set_cap (cap.ReplyCap thread True) sl
|
|
od)
|
|
(setCTE sl' (CTE (capability.ReplyCap thread True) initMDBNode))"
|
|
apply clarsimp
|
|
apply (rule corres_caps_decomposition)
|
|
defer
|
|
apply (wp|simp)+
|
|
apply (clarsimp simp: o_def cdt_relation_def cte_wp_at_ctes_of
|
|
split del: split_if cong: if_cong simp del: id_apply)
|
|
apply (case_tac cte, clarsimp)
|
|
apply (fold fun_upd_def)
|
|
apply (subst descendants_of_Null_update')
|
|
apply fastforce
|
|
apply fastforce
|
|
apply assumption
|
|
apply assumption
|
|
apply (simp add: nullPointer_def)
|
|
apply (subgoal_tac "cte_at (a, b) s")
|
|
prefer 2
|
|
apply (drule not_sym, clarsimp simp: cte_wp_at_caps_of_state
|
|
split: split_if_asm)
|
|
apply (simp add: state_relation_def cdt_relation_def)
|
|
apply (clarsimp simp: o_def cdt_list_relation_def cte_wp_at_ctes_of
|
|
split del: split_if cong: if_cong simp del: id_apply)
|
|
apply (case_tac cte, clarsimp)
|
|
apply (clarsimp simp: state_relation_def cdt_list_relation_def)
|
|
apply (simp split: split_if_asm)
|
|
apply (erule_tac x=a in allE, erule_tac x=b in allE)
|
|
apply clarsimp
|
|
apply(case_tac "next_slot (a, b) (cdt_list s) (cdt s)")
|
|
apply(simp)
|
|
apply(simp)
|
|
apply(fastforce simp: valid_mdb'_def valid_mdb_ctes_def valid_nullcaps_def)
|
|
apply (clarsimp simp: state_relation_def)
|
|
apply (clarsimp simp: state_relation_def)
|
|
apply (clarsimp simp add: revokable_relation_def cte_wp_at_ctes_of
|
|
split del: split_if)
|
|
apply simp
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: initMDBNode_def)
|
|
apply clarsimp
|
|
apply (subgoal_tac "null_filter (caps_of_state s) (a, b) \<noteq> None")
|
|
prefer 2
|
|
apply (clarsimp simp: null_filter_def cte_wp_at_caps_of_state
|
|
split: split_if_asm)
|
|
apply (subgoal_tac "cte_at (a,b) s")
|
|
prefer 2
|
|
apply clarsimp
|
|
apply (drule null_filter_caps_of_stateD)
|
|
apply (erule cte_wp_cte_at)
|
|
apply (clarsimp split: split_if_asm cong: conj_cong
|
|
simp: cte_map_eq_subst revokable_relation_simp
|
|
cte_wp_at_cte_at valid_pspace_def)
|
|
apply (clarsimp simp: state_relation_def)
|
|
apply (clarsimp elim!: state_relationE simp: ghost_relation_of_heap)+
|
|
apply (rule corres_guard_imp)
|
|
apply (rule corres_underlying_symb_exec_l [OF set_original_symb_exec_l'])
|
|
apply (rule set_cap_pspace_corres)
|
|
apply simp
|
|
apply wp
|
|
apply (clarsimp simp: cte_wp_at_cte_at valid_pspace_def)
|
|
apply (clarsimp simp: valid_pspace'_def cte_wp_at'_def)
|
|
done
|
|
|
|
lemma cte_map_nat_to_cref:
|
|
"\<lbrakk> n < 2 ^ b; b < 32 \<rbrakk> \<Longrightarrow>
|
|
cte_map (p, nat_to_cref b n) = p + (of_nat n * 16)"
|
|
apply (clarsimp simp: cte_map_def nat_to_cref_def
|
|
dest!: less_is_drop_replicate)
|
|
apply (rule arg_cong [where f="\<lambda>x. x * 16"])
|
|
apply (subst of_drop_to_bl)
|
|
apply (simp add: word_bits_def)
|
|
apply (subst mask_eq_iff_w2p)
|
|
apply (simp add: word_size)
|
|
apply (simp add: word_less_nat_alt word_size word_bits_def)
|
|
apply (rule order_le_less_trans)
|
|
defer
|
|
apply assumption
|
|
apply (subst unat_of_nat)
|
|
apply (rule mod_le_dividend)
|
|
done
|
|
|
|
lemma valid_nullcapsE:
|
|
"\<lbrakk> valid_nullcaps m; m p = Some (CTE NullCap n);
|
|
\<lbrakk> mdbPrev n = 0; mdbNext n = 0 \<rbrakk> \<Longrightarrow> P \<rbrakk>
|
|
\<Longrightarrow> P"
|
|
by (fastforce simp: valid_nullcaps_def nullMDBNode_def nullPointer_def)
|
|
|
|
lemma valid_nullcaps_prev:
|
|
"\<lbrakk> m (mdbPrev n) = Some (CTE NullCap n'); m p = Some (CTE c n);
|
|
no_0 m; valid_dlist m; valid_nullcaps m \<rbrakk> \<Longrightarrow> False"
|
|
apply (erule (1) valid_nullcapsE)
|
|
apply (erule_tac p=p in valid_dlistEp, assumption)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma valid_nullcaps_next:
|
|
"\<lbrakk> m (mdbNext n) = Some (CTE NullCap n'); m p = Some (CTE c n);
|
|
no_0 m; valid_dlist m; valid_nullcaps m \<rbrakk> \<Longrightarrow> False"
|
|
apply (erule (1) valid_nullcapsE)
|
|
apply (erule_tac p=p in valid_dlistEn, assumption)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
done
|
|
|
|
defs noReplyCapsFor_def:
|
|
"noReplyCapsFor \<equiv> \<lambda>t s. \<forall>sl m. \<not> cte_wp_at' (\<lambda>cte. cteCap cte = ReplyCap t m) sl s"
|
|
|
|
lemma pspace_relation_no_reply_caps:
|
|
assumes pspace: "pspace_relation (kheap s) (ksPSpace s')"
|
|
and invs: "invs s"
|
|
and tcb: "tcb_at t s"
|
|
and m_cte': "cte_wp_at' (op = cte) sl' s'"
|
|
and m_null: "cteCap cte = capability.NullCap"
|
|
and m_sl: "sl' = cte_map (t, tcb_cnode_index 2)"
|
|
shows "noReplyCapsFor t s'"
|
|
proof -
|
|
from tcb have m_cte: "cte_at (t, tcb_cnode_index 2) s"
|
|
by (clarsimp elim!: tcb_at_cte_at)
|
|
have m_cte_null:
|
|
"cte_wp_at (\<lambda>c. c = cap.NullCap) (t, tcb_cnode_index 2) s"
|
|
using pspace invs
|
|
apply (frule_tac pspace_relation_cte_wp_atI')
|
|
apply (rule assms)
|
|
apply clarsimp
|
|
apply (clarsimp simp: m_sl)
|
|
apply (frule cte_map_inj_eq)
|
|
apply (rule m_cte)
|
|
apply (erule cte_wp_cte_at)
|
|
apply clarsimp+
|
|
apply (clarsimp elim!: cte_wp_at_weakenE simp: m_null)
|
|
done
|
|
have no_reply_caps:
|
|
"\<forall>sl m. \<not> cte_wp_at (\<lambda>c. c = cap.ReplyCap t m) sl s"
|
|
by (rule no_reply_caps_for_thread [OF invs tcb m_cte_null])
|
|
hence noReplyCaps:
|
|
"\<forall>sl m. \<not> cte_wp_at' (\<lambda>cte. cteCap cte = ReplyCap t m) sl s'"
|
|
apply (intro allI)
|
|
apply (clarsimp simp: cte_wp_at_neg2 cte_wp_at_ctes_of simp del: split_paired_All)
|
|
apply (frule pspace_relation_cte_wp_atI [OF pspace _ invs_valid_objs [OF invs]])
|
|
apply (clarsimp simp: cte_wp_at_neg2 simp del: split_paired_All)
|
|
apply (drule_tac x="(a, b)" in spec)
|
|
apply (clarsimp simp: cte_wp_cte_at cte_wp_at_caps_of_state)
|
|
apply (case_tac c, simp_all)
|
|
apply fastforce
|
|
done
|
|
thus ?thesis
|
|
by (simp add: noReplyCapsFor_def)
|
|
qed
|
|
|
|
lemma setup_reply_master_corres:
|
|
"corres dc (einvs and tcb_at t) (invs' and tcb_at' t)
|
|
(setup_reply_master t) (setupReplyMaster t)"
|
|
apply (simp add: setupReplyMaster_def setup_reply_master_def)
|
|
apply (simp add: locateSlot_conv tcbReplySlot_def objBits_def objBitsKO_def)
|
|
apply (simp add: nullMDBNode_def, fold initMDBNode_def)
|
|
apply (rule_tac F="t + 0x20 = cte_map (t, tcb_cnode_index 2)"
|
|
in corres_req)
|
|
apply (clarsimp simp: tcb_cnode_index_def2 cte_map_nat_to_cref)
|
|
apply (clarsimp simp: cte_level_bits_def)
|
|
apply (rule stronger_corres_guard_imp)
|
|
apply (rule corres_split [OF _ get_cap_corres])
|
|
apply (rule corres_when)
|
|
apply fastforce
|
|
apply (rule_tac P'="einvs and tcb_at t" in corres_stateAssert_implied)
|
|
apply (rule create_reply_master_corres)
|
|
apply simp
|
|
apply (subgoal_tac "\<exists>cte. cte_wp_at' (op = cte) (cte_map (t, tcb_cnode_index 2)) s'
|
|
\<and> cteCap cte = capability.NullCap")
|
|
apply (fastforce dest: pspace_relation_no_reply_caps
|
|
state_relation_pspace_relation)
|
|
apply (clarsimp simp: cte_map_def tcb_cnode_index_def cte_wp_at_ctes_of)
|
|
apply (rule_tac Q="\<lambda>rv. einvs and tcb_at t and
|
|
cte_wp_at (op = rv) (t, tcb_cnode_index 2)"
|
|
in hoare_strengthen_post)
|
|
apply (wp hoare_drop_imps get_cap_wp)
|
|
apply (clarsimp simp: invs_def valid_state_def elim!: cte_wp_at_weakenE)
|
|
apply (rule_tac Q="\<lambda>rv. valid_pspace' and valid_mdb' and
|
|
cte_wp_at' (op = rv) (cte_map (t, tcb_cnode_index 2))"
|
|
in hoare_strengthen_post)
|
|
apply (wp hoare_drop_imps getCTE_wp')
|
|
apply (clarsimp simp: cte_wp_at_ctes_of valid_mdb'_def valid_mdb_ctes_def)
|
|
apply (case_tac r, fastforce elim: valid_nullcapsE)
|
|
apply (fastforce elim: tcb_at_cte_at)
|
|
apply (clarsimp simp: cte_at'_obj_at' tcb_cte_cases_def cte_map_def)
|
|
apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def)
|
|
done
|
|
|
|
crunch tcb'[wp]: setupReplyMaster "tcb_at' t"
|
|
(wp: crunch_wps)
|
|
|
|
crunch idle'[wp]: setupReplyMaster "valid_idle'"
|
|
|
|
(* Levity: added (20090126 19:32:14) *)
|
|
declare stateAssert_wp [wp]
|
|
|
|
lemma setupReplyMaster_valid_mdb:
|
|
"slot = t + 2 ^ objBits (undefined :: cte) * tcbReplySlot \<Longrightarrow>
|
|
\<lbrace>valid_mdb' and valid_pspace' and tcb_at' t\<rbrace>
|
|
setupReplyMaster t
|
|
\<lbrace>\<lambda>rv. valid_mdb'\<rbrace>"
|
|
apply (clarsimp simp: setupReplyMaster_def locateSlot_conv
|
|
nullMDBNode_def)
|
|
apply (fold initMDBNode_def)
|
|
apply (wp setCTE_valid_mdb getCTE_wp')
|
|
apply clarsimp
|
|
apply (intro conjI)
|
|
apply (case_tac cte)
|
|
apply (fastforce simp: cte_wp_at_ctes_of valid_mdb'_def valid_mdb_ctes_def
|
|
no_mdb_def
|
|
elim: valid_nullcapsE)
|
|
apply (frule obj_at_aligned')
|
|
apply (simp add: valid_cap'_def capAligned_def
|
|
objBits_def objBitsKO_def word_bits_def)+
|
|
apply (clarsimp simp: valid_pspace'_def)
|
|
apply (clarsimp simp: caps_no_overlap'_def capRange_def)
|
|
apply (clarsimp simp: fresh_virt_cap_class_def
|
|
elim!: ranE)
|
|
apply (clarsimp simp add: noReplyCapsFor_def cte_wp_at_ctes_of)
|
|
apply (case_tac x)
|
|
apply (rename_tac capability mdbnode)
|
|
apply (case_tac capability; simp)
|
|
apply (rename_tac arch_capability)
|
|
apply (case_tac arch_capability; simp)
|
|
apply fastforce
|
|
done
|
|
|
|
lemma setupReplyMaster_valid_objs [wp]:
|
|
"\<lbrace> valid_objs' and pspace_aligned' and pspace_distinct' and tcb_at' t\<rbrace>
|
|
setupReplyMaster t
|
|
\<lbrace>\<lambda>_. valid_objs'\<rbrace>"
|
|
apply (simp add: setupReplyMaster_def locateSlot_conv)
|
|
apply (wp setCTE_valid_objs getCTE_wp')
|
|
apply (clarsimp)
|
|
apply (frule obj_at_aligned')
|
|
apply (simp add: valid_cap'_def capAligned_def
|
|
objBits_def objBitsKO_def word_bits_def)+
|
|
done
|
|
|
|
lemma setupReplyMaster_wps[wp]:
|
|
"\<lbrace>pspace_aligned'\<rbrace> setupReplyMaster t \<lbrace>\<lambda>rv. pspace_aligned'\<rbrace>"
|
|
"\<lbrace>pspace_distinct'\<rbrace> setupReplyMaster t \<lbrace>\<lambda>rv. pspace_distinct'\<rbrace>"
|
|
"slot = cte_map (t, tcb_cnode_index 2) \<Longrightarrow>
|
|
\<lbrace>\<lambda>s. P ((cteCaps_of s)(slot \<mapsto> (capability.ReplyCap t True))) \<and> P (cteCaps_of s)\<rbrace>
|
|
setupReplyMaster t
|
|
\<lbrace>\<lambda>rv s. P (cteCaps_of s)\<rbrace>"
|
|
apply (simp_all add: setupReplyMaster_def locateSlot_conv)
|
|
apply (wp hoare_drop_imps
|
|
| simp add: o_def
|
|
| rule hoare_strengthen_post [OF getCTE_sp])+
|
|
apply (clarsimp elim!: rsubst[where P=P] intro!: ext)
|
|
apply (clarsimp simp: tcbReplySlot_def objBits_def objBitsKO_def
|
|
tcb_cnode_index_def2 cte_map_nat_to_cref cte_level_bits_def)
|
|
done
|
|
|
|
crunch no_0_obj'[wp]: setupReplyMaster no_0_obj'
|
|
(wp: crunch_wps)
|
|
|
|
lemma setupReplyMaster_valid_pspace':
|
|
"\<lbrace>valid_pspace' and tcb_at' t\<rbrace>
|
|
setupReplyMaster t
|
|
\<lbrace>\<lambda>rv. valid_pspace'\<rbrace>"
|
|
apply (simp add: valid_pspace'_def)
|
|
apply (wp setupReplyMaster_valid_mdb)
|
|
apply (simp_all add: valid_pspace'_def)
|
|
done
|
|
|
|
lemma setupReplyMaster_ifunsafe'[wp]:
|
|
"slot = t + 2 ^ objBits (undefined :: cte) * tcbReplySlot \<Longrightarrow>
|
|
\<lbrace>if_unsafe_then_cap' and ex_cte_cap_to' slot\<rbrace>
|
|
setupReplyMaster t
|
|
\<lbrace>\<lambda>rv s. if_unsafe_then_cap' s\<rbrace>"
|
|
apply (simp add: ifunsafe'_def3 setupReplyMaster_def locateSlot_conv)
|
|
apply (wp getCTE_wp')
|
|
apply (clarsimp simp: ex_cte_cap_to'_def cte_wp_at_ctes_of cteCaps_of_def
|
|
cte_level_bits_def objBits_simps)
|
|
apply (drule_tac x=crefa in spec)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (rule_tac x=cref in exI, fastforce)
|
|
apply clarsimp
|
|
apply (rule_tac x=cref' in exI, fastforce)
|
|
done
|
|
|
|
|
|
lemma setupReplyMaster_iflive'[wp]:
|
|
"\<lbrace>if_live_then_nonz_cap'\<rbrace> setupReplyMaster t \<lbrace>\<lambda>rv. if_live_then_nonz_cap'\<rbrace>"
|
|
apply (simp add: setupReplyMaster_def locateSlot_conv)
|
|
apply (wp setCTE_iflive' getCTE_wp')
|
|
apply (clarsimp elim!: cte_wp_at_weakenE')
|
|
done
|
|
|
|
lemma setupReplyMaster_global_refs[wp]:
|
|
"\<lbrace>\<lambda>s. valid_global_refs' s \<and> thread \<notin> global_refs' s \<and> tcb_at' thread s
|
|
\<and> ex_nonz_cap_to' thread s \<and> valid_objs' s\<rbrace>
|
|
setupReplyMaster thread
|
|
\<lbrace>\<lambda>rv. valid_global_refs'\<rbrace>"
|
|
apply (simp add: setupReplyMaster_def locateSlot_conv)
|
|
apply (wp getCTE_wp')
|
|
apply (clarsimp simp: capRange_def cte_wp_at_ctes_of objBits_simps)
|
|
apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of)
|
|
apply (rename_tac "prev_cte")
|
|
apply (case_tac prev_cte, simp)
|
|
apply (frule(1) ctes_of_valid_cap')
|
|
apply (drule(1) valid_global_refsD_with_objSize)+
|
|
apply (clarsimp simp: valid_cap'_def objBits_simps obj_at'_def projectKOs
|
|
split: capability.split_asm)
|
|
done
|
|
|
|
crunch valid_arch'[wp]: setupReplyMaster "valid_arch_state'"
|
|
lemma ex_nonz_tcb_cte_caps':
|
|
"\<lbrakk>ex_nonz_cap_to' t s; tcb_at' t s; valid_objs' s; sl \<in> dom tcb_cte_cases\<rbrakk> \<Longrightarrow>
|
|
ex_cte_cap_to' (t + sl) s"
|
|
apply (clarsimp simp: ex_nonz_cap_to'_def ex_cte_cap_to'_def cte_wp_at_ctes_of)
|
|
apply (subgoal_tac "s \<turnstile>' cteCap cte")
|
|
apply (rule_tac x=cref in exI, rule_tac x=cte in exI)
|
|
apply (clarsimp simp: valid_cap'_def obj_at'_def projectKOs dom_def
|
|
split: cte.split_asm capability.split_asm)
|
|
apply (case_tac cte)
|
|
apply (clarsimp simp: ctes_of_valid_cap')
|
|
done
|
|
|
|
lemma ex_nonz_cap_not_global':
|
|
"\<lbrakk>ex_nonz_cap_to' t s; valid_objs' s; valid_global_refs' s\<rbrakk> \<Longrightarrow>
|
|
t \<notin> global_refs' s"
|
|
apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of)
|
|
apply (frule(1) valid_global_refsD')
|
|
apply clarsimp
|
|
apply (drule orthD1, erule (1) subsetD)
|
|
apply (subgoal_tac "s \<turnstile>' cteCap cte")
|
|
apply (fastforce simp: valid_cap'_def capRange_def capAligned_def
|
|
is_aligned_no_overflow
|
|
split: cte.split_asm capability.split_asm)
|
|
apply (case_tac cte)
|
|
apply (clarsimp simp: ctes_of_valid_cap')
|
|
done
|
|
|
|
crunch typ_at'[wp]: setupReplyMaster "\<lambda>s. P (typ_at' T p s)"
|
|
(wp: hoare_drop_imps)
|
|
|
|
lemma setCTE_irq_handlers':
|
|
"\<lbrace>\<lambda>s. valid_irq_handlers' s \<and> (\<forall>irq. cteCap cte = IRQHandlerCap irq \<longrightarrow> irq_issued' irq s)\<rbrace>
|
|
setCTE ptr cte
|
|
\<lbrace>\<lambda>rv. valid_irq_handlers'\<rbrace>"
|
|
apply (simp add: valid_irq_handlers'_def cteCaps_of_def irq_issued'_def)
|
|
apply (wp hoare_use_eq [where f=ksInterruptState, OF setCTE_ksInterruptState setCTE_ctes_of_wp])
|
|
apply (auto simp: ran_def)
|
|
done
|
|
|
|
lemma setupReplyMaster_irq_handlers'[wp]:
|
|
"\<lbrace>valid_irq_handlers'\<rbrace> setupReplyMaster t \<lbrace>\<lambda>rv. valid_irq_handlers'\<rbrace>"
|
|
apply (simp add: setupReplyMaster_def locateSlot_conv)
|
|
apply (wp setCTE_irq_handlers' getCTE_wp)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of)
|
|
done
|
|
|
|
crunch irq_states' [wp]: setupReplyMaster valid_irq_states'
|
|
crunch irqs_makes' [wp]: setupReplyMaster irqs_masked'
|
|
(lift: irqs_masked_lift)
|
|
crunch pde_mappings' [wp]: setupReplyMaster valid_pde_mappings'
|
|
|
|
crunch pred_tcb_at' [wp]: setupReplyMaster "pred_tcb_at' proj P t"
|
|
|
|
crunch ksMachine[wp]: setupReplyMaster "\<lambda>s. P (ksMachineState s)"
|
|
|
|
lemma setupReplyMaster_vms'[wp]:
|
|
"\<lbrace>valid_machine_state'\<rbrace> setupReplyMaster t \<lbrace>\<lambda>_. valid_machine_state'\<rbrace>"
|
|
apply (simp add: valid_machine_state'_def pointerInUserData_def )
|
|
apply (intro hoare_vcg_all_lift hoare_vcg_disj_lift)
|
|
apply wp
|
|
done
|
|
|
|
crunch pspace_domain_valid[wp]: setupReplyMaster "pspace_domain_valid"
|
|
crunch ct_not_inQ[wp]: setupReplyMaster "ct_not_inQ"
|
|
crunch ksCurDomain[wp]: setupReplyMaster "\<lambda>s. P (ksCurDomain s)"
|
|
crunch ksCurThread[wp]: setupReplyMaster "\<lambda>s. P (ksCurThread s)"
|
|
crunch ksIdlethread[wp]: setupReplyMaster "\<lambda>s. P (ksIdleThread s)"
|
|
crunch ksDomSchedule[wp]: setupReplyMaster "\<lambda>s. P (ksDomSchedule s)"
|
|
crunch scheduler_action[wp]: setupReplyMaster "\<lambda>s. P (ksSchedulerAction s)"
|
|
crunch obj_at'_inQ[wp]: setupReplyMaster "obj_at' (inQ d p) t"
|
|
crunch tcbDomain_inv[wp]: setupReplyMaster "obj_at' (\<lambda>tcb. P (tcbDomain tcb)) t"
|
|
crunch tcbPriority_inv[wp]: setupReplyMaster "obj_at' (\<lambda>tcb. P (tcbPriority tcb)) t"
|
|
crunch ready_queues[wp]: setupReplyMaster "\<lambda>s. P (ksReadyQueues s)"
|
|
crunch ready_queuesL1[wp]: setupReplyMaster "\<lambda>s. P (ksReadyQueuesL1Bitmap s)"
|
|
crunch ready_queuesL2[wp]: setupReplyMaster "\<lambda>s. P (ksReadyQueuesL2Bitmap s)"
|
|
|
|
crunch ksDomScheduleIdx[wp]: setupReplyMaster "\<lambda>s. P (ksDomScheduleIdx s)"
|
|
|
|
lemma setupReplyMaster_invs'[wp]:
|
|
"\<lbrace>invs' and tcb_at' t and ex_nonz_cap_to' t\<rbrace>
|
|
setupReplyMaster t
|
|
\<lbrace>\<lambda>rv. invs'\<rbrace>"
|
|
apply (simp add: invs'_def valid_state'_def)
|
|
apply (rule hoare_pre)
|
|
apply (wp setupReplyMaster_valid_pspace' sch_act_wf_lift tcb_in_cur_domain'_lift ct_idle_or_in_cur_domain'_lift
|
|
valid_queues_lift cur_tcb_lift valid_queues_lift' hoare_vcg_disj_lift
|
|
valid_irq_node_lift | simp)+
|
|
apply (clarsimp simp: ex_nonz_tcb_cte_caps' valid_pspace'_def
|
|
objBits_def objBitsKO_def tcbReplySlot_def
|
|
ex_nonz_cap_not_global' dom_def)
|
|
done
|
|
|
|
lemma setupReplyMaster_cte_wp_at'':
|
|
"\<lbrace>cte_wp_at' (\<lambda>cte. P (cteCap cte)) p and K (\<not> P NullCap)\<rbrace>
|
|
setupReplyMaster t
|
|
\<lbrace>\<lambda>rv s. cte_wp_at' (P \<circ> cteCap) p s\<rbrace>"
|
|
apply (simp add: setupReplyMaster_def locateSlot_conv tree_cte_cteCap_eq)
|
|
apply (wp getCTE_wp')
|
|
apply (fastforce simp: cte_wp_at_ctes_of cteCaps_of_def)
|
|
done
|
|
|
|
lemmas setupReplyMaster_cte_wp_at' = setupReplyMaster_cte_wp_at''[unfolded o_def]
|
|
|
|
lemma setupReplyMaster_cap_to'[wp]:
|
|
"\<lbrace>ex_nonz_cap_to' p\<rbrace> setupReplyMaster t \<lbrace>\<lambda>rv. ex_nonz_cap_to' p\<rbrace>"
|
|
apply (simp add: ex_nonz_cap_to'_def)
|
|
apply (rule hoare_pre)
|
|
apply (wp hoare_vcg_ex_lift setupReplyMaster_cte_wp_at')
|
|
apply clarsimp
|
|
done
|
|
|
|
definition
|
|
is_arch_update' :: "capability \<Rightarrow> cte \<Rightarrow> bool"
|
|
where
|
|
"is_arch_update' cap cte \<equiv> isArchObjectCap cap \<and> capMasterCap cap = capMasterCap (cteCap cte)"
|
|
|
|
lemma mdb_next_pres:
|
|
"\<lbrakk> m p = Some v;
|
|
mdbNext (cteMDBNode x) = mdbNext (cteMDBNode v) \<rbrakk> \<Longrightarrow>
|
|
m(p \<mapsto> x) \<turnstile> a \<leadsto> b = m \<turnstile> a \<leadsto> b"
|
|
by (simp add: mdb_next_unfold)
|
|
|
|
lemma mdb_next_trans_next_pres:
|
|
"\<lbrakk> m p = Some v; mdbNext (cteMDBNode x) = mdbNext (cteMDBNode v) \<rbrakk> \<Longrightarrow>
|
|
m(p \<mapsto> x) \<turnstile> a \<leadsto>\<^sup>+ b = m \<turnstile> a \<leadsto>\<^sup>+ b"
|
|
apply (rule iffI)
|
|
apply (erule trancl_induct)
|
|
apply (fastforce simp: mdb_next_pres)
|
|
apply (erule trancl_trans)
|
|
apply (rule r_into_trancl)
|
|
apply (fastforce simp: mdb_next_pres)
|
|
apply (erule trancl_induct)
|
|
apply (rule r_into_trancl)
|
|
apply (simp add: mdb_next_pres del: fun_upd_apply)
|
|
apply (erule trancl_trans)
|
|
apply (fastforce simp: mdb_next_pres simp del: fun_upd_apply)
|
|
done
|
|
|
|
lemma mdb_next_rtrans_next_pres:
|
|
"\<lbrakk> m p = Some v; mdbNext (cteMDBNode x) = mdbNext (cteMDBNode v) \<rbrakk> \<Longrightarrow>
|
|
m(p \<mapsto> x) \<turnstile> a \<leadsto>\<^sup>* b = m \<turnstile> a \<leadsto>\<^sup>* b"
|
|
by (simp add: rtrancl_eq_or_trancl mdb_next_trans_next_pres)
|
|
|
|
lemma arch_update_descendants':
|
|
"\<lbrakk> is_arch_update' cap oldcte; m p = Some oldcte\<rbrakk> \<Longrightarrow>
|
|
descendants_of' x (m(p \<mapsto> cteCap_update (\<lambda>_. cap) oldcte)) = descendants_of' x m"
|
|
apply (erule same_master_descendants)
|
|
apply (auto simp: is_arch_update'_def isCap_simps)
|
|
done
|
|
|
|
lemma arch_update_setCTE_mdb:
|
|
"\<lbrace>cte_wp_at' (is_arch_update' cap) p and cte_wp_at' (op = oldcte) p and valid_mdb'\<rbrace>
|
|
setCTE p (cteCap_update (\<lambda>_. cap) oldcte)
|
|
\<lbrace>\<lambda>rv. valid_mdb'\<rbrace>"
|
|
apply (simp add: valid_mdb'_def)
|
|
apply wp
|
|
apply (clarsimp simp: valid_mdb_ctes_def cte_wp_at_ctes_of simp del: fun_upd_apply)
|
|
apply (rule conjI)
|
|
apply (rule valid_dlistI)
|
|
apply (fastforce split: split_if_asm elim: valid_dlistE)
|
|
apply (fastforce split: split_if_asm elim: valid_dlistE)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: no_0_def)
|
|
apply (rule conjI)
|
|
apply (simp add: mdb_chain_0_def mdb_next_trans_next_pres)
|
|
apply blast
|
|
apply (rule conjI)
|
|
apply (cases oldcte)
|
|
apply (clarsimp simp: valid_badges_def mdb_next_pres simp del: fun_upd_apply)
|
|
apply (clarsimp simp: is_arch_update'_def)
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (clarsimp simp: isCap_simps)
|
|
prefer 2
|
|
subgoal by fastforce
|
|
apply (erule_tac x=pa in allE)
|
|
apply (erule_tac x=p in allE)
|
|
apply simp
|
|
apply (simp add: sameRegionAs_def3)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: caps_contained'_def simp del: fun_upd_apply)
|
|
apply (cases oldcte)
|
|
apply (clarsimp simp: is_arch_update'_def)
|
|
apply (frule capMaster_untypedRange)
|
|
apply (frule capMaster_capRange)
|
|
apply (drule sym [where s="capMasterCap cap"])
|
|
apply (frule masterCap.intro)
|
|
apply (clarsimp simp: masterCap.isUntypedCap split: split_if_asm)
|
|
subgoal by fastforce
|
|
subgoal by fastforce
|
|
apply (erule_tac x=pa in allE)
|
|
apply (erule_tac x=p in allE)
|
|
apply fastforce
|
|
apply (erule_tac x=pa in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
subgoal by fastforce
|
|
apply (rule conjI)
|
|
apply (cases oldcte)
|
|
apply (clarsimp simp: is_arch_update'_def)
|
|
apply (clarsimp simp: mdb_chunked_def mdb_next_trans_next_pres simp del: fun_upd_apply)
|
|
apply (drule sym [where s="capMasterCap cap"])
|
|
apply (frule masterCap.intro)
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply (clarsimp simp: masterCap.sameRegionAs)
|
|
apply (simp add: masterCap.sameRegionAs is_chunk_def mdb_next_trans_next_pres
|
|
mdb_next_rtrans_next_pres)
|
|
subgoal by fastforce
|
|
apply (erule_tac x=pa in allE)
|
|
apply (erule_tac x=p in allE)
|
|
apply (clarsimp simp: masterCap.sameRegionAs)
|
|
apply (simp add: masterCap.sameRegionAs is_chunk_def mdb_next_trans_next_pres
|
|
mdb_next_rtrans_next_pres)
|
|
subgoal by fastforce
|
|
apply (erule_tac x=pa in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply clarsimp
|
|
apply (simp add: masterCap.sameRegionAs is_chunk_def mdb_next_trans_next_pres
|
|
mdb_next_rtrans_next_pres)
|
|
subgoal by fastforce
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: is_arch_update'_def untyped_mdb'_def arch_update_descendants'
|
|
simp del: fun_upd_apply)
|
|
apply (cases oldcte)
|
|
apply clarsimp
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply (frule capMaster_isUntyped)
|
|
apply (drule capMaster_capRange)
|
|
apply simp
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: untyped_inc'_def arch_update_descendants'
|
|
simp del: fun_upd_apply)
|
|
apply (cases oldcte)
|
|
apply (clarsimp simp: is_arch_update'_def)
|
|
apply (drule capMaster_untypedRange)
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply (erule_tac x=pa in allE)
|
|
apply (erule_tac x=p' in allE)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply (cases oldcte)
|
|
apply (clarsimp simp: valid_nullcaps_def is_arch_update'_def isCap_simps)
|
|
apply (rule conjI)
|
|
apply (cases oldcte)
|
|
apply (clarsimp simp: ut_revocable'_def is_arch_update'_def isCap_simps)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: class_links_def simp del: fun_upd_apply)
|
|
apply (cases oldcte)
|
|
apply (clarsimp simp: is_arch_update'_def mdb_next_pres)
|
|
apply (drule capMaster_capClass)
|
|
apply (clarsimp split: split_if_asm)
|
|
apply fastforce
|
|
apply (rule conjI)
|
|
apply (erule(1) distinct_zombies_sameMasterE)
|
|
apply (clarsimp simp: is_arch_update'_def)
|
|
apply (clarsimp simp: irq_control_def)
|
|
apply (cases oldcte)
|
|
apply (subgoal_tac "cap \<noteq> IRQControlCap")
|
|
prefer 2
|
|
apply (clarsimp simp: is_arch_update'_def isCap_simps)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (simp add: reply_masters_rvk_fb_def)
|
|
apply (erule ball_ran_fun_updI)
|
|
apply (clarsimp simp add: is_arch_update'_def isCap_simps)
|
|
done
|
|
|
|
lemma capMaster_zobj_refs:
|
|
"capMasterCap c = capMasterCap c' \<Longrightarrow> zobj_refs' c = zobj_refs' c'"
|
|
by (simp add: capMasterCap_def split: capability.splits arch_capability.splits)
|
|
|
|
lemma cte_refs_Master:
|
|
"cte_refs' (capMasterCap cap) = cte_refs' cap"
|
|
by (rule ext, simp add: capMasterCap_def split: capability.split)
|
|
|
|
lemma zobj_refs_Master:
|
|
"zobj_refs' (capMasterCap cap) = zobj_refs' cap"
|
|
by (simp add: capMasterCap_def split: capability.split)
|
|
|
|
lemma capMaster_same_refs:
|
|
"capMasterCap a = capMasterCap b \<Longrightarrow> cte_refs' a = cte_refs' b \<and> zobj_refs' a = zobj_refs' b"
|
|
apply (rule conjI)
|
|
apply (rule master_eqI, rule cte_refs_Master, simp)
|
|
apply (rule master_eqI, rule zobj_refs_Master, simp)
|
|
done
|
|
|
|
lemma arch_update_setCTE_iflive:
|
|
"\<lbrace>cte_wp_at' (is_arch_update' cap) p and cte_wp_at' (op = oldcte) p and if_live_then_nonz_cap'\<rbrace>
|
|
setCTE p (cteCap_update (\<lambda>_. cap) oldcte)
|
|
\<lbrace>\<lambda>rv. if_live_then_nonz_cap'\<rbrace>"
|
|
apply (wp setCTE_iflive')
|
|
apply (clarsimp simp: cte_wp_at_ctes_of is_arch_update'_def dest!: capMaster_zobj_refs)
|
|
done
|
|
|
|
lemma arch_update_setCTE_ifunsafe:
|
|
"\<lbrace>cte_wp_at' (is_arch_update' cap) p and cte_wp_at' (op = oldcte) p and if_unsafe_then_cap'\<rbrace>
|
|
setCTE p (cteCap_update (\<lambda>_. cap) oldcte)
|
|
\<lbrace>\<lambda>rv s. if_unsafe_then_cap' s\<rbrace>"
|
|
apply (clarsimp simp: ifunsafe'_def2 cte_wp_at_ctes_of pred_conj_def)
|
|
apply (rule hoare_lift_Pf2 [where f=irq_node'])
|
|
prefer 2
|
|
apply wp
|
|
apply (clarsimp simp: cte_wp_at_ctes_of is_arch_update'_def)
|
|
apply (frule capMaster_same_refs)
|
|
apply clarsimp
|
|
apply (rule conjI, clarsimp)
|
|
apply (erule_tac x=p in allE)
|
|
apply clarsimp
|
|
apply (erule impE)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (rule_tac x=cref' in exI)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (erule_tac x=cref in allE)
|
|
apply clarsimp
|
|
apply (rule_tac x=cref' in exI)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma setCTE_cur_tcb[wp]:
|
|
"\<lbrace>cur_tcb'\<rbrace> setCTE ptr val \<lbrace>\<lambda>rv. cur_tcb'\<rbrace>"
|
|
by (wp cur_tcb_lift)
|
|
|
|
lemma setCTE_vms'[wp]:
|
|
"\<lbrace>valid_machine_state'\<rbrace> setCTE ptr val \<lbrace>\<lambda>rv. valid_machine_state'\<rbrace>"
|
|
apply (simp add: valid_machine_state'_def pointerInUserData_def )
|
|
apply (intro hoare_vcg_all_lift hoare_vcg_disj_lift)
|
|
apply wp
|
|
done
|
|
|
|
lemma arch_update_setCTE_invs:
|
|
"\<lbrace>cte_wp_at' (is_arch_update' cap) p and cte_wp_at' (op = oldcte) p and invs' and valid_cap' cap\<rbrace>
|
|
setCTE p (cteCap_update (\<lambda>_. cap) oldcte)
|
|
\<lbrace>\<lambda>rv. invs'\<rbrace>"
|
|
apply (simp add: invs'_def valid_state'_def valid_pspace'_def)
|
|
apply (rule hoare_pre)
|
|
apply (wp arch_update_setCTE_mdb valid_queues_lift sch_act_wf_lift tcb_in_cur_domain'_lift ct_idle_or_in_cur_domain'_lift
|
|
arch_update_setCTE_iflive arch_update_setCTE_ifunsafe
|
|
valid_irq_node_lift setCTE_typ_at' setCTE_irq_handlers'
|
|
valid_queues_lift' setCTE_pred_tcb_at' irqs_masked_lift
|
|
setCTE_norq hoare_vcg_disj_lift | simp add: pred_tcb_at'_def)+
|
|
apply (clarsimp simp: valid_global_refs'_def is_arch_update'_def cte_wp_at_ctes_of isCap_simps)
|
|
apply (frule capMaster_eq_capBits_eq)
|
|
apply (drule capMaster_capRange)
|
|
apply (clarsimp simp: valid_refs'_def valid_cap_sizes'_def)
|
|
apply fastforce
|
|
done
|
|
|
|
definition
|
|
"safe_parent_for' m p cap \<equiv>
|
|
\<exists>parent node. m p = Some (CTE parent node) \<and>
|
|
sameRegionAs parent cap \<and>
|
|
((\<exists>irq. cap = IRQHandlerCap irq) \<and>
|
|
parent = IRQControlCap \<and>
|
|
(\<forall>p n'. m p \<noteq> Some (CTE cap n'))
|
|
\<or>
|
|
isUntypedCap parent \<and> descendants_of' p m = {} \<and> capRange cap \<noteq> {}
|
|
\<and> capBits cap \<le> capBits parent)"
|
|
|
|
definition
|
|
"is_simple_cap' cap \<equiv>
|
|
cap \<noteq> NullCap \<and>
|
|
cap \<noteq> IRQControlCap \<and>
|
|
\<not> isUntypedCap cap \<and>
|
|
\<not> isReplyCap cap \<and>
|
|
\<not> isEndpointCap cap \<and>
|
|
\<not> isNotificationCap cap \<and>
|
|
\<not> isThreadCap cap \<and>
|
|
\<not> isCNodeCap cap \<and>
|
|
\<not> isZombie cap \<and>
|
|
\<not> isArchPageCap cap"
|
|
|
|
|
|
(* FIXME: duplicated *)
|
|
locale mdb_insert_simple = mdb_insert +
|
|
assumes safe_parent: "safe_parent_for' m src c'"
|
|
assumes simple: "is_simple_cap' c'"
|
|
begin
|
|
|
|
lemma dest_no_parent_n:
|
|
"n \<turnstile> dest \<rightarrow> p = False"
|
|
using src simple safe_parent
|
|
apply clarsimp
|
|
apply (erule subtree.induct)
|
|
prefer 2
|
|
apply simp
|
|
apply (clarsimp simp: parentOf_def mdb_next_unfold n_dest new_dest_def n)
|
|
apply (cases "mdbNext src_node = dest")
|
|
apply (subgoal_tac "m \<turnstile> src \<leadsto> dest")
|
|
apply simp
|
|
apply (subst mdb_next_unfold)
|
|
apply (simp add: src)
|
|
apply (clarsimp simp: isMDBParentOf_CTE)
|
|
apply (clarsimp simp: is_simple_cap'_def revokable'_def)
|
|
apply (cases c', auto simp: isCap_simps)
|
|
apply (clarsimp simp add: sameRegionAs_def2)
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply (clarsimp simp: safe_parent_for'_def isCap_simps)
|
|
done
|
|
|
|
lemma src_node_revokable [simp]:
|
|
"mdbRevocable src_node"
|
|
using safe_parent ut_rev src
|
|
apply (clarsimp simp add: safe_parent_for'_def)
|
|
apply (erule disjE)
|
|
apply clarsimp
|
|
apply (erule irq_revocable, rule irq_control)
|
|
apply (clarsimp simp: ut_revocable'_def)
|
|
done
|
|
|
|
lemma new_child [simp]:
|
|
"isMDBParentOf new_src new_dest"
|
|
using safe_parent ut_rev src
|
|
apply (simp add: new_src_def new_dest_def isMDBParentOf_def)
|
|
apply (clarsimp simp: safe_parent_for'_def)
|
|
apply (auto simp: isCap_simps)
|
|
done
|
|
|
|
lemma n_dest_child:
|
|
"n \<turnstile> src \<rightarrow> dest"
|
|
apply (rule subtree.direct_parent)
|
|
apply (simp add: n_direct_eq)
|
|
apply simp
|
|
apply (clarsimp simp: parentOf_def src dest n)
|
|
done
|
|
|
|
lemma parent_m_n:
|
|
assumes "m \<turnstile> p \<rightarrow> p'"
|
|
shows "if p' = src then n \<turnstile> p \<rightarrow> dest \<and> n \<turnstile> p \<rightarrow> p' else n \<turnstile> p \<rightarrow> p'" using assms
|
|
proof induct
|
|
case (direct_parent c)
|
|
thus ?case
|
|
apply (cases "p = src")
|
|
apply simp
|
|
apply (rule conjI, clarsimp)
|
|
apply clarsimp
|
|
apply (rule subtree.trans_parent [where c'=dest])
|
|
apply (rule n_dest_child)
|
|
apply (simp add: n_direct_eq)
|
|
apply simp
|
|
apply (clarsimp simp: parentOf_def n)
|
|
apply (clarsimp simp: new_src_def src)
|
|
apply simp
|
|
apply (subgoal_tac "n \<turnstile> p \<rightarrow> c")
|
|
prefer 2
|
|
apply (rule subtree.direct_parent)
|
|
apply (clarsimp simp add: n_direct_eq)
|
|
apply simp
|
|
apply (clarsimp simp: parentOf_def n)
|
|
apply (fastforce simp: new_src_def src)
|
|
apply clarsimp
|
|
apply (erule subtree_trans)
|
|
apply (rule n_dest_child)
|
|
done
|
|
next
|
|
case (trans_parent c d)
|
|
thus ?case
|
|
apply -
|
|
apply (cases "c = dest", simp)
|
|
apply (cases "d = dest", simp)
|
|
apply (cases "c = src")
|
|
apply clarsimp
|
|
apply (erule subtree.trans_parent [where c'=dest])
|
|
apply (clarsimp simp add: n_direct_eq)
|
|
apply simp
|
|
apply (clarsimp simp: parentOf_def n)
|
|
apply (rule conjI, clarsimp)
|
|
apply (clarsimp simp: new_src_def src)
|
|
apply clarsimp
|
|
apply (subgoal_tac "n \<turnstile> p \<rightarrow> d")
|
|
apply clarsimp
|
|
apply (erule subtree_trans, rule n_dest_child)
|
|
apply (erule subtree.trans_parent)
|
|
apply (simp add: n_direct_eq)
|
|
apply simp
|
|
apply (clarsimp simp: parentOf_def n)
|
|
apply (fastforce simp: src new_src_def)
|
|
done
|
|
qed
|
|
|
|
lemma n_to_dest [simp]:
|
|
"n \<turnstile> p \<leadsto> dest = (p = src)"
|
|
by (simp add: n_direct_eq)
|
|
|
|
lemma parent_n_m:
|
|
assumes "n \<turnstile> p \<rightarrow> p'"
|
|
shows "if p' = dest then p \<noteq> src \<longrightarrow> m \<turnstile> p \<rightarrow> src else m \<turnstile> p \<rightarrow> p'"
|
|
proof -
|
|
from assms have [simp]: "p \<noteq> dest" by (clarsimp simp: dest_no_parent_n)
|
|
from assms
|
|
show ?thesis
|
|
proof induct
|
|
case (direct_parent c)
|
|
thus ?case
|
|
apply simp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (rule subtree.direct_parent)
|
|
apply (simp add: n_direct_eq split: split_if_asm)
|
|
apply simp
|
|
apply (clarsimp simp: parentOf_def n src new_src_def split: split_if_asm)
|
|
done
|
|
next
|
|
case (trans_parent c d)
|
|
thus ?case
|
|
apply clarsimp
|
|
apply (rule conjI, clarsimp)
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (simp add: n_direct_eq)
|
|
apply (cases "p=src")
|
|
apply simp
|
|
apply (rule subtree.direct_parent, assumption, assumption)
|
|
apply (clarsimp simp: parentOf_def n src new_src_def split: split_if_asm)
|
|
apply clarsimp
|
|
apply (erule subtree.trans_parent, assumption, assumption)
|
|
apply (clarsimp simp: parentOf_def n src new_src_def split: split_if_asm)
|
|
apply (erule subtree.trans_parent)
|
|
apply (simp add: n_direct_eq split: split_if_asm)
|
|
apply assumption
|
|
apply (clarsimp simp: parentOf_def n src new_src_def split: split_if_asm)
|
|
done
|
|
qed
|
|
qed
|
|
|
|
|
|
lemma descendants:
|
|
"descendants_of' p n =
|
|
(if src \<in> descendants_of' p m \<or> p = src
|
|
then descendants_of' p m \<union> {dest} else descendants_of' p m)"
|
|
apply (rule set_eqI)
|
|
apply (simp add: descendants_of'_def)
|
|
apply (fastforce dest!: parent_n_m dest: parent_m_n simp: n_dest_child split: split_if_asm)
|
|
done
|
|
|
|
end
|
|
|
|
declare split_if [split del]
|
|
|
|
lemma safe_parent_for_maskedAsFull[simp]:
|
|
"safe_parent_for' m p (maskedAsFull src_cap a) = safe_parent_for' m p src_cap"
|
|
apply (clarsimp simp:safe_parent_for'_def)
|
|
apply (rule iffI)
|
|
apply (clarsimp simp:maskedAsFull_def isCap_simps split:if_splits cap.splits
|
|
cong:sameRegionAs_update_untyped')+
|
|
done
|
|
|
|
lemma setUntypedCapAsFull_safe_parent_for':
|
|
"\<lbrace>\<lambda>s. safe_parent_for' (ctes_of s) slot a \<and> cte_wp_at' (op = srcCTE) slot s\<rbrace>
|
|
setUntypedCapAsFull (cteCap srcCTE) c' slot
|
|
\<lbrace>\<lambda>rv s. safe_parent_for' (ctes_of s) slot a\<rbrace>"
|
|
apply (clarsimp simp:safe_parent_for'_def setUntypedCapAsFull_def split:if_splits)
|
|
apply (intro conjI impI)
|
|
apply (wp updateCap_ctes_of_wp)
|
|
apply (subgoal_tac "mdb_inv_preserve (ctes_of s)
|
|
(modify_map (ctes_of s) slot
|
|
(cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. max_free_index (capBlockSize c')) (cteCap srcCTE))))")
|
|
apply (frule mdb_inv_preserve.descendants_of[where p = slot])
|
|
apply (clarsimp simp:isCap_simps modify_map_def cte_wp_at_ctes_of simp del:fun_upd_apply)
|
|
apply (clarsimp cong:sameRegionAs_update_untyped)
|
|
apply (rule mdb_inv_preserve_updateCap)
|
|
apply (simp add:cte_wp_at_ctes_of)
|
|
apply simp
|
|
apply wp
|
|
apply simp
|
|
done
|
|
|
|
lemma maskedAsFull_revokable_safe_parent:
|
|
"\<lbrakk>is_simple_cap' c'; safe_parent_for' m p c'; m p = Some cte;
|
|
cteCap cte = (maskedAsFull src_cap' a)\<rbrakk>
|
|
\<Longrightarrow> revokable' (maskedAsFull src_cap' a) c' = revokable' src_cap' c'"
|
|
apply (clarsimp simp:revokable'_def maskedAsFull_def split:if_splits)
|
|
apply (intro allI impI conjI)
|
|
apply (clarsimp simp:isCap_simps is_simple_cap'_def)+
|
|
done
|
|
|
|
lemma is_simple_cap'_maskedAsFull[simp]:
|
|
"is_simple_cap' (maskedAsFull src_cap' c') = is_simple_cap' src_cap'"
|
|
by (auto simp: is_simple_cap'_def maskedAsFull_def isCap_simps split:if_splits)
|
|
|
|
lemma cins_corres_simple:
|
|
assumes "cap_relation c c'" "src' = cte_map src" "dest' = cte_map dest"
|
|
notes trans_state_update'[symmetric,simp]
|
|
shows "corres dc
|
|
(valid_objs and pspace_distinct and pspace_aligned and
|
|
valid_mdb and valid_list and K (src\<noteq>dest) and
|
|
cte_wp_at (\<lambda>c. c=cap.NullCap) dest and
|
|
K (is_simple_cap c) and
|
|
(\<lambda>s. cte_wp_at (safe_parent_for (cdt s) src c) src s))
|
|
(pspace_distinct' and pspace_aligned' and valid_mdb' and valid_cap' c' and
|
|
K (is_simple_cap' c') and
|
|
cte_wp_at' (\<lambda>c. cteCap c=NullCap) dest' and
|
|
(\<lambda>s. safe_parent_for' (ctes_of s) src' c'))
|
|
(cap_insert c src dest)
|
|
(cteInsert c' src' dest')"
|
|
(is "corres _ (?P and (\<lambda>s. cte_wp_at _ _ s)) (?P' and cte_wp_at' _ _ and _) _ _")
|
|
using assms
|
|
unfolding cap_insert_def cteInsert_def
|
|
apply (fold revokable_def revokable'_fold)
|
|
apply simp
|
|
apply (rule corres_guard_imp)
|
|
apply (rule corres_split [OF _ get_cap_corres])
|
|
apply (rule corres_split [OF _ get_cap_corres])
|
|
apply (rule_tac F="cteCap rv' = NullCap" in corres_gen_asm2)
|
|
apply simp
|
|
apply (rule_tac P="?P and cte_at dest and
|
|
(\<lambda>s. cte_wp_at (safe_parent_for (cdt s) src c) src s) and
|
|
cte_wp_at (op = src_cap) src" and
|
|
Q="?P' and
|
|
cte_wp_at' (op = rv') (cte_map dest) and
|
|
cte_wp_at' (op = srcCTE) (cte_map src) and
|
|
(\<lambda>s. safe_parent_for' (ctes_of s) src' c')"
|
|
in corres_assert_assume)
|
|
prefer 2
|
|
apply (clarsimp simp: cte_wp_at_ctes_of valid_mdb'_def valid_mdb_ctes_def valid_nullcaps_def)
|
|
apply (case_tac rv')
|
|
apply (simp add: initMDBNode_def)
|
|
apply (erule allE)+
|
|
apply (erule (1) impE)
|
|
apply (simp add: nullPointer_def)
|
|
apply (rule corres_guard_imp)
|
|
apply (rule_tac R="\<lambda>r. ?P and cte_at dest and
|
|
(\<lambda>s. cte_wp_at (safe_parent_for (cdt s) src c) src s) and
|
|
cte_wp_at (op = (masked_as_full src_cap c)) src" and
|
|
R'="\<lambda>r. ?P' and cte_wp_at' (op = rv') (cte_map dest)
|
|
and cte_wp_at' (op = (CTE (maskedAsFull (cteCap srcCTE) c') (cteMDBNode srcCTE))) (cte_map src)
|
|
and (\<lambda>s. safe_parent_for' (ctes_of s) src' c')"
|
|
in corres_split[where r'=dc])
|
|
apply (rule corres_stronger_no_failI)
|
|
apply (rule no_fail_pre, wp hoare_weak_lift_imp)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of valid_mdb'_def valid_mdb_ctes_def)
|
|
apply (erule_tac valid_dlistEn[where p = "cte_map src"])
|
|
apply (simp+)[3]
|
|
apply (clarsimp simp: corres_underlying_def state_relation_def
|
|
in_monad valid_mdb'_def valid_mdb_ctes_def)
|
|
apply (drule (1) pspace_relationsD)
|
|
apply (drule (18) set_cap_not_quite_corres)
|
|
apply (rule refl)
|
|
apply (elim conjE exE)
|
|
apply (rule bind_execI, assumption)
|
|
apply (subgoal_tac "mdb_insert_abs (cdt a) src dest")
|
|
prefer 2
|
|
apply (clarsimp simp: cte_wp_at_caps_of_state valid_mdb_def2)
|
|
apply (rule mdb_insert_abs.intro)
|
|
apply clarsimp
|
|
apply (erule (1) mdb_cte_at_Null_None)
|
|
apply (erule (1) mdb_cte_at_Null_descendants)
|
|
apply (subgoal_tac "no_mloop (cdt a)")
|
|
prefer 2
|
|
apply (simp add: valid_mdb_def)
|
|
apply (clarsimp simp: exec_gets update_cdt_def bind_assoc set_cdt_def
|
|
exec_get exec_put set_original_def modify_def
|
|
simp del: fun_upd_apply
|
|
|
|
| (rule bind_execI[where f="cap_insert_ext x y z x' y'" for x y z x' y'], clarsimp simp: mdb_insert_abs.cap_insert_ext_det_def2 update_cdt_list_def set_cdt_list_def put_def simp del: fun_upd_apply) | rule refl)+
|
|
|
|
apply (clarsimp simp: put_def state_relation_def simp del: fun_upd_apply)
|
|
apply (drule updateCap_stuff)
|
|
apply clarsimp
|
|
apply (drule (3) updateMDB_the_lot', simp, simp, elim conjE)
|
|
apply (drule (3) updateMDB_the_lot', simp, simp, elim conjE)
|
|
apply (drule (3) updateMDB_the_lot', simp, simp, elim conjE)
|
|
apply (clarsimp simp: pspace_relations_def)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of nullPointer_def prev_update_modify_mdb_relation)
|
|
apply (subgoal_tac "cte_map dest \<noteq> 0")
|
|
prefer 2
|
|
apply (clarsimp simp: valid_mdb'_def
|
|
valid_mdb_ctes_def no_0_def)
|
|
apply (subgoal_tac "cte_map src \<noteq> 0")
|
|
prefer 2
|
|
apply (clarsimp simp: valid_mdb'_def
|
|
valid_mdb_ctes_def no_0_def)
|
|
apply (thin_tac "ksMachineState t = p" for t p)+
|
|
apply (thin_tac "ksCurThread t = p" for t p)+
|
|
apply (thin_tac "ksIdleThread t = p" for t p)+
|
|
apply (thin_tac "ksReadyQueues t = p" for t p)+
|
|
apply (thin_tac "ksSchedulerAction t = p" for t p)+
|
|
apply (subgoal_tac "should_be_parent_of src_cap (is_original_cap a src) c (revokable src_cap c) = True")
|
|
prefer 2
|
|
apply (subst should_be_parent_of_masked_as_full[symmetric])
|
|
apply (subst safe_parent_is_parent)
|
|
apply (simp add: cte_wp_at_caps_of_state)
|
|
apply (simp add: cte_wp_at_caps_of_state)
|
|
apply simp
|
|
apply simp
|
|
apply (subst conj_assoc[symmetric])
|
|
apply (rule conjI)
|
|
defer
|
|
apply (thin_tac "ctes_of t = t'" for t t')+
|
|
apply (clarsimp simp: modify_map_apply)
|
|
apply (clarsimp simp: revokable_relation_def simp del: fun_upd_apply)
|
|
apply (simp split: split_if)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (subgoal_tac "mdbRevocable node = revokable' (cteCap srcCTE) c'")
|
|
prefer 2
|
|
apply (case_tac rv')
|
|
apply (clarsimp simp add: const_def modify_map_def split: split_if_asm)
|
|
apply clarsimp
|
|
apply (rule revokable_eq, assumption, assumption)
|
|
apply (subst same_region_as_relation [symmetric])
|
|
prefer 3
|
|
apply (rule safe_parent_same_region)
|
|
apply (simp add: cte_wp_at_caps_of_state safe_parent_for_masked_as_full)
|
|
apply assumption
|
|
apply assumption
|
|
apply (clarsimp simp: cte_wp_at_def is_simple_cap_def)
|
|
apply clarsimp
|
|
apply (case_tac srcCTE)
|
|
apply (case_tac rv')
|
|
apply clarsimp
|
|
apply (subgoal_tac "\<exists>cap' node'. ctes_of b (cte_map (aa,bb)) = Some (CTE cap' node')")
|
|
prefer 2
|
|
subgoal by (clarsimp simp: modify_map_def split: split_if_asm)
|
|
apply clarsimp
|
|
apply (drule set_cap_caps_of_state_monad)+
|
|
apply (subgoal_tac "null_filter (caps_of_state a) (aa,bb) \<noteq> None")
|
|
prefer 2
|
|
subgoal by (clarsimp simp: cte_wp_at_caps_of_state null_filter_def split: if_splits)
|
|
apply clarsimp
|
|
apply (subgoal_tac "cte_at (aa,bb) a")
|
|
prefer 2
|
|
apply (drule null_filter_caps_of_stateD)
|
|
apply (erule cte_wp_at_weakenE, rule TrueI)
|
|
apply (subgoal_tac "mdbRevocable node = mdbRevocable node'")
|
|
apply clarsimp
|
|
apply (subgoal_tac "cte_map (aa,bb) \<noteq> cte_map dest")
|
|
subgoal by (clarsimp simp: modify_map_def split: split_if_asm)
|
|
apply (erule (5) cte_map_inj)
|
|
apply (rule set_untyped_cap_as_full_corres)
|
|
apply simp+
|
|
apply (wp set_untyped_cap_full_valid_objs set_untyped_cap_as_full_valid_mdb set_untyped_cap_as_full_valid_list
|
|
set_untyped_cap_as_full_cte_wp_at setUntypedCapAsFull_valid_cap
|
|
setUntypedCapAsFull_cte_wp_at setUntypedCapAsFull_safe_parent_for' | clarsimp | wps)+
|
|
apply (clarsimp simp:cte_wp_at_caps_of_state )
|
|
apply (case_tac rv',clarsimp simp:cte_wp_at_ctes_of maskedAsFull_def)
|
|
apply (wp getCTE_wp' get_cap_wp)
|
|
apply clarsimp
|
|
subgoal by (fastforce elim: cte_wp_at_weakenE)
|
|
subgoal by (clarsimp simp: cte_wp_at'_def)
|
|
apply (thin_tac "ctes_of s = t" for s t)+
|
|
apply (thin_tac "pspace_relation s t" for s t)+
|
|
apply (thin_tac "machine_state t = s" for t s)+
|
|
apply (case_tac "srcCTE")
|
|
apply (rename_tac src_cap' src_node)
|
|
apply (case_tac "rv'")
|
|
apply (rename_tac dest_node)
|
|
apply (clarsimp simp: in_set_cap_cte_at_swp)
|
|
apply (subgoal_tac "cte_at src a \<and> safe_parent_for (cdt a) src c src_cap")
|
|
prefer 2
|
|
subgoal by (fastforce simp: cte_wp_at_def safe_parent_for_masked_as_full)
|
|
apply (erule conjE)
|
|
|
|
apply (subgoal_tac "mdb_insert (ctes_of b) (cte_map src) (maskedAsFull src_cap' c') src_node
|
|
(cte_map dest) NullCap dest_node")
|
|
prefer 2
|
|
apply (rule mdb_insert.intro)
|
|
apply (rule mdb_ptr.intro)
|
|
apply (rule vmdb.intro, simp add: valid_mdb_ctes_def)
|
|
apply (erule mdb_ptr_axioms.intro)
|
|
apply (rule mdb_ptr.intro)
|
|
apply (rule vmdb.intro, simp add: valid_mdb_ctes_def)
|
|
apply (erule mdb_ptr_axioms.intro)
|
|
apply (rule mdb_insert_axioms.intro)
|
|
apply (rule refl)
|
|
apply assumption
|
|
apply assumption
|
|
apply assumption
|
|
apply assumption
|
|
apply (erule (5) cte_map_inj)
|
|
apply (rule conjI)
|
|
apply (simp (no_asm_simp) add: cdt_relation_def split: split_if)
|
|
apply (intro impI allI)
|
|
apply (frule mdb_insert_simple_axioms.intro)
|
|
apply(clarsimp simp:cte_wp_at_ctes_of)
|
|
apply (drule (1) mdb_insert_simple.intro)
|
|
apply (drule_tac src_cap' = src_cap' in maskedAsFull_revokable_safe_parent[symmetric])
|
|
apply simp+
|
|
apply (subst mdb_insert_simple.descendants)
|
|
apply simp
|
|
apply (subst mdb_insert_abs.descendants_child, assumption)
|
|
apply (frule set_cap_caps_of_state_monad)
|
|
apply (subgoal_tac "cte_at (aa,bb) a")
|
|
prefer 2
|
|
apply (clarsimp simp: cte_wp_at_caps_of_state split: split_if_asm)
|
|
apply (simp add: descendants_of_eq' cdt_relation_def split: split_if del: split_paired_All)
|
|
apply clarsimp
|
|
apply (drule (5) cte_map_inj)+
|
|
apply simp
|
|
(* exact reproduction of proof in cins_corres,
|
|
as it does not used is_derived *)
|
|
apply(simp add: cdt_list_relation_def del: split_paired_All split_paired_Ex)
|
|
apply(subgoal_tac "no_mloop (cdt a) \<and> finite_depth (cdt a)")
|
|
prefer 2
|
|
apply(simp add: finite_depth valid_mdb_def)
|
|
apply(intro impI allI)
|
|
apply(simp add: fun_upd_twist)
|
|
|
|
apply(subst next_slot_eq[OF mdb_insert_abs.next_slot])
|
|
apply(simp_all del: fun_upd_apply)
|
|
apply(simp split: option.splits del: fun_upd_apply add: fun_upd_twist)
|
|
apply(intro allI impI)
|
|
apply(subgoal_tac "src \<noteq> (aa, bb)")
|
|
prefer 2
|
|
apply(rule notI)
|
|
apply(simp add: valid_mdb_def no_mloop_weaken)
|
|
apply(subst fun_upd_twist, simp, simp)
|
|
|
|
apply(case_tac "ca=src")
|
|
apply(simp)
|
|
apply(clarsimp simp: modify_map_def)
|
|
subgoal by(fastforce split: split_if_asm)
|
|
apply(case_tac "ca = dest")
|
|
apply(simp)
|
|
apply(case_tac "next_slot src (cdt_list (a)) (cdt a)")
|
|
apply(simp)
|
|
apply(simp)
|
|
apply(clarsimp simp: modify_map_def const_def)
|
|
apply(simp split: split_if_asm)
|
|
apply(drule_tac p="cte_map src" in valid_mdbD1')
|
|
apply(simp)
|
|
apply(simp add: valid_mdb'_def valid_mdb_ctes_def)
|
|
apply(clarsimp)
|
|
apply(drule cte_map_inj_eq)
|
|
apply(simp_all)[6]
|
|
apply(erule_tac x="fst src" in allE)
|
|
apply(erule_tac x="snd src" in allE)
|
|
apply(fastforce)
|
|
apply(simp)
|
|
apply(case_tac "next_slot ca (cdt_list (a)) (cdt a)")
|
|
apply(simp)
|
|
apply(simp)
|
|
apply(subgoal_tac "cte_at ca a")
|
|
prefer 2
|
|
apply(rule cte_at_next_slot)
|
|
apply(simp_all)[5]
|
|
apply(clarsimp simp: modify_map_def const_def)
|
|
apply(simp split: split_if_asm)
|
|
apply(drule cte_map_inj_eq)
|
|
apply(simp_all)[6]
|
|
apply(drule_tac p="cte_map src" in valid_mdbD1')
|
|
apply(simp)
|
|
apply(simp add: valid_mdb'_def valid_mdb_ctes_def)
|
|
apply(clarsimp)
|
|
apply(clarsimp)
|
|
apply(case_tac z)
|
|
apply(erule_tac x=aa in allE)
|
|
apply(erule_tac x=bb in allE)
|
|
apply(fastforce)
|
|
apply(drule cte_map_inj_eq)
|
|
apply(simp_all)[6]
|
|
apply(drule cte_map_inj_eq)
|
|
apply(simp_all)[6]
|
|
apply(drule cte_map_inj_eq)
|
|
apply(simp_all)[6]
|
|
by(fastforce)
|
|
|
|
declare split_if [split]
|
|
|
|
lemma sameRegion_capRange_sub:
|
|
"sameRegionAs cap cap' \<Longrightarrow> capRange cap' \<subseteq> capRange cap"
|
|
apply (clarsimp simp: sameRegionAs_def2 isCap_Master capRange_Master)
|
|
apply (erule disjE)
|
|
apply (clarsimp dest!: capMaster_capRange)
|
|
apply (erule disjE)
|
|
apply fastforce
|
|
apply (clarsimp simp: isCap_simps capRange_def)
|
|
done
|
|
|
|
lemma safe_parent_for_capRange_capBits:
|
|
"\<lbrakk> safe_parent_for' m p cap; m p = Some cte \<rbrakk> \<Longrightarrow> capRange cap \<subseteq> capRange (cteCap cte)
|
|
\<and> capBits cap \<le> capBits (cteCap cte)"
|
|
apply (clarsimp simp: safe_parent_for'_def)
|
|
apply (erule disjE)
|
|
apply (clarsimp simp: capRange_def)
|
|
by (auto simp: sameRegionAs_def2 isCap_simps capRange_def
|
|
capMasterCap_def capRange_Master objBits_simps
|
|
split:capability.splits arch_capability.splits)
|
|
|
|
lemma safe_parent_Null:
|
|
"\<lbrakk> m src = Some (CTE NullCap n); safe_parent_for' m src c' \<rbrakk> \<Longrightarrow> False"
|
|
by (simp add: safe_parent_for'_def)
|
|
|
|
lemma notUntypedRange:
|
|
"\<not>isUntypedCap cap \<Longrightarrow> untypedRange cap = {}"
|
|
by (cases cap) (auto simp: isCap_simps)
|
|
|
|
lemma safe_parent_for_untypedRange:
|
|
"\<lbrakk> safe_parent_for' m p cap; m p = Some cte \<rbrakk> \<Longrightarrow> untypedRange cap \<subseteq> untypedRange (cteCap cte)"
|
|
apply (clarsimp simp: safe_parent_for'_def)
|
|
apply (erule disjE)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (simp add: sameRegionAs_def2)
|
|
apply (erule disjE)
|
|
apply clarsimp
|
|
apply (drule capMaster_untypedRange)
|
|
apply blast
|
|
apply (erule disjE)
|
|
apply (clarsimp simp: capRange_Master untypedCapRange)
|
|
apply (cases "isUntypedCap cap")
|
|
apply (clarsimp simp: capRange_Master untypedCapRange)
|
|
apply blast
|
|
apply (drule notUntypedRange)
|
|
apply simp
|
|
apply (clarsimp simp: isCap_Master isCap_simps)
|
|
done
|
|
|
|
lemma safe_parent_for_capUntypedRange:
|
|
"\<lbrakk> safe_parent_for' m p cap; m p = Some cte \<rbrakk> \<Longrightarrow> capRange cap \<subseteq> untypedRange (cteCap cte)"
|
|
apply (clarsimp simp: safe_parent_for'_def)
|
|
apply (erule disjE)
|
|
apply (clarsimp simp: capRange_def)
|
|
apply clarsimp
|
|
apply (simp add: sameRegionAs_def2)
|
|
apply (erule disjE)
|
|
apply clarsimp
|
|
apply (frule capMaster_capRange)
|
|
apply (clarsimp simp: capRange_Master untypedCapRange)
|
|
apply (erule disjE)
|
|
apply (clarsimp simp: capRange_Master untypedCapRange)
|
|
apply blast
|
|
apply (clarsimp simp: isCap_Master isCap_simps)
|
|
done
|
|
|
|
lemma safe_parent_for_descendants':
|
|
"\<lbrakk> safe_parent_for' m p cap; m p = Some (CTE pcap n); isUntypedCap pcap \<rbrakk> \<Longrightarrow> descendants_of' p m = {}"
|
|
by (auto simp: safe_parent_for'_def isCap_simps)
|
|
|
|
lemma safe_parent_not_ep':
|
|
"\<lbrakk> safe_parent_for' m p cap; m p = Some (CTE src_cap n) \<rbrakk> \<Longrightarrow> \<not>isEndpointCap src_cap"
|
|
by (auto simp: safe_parent_for'_def isCap_simps)
|
|
|
|
lemma safe_parent_not_ntfn':
|
|
"\<lbrakk> safe_parent_for' m p cap; m p = Some (CTE src_cap n) \<rbrakk> \<Longrightarrow> \<not>isNotificationCap src_cap"
|
|
by (auto simp: safe_parent_for'_def isCap_simps)
|
|
|
|
lemma safe_parent_capClass:
|
|
"\<lbrakk> safe_parent_for' m p cap; m p = Some (CTE src_cap n) \<rbrakk> \<Longrightarrow> capClass cap = capClass src_cap"
|
|
by (auto simp: safe_parent_for'_def isCap_simps sameRegionAs_def2 capRange_Master capRange_def
|
|
capMasterCap_def
|
|
split: capability.splits arch_capability.splits)
|
|
|
|
locale mdb_insert_simple' = mdb_insert_simple +
|
|
fixes n'
|
|
defines "n' \<equiv> modify_map n (mdbNext src_node) (cteMDBNode_update (mdbPrev_update (\<lambda>_. dest)))"
|
|
begin
|
|
|
|
lemma no_0_n' [intro!]: "no_0 n'" by (auto simp: n'_def)
|
|
lemmas n_0_simps' [iff] = no_0_simps [OF no_0_n']
|
|
|
|
lemmas no_0_m_prev [iff] = no_0_prev [OF no_0]
|
|
lemmas no_0_n_prev [iff] = no_0_prev [OF no_0_n']
|
|
|
|
lemma chain_n': "mdb_chain_0 n'"
|
|
unfolding n'_def
|
|
by (rule mdb_chain_0_modify_map_prev) (rule chain_n)
|
|
|
|
lemma no_loops_n': "no_loops n'" using chain_n' no_0_n'
|
|
by (rule mdb_chain_0_no_loops)
|
|
|
|
lemma irrefl_direct_simp_n' [iff]:
|
|
"n' \<turnstile> x \<leadsto> x = False"
|
|
using no_loops_n' by (rule no_loops_direct_simp)
|
|
|
|
lemma irrefl_trancl_simp' [iff]:
|
|
"n \<turnstile> x \<leadsto>\<^sup>+ x = False"
|
|
using no_loops_n by (rule no_loops_trancl_simp)
|
|
|
|
lemma n_direct_eq':
|
|
"n' \<turnstile> p \<leadsto> p' = (if p = src then p' = dest else
|
|
if p = dest then m \<turnstile> src \<leadsto> p'
|
|
else m \<turnstile> p \<leadsto> p')"
|
|
by (simp add: n'_def mdb_next_modify n_direct_eq)
|
|
|
|
lemma dest_no_next_p:
|
|
"m p = Some cte \<Longrightarrow> mdbNext (cteMDBNode cte) \<noteq> dest"
|
|
using dest dest_prev
|
|
apply (cases cte)
|
|
apply (rule notI)
|
|
apply (rule dlistEn, assumption)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma dest_no_src_next [iff]:
|
|
"mdbNext src_node \<noteq> dest"
|
|
using src by (clarsimp dest!: dest_no_next_p)
|
|
|
|
lemma n_dest':
|
|
"n' dest = Some new_dest"
|
|
by (simp add: n'_def n modify_map_if new_dest_def)
|
|
|
|
lemma n_src_dest':
|
|
"n' \<turnstile> src \<leadsto> dest"
|
|
by (simp add: n_src_dest n'_def)
|
|
|
|
lemma dest_chain_0' [simp, intro!]:
|
|
"n' \<turnstile> dest \<leadsto>\<^sup>+ 0"
|
|
using chain_n' n_dest'
|
|
by (simp add: mdb_chain_0_def) blast
|
|
|
|
lemma n'_trancl_eq':
|
|
"n' \<turnstile> p \<leadsto>\<^sup>+ p' =
|
|
(if p' = dest then m \<turnstile> p \<leadsto>\<^sup>* src
|
|
else if p = dest then m \<turnstile> src \<leadsto>\<^sup>+ p'
|
|
else m \<turnstile> p \<leadsto>\<^sup>+ p')"
|
|
unfolding n'_def trancl_prev_update
|
|
by (simp add: n_trancl_eq')
|
|
|
|
lemma n'_trancl_eq:
|
|
"n' \<turnstile> p \<leadsto>\<^sup>+ p' =
|
|
(if p' = dest then p = src \<or> m \<turnstile> p \<leadsto>\<^sup>+ src
|
|
else if p = dest then m \<turnstile> src \<leadsto>\<^sup>+ p'
|
|
else m \<turnstile> p \<leadsto>\<^sup>+ p')"
|
|
unfolding n'_def trancl_prev_update
|
|
by (simp add: n_trancl_eq)
|
|
|
|
lemma n_rtrancl_eq':
|
|
"n' \<turnstile> p \<leadsto>\<^sup>* p' =
|
|
(if p' = dest then p = dest \<or> p \<noteq> dest \<and> m \<turnstile> p \<leadsto>\<^sup>* src
|
|
else if p = dest then p' \<noteq> src \<and> m \<turnstile> src \<leadsto>\<^sup>* p'
|
|
else m \<turnstile> p \<leadsto>\<^sup>* p')"
|
|
unfolding n'_def rtrancl_prev_update
|
|
by (simp add: n_rtrancl_eq)
|
|
|
|
lemma n'_cap:
|
|
"n' p = Some (CTE cap node) \<Longrightarrow>
|
|
\<exists>node'. if p = dest then cap = c' \<and> m p = Some (CTE dest_cap node')
|
|
else m p = Some (CTE cap node')"
|
|
by (auto simp add: n'_def n src dest new_src_def new_dest_def modify_map_if split: split_if_asm)
|
|
|
|
lemma n'_rev:
|
|
"n' p = Some (CTE cap node) \<Longrightarrow>
|
|
\<exists>node'. if p = dest then mdbRevocable node = revokable' src_cap c' \<and> m p = Some (CTE dest_cap node')
|
|
else m p = Some (CTE cap node') \<and> mdbRevocable node = mdbRevocable node'"
|
|
by (auto simp add: n'_def n src dest new_src_def new_dest_def modify_map_if split: split_if_asm)
|
|
|
|
lemma m_cap':
|
|
"m p = Some (CTE cap node) \<Longrightarrow>
|
|
\<exists>node'. if p = dest then cap = dest_cap \<and> n' p = Some (CTE c' node')
|
|
else n' p = Some (CTE cap node')"
|
|
apply (simp add: n'_def n new_src_def new_dest_def modify_map_if)
|
|
apply (cases "p=dest")
|
|
apply (auto simp: src dest)
|
|
done
|
|
|
|
lemma dest_no_parent_n' [simp]:
|
|
"n' \<turnstile> dest \<rightarrow> p = False"
|
|
by (simp add: n'_def dest_no_parent_n)
|
|
|
|
lemma descendants':
|
|
"descendants_of' p n' =
|
|
(if src \<in> descendants_of' p m \<or> p = src
|
|
then descendants_of' p m \<union> {dest} else descendants_of' p m)"
|
|
by (simp add: n'_def descendants descendants_of_prev_update)
|
|
|
|
lemma ut_revocable_n' [simp]:
|
|
"ut_revocable' n'"
|
|
using dest
|
|
apply (clarsimp simp: ut_revocable'_def)
|
|
apply (frule n'_cap)
|
|
apply (drule n'_rev)
|
|
apply clarsimp
|
|
apply (clarsimp simp: n_dest' new_dest_def split: split_if_asm)
|
|
apply (clarsimp simp: revokable'_def isCap_simps)
|
|
apply (drule_tac p=p and m=m in ut_revocableD', assumption)
|
|
apply (rule ut_rev)
|
|
apply simp
|
|
done
|
|
|
|
lemma valid_nc' [simp]:
|
|
"valid_nullcaps n'"
|
|
unfolding valid_nullcaps_def
|
|
using src dest dest_prev dest_next simple safe_parent
|
|
apply (clarsimp simp: n'_def n_def modify_map_if)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: is_simple_cap'_def)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply (fastforce dest!: safe_parent_Null)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (drule (1) valid_nullcaps_next, rule no_0, rule dlist, rule nullcaps)
|
|
apply simp
|
|
apply clarsimp
|
|
apply (erule nullcapsD', rule nullcaps)
|
|
done
|
|
|
|
lemma n'_prev_eq:
|
|
"n' \<turnstile> p \<leftarrow> p' =
|
|
(if p' = mdbNext src_node \<and> p' \<noteq> 0 then p = dest
|
|
else if p' = dest then p = src
|
|
else m \<turnstile> p \<leftarrow> p')"
|
|
using src dest dest_prev dest_next
|
|
apply (cases "p' = 0", simp)
|
|
apply (simp split del: split_if)
|
|
apply (cases "p' = mdbNext src_node")
|
|
apply (clarsimp simp: modify_map_apply n'_def n_def mdb_prev_def)
|
|
apply (clarsimp simp: modify_map_if)
|
|
apply (rule iffI, clarsimp)
|
|
apply clarsimp
|
|
apply (rule dlistEn, assumption, simp)
|
|
apply clarsimp
|
|
apply (case_tac cte')
|
|
apply clarsimp
|
|
apply (cases "p' = dest")
|
|
apply (clarsimp simp: modify_map_if n'_def n_def mdb_prev_def)
|
|
apply clarsimp
|
|
apply (clarsimp simp: modify_map_if n'_def n_def mdb_prev_def)
|
|
apply (cases "p' = src", simp)
|
|
apply clarsimp
|
|
apply (rule iffI, clarsimp)
|
|
apply clarsimp
|
|
apply (case_tac z)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma m_prev_of_next:
|
|
"m \<turnstile> p \<leftarrow> mdbNext src_node = (p = src \<and> mdbNext src_node \<noteq> 0)"
|
|
using src
|
|
apply (clarsimp simp: mdb_prev_def)
|
|
apply (rule iffI)
|
|
apply clarsimp
|
|
apply (rule dlistEn, assumption, clarsimp)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (rule dlistEn, assumption, clarsimp)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma src_next_eq:
|
|
"m \<turnstile> p \<leadsto> mdbNext src_node = (if mdbNext src_node \<noteq> 0 then p = src else m \<turnstile> p \<leadsto> 0)"
|
|
using src
|
|
apply -
|
|
apply (rule iffI)
|
|
prefer 2
|
|
apply (clarsimp split: split_if_asm)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (frule (1) dlist_nextD0)
|
|
apply (clarsimp simp: m_prev_of_next)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma src_next_eq':
|
|
"m (mdbNext src_node) = Some cte \<Longrightarrow> m \<turnstile> p \<leadsto> mdbNext src_node = (p = src)"
|
|
by (subst src_next_eq) auto
|
|
|
|
lemma dest_no_prev [iff]:
|
|
"\<not> m \<turnstile> dest \<leftarrow> p"
|
|
using dest dest_next
|
|
apply (clarsimp simp: mdb_prev_def)
|
|
apply (rule dlistEp [where p=p], assumption, clarsimp)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma src_prev [iff]:
|
|
"m \<turnstile> src \<leftarrow> p = (p = mdbNext src_node \<and> p \<noteq> 0)"
|
|
using src
|
|
apply -
|
|
apply (rule iffI)
|
|
prefer 2
|
|
apply (clarsimp simp: mdb_ptr_src.next_p_prev)
|
|
apply (clarsimp simp: mdb_prev_def)
|
|
apply (rule conjI)
|
|
prefer 2
|
|
apply clarsimp
|
|
apply (rule dlistEp [where p=p], assumption, clarsimp)
|
|
apply simp
|
|
done
|
|
|
|
lemma blurg: "(\<forall>c c'. Q c \<longrightarrow> P c') = (\<forall>c. Q c \<longrightarrow> (\<forall>c'. P c'))"
|
|
apply simp
|
|
done
|
|
|
|
lemma dlist' [simp]:
|
|
"valid_dlist n'"
|
|
using src dest
|
|
apply (unfold valid_dlist_def3 n_direct_eq' n'_prev_eq)
|
|
apply (split split_if)
|
|
apply (split split_if)
|
|
apply (split split_if)
|
|
apply (split split_if)
|
|
apply (split split_if)
|
|
apply (split split_if)
|
|
apply (split split_if)
|
|
apply simp
|
|
apply (intro conjI impI allI notI)
|
|
apply (fastforce simp: src_next_eq')
|
|
apply (clarsimp simp: src_next_eq split: split_if_asm)
|
|
apply (simp add: mdb_ptr_src.p_next)
|
|
apply (erule (1) dlist_nextD0)
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (erule (1) dlist_prevD0)
|
|
done
|
|
|
|
lemma utRange_c':
|
|
"untypedRange c' \<subseteq> untypedRange src_cap"
|
|
using safe_parent src
|
|
by - (drule (1) safe_parent_for_untypedRange, simp)
|
|
|
|
lemma capRange_c':
|
|
"capRange c' \<subseteq> capRange src_cap"
|
|
using safe_parent src
|
|
by - (drule (1) safe_parent_for_capRange_capBits, simp)
|
|
|
|
lemma not_ut_c' [simp]:
|
|
"\<not>isUntypedCap c'"
|
|
using simple
|
|
by (simp add: is_simple_cap'_def)
|
|
|
|
lemma utCapRange_c':
|
|
"capRange c' \<subseteq> untypedRange src_cap"
|
|
using safe_parent src
|
|
by - (drule (1) safe_parent_for_capUntypedRange, simp)
|
|
|
|
lemma ut_descendants:
|
|
"isUntypedCap src_cap \<Longrightarrow> descendants_of' src m = {}"
|
|
using safe_parent src
|
|
by (rule safe_parent_for_descendants')
|
|
|
|
lemma ut_mdb' [simp]:
|
|
"untyped_mdb' n'"
|
|
using src dest utRange_c' capRange_c' utCapRange_c'
|
|
apply (clarsimp simp: untyped_mdb'_def)
|
|
apply (drule n'_cap)+
|
|
apply (clarsimp simp: descendants')
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (cases "isUntypedCap src_cap")
|
|
prefer 2
|
|
apply (drule_tac p=p and p'=src and m=m in untyped_mdbD', assumption+)
|
|
apply blast
|
|
apply (rule untyped_mdb)
|
|
apply simp
|
|
apply (frule ut_descendants)
|
|
apply (drule (3) untyped_incD', rule untyped_inc)
|
|
apply clarsimp
|
|
apply blast
|
|
apply (fastforce elim: untyped_mdbD' intro!: untyped_mdb)
|
|
done
|
|
|
|
lemma n'_badge:
|
|
"n' p = Some (CTE cap node) \<Longrightarrow>
|
|
\<exists>node'. if p = dest then mdbFirstBadged node = revokable' src_cap c' \<and> m p = Some (CTE dest_cap node')
|
|
else m p = Some (CTE cap node') \<and> mdbFirstBadged node = mdbFirstBadged node'"
|
|
by (auto simp add: n'_def n src dest new_src_def new_dest_def modify_map_if split: split_if_asm)
|
|
|
|
lemma src_not_ep [simp]:
|
|
"\<not>isEndpointCap src_cap"
|
|
using safe_parent src by (rule safe_parent_not_ep')
|
|
|
|
lemma src_not_ntfn [simp]:
|
|
"\<not>isNotificationCap src_cap"
|
|
using safe_parent src by (rule safe_parent_not_ntfn')
|
|
|
|
lemma c_not_ep [simp]:
|
|
"\<not>isEndpointCap c'"
|
|
using simple by (simp add: is_simple_cap'_def)
|
|
|
|
lemma c_not_ntfn [simp]:
|
|
"\<not>isNotificationCap c'"
|
|
using simple by (simp add: is_simple_cap'_def)
|
|
|
|
lemma valid_badges' [simp]:
|
|
"valid_badges n'"
|
|
using simple src dest
|
|
apply (clarsimp simp: valid_badges_def)
|
|
apply (simp add: n_direct_eq')
|
|
apply (frule_tac p=p in n'_badge)
|
|
apply (frule_tac p=p' in n'_badge)
|
|
apply (drule n'_cap)+
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (insert valid_badges)
|
|
apply (simp add: valid_badges_def)
|
|
apply blast
|
|
done
|
|
|
|
lemma caps_contained' [simp]:
|
|
"caps_contained' n'"
|
|
using src dest capRange_c' utCapRange_c'
|
|
apply (clarsimp simp: caps_contained'_def)
|
|
apply (drule n'_cap)+
|
|
apply clarsimp
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (drule capRange_untyped)
|
|
apply simp
|
|
apply (drule capRange_untyped)
|
|
apply clarsimp
|
|
apply (cases "isUntypedCap src_cap")
|
|
prefer 2
|
|
apply (drule_tac p=p and p'=src in caps_containedD', assumption+)
|
|
apply blast
|
|
apply (rule caps_contained)
|
|
apply blast
|
|
apply (frule capRange_untyped)
|
|
apply (drule (3) untyped_incD', rule untyped_inc)
|
|
apply (clarsimp simp: ut_descendants)
|
|
apply blast
|
|
apply (drule (3) caps_containedD', rule caps_contained)
|
|
apply blast
|
|
done
|
|
|
|
lemma capClass_c' [simp]:
|
|
"capClass c' = capClass src_cap"
|
|
using safe_parent src by (rule safe_parent_capClass)
|
|
|
|
lemma class_links' [simp]:
|
|
"class_links n'"
|
|
using src dest
|
|
apply (clarsimp simp: class_links_def)
|
|
apply (simp add: n_direct_eq')
|
|
apply (case_tac cte, case_tac cte')
|
|
apply clarsimp
|
|
apply (drule n'_cap)+
|
|
apply clarsimp
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (drule (2) class_linksD, rule class_links)
|
|
apply simp
|
|
apply (drule (2) class_linksD, rule class_links)
|
|
apply simp
|
|
done
|
|
|
|
lemma untyped_inc' [simp]:
|
|
"untyped_inc' n'"
|
|
using src dest
|
|
apply (clarsimp simp: untyped_inc'_def)
|
|
apply (drule n'_cap)+
|
|
apply (clarsimp simp: descendants')
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (drule (3) untyped_incD', rule untyped_inc)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (frule_tac p=src and p'=p' in untyped_incD', assumption+, rule untyped_inc)
|
|
apply (clarsimp simp: ut_descendants)
|
|
apply (intro conjI, clarsimp+)
|
|
apply (drule (3) untyped_incD', rule untyped_inc)
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma sameRegion_src [simp]:
|
|
"sameRegionAs src_cap c'"
|
|
using safe_parent src
|
|
apply (simp add: safe_parent_for'_def)
|
|
done
|
|
|
|
lemma sameRegion_src_c':
|
|
"sameRegionAs cap src_cap \<Longrightarrow> sameRegionAs cap c'"
|
|
using safe_parent simple src capRange_c'
|
|
apply (simp add: safe_parent_for'_def)
|
|
apply (erule disjE)
|
|
apply (clarsimp simp: sameRegionAs_def2 isCap_simps capRange_def)
|
|
apply clarsimp
|
|
apply (simp add: sameRegionAs_def2 isCap_Master capRange_Master)
|
|
apply (erule disjE)
|
|
prefer 2
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply (elim conjE)
|
|
apply (erule disjE)
|
|
prefer 2
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply simp
|
|
apply blast
|
|
done
|
|
|
|
lemma sameRegion_c_src':
|
|
"sameRegionAs c' cap \<Longrightarrow> sameRegionAs src_cap cap"
|
|
using safe_parent simple src capRange_c'
|
|
apply (simp add: safe_parent_for'_def)
|
|
apply (erule disjE)
|
|
apply clarsimp
|
|
apply (clarsimp simp: sameRegionAs_def2 capRange_def isCap_simps)
|
|
apply clarsimp
|
|
apply (simp add: sameRegionAs_def2 isCap_Master capRange_Master)
|
|
apply (erule disjE)
|
|
prefer 2
|
|
apply clarsimp
|
|
apply (erule disjE, blast)
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply (clarsimp simp: capRange_def)
|
|
apply (elim conjE)
|
|
apply (drule capMaster_capRange)
|
|
apply simp
|
|
done
|
|
|
|
lemma safe_not_next_region:
|
|
"\<lbrakk> m \<turnstile> src \<leadsto> p; m p = Some (CTE cap node) \<rbrakk> \<Longrightarrow> \<not> sameRegionAs c' cap"
|
|
using safe_parent src
|
|
unfolding safe_parent_for'_def
|
|
apply clarsimp
|
|
apply (erule disjE)
|
|
apply (clarsimp simp: mdb_next_unfold)
|
|
apply (clarsimp simp: sameRegionAs_def2 isCap_simps)
|
|
apply (clarsimp simp: descendants_of'_def)
|
|
apply (erule_tac x=p in allE)
|
|
apply (erule notE, rule direct_parent, assumption)
|
|
apply clarsimp
|
|
apply (simp add: parentOf_def)
|
|
apply (simp add: isMDBParentOf_def)
|
|
apply (erule sameRegionAs_trans [rotated])
|
|
apply (rule sameRegion_src)
|
|
done
|
|
|
|
lemma irq_c'_new:
|
|
assumes irq_src: "isIRQControlCap src_cap"
|
|
shows "m p = Some (CTE cap node) \<Longrightarrow> \<not> sameRegionAs c' cap"
|
|
using safe_parent irq_src src
|
|
apply (clarsimp simp: safe_parent_for'_def isCap_simps)
|
|
apply (clarsimp simp: sameRegionAs_def2 isCap_simps)
|
|
done
|
|
|
|
lemma ut_capRange_non_empty:
|
|
"isUntypedCap src_cap \<Longrightarrow> capRange c' \<noteq> {}"
|
|
using safe_parent src unfolding safe_parent_for'_def
|
|
by (clarsimp simp: isCap_simps)
|
|
|
|
lemma ut_sameRegion_non_empty:
|
|
"\<lbrakk> isUntypedCap src_cap; sameRegionAs c' cap \<rbrakk> \<Longrightarrow> capRange cap \<noteq> {}"
|
|
using simple safe_parent src
|
|
apply (clarsimp simp: is_simple_cap'_def sameRegionAs_def2 isCap_Master)
|
|
apply (erule disjE)
|
|
apply (clarsimp simp: ut_capRange_non_empty dest!: capMaster_capRange)
|
|
apply clarsimp
|
|
apply (clarsimp simp: safe_parent_for'_def)
|
|
apply (erule disjE, clarsimp simp: isCap_simps)
|
|
apply (clarsimp simp: isCap_simps capRange_def)
|
|
done
|
|
|
|
lemma ut_c'_new:
|
|
assumes ut_src: "isUntypedCap src_cap"
|
|
shows "m p = Some (CTE cap node) \<Longrightarrow> \<not> sameRegionAs c' cap"
|
|
using src simple
|
|
apply clarsimp
|
|
apply (drule untyped_mdbD', rule ut_src, assumption)
|
|
apply (clarsimp simp: is_simple_cap'_def sameRegionAs_def2 isCap_Master capRange_Master)
|
|
apply (fastforce simp: isCap_simps)
|
|
apply (frule sameRegion_capRange_sub)
|
|
apply (drule ut_sameRegion_non_empty [OF ut_src])
|
|
apply (insert utCapRange_c')
|
|
apply blast
|
|
apply (rule untyped_mdb)
|
|
apply (simp add: ut_descendants [OF ut_src])
|
|
done
|
|
|
|
lemma c'_new:
|
|
"m p = Some (CTE cap node) \<Longrightarrow> \<not> sameRegionAs c' cap"
|
|
using safe_parent src unfolding safe_parent_for'_def
|
|
apply (elim exE conjE)
|
|
apply (erule disjE)
|
|
apply (erule irq_c'_new [rotated])
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply clarsimp
|
|
apply (drule (1) ut_c'_new)
|
|
apply simp
|
|
done
|
|
|
|
lemma irq_control_src:
|
|
"\<lbrakk> isIRQControlCap src_cap;
|
|
m p = Some (CTE cap node);
|
|
sameRegionAs cap c' \<rbrakk> \<Longrightarrow> p = src"
|
|
using safe_parent src unfolding safe_parent_for'_def
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply (clarsimp simp: sameRegionAs_def2 isCap_Master)
|
|
apply (erule disjE, clarsimp simp: isCap_simps)
|
|
apply (erule disjE, clarsimp simp: isCap_simps)
|
|
apply (erule disjE, clarsimp simp: isCap_simps capRange_def)
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply (drule (1) irq_controlD, rule irq_control)
|
|
apply simp
|
|
done
|
|
|
|
lemma not_irq_parentD:
|
|
"\<not> isIRQControlCap src_cap \<Longrightarrow>
|
|
isUntypedCap src_cap \<and> descendants_of' src m = {} \<and> capRange c' \<noteq> {}"
|
|
using src safe_parent unfolding safe_parent_for'_def
|
|
by (clarsimp simp: isCap_simps)
|
|
|
|
lemma ut_src_only_ut_c_parents:
|
|
"\<lbrakk> isUntypedCap src_cap; sameRegionAs cap c'; m p = Some (CTE cap node) \<rbrakk> \<Longrightarrow> isUntypedCap cap"
|
|
using safe_parent src unfolding safe_parent_for'_def
|
|
apply clarsimp
|
|
apply (erule disjE, clarsimp simp: isCap_simps)
|
|
apply clarsimp
|
|
apply (rule ccontr)
|
|
apply (drule (3) untyped_mdbD')
|
|
apply (frule sameRegion_capRange_sub)
|
|
apply (insert utCapRange_c')[1]
|
|
apply blast
|
|
apply (rule untyped_mdb)
|
|
apply simp
|
|
done
|
|
|
|
lemma ut_src:
|
|
"\<lbrakk> isUntypedCap src_cap; sameRegionAs cap c'; m p = Some (CTE cap node) \<rbrakk> \<Longrightarrow>
|
|
isUntypedCap cap \<and> untypedRange cap \<inter> untypedRange src_cap \<noteq> {}"
|
|
apply (frule (2) ut_src_only_ut_c_parents)
|
|
apply simp
|
|
apply (frule sameRegion_capRange_sub)
|
|
apply (insert utCapRange_c')[1]
|
|
apply (simp add: untypedCapRange)
|
|
apply (drule ut_capRange_non_empty)
|
|
apply blast
|
|
done
|
|
|
|
|
|
lemma chunked' [simp]:
|
|
"mdb_chunked n'"
|
|
using src dest
|
|
apply (clarsimp simp: mdb_chunked_def)
|
|
apply (drule n'_cap)+
|
|
apply (clarsimp simp: n'_trancl_eq)
|
|
apply (clarsimp split: split_if_asm)
|
|
prefer 3
|
|
apply (frule (3) mdb_chunkedD, rule chunked)
|
|
apply clarsimp
|
|
apply (rule conjI, clarsimp)
|
|
apply (clarsimp simp: is_chunk_def n'_trancl_eq n_rtrancl_eq' n_dest' new_dest_def)
|
|
apply (rule conjI, clarsimp)
|
|
apply (rule conjI, clarsimp)
|
|
apply clarsimp
|
|
apply (erule_tac x=src in allE)
|
|
apply simp
|
|
apply (erule sameRegion_src_c')
|
|
apply clarsimp
|
|
apply (erule_tac x=p'' in allE)
|
|
apply clarsimp
|
|
apply (frule_tac p=p'' in m_cap')
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (clarsimp simp: is_chunk_def n'_trancl_eq n_rtrancl_eq' n_dest' new_dest_def)
|
|
apply (rule conjI, clarsimp)
|
|
apply (rule conjI, clarsimp)
|
|
apply clarsimp
|
|
apply (erule_tac x=src in allE)
|
|
apply simp
|
|
apply (erule sameRegion_src_c')
|
|
apply clarsimp
|
|
apply (erule_tac x=p'' in allE)
|
|
apply clarsimp
|
|
apply (frule_tac p=p'' in m_cap')
|
|
apply clarsimp
|
|
apply (case_tac "p' = src")
|
|
apply simp
|
|
apply (clarsimp simp: is_chunk_def)
|
|
apply (simp add: n'_trancl_eq n_rtrancl_eq')
|
|
apply (erule disjE)
|
|
apply (simp add: n_dest' new_dest_def)
|
|
apply clarsimp
|
|
apply (drule (1) trancl_rtrancl_trancl)
|
|
apply simp
|
|
apply clarsimp
|
|
apply (drule c'_new)
|
|
apply (erule (1) notE)
|
|
apply (case_tac "p=src")
|
|
apply clarsimp
|
|
apply (clarsimp simp: is_chunk_def)
|
|
apply (simp add: n'_trancl_eq n_rtrancl_eq')
|
|
apply (erule disjE)
|
|
apply (clarsimp simp: n_dest' new_dest_def)
|
|
apply clarsimp
|
|
apply (drule (1) trancl_rtrancl_trancl)
|
|
apply simp
|
|
apply (case_tac "isIRQControlCap src_cap")
|
|
apply (drule (2) irq_control_src)
|
|
apply simp
|
|
apply (drule not_irq_parentD)
|
|
apply clarsimp
|
|
apply (frule (2) ut_src)
|
|
apply clarsimp
|
|
apply (subgoal_tac "src \<in> descendants_of' p m")
|
|
prefer 2
|
|
apply (drule (3) untyped_incD', rule untyped_inc)
|
|
apply clarsimp
|
|
apply fastforce
|
|
apply (frule_tac m=m and p=p and p'=src in mdb_chunkedD, assumption+)
|
|
apply (clarsimp simp: descendants_of'_def)
|
|
apply (drule subtree_parent)
|
|
apply (clarsimp simp: parentOf_def isMDBParentOf_def split: split_if_asm)
|
|
apply simp
|
|
apply (rule chunked)
|
|
apply clarsimp
|
|
apply (erule disjE)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
prefer 2
|
|
apply clarsimp
|
|
apply (drule (1) trancl_trans, simp)
|
|
apply (clarsimp simp: is_chunk_def)
|
|
apply (simp add: n'_trancl_eq n_rtrancl_eq' split: split_if_asm)
|
|
apply (clarsimp simp: n_dest' new_dest_def)
|
|
apply (erule_tac x=p'' in allE)
|
|
apply clarsimp
|
|
apply (drule_tac p=p'' in m_cap')
|
|
apply clarsimp
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (drule (1) trancl_trans, simp)
|
|
apply (clarsimp simp: descendants_of'_def)
|
|
apply (drule subtree_mdb_next)
|
|
apply (drule (1) trancl_trans)
|
|
apply simp
|
|
done
|
|
|
|
lemma distinct_zombies_m:
|
|
"distinct_zombies m"
|
|
using valid by (simp add: valid_mdb_ctes_def)
|
|
|
|
lemma untyped_rangefree:
|
|
"\<lbrakk> isUntypedCap src_cap; m x = Some cte; x \<noteq> src; \<not> isUntypedCap (cteCap cte) \<rbrakk>
|
|
\<Longrightarrow> capRange (cteCap cte) \<noteq> capRange c'"
|
|
apply (frule ut_descendants)
|
|
apply (cases cte, clarsimp)
|
|
apply (frule(2) untyped_mdbD' [OF src _ _ _ _ untyped_mdb])
|
|
apply (simp add: untypedCapRange[symmetric])
|
|
apply (frule ut_capRange_non_empty)
|
|
apply (cut_tac capRange_c')
|
|
apply blast
|
|
apply simp
|
|
done
|
|
|
|
lemma notZomb:
|
|
"\<not> isZombie src_cap" "\<not> isZombie c'"
|
|
using sameRegion_src simple
|
|
by (auto simp: isCap_simps sameRegionAs_def3
|
|
simp del: sameRegion_src,
|
|
auto simp: is_simple_cap'_def isCap_simps)
|
|
|
|
lemma notArchPage:
|
|
"\<not> isArchPageCap c'"
|
|
using simple
|
|
by (clarsimp simp: isCap_simps is_simple_cap'_def)
|
|
|
|
lemma distinct_zombies[simp]:
|
|
"distinct_zombies n'"
|
|
using distinct_zombies_m
|
|
apply (simp add: n'_def distinct_zombies_nonCTE_modify_map)
|
|
apply (simp add: n_def modify_map_apply src dest)
|
|
apply (rule distinct_zombies_sameE[rotated])
|
|
apply (simp add: src)
|
|
apply simp+
|
|
apply (cases "isUntypedCap src_cap")
|
|
apply (erule distinct_zombies_seperateE)
|
|
apply (case_tac "y = src")
|
|
apply (clarsimp simp add: src)
|
|
apply (frule(3) untyped_rangefree)
|
|
apply (simp add: capRange_def)
|
|
apply (rule sameRegionAsE [OF sameRegion_src], simp_all)
|
|
apply (erule distinct_zombies_copyMasterE, rule src)
|
|
apply simp
|
|
apply (simp add: notZomb)
|
|
apply (simp add: notArchPage)
|
|
apply (erule distinct_zombies_sameMasterE, rule dest)
|
|
apply (clarsimp simp: isCap_simps)
|
|
done
|
|
|
|
lemma irq' [simp]:
|
|
"irq_control n'" using simple
|
|
apply (clarsimp simp: irq_control_def)
|
|
apply (frule n'_cap)
|
|
apply (drule n'_rev)
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (simp add: is_simple_cap'_def)
|
|
apply (frule irq_revocable, rule irq_control)
|
|
apply clarsimp
|
|
apply (drule n'_cap)
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (erule disjE)
|
|
apply (clarsimp simp: is_simple_cap'_def)
|
|
apply (erule (1) irq_controlD, rule irq_control)
|
|
done
|
|
|
|
lemma reply_masters_rvk_fb:
|
|
"reply_masters_rvk_fb m"
|
|
using valid by (simp add: valid_mdb_ctes_def)
|
|
|
|
lemma reply_masters_rvk_fb' [simp]:
|
|
"reply_masters_rvk_fb n'"
|
|
using reply_masters_rvk_fb simple
|
|
apply (simp add: reply_masters_rvk_fb_def n'_def
|
|
n_def ball_ran_modify_map_eq)
|
|
apply (subst ball_ran_modify_map_eq)
|
|
apply (clarsimp simp: modify_map_def m_p is_simple_cap'_def)
|
|
apply (simp add: ball_ran_modify_map_eq m_p is_simple_cap'_def
|
|
dest_cap isCap_simps)
|
|
done
|
|
|
|
lemma mdb:
|
|
"valid_mdb_ctes n'"
|
|
by (simp add: valid_mdb_ctes_def no_0_n' chain_n')
|
|
|
|
end
|
|
|
|
lemma updateCapFreeIndex_no_0:
|
|
assumes preserve:"\<And>m m'. mdb_inv_preserve m m'
|
|
\<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
|
|
shows
|
|
"\<lbrace>\<lambda>s. P (no_0(Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE \<and> isUntypedCap (cteCap c)) src s\<rbrace>
|
|
updateCap src (capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE))
|
|
\<lbrace>\<lambda>r s. P (no_0 (Q (ctes_of s)))\<rbrace>"
|
|
apply (wp updateCap_ctes_of_wp)
|
|
apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
|
|
(cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) (cteCap srcCTE)))))")
|
|
apply (drule mdb_inv_preserve.by_products)
|
|
apply simp
|
|
apply (rule preserve)
|
|
apply (simp add:cte_wp_at_ctes_of)+
|
|
apply (rule mdb_inv_preserve_updateCap)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of)+
|
|
done
|
|
|
|
lemma setUntypedCapAsFull_no_0:
|
|
assumes preserve:"\<And>m m'. mdb_inv_preserve m m'
|
|
\<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
|
|
shows
|
|
"\<lbrace>\<lambda>s. P (no_0 (Q (ctes_of s))) \<and> cte_wp_at' (\<lambda>c. c = srcCTE) src s\<rbrace>
|
|
setUntypedCapAsFull (cteCap srcCTE) cap src
|
|
\<lbrace>\<lambda>r s. P (no_0 (Q (ctes_of s)))\<rbrace>"
|
|
apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI)
|
|
apply (wp updateCapFreeIndex_no_0)
|
|
apply (clarsimp simp:preserve cte_wp_at_ctes_of)+
|
|
apply wp
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma cteInsert_simple_mdb':
|
|
"\<lbrace>valid_mdb' and pspace_aligned' and pspace_distinct' and (\<lambda>s. src \<noteq> dest) and K (capAligned cap) and
|
|
(\<lambda>s. safe_parent_for' (ctes_of s) src cap) and K (is_simple_cap' cap) \<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>_. valid_mdb'\<rbrace>"
|
|
unfolding cteInsert_def valid_mdb'_def
|
|
apply (fold revokable'_fold)
|
|
apply simp
|
|
apply (rule hoare_name_pre_state)
|
|
apply (rule hoare_pre)
|
|
apply (wp updateCap_ctes_of_wp getCTE_wp' setUntypedCapAsFull_ctes
|
|
mdb_inv_preserve_updateCap mdb_inv_preserve_modify_map mdb_inv_preserve_update_cap_same | clarsimp)+
|
|
apply (clarsimp simp: cte_wp_at_ctes_of)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: valid_mdb_ctes_def)
|
|
apply (case_tac cte)
|
|
apply (rename_tac src_cap src_node)
|
|
apply (case_tac ctea)
|
|
apply (rename_tac dest_cap dest_node)
|
|
apply clarsimp
|
|
apply (subst modify_map_eq)
|
|
apply simp+
|
|
apply (clarsimp simp:maskedAsFull_def is_simple_cap'_def)
|
|
apply (subgoal_tac "mdb_insert_simple'
|
|
(ctes_of sa) src src_cap src_node dest NullCap dest_node cap")
|
|
prefer 2
|
|
apply (intro mdb_insert_simple'.intro
|
|
mdb_insert_simple.intro mdb_insert_simple_axioms.intro
|
|
mdb_ptr.intro mdb_insert.intro vmdb.intro
|
|
mdb_ptr_axioms.intro mdb_insert_axioms.intro)
|
|
apply (simp add:modify_map_def valid_mdb_ctes_maskedAsFull)+
|
|
apply (clarsimp simp:nullPointer_def)+
|
|
apply ((clarsimp simp:valid_mdb_ctes_def)+)
|
|
apply (drule mdb_insert_simple'.mdb)
|
|
apply (clarsimp simp:valid_mdb_ctes_def)
|
|
done
|
|
|
|
lemma cteInsert_valid_globals_simple:
|
|
"\<lbrace>valid_global_refs' and (\<lambda>s. safe_parent_for' (ctes_of s) src cap)\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>rv. valid_global_refs'\<rbrace>"
|
|
apply (simp add: cteInsert_def)
|
|
apply (rule hoare_pre)
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of)
|
|
apply (drule (1) safe_parent_for_capRange_capBits)
|
|
apply (drule (1) valid_global_refsD_with_objSize)
|
|
apply (auto elim: order_trans[rotated])
|
|
done
|
|
|
|
lemma cteInsert_simple_invs:
|
|
"\<lbrace>invs' and cte_wp_at' (\<lambda>c. cteCap c=NullCap) dest and valid_cap' cap and
|
|
(\<lambda>s. src \<noteq> dest) and (\<lambda>s. safe_parent_for' (ctes_of s) src cap)
|
|
and (\<lambda>s. \<forall>irq. cap = IRQHandlerCap irq \<longrightarrow> irq_issued' irq s)
|
|
and ex_cte_cap_to' dest and K (is_simple_cap' cap)\<rbrace>
|
|
cteInsert cap src dest
|
|
\<lbrace>\<lambda>rv. invs'\<rbrace>"
|
|
apply (rule hoare_pre)
|
|
apply (simp add: invs'_def valid_state'_def valid_pspace'_def)
|
|
apply (wp cur_tcb_lift sch_act_wf_lift valid_queues_lift tcb_in_cur_domain'_lift
|
|
valid_irq_node_lift valid_queues_lift' irqs_masked_lift
|
|
cteInsert_simple_mdb' cteInsert_valid_globals_simple
|
|
cteInsert_norq | simp add: pred_tcb_at'_def)+
|
|
apply (auto simp: invs'_def valid_state'_def valid_pspace'_def
|
|
elim: valid_capAligned)
|
|
done
|
|
|
|
|
|
lemma ensureEmptySlot_stronger [wp]:
|
|
"\<lbrace>\<lambda>s. cte_wp_at' (\<lambda>c. cteCap c = NullCap) p s \<longrightarrow> P s\<rbrace> ensureEmptySlot p \<lbrace>\<lambda>rv. P\<rbrace>, -"
|
|
apply (simp add: ensureEmptySlot_def whenE_def unlessE_whenE)
|
|
apply (wp getCTE_wp')
|
|
apply (clarsimp simp: cte_wp_at'_def)
|
|
done
|
|
|
|
lemma lookupSlotForCNodeOp_real_cte_at'[wp]:
|
|
"\<lbrace>valid_objs' and valid_cap' rootCap\<rbrace>
|
|
lookupSlotForCNodeOp isSrc rootCap cref depth
|
|
\<lbrace>\<lambda>rv. real_cte_at' rv\<rbrace>,-"
|
|
apply (simp add: lookupSlotForCNodeOp_def split_def unlessE_def
|
|
split del: split_if cong: if_cong)
|
|
apply (rule hoare_pre)
|
|
apply (wp resolveAddressBits_real_cte_at' | simp | wp_once hoare_drop_imps)+
|
|
done
|
|
|
|
lemma cte_refs_maskCapRights[simp]:
|
|
"cte_refs' (maskCapRights rghts cap) = cte_refs' cap"
|
|
by (rule ext, cases cap,
|
|
simp_all add: maskCapRights_def isCap_defs Let_def
|
|
ArchRetype_H.maskCapRights_def
|
|
split del: split_if
|
|
split: arch_capability.split)
|
|
|
|
lemma capASID_PageCap_None [simp]:
|
|
"capASID (ArchObjectCap (PageCap r R page_size None)) = None"
|
|
by (simp add: capASID_def)
|
|
|
|
lemma getSlotCap_cap_to'[wp]:
|
|
"\<lbrace>\<top>\<rbrace> getSlotCap cp \<lbrace>\<lambda>rv s. \<forall>r\<in>cte_refs' rv (irq_node' s). ex_cte_cap_to' r s\<rbrace>"
|
|
apply (simp add: getSlotCap_def)
|
|
apply (wp getCTE_wp)
|
|
apply (fastforce simp: cte_wp_at_ctes_of ex_cte_cap_to'_def)
|
|
done
|
|
|
|
lemma getSlotCap_cap_to2:
|
|
"\<lbrace>\<top> and K (\<forall>cap. P cap \<longrightarrow> Q cap)\<rbrace>
|
|
getSlotCap slot
|
|
\<lbrace>\<lambda>rv s. P rv \<longrightarrow> (\<forall>x \<in> cte_refs' rv (irq_node' s). ex_cte_cap_wp_to' Q x s)\<rbrace>"
|
|
apply (simp add: getSlotCap_def)
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of ex_cte_cap_wp_to'_def)
|
|
apply fastforce
|
|
done
|
|
|
|
lemma locateSlot_cap_to'[wp]:
|
|
"\<lbrace>\<lambda>s. isCNodeCap cap \<and> (\<forall>r \<in> cte_refs' cap (irq_node' s). ex_cte_cap_wp_to' P r s)\<rbrace>
|
|
locateSlotCNode (capCNodePtr cap) n (v && mask (capCNodeBits cap))
|
|
\<lbrace>ex_cte_cap_wp_to' P\<rbrace>"
|
|
apply (simp add: locateSlot_conv)
|
|
apply wp
|
|
apply (clarsimp dest!: isCapDs valid_capAligned
|
|
simp: objBits_simps mult.commute capAligned_def cte_level_bits_def)
|
|
apply (erule bspec)
|
|
apply (case_tac "bits < word_bits")
|
|
apply simp
|
|
apply (rule and_mask_less_size)
|
|
apply (simp add: word_bits_def word_size)
|
|
apply (simp add: power_overflow word_bits_def)
|
|
done
|
|
|
|
lemma rab_cap_to'':
|
|
assumes P: "\<And>cap. isCNodeCap cap \<longrightarrow> P cap"
|
|
shows
|
|
"s \<turnstile> \<lbrace>\<lambda>s. isCNodeCap cap \<longrightarrow> (\<forall>r\<in>cte_refs' cap (irq_node' s). ex_cte_cap_wp_to' P r s)\<rbrace>
|
|
resolveAddressBits cap cref depth
|
|
\<lbrace>\<lambda>rv s. ex_cte_cap_wp_to' P (fst rv) s\<rbrace>,\<lbrace>\<top>\<top>\<rbrace>"
|
|
proof (induct arbitrary: s rule: resolveAddressBits.induct)
|
|
case (1 cap fn cref depth)
|
|
show ?case
|
|
apply (subst resolveAddressBits.simps)
|
|
apply (simp add: Let_def split_def cap_case_CNodeCap[unfolded isCap_simps]
|
|
split del: split_if cong: if_cong)
|
|
apply (rule hoare_pre_spec_validE)
|
|
apply ((elim exE | wp_once spec_strengthen_postE[OF "1.hyps"])+,
|
|
(rule refl conjI | simp add: in_monad split del: split_if del: cte_refs'.simps)+)
|
|
apply (wp getSlotCap_cap_to2
|
|
| simp add: assertE_def split_def whenE_def locateSlotCap_def
|
|
split del: split_if | simp add: imp_conjL[symmetric]
|
|
| wp_once hoare_drop_imps)+
|
|
apply (clarsimp simp: P)
|
|
done
|
|
qed
|
|
|
|
lemma rab_cap_to'[wp]:
|
|
"\<lbrace>(\<lambda>s. isCNodeCap cap \<longrightarrow> (\<forall>r\<in>cte_refs' cap (irq_node' s). ex_cte_cap_wp_to' P r s))
|
|
and K (\<forall>cap. isCNodeCap cap \<longrightarrow> P cap)\<rbrace>
|
|
resolveAddressBits cap cref depth
|
|
\<lbrace>\<lambda>rv s. ex_cte_cap_wp_to' P (fst rv) s\<rbrace>,-"
|
|
apply (rule hoare_gen_asmE)
|
|
apply (unfold validE_R_def)
|
|
apply (rule use_spec, rule rab_cap_to'')
|
|
apply simp
|
|
done
|
|
|
|
lemma lookupCNode_cap_to'[wp]:
|
|
"\<lbrace>\<lambda>s. \<forall>r\<in>cte_refs' rootCap (irq_node' s). ex_cte_cap_to' r s\<rbrace>
|
|
lookupSlotForCNodeOp isSrc rootCap cref depth
|
|
\<lbrace>\<lambda>p. ex_cte_cap_to' p\<rbrace>,-"
|
|
apply (simp add: lookupSlotForCNodeOp_def Let_def split_def unlessE_def
|
|
split del: split_if cong: if_cong)
|
|
apply (rule hoare_pre)
|
|
apply (wp hoare_drop_imps | simp)+
|
|
done
|
|
|
|
lemma badge_derived'_refl[simp]: "badge_derived' c c"
|
|
by (simp add: badge_derived'_def)
|
|
|
|
lemma derived'_not_Null:
|
|
"\<not> is_derived' m p c capability.NullCap"
|
|
"\<not> is_derived' m p capability.NullCap c"
|
|
by (clarsimp simp: is_derived'_def badge_derived'_def)+
|
|
|
|
lemma getSlotCap_wp:
|
|
"\<lbrace>\<lambda>s. (\<exists>cap. cte_wp_at' (\<lambda>c. cteCap c = cap) p s \<and> Q cap s)\<rbrace>
|
|
getSlotCap p \<lbrace>Q\<rbrace>"
|
|
apply (simp add: getSlotCap_def)
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp: cte_wp_at'_def)
|
|
done
|
|
|
|
lemma storeWordUser_typ_at' :
|
|
"\<lbrace>\<lambda>s. P (typ_at' T p s)\<rbrace> storeWordUser v w \<lbrace>\<lambda>_ s. P (typ_at' T p s)\<rbrace>"
|
|
unfolding storeWordUser_def by wp
|
|
|
|
lemma arch_update_updateCap_invs:
|
|
"\<lbrace>cte_wp_at' (is_arch_update' cap) p and invs' and valid_cap' cap\<rbrace>
|
|
updateCap p cap
|
|
\<lbrace>\<lambda>_. invs'\<rbrace>"
|
|
apply (simp add: updateCap_def)
|
|
apply (wp arch_update_setCTE_invs getCTE_wp')
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma updateCap_same_master:
|
|
"\<lbrakk> cap_relation cap cap' \<rbrakk> \<Longrightarrow>
|
|
corres dc (valid_objs and pspace_aligned and pspace_distinct and
|
|
cte_wp_at (\<lambda>c. cap_master_cap c = cap_master_cap cap \<and>
|
|
\<not>is_reply_cap c \<and> \<not>is_master_reply_cap c \<and>
|
|
\<not>is_ep_cap c \<and> \<not>is_ntfn_cap c) slot)
|
|
(pspace_aligned' and pspace_distinct' and cte_at' (cte_map slot))
|
|
(set_cap cap slot)
|
|
(updateCap (cte_map slot) cap')" (is "_ \<Longrightarrow> corres _ ?P ?P' _ _")
|
|
apply (unfold updateCap_def)
|
|
apply (rule corres_guard_imp)
|
|
apply (rule_tac Q="?P" and R'="\<lambda>cte. ?P' and (\<lambda>s. ctes_of s (cte_map slot) = Some cte)"
|
|
in corres_symb_exec_r_conj)
|
|
apply (rule corres_stronger_no_failI)
|
|
apply (rule no_fail_pre, wp)
|
|
apply (clarsimp simp: cte_wp_at_ctes_of)
|
|
apply clarsimp
|
|
apply (clarsimp simp add: state_relation_def)
|
|
apply (drule (1) pspace_relationsD)
|
|
apply (frule (4) set_cap_not_quite_corres_prequel)
|
|
apply (erule cte_wp_at_weakenE, rule TrueI)
|
|
apply assumption
|
|
apply assumption
|
|
apply simp
|
|
apply (rule refl)
|
|
apply clarsimp
|
|
apply (rule bexI)
|
|
prefer 2
|
|
apply assumption
|
|
apply (clarsimp simp: pspace_relations_def)
|
|
apply (subst conj_assoc[symmetric])
|
|
apply (rule conjI)
|
|
apply (frule setCTE_pspace_only)
|
|
apply (clarsimp simp: set_cap_def in_monad split_def get_object_def set_object_def
|
|
split: split_if_asm Structures_A.kernel_object.splits)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv)
|
|
apply (intro allI conjI)
|
|
apply (frule use_valid[OF _ setCTE_gsUserPages])
|
|
prefer 2
|
|
apply simp+
|
|
apply (frule use_valid[OF _ setCTE_gsCNodes])
|
|
prefer 2
|
|
apply simp+
|
|
apply (subst conj_assoc[symmetric])
|
|
apply (rule conjI)
|
|
prefer 2
|
|
apply (rule conjI)
|
|
prefer 2
|
|
apply (frule setCTE_pspace_only)
|
|
apply clarsimp
|
|
apply (clarsimp simp: set_cap_def in_monad split_def get_object_def set_object_def
|
|
split: split_if_asm Structures_A.kernel_object.splits)
|
|
apply (frule set_cap_caps_of_state_monad)
|
|
apply (drule is_original_cap_set_cap)
|
|
apply clarsimp
|
|
apply (erule use_valid [OF _ setCTE_ctes_of_wp])
|
|
apply (clarsimp simp: revokable_relation_def simp del: fun_upd_apply)
|
|
apply (clarsimp split: split_if_asm)
|
|
apply (drule cte_map_inj_eq)
|
|
prefer 2
|
|
apply (erule cte_wp_at_weakenE, rule TrueI)
|
|
apply (simp add: null_filter_def split: split_if_asm)
|
|
apply (erule cte_wp_at_weakenE, rule TrueI)
|
|
apply (erule caps_of_state_cte_at)
|
|
apply fastforce
|
|
apply fastforce
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply (simp add: null_filter_def split: split_if_asm)
|
|
apply (erule_tac x=aa in allE, erule_tac x=bb in allE)
|
|
apply (clarsimp simp: cte_wp_at_caps_of_state)
|
|
apply (erule disjE)
|
|
apply (clarsimp simp: cap_master_cap_simps dest!: cap_master_cap_eqDs)
|
|
apply (case_tac rv)
|
|
apply clarsimp
|
|
apply (subgoal_tac "(aa,bb) \<noteq> slot")
|
|
prefer 2
|
|
apply clarsimp
|
|
apply (simp add: null_filter_def cte_wp_at_caps_of_state split: split_if_asm)
|
|
apply (clarsimp simp: cdt_relation_def)
|
|
apply (frule set_cap_caps_of_state_monad)
|
|
apply (frule mdb_set_cap, frule exst_set_cap)
|
|
apply clarsimp
|
|
apply (erule use_valid [OF _ setCTE_ctes_of_wp])
|
|
apply (frule cte_wp_at_norm)
|
|
apply (clarsimp simp del: fun_upd_apply)
|
|
apply (frule (1) pspace_relation_ctes_ofI)
|
|
apply fastforce
|
|
apply fastforce
|
|
apply (clarsimp simp del: fun_upd_apply)
|
|
apply (subst same_master_descendants)
|
|
apply assumption
|
|
apply (clarsimp simp: master_cap_relation)
|
|
apply (frule_tac d=c in master_cap_relation [symmetric], assumption)
|
|
apply (frule is_reply_cap_relation[symmetric],
|
|
drule is_reply_master_relation[symmetric])+
|
|
apply simp
|
|
apply (drule masterCap.intro)
|
|
apply (drule masterCap.isReplyCap)
|
|
apply simp
|
|
apply (drule is_ep_cap_relation)+
|
|
apply (drule master_cap_ep)
|
|
apply simp
|
|
apply (drule is_ntfn_cap_relation)+
|
|
apply (drule master_cap_ntfn)
|
|
apply simp
|
|
apply (simp add: in_set_cap_cte_at)
|
|
apply(simp add: cdt_list_relation_def split del: split_if)
|
|
apply(intro allI impI)
|
|
apply(erule_tac x=aa in allE)+
|
|
apply(erule_tac x=bb in allE)+
|
|
apply(clarsimp split: split_if_asm)
|
|
apply(case_tac rv, clarsimp)
|
|
apply (wp getCTE_wp')
|
|
apply clarsimp
|
|
apply (rule no_fail_pre, wp)
|
|
apply clarsimp
|
|
apply assumption
|
|
apply clarsimp
|
|
apply (clarsimp simp: cte_wp_at_ctes_of)
|
|
done
|
|
|
|
lemma diminished_cte_refs':
|
|
"diminished' cap cap' \<Longrightarrow> cte_refs' cap n = cte_refs' cap' n"
|
|
by (clarsimp simp: diminished'_def)
|
|
|
|
lemma diminished_Untyped' :
|
|
"diminished' (UntypedCap r n x) cap = (cap = UntypedCap r n x)"
|
|
apply (rule iffI)
|
|
apply (case_tac cap)
|
|
apply (clarsimp simp:isCap_simps maskCapRights_def diminished'_def split:split_if_asm)+
|
|
(* 6 subgoals *)
|
|
apply (rename_tac arch_capability R)
|
|
apply (case_tac arch_capability)
|
|
apply (clarsimp simp: isCap_simps ArchRetype_H.maskCapRights_def maskCapRights_def
|
|
diminished'_def Let_def)+
|
|
done
|
|
|
|
lemma updateCapFreeIndex_valid_mdb_ctes:
|
|
assumes preserve:"\<And>m m'. mdb_inv_preserve m m' \<Longrightarrow> mdb_inv_preserve (Q m) (Q m')"
|
|
and coin :"\<And>m cte. \<lbrakk>m src = Some cte\<rbrakk> \<Longrightarrow> (\<exists>cte'. (Q m) src = Some cte' \<and> cteCap cte = cteCap cte')"
|
|
and assoc :"\<And>m f. Q (modify_map m src (cteCap_update f)) = modify_map (Q m) src (cteCap_update f)"
|
|
shows
|
|
"\<lbrace>\<lambda>s. usableUntypedRange (capFreeIndex_update (\<lambda>_. index) cap) \<subseteq> usableUntypedRange cap \<and> isUntypedCap cap
|
|
\<and> valid_mdb_ctes (Q (ctes_of s)) \<and> cte_wp_at' (\<lambda>c. cteCap c = cap) src s\<rbrace>
|
|
updateCap src (capFreeIndex_update (\<lambda>_. index) cap)
|
|
\<lbrace>\<lambda>r s. (valid_mdb_ctes (Q (ctes_of s)))\<rbrace>"
|
|
apply (wp updateCap_ctes_of_wp)
|
|
apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src
|
|
(cteCap_update (\<lambda>_. capFreeIndex_update (\<lambda>_. index) cap))))")
|
|
apply (clarsimp simp:valid_mdb_ctes_def)
|
|
apply (intro conjI)
|
|
apply ((simp add:mdb_inv_preserve.preserve_stuff
|
|
mdb_inv_preserve.by_products)+)[7]
|
|
apply (rule mdb_inv_preserve.untyped_inc')
|
|
apply assumption
|
|
apply (clarsimp simp:assoc cte_wp_at_ctes_of)
|
|
apply (clarsimp simp:modify_map_def split:if_splits)
|
|
apply (drule coin)
|
|
apply clarsimp
|
|
apply (erule(1) subsetD)
|
|
apply simp
|
|
apply (simp_all add:mdb_inv_preserve.preserve_stuff
|
|
mdb_inv_preserve.by_products)
|
|
apply (rule preserve)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of)
|
|
apply (rule mdb_inv_preserve_updateCap)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of)+
|
|
done
|
|
|
|
lemma updateFreeIndex_pspace':
|
|
"\<lbrace>\<lambda>s. (capFreeIndex cap \<le> idx \<and> idx \<le> 2 ^ capBlockSize cap \<and>
|
|
is_aligned (of_nat idx :: word32) 4 \<and> isUntypedCap cap) \<and>
|
|
valid_pspace' s \<and> cte_wp_at' (\<lambda>c. cteCap c = cap) src s\<rbrace>
|
|
updateCap src (capFreeIndex_update (\<lambda>_. idx) cap)
|
|
\<lbrace>\<lambda>r s. valid_pspace' s\<rbrace>"
|
|
apply (clarsimp simp:valid_pspace'_def)
|
|
apply (rule hoare_pre)
|
|
apply (rule hoare_vcg_conj_lift)
|
|
apply (clarsimp simp:updateCap_def)
|
|
apply (wp getCTE_wp)
|
|
apply (clarsimp simp:valid_mdb'_def)
|
|
apply (wp updateCapFreeIndex_valid_mdb_ctes)
|
|
apply (simp | wp)+
|
|
apply (clarsimp simp:cte_wp_at_ctes_of valid_mdb'_def)
|
|
apply (case_tac cte,simp add:isCap_simps)
|
|
apply (rename_tac capability mdbnode)
|
|
apply (drule(1) ctes_of_valid_cap')
|
|
apply (subgoal_tac "usableUntypedRange (capFreeIndex_update (\<lambda>_. idx) capability)
|
|
\<subseteq> usableUntypedRange capability")
|
|
apply (clarsimp simp:valid_cap'_def capAligned_def valid_untyped'_def
|
|
simp del:atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
|
|
Int_atLeastAtMost atLeastatMost_empty_iff usableUntypedRange.simps
|
|
split del:if_splits)
|
|
apply (drule_tac x = ptr' in spec)
|
|
apply (clarsimp simp:ko_wp_at'_def
|
|
simp del:atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff
|
|
Int_atLeastAtMost atLeastatMost_empty_iff usableUntypedRange.simps
|
|
split del:if_splits)
|
|
apply blast
|
|
apply (clarsimp simp:isCap_simps valid_cap'_def capAligned_def
|
|
split:if_splits)
|
|
apply (erule order_trans[rotated])
|
|
apply (rule word_plus_mono_right)
|
|
apply (rule of_nat_mono_maybe_le[THEN iffD1])
|
|
apply (subst word_bits_def[symmetric])
|
|
apply (erule less_le_trans[OF _ power_increasing])
|
|
apply simp
|
|
apply simp
|
|
apply (subst word_bits_def[symmetric])
|
|
apply (erule le_less_trans)
|
|
apply (erule less_le_trans[OF _ power_increasing])
|
|
apply simp+
|
|
apply (erule is_aligned_no_wrap')
|
|
apply (rule word_of_nat_less)
|
|
apply simp
|
|
done
|
|
|
|
lemma updateFreeIndex_invs':
|
|
"\<lbrace>\<lambda>s. (capFreeIndex cap \<le> idx \<and> idx \<le> 2 ^ capBlockSize cap \<and>
|
|
isUntypedCap cap \<and> is_aligned (of_nat idx :: word32) 4) \<and>
|
|
invs' s \<and> cte_wp_at' (\<lambda>c. cteCap c = cap) src s\<rbrace>
|
|
updateCap src (capFreeIndex_update (\<lambda>_. idx) cap)
|
|
\<lbrace>\<lambda>r s. invs' s\<rbrace>"
|
|
apply (clarsimp simp:invs'_def valid_state'_def)
|
|
apply (wp updateFreeIndex_pspace' sch_act_wf_lift valid_queues_lift updateCap_iflive' tcb_in_cur_domain'_lift
|
|
| simp add: pred_tcb_at'_def)+
|
|
apply (rule hoare_pre)
|
|
apply (rule hoare_vcg_conj_lift)
|
|
apply (simp add: ifunsafe'_def3 cteInsert_def setUntypedCapAsFull_def
|
|
split del: split_if)
|
|
apply (wp getCTE_wp)
|
|
apply (rule hoare_vcg_conj_lift)
|
|
apply (simp add:updateCap_def)
|
|
apply wp
|
|
apply (wp valid_irq_node_lift)
|
|
apply (rule hoare_vcg_conj_lift)
|
|
apply (simp add:updateCap_def)
|
|
apply (wp setCTE_irq_handlers' getCTE_wp)
|
|
apply (simp add:updateCap_def)
|
|
apply (wp irqs_masked_lift valid_queues_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift hoare_vcg_disj_lift)
|
|
apply (clarsimp simp:cte_wp_at_ctes_of)
|
|
apply (intro conjI allI impI)
|
|
apply (clarsimp simp: modify_map_def cteCaps_of_def ifunsafe'_def3 split:if_splits)
|
|
apply (drule_tac x=src in spec)
|
|
apply (clarsimp simp:isCap_simps)
|
|
apply (rule_tac x = cref' in exI)
|
|
apply clarsimp
|
|
apply (drule_tac x = cref in spec)
|
|
apply clarsimp
|
|
apply (rule_tac x = cref' in exI)
|
|
apply clarsimp
|
|
apply (drule(1) valid_global_refsD')
|
|
apply (clarsimp simp: isCap_simps)
|
|
apply (drule(1) valid_global_refsD_with_objSize)
|
|
apply (clarsimp simp:isCap_simps cte_wp_at_ctes_of)+
|
|
done
|
|
|
|
end
|