3448 lines
150 KiB
Plaintext
3448 lines
150 KiB
Plaintext
(*
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
|
*
|
|
* SPDX-License-Identifier: GPL-2.0-only
|
|
*)
|
|
|
|
text \<open>
|
|
This file sets up a kernel automaton, ADT_A_if, which is
|
|
slightly different from ADT_A.
|
|
It then setups a big step framework to transfrom this automaton in the
|
|
big step automaton on which the infoflow theorem will be proved
|
|
\<close>
|
|
|
|
theory ADT_IF
|
|
imports
|
|
Noninterference_Base
|
|
Access.ArchSyscall_AC
|
|
Access.ArchADT_AC
|
|
ArchIRQMasks_IF
|
|
ArchScheduler_IF
|
|
ArchUserOp_IF
|
|
begin
|
|
|
|
section \<open>Generic big step automaton\<close>
|
|
|
|
inductive_set sub_big_steps ::
|
|
"('a,'b,'c) data_type \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'c list) set"
|
|
for A :: "('a,'b,'c) data_type" and R :: "('a \<Rightarrow> 'a \<Rightarrow> bool)" and s :: "'a" where
|
|
nil: "\<lbrakk> evlist = []; t = s; \<not> R s s \<rbrakk>
|
|
\<Longrightarrow> (t,evlist) \<in> sub_big_steps A R s"
|
|
| step: "\<lbrakk> evlist = evlist' @ [e]; (s',evlist') \<in> sub_big_steps A R s; (s',t) \<in> Step A e; \<not> R s t \<rbrakk>
|
|
\<Longrightarrow> (t,evlist) \<in> sub_big_steps A R s"
|
|
|
|
text \<open>
|
|
Turn the (observable) multi-step executions of one automaton into the
|
|
steps of another. We call this second automaton a \emph{big step} automaton
|
|
of the first. We use a relation on observable states of the original
|
|
automaton to demarcate one big step from the next.
|
|
\<close>
|
|
inductive_set big_steps ::
|
|
"('a,'b,'c) data_type \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('c list \<Rightarrow> 'd) \<Rightarrow> ('d \<Rightarrow> ('a \<times> 'a) set)"
|
|
for A :: "('a,'b,'c) data_type" and R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
|
|
and exmap :: "'c list \<Rightarrow> 'd" and ev :: "'d" where
|
|
cstep: "\<lbrakk> (s',as) \<in> sub_big_steps A R s; (s',t) \<in> Step A a; R s t; ev = exmap (as @ [a]) \<rbrakk>
|
|
\<Longrightarrow> (s,t) \<in> big_steps A R exmap ev"
|
|
|
|
definition big_step_adt ::
|
|
"('a,'b,'c) data_type \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('c list \<Rightarrow> 'd) \<Rightarrow> ('a,'b,'d) data_type" where
|
|
"big_step_adt A R exmap \<equiv> \<lparr>Init = Init A, Fin = Fin A, Step = big_steps A R exmap\<rparr>"
|
|
|
|
lemma system_Step_def_raw:
|
|
"system.Step = (\<lambda>A a. {(s,s'). s' \<in> execution A s [a]})"
|
|
apply (rule ext)
|
|
apply (rule ext)
|
|
apply (subst system.Step_def)
|
|
by (rule refl)
|
|
|
|
lemma big_stepsD:
|
|
"(s,t) \<in> big_steps A R exmap ev
|
|
\<Longrightarrow> \<exists>s' as a. (s',as) \<in> sub_big_steps A R s \<and> (s',t) \<in> Step A a \<and> R s t \<and> ev = exmap (as @ [a])"
|
|
apply (erule big_steps.induct)
|
|
apply blast
|
|
done
|
|
|
|
lemma big_stepsE:
|
|
assumes bs: "(s,t) \<in> big_steps A R exmap ev"
|
|
obtains s' as a where "(s',as) \<in> sub_big_steps A R s"
|
|
"(s',t) \<in> Step A a"
|
|
"R s t"
|
|
"ev = exmap (as @ [a])"
|
|
using bs[THEN big_stepsD] by blast
|
|
|
|
|
|
lemma Run_subset:
|
|
"(\<And>ev. Stepf ev \<subseteq> Stepf' ev) \<Longrightarrow> Run Stepf as \<subseteq> Run Stepf' as"
|
|
apply (induct as)
|
|
apply simp
|
|
apply auto
|
|
done
|
|
|
|
lemma rtranclp_def2:
|
|
"(R\<^sup>*\<^sup>* s0 s) = (R\<^sup>+\<^sup>+ s0 s \<or> s = s0)"
|
|
apply safe
|
|
apply (drule rtranclpD)
|
|
apply simp
|
|
apply (erule tranclp_into_rtranclp)
|
|
done
|
|
|
|
definition Fin_trancl where
|
|
"Fin_trancl A R s s' \<equiv> R\<^sup>+\<^sup>+ s s' \<or> Fin A s = Fin A s'"
|
|
|
|
text \<open>
|
|
A sufficient condition to show that the big steps of a big step ADT
|
|
terminate (i.e. that the relation R eventually becomes satisfied.)
|
|
\<close>
|
|
definition rel_terminate ::
|
|
"('a,'b,'c) data_type \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a set) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> nat) \<Rightarrow> bool" where
|
|
"rel_terminate A s0 R I measuref \<equiv>
|
|
(\<forall>s. s \<in> I \<and> (\<exists>s0'\<in> Init A s0. R\<^sup>*\<^sup>* s0' s)
|
|
\<longrightarrow> (\<forall>as s'. (s',as) \<in> sub_big_steps A R s
|
|
\<longrightarrow> (\<forall>s'' a. (s',s'') \<in> Step A a
|
|
\<longrightarrow> (measuref s s'' < measuref s s') \<and>
|
|
(measuref s s' > 0 \<longrightarrow> measuref s s'' = 0 \<longrightarrow> R s s''))))"
|
|
|
|
|
|
lemma rel_terminateE:
|
|
assumes a: "rel_terminate A s0 R I measuref"
|
|
assumes b:
|
|
"\<lbrakk> (\<And>s s' as s'' a. \<lbrakk> s \<in> I; \<exists>s0'\<in> Init A s0. R\<^sup>*\<^sup>* s0' s; (s',as) \<in> sub_big_steps A R s;
|
|
(s',s'') \<in> Step A a; measuref s s' > 0; measuref s s'' = 0 \<rbrakk>
|
|
\<Longrightarrow> R s s'');
|
|
(\<And>s s' as s'' a. \<lbrakk> s \<in> I; \<exists>s0'\<in> Init A s0. R\<^sup>*\<^sup>* s0' s;
|
|
(s',as) \<in> sub_big_steps A R s; (s',s'') \<in> Step A a \<rbrakk>
|
|
\<Longrightarrow> measuref s s'' < measuref s s') \<rbrakk>
|
|
\<Longrightarrow> C"
|
|
shows "C"
|
|
using a b by (fastforce simp: rel_terminate_def)
|
|
|
|
lemma Run_big_steps_tranclp:
|
|
"(s0, s) \<in> Run (big_steps C R exmap) js \<Longrightarrow> R\<^sup>*\<^sup>* s0 s"
|
|
apply (induct js arbitrary: s rule: rev_induct)
|
|
apply simp
|
|
apply (fastforce dest: Run_mid elim: big_steps.cases)
|
|
done
|
|
|
|
lemma Step_system_reachable_trans:
|
|
"\<lbrakk> Step_system A s0; system.reachable A s0 s; system.reachable A s s' \<rbrakk>
|
|
\<Longrightarrow> system.reachable A s0 s'"
|
|
apply (clarsimp simp: system.reachable_def)
|
|
apply (rule Step_system.reachable_execution[simplified system.reachable_def])
|
|
apply blast+
|
|
done
|
|
|
|
lemma Step_system_reachable:
|
|
"\<lbrakk> Step_system A s0; system.reachable A s0 s \<rbrakk>
|
|
\<Longrightarrow> Step_system A s"
|
|
apply (subst Step_system_def)
|
|
apply (rule conjI)
|
|
apply (fastforce simp: system.reachable_def Step_system.execution_Run intro: exI[where x="[]"])
|
|
apply clarsimp
|
|
apply (frule Step_system_reachable_trans, assumption+)
|
|
apply (simp add: Step_system.execution_Run)
|
|
done
|
|
|
|
lemma Step_system_execution_Run_s0:
|
|
"Step_system A s0 \<Longrightarrow> execution A s0 as = {s'. (s0,s') \<in> Run (system.Step A) as}"
|
|
apply (rule Step_system.execution_Run, assumption)
|
|
apply (erule Step_system.reachable_s0)
|
|
done
|
|
|
|
text \<open>
|
|
Define a relation on states that is basically the inverse of the
|
|
Step relation for states @{term y} reachable from a given state @{term s}
|
|
before the next big step has finished.
|
|
\<close>
|
|
definition step_measuref_rel_from ::
|
|
"('a,'b,'c) data_type \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) set" where
|
|
"step_measuref_rel_from A R s \<equiv>
|
|
{(x,y). \<exists>a as. (y,x) \<in> Step A a \<and> (y,as) \<in> sub_big_steps A R s}"
|
|
|
|
lemma wf_step_measuref_rel_from:
|
|
"\<lbrakk> rel_terminate A s0 R I measuref; s \<in> I; \<exists>s0'\<in> Init A s0. R\<^sup>*\<^sup>* s0' s \<rbrakk>
|
|
\<Longrightarrow> wf (step_measuref_rel_from A R s)"
|
|
apply (cut_tac wf_measure[where f="measuref s"])
|
|
apply (erule wf_subset)
|
|
apply (fastforce simp: measure_def inv_image_def step_measuref_rel_from_def rel_terminate_def)
|
|
done
|
|
|
|
lemma system_Step_one:
|
|
"(x, s') \<in> system.Step A a \<Longrightarrow> (x, s') \<in> Run (system.Step A) [a]"
|
|
by simp
|
|
|
|
definition inv_holds :: "('a,'b,'j) data_type \<Rightarrow> 'a set \<Rightarrow> bool" (infix "[>" 60) where
|
|
"D [> I \<equiv> (\<forall>j. Step D j `` I \<subseteq> I)"
|
|
|
|
lemma inv_holdsI:
|
|
"(\<forall>j. Step D j `` I \<subseteq> I) \<Longrightarrow> D [> I"
|
|
by (simp add: inv_holds_def)
|
|
|
|
lemma inv_holds_conjI:
|
|
"\<lbrakk> D [> P; D [> Q \<rbrakk> \<Longrightarrow> D [> P \<inter> Q"
|
|
by (simp add: inv_holds_def) blast
|
|
|
|
lemma inv_holds_steps:
|
|
assumes I: "A [> I"
|
|
assumes start_I: "B \<subseteq> I"
|
|
shows "steps (Simulation.Step A) B as \<subseteq> I"
|
|
apply clarsimp
|
|
apply (induct as rule: rev_induct)
|
|
apply (simp add: steps_def)
|
|
apply (rule set_mp)
|
|
apply (rule start_I)
|
|
apply simp
|
|
apply (simp add: steps_def)
|
|
apply (erule ImageE)
|
|
apply (drule_tac x=xb in meta_spec)
|
|
apply simp
|
|
apply (rule set_mp)
|
|
apply (rule I[simplified inv_holds_def,rule_format])
|
|
apply (rule ImageI)
|
|
apply assumption
|
|
apply simp
|
|
done
|
|
|
|
|
|
locale serial_system_weak = system +
|
|
fixes I
|
|
assumes I: "A [> I"
|
|
assumes serial: "\<And>s' a. s' \<in> I \<Longrightarrow> (\<exists>t. (s', t) \<in> data_type.Step A a)"
|
|
begin
|
|
|
|
lemma step_serial:
|
|
assumes nonempty_start: "B \<noteq> {}"
|
|
assumes invariant_start: "B \<subseteq> I"
|
|
shows "steps (Simulation.Step A) B as \<noteq> {}"
|
|
apply (induct as rule: rev_induct)
|
|
apply (simp add: steps_def nonempty_start)
|
|
apply (erule nonemptyE)
|
|
apply (frule set_mp[OF inv_holds_steps[OF I invariant_start]])
|
|
apply (frule_tac a=x in serial)
|
|
apply (elim exE)
|
|
apply (rule_tac x=t in notemptyI)
|
|
apply (fastforce simp: steps_def)
|
|
done
|
|
|
|
end
|
|
|
|
|
|
lemma sub_big_steps_I_holds:
|
|
"\<lbrakk> A [> I; s \<in> I; (x, xs) \<in> sub_big_steps A R s \<rbrakk>
|
|
\<Longrightarrow> x \<in> I"
|
|
apply (erule sub_big_steps.induct)
|
|
apply simp
|
|
apply (simp add: inv_holds_def)
|
|
apply blast
|
|
done
|
|
|
|
lemma rel_terminate_terminates:
|
|
assumes ss: "serial_system_weak A I"
|
|
assumes rt: "rel_terminate A s0 R I measuref"
|
|
assumes si: "s \<in> I"
|
|
assumes sR: "\<exists>s0'\<in> Init A s0. R\<^sup>*\<^sup>* s0' s"
|
|
shows "\<forall>js. (x,js) \<in> sub_big_steps A R s
|
|
\<longrightarrow> (\<exists>as s' a s''. (s',(js@as)) \<in> sub_big_steps A R s \<and>
|
|
(s',s'') \<in> Step A a \<and> R s s'')"
|
|
proof -
|
|
show ?thesis
|
|
apply (induct x rule: wf_induct)
|
|
apply (rule wf_step_measuref_rel_from[OF rt si sR])
|
|
apply clarsimp
|
|
apply (frule sub_big_steps_I_holds[OF ss[THEN serial_system_weak.I] si])
|
|
apply (frule_tac serial_system_weak.serial[OF ss])
|
|
apply (erule exE, rename_tac s')
|
|
apply (drule_tac x=s' in spec)
|
|
apply (erule impE)
|
|
apply (fastforce simp: step_measuref_rel_from_def)
|
|
apply (case_tac "R s s'")
|
|
apply (rule_tac x="[]" in exI)
|
|
apply (rule_tac x=x in exI)
|
|
apply fastforce
|
|
apply (fastforce intro: sub_big_steps.step)
|
|
done
|
|
qed
|
|
|
|
|
|
lemma sub_big_steps_nrefl:
|
|
"(\<And>s. \<not> R s s) \<Longrightarrow> (s,[]) \<in> sub_big_steps A R s"
|
|
by (blast intro: nil)
|
|
|
|
lemma big_steps_enabled:
|
|
assumes ss: "serial_system_weak A I"
|
|
assumes rt: "rel_terminate A s0 R I measuref"
|
|
assumes s_I: "s \<in> I"
|
|
assumes nrefl: "\<And>s. \<not> R s s"
|
|
shows "\<exists>s0'\<in> Init A s0. R\<^sup>*\<^sup>* s0' s \<Longrightarrow> \<exists>x s'. (s, s') \<in> big_steps A R exmap x"
|
|
apply (frule rel_terminate_terminates[OF ss rt s_I])
|
|
apply (drule_tac x="[]" in spec)
|
|
apply (erule impE[OF _ sub_big_steps_nrefl])
|
|
apply (rule nrefl)
|
|
apply (fastforce intro: cstep)
|
|
done
|
|
|
|
text \<open>
|
|
We assume here that there is only one event that can ever occur. This
|
|
is overly restrictive in general, but should be fine for the seL4
|
|
automata (which shouldn't need multiple event labels since it should only
|
|
ever be able to perform one event in each state).
|
|
\<close>
|
|
lemma Step_system_to_enabled_system:
|
|
assumes single_event: "(\<forall>(x::'b) (y::'b). x = y)"
|
|
assumes st: "Step_system A s0"
|
|
assumes en: "\<And>s. system.reachable A s0 s \<Longrightarrow> \<exists>(x::'b) s'. (s,s') \<in> system.Step A x"
|
|
shows "enabled_system A s0"
|
|
apply (clarsimp simp: enabled_system_def)
|
|
proof -
|
|
fix s js jsa
|
|
assume a: "s \<in> execution A s0 js"
|
|
show "\<exists>s'. s' \<in> execution A s jsa"
|
|
proof -
|
|
have er: "\<And>as. execution A s as = {s'. (s,s') \<in> Run (system.Step A) as}"
|
|
apply (rule Step_system.execution_Run[OF st])
|
|
using a apply (fastforce simp: system.reachable_def)
|
|
done
|
|
show ?thesis
|
|
apply (induct jsa rule: rev_induct)
|
|
apply (simp add: er)
|
|
apply (clarsimp simp: er)
|
|
apply (cut_tac s=s' in en)
|
|
apply (rule Step_system.reachable_execution[OF st])
|
|
using a apply (fastforce simp: system.reachable_def)
|
|
apply (simp add: er)
|
|
apply clarify
|
|
apply (rename_tac b s'a)
|
|
apply (rule_tac x=s'a in exI)
|
|
apply (rule Run_trans, assumption)
|
|
apply (rule system_Step_one)
|
|
apply (cut_tac x=b and xa=x in single_event[rule_format], simp)
|
|
done
|
|
qed
|
|
qed
|
|
|
|
lemma steps_subset:
|
|
"A \<subseteq> B \<Longrightarrow> steps steps1 A as \<subseteq> steps steps1 B as"
|
|
apply (simp add: steps_def Image_def)
|
|
apply (induct as rule: rev_induct)
|
|
apply simp
|
|
apply force
|
|
done
|
|
|
|
|
|
locale Init_Fin_serial_weak = serial_system_weak +
|
|
assumes Init_Fin: "\<And>s'. s' \<in> I \<Longrightarrow> s' \<in> Init A (Fin A s')"
|
|
assumes s0_I: "Init A s0 \<subseteq> I"
|
|
begin
|
|
|
|
lemma enabled:
|
|
"enabled_system A s0"
|
|
supply image_cong_simp[cong del]
|
|
supply ex_image_cong_iff [simp del]
|
|
apply (clarsimp simp: enabled_system_def)
|
|
apply (rename_tac jsa, induct_tac jsa rule: rev_induct)
|
|
apply (clarsimp simp: execution_def steps_def)
|
|
apply (fold steps_def)
|
|
apply (rule_tac x="Fin A x" in exI)
|
|
apply (rule imageI)
|
|
apply (rule Init_Fin)
|
|
apply (rule set_mp)
|
|
apply (rule inv_holds_steps[OF I])
|
|
apply (rule s0_I)
|
|
apply simp
|
|
apply (clarsimp simp: execution_def steps_def)
|
|
apply (fold steps_def)
|
|
apply (subgoal_tac "steps (data_type.Step A) (Init A (Fin A xa)) xs \<inter> I \<noteq> {}")
|
|
apply (erule nonemptyE)
|
|
apply clarsimp
|
|
apply (drule_tac a=x in serial)
|
|
apply clarsimp
|
|
apply (rule_tac x="Fin A t" in exI)
|
|
apply (rule imageI)
|
|
apply (rule ImageI)
|
|
apply assumption
|
|
apply assumption
|
|
apply (cut_tac inv_holds_steps[OF I s0_I])
|
|
apply (drule (1) subsetD)
|
|
apply (cut_tac B="{xa}" and as=xs in inv_holds_steps[OF I])
|
|
apply simp
|
|
apply (cut_tac B="{xa}" and as=xs in step_serial)
|
|
apply simp+
|
|
apply (cut_tac A="{xa}" and B="Init A (Fin A xa)" in steps_subset)
|
|
apply (simp add: Init_Fin)
|
|
apply force
|
|
done
|
|
|
|
end
|
|
|
|
|
|
lemma invariant_holds_steps:
|
|
assumes I: "A \<Turnstile> I"
|
|
assumes start_I: "B \<subseteq> I"
|
|
shows "steps (Simulation.Step A) B as \<subseteq> I"
|
|
apply clarsimp
|
|
apply (induct as rule: rev_induct)
|
|
apply (simp add: steps_def)
|
|
apply (rule set_mp)
|
|
apply (rule start_I)
|
|
apply simp
|
|
apply (simp add: steps_def)
|
|
apply (erule ImageE)
|
|
apply (drule_tac x=xb in meta_spec)
|
|
apply simp
|
|
apply (rule set_mp)
|
|
apply (rule I[simplified invariant_holds_def, THEN conjunct2,rule_format])
|
|
apply (rule ImageI)
|
|
apply assumption
|
|
apply simp
|
|
done
|
|
|
|
|
|
locale serial_system = system +
|
|
fixes I
|
|
assumes I: "A \<Turnstile> I"
|
|
assumes serial: "\<And>s' a. s' \<in> I \<Longrightarrow> (\<exists>t. (s', t) \<in> data_type.Step A a)"
|
|
begin
|
|
|
|
lemma step_serial:
|
|
assumes nonempty_start: "B \<noteq> {}"
|
|
assumes invariant_start: "B \<subseteq> I"
|
|
shows "steps (Simulation.Step A) B as \<noteq> {}"
|
|
apply (induct as rule: rev_induct)
|
|
apply (simp add: steps_def nonempty_start)
|
|
apply (erule nonemptyE)
|
|
apply (frule set_mp[OF invariant_holds_steps[OF I invariant_start]])
|
|
apply (frule_tac a=x in serial)
|
|
apply (elim exE)
|
|
apply (rule_tac x=t in notemptyI)
|
|
apply (fastforce simp: steps_def)
|
|
done
|
|
|
|
lemma fw_sim_serial:
|
|
assumes refines: "LI B A R (I_b \<times> I_a)"
|
|
assumes B_I_b: "B \<Turnstile> I_b'"
|
|
assumes A_I_as: "I \<subseteq> I_a"
|
|
assumes B_I_bs': "I_b' \<subseteq> I_b"
|
|
assumes constrained_B: "\<And>s. s \<in> I_b' \<Longrightarrow> \<exists>s'. s' \<in> I \<and> (s,s') \<in> R"
|
|
shows "serial_system B I_b'"
|
|
apply unfold_locales
|
|
apply (rule B_I_b)
|
|
apply (insert refines)
|
|
apply (clarsimp simp: LI_def)
|
|
apply (drule_tac x=a in spec)
|
|
apply (frule_tac s=s' in constrained_B)
|
|
apply clarsimp
|
|
apply (frule_tac a=a in serial)
|
|
apply (clarsimp simp: rel_semi_def)
|
|
apply (cut_tac B_I_bs' A_I_as)
|
|
apply blast
|
|
done
|
|
|
|
end
|
|
|
|
|
|
locale Init_Fin_serial = serial_system +
|
|
assumes Init_Fin: "\<And>s'. s' \<in> I \<Longrightarrow> s' \<in> Init A (Fin A s')"
|
|
assumes s0_I: "Init A s0 \<subseteq> I"
|
|
begin
|
|
|
|
lemma enabled:
|
|
"enabled_system A s0"
|
|
supply image_cong_simp [cong del]
|
|
supply ex_image_cong_iff [simp del]
|
|
apply (clarsimp simp: enabled_system_def)
|
|
apply (induct_tac jsa rule: rev_induct)
|
|
apply (clarsimp simp: execution_def steps_def)
|
|
apply (fold steps_def)
|
|
apply (rule_tac x="Fin A x" in exI)
|
|
apply (rule imageI)
|
|
apply (rule Init_Fin)
|
|
apply (rule set_mp)
|
|
apply (rule invariant_holds_steps[OF I])
|
|
apply (rule s0_I)
|
|
apply simp
|
|
apply (clarsimp simp: execution_def steps_def)
|
|
apply (fold steps_def)
|
|
apply (subgoal_tac "xb \<in> I")
|
|
apply (drule_tac a=x in serial)
|
|
apply clarsimp
|
|
apply (rule_tac x="Fin A t" in exI)
|
|
apply (rule imageI)
|
|
apply (rule ImageI)
|
|
apply assumption
|
|
apply assumption
|
|
apply (rule set_mp)
|
|
apply (rule invariant_holds_steps[OF I])
|
|
prefer 2
|
|
apply assumption
|
|
apply (rule I[simplified invariant_holds_def, THEN conjunct1,rule_format])
|
|
done
|
|
|
|
end
|
|
|
|
|
|
sublocale Init_Fin_serial \<subseteq> enabled_system by (rule enabled)
|
|
|
|
sublocale Init_Fin_serial \<subseteq> Init_Fin_serial_weak
|
|
using I by unfold_locales (auto simp add: inv_holds_def invariant_holds_def elim: serial Init_Fin)
|
|
|
|
lemma (in Init_Fin_serial) serial_to_weak:
|
|
"Init_Fin_serial_weak A s0 I"
|
|
by intro_locales
|
|
|
|
definition inv_from_rel :: "('a, 'b, 'j) data_type \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set" where
|
|
"inv_from_rel A s0 R \<equiv> {s. \<exists>s0'\<in> Init A s0. R\<^sup>*\<^sup>* s0' s}"
|
|
|
|
lemma big_step_adt_R_tranclp_inv:
|
|
"big_step_adt C R exmap [> inv_from_rel C s0 R"
|
|
apply (rule inv_holdsI)
|
|
apply (clarsimp simp: big_step_adt_def inv_from_rel_def Fin_trancl_def)
|
|
apply (rule_tac x="s0'" in bexI)
|
|
apply (force elim: big_steps.cases)
|
|
apply simp
|
|
done
|
|
|
|
lemma big_steps_I_holds:
|
|
"\<lbrakk> (xa, x) \<in> big_steps A R exmap j; xa \<in> I; A [> I \<rbrakk>
|
|
\<Longrightarrow> x \<in> I"
|
|
apply (erule big_stepsE)
|
|
apply (frule sub_big_steps_I_holds, assumption+)
|
|
apply (simp add: inv_holds_def)
|
|
apply blast
|
|
done
|
|
|
|
lemma big_step_adt_inv_holds:
|
|
"A [> I \<Longrightarrow> big_step_adt A R exmap [> I"
|
|
apply (simp add: big_step_adt_def inv_holds_def)
|
|
apply clarsimp
|
|
apply (rule big_steps_I_holds, assumption+)
|
|
apply (simp add: inv_holds_def)
|
|
done
|
|
|
|
lemma big_step_adt_Init_Fin_serial_weak:
|
|
assumes single_event: "\<forall>(x::'b) (y::'b). x = y"
|
|
assumes nrefl: "\<And>s. \<not> R s s"
|
|
assumes ifsw: "Init_Fin_serial_weak A s0 I"
|
|
assumes rt: "rel_terminate A s0 R I measuref"
|
|
assumes J_def: "J = inv_from_rel A s0 R \<inter> I"
|
|
shows "Init_Fin_serial_weak (big_step_adt A R (exmap::('a list \<Rightarrow> 'b))) s0 J"
|
|
using ifsw
|
|
apply (unfold_locales)
|
|
apply (simp add: J_def)
|
|
apply (rule inv_holds_conjI)
|
|
apply (rule big_step_adt_R_tranclp_inv)
|
|
apply (rule big_step_adt_inv_holds)
|
|
apply (simp add: Init_Fin_serial_weak_def serial_system_weak.I)
|
|
apply (simp add: big_step_adt_def J_def inv_from_rel_def)
|
|
apply (elim conjE exE)
|
|
apply (cut_tac s=s' and I=I and exmap=exmap in big_steps_enabled)
|
|
apply (force simp: Init_Fin_serial_weak_def)
|
|
apply (rule rt)
|
|
apply assumption
|
|
apply (simp add: nrefl)
|
|
apply simp
|
|
apply clarsimp
|
|
apply (cut_tac x=x and xa=a in single_event[rule_format])
|
|
apply blast
|
|
apply (simp add: J_def big_step_adt_def Init_Fin_serial_weak.Init_Fin)
|
|
apply (simp add: big_step_adt_def Init_Fin_serial_weak.s0_I J_def inv_from_rel_def, force)
|
|
done
|
|
|
|
lemma big_step_adt_enabled_system:
|
|
assumes single_event: "\<forall>(x::'b) (y::'b). x = y"
|
|
assumes nrefl: "\<And>s. \<not> R s s"
|
|
assumes ifsw: "Init_Fin_serial_weak A s0 I"
|
|
assumes rt: "rel_terminate A s0 R I measuref"
|
|
shows "enabled_system (big_step_adt A R (exmap::('a list \<Rightarrow> 'b))) s0"
|
|
apply (cut_tac big_step_adt_Init_Fin_serial_weak[OF single_event nrefl ifsw rt])
|
|
apply (erule Init_Fin_serial_weak.enabled)
|
|
apply simp
|
|
done
|
|
|
|
(* For reachability in big_step_adt we need to consider internal reachability. *)
|
|
definition reachable_i where
|
|
"reachable_i A s0 s \<equiv> \<exists>js. (s0, s) \<in> Run (Step A) js"
|
|
|
|
lemma sub_big_steps_Run:
|
|
"(t,evlist) \<in> sub_big_steps A R s \<Longrightarrow> (s, t) \<in> Run (Step A) evlist \<and> \<not> R s t"
|
|
apply (induct t evlist rule: sub_big_steps.induct)
|
|
apply simp
|
|
apply clarsimp
|
|
apply (rule Run_trans)
|
|
apply assumption
|
|
apply simp
|
|
done
|
|
|
|
lemma big_step_adt_reachable_i_states:
|
|
"(s0, s) \<in> Run (Step (big_step_adt C R exmap)) js \<Longrightarrow> \<exists>js. (s0, s) \<in> Run (Step C) js"
|
|
apply (induct js arbitrary: s0)
|
|
apply (rule_tac x="[]" in exI, simp)
|
|
apply (clarsimp simp: big_step_adt_def)
|
|
apply (rename_tac s0 sa)
|
|
apply (erule big_stepsE)
|
|
apply (drule sub_big_steps_Run)
|
|
apply (subgoal_tac "(s0,sa) \<in> Run (data_type.Step C) (as@[aa])")
|
|
apply (blast intro: Run_trans)
|
|
apply (fastforce intro: Run_trans)
|
|
done
|
|
|
|
lemma reachable_i_big_step_adt:
|
|
"reachable_i (big_step_adt C R exmap) s0 s \<Longrightarrow> reachable_i C s0 s"
|
|
apply (clarsimp simp: reachable_i_def)
|
|
apply (blast intro: big_step_adt_reachable_i_states)
|
|
done
|
|
|
|
lemma steps_eq_Run:
|
|
"(s' \<in> steps (Step A) (Init A s0) js) =
|
|
(\<exists>s0'. s0' \<in> Init A s0 \<and> (s0', s') \<in> Run (Step A) js)"
|
|
apply (rule iffI)
|
|
apply (clarsimp simp: steps_def image_def Image_def)
|
|
apply (induct js arbitrary: s' rule: rev_induct)
|
|
apply simp
|
|
apply (force intro: Run_trans)
|
|
apply (clarsimp simp: steps_def image_def Image_def)
|
|
apply (induct js arbitrary: s' rule: rev_induct)
|
|
apply simp
|
|
apply clarsimp
|
|
apply (drule Run_mid, force)
|
|
done
|
|
|
|
lemma reachable_reachable_i:
|
|
"system.reachable A s0 s \<Longrightarrow> \<exists>s0' s'. s0' \<in> Init A s0 \<and> Fin A s' = s \<and> reachable_i A s0' s'"
|
|
by (force simp: system.reachable_def reachable_i_def execution_def steps_eq_Run)
|
|
|
|
lemma reachable_i_reachable:
|
|
"\<lbrakk> reachable_i A s0' s'; s0' \<in> Init A s0; Fin A s' = s \<rbrakk>
|
|
\<Longrightarrow> system.reachable A s0 s"
|
|
by (force simp: system.reachable_def reachable_i_def execution_def steps_eq_Run)
|
|
|
|
lemma reachable_big_step_adt:
|
|
"system.reachable (big_step_adt C R exmap) s0 s
|
|
\<Longrightarrow> system.reachable C s0 s"
|
|
by (force dest: reachable_reachable_i
|
|
intro: reachable_i_reachable reachable_i_big_step_adt
|
|
simp: big_step_adt_def)
|
|
|
|
lemma big_step_adt_Init_inv_Fin_system:
|
|
"Init_inv_Fin_system A s0 \<Longrightarrow> Init_inv_Fin_system (big_step_adt A R exmap) s0"
|
|
apply (clarsimp simp: Init_inv_Fin_system_def big_step_adt_def)
|
|
apply (erule_tac x=s in allE)
|
|
apply (force intro: reachable_big_step_adt simp: big_step_adt_def)
|
|
done
|
|
|
|
lemma big_step_adt_Step_system:
|
|
"Init_inv_Fin_system C s0 \<Longrightarrow> Step_system (big_step_adt C R exmap) s0"
|
|
apply (rule Init_Fin_system_Step_system)
|
|
apply (rule Init_inv_Fin_system_Init_Fin_system)
|
|
apply (rule big_step_adt_Init_inv_Fin_system)
|
|
apply simp
|
|
done
|
|
|
|
lemma big_step_adt_enabled_Step_system:
|
|
assumes single_event: "\<forall>(x::'b) (y::'b). x = y"
|
|
assumes nrefl: "\<And>s. \<not> R s s"
|
|
assumes ifsw: "Init_Fin_serial_weak A s0 I"
|
|
assumes iifs: "Init_inv_Fin_system A s0"
|
|
assumes rt: "rel_terminate A s0 R I measuref"
|
|
shows "enabled_Step_system (big_step_adt A R (examp::('a list \<Rightarrow> 'b))) s0"
|
|
using assms
|
|
by (simp add: enabled_Step_system_def big_step_adt_Step_system big_step_adt_enabled_system)
|
|
|
|
|
|
section \<open>ADT_A_if definition and enabledness\<close>
|
|
|
|
subsection \<open>global_automaton_if definition\<close>
|
|
|
|
text \<open>
|
|
We define a bunch of states that the system can be in. The first two
|
|
are when the processor is in user mode, the final four are for when in
|
|
kernel mode.
|
|
- in user mode (a user-level thread is running)
|
|
- in idle mode (the idle thread is running)
|
|
- kernel entry for some event e (kernel entry is occurring)
|
|
- in kernel mode where kernel execution has been pre-empted by interrupt
|
|
arrival
|
|
- in kernel mode where the scheduler is about to execute -- the boolean here
|
|
is ghost state to capture when the schedule event follows interrupt-handling
|
|
(i.e. is True when the previous mode was KernelEntry Interrupt or KernelPreempted)
|
|
- in kernel mode, about to exit to userspace
|
|
\<close>
|
|
datatype sys_mode = InUserMode | InIdleMode |
|
|
KernelEntry event | KernelPreempted |
|
|
KernelSchedule bool | KernelExit
|
|
|
|
type_synonym 'k global_sys_state = "(user_context \<times> 'k) \<times> sys_mode"
|
|
|
|
text \<open>
|
|
We take the @{term global_automaton} and split the kernel transitions
|
|
into multiple steps. This is done because, while the entire execution
|
|
from kernel entry to exit is atomic, different parts of it need to be
|
|
considered as being done on behalf of different domains. For instance,
|
|
the part that does kernel entry and then handles the event should happen
|
|
on behalf of the domain of the currently running thread, but the
|
|
part that handles pre-emptions will probably need to purport to happen on
|
|
behalf of the scheduler domain.
|
|
|
|
- a transition for kernel entry on event e (kernel entry happens,
|
|
and we handle the event, possibly gettting pre-empted along the way)
|
|
- a transition for handling those pre-emptions
|
|
- a transition for running the scheduler at the end of every kernel event
|
|
- a transition for kernel exit
|
|
|
|
TODO: schedule and kernel exit may be able to be put into the same
|
|
transition. It depends on what domain each transition needs to
|
|
purport to run on behalf of
|
|
|
|
We also have the user operations possibly give an event, which gives us
|
|
a handle on modelling when user programs request system calls or cause
|
|
other exceptions to occur.
|
|
\<close>
|
|
definition global_automaton_if ::
|
|
"((user_context \<times> 'k) \<times> irq option \<times> (user_context \<times> 'k)) set
|
|
\<Rightarrow> ((user_context \<times> 'k) \<times> event option \<times> (user_context \<times> 'k)) set
|
|
\<Rightarrow> (event \<Rightarrow> ((user_context \<times> 'k) \<times> bool \<times> (user_context \<times> 'k)) set)
|
|
\<Rightarrow> (((user_context \<times> 'k) \<times> unit \<times> (user_context \<times> 'k)) set)
|
|
\<Rightarrow> (((user_context \<times> 'k) \<times> unit \<times> (user_context \<times> 'k)) set)
|
|
\<Rightarrow> (((user_context \<times> 'k) \<times> sys_mode \<times> (user_context \<times> 'k)) set)
|
|
\<Rightarrow> ('k global_sys_state \<times> 'k global_sys_state) set" where
|
|
"global_automaton_if get_active_irqf do_user_opf kernel_callf preemptionf schedulef kernel_exitf \<equiv>
|
|
\<comment> \<open>Kernel entry with preemption during event handling
|
|
NOTE: kernel cannot be preempted while servicing an interrupt\<close>
|
|
{((s, KernelEntry e),
|
|
(s', KernelPreempted)) | s s' e. (s, True, s') \<in> kernel_callf e \<and> e \<noteq> Interrupt} \<union>
|
|
\<comment> \<open>kernel entry without preemption during event handling\<close>
|
|
{((s, KernelEntry e),
|
|
(s', KernelSchedule (e = Interrupt))) | s s' e. (s, False, s') \<in> kernel_callf e } \<union>
|
|
\<comment> \<open>handle in-kernel preemption\<close>
|
|
{((s, KernelPreempted), (s', KernelSchedule True)) | s s'. (s, (), s') \<in> preemptionf } \<union>
|
|
\<comment> \<open>schedule\<close>
|
|
{((s, KernelSchedule b), (s', KernelExit)) | s s' b. (s, (), s') \<in> schedulef } \<union>
|
|
\<comment> \<open>kernel exit\<close>
|
|
{((s, KernelExit), (s', m)) | s s' m. (s, m, s') \<in> kernel_exitf } \<union>
|
|
\<comment> \<open>User runs, causes exception\<close>
|
|
{((s, InUserMode), (s', KernelEntry e)) | s s_aux s' e. (s, None, s_aux) \<in> get_active_irqf \<and>
|
|
(s_aux, Some e, s') \<in> do_user_opf \<and>
|
|
e \<noteq> Interrupt} \<union>
|
|
\<comment> \<open>User runs, no exception happens\<close>
|
|
{((s, InUserMode), (s', InUserMode) ) | s s_aux s'. (s, None, s_aux) \<in> get_active_irqf \<and>
|
|
(s_aux, None, s') \<in> do_user_opf} \<union>
|
|
\<comment> \<open>Interrupt while in user mode\<close>
|
|
{((s, InUserMode), (s', KernelEntry Interrupt)) | s s' i. (s, Some i, s') \<in> get_active_irqf} \<union>
|
|
\<comment> \<open>Interrupt while in idle mode\<close>
|
|
{((s, InIdleMode), (s', KernelEntry Interrupt)) | s s' i. (s, Some i, s') \<in> get_active_irqf} \<union>
|
|
\<comment> \<open>No interrupt while in idle mode\<close>
|
|
{((s, InIdleMode), (s', InIdleMode)) | s s'. (s, None, s') \<in> get_active_irqf}"
|
|
|
|
|
|
subsection \<open>do_user_op_if\<close>
|
|
|
|
definition do_user_op_A_if ::
|
|
"user_transition_if
|
|
\<Rightarrow> ((user_context \<times> det_state) \<times> event option \<times> (user_context \<times> det_state)) set" where
|
|
"do_user_op_A_if uop \<equiv>
|
|
{(s,e,(tc,s'))| s e tc s'. ((e,tc),s') \<in> fst (split (do_user_op_if uop) s)}"
|
|
|
|
lemma no_irq_user_memory_update[simp]:
|
|
"no_irq (user_memory_update a)"
|
|
by (wpsimp simp: no_irq_def user_memory_update_def)
|
|
|
|
lemma no_irq_device_memory_update[simp]:
|
|
"no_irq (device_memory_update a)"
|
|
by (wpsimp simp: no_irq_def device_memory_update_def)
|
|
|
|
|
|
subsection \<open>kernel_entry_if\<close>
|
|
|
|
text \<open>
|
|
Enter the kernel, and handle the event. Leave the user context
|
|
unchanged; although it shouldn't matter really what its value is
|
|
while we are still in kernel mode.
|
|
\<close>
|
|
definition kernel_entry_if ::
|
|
"event \<Rightarrow> user_context \<Rightarrow> (((unit + unit) \<times> user_context),det_ext) s_monad" where
|
|
"kernel_entry_if e tc \<equiv>
|
|
do t \<leftarrow> gets cur_thread;
|
|
thread_set (\<lambda>tcb. tcb \<lparr>tcb_arch := arch_tcb_context_set tc (tcb_arch tcb)\<rparr>) t;
|
|
r \<leftarrow> handle_event e;
|
|
return (r,tc)
|
|
od"
|
|
|
|
crunch cur_domain[wp]: kernel_entry_if "\<lambda>s. P (cur_domain s)"
|
|
crunch idle_thread[wp]: kernel_entry_if "\<lambda>s::det_state. P (idle_thread s)"
|
|
crunch cur_thread [wp]: kernel_entry_if "\<lambda>s::det_state. P (cur_thread s)"
|
|
|
|
lemma thread_set_tcb_context_update_ct_active[wp]:
|
|
"thread_set (tcb_arch_update (arch_tcb_context_set f)) t \<lbrace>ct_active\<rbrace>"
|
|
apply (simp add: thread_set_def ct_in_state_def | wp set_object_wp)+
|
|
apply (clarsimp simp: st_tcb_at_def obj_at_def get_tcb_def)
|
|
done
|
|
|
|
lemma thread_set_tcb_context_update_not_ct_active[wp]:
|
|
"thread_set (tcb_arch_update (arch_tcb_context_set f)) t \<lbrace>\<lambda>s. \<not> ct_active s\<rbrace>"
|
|
apply (simp add: thread_set_def ct_in_state_def | wp set_object_wp)+
|
|
apply (clarsimp simp: st_tcb_at_def obj_at_def get_tcb_def
|
|
split: kernel_object.splits option.splits)
|
|
done
|
|
|
|
lemma kernel_entry_if_invs:
|
|
"\<lbrace>invs and (\<lambda>s. e \<noteq> Interrupt \<longrightarrow> ct_active s)\<rbrace>
|
|
kernel_entry_if e tc
|
|
\<lbrace>\<lambda>_. invs\<rbrace>"
|
|
unfolding kernel_entry_if_def
|
|
by (wpsimp wp: thread_set_invs_trivial static_imp_wp
|
|
simp: arch_tcb_update_aux2 ran_tcb_cap_cases)+
|
|
|
|
lemma kernel_entry_if_globals_equiv:
|
|
"\<lbrace>invs and (\<lambda>s. e \<noteq> Interrupt \<longrightarrow> ct_active s) and globals_equiv st
|
|
and (\<lambda>s. ct_idle s \<longrightarrow> tc = idle_context s)\<rbrace>
|
|
kernel_entry_if e tc
|
|
\<lbrace>\<lambda>_. globals_equiv st\<rbrace>"
|
|
apply (simp add: kernel_entry_if_def)
|
|
apply (wp static_imp_wp handle_event_globals_equiv
|
|
thread_set_invs_trivial thread_set_context_globals_equiv
|
|
| simp add: ran_tcb_cap_cases arch_tcb_update_aux2)+
|
|
apply (clarsimp simp: cur_thread_idle)
|
|
done
|
|
|
|
lemma thread_set_tcb_context_update_neg_cte_wp_at[wp]:
|
|
"thread_set (tcb_arch_update f) t \<lbrace>\<lambda>s. \<not> cte_wp_at P slot s\<rbrace>"
|
|
apply (simp add: thread_set_def)
|
|
apply (wp set_object_wp get_object_wp | simp)+
|
|
apply (case_tac "t = fst slot")
|
|
apply (clarsimp split: kernel_object.splits)
|
|
apply (erule notE)
|
|
apply (erule cte_wp_atE)
|
|
apply (fastforce simp: obj_at_def)
|
|
apply (drule get_tcb_SomeD)
|
|
apply (rule cte_wp_at_tcbI)
|
|
apply (simp)
|
|
apply assumption
|
|
apply (fastforce simp: tcb_cap_cases_def split: if_splits)
|
|
apply (fastforce elim: cte_wp_atE intro: cte_wp_at_cteI cte_wp_at_tcbI)
|
|
done
|
|
|
|
lemma thread_set_tcb_context_update_domain_sep_inv[wp]:
|
|
"thread_set (tcb_arch_update f) t \<lbrace>domain_sep_inv irqs st\<rbrace>"
|
|
by (wp domain_sep_inv_triv)
|
|
|
|
lemma kernel_entry_silc_inv[wp]:
|
|
"\<lbrace>silc_inv aag st and einvs and simple_sched_action and (\<lambda>s. ev \<noteq> Interrupt \<longrightarrow> ct_active s)
|
|
and pas_refined aag and (\<lambda>s. ct_active s \<longrightarrow> is_subject aag (cur_thread s))
|
|
and domain_sep_inv (pasMaySendIrqs aag) st'\<rbrace>
|
|
kernel_entry_if ev tc
|
|
\<lbrace>\<lambda>_. silc_inv aag st\<rbrace>"
|
|
unfolding kernel_entry_if_def
|
|
by (wpsimp simp: ran_tcb_cap_cases arch_tcb_update_aux2
|
|
wp: static_imp_wp handle_event_silc_inv thread_set_silc_inv thread_set_invs_trivial
|
|
thread_set_not_state_valid_sched thread_set_pas_refined
|
|
| wp (once) hoare_vcg_imp_lift | force)+
|
|
|
|
|
|
subsection \<open>handle_preemption_if\<close>
|
|
|
|
text \<open>
|
|
Since this executes entirely in kernel mode, leave the
|
|
user context unchanged
|
|
\<close>
|
|
definition handle_preemption_if :: "user_context \<Rightarrow> (user_context,det_ext) s_monad" where
|
|
"handle_preemption_if tc \<equiv>
|
|
do irq \<leftarrow> do_machine_op (getActiveIRQ True);
|
|
when (irq \<noteq> None) $ handle_interrupt (the irq);
|
|
return tc
|
|
od"
|
|
|
|
|
|
subsection \<open>schedule_if\<close>
|
|
|
|
text \<open>
|
|
Since this executes entirely in kernel mode, leave the
|
|
user context unchanged
|
|
\<close>
|
|
definition schedule_if :: "user_context \<Rightarrow> (user_context,det_ext) s_monad" where
|
|
"schedule_if tc \<equiv>
|
|
do schedule;
|
|
activate_thread;
|
|
return tc
|
|
od"
|
|
|
|
crunch silc_inv[wp]: schedule_if "silc_inv aag st"
|
|
crunch domain_sep_inv[wp]: schedule_if "\<lambda>s :: det_state. domain_sep_inv irqs st s"
|
|
crunch idle_thread[wp]: activate_thread "\<lambda>s :: det_state. P (idle_thread s)"
|
|
crunch cur_domain[wp]: activate_thread "\<lambda>s. P (cur_domain s)"
|
|
|
|
function (domintros) next_irq_state :: "nat \<Rightarrow> (irq \<Rightarrow> bool) \<Rightarrow> nat" where
|
|
"next_irq_state cur masks =
|
|
(if irq_at cur masks = None then next_irq_state (Suc cur) masks else cur)"
|
|
by (pat_completeness, auto)
|
|
|
|
definition irq_measure_if where
|
|
"irq_measure_if s \<equiv> let cur = Suc (irq_state (machine_state s))
|
|
in (next_irq_state cur (irq_masks (machine_state s))) - cur"
|
|
|
|
definition irq_measure_if_inv where
|
|
"irq_measure_if_inv st s \<equiv> irq_measure_if (s::det_state) \<le> irq_measure_if (st::det_state)"
|
|
|
|
definition irq_state_inv where
|
|
"irq_state_inv (st :: det_state) (s :: det_state) \<equiv>
|
|
irq_state (machine_state s) \<ge> irq_state (machine_state st) \<and>
|
|
irq_masks (machine_state s) = irq_masks (machine_state st) \<and>
|
|
next_irq_state (Suc (irq_state (machine_state s))) (irq_masks (machine_state s)) =
|
|
next_irq_state (Suc (irq_state (machine_state st))) (irq_masks (machine_state s))"
|
|
|
|
definition irq_state_next where
|
|
"irq_state_next (st :: det_state) (s :: det_state) \<equiv>
|
|
irq_state (machine_state s) \<ge> irq_state (machine_state st) \<and>
|
|
irq_masks (machine_state s) = irq_masks (machine_state st) \<and>
|
|
irq_state (machine_state s) = next_irq_state (Suc (irq_state (machine_state st)))
|
|
(irq_masks (machine_state s))"
|
|
|
|
|
|
locale ADT_IF_1 =
|
|
fixes initial_aag :: "'a subject_label PAS"
|
|
assumes do_user_op_if_invs[wp]:
|
|
"do_user_op_if uop tc \<lbrace>invs and ct_running :: det_state \<Rightarrow> bool\<rbrace>"
|
|
and do_user_op_if_domain_sep_inv[wp]:
|
|
"do_user_op_if uop tc \<lbrace>\<lambda>s. domain_sep_inv irqs (st :: det_state) (s :: det_state)\<rbrace>"
|
|
and do_user_op_if_valid_sched[wp]:
|
|
"do_user_op_if uop tc \<lbrace>valid_sched\<rbrace>"
|
|
and do_user_op_if_irq_masks[wp]:
|
|
"\<And>P. do_user_op_if uop tc \<lbrace>\<lambda>s. P (irq_masks_of_state s)\<rbrace>"
|
|
and do_user_op_if_valid_list[wp]:
|
|
"do_user_op_if uop tc \<lbrace>valid_list\<rbrace>"
|
|
and do_user_op_if_scheduler_action[wp]:
|
|
"\<And>P. do_user_op_if uop tc \<lbrace>\<lambda>s. P (scheduler_action s)\<rbrace>"
|
|
and do_user_op_silc_inv[wp]:
|
|
"do_user_op_if uop tc \<lbrace>silc_inv (aag :: 'a subject_label PAS) st\<rbrace>"
|
|
and do_user_op_pas_refined[wp]:
|
|
"do_user_op_if uop tc \<lbrace>pas_refined aag\<rbrace>"
|
|
and do_user_op_cur_thread[wp]:
|
|
"\<And>P. do_user_op_if uop tc \<lbrace>\<lambda>s :: det_state. P (cur_thread s)\<rbrace>"
|
|
and do_user_op_cur_domain[wp]:
|
|
"\<And>P. do_user_op_if uop tc \<lbrace>\<lambda>s. P (cur_domain s)\<rbrace>"
|
|
and do_user_op_idle_thread[wp]:
|
|
"\<And>P. do_user_op_if uop tc \<lbrace>\<lambda>s :: det_state. P (idle_thread s)\<rbrace>"
|
|
and do_user_op_domain_fields[wp]:
|
|
"\<And>P. do_user_op_if uop tc \<lbrace>domain_fields P\<rbrace>"
|
|
and do_use_op_guarded_pas_domain[wp]:
|
|
"do_user_op_if uop tc \<lbrace>guarded_pas_domain aag\<rbrace>"
|
|
and tcb_arch_ref_tcb_context_set[simp]:
|
|
"tcb_arch_ref (tcb_arch_update (arch_tcb_context_set uc) tcb) = tcb_arch_ref tcb"
|
|
and arch_switch_to_idle_thread_pspace_aligned[wp]:
|
|
"arch_switch_to_idle_thread \<lbrace>\<lambda>s :: det_ext state. pspace_aligned s\<rbrace>"
|
|
and arch_switch_to_idle_thread_valid_vspace_objs[wp]:
|
|
"arch_switch_to_idle_thread \<lbrace>\<lambda>s :: det_ext state. valid_vspace_objs s\<rbrace>"
|
|
and arch_switch_to_idle_thread_valid_arch_state[wp]:
|
|
"arch_switch_to_idle_thread \<lbrace>\<lambda>s :: det_ext state. valid_arch_state s\<rbrace>"
|
|
and arch_switch_to_thread_pspace_aligned[wp]:
|
|
"arch_switch_to_thread t \<lbrace>\<lambda>s :: det_ext state. pspace_aligned s\<rbrace>"
|
|
and arch_switch_to_thread_valid_vspace_objs[wp]:
|
|
"arch_switch_to_thread t \<lbrace>\<lambda>s :: det_ext state. valid_vspace_objs s\<rbrace>"
|
|
and arch_switch_to_thread_valid_arch_state[wp]:
|
|
"arch_switch_to_thread t \<lbrace>\<lambda>s :: det_ext state. valid_arch_state s\<rbrace>"
|
|
and arch_switch_to_thread_cur_thread[wp]:
|
|
"\<And>P. arch_switch_to_thread t \<lbrace>\<lambda>s :: det_state. P (cur_thread s)\<rbrace>"
|
|
and arch_activate_idle_thread_cur_thread[wp]:
|
|
"\<And>P. arch_activate_idle_thread t \<lbrace>\<lambda>s :: det_state. P (cur_thread s)\<rbrace>"
|
|
and arch_activate_idle_thread_scheduler_action[wp]:
|
|
"\<And>P. arch_activate_idle_thread t \<lbrace>\<lambda>s :: det_state. P (scheduler_action s)\<rbrace>"
|
|
and handle_vm_fault_domain_fields[wp]:
|
|
"\<And>P. handle_vm_fault t vmft \<lbrace>domain_fields P\<rbrace>"
|
|
and handle_hypervisor_fault_domain_fields[wp]:
|
|
"\<And>P. handle_hypervisor_fault t hft \<lbrace>domain_fields P\<rbrace>"
|
|
and arch_perform_invocation_noErr[wp]:
|
|
"\<And>Q. \<lbrace>\<top>\<rbrace> arch_perform_invocation i -, \<lbrace>\<lambda>rv s :: det_state. Q rv s\<rbrace>"
|
|
and arch_invoke_irq_control_noErr[wp]:
|
|
"\<And>Q. \<lbrace>\<top>\<rbrace> arch_invoke_irq_control ici -, \<lbrace>\<lambda>rv s :: det_state. Q rv s\<rbrace>"
|
|
and init_arch_objects_irq_state_of_state[wp]:
|
|
"\<And>P. init_arch_objects new_type ptr num_objects obj_sz refs \<lbrace>\<lambda>s. P (irq_state_of_state s)\<rbrace>"
|
|
and getActiveIRQ_None:
|
|
"(None, s') \<in> fst (do_machine_op (getActiveIRQ in_kernel) (s :: det_state))
|
|
\<Longrightarrow> irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = None"
|
|
and getActiveIRQ_Some:
|
|
"(Some irq, s') \<in> fst (do_machine_op (getActiveIRQ in_kernel) s)
|
|
\<Longrightarrow> irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = Some irq"
|
|
and kernel_entry_if_idle_equiv:
|
|
"\<lbrace>invs and (\<lambda>s. e \<noteq> Interrupt \<longrightarrow> ct_active s) and idle_equiv st
|
|
and (\<lambda>s. ct_idle s \<longrightarrow> tc = idle_context s)\<rbrace>
|
|
kernel_entry_if e tc
|
|
\<lbrace>\<lambda>_. idle_equiv st\<rbrace>"
|
|
and handle_preemption_idle_equiv[wp]:
|
|
"\<lbrace>idle_equiv st and invs\<rbrace> handle_preemption_if tc \<lbrace>\<lambda>_. idle_equiv st\<rbrace>"
|
|
and schedule_if_idle_equiv[wp]:
|
|
"\<lbrace>idle_equiv st and invs\<rbrace> schedule_if tc \<lbrace>\<lambda>_. idle_equiv st\<rbrace>"
|
|
and do_user_op_if_idle_equiv[wp]:
|
|
"\<lbrace>idle_equiv st and invs\<rbrace> do_user_op_if uop tc \<lbrace>\<lambda>_. idle_equiv st\<rbrace>"
|
|
and kernel_entry_if_valid_vspace_objs_if[wp]:
|
|
"\<lbrace>valid_vspace_objs_if and invs and (\<lambda>s. e \<noteq> Interrupt \<longrightarrow> ct_active s)\<rbrace>
|
|
kernel_entry_if e tc
|
|
\<lbrace>\<lambda>_. valid_vspace_objs_if\<rbrace>"
|
|
and handle_preemption_if_valid_pdpt_objs[wp]:
|
|
"handle_preemption_if tc \<lbrace>\<lambda>s. valid_vspace_objs_if s\<rbrace>"
|
|
and schedule_if_valid_pdpt_objs[wp]:
|
|
"schedule_if tc \<lbrace>\<lambda>s. valid_vspace_objs_if s\<rbrace>"
|
|
and do_user_op_if_valid_pdpt_objs[wp]:
|
|
"do_user_op_if uop tc \<lbrace>\<lambda>s :: det_state. valid_vspace_objs_if s\<rbrace>"
|
|
and valid_vspace_objs_if_ms_update[simp]:
|
|
"\<And>f. valid_vspace_objs_if (machine_state_update f s) = valid_vspace_objs_if s"
|
|
and do_user_op_if_irq_state_of_state:
|
|
"\<And>P. do_user_op_if uop tc \<lbrace>\<lambda>s. P (irq_state_of_state s)\<rbrace>"
|
|
and do_user_op_if_irq_masks_of_state:
|
|
"\<And>P. do_user_op_if uop tc \<lbrace>\<lambda>s. P (irq_masks_of_state s)\<rbrace>"
|
|
and do_user_op_if_irq_measure_if:
|
|
"\<And>P. do_user_op_if uop tc \<lbrace>\<lambda>s :: det_state. P (irq_measure_if s)\<rbrace>"
|
|
and invoke_tcb_irq_state_inv:
|
|
"\<lbrace>(\<lambda>s. irq_state_inv st s) and domain_sep_inv False (sta :: det_state)
|
|
and tcb_inv_wf tinv and K (irq_is_recurring irq st)\<rbrace>
|
|
invoke_tcb tinv
|
|
\<lbrace>\<lambda>_ s. irq_state_inv st s\<rbrace>, \<lbrace>\<lambda>_. irq_state_next st\<rbrace>"
|
|
and reset_untyped_cap_irq_state_inv:
|
|
"\<lbrace>irq_state_inv st and K (irq_is_recurring irq st)\<rbrace>
|
|
reset_untyped_cap slot
|
|
\<lbrace>\<lambda>y. irq_state_inv st\<rbrace>, \<lbrace>\<lambda>y. irq_state_next st\<rbrace>"
|
|
and handle_vm_fault_irq_state_of_state[wp]:
|
|
"handle_vm_fault t vmft \<lbrace>\<lambda>s. P (irq_state_of_state s)\<rbrace>"
|
|
and handle_hypervisor_fault_irq_state_of_state[wp]:
|
|
"handle_hypervisor_fault t hft \<lbrace>\<lambda>s. P (irq_state_of_state s)\<rbrace>"
|
|
and create_cap_irq_state_of_state[wp]:
|
|
"create_cap type bits untyped dev sl \<lbrace>\<lambda>s. P (irq_state_of_state s)\<rbrace>"
|
|
and arch_invoke_irq_control_irq_state_of_state[wp]:
|
|
"arch_invoke_irq_control ici \<lbrace>\<lambda>s. P (irq_state_of_state s)\<rbrace>"
|
|
begin
|
|
|
|
lemma kernel_entry_pas_refined[wp]:
|
|
"\<lbrace>pas_refined aag and guarded_pas_domain aag and domain_sep_inv (pasMaySendIrqs aag) st
|
|
and einvs and schact_is_rct
|
|
and (\<lambda>s. ct_active s \<longrightarrow> is_subject aag (cur_thread s))
|
|
and (\<lambda>s. ev \<noteq> Interrupt \<longrightarrow> ct_active s)\<rbrace>
|
|
kernel_entry_if ev tc
|
|
\<lbrace>\<lambda>_. pas_refined aag\<rbrace>"
|
|
unfolding kernel_entry_if_def
|
|
by (wpsimp simp: ran_tcb_cap_cases schact_is_rct_def arch_tcb_update_aux2
|
|
wp: static_imp_wp handle_event_pas_refined thread_set_pas_refined
|
|
guarded_pas_domain_lift thread_set_invs_trivial thread_set_not_state_valid_sched
|
|
| force)+
|
|
|
|
lemma kernel_entry_if_domain_sep_inv:
|
|
"\<lbrace>domain_sep_inv irqs st and einvs and (\<lambda>s. e \<noteq> Interrupt \<longrightarrow> ct_active s)\<rbrace>
|
|
kernel_entry_if e tc
|
|
\<lbrace>\<lambda>_. domain_sep_inv irqs st\<rbrace>"
|
|
unfolding kernel_entry_if_def
|
|
by (wpsimp simp: ran_tcb_cap_cases arch_tcb_update_aux2
|
|
wp: handle_event_domain_sep_inv static_imp_wp
|
|
thread_set_invs_trivial thread_set_not_state_valid_sched)+
|
|
|
|
lemma kernel_entry_if_valid_sched:
|
|
"\<lbrace>valid_sched and invs and (ct_active or ct_idle)
|
|
and (\<lambda>s. (e \<noteq> Interrupt \<longrightarrow> ct_active s) \<and> scheduler_action s = resume_cur_thread)\<rbrace>
|
|
kernel_entry_if e tc
|
|
\<lbrace>\<lambda>_. valid_sched\<rbrace>"
|
|
by (wpsimp simp: kernel_entry_if_def ran_tcb_cap_cases arch_tcb_update_aux2
|
|
wp: handle_event_valid_sched thread_set_invs_trivial hoare_vcg_disj_lift
|
|
thread_set_no_change_tcb_state ct_in_state_thread_state_lift
|
|
thread_set_not_state_valid_sched static_imp_wp)+
|
|
|
|
lemma kernel_entry_if_irq_masks:
|
|
"\<lbrace>(\<lambda>s. P (irq_masks_of_state s)) and domain_sep_inv False st and invs\<rbrace>
|
|
kernel_entry_if e tc
|
|
\<lbrace>\<lambda>_ s. P (irq_masks_of_state s)\<rbrace>"
|
|
by (simp add: kernel_entry_if_def ran_tcb_cap_cases arch_tcb_update_aux2
|
|
| wp handle_event_irq_masks thread_set_invs_trivial | force)+
|
|
|
|
crunches schedule
|
|
for pspace_aligned[wp]: "\<lambda>s :: det_ext state. pspace_aligned s"
|
|
and valid_vspace_objs[wp]: "\<lambda>s :: det_ext state. valid_vspace_objs s"
|
|
and valid_arch_state[wp]: "\<lambda>s :: det_ext state. valid_arch_state s"
|
|
(wp: crunch_wps)
|
|
|
|
crunch pas_refined[wp]: schedule_if "pas_refined aag"
|
|
|
|
crunch cur_thread: activate_thread "\<lambda>s :: det_state. P (cur_thread s)"
|
|
|
|
lemma activate_thread_guarded_pas_domain[wp]:
|
|
"activate_thread \<lbrace>guarded_pas_domain aag\<rbrace>"
|
|
by (rule guarded_pas_domain_lift; wp activate_thread_cur_thread)
|
|
|
|
end
|
|
|
|
|
|
lemma kernel_entry_if_guarded_pas_domain:
|
|
"kernel_entry_if e tc \<lbrace>guarded_pas_domain aag\<rbrace>"
|
|
apply (simp add: kernel_entry_if_def)
|
|
apply (wp guarded_pas_domain_lift)
|
|
done
|
|
|
|
crunch valid_list[wp]: kernel_entry_if "valid_list"
|
|
|
|
definition kernel_call_A_if ::
|
|
"event \<Rightarrow> ((user_context \<times> det_state) \<times> bool \<times> (user_context \<times> det_state)) set" where
|
|
"kernel_call_A_if e \<equiv>
|
|
{(s, b, (tc,s')) | s b tc s' r. ((r,tc),s') \<in> fst (split (kernel_entry_if e) s) \<and>
|
|
b = (case r of Inl _ \<Rightarrow> True | Inr _ \<Rightarrow> False)}"
|
|
|
|
lemma handle_preemption_if_invs:
|
|
"handle_preemption_if tc \<lbrace>invs\<rbrace>"
|
|
by (simp add: handle_preemption_if_def | wp)+
|
|
|
|
lemma handle_preemption_if_domain_sep_inv:
|
|
"handle_preemption_if e \<lbrace>domain_sep_inv irqs st\<rbrace>"
|
|
by (simp add: handle_preemption_if_def | wp)+
|
|
|
|
lemma handle_preemption_if_silc_inv[wp]:
|
|
"handle_preemption_if tc \<lbrace>silc_inv aag st\<rbrace>"
|
|
apply (simp add: handle_preemption_if_def)
|
|
apply (wp handle_interrupt_silc_inv do_machine_op_silc_inv | simp)+
|
|
done
|
|
|
|
lemma handle_preemption_if_pas_refined[wp]:
|
|
"\<lbrace>pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state\<rbrace>
|
|
handle_preemption_if tc
|
|
\<lbrace>\<lambda>_. pas_refined aag\<rbrace>"
|
|
by (wpsimp wp: handle_interrupt_pas_refined getActiveIRQ_wp hoare_drop_imps
|
|
simp: handle_preemption_if_def if_fun_split)
|
|
|
|
crunch cur_domain[wp]: handle_preemption_if "\<lambda>s. P (cur_domain s)"
|
|
crunch cur_thread[wp]: handle_preemption_if "\<lambda>s :: det_state. P (cur_thread s)"
|
|
crunch idle_thread[wp]: handle_preemption_if "\<lambda>s :: det_state. P (idle_thread s)"
|
|
|
|
lemma handle_preemption_if_guarded_pas_domain[wp]:
|
|
"handle_preemption_if tc \<lbrace>guarded_pas_domain aag\<rbrace>"
|
|
by (rule guarded_pas_domain_lift; wp)
|
|
|
|
lemma handle_preemption_if_irq_masks:
|
|
"\<lbrace>(\<lambda>s. P (irq_masks_of_state s)) and domain_sep_inv False st\<rbrace>
|
|
handle_preemption_if tc
|
|
\<lbrace>\<lambda>_ s. P (irq_masks_of_state s)\<rbrace>"
|
|
apply (simp add: handle_preemption_if_def | wp handle_interrupt_irq_masks[where st=st])+
|
|
apply (rule_tac Q="\<lambda>rv s. P (irq_masks_of_state s) \<and> domain_sep_inv False st s \<and>
|
|
(\<forall>x. rv = Some x \<longrightarrow> x \<le> maxIRQ)" in hoare_strengthen_post)
|
|
by (wp | simp)+
|
|
|
|
crunch valid_list[wp]: handle_preemption_if "valid_list"
|
|
(ignore: getActiveIRQ)
|
|
|
|
definition kernel_handle_preemption_if ::
|
|
"((user_context \<times> det_state) \<times> unit \<times> (user_context \<times> det_state)) set" where
|
|
"kernel_handle_preemption_if \<equiv>
|
|
{(s, u, s'). s' \<in> fst (split handle_preemption_if s)}"
|
|
|
|
lemma schedule_if_invs[wp]:
|
|
"schedule_if tc \<lbrace>invs\<rbrace>"
|
|
by (simp add: schedule_if_def | wp | rule hoare_strengthen_post[OF activate_invs])+
|
|
|
|
lemma guarded_pas_domain_arch_state_update[simp]:
|
|
"guarded_pas_domain aag (s\<lparr>arch_state := x\<rparr>) = guarded_pas_domain aag s"
|
|
by (simp add: guarded_pas_domain_def)
|
|
|
|
lemma switch_to_thread_guarded_pas_domain:
|
|
"\<lbrace>\<lambda>s. pasObjectAbs aag t \<in> pasDomainAbs aag (cur_domain s)\<rbrace>
|
|
switch_to_thread t
|
|
\<lbrace>\<lambda>_. guarded_pas_domain aag\<rbrace>"
|
|
apply (simp add: switch_to_thread_def)
|
|
apply (wp modify_wp hoare_drop_imps| simp add: guarded_pas_domain_def)+
|
|
done
|
|
|
|
lemma guarded_pas_domain_machine_state_update[simp]:
|
|
"guarded_pas_domain aag (s\<lparr>machine_state := x\<rparr>) = guarded_pas_domain aag s"
|
|
by (simp add: guarded_pas_domain_def)
|
|
|
|
(* FIXME: Why was the [wp] attribute clobbered by interpretation of the Arch locale? *)
|
|
declare storeWord_irq_masks[wp]
|
|
|
|
lemma switch_to_idle_thread_guarded_pas_domain[wp]:
|
|
"\<lbrace>\<top>\<rbrace> switch_to_idle_thread \<lbrace>\<lambda>_. guarded_pas_domain aag\<rbrace>"
|
|
apply (simp add: switch_to_idle_thread_def bind_assoc double_gets_drop_regets)
|
|
apply (wp modify_wp dmo_wp hoare_vcg_imp_lift | wp (once) | simp add: guarded_pas_domain_def)+
|
|
done
|
|
|
|
lemma choose_thread_guarded_pas_domain:
|
|
"\<lbrace>pas_refined aag and valid_queues\<rbrace>
|
|
choose_thread
|
|
\<lbrace>\<lambda>_. guarded_pas_domain aag\<rbrace>"
|
|
apply (simp add: choose_thread_def guarded_switch_to_def
|
|
| wp switch_to_thread_respects switch_to_idle_thread_respects
|
|
gts_wp switch_to_thread_guarded_pas_domain)+
|
|
apply (clarsimp simp: pas_refined_def)
|
|
apply (clarsimp simp: tcb_domain_map_wellformed_aux_def)
|
|
apply (erule_tac x="(hd (max_non_empty_queue (ready_queues s (cur_domain s))), cur_domain s)"
|
|
in ballE)
|
|
apply simp
|
|
apply (clarsimp simp: valid_queues_def is_etcb_at_def)
|
|
apply (erule_tac x="cur_domain s" in allE)
|
|
apply (erule_tac x="Max {prio. ready_queues s (cur_domain s) prio \<noteq> []}" in allE)
|
|
apply clarsimp
|
|
apply (erule_tac x="hd (max_non_empty_queue (ready_queues s (cur_domain s)))" in ballE)
|
|
apply (clarsimp)
|
|
apply (erule notE, rule domtcbs)
|
|
apply force
|
|
apply (simp add: etcb_at_def)
|
|
apply (simp add: max_non_empty_queue_def)
|
|
apply (erule_tac P="hd A \<in> B" for A B in notE)
|
|
apply (rule Max_prop)
|
|
apply force+
|
|
done
|
|
|
|
lemma schedule_if_ct_running_or_ct_idle[wp]:
|
|
"\<lbrace>invs\<rbrace> schedule_if tc \<lbrace>\<lambda>_ s. ct_running s \<or> ct_idle s\<rbrace>"
|
|
apply (simp add: schedule_if_def | wp)+
|
|
apply (rule hoare_strengthen_post[OF activate_invs] | simp | wp)+
|
|
done
|
|
|
|
lemma set_thread_state_scheduler_action:
|
|
"\<lbrace>(\<lambda>s. P (scheduler_action (s :: det_state))) and st_tcb_at runnable t and K (runnable s)\<rbrace>
|
|
set_thread_state t s
|
|
\<lbrace>\<lambda>_ s. P (scheduler_action s)\<rbrace>"
|
|
apply (simp add: set_thread_state_def | wp sts_ext_running_noop set_object_wp)+
|
|
apply (clarsimp simp: st_tcb_at_def obj_at_def)
|
|
done
|
|
|
|
|
|
context ADT_IF_1 begin
|
|
|
|
lemma schedule_guarded_pas_domain:
|
|
"\<lbrace>guarded_pas_domain aag and einvs and pas_refined aag\<rbrace>
|
|
schedule
|
|
\<lbrace>\<lambda>_. guarded_pas_domain aag\<rbrace>"
|
|
supply ethread_get_wp[wp del]
|
|
apply (simp add: schedule_def)
|
|
apply (wpsimp wp: guarded_pas_domain_lift[where f="activate_thread"]
|
|
guarded_pas_domain_lift[where f="set_scheduler_action f" for f]
|
|
guarded_switch_to_lift switch_to_thread_guarded_pas_domain
|
|
next_domain_valid_queues activate_thread_cur_thread gts_wp
|
|
| wpc
|
|
| rule choose_thread_guarded_pas_domain
|
|
| simp add: schedule_choose_new_thread_def ethread_get_when_def split del: if_split
|
|
| wp (once) hoare_drop_imp[where f="ethread_get t v" for t v]
|
|
| wp (once) hoare_drop_imp[where f="schedule_switch_thread_fastfail c i cp p" for c i cp p])+
|
|
apply (wp hoare_drop_imp)
|
|
apply (wpsimp wp: guarded_pas_domain_lift[where f="activate_thread"]
|
|
guarded_pas_domain_lift[where f="set_scheduler_action f" for f]
|
|
guarded_switch_to_lift switch_to_thread_guarded_pas_domain
|
|
next_domain_valid_queues activate_thread_cur_thread gts_wp
|
|
| wpc
|
|
| rule choose_thread_guarded_pas_domain
|
|
| simp add: schedule_choose_new_thread_def ethread_get_when_def split del: if_split
|
|
| wp (once) hoare_drop_imp[where f="ethread_get t v" for t v]
|
|
| wp (once) hoare_drop_imp[where f="schedule_switch_thread_fastfail c i cp p" for c i cp p])+
|
|
apply (fastforce intro: switch_to_cur_domain switch_thread_runnable
|
|
simp: valid_sched_def elim!: st_tcb_weakenE)+
|
|
done
|
|
|
|
lemma schedule_if_guarded_pas_domain[wp]:
|
|
"\<lbrace>guarded_pas_domain aag and einvs and pas_refined aag\<rbrace>
|
|
schedule_if tc
|
|
\<lbrace>\<lambda>_. guarded_pas_domain aag\<rbrace>"
|
|
apply (simp add: schedule_if_def)
|
|
apply (wp schedule_guarded_pas_domain)
|
|
done
|
|
|
|
lemma activate_thread_scheduler_action[wp]:
|
|
"activate_thread \<lbrace>\<lambda>s. P (scheduler_action s)\<rbrace>"
|
|
apply (simp add: activate_thread_def | wp set_thread_state_scheduler_action gts_wp | wpc)+
|
|
apply (fastforce elim: st_tcb_weakenE)
|
|
done
|
|
|
|
lemma schedule_if_scheduler_action[wp]:
|
|
"\<lbrace>\<top>\<rbrace> schedule_if tc \<lbrace>\<lambda>_ s. scheduler_action s = resume_cur_thread\<rbrace>"
|
|
apply (simp add: schedule_if_def | wp | wpc)+
|
|
apply (simp add: schedule_def schedule_choose_new_thread_def split del: if_split | wp | wpc)+
|
|
done
|
|
|
|
lemma do_user_op_if_only_timer_irq_inv[wp]:
|
|
"\<lbrace>only_timer_irq_inv irq (st :: det_state)\<rbrace>
|
|
do_user_op_if uop tc
|
|
\<lbrace>\<lambda>_. only_timer_irq_inv irq st\<rbrace>"
|
|
apply (rule hoare_pre)
|
|
apply (wp only_timer_irq_inv_pres | simp | blast)+
|
|
done
|
|
|
|
lemma kernel_entry_if_only_timer_irq_inv:
|
|
"\<lbrace>only_timer_irq_inv irq st and einvs and (\<lambda>s. e \<noteq> Interrupt \<longrightarrow> ct_active s)\<rbrace>
|
|
kernel_entry_if e tc
|
|
\<lbrace>\<lambda>_. only_timer_irq_inv irq st\<rbrace>"
|
|
by (wp only_timer_irq_inv_pres kernel_entry_if_irq_masks kernel_entry_if_domain_sep_inv
|
|
| simp | blast)+
|
|
|
|
end
|
|
|
|
|
|
crunches schedule_if
|
|
for valid_sched[wp]: valid_sched
|
|
and valid_list[wp]: valid_list
|
|
|
|
lemma schedule_if_irq_masks:
|
|
"\<lbrace>(\<lambda>s. P (irq_masks_of_state s)) and domain_sep_inv False st\<rbrace>
|
|
schedule_if tc
|
|
\<lbrace>\<lambda>_ s. P (irq_masks_of_state s)\<rbrace>"
|
|
by (simp add: schedule_if_def | wp)+
|
|
|
|
|
|
definition kernel_schedule_if ::
|
|
"((user_context \<times> det_state) \<times> unit \<times> (user_context \<times> det_state)) set" where
|
|
"kernel_schedule_if \<equiv> {(s, e, s'). s' \<in> fst (split schedule_if s)}"
|
|
|
|
|
|
subsection \<open>kernel_exit_if\<close>
|
|
|
|
text \<open>
|
|
Restore the user context
|
|
\<close>
|
|
definition kernel_exit_if :: "user_context \<Rightarrow> (user_context,det_ext) s_monad" where
|
|
"kernel_exit_if tc \<equiv>
|
|
do t' \<leftarrow> gets cur_thread;
|
|
thread_get (arch_tcb_context_get o tcb_arch) t'
|
|
od"
|
|
|
|
crunch inv[wp]: kernel_exit_if "P"
|
|
|
|
definition kernel_exit_A_if ::
|
|
"((user_context \<times> det_state) \<times> sys_mode \<times> (user_context \<times> det_state)) set" where
|
|
"kernel_exit_A_if \<equiv>
|
|
{(s, m, s'). s' \<in> fst (split kernel_exit_if s) \<and>
|
|
m = (if ct_running (snd s') then InUserMode else InIdleMode)}"
|
|
|
|
|
|
subsection \<open>check_active_irq_if\<close>
|
|
|
|
type_synonym observable_if = "det_state global_sys_state"
|
|
|
|
text \<open>
|
|
Check for active IRQs without updating the user context
|
|
\<close>
|
|
definition check_active_irq_if ::
|
|
"user_context \<Rightarrow> (irq option \<times> user_context, ('z :: state_ext)) s_monad" where
|
|
"check_active_irq_if tc \<equiv>
|
|
do irq \<leftarrow> do_machine_op (getActiveIRQ False);
|
|
return (irq, tc)
|
|
od"
|
|
|
|
subsection \<open>ADT_A_if definition\<close>
|
|
|
|
definition check_active_irq_A_if :: "((user_context \<times> ('z :: state_ext) state) \<times> irq option \<times>
|
|
(user_context \<times> ('z :: state_ext) state)) set" where
|
|
"check_active_irq_A_if \<equiv>
|
|
{((tc, s), irq, (tc', s')). ((irq, tc'), s') \<in> fst (check_active_irq_if tc s)}"
|
|
|
|
abbreviation internal_state_if :: "'a global_sys_state \<Rightarrow> 'a" where
|
|
"internal_state_if \<equiv> \<lambda>s. (snd (fst s))"
|
|
|
|
|
|
(*Weakened invs_if to properties only necessary for refinement*)
|
|
definition full_invs_if :: "observable_if set" where
|
|
"full_invs_if \<equiv>
|
|
{s. einvs (internal_state_if s) \<and>
|
|
(snd s \<noteq> KernelSchedule True \<longrightarrow> domain_time (internal_state_if s) > 0) \<and>
|
|
(domain_time (internal_state_if s) = 0
|
|
\<longrightarrow> scheduler_action (internal_state_if s) = choose_new_thread) \<and>
|
|
valid_domain_list (internal_state_if s) \<and>
|
|
(case (snd s) of
|
|
KernelEntry e \<Rightarrow> (e \<noteq> Interrupt \<longrightarrow> ct_running (internal_state_if s)) \<and>
|
|
(ct_running (internal_state_if s) \<or> ct_idle (internal_state_if s)) \<and>
|
|
scheduler_action (internal_state_if s) = resume_cur_thread
|
|
| KernelExit \<Rightarrow> (ct_running (internal_state_if s) \<or> ct_idle (internal_state_if s)) \<and>
|
|
scheduler_action (internal_state_if s) = resume_cur_thread
|
|
| InUserMode \<Rightarrow> ct_running (internal_state_if s) \<and>
|
|
scheduler_action (internal_state_if s) = resume_cur_thread
|
|
| InIdleMode \<Rightarrow> ct_idle (internal_state_if s) \<and>
|
|
scheduler_action (internal_state_if s) = resume_cur_thread
|
|
| _ \<Rightarrow> True) }"
|
|
|
|
|
|
(*We'll define this later, currently it doesn't matter if
|
|
we restrict the permitted steps of the system*)
|
|
consts step_restrict :: "det_state global_sys_state \<Rightarrow> bool"
|
|
|
|
definition ADT_A_if ::
|
|
"user_transition_if \<Rightarrow> (det_state global_sys_state, observable_if, unit) data_type" where
|
|
"ADT_A_if uop \<equiv>
|
|
\<lparr>Init = \<lambda>s. {s} \<inter> full_invs_if \<inter> {s. step_restrict s}, Fin = id,
|
|
Step = (\<lambda>u. global_automaton_if check_active_irq_A_if (do_user_op_A_if uop) kernel_call_A_if
|
|
kernel_handle_preemption_if kernel_schedule_if kernel_exit_A_if
|
|
\<inter> {(s,s'). step_restrict s'})\<rparr>"
|
|
|
|
lemma check_active_irq_if_wp:
|
|
"\<lbrace>\<lambda>s. P ((irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))),tc)
|
|
(s\<lparr>machine_state := (machine_state s\<lparr>irq_state := irq_state (machine_state s) + 1\<rparr>)\<rparr>)\<rbrace>
|
|
check_active_irq_if tc
|
|
\<lbrace>P\<rbrace>"
|
|
by (wpsimp wp: dmo_getActiveIRQ_wp simp: check_active_irq_if_def)
|
|
|
|
lemma handle_preemption_if_only_timer_irq_inv[wp]:
|
|
"handle_preemption_if tc \<lbrace>only_timer_irq_inv irq st\<rbrace>"
|
|
by (wp only_timer_irq_inv_pres handle_preemption_if_irq_masks handle_preemption_if_domain_sep_inv
|
|
| simp | blast)+
|
|
|
|
lemma schedule_if_only_timer_irq_inv[wp]:
|
|
"schedule_if tc \<lbrace>only_timer_irq_inv irq st\<rbrace>"
|
|
by (wp only_timer_irq_inv_pres schedule_if_irq_masks | blast)+
|
|
|
|
|
|
subsection \<open>Big step IF automaton\<close>
|
|
|
|
fun interrupted_modes where
|
|
"interrupted_modes KernelPreempted = True"
|
|
| "interrupted_modes (KernelEntry Interrupt) = True"
|
|
| "interrupted_modes _ = False"
|
|
|
|
text \<open>
|
|
A first attempt at defining the big steps. They look like this:
|
|
|
|
user mode +-----------+ +------ ...
|
|
- - - - - - - - / \ /
|
|
kernel mode / +---------------+
|
|
KernelExit interrupted KernelExit
|
|
|
|
|
|
big steps --------------> --------------> ------- ...
|
|
|
|
dom current dom scheduler current dom
|
|
|
|
|
|
That is, a step of the current domain lasts from its kernel exit until
|
|
the point at which the kernel services the next interrupt, either because
|
|
the arrival of that interrupt traps from user- to kernel-mode (in which
|
|
case the system has just moved into KernelEntry Interrupt state) or
|
|
because a long-running system call was pre-empted by the arrival of an
|
|
interrupt (in which case the system has just moved into the
|
|
KernelPreempted state).
|
|
|
|
The scheduler domain then runs until the next kernel exit, at which point
|
|
whoever is now the current domain begins its big execution step.
|
|
\<close>
|
|
|
|
definition big_step_R :: "det_state global_sys_state \<Rightarrow> det_state global_sys_state \<Rightarrow> bool" where
|
|
"big_step_R \<equiv> \<lambda>s s'. (snd s = KernelExit \<and> interrupted_modes (snd s'))
|
|
\<or> (interrupted_modes (snd s) \<and> snd s' = KernelExit)"
|
|
|
|
definition big_step_evmap :: "unit list \<Rightarrow> unit" where
|
|
"big_step_evmap evs \<equiv> ()"
|
|
|
|
definition big_step_ADT_A_if ::
|
|
"user_transition_if \<Rightarrow> (observable_if, observable_if, unit) data_type" where
|
|
"big_step_ADT_A_if utf \<equiv> big_step_adt (ADT_A_if utf) big_step_R big_step_evmap"
|
|
|
|
definition cur_context where
|
|
"cur_context s = arch_tcb_context_get (tcb_arch (the (get_tcb (cur_thread s) s)))"
|
|
|
|
|
|
subsection \<open>Locales setup\<close>
|
|
|
|
(* the second argument of det_inv the user_context, which is saved in kernel state
|
|
on kernel_entry_if, and restored on kernel_exit_if.
|
|
Between these sys_modes the user_context that is passed through is not used,
|
|
rather cur_context is. *)
|
|
locale invariant_over_ADT_if =
|
|
fixes det_inv :: "sys_mode \<Rightarrow> user_context \<Rightarrow> det_state \<Rightarrow> bool"
|
|
fixes utf :: "user_transition_if"
|
|
assumes det_inv_abs_state:
|
|
"\<And>e tc s. valid_machine_state s \<Longrightarrow> det_inv e tc s \<Longrightarrow> det_inv e tc (abs_state s)"
|
|
assumes kernel_entry_if_det_inv:
|
|
"\<And>e tc. \<lbrace>einvs and det_inv (KernelEntry e) tc and ct_running and K (e \<noteq> Interrupt)\<rbrace>
|
|
kernel_entry_if e tc
|
|
\<lbrace>\<lambda>rv s. case (fst rv) of Inl irq \<Rightarrow> det_inv KernelPreempted (cur_context s) s
|
|
| Inr () \<Rightarrow> det_inv (KernelSchedule False) (cur_context s) s\<rbrace>"
|
|
assumes kernel_entry_if_Interrupt_det_inv:
|
|
"\<And>tc. \<lbrace>einvs and det_inv (KernelEntry Interrupt) tc and (\<lambda>s. ct_running s \<or> ct_idle s)\<rbrace>
|
|
kernel_entry_if Interrupt tc
|
|
\<lbrace>\<lambda>rv s. case (fst rv) of Inl irq \<Rightarrow> det_inv KernelPreempted (cur_context s) s
|
|
| Inr () \<Rightarrow> det_inv (KernelSchedule True) (cur_context s) s\<rbrace>"
|
|
assumes handle_preemption_if_det_inv:
|
|
"\<And>tc. \<lbrace>einvs and (\<lambda>s. det_inv KernelPreempted (cur_context s) s)\<rbrace>
|
|
handle_preemption_if tc
|
|
\<lbrace>\<lambda>rv s. det_inv (KernelSchedule True) (cur_context s) s\<rbrace>"
|
|
assumes schedule_if_det_inv:
|
|
"\<And>b tc. \<lbrace>einvs and (\<lambda>s. det_inv (KernelSchedule b) (cur_context s) s)\<rbrace>
|
|
schedule_if tc
|
|
\<lbrace>\<lambda>rv s. det_inv KernelExit (cur_context s) s\<rbrace>"
|
|
assumes kernel_exit_if_det_inv:
|
|
"\<And>tc. \<lbrace>einvs and (\<lambda>s. det_inv KernelExit (cur_context s) s) and (\<lambda>s. ct_running s \<or> ct_idle s)\<rbrace>
|
|
kernel_exit_if tc
|
|
\<lbrace>\<lambda>rv s. if ct_running s then det_inv InUserMode rv s else det_inv InIdleMode rv s\<rbrace>"
|
|
assumes do_user_op_if_det_inv:
|
|
"\<And>tc. \<lbrace>einvs and det_inv InUserMode tc and ct_running\<rbrace>
|
|
do_user_op_if utf tc
|
|
\<lbrace>\<lambda>rv. case (fst rv) of Some e \<Rightarrow> det_inv (KernelEntry e) (snd rv)
|
|
| None \<Rightarrow> det_inv InUserMode (snd rv)\<rbrace>"
|
|
assumes check_active_irq_if_User_det_inv:
|
|
"\<And>tc. \<lbrace>einvs and det_inv InUserMode tc and ct_running\<rbrace>
|
|
check_active_irq_if tc
|
|
\<lbrace>\<lambda>rv. case (fst rv) of Some irq \<Rightarrow> det_inv (KernelEntry Interrupt) (snd rv)
|
|
| None \<Rightarrow> det_inv InUserMode (snd rv)\<rbrace>"
|
|
assumes check_active_irq_if_Idle_det_inv:
|
|
"\<And>tc. \<lbrace>einvs and det_inv InIdleMode tc and ct_idle\<rbrace>
|
|
check_active_irq_if tc
|
|
\<lbrace>\<lambda>rv. case (fst rv) of Some irq \<Rightarrow> det_inv (KernelEntry Interrupt) (snd rv)
|
|
| None \<Rightarrow> det_inv InIdleMode (snd rv)\<rbrace>"
|
|
|
|
|
|
locale valid_initial_state_noenabled = invariant_over_ADT_if + (* FIXME: arch_split *)
|
|
fixes s0_internal :: det_state
|
|
fixes initial_aag :: "'a subject_label PAS"
|
|
fixes timer_irq :: irq
|
|
fixes current_aag
|
|
fixes s0 :: observable_if
|
|
fixes s0_context :: user_context
|
|
defines
|
|
"current_aag t \<equiv> initial_aag\<lparr>pasSubject := the_elem (pasDomainAbs initial_aag (cur_domain t))\<rparr>"
|
|
(* Run the system from right where we exit the kernel for the first time to user-space.
|
|
It shouldn't matter what the initial machine context is since the first
|
|
thing that should happen on a KernelExit is to restore it from the cur_thread *)
|
|
defines "s0 \<equiv> ((if ct_idle s0_internal then idle_context s0_internal else s0_context,s0_internal),
|
|
KernelExit)"
|
|
assumes cur_domain_subject_s0:
|
|
"pasSubject initial_aag \<in> pasDomainAbs initial_aag (cur_domain s0_internal)"
|
|
assumes policy_wellformed: "pas_wellformed_noninterference initial_aag"
|
|
fixes Invs
|
|
defines "Invs s \<equiv> einvs s \<and> only_timer_irq_inv timer_irq s0_internal s \<and>
|
|
silc_inv (current_aag s) s0_internal s \<and>
|
|
domain_sep_inv False s0_internal s \<and>
|
|
pas_refined (current_aag s) s \<and>
|
|
guarded_pas_domain (current_aag s) s \<and>
|
|
idle_equiv s0_internal s \<and>
|
|
valid_domain_list s \<and> valid_vspace_objs_if s"
|
|
assumes Invs_s0_internal: "Invs s0_internal"
|
|
assumes det_inv_s0: "det_inv KernelExit (cur_context s0_internal) s0_internal"
|
|
assumes scheduler_action_s0_internal: "scheduler_action s0_internal = resume_cur_thread"
|
|
assumes ct_running_or_ct_idle_s0_internal: "ct_running s0_internal \<or> ct_idle s0_internal"
|
|
assumes domain_time_s0_internal: "domain_time s0_internal > 0"
|
|
assumes utf_det:
|
|
"\<forall>pl pr pxn tc ms s. det_inv InUserMode tc s \<and> einvs s \<and>
|
|
context_matches_state pl pr pxn ms s \<and> ct_running s
|
|
\<longrightarrow> (\<exists>x. utf (cur_thread s) pl pr pxn (tc, ms) = {x})"
|
|
assumes utf_non_empty: "\<forall>t pl pr pxn tc ms. utf t pl pr pxn (tc, ms) \<noteq> {}"
|
|
assumes utf_non_interrupt: "\<forall>t pl pr pxn tc ms e f g.
|
|
(e,f,g) \<in> utf t pl pr pxn (tc, ms) \<longrightarrow> e \<noteq> Some Interrupt"
|
|
assumes extras_s0: "step_restrict s0"
|
|
assumes pasMaySendIrqs_initial_aag[simp]: "pasMaySendIrqs initial_aag = False"
|
|
|
|
|
|
locale valid_initial_state = valid_initial_state_noenabled +
|
|
assumes ADT_A_if_enabled_system:
|
|
"enabled_system (ADT_A_if utf) s0"
|
|
assumes ADT_A_if_Init_Fin_serial:
|
|
"Init_Fin_serial (ADT_A_if utf) s0 (full_invs_if \<inter> {s. step_restrict s})"
|
|
|
|
|
|
subsection \<open>domain_field preserved on non-interrupt kernel event\<close>
|
|
|
|
crunch irq_state_of_state[wp]: cap_move "\<lambda>s. P (irq_state_of_state s)"
|
|
crunch domain_fields[wp]: handle_yield "domain_fields P"
|
|
crunch domain_fields[wp]: activate_thread "domain_fields P"
|
|
crunch domain_list[wp]: kernel_entry_if "\<lambda>s. P (domain_list s)"
|
|
crunch domain_list[wp]: handle_preemption_if "\<lambda>s. P (domain_list s)"
|
|
crunch domain_list[wp]: schedule_if "\<lambda>s. P (domain_list s)"
|
|
(wp: crunch_wps simp: crunch_simps)
|
|
|
|
lemma schedule_if_domain_time_nonzero':
|
|
"\<lbrace>valid_domain_list and (\<lambda>s. domain_time s = 0 \<longrightarrow> scheduler_action s = choose_new_thread)\<rbrace>
|
|
schedule_if tc
|
|
\<lbrace>(\<lambda>_ s. domain_time s > 0)\<rbrace>"
|
|
apply (simp add: schedule_if_def schedule_def)
|
|
apply (wpsimp wp: next_domain_domain_time_left
|
|
simp: crunch_simps guarded_switch_to_def switch_to_thread_def
|
|
choose_thread_def switch_to_idle_thread_def)+
|
|
apply (wp hoare_drop_imps)
|
|
apply (wp hoare_drop_imps)
|
|
apply wp+
|
|
apply (wpsimp simp: choose_thread_def switch_to_idle_thread_def
|
|
guarded_switch_to_def switch_to_thread_def
|
|
wp: gts_wp)+
|
|
apply (auto simp: word_neq_0_conv)
|
|
done
|
|
|
|
lemma schedule_if_domain_time_nonzero:
|
|
"\<lbrace>valid_domain_list and (\<lambda>s. domain_time s = 0 \<longrightarrow> scheduler_action s = choose_new_thread)\<rbrace>
|
|
schedule_if tc
|
|
\<lbrace>\<lambda>_ s. domain_time s \<noteq> 0\<rbrace>"
|
|
apply (rule hoare_strengthen_post[OF schedule_if_domain_time_nonzero'])
|
|
apply simp
|
|
done
|
|
|
|
|
|
context ADT_IF_1 begin
|
|
|
|
lemma handle_event_domain_fields:
|
|
notes hy_inv[wp del]
|
|
shows "\<lbrace>domain_fields P and K (e \<noteq> Interrupt)\<rbrace>
|
|
handle_event e
|
|
\<lbrace>\<lambda>_. domain_fields P\<rbrace>"
|
|
apply (rule hoare_gen_asm)
|
|
apply (rule hoare_pre)
|
|
apply (case_tac e)
|
|
apply (rename_tac syscall)
|
|
apply (case_tac syscall)
|
|
apply (wp | simp add: handle_call_def)+
|
|
done
|
|
|
|
lemma kernel_entry_if_domain_fields:
|
|
"\<lbrace>domain_fields P and K (e \<noteq> Interrupt)\<rbrace>
|
|
kernel_entry_if e tc
|
|
\<lbrace>\<lambda>_. domain_fields P\<rbrace>"
|
|
apply (simp add: kernel_entry_if_def)
|
|
apply (wp handle_event_domain_fields | simp)+
|
|
done
|
|
|
|
lemma kernel_entry_if_domain_time_sched_action:
|
|
"\<lbrace>\<lambda>s. domain_time s > 0\<rbrace>
|
|
kernel_entry_if e tc
|
|
\<lbrace>\<lambda>_ s. domain_time s = 0 \<longrightarrow> scheduler_action s = choose_new_thread\<rbrace>"
|
|
apply (case_tac "e = Interrupt")
|
|
apply (simp add: kernel_entry_if_def)
|
|
apply (wp handle_interrupt_valid_domain_time| wpc | simp)+
|
|
apply (rule_tac Q="\<lambda>r s. domain_time s > 0" in hoare_strengthen_post)
|
|
apply (wp | simp)+
|
|
apply (wp hoare_false_imp kernel_entry_if_domain_fields | fastforce)+
|
|
done
|
|
|
|
end
|
|
|
|
|
|
subsection \<open>to split generic preservation lemma\<close>
|
|
|
|
lemma handle_preemption_if_domain_time_sched_action:
|
|
"\<lbrace>\<lambda>s. domain_time s > 0\<rbrace>
|
|
handle_preemption_if tc
|
|
\<lbrace>\<lambda>_ s. domain_time s = 0 \<longrightarrow> scheduler_action s = choose_new_thread\<rbrace>"
|
|
apply (simp add: handle_preemption_if_def)
|
|
apply (wp handle_interrupt_valid_domain_time| wpc | simp)+
|
|
apply (rule_tac Q="\<lambda>r s. domain_time s > 0" in hoare_strengthen_post)
|
|
apply wpsimp+
|
|
done
|
|
|
|
definition user_context_of :: "'k global_sys_state \<Rightarrow> user_context" where
|
|
"user_context_of \<equiv> \<lambda>s. fst (fst s)"
|
|
|
|
lemma user_context_of_simp[simp]:
|
|
"user_context_of ((uc,s),mode) = uc"
|
|
by (simp add: user_context_of_def)
|
|
|
|
definition sys_mode_of :: "'k global_sys_state \<Rightarrow> sys_mode" where
|
|
"sys_mode_of \<equiv> \<lambda>s. snd s"
|
|
|
|
lemma sys_mode_of_simp[simp]:
|
|
"sys_mode_of ((uc,s),mode) = mode"
|
|
by (simp add: sys_mode_of_def)
|
|
|
|
lemma exit_idle_context:
|
|
"\<lbrace>ct_idle and invs\<rbrace> kernel_exit_if tc' \<lbrace>\<lambda>tc s. tc = idle_context s\<rbrace>"
|
|
apply (simp add: kernel_exit_if_def thread_get_def)
|
|
apply wp
|
|
apply (subgoal_tac "cur_thread s = idle_thread s")
|
|
apply (clarsimp simp: cur_thread_idle idle_context_def)+
|
|
done
|
|
|
|
lemma check_active_irq_context:
|
|
"\<lbrace>\<top>\<rbrace> check_active_irq_if tc' \<lbrace>\<lambda>tc s. (snd tc) = tc'\<rbrace>"
|
|
apply (simp add: check_active_irq_if_def)
|
|
apply (wp del: no_irq| simp)+
|
|
done
|
|
|
|
lemma kernel_entry_context:
|
|
"\<lbrace>\<top>\<rbrace> kernel_entry_if e tc' \<lbrace>\<lambda>tc s. (snd tc) = tc'\<rbrace>"
|
|
apply (simp add: kernel_entry_if_def)
|
|
apply (wp del: no_irq| simp)+
|
|
done
|
|
|
|
lemma handle_preemption_context:
|
|
"\<lbrace>\<top>\<rbrace> handle_preemption_if tc' \<lbrace>\<lambda>tc s. tc = tc'\<rbrace>"
|
|
apply (simp add: handle_preemption_if_def)
|
|
apply (wp del: no_irq| simp)+
|
|
done
|
|
|
|
lemma get_tcb_machine_stat_update[simp]:
|
|
"get_tcb t (s\<lparr>machine_state := x\<rparr>) = get_tcb t s"
|
|
by (simp add: get_tcb_def)
|
|
|
|
lemma handle_preemption_globals_equiv[wp]:
|
|
"\<lbrace>globals_equiv st and invs\<rbrace>
|
|
handle_preemption_if a
|
|
\<lbrace>\<lambda>_. globals_equiv st\<rbrace>"
|
|
apply (simp add: handle_preemption_if_def)
|
|
apply (wp handle_interrupt_globals_equiv dmo_getActiveIRQ_globals_equiv crunch_wps
|
|
| simp add: crunch_simps)+
|
|
done
|
|
|
|
lemma schedule_if_globals_equiv_scheduler[wp]:
|
|
"\<lbrace>globals_equiv_scheduler st and invs\<rbrace>
|
|
schedule_if tc
|
|
\<lbrace>\<lambda>_. globals_equiv_scheduler st\<rbrace>"
|
|
apply (simp add: schedule_if_def)
|
|
apply wp
|
|
apply (wp globals_equiv_scheduler_inv'[where P="invs"] activate_thread_globals_equiv)
|
|
apply (simp add: invs_arch_state invs_valid_idle)
|
|
apply (wp | simp)+
|
|
done
|
|
|
|
lemma dmo_user_memory_update_idle_equiv:
|
|
"\<lbrace>idle_equiv st\<rbrace> do_machine_op (user_memory_update um) \<lbrace>\<lambda>_. idle_equiv st\<rbrace>"
|
|
by (wpsimp wp: dmo_wp)
|
|
|
|
lemma dmo_device_memory_update_idle_equiv:
|
|
"\<lbrace>idle_equiv st\<rbrace> do_machine_op (device_memory_update um) \<lbrace>\<lambda>_. idle_equiv st\<rbrace>"
|
|
by (wpsimp wp: dmo_wp)
|
|
|
|
lemma ct_active_not_idle':
|
|
"ct_active s \<Longrightarrow> \<not> ct_idle s"
|
|
by (clarsimp simp add: ct_in_state_def st_tcb_at_def obj_at_def)
|
|
|
|
lemma Init_Fin_serial_weak_strengthen:
|
|
"\<lbrakk> Init_Fin_serial_weak A s0 I; A [> J; J \<subseteq> I; Init A s0 \<subseteq> J \<rbrakk>
|
|
\<Longrightarrow> Init_Fin_serial_weak A s0 J"
|
|
by (force simp: Init_Fin_serial_weak_def serial_system_weak_def Init_Fin_serial_weak_axioms_def)
|
|
|
|
lemma rel_terminate_weaken:
|
|
"\<lbrakk> rel_terminate A s0 R I measuref; J \<subseteq> I \<rbrakk>
|
|
\<Longrightarrow> rel_terminate A s0 R J measuref"
|
|
by (force simp: rel_terminate_def)
|
|
|
|
|
|
context valid_initial_state begin
|
|
|
|
lemma domains_distinct:
|
|
"pas_domains_distinct initial_aag"
|
|
apply (rule pas_wellformed_noninterference_domains_distinct)
|
|
apply (rule policy_wellformed)
|
|
done
|
|
|
|
lemma current_domains_distinct:
|
|
"pas_domains_distinct (current_aag s)"
|
|
using domains_distinct
|
|
by (simp add: current_aag_def pas_domains_distinct_def)
|
|
|
|
lemmas the_subject_of_aag_domain = domain_has_the_label[OF domains_distinct]
|
|
|
|
lemma current_aag_initial:
|
|
"current_aag s0_internal = initial_aag"
|
|
by (simp add: current_aag_def the_subject_of_aag_domain cur_domain_subject_s0)
|
|
|
|
subsection \<open>@{term ADT_A_if} is a step system with the invs_if invariant\<close>
|
|
|
|
definition cur_thread_context_of :: "observable_if \<Rightarrow> user_context" where
|
|
"cur_thread_context_of \<equiv>
|
|
\<lambda>s. case sys_mode_of s of InUserMode \<Rightarrow> user_context_of s
|
|
| InIdleMode \<Rightarrow> user_context_of s
|
|
| KernelEntry e \<Rightarrow> user_context_of s
|
|
| _ \<Rightarrow> cur_context (internal_state_if s)"
|
|
|
|
definition invs_if :: "observable_if \<Rightarrow> bool" where
|
|
"invs_if s \<equiv>
|
|
Invs (internal_state_if s) \<and>
|
|
det_inv (sys_mode_of s) (cur_thread_context_of s) (internal_state_if s) \<and>
|
|
(snd s \<noteq> KernelSchedule True \<longrightarrow> domain_time (internal_state_if s) > 0) \<and>
|
|
(domain_time (internal_state_if s) = 0
|
|
\<longrightarrow> scheduler_action (internal_state_if s) = choose_new_thread) \<and>
|
|
(snd s \<noteq> KernelExit
|
|
\<longrightarrow> (ct_idle (internal_state_if s)
|
|
\<longrightarrow> user_context_of s = idle_context (internal_state_if s))) \<and>
|
|
(case (snd s) of
|
|
KernelEntry e \<Rightarrow> (e \<noteq> Interrupt \<longrightarrow> ct_running (internal_state_if s)) \<and>
|
|
(ct_running (internal_state_if s) \<or> ct_idle (internal_state_if s)) \<and>
|
|
scheduler_action (internal_state_if s) = resume_cur_thread
|
|
| KernelExit \<Rightarrow> (ct_running (internal_state_if s) \<or> ct_idle (internal_state_if s)) \<and>
|
|
scheduler_action (internal_state_if s) = resume_cur_thread
|
|
| InUserMode \<Rightarrow> ct_running (internal_state_if s) \<and>
|
|
scheduler_action (internal_state_if s) = resume_cur_thread
|
|
| InIdleMode \<Rightarrow> ct_idle (internal_state_if s) \<and>
|
|
scheduler_action (internal_state_if s) = resume_cur_thread
|
|
| _ \<Rightarrow> True)"
|
|
|
|
lemma invs_if_s0[simp]:
|
|
"invs_if s0"
|
|
apply (clarsimp simp: s0_def invs_if_def Invs_s0_internal[simplified]
|
|
ct_running_or_ct_idle_s0_internal domain_time_s0_internal
|
|
det_inv_s0 cur_thread_context_of_def scheduler_action_s0_internal)
|
|
using domain_time_s0_internal by fastforce
|
|
|
|
lemma only_timer_irq_inv_irq_state_update[simp]:
|
|
"only_timer_irq_inv timer_irq s0_internal
|
|
(b\<lparr>machine_state := machine_state b\<lparr>irq_state := Suc (irq_state (machine_state b))\<rparr>\<rparr>) =
|
|
only_timer_irq_inv timer_irq s0_internal b"
|
|
by (clarsimp simp: only_timer_irq_inv_def only_timer_irq_def irq_is_recurring_def is_irq_at_def)
|
|
|
|
lemma initial_aag_bak:
|
|
"initial_aag =
|
|
(current_aag s)\<lparr>pasSubject := the_elem (pasDomainAbs (current_aag s) (cur_domain s0_internal))\<rparr>"
|
|
using current_aag_def cur_domain_subject_s0 the_subject_of_aag_domain by simp
|
|
|
|
(* By our locale assumptions, every domain has an associated label *)
|
|
lemma the_label_of_domain_exists[intro, simp]:
|
|
"the_elem (pasDomainAbs initial_aag l) \<in> pasDomainAbs initial_aag l"
|
|
using domains_distinct[simplified pas_domains_distinct_def] the_subject_of_aag_domain by blast
|
|
|
|
(* Corollary for current_aag *)
|
|
lemma pas_cur_domain_current_aag:
|
|
"pas_cur_domain (current_aag s) s"
|
|
by (simp add: current_aag_def)
|
|
|
|
lemma subject_current_aag:
|
|
"pasSubject (current_aag s) \<in> pasDomainAbs initial_aag (cur_domain s)"
|
|
by (simp add: current_aag_def)
|
|
|
|
lemma pas_wellformed_cur[iff]:
|
|
"pas_wellformed_noninterference (current_aag s)"
|
|
apply (cut_tac policy_wellformed)
|
|
apply (simp add: pas_wellformed_noninterference_def current_aag_def pas_domains_distinct_def)
|
|
done
|
|
|
|
declare policy_wellformed[iff]
|
|
|
|
lemma current_aag_lift:
|
|
assumes b: "\<And>aag. \<lbrace>P aag\<rbrace> f \<lbrace>\<lambda>r s. Q aag r s\<rbrace>"
|
|
assumes a: "\<And>P. \<lbrace>\<lambda>s. P (cur_domain s)\<rbrace> f \<lbrace>\<lambda>r s. P (cur_domain s)\<rbrace>"
|
|
shows "\<lbrace>\<lambda>s. P (current_aag s) s\<rbrace> f \<lbrace>\<lambda>r s. Q (current_aag s) r s\<rbrace>"
|
|
apply (simp add: current_aag_def)
|
|
apply (rule hoare_lift_Pf3[where f="cur_domain", OF b a])
|
|
done
|
|
|
|
lemma silc_inv_cur:
|
|
"silc_inv (current_aag s) st s = silc_inv initial_aag st s"
|
|
apply (rule iffI)
|
|
apply (subst initial_aag_bak[where s=s])
|
|
apply (rule silc_inv_pasSubject_update)
|
|
apply simp+
|
|
apply (simp add: current_aag_def)
|
|
apply (subst the_subject_of_aag_domain[where l = "pasSubject initial_aag"])
|
|
apply (rule cur_domain_subject_s0)
|
|
apply (blast intro: cur_domain_subject_s0)
|
|
apply (simp add: current_aag_def)
|
|
apply (rule silc_inv_pasSubject_update)
|
|
apply blast+
|
|
done
|
|
|
|
lemma guarded_pas_domain_cur:
|
|
"guarded_pas_domain (current_aag s) s = guarded_pas_domain initial_aag s"
|
|
by (simp add: current_aag_def)
|
|
|
|
lemma pas_refined_cur:
|
|
"pas_refined (current_aag s) s = pas_refined initial_aag s"
|
|
apply (rule iffI)
|
|
apply (subst initial_aag_bak[where s=s])
|
|
apply (erule pas_refined_pasSubject_update)
|
|
apply simp
|
|
apply (simp add: current_aag_def)
|
|
apply (subst the_subject_of_aag_domain[where l = "pasSubject initial_aag"])
|
|
apply (rule cur_domain_subject_s0)
|
|
apply (blast intro: cur_domain_subject_s0)
|
|
apply (simp add: current_aag_def)
|
|
apply (rule pas_refined_pasSubject_update)
|
|
apply blast+
|
|
done
|
|
|
|
lemma pasObjectAbs_current_aag:
|
|
"pasObjectAbs (current_aag x) = pasObjectAbs initial_aag"
|
|
by (simp add: current_aag_def)
|
|
|
|
lemma pasIRQAbs_current_aag:
|
|
"pasIRQAbs (current_aag x) = pasIRQAbs initial_aag"
|
|
by (simp add: current_aag_def)
|
|
|
|
lemma pasASIDAbs_current_aag:
|
|
"pasASIDAbs (current_aag x) = pasASIDAbs initial_aag"
|
|
by (simp add: current_aag_def)
|
|
|
|
lemma pasPolicy_current_aag:
|
|
"pasPolicy (current_aag x) = pasPolicy initial_aag"
|
|
by (simp add: current_aag_def)
|
|
|
|
lemma guarded_pas_is_subject_current_aag:
|
|
"\<lbrakk> guarded_pas_domain (current_aag s) s; invs s \<rbrakk>
|
|
\<Longrightarrow> ct_active s \<longrightarrow> is_subject (current_aag s) (cur_thread s)"
|
|
apply (clarsimp simp add: guarded_pas_domain_def current_aag_def)
|
|
apply (rule sym)
|
|
apply (blast intro: the_elemI
|
|
dest: domains_distinct[THEN pas_domains_distinct_inj] ct_active_not_idle)
|
|
done
|
|
|
|
lemma handle_event_was_not_Interrupt:
|
|
"\<lbrace>\<top>\<rbrace> handle_event e -,\<lbrace>\<lambda> r s. e \<noteq> Interrupt\<rbrace>"
|
|
apply (case_tac e)
|
|
apply (simp | wp | wpc)+
|
|
done
|
|
|
|
lemma kernel_entry_if_was_not_Interrupt:
|
|
"(x, ba) \<in> fst (kernel_entry_if e a b)
|
|
\<Longrightarrow> (case fst x of Inr a \<Rightarrow> True | _ \<Rightarrow> e \<noteq> Interrupt)"
|
|
apply (simp add: kernel_entry_if_def)
|
|
apply (erule use_valid)
|
|
apply wp
|
|
apply simp
|
|
apply (rule handle_event_was_not_Interrupt[simplified validE_E_def validE_def])
|
|
apply wpsimp+
|
|
done
|
|
|
|
lemma ct_idle_lift:
|
|
assumes a: "\<And>P. \<lbrace>\<lambda>s. P (cur_thread s)\<rbrace> f \<lbrace>\<lambda>r s. P (cur_thread s)\<rbrace>"
|
|
assumes d: "\<And>P. \<lbrace>\<lambda>s. P (idle_thread s)\<rbrace> f \<lbrace>\<lambda>r s. P (idle_thread s)\<rbrace>"
|
|
assumes b: "\<lbrace>Q\<rbrace> f \<lbrace>\<lambda>_. invs\<rbrace>"
|
|
assumes c: "\<And>s. Q s \<Longrightarrow> invs s"
|
|
shows "\<lbrace>Q and (\<lambda>s. P (ct_idle s))\<rbrace> f \<lbrace>\<lambda>r s. P (ct_idle s)\<rbrace>"
|
|
apply (rule hoare_add_post[OF b],simp)
|
|
apply (clarsimp simp: valid_def)
|
|
apply (drule c)
|
|
apply (clarsimp simp: cur_thread_idle)
|
|
apply (rule use_valid[OF _ a],assumption)
|
|
apply (erule use_valid[OF _ d],simp)
|
|
done
|
|
|
|
lemma idle_equiv_context_equiv:
|
|
"\<lbrakk> idle_equiv s s'; invs s' \<rbrakk> \<Longrightarrow> idle_context s' = idle_context s"
|
|
apply (clarsimp simp: idle_equiv_def idle_context_def invs_def valid_state_def valid_idle_def)
|
|
apply (drule pred_tcb_at_tcb_at)
|
|
apply (clarsimp simp: tcb_at_def2 get_tcb_def)
|
|
done
|
|
|
|
lemma kernel_entry_if_det_inv':
|
|
"\<lbrace>einvs and det_inv (KernelEntry e) tc and (\<lambda>s. ct_running s \<or> ct_idle s)
|
|
and (\<lambda>s. e \<noteq> Interrupt \<longrightarrow> ct_running s)\<rbrace>
|
|
kernel_entry_if e tc
|
|
\<lbrace>\<lambda>rv s. det_inv (case (fst rv) of Inl irq \<Rightarrow> KernelPreempted
|
|
| Inr () \<Rightarrow> KernelSchedule (e = Interrupt)) (cur_context s) s\<rbrace>"
|
|
apply (case_tac "e = Interrupt")
|
|
apply simp
|
|
apply (rule hoare_strengthen_post[OF kernel_entry_if_Interrupt_det_inv])
|
|
apply (simp split: sum.splits unit.splits)
|
|
apply simp
|
|
apply (rule hoare_weaken_pre[OF hoare_strengthen_post[OF kernel_entry_if_det_inv]])
|
|
apply (simp split: sum.splits unit.splits)
|
|
apply simp
|
|
done
|
|
|
|
lemma pasMaySendIrqs_current_aag[simp]:
|
|
"pasMaySendIrqs (current_aag s) = False"
|
|
by (simp add: current_aag_def)
|
|
|
|
end
|
|
|
|
|
|
lemma Fin_ADT_if:
|
|
"Fin (ADT_A_if utf) = id"
|
|
by (simp add: ADT_A_if_def)
|
|
|
|
lemma Init_ADT_if:
|
|
"Init (ADT_A_if utf) = (\<lambda>s. {s} \<inter> full_invs_if \<inter> {s. step_restrict s})"
|
|
by (simp add: ADT_A_if_def)
|
|
|
|
lemma handle_preemption_if_valid_sched[wp]:
|
|
"\<lbrace>valid_sched and invs\<rbrace>
|
|
handle_preemption_if irq
|
|
\<lbrace>\<lambda>_. valid_sched\<rbrace>"
|
|
apply (wpsimp simp: handle_preemption_if_def cong: if_cong)
|
|
apply (rule_tac Q="\<lambda>rv. valid_sched and invs and K (rv \<notin> Some ` non_kernel_IRQs)"
|
|
in hoare_strengthen_post[rotated])
|
|
apply clarsimp
|
|
apply (wpsimp wp: getActiveIRQ_neq_non_kernel)+
|
|
done
|
|
|
|
|
|
locale ADT_valid_initial_state =
|
|
ADT_IF_1 initial_aag + valid_initial_state _ _ _ initial_aag for initial_aag
|
|
begin
|
|
|
|
lemma invs_if_Step_ADT_A_if:
|
|
notes active_from_running[simp]
|
|
shows "\<lbrakk> invs_if s; (s,t) \<in> Step (ADT_A_if utf) e \<rbrakk> \<Longrightarrow> invs_if t"
|
|
apply (clarsimp simp: ADT_A_if_def global_automaton_if_def
|
|
invs_if_def Invs_def cur_thread_context_of_def
|
|
| rule guarded_active_ct_cur_domain)+
|
|
apply (elim disjE)
|
|
apply (clarsimp simp: kernel_call_A_if_def)
|
|
apply (frule kernel_entry_if_was_not_Interrupt)
|
|
apply (frule use_valid[OF _ kernel_entry_if_det_inv])
|
|
apply simp
|
|
apply simp
|
|
apply (erule use_valid)
|
|
apply (rule current_aag_lift)
|
|
apply (wp kernel_entry_if_invs kernel_entry_silc_inv[where st'=s0_internal]
|
|
kernel_entry_pas_refined[where st=s0_internal]
|
|
kernel_entry_if_valid_sched kernel_entry_if_only_timer_irq_inv
|
|
kernel_entry_if_domain_sep_inv kernel_entry_if_guarded_pas_domain
|
|
kernel_entry_if_domain_fields kernel_entry_if_idle_equiv
|
|
kernel_entry_if_domain_time_sched_action
|
|
hoare_false_imp ct_idle_lift
|
|
| clarsimp intro!: guarded_pas_is_subject_current_aag[rule_format]
|
|
| intro conjI)+
|
|
apply (rule guarded_pas_is_subject_current_aag[rule_format],assumption+)
|
|
apply (simp add: schact_is_rct_def)+
|
|
apply (rule guarded_pas_is_subject_current_aag[rule_format],assumption+)
|
|
apply (simp add: ct_active_not_idle' | elim exE)+
|
|
apply (simp add: kernel_call_A_if_def | elim exE conjE)+
|
|
apply (rule context_conjI)
|
|
apply (erule use_valid)
|
|
apply (rule kernel_entry_if_invs,simp)
|
|
apply (subgoal_tac "idle_equiv s0_internal ba")
|
|
prefer 2
|
|
apply (erule use_valid)
|
|
apply (rule kernel_entry_if_idle_equiv)
|
|
apply simp
|
|
apply (simp add: idle_equiv_context_equiv)
|
|
apply (frule use_valid[OF _ kernel_entry_context],simp)
|
|
apply (frule use_valid[OF _ kernel_entry_if_det_inv'])
|
|
apply simp
|
|
apply (simp split: unit.splits)
|
|
apply (erule use_valid)
|
|
apply (rule current_aag_lift)
|
|
apply (wp hoare_vcg_const_imp_lift kernel_entry_if_invs
|
|
kernel_entry_silc_inv[where st'=s0_internal]
|
|
kernel_entry_pas_refined[where st=s0_internal]
|
|
kernel_entry_if_valid_sched kernel_entry_if_only_timer_irq_inv
|
|
kernel_entry_if_domain_sep_inv kernel_entry_if_guarded_pas_domain
|
|
kernel_entry_if_domain_time_sched_action
|
|
ct_idle_lift
|
|
| clarsimp intro: guarded_pas_is_subject_current_aag
|
|
| wp kernel_entry_if_domain_fields)+
|
|
apply (rule conjI, fastforce intro!: active_from_running)
|
|
apply (simp add: schact_is_rct_def)
|
|
apply (rule guarded_pas_is_subject_current_aag,assumption+)
|
|
apply (simp_all only: silc_inv_cur pas_refined_cur guarded_pas_domain_cur)
|
|
apply (simp | elim exE)+
|
|
apply (elim exE conjE)
|
|
apply (clarsimp simp add: kernel_handle_preemption_if_def)
|
|
apply (subgoal_tac "idle_equiv s0_internal ba \<and> invs ba")
|
|
prefer 2
|
|
apply (erule use_valid)
|
|
apply (wp handle_preemption_if_invs | simp)+
|
|
apply (clarsimp simp add: idle_equiv_context_equiv)
|
|
apply (erule use_valid)
|
|
apply (rule hoare_add_post[OF handle_preemption_context, OF TrueI], simp,
|
|
rule hoare_drop_imps)
|
|
apply (wp handle_preemption_if_invs handle_preemption_if_domain_sep_inv
|
|
handle_preemption_if_domain_time_sched_action
|
|
handle_preemption_if_det_inv ct_idle_lift)
|
|
apply fastforce
|
|
apply (simp add: kernel_schedule_if_def | elim exE conjE)+
|
|
apply (erule use_valid)
|
|
apply ((wp schedule_if_ct_running_or_ct_idle schedule_if_domain_time_nonzero'
|
|
schedule_if_domain_time_nonzero schedule_if_det_inv hoare_false_imp
|
|
| fastforce simp: invs_valid_idle)+)[2]
|
|
apply (simp add: kernel_exit_A_if_def | elim exE conjE)+
|
|
apply (frule state_unchanged[OF kernel_exit_if_inv])
|
|
apply (frule use_valid[OF _ kernel_exit_if_det_inv])
|
|
apply simp
|
|
apply (clarsimp)
|
|
apply (elim disjE)
|
|
apply (simp add: ct_active_not_idle')+
|
|
apply (erule use_valid[OF _ exit_idle_context],simp+)
|
|
apply (simp add: do_user_op_A_if_def check_active_irq_A_if_def | elim exE conjE)+
|
|
apply (frule use_valid[OF _ do_user_op_if_det_inv])
|
|
apply (frule use_valid[OF _ check_active_irq_if_User_det_inv])
|
|
apply simp
|
|
apply simp
|
|
apply (erule use_valid[OF _ check_active_irq_if_wp])
|
|
apply simp
|
|
apply simp
|
|
apply (erule use_valid, erule use_valid[OF _ check_active_irq_if_wp])
|
|
apply (rule_tac Q="\<lambda>a. (invs and ct_running) and
|
|
(\<lambda>b. valid_vspace_objs_if b \<and> valid_list b \<and> valid_sched b \<and>
|
|
only_timer_irq_inv timer_irq s0_internal b \<and>
|
|
silc_inv initial_aag s0_internal b \<and>
|
|
pas_refined initial_aag b \<and>
|
|
guarded_pas_domain initial_aag b \<and>
|
|
idle_equiv s0_internal b \<and>
|
|
domain_sep_inv False s0_internal b \<and>
|
|
valid_domain_list b \<and> 0 < domain_time b \<and>
|
|
scheduler_action b = resume_cur_thread)" in hoare_strengthen_post)
|
|
apply ((wp do_user_op_if_invs ct_idle_lift | simp add: ct_active_not_idle' | clarsimp)+)[2]
|
|
apply (erule use_valid[OF _ check_active_irq_if_wp])
|
|
apply (simp add: ct_in_state_def)
|
|
apply (simp add: do_user_op_A_if_def check_active_irq_A_if_def | elim exE conjE)+
|
|
apply (frule use_valid[OF _ do_user_op_if_det_inv])
|
|
apply (frule use_valid[OF _ check_active_irq_if_User_det_inv])
|
|
apply simp
|
|
apply simp
|
|
apply (erule use_valid[OF _ check_active_irq_if_wp])
|
|
apply simp
|
|
apply simp
|
|
apply (erule use_valid, erule use_valid[OF _ check_active_irq_if_wp])
|
|
apply (rule_tac Q="\<lambda>a. (invs and ct_running) and
|
|
(\<lambda>b. valid_vspace_objs_if b \<and> valid_list b \<and> valid_sched b \<and>
|
|
only_timer_irq_inv timer_irq s0_internal b \<and>
|
|
silc_inv initial_aag s0_internal b \<and>
|
|
pas_refined initial_aag b \<and>
|
|
guarded_pas_domain initial_aag b \<and>
|
|
idle_equiv s0_internal b \<and>
|
|
domain_sep_inv False s0_internal b \<and>
|
|
valid_domain_list b \<and> 0 < domain_time b \<and>
|
|
scheduler_action b = resume_cur_thread)" in hoare_strengthen_post)
|
|
apply ((wp do_user_op_if_invs | simp | clarsimp simp: ct_active_not_idle')+)[2]
|
|
apply (erule use_valid[OF _ check_active_irq_if_wp])
|
|
apply (simp add: ct_in_state_def)
|
|
apply (simp add: check_active_irq_A_if_def | elim exE conjE)+
|
|
apply (frule use_valid[OF _ check_active_irq_if_User_det_inv])
|
|
apply simp
|
|
apply simp
|
|
apply (erule use_valid[OF _ check_active_irq_if_wp])
|
|
apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def)
|
|
apply (simp add: check_active_irq_A_if_def | elim exE conjE)+
|
|
apply (frule use_valid[OF _ check_active_irq_context],simp)
|
|
apply (frule use_valid[OF _ check_active_irq_if_Idle_det_inv])
|
|
apply simp
|
|
apply simp
|
|
apply (erule use_valid[OF _ check_active_irq_if_wp])
|
|
apply (simp add: ct_in_state_def idle_context_def)
|
|
apply (simp add: check_active_irq_A_if_def | elim exE conjE)+
|
|
apply (frule use_valid[OF _ check_active_irq_if_Idle_det_inv])
|
|
apply simp
|
|
apply simp
|
|
apply (rule use_valid[OF _ check_active_irq_if_wp],assumption)
|
|
apply (simp add: ct_in_state_def)
|
|
apply (frule use_valid[OF _ check_active_irq_context],simp+)
|
|
apply (simp add: idle_context_def)
|
|
done
|
|
|
|
lemma execution_invs:
|
|
assumes e: "s \<in> execution (ADT_A_if utf) s0 js"
|
|
shows "invs_if s"
|
|
apply (insert e)
|
|
apply (induct js arbitrary: s rule: rev_induct)
|
|
apply (clarsimp simp add: execution_def Fin_ADT_if Init_ADT_if
|
|
image_def)
|
|
apply (simp add: execution_def Fin_ADT_if Init_ADT_if steps_def)
|
|
apply (simp add: execution_def steps_def image_def)
|
|
apply (erule bexE)
|
|
apply (unfold Image_def)
|
|
apply (drule CollectD)
|
|
apply (erule bexE)
|
|
apply simp
|
|
apply (rule invs_if_Step_ADT_A_if)
|
|
apply (drule_tac meta_spec)
|
|
apply (fastforce)
|
|
apply simp
|
|
apply (clarsimp simp: Fin_ADT_if ADT_A_if_def)
|
|
done
|
|
|
|
end
|
|
|
|
|
|
lemma execution_restrict:
|
|
assumes e: "s \<in> execution (ADT_A_if utf) s0 js"
|
|
shows "step_restrict s"
|
|
apply (insert e)
|
|
apply (induct js arbitrary: s rule: rev_induct)
|
|
apply (clarsimp simp add: execution_def ADT_A_if_def steps_def)
|
|
apply (clarsimp simp add: execution_def Fin_ADT_if Init_ADT_if steps_def)
|
|
apply (simp add: ADT_A_if_def)
|
|
done
|
|
|
|
lemma Step_ADT_A_if':
|
|
"((s,s') \<in> system.Step (ADT_A_if utf) u) \<Longrightarrow> ((s,s') \<in> Step (ADT_A_if utf) u)"
|
|
apply (simp add: system.Step_def execution_def steps_def ADT_A_if_def)
|
|
apply fastforce
|
|
done
|
|
|
|
|
|
context valid_initial_state begin
|
|
|
|
lemma invs_if_full_invs_if:
|
|
"invs_if s \<Longrightarrow> s \<in> full_invs_if"
|
|
by (clarsimp simp: full_invs_if_def invs_if_def Invs_def)
|
|
|
|
end
|
|
|
|
context ADT_valid_initial_state begin
|
|
|
|
lemma ADT_A_if_Step_system:
|
|
"Step_system (ADT_A_if utf) s0"
|
|
apply (rule Init_Fin_system_Step_system)
|
|
apply (rule Init_inv_Fin_system_Init_Fin_system)
|
|
apply (clarsimp simp: Init_inv_Fin_system_def ADT_A_if_def
|
|
invs_if_full_invs_if system.reachable_def extras_s0)
|
|
apply (frule execution_invs[simplified ADT_A_if_def])
|
|
apply (frule execution_restrict[simplified ADT_A_if_def])
|
|
apply (frule invs_if_full_invs_if,force)
|
|
done
|
|
|
|
lemma ADT_A_if_Run_reachable:
|
|
"(s0, t) \<in> Run (system.Step (ADT_A_if utf)) as \<Longrightarrow> system.reachable (ADT_A_if utf) s0 t"
|
|
apply (simp add: system.reachable_def)
|
|
apply (simp add: Step_system_execution_Run_s0[OF ADT_A_if_Step_system])
|
|
by blast
|
|
|
|
lemma Step_ADT_A_if:
|
|
"system.reachable (ADT_A_if utf) s0 s
|
|
\<Longrightarrow> ((s,s') \<in> system.Step (ADT_A_if utf) u) = ((s,s') \<in> Step (ADT_A_if utf) u)"
|
|
apply (simp add: system.reachable_def)
|
|
apply (clarsimp)
|
|
apply (frule execution_invs)
|
|
apply (frule invs_if_full_invs_if)
|
|
apply (frule execution_restrict)
|
|
apply (simp add: system.Step_def execution_def steps_def ADT_A_if_def)
|
|
done
|
|
|
|
lemma ADT_A_if_reachable_invs_if:
|
|
"system.reachable (ADT_A_if utf) s0 s \<Longrightarrow> invs_if s"
|
|
apply (clarsimp simp: system.reachable_def)
|
|
apply (erule execution_invs)
|
|
done
|
|
|
|
lemma ADT_A_if_reachable_full_invs_if:
|
|
"system.reachable (ADT_A_if utf) s0 s \<Longrightarrow> s \<in> full_invs_if"
|
|
apply (clarsimp simp: system.reachable_def)
|
|
apply (rule invs_if_full_invs_if)
|
|
apply (rule ADT_A_if_reachable_invs_if)
|
|
apply (simp add: system.reachable_def)
|
|
apply force
|
|
done
|
|
|
|
lemma ADT_A_if_enabled_Step_system:
|
|
"enabled_Step_system (ADT_A_if utf) s0"
|
|
by (simp add: enabled_Step_system_def ADT_A_if_Step_system ADT_A_if_enabled_system)
|
|
|
|
end
|
|
|
|
|
|
section \<open>IRQs and big step automaton enabledness\<close>
|
|
|
|
definition measuref_if :: "det_state global_sys_state \<Rightarrow> det_state global_sys_state \<Rightarrow> nat" where
|
|
"measuref_if s s' \<equiv>
|
|
(if (snd s) = KernelExit
|
|
then (if interrupted_modes (snd s') then 0
|
|
else 1 + (4 * irq_measure_if (internal_state_if s')) +
|
|
(case (snd s') of (KernelEntry e) \<Rightarrow> 3
|
|
| _ \<Rightarrow> (if (\<exists>b. (snd s') = KernelSchedule b) then 2
|
|
else (if (snd s') = KernelExit then 1 else 0))))
|
|
else (if interrupted_modes (snd s') then 2
|
|
else (if (\<exists>b. (snd s') = KernelSchedule b) then 1 else 0)))"
|
|
|
|
crunch irq_state_of_state_inv[wp]: device_memory_update "\<lambda>ms. P (irq_state ms)"
|
|
crunch irq_masks_inv[wp]: device_memory_update "\<lambda>ms. P (irq_masks ms)"
|
|
(wp: crunch_wps simp: crunch_simps no_irq_def)
|
|
|
|
lemma next_irq_state_Suc:
|
|
"\<lbrakk> irq_at cur masks = None; next_irq_state_dom (cur,masks) \<rbrakk>
|
|
\<Longrightarrow> next_irq_state (Suc cur) masks = next_irq_state cur masks"
|
|
by (simp add: next_irq_state.psimps split: if_splits)
|
|
|
|
lemma next_irq_state_Suc':
|
|
"\<lbrakk> irq_at cur masks = Some i; next_irq_state_dom (cur,masks) \<rbrakk>
|
|
\<Longrightarrow> next_irq_state cur masks = cur"
|
|
by (simp add: next_irq_state.psimps split: if_splits)
|
|
|
|
lemma is_irq_at_next_irq_state_dom':
|
|
"is_irq_at s irq pos \<Longrightarrow> next_irq_state_dom (pos,irq_masks (machine_state s))"
|
|
apply (rule next_irq_state.domintros)
|
|
apply (fastforce simp: is_irq_at_def )
|
|
done
|
|
|
|
lemma is_irq_at_next_irq_state_dom:
|
|
"\<lbrakk> pos \<le> next; is_irq_at s irq next \<rbrakk>
|
|
\<Longrightarrow> next_irq_state_dom (pos,irq_masks (machine_state s))"
|
|
apply (induct rule: inc_induct)
|
|
apply (erule is_irq_at_next_irq_state_dom')
|
|
apply (rule next_irq_state.domintros)
|
|
apply (blast)
|
|
done
|
|
|
|
lemma is_irq_at_next_irq_state:
|
|
"is_irq_at s irq pos
|
|
\<Longrightarrow> next_irq_state pos (irq_masks (machine_state s)) = pos"
|
|
apply (subst next_irq_state.psimps[OF is_irq_at_next_irq_state_dom'])
|
|
apply assumption
|
|
apply (fastforce simp: is_irq_at_def)
|
|
done
|
|
|
|
lemma next_irq_state_le:
|
|
"\<lbrakk> irq_is_recurring irq s; masks = (irq_masks (machine_state s)) \<rbrakk>
|
|
\<Longrightarrow> cur \<le> next_irq_state cur masks"
|
|
apply (clarsimp simp: irq_is_recurring_def)
|
|
apply (drule_tac x=cur in spec)
|
|
apply (erule exE)
|
|
proof -
|
|
fix m
|
|
assume i: "is_irq_at s irq (cur + m)"
|
|
have le: "cur \<le> cur + m" by simp
|
|
thus "cur \<le> next_irq_state cur (irq_masks (machine_state s))"
|
|
apply -
|
|
apply (induct rule: inc_induct)
|
|
apply (clarsimp simp: is_irq_at_next_irq_state[OF i])
|
|
apply (case_tac "is_irq_at s irq n")
|
|
apply (simp add: is_irq_at_next_irq_state)
|
|
apply (subst next_irq_state.psimps)
|
|
apply (rule is_irq_at_next_irq_state_dom[OF _ i])
|
|
apply simp
|
|
apply simp
|
|
done
|
|
qed
|
|
|
|
lemma next_irq_state_mono:
|
|
assumes lep: "pos \<le> pos'"
|
|
assumes recur: "irq_is_recurring irq s"
|
|
assumes m: "masks = irq_masks (machine_state s)"
|
|
shows "next_irq_state pos masks \<le> next_irq_state pos' masks"
|
|
apply (insert recur m)
|
|
apply (clarsimp simp: irq_is_recurring_def)
|
|
apply (drule_tac x=pos' in spec)
|
|
apply (erule exE)
|
|
proof -
|
|
fix m
|
|
assume i: "is_irq_at s irq (pos' + m)"
|
|
from lep have le: "pos \<le> pos' + m" by fastforce
|
|
from lep show "next_irq_state pos (irq_masks (machine_state s)) \<le>
|
|
next_irq_state pos' (irq_masks (machine_state s))"
|
|
apply -
|
|
apply (induct rule: inc_induct)
|
|
apply simp
|
|
apply (case_tac "is_irq_at s irq n")
|
|
apply (simp add: is_irq_at_next_irq_state)
|
|
apply (rule less_imp_le_nat)
|
|
apply (erule less_le_trans)
|
|
apply (blast intro: next_irq_state_le[OF recur])
|
|
apply (subst next_irq_state.psimps)
|
|
apply (rule is_irq_at_next_irq_state_dom[OF _ i])
|
|
apply simp
|
|
apply (clarsimp simp: is_irq_at_def Let_def)
|
|
apply (rule less_imp_le_nat)
|
|
apply (erule less_le_trans)
|
|
apply (blast intro: next_irq_state_le[OF recur])
|
|
done
|
|
qed
|
|
|
|
lemma recurring_next_irq_state_dom:
|
|
"irq_is_recurring irq s \<Longrightarrow> next_irq_state_dom (n,irq_masks (machine_state s))"
|
|
apply (clarsimp simp: irq_is_recurring_def)
|
|
apply (drule_tac x=n in spec)
|
|
apply (erule exE)
|
|
proof -
|
|
fix m
|
|
assume i: "is_irq_at s irq (n + m)"
|
|
have "n \<le> n + m" by simp
|
|
thus "next_irq_state_dom (n, irq_masks (machine_state s))"
|
|
proof(induct rule: inc_induct)
|
|
from i obtain irq where a: "irq_at (n + m) (irq_masks (machine_state s)) = Some irq"
|
|
by (fastforce simp: is_irq_at_def)
|
|
show "next_irq_state_dom (n + m, irq_masks (machine_state s))"
|
|
using a by (fastforce intro: next_irq_state.domintros)
|
|
next
|
|
fix i
|
|
assume "next_irq_state_dom (Suc i, irq_masks (machine_state s))"
|
|
thus "next_irq_state_dom (i, irq_masks (machine_state s))"
|
|
by (rule next_irq_state.domintros)
|
|
qed
|
|
qed
|
|
|
|
lemma next_irq_state_less:
|
|
"\<lbrakk> irq_at cur masks = None; irq_is_recurring irq s; masks = (irq_masks (machine_state s)) \<rbrakk>
|
|
\<Longrightarrow> cur < next_irq_state cur masks"
|
|
apply (frule_tac n=cur in recurring_next_irq_state_dom)
|
|
apply (simp add: next_irq_state.psimps)
|
|
apply (rule less_le_trans[OF _ next_irq_state_le])
|
|
apply simp
|
|
apply assumption
|
|
apply (rule refl)
|
|
done
|
|
|
|
lemma next_irq_state_Suc_le:
|
|
assumes recur: "irq_is_recurring irq s"
|
|
assumes m: "masks = irq_masks (machine_state s)"
|
|
shows "next_irq_state pos masks \<le> next_irq_state (Suc pos) masks"
|
|
by (rule next_irq_state_mono[OF _ recur m], simp)
|
|
|
|
lemma irq_state_inv_refl:
|
|
"irq_state_inv s s"
|
|
by (simp add: irq_state_inv_def)
|
|
|
|
lemma irq_state_inv_triv:
|
|
assumes irq_state: "\<And>P. f \<lbrace>\<lambda>s. P (irq_state_of_state s)\<rbrace>"
|
|
assumes irq_masks: "\<And>P. f \<lbrace>\<lambda>s. P (irq_masks_of_state s)\<rbrace>"
|
|
shows "f \<lbrace>irq_state_inv st\<rbrace>"
|
|
apply (clarsimp simp: valid_def irq_state_inv_def)
|
|
apply (rule use_valid[OF _ irq_state], assumption)
|
|
apply (erule use_valid[OF _ irq_masks])
|
|
apply simp
|
|
done
|
|
|
|
lemma irq_state_inv_triv':
|
|
assumes irq_state: "\<And>P. f \<lbrace>\<lambda>s. P (irq_state_of_state s)\<rbrace>"
|
|
assumes irq_masks: "\<And>P. \<lbrace>(\<lambda>s. P (irq_masks_of_state s)) and Q\<rbrace> f \<lbrace>\<lambda>_ s. P (irq_masks_of_state s)\<rbrace>"
|
|
shows "\<lbrace>irq_state_inv st and Q\<rbrace> f \<lbrace>\<lambda>_. irq_state_inv st\<rbrace>"
|
|
apply (clarsimp simp: valid_def irq_state_inv_def)
|
|
apply (rule use_valid[OF _ irq_state], assumption)
|
|
apply (erule use_valid[OF _ irq_masks])
|
|
apply simp
|
|
done
|
|
|
|
lemma OR_choiceE_wp:
|
|
assumes a: "\<And>s. \<lbrace>P and (=) s\<rbrace> b \<lbrace>\<lambda> r s'. (r \<longrightarrow> P' s) \<and> (\<not> r \<longrightarrow> P'' s)\<rbrace>"
|
|
assumes b: "\<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>"
|
|
assumes c: "\<lbrace>P''\<rbrace> g \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>"
|
|
shows "\<lbrace>P\<rbrace> OR_choiceE b f g \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>"
|
|
apply (simp add: OR_choiceE_def)
|
|
apply (wp b c | wpc)+
|
|
apply (clarsimp simp: mk_ef_def wrap_ext_bool_det_ext_ext_def)
|
|
apply (drule a[simplified valid_def, rule_format, rotated])
|
|
apply simp
|
|
apply (fastforce split: prod.splits)
|
|
done
|
|
|
|
lemma preemption_point_irq_state_inv'[wp]:
|
|
"\<lbrace>irq_state_inv st and K (irq_is_recurring irq st)\<rbrace>
|
|
preemption_point
|
|
\<lbrace>\<lambda>_. irq_state_inv st\<rbrace>, \<lbrace>\<lambda>_. irq_state_next st\<rbrace>"
|
|
apply (simp add: preemption_point_def)
|
|
apply (wpsimp wp: OR_choiceE_wp[where P'="irq_state_inv st and K(irq_is_recurring irq st)"
|
|
and P''="irq_state_inv st and K(irq_is_recurring irq st)"]
|
|
simp: reset_work_units_def)+
|
|
apply simp
|
|
apply (wpsimp wp: OR_choiceE_wp dmo_getActiveIRQ_wp simp: reset_work_units_def)+
|
|
apply (clarsimp simp: irq_state_inv_def)
|
|
apply (simp add: next_irq_state_Suc[OF _ recurring_next_irq_state_dom])
|
|
apply (clarsimp simp: irq_state_next_def)
|
|
apply (simp add: next_irq_state_Suc'[OF _ recurring_next_irq_state_dom])
|
|
apply (wp | simp add: update_work_units_def irq_state_inv_def | fastforce)+
|
|
done
|
|
|
|
lemma validE_validE_E':
|
|
"\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> f -, \<lbrace>E\<rbrace>"
|
|
apply (rule validE_validE_E)
|
|
apply (rule hoare_post_impErr)
|
|
apply assumption
|
|
apply simp+
|
|
done
|
|
|
|
lemmas preemption_point_irq_state_inv[wp] = validE_validE_R'[OF preemption_point_irq_state_inv']
|
|
lemmas preemption_point_irq_state_next[wp] = validE_validE_E'[OF preemption_point_irq_state_inv']
|
|
|
|
lemma hoare_add_postE:
|
|
"\<lbrakk> \<lbrace>S\<rbrace> f \<lbrace>\<lambda>_. S'\<rbrace>; \<lbrace>P\<rbrace> f \<lbrace>\<lambda>r s. S' s \<longrightarrow> Q r s\<rbrace>, \<lbrace>\<lambda>r s. S' s \<longrightarrow> E r s\<rbrace> \<rbrakk>
|
|
\<Longrightarrow> \<lbrace>P and S\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
|
|
apply (clarsimp simp: validE_def)
|
|
apply (rule hoare_add_post)
|
|
apply assumption
|
|
apply simp
|
|
apply (rule hoare_strengthen_post)
|
|
apply (rule hoare_pre)
|
|
apply (assumption, simp, fastforce split: sum.splits)
|
|
done
|
|
|
|
lemma rec_del_irq_state_inv':
|
|
notes drop_spec_valid[wp_split del] drop_spec_validE[wp_split del] rec_del.simps[simp del]
|
|
shows
|
|
"s \<turnstile> \<lbrace>irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\<rbrace>
|
|
rec_del call
|
|
\<lbrace>\<lambda>a s. (case call of FinaliseSlotCall x y \<Rightarrow> y \<or> fst a \<longrightarrow> snd a = NullCap
|
|
| _ \<Rightarrow> True) \<and>
|
|
domain_sep_inv False sta s \<and> irq_state_inv st s\<rbrace>, \<lbrace>\<lambda>_. irq_state_next st\<rbrace>"
|
|
proof (induct s arbitrary: rule: rec_del.induct, simp_all only: rec_del_fails hoare_fail_any)
|
|
case (1 slot exposed s) show ?case
|
|
apply (simp add: split_def rec_del.simps)
|
|
apply (wp drop_spec_validE[OF returnOk_wp]
|
|
drop_spec_validE[OF liftE_wp] empty_slot_domain_sep_inv)
|
|
apply (wp irq_state_inv_triv' empty_slot_irq_masks)
|
|
apply (rule spec_strengthen_postE[OF "1.hyps", simplified])
|
|
apply fastforce
|
|
done
|
|
next
|
|
case (2 slot exposed s) show ?case
|
|
apply (rule hoare_spec_gen_asm)
|
|
apply (simp add: rec_del.simps split del: if_split)
|
|
apply (rule hoare_pre_spec_validE)
|
|
apply (wp drop_spec_validE[OF returnOk_wp] drop_spec_validE[OF liftE_wp] set_cap_domain_sep_inv
|
|
| simp add: split_def split del: if_split)+
|
|
apply (wp irq_state_inv_triv)[1]
|
|
apply (wp | simp split del: if_split)+
|
|
apply (rule spec_strengthen_postE)
|
|
apply (rule "2.hyps"[simplified], fastforce+)
|
|
apply (rule drop_spec_validE,
|
|
(wp preemption_point_irq_state_inv[where irq=irq] | simp)+)[1]
|
|
apply (rule spec_strengthen_postE)
|
|
apply (rule "2.hyps"[simplified], fastforce+)
|
|
apply (wp finalise_cap_domain_sep_inv_cap get_cap_wp
|
|
finalise_cap_returns_NullCap[where irqs=False, simplified]
|
|
drop_spec_validE[OF liftE_wp] set_cap_domain_sep_inv
|
|
| simp add: without_preemption_def split del: if_split
|
|
| wp (once) hoare_drop_imps
|
|
| wp irq_state_inv_triv)+
|
|
apply (blast dest: cte_wp_at_domain_sep_inv_cap)
|
|
done
|
|
next
|
|
case (3 ptr bits n slot s) show ?case
|
|
apply (simp add: rec_del.simps)
|
|
apply (wp drop_spec_validE[OF returnOk_wp] drop_spec_validE[OF liftE_wp] irq_state_inv_triv)
|
|
apply (rule hoare_pre_spec_validE)
|
|
apply (wp drop_spec_validE[OF assertE_wp])
|
|
apply (fastforce)
|
|
done
|
|
next
|
|
case (4 ptr bits n slot s) show ?case
|
|
apply (simp add: rec_del.simps)
|
|
apply (wpsimp wp: irq_state_inv_triv set_cap_domain_sep_inv drop_spec_validE[OF liftE_wp]
|
|
drop_spec_validE[OF assertE_wp] drop_spec_validE[OF returnOk_wp] get_cap_wp)
|
|
apply (rule spec_strengthen_postE[OF "4.hyps", simplified])
|
|
apply (simp add: returnOk_def return_def)
|
|
apply (clarsimp simp: domain_sep_inv_cap_def)
|
|
done
|
|
qed
|
|
|
|
lemma rec_del_irq_state_inv:
|
|
"\<lbrace>irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\<rbrace>
|
|
rec_del call
|
|
\<lbrace>\<lambda>_. irq_state_inv st\<rbrace>, \<lbrace>\<lambda>_. irq_state_next st\<rbrace>"
|
|
apply (rule hoare_post_impErr)
|
|
apply (rule use_spec)
|
|
apply (rule rec_del_irq_state_inv')
|
|
apply auto
|
|
done
|
|
|
|
lemma cap_delete_irq_state_inv':
|
|
"\<lbrace>irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\<rbrace>
|
|
cap_delete slot
|
|
\<lbrace>\<lambda>_. irq_state_inv st\<rbrace>, \<lbrace>\<lambda>_. irq_state_next st\<rbrace>"
|
|
by (wpsimp wp: rec_del_irq_state_inv simp: cap_delete_def) auto
|
|
|
|
lemmas cap_delete_irq_state_inv[wp] = validE_validE_R'[OF cap_delete_irq_state_inv']
|
|
lemmas cap_delete_irq_state_next[wp] = validE_validE_E'[OF cap_delete_irq_state_inv']
|
|
|
|
lemma cap_revoke_irq_state_inv'':
|
|
notes drop_spec_valid[wp_split del] drop_spec_validE[wp_split del]
|
|
shows
|
|
"s \<turnstile> \<lbrace>irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\<rbrace>
|
|
cap_revoke slot
|
|
\<lbrace>\<lambda>_. irq_state_inv st\<rbrace>, \<lbrace>\<lambda>_. irq_state_next st\<rbrace>"
|
|
proof(induct rule: cap_revoke.induct[where ?a1.0=s])
|
|
case (1 slot s)
|
|
show ?case
|
|
apply (subst cap_revoke.simps)
|
|
apply (rule hoare_spec_gen_asm)
|
|
apply (rule hoare_pre_spec_validE)
|
|
apply (wp "1.hyps")
|
|
apply (wp spec_valid_conj_liftE2 | simp)+
|
|
apply (wp drop_spec_validE[OF preemption_point_irq_state_inv[simplified validE_R_def]]
|
|
drop_spec_validE[OF preemption_point_irq_state_inv'[where irq=irq]]
|
|
drop_spec_validE[OF valid_validE[OF preemption_point_domain_sep_inv]]
|
|
cap_delete_domain_sep_inv cap_delete_irq_state_inv
|
|
drop_spec_validE[OF assertE_wp] drop_spec_validE[OF returnOk_wp]
|
|
drop_spec_validE[OF liftE_wp] drop_spec_validE[OF hoare_vcg_conj_liftE1]
|
|
| simp | wp (once) hoare_drop_imps)+
|
|
apply fastforce
|
|
done
|
|
qed
|
|
|
|
lemmas cap_revoke_irq_state_inv' = use_spec(2)[OF cap_revoke_irq_state_inv'']
|
|
lemmas cap_revoke_irq_state_inv[wp] = validE_validE_R'[OF cap_revoke_irq_state_inv']
|
|
lemmas cap_revoke_irq_state_next[wp] = validE_validE_E'[OF cap_revoke_irq_state_inv']
|
|
|
|
lemma finalise_slot_irq_state_inv:
|
|
"\<lbrace>irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\<rbrace>
|
|
finalise_slot p e
|
|
\<lbrace>\<lambda>_ s. irq_state_inv st s\<rbrace>, \<lbrace>\<lambda>_. irq_state_next st\<rbrace>"
|
|
by (wpsimp wp: rec_del_irq_state_inv[folded validE_R_def] simp: finalise_slot_def) blast
|
|
|
|
lemma invoke_cnode_irq_state_inv:
|
|
"\<lbrace>irq_state_inv st and domain_sep_inv False sta
|
|
and valid_cnode_inv cnode_invocation and K (irq_is_recurring irq st)\<rbrace>
|
|
invoke_cnode cnode_invocation
|
|
\<lbrace>\<lambda>_. irq_state_inv st\<rbrace>, \<lbrace>\<lambda>_. irq_state_next st\<rbrace>"
|
|
apply (rule hoare_assume_preE)
|
|
apply (simp add: invoke_cnode_def)
|
|
apply (rule hoare_pre)
|
|
apply wpc
|
|
apply ((wp cap_revoke_irq_state_inv' cap_delete_irq_state_inv hoare_vcg_all_lift
|
|
| wpc
|
|
| simp add: cap_move_def split del: if_split
|
|
| wp (once) irq_state_inv_triv
|
|
| wp (once) hoare_drop_imps)+)[7]
|
|
apply fastforce
|
|
done
|
|
|
|
lemma checked_insert_irq_state_of_state[wp]:
|
|
"check_cap_at a b (check_cap_at c d (cap_insert e f g)) \<lbrace>\<lambda>s. P (irq_state_of_state s)\<rbrace>"
|
|
by (wp | simp add: check_cap_at_def)+
|
|
|
|
lemma irq_state_inv_invoke_domain[wp]:
|
|
"invoke_domain a b \<lbrace>irq_state_inv st\<rbrace>"
|
|
apply (simp add: irq_state_inv_def[abs_def])
|
|
apply (rule hoare_pre)
|
|
apply wps
|
|
apply (wp | clarsimp)+
|
|
done
|
|
|
|
crunch irq_state_of_state: bind_notification "\<lambda>s. P (irq_state_of_state s)"
|
|
crunch machine_state[wp]: set_mcpriority "\<lambda>s. P (machine_state s)"
|
|
|
|
lemmas bind_notification_irq_state_inv[wp] =
|
|
irq_state_inv_triv[OF bind_notification_irq_state_of_state bind_notification_irq_masks]
|
|
|
|
lemma do_reply_transfer_irq_state_inv_triv[wp]:
|
|
"do_reply_transfer a b c d \<lbrace>irq_state_inv st\<rbrace>"
|
|
by (wp irq_state_inv_triv)
|
|
|
|
lemma set_domain_irq_state_inv_triv[wp]:
|
|
"set_domain a b \<lbrace>irq_state_inv st\<rbrace>"
|
|
by (wp irq_state_inv_triv)
|
|
|
|
lemma use_validE_E:
|
|
"\<lbrakk> (Inl r, s') \<in> fst (fa s); \<lbrace>P\<rbrace> fa -, \<lbrace>Q\<rbrace>; P s \<rbrakk> \<Longrightarrow> Q r s'"
|
|
by (fastforce simp: validE_E_def validE_def valid_def)
|
|
|
|
lemma irq_state_inv_trivE':
|
|
assumes irq_state:
|
|
"\<And>P. f \<lbrace>\<lambda>s. P (irq_state_of_state s)\<rbrace>"
|
|
assumes irq_masks:
|
|
"\<And>P. \<lbrace>(\<lambda>s. P (irq_masks_of_state s)) and Q\<rbrace> f \<lbrace>\<lambda>_ s. P (irq_masks_of_state s)\<rbrace>"
|
|
assumes no_err:
|
|
"\<And>P. \<lbrace>\<top>\<rbrace> f -, \<lbrace>P\<rbrace>"
|
|
shows
|
|
"\<lbrace>irq_state_inv st and Q\<rbrace> f \<lbrace>\<lambda>_. irq_state_inv st\<rbrace>, \<lbrace>\<lambda>_. irq_state_next st\<rbrace>"
|
|
apply (clarsimp simp: validE_def valid_def irq_state_inv_def split: sum.splits)
|
|
apply (rule use_valid[OF _ irq_state], assumption)
|
|
apply (rule use_valid[OF _ irq_masks],assumption)
|
|
apply clarsimp
|
|
apply (erule use_validE_E[OF _ no_err])
|
|
apply simp
|
|
done
|
|
|
|
|
|
context ADT_IF_1 begin
|
|
|
|
crunch irq_state_of_state[wp]: invoke_irq_control "\<lambda>s. P (irq_state_of_state s)"
|
|
|
|
lemma invoke_irq_control_noErr[wp]:
|
|
"\<lbrace>\<top>\<rbrace> invoke_irq_control a -,\<lbrace>\<lambda>rv s :: det_state. Q rv s\<rbrace>"
|
|
by (cases a; wpsimp simp: arch_invoke_irq_control_noErr)
|
|
|
|
lemma invoke_untyped_irq_state_inv:
|
|
"\<lbrace>irq_state_inv st and K (irq_is_recurring irq st)\<rbrace>
|
|
invoke_untyped ui
|
|
\<lbrace>\<lambda>_. irq_state_inv st\<rbrace>, \<lbrace>\<lambda>_. irq_state_next st\<rbrace>"
|
|
apply (cases ui, simp add: invoke_untyped_def mapM_x_def[symmetric])
|
|
apply (rule hoare_pre)
|
|
apply (wp mapM_x_wp' whenE_wp reset_untyped_cap_irq_state_inv[where irq=irq]
|
|
| rule irq_state_inv_triv | simp)+
|
|
done
|
|
|
|
lemma perform_invocation_irq_state_inv:
|
|
"\<lbrace>irq_state_inv st and domain_sep_inv False (sta :: det_state)
|
|
and valid_invocation op and K (irq_is_recurring irq st)
|
|
and (\<lambda>s. \<forall>i. op = InvokeIRQHandler i \<longrightarrow>
|
|
(\<exists>p. cte_wp_at ((=) (IRQHandlerCap (irq_of_handler_inv i))) p s))\<rbrace>
|
|
perform_invocation x y op
|
|
\<lbrace>\<lambda>_. irq_state_inv st\<rbrace>, \<lbrace>\<lambda>_. irq_state_next st\<rbrace>"
|
|
apply (case_tac op; simp;
|
|
(solves \<open>(wp invoke_untyped_irq_state_inv[where irq=irq] irq_state_inv_triv
|
|
invoke_tcb_irq_state_inv invoke_cnode_irq_state_inv[simplified validE_R_def]
|
|
| clarsimp | simp add: invoke_domain_def)+\<close>)?)
|
|
apply wp
|
|
apply (wp irq_state_inv_triv' invoke_irq_control_irq_masks)
|
|
apply clarsimp
|
|
apply assumption
|
|
apply auto[1]
|
|
apply wp
|
|
apply (wp irq_state_inv_triv' invoke_irq_handler_irq_masks | clarsimp)+
|
|
apply assumption
|
|
apply auto[1]
|
|
done
|
|
|
|
lemma hoare_drop_impE:
|
|
assumes a: "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>"
|
|
shows "\<lbrace>P\<rbrace> f \<lbrace>\<lambda> r s. R r s \<longrightarrow> Q r s\<rbrace>, \<lbrace>E\<rbrace>"
|
|
using assms by (fastforce simp: validE_def valid_def split: sum.splits)
|
|
|
|
lemma handle_invocation_irq_state_inv:
|
|
"\<lbrace>invs and domain_sep_inv False (sta :: det_state)
|
|
and irq_state_inv st and K (irq_is_recurring irq st)\<rbrace>
|
|
handle_invocation x y
|
|
\<lbrace>\<lambda>_. irq_state_inv st\<rbrace>, \<lbrace>\<lambda>_. irq_state_next st\<rbrace>"
|
|
apply (simp add: handle_invocation_def ts_Restart_case_helper split_def
|
|
liftE_liftM_liftME liftME_def bindE_assoc
|
|
split del: if_split)
|
|
apply (wp syscall_valid)
|
|
apply ((wp irq_state_inv_triv | wpc | simp)+)[2]
|
|
apply (wp static_imp_wp perform_invocation_irq_state_inv hoare_vcg_all_lift
|
|
hoare_vcg_ex_lift decode_invocation_IRQHandlerCap
|
|
| wpc
|
|
| wp (once) hoare_drop_imps
|
|
| simp split del: if_split
|
|
| wp (once) irq_state_inv_triv)+
|
|
apply fastforce
|
|
done
|
|
|
|
lemma handle_event_irq_state_inv:
|
|
"event \<noteq> Interrupt
|
|
\<Longrightarrow> \<lbrace>irq_state_inv st and invs and domain_sep_inv False (sta :: det_state)
|
|
and K (irq_is_recurring irq st)\<rbrace>
|
|
handle_event event
|
|
\<lbrace>\<lambda>_. irq_state_inv st\<rbrace>, \<lbrace>\<lambda>_. irq_state_next st\<rbrace>"
|
|
apply (case_tac event; simp)
|
|
apply (rename_tac syscall)
|
|
apply (case_tac syscall)
|
|
by (simp add: handle_send_def handle_call_def
|
|
| wp handle_invocation_irq_state_inv[where sta=sta and irq=irq]
|
|
irq_state_inv_triv[OF handle_recv_irq_state_of_state] irq_state_inv_triv
|
|
irq_state_inv_triv[OF handle_reply_irq_state_of_state] hy_inv)+
|
|
|
|
end
|
|
|
|
|
|
lemma schedule_if_irq_state_inv:
|
|
"schedule_if tc \<lbrace>irq_state_inv st\<rbrace>"
|
|
by (wp irq_state_inv_triv
|
|
| simp add: schedule_if_def activate_thread_def
|
|
| wpc
|
|
| wp (once) hoare_drop_imps)+
|
|
|
|
lemma irq_measure_if_inv:
|
|
assumes irq_state:
|
|
"\<And>st. \<lbrace>P st\<rbrace> f \<lbrace>\<lambda>_. irq_state_inv st\<rbrace>,-"
|
|
shows
|
|
"\<lbrace>\<lambda>s. irq_measure_if_inv st s \<and> (irq_state_inv s s \<longrightarrow> P s s)\<rbrace> f \<lbrace>\<lambda>_. irq_measure_if_inv st\<rbrace>, -"
|
|
apply (clarsimp simp: valid_def validE_R_def validE_def)
|
|
apply (simp add: irq_measure_if_inv_def)
|
|
apply (erule order_trans[rotated])
|
|
apply (simp add: irq_state_inv_refl)
|
|
apply (drule use_validE_R, rule irq_state, assumption)
|
|
apply (auto simp: irq_state_inv_def irq_measure_if_inv_def Let_def irq_measure_if_def)
|
|
done
|
|
|
|
lemma irq_measure_if_inv_old:
|
|
assumes irq_state:
|
|
"\<And>st. \<lbrace>irq_state_inv st and Q\<rbrace> f \<lbrace>\<lambda>_. irq_state_inv st\<rbrace>, -"
|
|
shows
|
|
"\<lbrace>irq_measure_if_inv st and Q\<rbrace> f \<lbrace>\<lambda>_. irq_measure_if_inv st\<rbrace>, -"
|
|
by (wpsimp wp: irq_measure_if_inv irq_state)
|
|
|
|
lemma irq_measure_if_inv':
|
|
assumes irq_state:
|
|
"\<And>st. \<lbrace>P st\<rbrace> f \<lbrace>\<lambda>_. irq_state_inv st\<rbrace>"
|
|
shows
|
|
"\<lbrace>\<lambda>s. irq_measure_if_inv st s \<and> (irq_state_inv s s \<longrightarrow> P s s)\<rbrace> f \<lbrace>\<lambda>_. irq_measure_if_inv st\<rbrace>"
|
|
apply (clarsimp simp: valid_def irq_measure_if_inv_def irq_state_inv_refl)
|
|
apply (erule le_trans[rotated])
|
|
apply (drule(1) use_valid[OF _ irq_state])
|
|
apply (clarsimp simp: irq_measure_if_def Let_def irq_state_inv_def)
|
|
apply auto
|
|
done
|
|
|
|
lemma irq_measure_if_inv_old':
|
|
assumes irq_state:
|
|
"\<And>st. \<lbrace>irq_state_inv st and Q\<rbrace> f \<lbrace>\<lambda>_. irq_state_inv st\<rbrace>"
|
|
shows
|
|
"\<lbrace>irq_measure_if_inv st and Q\<rbrace> f \<lbrace>\<lambda>_. irq_measure_if_inv st\<rbrace>"
|
|
by (wpsimp wp: irq_measure_if_inv' irq_state)
|
|
|
|
lemma irq_state_inv_irq_is_recurring:
|
|
"irq_state_inv sta s \<Longrightarrow> irq_is_recurring irq sta = irq_is_recurring irq s"
|
|
by (clarsimp simp: irq_is_recurring_def irq_state_inv_def is_irq_at_def)
|
|
|
|
abbreviation next_irq_state_of_state where
|
|
"next_irq_state_of_state s \<equiv> next_irq_state (Suc (irq_state_of_state s)) (irq_masks_of_state s)"
|
|
|
|
|
|
context ADT_IF_1 begin
|
|
|
|
lemma kernel_entry_if_next_irq_state_of_state:
|
|
"\<lbrakk> event \<noteq> Interrupt; invs i_s; domain_sep_inv False (st :: det_state) i_s;
|
|
irq_is_recurring irq i_s; ((Inr (), a), b) \<in> fst (kernel_entry_if event uc i_s) \<rbrakk>
|
|
\<Longrightarrow> next_irq_state_of_state b = next_irq_state_of_state i_s"
|
|
apply (simp add: kernel_entry_if_def in_bind in_return | elim conjE exE)+
|
|
apply (erule use_validE_R)
|
|
apply (rule_tac Q'="\<lambda>_. irq_state_inv i_s" in hoare_post_imp_R)
|
|
apply (rule validE_validE_R')
|
|
apply (rule handle_event_irq_state_inv[where sta=st and irq=irq] | simp)+
|
|
apply (clarsimp simp: irq_state_inv_def)
|
|
apply (simp add: arch_tcb_update_aux2)
|
|
apply (erule_tac f="thread_set (tcb_arch_update (arch_tcb_context_set uc)) t" in use_valid)
|
|
apply (wpsimp wp: irq_measure_if_inv' irq_state_inv_triv
|
|
thread_set_invs_trivial irq_is_recurring_triv
|
|
simp: ran_tcb_cap_cases)+
|
|
apply (erule use_valid)
|
|
apply (wp | simp )+
|
|
apply (simp add: irq_state_inv_def)
|
|
done
|
|
|
|
lemma kernel_entry_if_next_irq_state_of_state_next:
|
|
"\<lbrakk> event \<noteq> Interrupt; invs i_s; domain_sep_inv False (st :: det_state) i_s;
|
|
irq_is_recurring irq i_s; ((Inl r, a), b) \<in> fst (kernel_entry_if event uc i_s) \<rbrakk>
|
|
\<Longrightarrow> irq_state_of_state b = next_irq_state_of_state i_s"
|
|
apply (simp add: kernel_entry_if_def in_bind in_return | elim conjE exE)+
|
|
apply (erule use_validE_E)
|
|
apply (rule validE_validE_E)
|
|
apply (rule hoare_post_impErr)
|
|
apply (rule handle_event_irq_state_inv[where sta=st and irq=irq and st=i_s])
|
|
apply simp+
|
|
apply (simp add: irq_state_next_def)
|
|
apply (simp add: arch_tcb_update_aux2)
|
|
apply (erule_tac f="thread_set (tcb_arch_update (arch_tcb_context_set uc)) t" in use_valid)
|
|
apply (wpsimp wp: irq_measure_if_inv' irq_state_inv_triv
|
|
thread_set_invs_trivial irq_is_recurring_triv
|
|
simp: ran_tcb_cap_cases)+
|
|
apply (erule use_valid)
|
|
apply (wp | simp )+
|
|
apply (simp add: irq_state_inv_def)
|
|
done
|
|
|
|
lemma kernel_entry_if_irq_measure:
|
|
"\<lbrakk> event \<noteq> Interrupt; invs i_s; domain_sep_inv False (st :: det_state) i_s;
|
|
irq_is_recurring irq i_s; ((Inr (), a), b) \<in> fst (kernel_entry_if event uc i_s) \<rbrakk>
|
|
\<Longrightarrow> irq_measure_if b \<le> irq_measure_if i_s"
|
|
apply (fold irq_measure_if_inv_def)
|
|
apply (rule mp)
|
|
apply (erule_tac P="(=) i_s" and Q="\<lambda>rv s. (isRight (fst rv)) \<longrightarrow> Q s" for Q in use_valid)
|
|
apply (simp_all add: isRight_def)
|
|
apply (simp add: kernel_entry_if_def)
|
|
apply (rule hoare_pre, wp)
|
|
apply (rule validE_cases_valid, simp)
|
|
apply (wp irq_measure_if_inv handle_event_irq_state_inv[THEN validE_validE_R'])+
|
|
apply (wpsimp wp: irq_measure_if_inv' irq_state_inv_triv
|
|
thread_set_invs_trivial irq_is_recurring_triv
|
|
simp: ran_tcb_cap_cases arch_tcb_update_aux2 irq_state_inv_refl)+
|
|
apply (simp add: irq_measure_if_inv_def)
|
|
done
|
|
|
|
end
|
|
|
|
|
|
lemma schedule_if_irq_measure_if:
|
|
"(r, b) \<in> fst (schedule_if uc i_s) \<Longrightarrow> irq_measure_if b \<le> irq_measure_if i_s"
|
|
apply (fold irq_measure_if_inv_def)
|
|
apply (erule use_valid[OF _ irq_measure_if_inv'] | wp schedule_if_irq_state_inv | simp)+
|
|
apply (simp add: irq_measure_if_inv_def)
|
|
done
|
|
|
|
lemma schedule_if_next_irq_state_of_state:
|
|
"(r, b) \<in> fst (schedule_if uc i_s) \<Longrightarrow> next_irq_state_of_state b = next_irq_state_of_state i_s"
|
|
apply (erule use_valid)
|
|
apply (rule_tac Q="\<lambda>_. irq_state_inv i_s" in hoare_strengthen_post)
|
|
apply (wp schedule_if_irq_state_inv)
|
|
apply (auto simp: irq_state_inv_def)
|
|
done
|
|
|
|
lemma next_irq_state_of_state_triv:
|
|
assumes masks: "\<And>P. f \<lbrace>\<lambda>s. P (irq_masks_of_state s)\<rbrace>"
|
|
assumes sta: "\<And>P. f \<lbrace>\<lambda>s. P (irq_state_of_state s)\<rbrace>"
|
|
shows "f \<lbrace>\<lambda>s. P (next_irq_state_of_state s)\<rbrace>"
|
|
apply (clarsimp simp: valid_def)
|
|
apply (frule (1) use_valid[OF _ masks])
|
|
apply (erule (1) use_valid[OF _ sta])
|
|
done
|
|
|
|
lemma interrupted_modes_KernelEntry[simp]:
|
|
"interrupted_modes (KernelEntry e) = (e = Interrupt)"
|
|
by (case_tac e, simp_all)
|
|
|
|
lemma rah4:
|
|
"b < a \<Longrightarrow> 4 * (a - Suc b) + 3 < 4 * (a - b)"
|
|
by (simp add: Suc_le_lessD)
|
|
|
|
lemma kernel_exit_irq_masks[wp]:
|
|
"\<lbrace>\<lambda>s. P (irq_masks_of_state s)\<rbrace> kernel_exit_if uc \<lbrace>\<lambda>r s. P (irq_masks_of_state s)\<rbrace>"
|
|
apply (simp add: kernel_exit_if_def)
|
|
apply wp
|
|
done
|
|
|
|
|
|
context valid_initial_state begin
|
|
|
|
lemma invs_if_irq_is_recurring[simp]:
|
|
"invs_if s \<Longrightarrow> irq_is_recurring timer_irq (internal_state_if s)"
|
|
by (clarsimp simp: invs_if_def Invs_def only_timer_irq_inv_def only_timer_irq_def)
|
|
|
|
lemma tranclp_s0:
|
|
"big_step_R\<^sup>*\<^sup>* s0 s \<Longrightarrow> interrupted_modes (snd s) \<or> (snd s) = KernelExit"
|
|
apply (simp only: rtranclp_def2)
|
|
apply (erule disjE)
|
|
apply (induct rule: tranclp.induct)
|
|
apply (auto simp: big_step_R_def s0_def)
|
|
done
|
|
|
|
lemma ADT_A_if_sub_big_steps_measuref_if:
|
|
"\<lbrakk> (s',evs) \<in> sub_big_steps (ADT_A_if utf) big_step_R s; big_step_R\<^sup>*\<^sup>* s0 s \<rbrakk>
|
|
\<Longrightarrow> measuref_if s s' > 0"
|
|
apply (drule tranclp_s0)
|
|
apply (erule sub_big_steps.induct)
|
|
apply (clarsimp simp: big_step_R_def measuref_if_def)
|
|
apply (clarsimp simp: big_step_R_def measuref_if_def split: if_splits)
|
|
apply (case_tac ba, simp_all, case_tac bc)
|
|
by (fastforce simp: Step_ADT_A_if' ADT_A_if_def global_automaton_if_def)+
|
|
|
|
lemma rah_simp:
|
|
"(\<forall>b. b) = False"
|
|
by blast
|
|
|
|
lemma invs_if_domain_sep_invs[intro]:
|
|
"invs_if ((a,s),b) \<Longrightarrow> domain_sep_inv False s0_internal s"
|
|
by (simp add: invs_if_def Invs_def)
|
|
|
|
lemma invs_if_invs[intro]:
|
|
"invs_if ((a,s),b) \<Longrightarrow> invs s"
|
|
by (simp add: invs_if_def Invs_def)
|
|
|
|
end
|
|
|
|
|
|
context ADT_valid_initial_state begin
|
|
|
|
lemmas do_user_op_if_next_irq_state_of_state =
|
|
next_irq_state_of_state_triv[OF do_user_op_if_irq_masks_of_state do_user_op_if_irq_state_of_state]
|
|
|
|
lemma ADT_A_if_Step_measure_if':
|
|
"\<lbrakk> (s,s') \<in> data_type.Step (ADT_A_if utf) x; invs_if s; measuref_if y s > 0 \<rbrakk>
|
|
\<Longrightarrow> measuref_if y s' < measuref_if y s \<and>
|
|
(\<not> interrupted_modes (snd s)
|
|
\<longrightarrow> \<not> interrupted_modes (snd s')
|
|
\<longrightarrow> next_irq_state_of_state (internal_state_if s') =
|
|
next_irq_state_of_state (internal_state_if s))"
|
|
apply (frule invs_if_irq_is_recurring)
|
|
apply (case_tac s, clarsimp)
|
|
apply (rename_tac uc i_s mode)
|
|
apply (case_tac mode)
|
|
apply (simp_all add: rah_simp system.Step_def execution_def steps_def ADT_A_if_def
|
|
global_automaton_if_def check_active_irq_A_if_def do_user_op_A_if_def
|
|
check_active_irq_if_def in_monad measuref_if_def
|
|
| safe | split if_splits)+
|
|
apply (frule getActiveIRQ_None)
|
|
apply (erule use_valid[OF _ do_user_op_if_irq_measure_if])
|
|
apply (erule use_valid[OF _ dmo_getActiveIRQ_wp])
|
|
apply (clarsimp simp: irq_measure_if_def Let_def)
|
|
apply (simp add: next_irq_state_Suc recurring_next_irq_state_dom)
|
|
apply (blast intro: rah4[OF next_irq_state_less])
|
|
apply (frule getActiveIRQ_None)
|
|
apply (erule use_valid[OF _ do_user_op_if_next_irq_state_of_state])
|
|
apply (erule use_valid[OF _ dmo_getActiveIRQ_wp])
|
|
apply (simp add: next_irq_state_Suc recurring_next_irq_state_dom)
|
|
apply (clarsimp split: if_splits)
|
|
apply (frule getActiveIRQ_None)
|
|
apply (erule use_valid[OF _ do_user_op_if_irq_measure_if])
|
|
apply (erule use_valid[OF _ dmo_getActiveIRQ_wp])
|
|
apply (clarsimp simp: irq_measure_if_def Let_def)
|
|
apply (simp add: next_irq_state_Suc recurring_next_irq_state_dom)
|
|
apply (fastforce dest: next_irq_state_less)
|
|
apply (frule getActiveIRQ_None)
|
|
apply (erule use_valid[OF _ do_user_op_if_next_irq_state_of_state])
|
|
apply (erule use_valid[OF _ dmo_getActiveIRQ_wp])
|
|
apply (simp add: next_irq_state_Suc recurring_next_irq_state_dom)
|
|
apply (clarsimp split: if_splits)+
|
|
apply (frule getActiveIRQ_None)
|
|
apply (erule use_valid[OF _ dmo_getActiveIRQ_wp])
|
|
apply (clarsimp simp: irq_measure_if_def Let_def)
|
|
apply (simp add: next_irq_state_Suc recurring_next_irq_state_dom)
|
|
apply (fastforce dest: next_irq_state_less)
|
|
apply (frule getActiveIRQ_None)
|
|
apply (erule use_valid[OF _ dmo_getActiveIRQ_wp])
|
|
apply (simp add: next_irq_state_Suc recurring_next_irq_state_dom)
|
|
apply (clarsimp split: if_splits)
|
|
apply (clarsimp simp: kernel_call_A_if_def kernel_entry_if_def in_monad)
|
|
apply (clarsimp split: if_splits)
|
|
apply (rule Suc_le_lessD)
|
|
apply simp
|
|
apply (simp add: kernel_call_A_if_def)
|
|
apply (elim exE conjE)
|
|
apply (rule_tac event=x3 in kernel_entry_if_irq_measure)
|
|
apply ((simp add: invs_if_def Invs_def only_timer_irq_inv_def
|
|
| elim conjE | assumption)+)[4]
|
|
apply (simp)
|
|
apply (simp add: kernel_call_A_if_def | elim conjE exE)+
|
|
apply (erule kernel_entry_if_next_irq_state_of_state)
|
|
apply ((simp add: invs_if_def Invs_def only_timer_irq_inv_def
|
|
| elim conjE | assumption)+)[4]
|
|
apply (clarsimp split: if_splits)
|
|
apply (rule Suc_le_lessD)
|
|
apply (simp add: kernel_schedule_if_def)
|
|
apply (blast intro: schedule_if_irq_measure_if)
|
|
apply (simp add: kernel_schedule_if_def)
|
|
apply (blast intro: schedule_if_next_irq_state_of_state)
|
|
apply (simp add: kernel_schedule_if_def)
|
|
apply (blast intro: schedule_if_next_irq_state_of_state)
|
|
apply (clarsimp simp: kernel_exit_A_if_def split: if_splits)
|
|
apply (clarsimp simp: kernel_exit_A_if_def)
|
|
apply ((erule use_valid, wp | simp)+)[1]
|
|
apply (clarsimp split: if_splits)
|
|
apply (clarsimp simp: kernel_exit_A_if_def split: if_splits)
|
|
apply (clarsimp simp: kernel_exit_A_if_def)
|
|
apply ((erule use_valid, wp | simp)+)[1]
|
|
apply (clarsimp split: if_splits)+
|
|
apply (clarsimp split: sys_mode.splits | safe)+
|
|
apply (clarsimp simp: irq_measure_if_def kernel_exit_A_if_def split: if_splits)
|
|
apply (drule state_unchanged[OF kernel_exit_if_inv], simp)
|
|
apply (clarsimp simp: irq_measure_if_def kernel_exit_A_if_def split: if_splits)
|
|
apply (drule state_unchanged[OF kernel_exit_if_inv], simp)
|
|
apply (clarsimp simp: kernel_exit_A_if_def split: if_splits)
|
|
apply (clarsimp simp: kernel_exit_A_if_def split: if_splits)
|
|
apply (clarsimp simp: kernel_exit_A_if_def)
|
|
apply ((erule use_valid, wp | simp)+)[1]
|
|
apply (clarsimp simp: kernel_exit_A_if_def split: if_splits)
|
|
done
|
|
|
|
lemma ADT_A_if_Step_measure_if'':
|
|
"\<lbrakk> (s,s') \<in> data_type.Step (ADT_A_if utf) x; invs_if s; measuref_if y s > 0 \<rbrakk>
|
|
\<Longrightarrow> measuref_if y s' < measuref_if y s \<and>
|
|
(\<not> interrupted_modes (snd s)
|
|
\<longrightarrow> interrupted_modes (snd s')
|
|
\<longrightarrow> irq_state_of_state (internal_state_if s') =
|
|
next_irq_state_of_state (internal_state_if s))"
|
|
apply (frule invs_if_irq_is_recurring)
|
|
apply (case_tac s, clarsimp)
|
|
apply (rename_tac uc i_s mode)
|
|
apply (case_tac mode)
|
|
apply (simp_all add: rah_simp system.Step_def execution_def steps_def ADT_A_if_def
|
|
global_automaton_if_def check_active_irq_A_if_def do_user_op_A_if_def
|
|
check_active_irq_if_def in_monad measuref_if_def
|
|
| safe | split if_splits)+
|
|
apply (frule getActiveIRQ_None)
|
|
apply (erule use_valid[OF _ do_user_op_if_irq_measure_if])
|
|
apply (erule use_valid[OF _ dmo_getActiveIRQ_wp])
|
|
apply (clarsimp simp: irq_measure_if_def Let_def)
|
|
apply (simp add: next_irq_state_Suc recurring_next_irq_state_dom)
|
|
apply (blast intro: rah4[OF next_irq_state_less])
|
|
apply (frule getActiveIRQ_None)
|
|
apply (erule use_valid[OF _ do_user_op_if_next_irq_state_of_state])
|
|
apply (erule use_valid[OF _ dmo_getActiveIRQ_wp])
|
|
apply (simp add: next_irq_state_Suc recurring_next_irq_state_dom)
|
|
apply (clarsimp split: if_splits)
|
|
apply (frule getActiveIRQ_None)
|
|
apply (erule use_valid[OF _ do_user_op_if_irq_measure_if])
|
|
apply (erule use_valid[OF _ dmo_getActiveIRQ_wp])
|
|
apply (clarsimp simp: irq_measure_if_def Let_def)
|
|
apply (simp add: next_irq_state_Suc recurring_next_irq_state_dom)
|
|
apply (fastforce dest: next_irq_state_less)
|
|
apply (frule getActiveIRQ_None)
|
|
apply (erule use_valid[OF _ do_user_op_if_next_irq_state_of_state])
|
|
apply (erule use_valid[OF _ dmo_getActiveIRQ_wp])
|
|
apply (simp add: next_irq_state_Suc recurring_next_irq_state_dom)
|
|
apply (clarsimp split: if_splits)+
|
|
apply (frule getActiveIRQ_Some)
|
|
apply (erule use_valid[OF _ dmo_getActiveIRQ_wp])
|
|
apply (simp add: next_irq_state_Suc' recurring_next_irq_state_dom)
|
|
apply (clarsimp split: if_splits)
|
|
apply (frule getActiveIRQ_Some)
|
|
apply (erule use_valid[OF _ dmo_getActiveIRQ_wp])
|
|
apply (simp add: next_irq_state_Suc' recurring_next_irq_state_dom)
|
|
apply (clarsimp split: if_splits)
|
|
apply (frule getActiveIRQ_None)
|
|
apply (erule use_valid[OF _ dmo_getActiveIRQ_wp])
|
|
apply (clarsimp simp: irq_measure_if_def Let_def)
|
|
apply (simp add: next_irq_state_Suc recurring_next_irq_state_dom)
|
|
apply (fastforce dest: next_irq_state_less)
|
|
apply (clarsimp split: if_splits)
|
|
apply (clarsimp simp: kernel_call_A_if_def in_monad)
|
|
apply (rule kernel_entry_if_next_irq_state_of_state_next,assumption+)
|
|
prefer 4
|
|
apply fastforce
|
|
apply ((simp add: invs_if_def Invs_def only_timer_irq_inv_def
|
|
| elim conjE | assumption)+)[3]
|
|
apply (clarsimp split: if_splits)
|
|
apply (rule Suc_le_lessD)
|
|
apply simp
|
|
apply (simp add: kernel_call_A_if_def)
|
|
apply (elim exE conjE)
|
|
apply (rule_tac event=x3 in kernel_entry_if_irq_measure)
|
|
apply ((simp add: invs_if_def Invs_def only_timer_irq_inv_def
|
|
| elim conjE | assumption)+)[4]
|
|
apply (simp)
|
|
apply (clarsimp split: if_splits)
|
|
apply (rule Suc_le_lessD)
|
|
apply (simp add: kernel_schedule_if_def)
|
|
apply (blast intro: schedule_if_irq_measure_if)
|
|
apply (clarsimp simp: kernel_exit_A_if_def split: if_splits)
|
|
apply (clarsimp simp: kernel_exit_A_if_def)
|
|
apply ((erule use_valid, wp | simp)+)[1]
|
|
apply (clarsimp split: if_splits)
|
|
apply (clarsimp simp: kernel_exit_A_if_def split: if_splits)
|
|
apply (clarsimp simp: kernel_exit_A_if_def)
|
|
apply ((erule use_valid, wp | simp)+)[1]
|
|
apply (clarsimp split: if_splits)+
|
|
apply (clarsimp simp: kernel_exit_A_if_def split: if_splits)
|
|
apply (clarsimp split: if_splits)
|
|
apply (clarsimp split: sys_mode.splits | safe)+
|
|
apply (clarsimp simp: irq_measure_if_def kernel_exit_A_if_def split: if_splits)
|
|
apply (drule state_unchanged[OF kernel_exit_if_inv], simp)
|
|
apply (clarsimp simp: irq_measure_if_def kernel_exit_A_if_def split: if_splits)
|
|
apply (drule state_unchanged[OF kernel_exit_if_inv], simp)
|
|
apply (clarsimp simp: kernel_exit_A_if_def split: if_splits)
|
|
apply (clarsimp simp: kernel_exit_A_if_def split: if_splits)
|
|
apply (clarsimp simp: kernel_exit_A_if_def)
|
|
apply ((erule use_valid, wp | simp)+)[1]
|
|
apply (clarsimp simp: kernel_exit_A_if_def split: if_splits)
|
|
done
|
|
|
|
lemma ADT_A_if_Step_irq_masks:
|
|
"\<lbrakk> (s,s') \<in> data_type.Step (ADT_A_if utf) x; invs_if s \<rbrakk>
|
|
\<Longrightarrow> irq_masks_of_state (internal_state_if s') = irq_masks_of_state (internal_state_if s)"
|
|
apply (case_tac s, clarsimp)
|
|
apply (rename_tac uc i_s mode)
|
|
apply (case_tac mode)
|
|
apply (simp_all add: system.Step_def steps_def ADT_A_if_def in_monad rah_simp execution_def
|
|
global_automaton_if_def check_active_irq_A_if_def do_user_op_A_if_def
|
|
check_active_irq_if_def kernel_schedule_if_def kernel_call_A_if_def
|
|
kernel_handle_preemption_if_def kernel_exit_A_if_def measuref_if_def
|
|
| safe | split if_splits)+
|
|
apply (erule use_valid[OF _ do_user_op_if_irq_masks_of_state]
|
|
use_valid[OF _ dmo_getActiveIRQ_irq_masks]
|
|
use_valid[OF _ kernel_entry_if_irq_masks]
|
|
| rule refl)+
|
|
apply fastforce
|
|
apply (subgoal_tac "irq_masks_of_state b = irq_masks_of_state i_s",simp)
|
|
apply (erule use_valid[OF _ kernel_entry_if_irq_masks])
|
|
apply fastforce
|
|
apply (erule use_valid[OF _ handle_preemption_if_irq_masks])
|
|
apply fastforce
|
|
apply (erule use_valid[OF _ schedule_if_irq_masks])
|
|
apply fastforce
|
|
apply (erule use_valid[OF _ kernel_exit_irq_masks])
|
|
apply simp
|
|
done
|
|
|
|
end
|
|
|
|
|
|
lemma steps_preserves_equivalence:
|
|
"\<lbrakk> (s', as) \<in> sub_big_steps A R s1; \<forall>t t' as a. (t, as) \<in> sub_big_steps A R s1
|
|
\<longrightarrow> (t, t') \<in> Step A a
|
|
\<longrightarrow> \<not> R s1 t'
|
|
\<longrightarrow> f t = f t' \<rbrakk>
|
|
\<Longrightarrow> f s1 = f s'"
|
|
by (fastforce elim: sub_big_steps.induct)
|
|
|
|
lemma step_out_equivalent:
|
|
"\<lbrakk> (s', as) \<in> sub_big_steps A R s1; (s', s2) \<in> data_type.Step A a; g s2 = f (g s');
|
|
\<forall>t t' as a. (t, as) \<in> sub_big_steps A R s1
|
|
\<longrightarrow> (t, t') \<in> data_type.Step A a
|
|
\<longrightarrow> \<not> R s1 t'
|
|
\<longrightarrow> f (g t) = f (g t') \<rbrakk>
|
|
\<Longrightarrow> f (g s1) = g s2"
|
|
by (fastforce elim: steps_preserves_equivalence)
|
|
|
|
(*Clagged from Noninterference*)
|
|
|
|
lemma irq_state_back:
|
|
"P (irq_state_of_state (internal_state_if ((a,b),c)))
|
|
(irq_masks_of_state (internal_state_if ((a,b),c))) \<Longrightarrow>
|
|
P (irq_state_of_state b) (irq_masks_of_state b)"
|
|
by simp
|
|
|
|
lemma sub_big_steps_not_related:
|
|
"(s,a) \<in> sub_big_steps A R s1 \<Longrightarrow> \<not> R s1 s"
|
|
by (erule sub_big_steps.cases,simp+)
|
|
|
|
(*Can probably be generalized*)
|
|
lemma small_step_to_big_step:
|
|
assumes a:
|
|
"\<And>s' evs. \<lbrakk> (s',evs) \<in> sub_big_steps (ADT_A_if utf) big_step_R s1;
|
|
(s', s2) \<in> data_type.Step (ADT_A_if utf) a; big_step_R s1 s2 \<rbrakk>
|
|
\<Longrightarrow> S"
|
|
assumes b: "(s1, s2) \<in> data_type.Step (big_step_ADT_A_if utf) a"
|
|
shows S
|
|
apply (insert b)
|
|
apply (simp add: big_step_ADT_A_if_def big_step_adt_def)
|
|
apply (erule big_steps.cases)
|
|
apply (rule_tac s'=s' and evs=as in a)
|
|
apply simp+
|
|
done
|
|
|
|
lemma Step_ADT_A_if_def_global_automaton_if:
|
|
"Step (ADT_A_if uop) =
|
|
(\<lambda>u. global_automaton_if check_active_irq_A_if (do_user_op_A_if uop) kernel_call_A_if
|
|
kernel_handle_preemption_if kernel_schedule_if kernel_exit_A_if
|
|
\<inter> {(s, y). step_restrict y})"
|
|
by (clarsimp simp: ADT_A_if_def)
|
|
|
|
lemma ADT_A_if_reachable_step_restrict:
|
|
"system.reachable (ADT_A_if utf) s0 s \<Longrightarrow> step_restrict s"
|
|
apply (clarsimp simp: system.reachable_def)
|
|
apply (erule execution_restrict)
|
|
done
|
|
|
|
lemma step_restrict_inv_holds_ADT_A_if:
|
|
"ADT_A_if utf [> {s. step_restrict s}"
|
|
apply (rule inv_holdsI)
|
|
apply (clarsimp simp: Image_def ADT_A_if_def)
|
|
done
|
|
|
|
|
|
context ADT_valid_initial_state begin
|
|
|
|
lemma invs_if_sub_big_steps_ADT_A_if:
|
|
"\<lbrakk> (s', evs) \<in> sub_big_steps (ADT_A_if utf) big_step_R s; invs_if s \<rbrakk>
|
|
\<Longrightarrow> invs_if s'"
|
|
apply (erule sub_big_steps.induct)
|
|
apply simp
|
|
apply (simp add: invs_if_Step_ADT_A_if)
|
|
done
|
|
|
|
lemma small_step_irq_state_next_irq:
|
|
"\<lbrakk> invs_if s1; (s',evs) \<in> sub_big_steps (ADT_A_if utf) big_step_R s1;
|
|
(s', s2) \<in> Step (ADT_A_if utf) a; big_step_R\<^sup>*\<^sup>* s0 s1;
|
|
snd s1 = KernelExit; interrupted_modes (snd s2) \<rbrakk>
|
|
\<Longrightarrow> next_irq_state_of_state (internal_state_if s1) = irq_state_of_state (internal_state_if s2)"
|
|
apply (subgoal_tac "invs_if s'")
|
|
apply (rule step_out_equivalent[where f="\<lambda>(states,mask). (next_irq_state (Suc states) mask,mask)"
|
|
and g="\<lambda>s. (irq_state_of_state (internal_state_if s),
|
|
irq_masks_of_state (internal_state_if s))",
|
|
simplified, THEN conjunct1])
|
|
apply assumption
|
|
apply assumption
|
|
apply (rule conjI)
|
|
apply (rule ADT_A_if_Step_measure_if''[THEN conjunct2,rule_format],assumption+)
|
|
apply (rule ADT_A_if_sub_big_steps_measuref_if,assumption+)
|
|
apply (frule sub_big_steps_not_related)
|
|
apply (simp add: big_step_R_def)
|
|
apply simp
|
|
apply (rule ADT_A_if_Step_irq_masks,assumption+)
|
|
apply clarsimp
|
|
apply (subgoal_tac "invs_if ((a,b),ba)")
|
|
apply (rule_tac b=b and a=a and c=ba in irq_state_back)
|
|
apply (rule_tac b=bb and a=aa and c=bc in irq_state_back)
|
|
apply (rule conjI)
|
|
apply (rule sym)
|
|
apply (rule ADT_A_if_Step_measure_if'[THEN conjunct2,rule_format],assumption+)
|
|
apply (rule ADT_A_if_sub_big_steps_measuref_if,assumption+)
|
|
apply (drule sub_big_steps_not_related)+
|
|
apply (simp add: big_step_R_def)
|
|
apply (simp add: big_step_R_def)
|
|
apply (rule sym)
|
|
apply (rule ADT_A_if_Step_irq_masks,assumption+)
|
|
apply (simp add: invs_if_sub_big_steps_ADT_A_if)+
|
|
done
|
|
|
|
lemma big_step_irq_state_next_irq:
|
|
"\<lbrakk> invs_if s1; big_step_R\<^sup>*\<^sup>* s0 s1; (s1, s2) \<in> Step (big_step_ADT_A_if utf) a;
|
|
snd s1 = KernelExit; i_s1 = internal_state_if s1; i_s2 = internal_state_if s2 \<rbrakk>
|
|
\<Longrightarrow> next_irq_state_of_state i_s1 = irq_state_of_state i_s2"
|
|
apply simp
|
|
apply (rule small_step_to_big_step)
|
|
apply (rule small_step_irq_state_next_irq,(simp add: big_step_R_def)+)
|
|
done
|
|
|
|
lemmas ADT_A_if_Step_measure_if =
|
|
ADT_A_if_Step_measure_if'[THEN conjunct1]
|
|
|
|
lemmas ADT_A_if_Step_next_irq_state_of_state =
|
|
ADT_A_if_Step_measure_if'[THEN conjunct2, rule_format]
|
|
|
|
lemma ADT_A_if_big_step_R_terminate:
|
|
"rel_terminate (ADT_A_if utf) s0 big_step_R {s. invs_if s} measuref_if"
|
|
apply (clarsimp simp: rel_terminate_def)
|
|
apply (rule conjI)
|
|
apply (rename_tac uc s mode as uc' s' mode' uc'' s'' mode'')
|
|
apply (rule ADT_A_if_Step_measure_if)
|
|
apply assumption
|
|
apply (simp add: invs_if_sub_big_steps_ADT_A_if)
|
|
apply (rule ADT_A_if_sub_big_steps_measuref_if)
|
|
apply simp
|
|
apply (simp add: ADT_A_if_def)
|
|
apply (simp add: ADT_A_if_def)
|
|
apply (drule tranclp_s0)
|
|
apply (fastforce simp: measuref_if_def big_step_R_def Step_ADT_A_if
|
|
Step_ADT_A_if_def_global_automaton_if global_automaton_if_def
|
|
split: if_splits)
|
|
done
|
|
|
|
lemma ADT_A_if_Init_inv_Fin:
|
|
"Init_inv_Fin_system (ADT_A_if utf) s0"
|
|
apply unfold_locales
|
|
apply (simp add: ADT_A_if_def invs_if_full_invs_if extras_s0)
|
|
apply (frule ADT_A_if_reachable_invs_if)
|
|
apply (drule ADT_A_if_reachable_step_restrict)
|
|
apply (simp add: ADT_A_if_def invs_if_full_invs_if)
|
|
apply (simp add: ADT_A_if_def)
|
|
done
|
|
|
|
lemma invs_if_inv_holds_ADT_A_if:
|
|
"ADT_A_if utf [> Collect invs_if"
|
|
by (force intro: inv_holdsI invs_if_Step_ADT_A_if)
|
|
|
|
lemma ADT_A_if_Init_Fin_serial_weak:
|
|
"Init_Fin_serial_weak (ADT_A_if utf) s0 ({s. invs_if s} \<inter> {s. step_restrict s})"
|
|
apply (rule Init_Fin_serial_weak_strengthen)
|
|
apply (rule Init_Fin_serial.serial_to_weak[OF ADT_A_if_Init_Fin_serial])
|
|
apply (intro inv_holds_conjI invs_if_inv_holds_ADT_A_if step_restrict_inv_holds_ADT_A_if)
|
|
apply (clarsimp simp: invs_if_full_invs_if)
|
|
apply (simp add: ADT_A_if_def)
|
|
apply (insert invs_if_s0 extras_s0)
|
|
apply blast
|
|
done
|
|
|
|
lemma big_step_ADT_A_if_enabled_Step_system:
|
|
"enabled_Step_system (big_step_ADT_A_if utf) s0"
|
|
apply (simp add: big_step_ADT_A_if_def)
|
|
apply (rule big_step_adt_enabled_Step_system)
|
|
apply simp
|
|
apply (fastforce simp: big_step_R_def)
|
|
apply (rule ADT_A_if_Init_Fin_serial_weak)
|
|
apply (rule ADT_A_if_Init_inv_Fin)
|
|
apply (rule rel_terminate_weaken)
|
|
apply (rule ADT_A_if_big_step_R_terminate)
|
|
apply simp
|
|
done
|
|
|
|
end
|
|
|
|
|
|
section \<open>Generic big step refinement\<close>
|
|
|
|
definition internal_R where
|
|
"internal_R A R s s' \<equiv> R (Fin A s) (Fin A s')"
|
|
|
|
lemma invariant_holds_inv_holds:
|
|
"A \<Turnstile> I \<Longrightarrow> A [> I"
|
|
by (simp add: invariant_holds_def inv_holds_def)
|
|
|
|
lemma inv_holdsE:
|
|
assumes I: "A [> I"
|
|
and step: "(s, t) \<in> Step A e"
|
|
and s_I: "s \<in> I"
|
|
and t_I: "t \<in> I \<Longrightarrow> P"
|
|
shows "P"
|
|
apply (rule t_I)
|
|
apply (insert step I s_I)
|
|
apply (force simp: inv_holds_def)
|
|
done
|
|
|
|
lemma LI_sub_big_steps:
|
|
"\<lbrakk> (s',as) \<in> sub_big_steps C (internal_R C R) s;
|
|
LI A C S (Ia \<times> Ic); A \<Turnstile> Ia; C \<Turnstile> Ic; (t, s) \<in> S; s \<in> Ic; t \<in> Ia \<rbrakk>
|
|
\<Longrightarrow> \<exists>t'. (t',as) \<in> sub_big_steps A (internal_R A R) t \<and> (t', s') \<in> S \<and> t' \<in> Ia"
|
|
apply (induct rule: sub_big_steps.induct)
|
|
apply (clarsimp simp: LI_def)
|
|
apply (rule_tac x=t in exI)
|
|
apply clarsimp
|
|
apply (rule sub_big_steps.nil, simp_all)[1]
|
|
apply (force simp: internal_R_def)
|
|
apply (clarsimp simp: LI_def)
|
|
apply (erule_tac x=e in allE)
|
|
apply (clarsimp simp: rel_semi_def)
|
|
apply (drule_tac c="(t', ta)" in set_mp)
|
|
apply (rule_tac b=s' in relcompI)
|
|
apply simp
|
|
apply (rule sub_big_steps_I_holds)
|
|
apply (rule invariant_holds_inv_holds, assumption+)
|
|
apply clarsimp
|
|
apply (rule_tac x=y in exI)
|
|
apply clarsimp
|
|
apply (subst conj_commute)
|
|
apply (rule context_conjI)
|
|
apply (erule inv_holdsE[OF invariant_holds_inv_holds])
|
|
apply assumption+
|
|
apply (rule sub_big_steps.step[OF refl])
|
|
apply assumption+
|
|
apply (subgoal_tac "z \<in> Ic")
|
|
prefer 2
|
|
apply (rule_tac I=Ic in inv_holdsE[OF invariant_holds_inv_holds])
|
|
apply assumption+
|
|
apply (erule sub_big_steps_I_holds[OF invariant_holds_inv_holds])
|
|
apply assumption+
|
|
apply (subgoal_tac "Fin A t = Fin C s")
|
|
apply (subgoal_tac "Fin A y = Fin C z")
|
|
apply (simp(no_asm_use) add: internal_R_def)
|
|
apply metis
|
|
apply force+
|
|
done
|
|
|
|
lemma LI_big_steps:
|
|
"\<lbrakk> (s, s') \<in> big_steps C (internal_R C R) exmap ev;
|
|
LI A C S (Ia \<times> Ic); A \<Turnstile> Ia; C \<Turnstile> Ic; (t, s) \<in> S; s \<in> Ic; t \<in> Ia \<rbrakk>
|
|
\<Longrightarrow> \<exists>t'. (t, t') \<in> big_steps A (internal_R A R) exmap ev \<and> (t', s') \<in> S \<and> t' \<in> Ia"
|
|
apply (drule big_stepsD)
|
|
apply clarsimp
|
|
apply (frule(2) sub_big_steps_I_holds[OF invariant_holds_inv_holds])
|
|
apply (drule (6) LI_sub_big_steps)
|
|
apply clarsimp
|
|
apply (clarsimp simp: LI_def)
|
|
apply (erule_tac x=a in allE)
|
|
apply (clarsimp simp: rel_semi_def)
|
|
apply (drule_tac c="(t', s')" in set_mp)
|
|
apply (rule_tac b="s'a" in relcompI)
|
|
apply simp
|
|
apply simp
|
|
apply clarsimp
|
|
apply (rule_tac x=y in exI)
|
|
apply simp
|
|
apply (subst conj_commute)
|
|
apply (rule context_conjI)
|
|
apply (clarsimp simp: invariant_holds_def, blast)
|
|
apply (rule big_steps.cstep)
|
|
apply assumption+
|
|
apply (simp add: internal_R_def)
|
|
apply (subgoal_tac "Fin A t = Fin C s")
|
|
apply (subgoal_tac "s' \<in> Ic")
|
|
apply (subgoal_tac "Fin A y = Fin C s'")
|
|
apply metis
|
|
apply metis
|
|
apply (simp(no_asm_use) add: invariant_holds_def, blast)
|
|
apply force
|
|
apply simp
|
|
done
|
|
|
|
lemma inv_holds_Run_big_steps:
|
|
"\<lbrakk> A [> I; s \<in> I; (s, t) \<in> Run (big_steps A R exmap) js \<rbrakk>
|
|
\<Longrightarrow> t \<in> I"
|
|
apply (induct js arbitrary: t rule: rev_induct)
|
|
apply force
|
|
apply (force intro: big_steps_I_holds dest: Run_mid)
|
|
done
|
|
|
|
lemma refines_Run_big_steps:
|
|
"\<lbrakk> (s, s') \<in> Run (big_steps C (internal_R C R) exmap) js;
|
|
LI A C S (Ia \<times> Ic); A \<Turnstile> Ia; C \<Turnstile> Ic; (t, s) \<in> S; s \<in> Ic; t \<in> Ia \<rbrakk>
|
|
\<Longrightarrow> \<exists>t'. (t, t') \<in> Run (big_steps A (internal_R A R) exmap) js \<and> (t', s') \<in> S \<and> t' \<in> Ia"
|
|
apply (induct js arbitrary: s' rule: rev_induct)
|
|
apply force
|
|
apply (frule Run_mid)
|
|
apply clarsimp
|
|
apply atomize
|
|
apply (erule_tac x=ta in allE)
|
|
apply clarsimp
|
|
apply (drule (4) LI_big_steps)
|
|
apply (erule (2) inv_holds_Run_big_steps[OF invariant_holds_inv_holds])
|
|
apply assumption
|
|
apply clarsimp
|
|
apply (rule_tac x="t'a" in exI)
|
|
apply (force intro: Run_trans)
|
|
done
|
|
|
|
text\<open>
|
|
TODO: with some more work we can probably change both @{term "refines"}
|
|
to be @{term "refines'"} (see below).
|
|
\<close>
|
|
|
|
lemma big_step_adt_refines:
|
|
"\<lbrakk> LI A C S (Ia \<times> Ic); A \<Turnstile> Ia; C \<Turnstile> Ic \<rbrakk>
|
|
\<Longrightarrow> refines (big_step_adt C (internal_R C R) exmap) (big_step_adt A (internal_R A R) exmap)"
|
|
apply (subst refines_def)
|
|
apply (clarsimp simp: execution_def steps_eq_Run)
|
|
apply (clarsimp simp: image_def)
|
|
apply (subst Bex_def, subst steps_eq_Run)
|
|
apply (clarsimp simp: big_step_adt_def)
|
|
apply (subgoal_tac "\<exists>a0'\<in> Init A s. (a0', s0') \<in> S")
|
|
prefer 2
|
|
apply (force simp: LI_def)
|
|
apply clarsimp
|
|
apply (frule (4) refines_Run_big_steps)
|
|
apply (force simp: invariant_holds_def)
|
|
apply (force simp: invariant_holds_def)
|
|
apply clarsimp
|
|
apply (rule_tac x="t'" in exI)
|
|
apply (clarsimp simp: LI_def)
|
|
apply (rule conjI)
|
|
apply blast
|
|
apply (subgoal_tac "xa \<in> Ic")
|
|
apply simp
|
|
apply (rule_tac s="s0'" in inv_holds_Run_big_steps[OF invariant_holds_inv_holds], assumption+)
|
|
apply (force simp: invariant_holds_def)
|
|
apply simp
|
|
done
|
|
|
|
text \<open>
|
|
A start at making the change mentioned above to
|
|
@{thm big_step_adt_refines}.
|
|
\<close>
|
|
|
|
text \<open>
|
|
Refinement restricted to states reachable from a common initial state
|
|
\<close>
|
|
definition refines' where
|
|
"refines' C A s0 \<equiv> \<forall>js s. system.reachable C s0 s \<longrightarrow> execution C s js \<subseteq> execution A s js"
|
|
|
|
lemma refines_refines':
|
|
"refines C A \<Longrightarrow> refines' C A s"
|
|
by (auto simp: refines_def refines'_def)
|
|
|
|
text \<open>Two validity requirements on the user operation (uop) of the infoflow adt.
|
|
These definitions are mostly only needed in ADT_A_if_Refine.\<close>
|
|
|
|
text \<open>uop_nonempty is required to prove corres between do_user_op_if and doUserOp_if\<close>
|
|
definition uop_nonempty :: "user_transition_if \<Rightarrow> bool" where
|
|
"uop_nonempty uop \<equiv> \<forall>t pl pr pxn tc um es. uop t pl pr pxn (tc, um, es) \<noteq> {}"
|
|
|
|
text \<open>uop_sane is required to prove that the infoflow adt describes an enabled system\<close>
|
|
definition uop_sane :: "user_transition_if \<Rightarrow> bool" where
|
|
"uop_sane f \<equiv> \<forall>t pl pr pxn tcu. (f t pl pr pxn tcu) \<noteq> {}
|
|
\<and> (\<forall>tc um es. (Some Interrupt, tc, um, es) \<notin> (f t pl pr pxn tcu))"
|
|
|
|
end
|