991 lines
44 KiB
Plaintext
991 lines
44 KiB
Plaintext
(*
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
|
*
|
|
* SPDX-License-Identifier: GPL-2.0-only
|
|
*)
|
|
|
|
(*
|
|
The main theorem
|
|
*)
|
|
|
|
theory Refine
|
|
imports
|
|
KernelInit_R
|
|
ADT_H
|
|
InitLemmas
|
|
PageTableDuplicates
|
|
begin
|
|
|
|
context begin interpretation Arch . (*FIXME: arch_split*)
|
|
|
|
text \<open>User memory content is the same on both levels\<close>
|
|
lemma typ_at_AUserDataI:
|
|
"\<lbrakk> typ_at (AArch (AUserData sz)) p s; pspace_relation (kheap s) (ksPSpace s');
|
|
pspace_aligned' s'; pspace_distinct' s'; n < 2 ^ (pageBitsForSize sz - pageBits) \<rbrakk>
|
|
\<Longrightarrow> typ_at' UserDataT (p + n * 2 ^ pageBits) s'"
|
|
apply (clarsimp simp add: obj_at_def a_type_def )
|
|
apply (simp split: Structures_A.kernel_object.split_asm
|
|
arch_kernel_obj.split_asm split: if_split_asm)
|
|
apply (drule(1) pspace_relation_absD)
|
|
apply (clarsimp)
|
|
apply (drule_tac x = "p + n * 2 ^ pageBits" in spec)
|
|
apply (drule_tac x = "\<lambda>_ obj. obj = KOUserData" in spec)
|
|
apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def)
|
|
apply (rule exI [where x = KOUserData])
|
|
apply (drule mp)
|
|
apply (rule exI [where x = n])
|
|
apply (simp add: shiftl_t2n)
|
|
apply (clarsimp simp: pspace_aligned'_def)
|
|
apply (drule (1) bspec [OF _ domI])
|
|
apply (clarsimp simp: objBits_simps)
|
|
apply (fastforce dest!: pspace_distinctD' simp: objBits_simps)
|
|
done
|
|
|
|
lemma typ_at_ADeviceDataI:
|
|
"\<lbrakk> typ_at (AArch (ADeviceData sz)) p s; pspace_relation (kheap s) (ksPSpace s');
|
|
pspace_aligned' s'; pspace_distinct' s'; n < 2 ^ (pageBitsForSize sz - pageBits) \<rbrakk>
|
|
\<Longrightarrow> typ_at' UserDataDeviceT (p + n * 2 ^ pageBits) s'"
|
|
apply (clarsimp simp add: obj_at_def a_type_def )
|
|
apply (simp split: Structures_A.kernel_object.split_asm
|
|
arch_kernel_obj.split_asm split: if_split_asm)
|
|
apply (drule(1) pspace_relation_absD)
|
|
apply (clarsimp)
|
|
apply (drule_tac x = "p + n * 2 ^ pageBits" in spec)
|
|
apply (drule_tac x = "\<lambda>_ obj. obj = KOUserDataDevice" in spec)
|
|
apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def)
|
|
apply (rule exI [where x = KOUserDataDevice])
|
|
apply (drule mp)
|
|
apply (rule exI [where x = n])
|
|
apply (simp add: shiftl_t2n)
|
|
apply (clarsimp simp: pspace_aligned'_def)
|
|
apply (drule (1) bspec [OF _ domI])
|
|
apply (clarsimp simp: objBits_simps)
|
|
apply (fastforce dest!: pspace_distinctD' simp: objBits_simps)
|
|
done
|
|
|
|
lemma typ_at_UserDataI:
|
|
"\<lbrakk> typ_at' UserDataT (p && ~~ mask pageBits) s';
|
|
pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s \<rbrakk>
|
|
\<Longrightarrow> \<exists>sz. typ_at (AArch (AUserData sz)) (p && ~~ mask (pageBitsForSize sz)) s"
|
|
apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def)
|
|
apply (frule (1) in_related_pspace_dom)
|
|
apply (clarsimp simp: pspace_dom_def)
|
|
apply (clarsimp simp: pspace_relation_def dom_def)
|
|
apply (erule allE, erule impE, blast)
|
|
apply clarsimp
|
|
apply (drule (1) bspec)
|
|
apply clarsimp
|
|
apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric])
|
|
apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def
|
|
cte_relation_def other_obj_relation_def
|
|
split: Structures_A.kernel_object.split_asm
|
|
Structures_H.kernel_object.split_asm
|
|
if_split_asm arch_kernel_obj.split_asm)
|
|
apply (rename_tac vmpage_size n)
|
|
apply (rule_tac x = vmpage_size in exI)
|
|
apply (subst conjunct2 [OF is_aligned_add_helper])
|
|
apply (drule (1) pspace_alignedD)
|
|
apply simp
|
|
apply (simp add: shiftl_t2n mult_ac)
|
|
apply (erule word_less_power_trans2 [OF _ pbfs_atleast_pageBits])
|
|
apply (case_tac vmpage_size, simp_all add: word_bits_conv bit_simps)[1]
|
|
apply (simp add: obj_at_def a_type_def)
|
|
done
|
|
|
|
lemma typ_at_DeviceDataI:
|
|
"\<lbrakk> typ_at' UserDataDeviceT (p && ~~ mask pageBits) s';
|
|
pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s \<rbrakk>
|
|
\<Longrightarrow> \<exists>sz. typ_at (AArch (ADeviceData sz)) (p && ~~ mask (pageBitsForSize sz)) s"
|
|
apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def)
|
|
apply (frule (1) in_related_pspace_dom)
|
|
apply (clarsimp simp: pspace_dom_def)
|
|
apply (clarsimp simp: pspace_relation_def dom_def)
|
|
apply (erule allE, erule impE, blast)
|
|
apply clarsimp
|
|
apply (drule (1) bspec)
|
|
apply clarsimp
|
|
apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric])
|
|
apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def
|
|
cte_relation_def other_obj_relation_def
|
|
split: Structures_A.kernel_object.split_asm
|
|
Structures_H.kernel_object.split_asm
|
|
if_split_asm arch_kernel_obj.split_asm)
|
|
apply (rename_tac vmpage_size n)
|
|
apply (rule_tac x = vmpage_size in exI)
|
|
apply (subst conjunct2 [OF is_aligned_add_helper])
|
|
apply (drule (1) pspace_alignedD)
|
|
apply simp
|
|
apply (simp add: shiftl_t2n mult_ac)
|
|
apply (erule word_less_power_trans2 [OF _ pbfs_atleast_pageBits])
|
|
apply (case_tac vmpage_size, simp_all add: word_bits_conv bit_simps)[1]
|
|
apply (simp add: obj_at_def a_type_def)
|
|
done
|
|
|
|
lemma pointerInUserData_relation:
|
|
"\<lbrakk> (s,s') \<in> state_relation; valid_state' s'; valid_state s\<rbrakk>
|
|
\<Longrightarrow> pointerInUserData p s' = in_user_frame p s"
|
|
apply (simp add: pointerInUserData_def in_user_frame_def)
|
|
apply (rule iffI)
|
|
apply (erule typ_at_UserDataI, (clarsimp simp: valid_state_def)+)[1]
|
|
apply clarsimp
|
|
apply (drule_tac sz = sz and
|
|
n = "(p && mask (pageBitsForSize sz)) >> pageBits"
|
|
in typ_at_AUserDataI [where s = s and s' = s'])
|
|
apply (fastforce simp: valid_state'_def)+
|
|
apply (rule shiftr_less_t2n')
|
|
apply (simp add: pbfs_atleast_pageBits mask_twice)
|
|
apply (case_tac sz, simp_all add: bit_simps)[1]
|
|
apply (subgoal_tac "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits = (p && ~~ mask pageBits)")
|
|
apply simp
|
|
apply (subst mult.commute)
|
|
apply (subst shiftl_t2n [symmetric])
|
|
apply (simp add: shiftr_shiftl1)
|
|
apply (subst mask_out_add_aligned)
|
|
apply (rule is_aligned_neg_mask)
|
|
apply (simp add: pbfs_atleast_pageBits)
|
|
apply (subst add.commute)
|
|
apply (simp add: word_plus_and_or_coroll2)
|
|
done
|
|
|
|
lemma pointerInDeviceData_relation:
|
|
"\<lbrakk> (s,s') \<in> state_relation; valid_state' s'; valid_state s\<rbrakk>
|
|
\<Longrightarrow> pointerInDeviceData p s' = in_device_frame p s"
|
|
apply (simp add: pointerInDeviceData_def in_device_frame_def)
|
|
apply (rule iffI)
|
|
apply (erule typ_at_DeviceDataI, (clarsimp simp: valid_state_def)+)[1]
|
|
apply clarsimp
|
|
apply (drule_tac sz = sz and
|
|
n = "(p && mask (pageBitsForSize sz)) >> pageBits"
|
|
in typ_at_ADeviceDataI [where s = s and s' = s'])
|
|
apply (fastforce simp: valid_state'_def)+
|
|
apply (rule shiftr_less_t2n')
|
|
apply (simp add: pbfs_atleast_pageBits mask_twice)
|
|
apply (case_tac sz, simp_all add: bit_simps)[1]
|
|
apply (subgoal_tac "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits = (p && ~~ mask pageBits)")
|
|
apply simp
|
|
apply (subst mult.commute)
|
|
apply (subst shiftl_t2n [symmetric])
|
|
apply (simp add: shiftr_shiftl1)
|
|
apply (subst mask_out_add_aligned)
|
|
apply (rule is_aligned_neg_mask)
|
|
apply (simp add: pbfs_atleast_pageBits)
|
|
apply (subst add.commute)
|
|
apply (simp add: word_plus_and_or_coroll2)
|
|
done
|
|
|
|
lemma user_mem_relation:
|
|
"\<lbrakk>(s,s') \<in> state_relation; valid_state' s'; valid_state s\<rbrakk>
|
|
\<Longrightarrow> user_mem' s' = user_mem s"
|
|
apply (rule ext)
|
|
apply (clarsimp simp: user_mem_def user_mem'_def pointerInUserData_relation pointerInDeviceData_relation)
|
|
apply (simp add: state_relation_def)
|
|
done
|
|
|
|
lemma device_mem_relation:
|
|
"\<lbrakk>(s,s') \<in> state_relation; valid_state' s'; valid_state s\<rbrakk>
|
|
\<Longrightarrow> device_mem' s' = device_mem s"
|
|
apply (rule ext)
|
|
apply (clarsimp simp: device_mem_def device_mem'_def pointerInUserData_relation
|
|
pointerInDeviceData_relation)
|
|
done
|
|
|
|
lemma absKState_correct:
|
|
assumes invs: "einvs (s :: det_ext state)" and invs': "invs' s'"
|
|
assumes rel: "(s,s') \<in> state_relation"
|
|
shows "absKState s' = abs_state s"
|
|
using assms
|
|
apply (intro state.equality, simp_all add: absKState_def abs_state_def)
|
|
apply (rule absHeap_correct, clarsimp+)
|
|
apply (clarsimp elim!: state_relationE)
|
|
apply (rule absCDT_correct, clarsimp+)
|
|
apply (rule absIsOriginalCap_correct, clarsimp+)
|
|
apply (simp add: state_relation_def)
|
|
apply (simp add: state_relation_def)
|
|
apply (clarsimp simp: user_mem_relation invs_def invs'_def)
|
|
apply (simp add: state_relation_def)
|
|
apply (rule absInterruptIRQNode_correct, simp add: state_relation_def)
|
|
apply (rule absInterruptStates_correct, simp add: state_relation_def)
|
|
apply (rule absArchState_correct, simp)
|
|
apply (rule absExst_correct, simp+)
|
|
done
|
|
|
|
text \<open>The top-level invariance\<close>
|
|
|
|
lemma set_thread_state_sched_act:
|
|
"\<lbrace>(\<lambda>s. runnable state) and (\<lambda>s. P (scheduler_action s))\<rbrace>
|
|
set_thread_state thread state
|
|
\<lbrace>\<lambda>rs s. P (scheduler_action (s::det_state))\<rbrace>"
|
|
apply (simp add: set_thread_state_def)
|
|
apply wp
|
|
apply (simp add: set_thread_state_ext_def)
|
|
apply wp
|
|
apply (rule hoare_pre_cont)
|
|
apply (rule_tac Q="\<lambda>rv. (\<lambda>s. runnable ts) and (\<lambda>s. P (scheduler_action s))"
|
|
in hoare_strengthen_post)
|
|
apply wp
|
|
apply force
|
|
apply (wp gts_st_tcb_at)+
|
|
apply (rule_tac Q="\<lambda>rv. st_tcb_at ((=) state) thread and (\<lambda>s. runnable state) and (\<lambda>s. P (scheduler_action s))" in hoare_strengthen_post)
|
|
apply (simp add: st_tcb_at_def)
|
|
apply (wp obj_set_prop_at)+
|
|
apply (force simp: st_tcb_at_def obj_at_def)
|
|
apply wp
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma activate_thread_sched_act:
|
|
"\<lbrace>ct_in_state activatable and (\<lambda>s. P (scheduler_action s))\<rbrace>
|
|
activate_thread
|
|
\<lbrace>\<lambda>rs s. P (scheduler_action (s::det_state))\<rbrace>"
|
|
by (simp add: activate_thread_def set_thread_state_def arch_activate_idle_thread_def
|
|
| (wp set_thread_state_sched_act gts_wp)+ | wpc)+
|
|
|
|
lemma schedule_sched_act_rct[wp]:
|
|
"\<lbrace>\<top>\<rbrace> Schedule_A.schedule
|
|
\<lbrace>\<lambda>rs (s::det_state). scheduler_action s = resume_cur_thread\<rbrace>"
|
|
unfolding Schedule_A.schedule_def
|
|
by (wpsimp)
|
|
|
|
lemma call_kernel_sched_act_rct[wp]:
|
|
"\<lbrace>einvs and (\<lambda>s. e \<noteq> Interrupt \<longrightarrow> ct_running s)
|
|
and (\<lambda>s. scheduler_action s = resume_cur_thread)\<rbrace>
|
|
call_kernel e
|
|
\<lbrace>\<lambda>rs (s::det_state). scheduler_action s = resume_cur_thread\<rbrace>"
|
|
apply (simp add: call_kernel_def)
|
|
apply (wp activate_thread_sched_act | simp)+
|
|
apply (clarsimp simp: active_from_running)
|
|
done
|
|
|
|
lemma kernel_entry_invs:
|
|
"\<lbrace>einvs and (\<lambda>s. e \<noteq> Interrupt \<longrightarrow> ct_running s)
|
|
and (\<lambda>s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle)
|
|
and (\<lambda>s. scheduler_action s = resume_cur_thread)\<rbrace>
|
|
kernel_entry e us
|
|
\<lbrace>\<lambda>rv. einvs and (\<lambda>s. ct_running s \<or> ct_idle s)
|
|
and (\<lambda>s. 0 < domain_time s) and valid_domain_list
|
|
and (\<lambda>s. scheduler_action s = resume_cur_thread)\<rbrace>"
|
|
apply (rule_tac Q="\<lambda>rv. invs and (\<lambda>s. ct_running s \<or> ct_idle s) and valid_sched and
|
|
(\<lambda>s. 0 < domain_time s) and valid_domain_list and
|
|
valid_list and (\<lambda>s. scheduler_action s = resume_cur_thread)"
|
|
in hoare_post_imp)
|
|
apply clarsimp
|
|
apply (simp add: kernel_entry_def)
|
|
apply (wp akernel_invs_det_ext call_kernel_valid_sched thread_set_invs_trivial
|
|
thread_set_ct_running thread_set_not_state_valid_sched
|
|
hoare_vcg_disj_lift ct_in_state_thread_state_lift thread_set_no_change_tcb_state
|
|
call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext
|
|
hoare_weak_lift_imp
|
|
| clarsimp simp add: tcb_cap_cases_def active_from_running)+
|
|
done
|
|
|
|
definition
|
|
"full_invs \<equiv> {((tc, s :: det_ext state), m, e). einvs s \<and>
|
|
(ct_running s \<or> ct_idle s) \<and>
|
|
(m = KernelMode \<longrightarrow> e \<noteq> None) \<and>
|
|
(m = UserMode \<longrightarrow> ct_running s) \<and>
|
|
(m = IdleMode \<longrightarrow> ct_idle s) \<and>
|
|
(e \<noteq> None \<and> e \<noteq> Some Interrupt \<longrightarrow> ct_running s) \<and>
|
|
0 < domain_time s \<and> valid_domain_list s \<and>
|
|
(scheduler_action s = resume_cur_thread)}"
|
|
|
|
lemma do_user_op_valid_list:"\<lbrace>valid_list\<rbrace> do_user_op f tc \<lbrace>\<lambda>_. valid_list\<rbrace>"
|
|
unfolding do_user_op_def
|
|
apply (wp | simp add: split_def)+
|
|
done
|
|
|
|
lemma do_user_op_valid_sched:"\<lbrace>valid_sched\<rbrace> do_user_op f tc \<lbrace>\<lambda>_. valid_sched\<rbrace>"
|
|
unfolding do_user_op_def
|
|
apply (wp | simp add: split_def)+
|
|
done
|
|
|
|
lemma do_user_op_sched_act:
|
|
"\<lbrace>\<lambda>s. P (scheduler_action s)\<rbrace> do_user_op f tc \<lbrace>\<lambda>_ s. P (scheduler_action s)\<rbrace>"
|
|
unfolding do_user_op_def
|
|
apply (wp | simp add: split_def)+
|
|
done
|
|
|
|
lemma do_user_op_invs2:
|
|
"\<lbrace>einvs and ct_running and (\<lambda>s. scheduler_action s = resume_cur_thread)
|
|
and (\<lambda>s. 0 < domain_time s) and valid_domain_list \<rbrace>
|
|
do_user_op f tc
|
|
\<lbrace>\<lambda>_. (einvs and ct_running and (\<lambda>s. scheduler_action s = resume_cur_thread))
|
|
and (\<lambda>s. 0 < domain_time s) and valid_domain_list \<rbrace>"
|
|
apply (rule_tac Q="\<lambda>_. valid_list and valid_sched and
|
|
(\<lambda>s. scheduler_action s = resume_cur_thread) and (invs and ct_running) and
|
|
(\<lambda>s. 0 < domain_time s) and valid_domain_list"
|
|
in hoare_strengthen_post)
|
|
apply (wp do_user_op_valid_list do_user_op_valid_sched do_user_op_sched_act
|
|
do_user_op_invs | simp | force)+
|
|
done
|
|
|
|
lemmas ext_init_def = ext_init_det_ext_ext_def ext_init_unit_def
|
|
|
|
lemma valid_list_init[simp]:
|
|
"valid_list init_A_st"
|
|
by (simp add: valid_list_2_def init_A_st_def ext_init_def init_cdt_def)
|
|
|
|
lemmas valid_list_inits[simp] = valid_list_init[simplified]
|
|
|
|
lemma valid_sched_init[simp]:
|
|
"valid_sched init_A_st"
|
|
apply (simp add: valid_sched_def init_A_st_def ext_init_def)
|
|
apply (clarsimp simp: valid_etcbs_def init_kheap_def st_tcb_at_kh_def obj_at_kh_def
|
|
obj_at_def is_etcb_at_def idle_thread_ptr_def
|
|
valid_queues_2_def ct_not_in_q_def not_queued_def
|
|
valid_sched_action_def is_activatable_def init_irq_node_ptr_def
|
|
riscv_global_pt_ptr_def init_global_pt_def
|
|
ct_in_cur_domain_2_def valid_blocked_2_def valid_idle_etcb_def
|
|
etcb_at'_def default_etcb_def)
|
|
done
|
|
|
|
lemma valid_domain_list_init[simp]:
|
|
"valid_domain_list init_A_st"
|
|
by (simp add: init_A_st_def ext_init_def valid_domain_list_def)
|
|
|
|
lemma akernel_invariant:
|
|
"ADT_A uop \<Turnstile> full_invs"
|
|
unfolding full_invs_def
|
|
apply (rule invariantI)
|
|
apply (clarsimp simp: ADT_A_def subset_iff)
|
|
apply (frule bspec[OF akernel_init_invs])
|
|
apply (simp add: Let_def Init_A_def)
|
|
apply (simp add: init_A_st_def ext_init_def)
|
|
apply (clarsimp simp: ADT_A_def global_automaton_def)
|
|
|
|
apply (rename_tac tc' s' mode' e' tc s mode e)
|
|
apply (elim disjE)
|
|
apply ((clarsimp simp: kernel_call_A_def
|
|
| drule use_valid[OF _ kernel_entry_invs])+)[2]
|
|
apply ((clarsimp simp: do_user_op_A_def monad_to_transition_def
|
|
check_active_irq_A_def
|
|
| drule use_valid[OF _ do_user_op_invs2]
|
|
| drule use_valid[OF _ check_active_irq_invs_just_running])+)[2]
|
|
apply ((clarsimp simp add: check_active_irq_A_def
|
|
| drule use_valid[OF _ check_active_irq_invs])+)[1]
|
|
apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def)
|
|
apply ((clarsimp simp add: do_user_op_A_def check_active_irq_A_def
|
|
| drule use_valid[OF _ do_user_op_invs2]
|
|
| drule use_valid[OF _ check_active_irq_invs_just_running])+)[1]
|
|
apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def)
|
|
apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def)
|
|
apply ((clarsimp simp add: check_active_irq_A_def
|
|
| drule use_valid[OF _ check_active_irq_invs])+)[1]
|
|
apply ((clarsimp simp add: check_active_irq_A_def
|
|
| drule use_valid[OF _ check_active_irq_invs_just_idle])+)[1]
|
|
apply ((clarsimp simp add: check_active_irq_A_def
|
|
| drule use_valid[OF _ check_active_irq_invs])+)[1]
|
|
done
|
|
|
|
lemma ckernel_invs:
|
|
"\<lbrace>invs' and
|
|
(\<lambda>s. e \<noteq> Interrupt \<longrightarrow> ct_running' s) and
|
|
(\<lambda>s. ksSchedulerAction s = ResumeCurrentThread)\<rbrace>
|
|
callKernel e
|
|
\<lbrace>\<lambda>rs. (\<lambda>s. ksSchedulerAction s = ResumeCurrentThread)
|
|
and (invs' and (ct_running' or ct_idle'))\<rbrace>"
|
|
apply (simp add: callKernel_def)
|
|
apply (rule hoare_pre)
|
|
apply (wp activate_invs' activate_sch_act schedule_sch
|
|
schedule_sch_act_simple he_invs' schedule_invs'
|
|
hoare_drop_imps
|
|
| simp add: no_irq_getActiveIRQ)+
|
|
done
|
|
|
|
(* abstract and haskell have identical domain list fields *)
|
|
abbreviation valid_domain_list' :: "'a kernel_state_scheme \<Rightarrow> bool" where
|
|
"valid_domain_list' \<equiv> \<lambda>s. valid_domain_list_2 (ksDomSchedule s)"
|
|
|
|
lemmas valid_domain_list'_def = valid_domain_list_2_def
|
|
|
|
defs kernelExitAssertions_def:
|
|
"kernelExitAssertions s \<equiv> 0 < ksDomainTime s \<and> valid_domain_list' s"
|
|
|
|
lemma callKernel_domain_time_left:
|
|
"\<lbrace> \<top> \<rbrace> callKernel e \<lbrace>\<lambda>_ s. 0 < ksDomainTime s \<and> valid_domain_list' s \<rbrace>"
|
|
unfolding callKernel_def kernelExitAssertions_def by wpsimp
|
|
|
|
lemma doMachineOp_sch_act_simple:
|
|
"doMachineOp f \<lbrace>sch_act_simple\<rbrace>"
|
|
by (wp sch_act_simple_lift)
|
|
|
|
lemma kernelEntry_invs':
|
|
"\<lbrace> invs' and (\<lambda>s. e \<noteq> Interrupt \<longrightarrow> ct_running' s) and
|
|
(ct_running' or ct_idle') and
|
|
(\<lambda>s. ksSchedulerAction s = ResumeCurrentThread) and
|
|
(\<lambda>s. 0 < ksDomainTime s) and valid_domain_list' \<rbrace>
|
|
kernelEntry e tc
|
|
\<lbrace>\<lambda>rs. (\<lambda>s. ksSchedulerAction s = ResumeCurrentThread) and
|
|
(invs' and (ct_running' or ct_idle')) and
|
|
(\<lambda>s. 0 < ksDomainTime s) and valid_domain_list' \<rbrace>"
|
|
apply (simp add: kernelEntry_def)
|
|
apply (wp ckernel_invs callKernel_domain_time_left
|
|
threadSet_invs_trivial threadSet_ct_running'
|
|
TcbAcc_R.dmo_invs' hoare_weak_lift_imp
|
|
doMachineOp_ct_in_state' doMachineOp_sch_act_simple
|
|
callKernel_domain_time_left
|
|
| clarsimp simp: user_memory_update_def no_irq_def tcb_at_invs'
|
|
valid_domain_list'_def)+
|
|
done
|
|
|
|
lemma absKState_correct':
|
|
"\<lbrakk>einvs s; invs' s'; (s,s') \<in> state_relation\<rbrakk>
|
|
\<Longrightarrow> absKState s' = abs_state s"
|
|
apply (intro state.equality, simp_all add: absKState_def abs_state_def)
|
|
apply (rule absHeap_correct)
|
|
apply (clarsimp simp: valid_state_def valid_pspace_def)+
|
|
apply (clarsimp dest!: state_relationD)
|
|
apply (rule absCDT_correct)
|
|
apply (clarsimp simp: valid_state_def valid_pspace_def
|
|
valid_state'_def valid_pspace'_def)+
|
|
apply (rule absIsOriginalCap_correct, clarsimp+)
|
|
apply (simp add: state_relation_def)
|
|
apply (simp add: state_relation_def)
|
|
apply (clarsimp simp: user_mem_relation invs_def invs'_def)
|
|
apply (simp add: state_relation_def)
|
|
apply (rule absInterruptIRQNode_correct, simp add: state_relation_def)
|
|
apply (rule absInterruptStates_correct, simp add: state_relation_def)
|
|
apply (erule absArchState_correct)
|
|
apply (rule absExst_correct, simp, assumption+)
|
|
done
|
|
|
|
lemma ptable_lift_abs_state[simp]:
|
|
"ptable_lift t (abs_state s) = ptable_lift t s"
|
|
by (simp add: ptable_lift_def abs_state_def)
|
|
|
|
lemma ptable_rights_abs_state[simp]:
|
|
"ptable_rights t (abs_state s) = ptable_rights t s"
|
|
by (simp add: ptable_rights_def abs_state_def)
|
|
|
|
lemma ptable_rights_imp_UserData:
|
|
assumes invs: "einvs s" and invs': "invs' s'"
|
|
assumes rel: "(s,s') : state_relation"
|
|
assumes rights: "ptable_rights t (absKState s') x \<noteq> {}"
|
|
assumes trans:
|
|
"ptable_lift t (absKState s') x = Some (RISCV64.addrFromPPtr y)"
|
|
shows "pointerInUserData y s' \<or> pointerInDeviceData y s'"
|
|
proof -
|
|
from invs invs' rel have [simp]: "absKState s' = abs_state s"
|
|
by - (rule absKState_correct', simp_all)
|
|
from invs have valid: "valid_state s" by auto
|
|
from invs' have valid': "valid_state' s'" by auto
|
|
have "in_user_frame y s \<or> in_device_frame y s "
|
|
by (rule ptable_rights_imp_frame[OF valid rights[simplified]
|
|
trans[simplified]])
|
|
thus ?thesis
|
|
by (auto simp add: pointerInUserData_relation[OF rel valid' valid]
|
|
pointerInDeviceData_relation[OF rel valid' valid])
|
|
qed
|
|
|
|
definition
|
|
"ex_abs G \<equiv> \<lambda>s'. \<exists>s. ((s :: (det_ext) state),s') \<in> state_relation \<and> G s"
|
|
|
|
lemma device_update_invs':
|
|
"\<lbrace>invs'\<rbrace>doMachineOp (device_memory_update ds)
|
|
\<lbrace>\<lambda>_. invs'\<rbrace>"
|
|
apply (simp add: doMachineOp_def device_memory_update_def simpler_modify_def select_f_def
|
|
gets_def get_def bind_def valid_def return_def)
|
|
by (clarsimp simp: invs'_def valid_state'_def valid_irq_states'_def valid_machine_state'_def)
|
|
|
|
crunches doMachineOp
|
|
for ksDomainTime[wp]: "\<lambda>s. P (ksDomainTime s)"
|
|
|
|
lemma doUserOp_invs':
|
|
"\<lbrace>invs' and ex_abs einvs and
|
|
(\<lambda>s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and
|
|
(\<lambda>s. 0 < ksDomainTime s) and valid_domain_list'\<rbrace>
|
|
doUserOp f tc
|
|
\<lbrace>\<lambda>_. invs' and
|
|
(\<lambda>s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and
|
|
(\<lambda>s. 0 < ksDomainTime s) and valid_domain_list'\<rbrace>"
|
|
apply (simp add: doUserOp_def split_def ex_abs_def)
|
|
apply (wp device_update_invs' doMachineOp_ct_in_state'
|
|
| (wp (once) dmo_invs', wpsimp simp: no_irq_modify device_memory_update_def
|
|
user_memory_update_def))+
|
|
apply (clarsimp simp: user_memory_update_def simpler_modify_def
|
|
restrict_map_def
|
|
split: option.splits)
|
|
apply (frule ptable_rights_imp_UserData[rotated 2], auto)
|
|
done
|
|
|
|
|
|
text \<open>The top-level correspondence\<close>
|
|
|
|
lemma kernel_corres':
|
|
"corres dc (einvs and (\<lambda>s. event \<noteq> Interrupt \<longrightarrow> ct_running s) and (ct_running or ct_idle)
|
|
and (\<lambda>s. scheduler_action s = resume_cur_thread))
|
|
(invs' and (\<lambda>s. event \<noteq> Interrupt \<longrightarrow> ct_running' s) and (ct_running' or ct_idle') and
|
|
(\<lambda>s. ksSchedulerAction s = ResumeCurrentThread))
|
|
(call_kernel event)
|
|
(do _ \<leftarrow> runExceptT $
|
|
handleEvent event `~catchError~`
|
|
(\<lambda>_. withoutPreemption $ do
|
|
irq <- doMachineOp (getActiveIRQ True);
|
|
when (isJust irq) $ handleInterrupt (fromJust irq)
|
|
od);
|
|
_ \<leftarrow> ThreadDecls_H.schedule;
|
|
activateThread
|
|
od)"
|
|
unfolding call_kernel_def callKernel_def
|
|
apply (simp add: call_kernel_def callKernel_def)
|
|
apply (rule corres_guard_imp)
|
|
apply (rule corres_split)
|
|
apply (rule corres_split_handle[OF handleEvent_corres])
|
|
apply simp
|
|
apply (rule corres_split[OF corres_machine_op])
|
|
apply (rule corres_underlying_trivial)
|
|
apply (rule no_fail_getActiveIRQ)
|
|
apply clarsimp
|
|
apply (rule_tac x=irq in option_corres)
|
|
apply (rule_tac P=\<top> and P'=\<top> in corres_inst)
|
|
apply (simp add: when_def)
|
|
apply (rule corres_when[simplified dc_def], simp)
|
|
apply simp
|
|
apply (rule handleInterrupt_corres[simplified dc_def])
|
|
apply simp
|
|
apply (wp hoare_drop_imps hoare_vcg_all_lift)[1]
|
|
apply simp
|
|
apply (rule_tac Q="\<lambda>irq s. invs' s \<and>
|
|
(\<forall>irq'. irq = Some irq' \<longrightarrow>
|
|
intStateIRQTable (ksInterruptState s ) irq' \<noteq>
|
|
IRQInactive)"
|
|
in hoare_post_imp)
|
|
apply simp
|
|
apply (wp doMachineOp_getActiveIRQ_IRQ_active handle_event_valid_sched | simp)+
|
|
apply (rule_tac Q="\<lambda>_. \<top>" and E="\<lambda>_. invs'" in hoare_post_impErr)
|
|
apply wpsimp+
|
|
apply (simp add: invs'_def valid_state'_def)
|
|
apply (rule corres_split[OF schedule_corres])
|
|
apply (rule activateThread_corres)
|
|
apply (wp handle_interrupt_valid_sched[unfolded non_kernel_IRQs_def, simplified]
|
|
schedule_invs' hoare_vcg_if_lift2 hoare_drop_imps |simp)+
|
|
apply (rule_tac Q="\<lambda>_. valid_sched and invs and valid_list" and
|
|
E="\<lambda>_. valid_sched and invs and valid_list"
|
|
in hoare_post_impErr)
|
|
apply (wp handle_event_valid_sched hoare_vcg_imp_lift' |simp)+
|
|
apply (clarsimp simp: active_from_running)
|
|
apply (clarsimp simp: active_from_running')
|
|
done
|
|
|
|
lemma kernel_corres:
|
|
"corres dc (einvs and (\<lambda>s. event \<noteq> Interrupt \<longrightarrow> ct_running s) and (ct_running or ct_idle) and
|
|
(\<lambda>s. scheduler_action s = resume_cur_thread) and
|
|
(\<lambda>s. 0 < domain_time s \<and> valid_domain_list s))
|
|
(invs' and (\<lambda>s. event \<noteq> Interrupt \<longrightarrow> ct_running' s) and (ct_running' or ct_idle') and
|
|
(\<lambda>s. ksSchedulerAction s = ResumeCurrentThread))
|
|
(call_kernel event) (callKernel event)"
|
|
unfolding callKernel_def K_bind_def
|
|
apply (rule corres_guard_imp)
|
|
apply (rule corres_add_noop_lhs2)
|
|
apply (simp only: bind_assoc[symmetric])
|
|
apply (rule corres_split[where r'=dc and
|
|
R="\<lambda>_ s. 0 < domain_time s \<and> valid_domain_list s" and
|
|
R'="\<lambda>_. \<top>"])
|
|
apply (simp only: bind_assoc)
|
|
apply (rule kernel_corres')
|
|
apply (rule corres_bind_return2, rule corres_stateAssert_assume_stronger)
|
|
apply simp
|
|
apply (simp add: kernelExitAssertions_def state_relation_def)
|
|
apply (wp call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext)
|
|
apply wp
|
|
apply clarsimp
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma user_mem_corres:
|
|
"corres (=) invs invs' (gets (\<lambda>x. g (user_mem x))) (gets (\<lambda>x. g (user_mem' x)))"
|
|
by (clarsimp simp add: gets_def get_def return_def bind_def
|
|
invs_def invs'_def
|
|
corres_underlying_def user_mem_relation)
|
|
|
|
lemma device_mem_corres:
|
|
"corres (=) invs invs' (gets (\<lambda>x. g (device_mem x))) (gets (\<lambda>x. g (device_mem' x)))"
|
|
by (clarsimp simp add: gets_def get_def return_def bind_def
|
|
invs_def invs'_def
|
|
corres_underlying_def device_mem_relation)
|
|
|
|
lemma entry_corres:
|
|
"corres (=) (einvs and (\<lambda>s. event \<noteq> Interrupt \<longrightarrow> ct_running s) and
|
|
(\<lambda>s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) and
|
|
(\<lambda>s. scheduler_action s = resume_cur_thread))
|
|
(invs' and (\<lambda>s. event \<noteq> Interrupt \<longrightarrow> ct_running' s) and
|
|
(\<lambda>s. 0 < ksDomainTime s) and valid_domain_list' and (ct_running' or ct_idle') and
|
|
(\<lambda>s. ksSchedulerAction s = ResumeCurrentThread))
|
|
(kernel_entry event tc) (kernelEntry event tc)"
|
|
apply (simp add: kernel_entry_def kernelEntry_def)
|
|
apply (rule corres_guard_imp)
|
|
apply (rule corres_split[OF getCurThread_corres])
|
|
apply (rule corres_split)
|
|
apply simp
|
|
apply (rule threadset_corresT)
|
|
apply (simp add: tcb_relation_def arch_tcb_relation_def
|
|
arch_tcb_context_set_def atcbContextSet_def)
|
|
apply (clarsimp simp: tcb_cap_cases_def cteSizeBits_def)
|
|
apply (clarsimp simp: tcb_cte_cases_def cteSizeBits_def)
|
|
apply (simp add: exst_same_def)
|
|
apply (rule corres_split[OF kernel_corres])
|
|
apply (rule corres_split_eqr[OF getCurThread_corres])
|
|
apply (rule threadGet_corres)
|
|
apply (simp add: tcb_relation_def arch_tcb_relation_def
|
|
arch_tcb_context_get_def atcbContextGet_def)
|
|
apply wp+
|
|
apply (rule hoare_strengthen_post, rule akernel_invs_det_ext,
|
|
simp add: invs_def valid_state_def valid_pspace_def cur_tcb_def)
|
|
apply (rule hoare_strengthen_post, rule ckernel_invs, simp add: invs'_def cur_tcb'_def)
|
|
apply (wp thread_set_invs_trivial thread_set_ct_running
|
|
threadSet_invs_trivial threadSet_ct_running'
|
|
thread_set_not_state_valid_sched hoare_weak_lift_imp
|
|
hoare_vcg_disj_lift ct_in_state_thread_state_lift
|
|
| simp add: tcb_cap_cases_def ct_in_state'_def thread_set_no_change_tcb_state
|
|
| (wps, wp threadSet_st_tcb_at2) )+
|
|
apply (clarsimp simp: invs_def cur_tcb_def valid_state_def valid_pspace_def)
|
|
apply (clarsimp simp: ct_in_state'_def)
|
|
done
|
|
|
|
lemma corres_gets_machine_state:
|
|
"corres (=) \<top> \<top> (gets (f \<circ> machine_state)) (gets (f \<circ> ksMachineState))"
|
|
by (clarsimp simp: gets_def corres_underlying_def
|
|
in_monad bind_def get_def return_def state_relation_def)
|
|
|
|
lemma do_user_op_corres:
|
|
"corres (=) (einvs and ct_running)
|
|
(invs' and (%s. ksSchedulerAction s = ResumeCurrentThread) and
|
|
ct_running')
|
|
(do_user_op f tc) (doUserOp f tc)"
|
|
apply (simp add: do_user_op_def doUserOp_def split_def)
|
|
apply (rule corres_guard_imp)
|
|
apply (rule corres_split[OF getCurThread_corres])
|
|
apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split)
|
|
apply (fastforce dest: absKState_correct [rotated])
|
|
apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split)
|
|
apply (fastforce dest: absKState_correct [rotated])
|
|
apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split)
|
|
apply (rule user_mem_corres)
|
|
apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split)
|
|
apply (rule device_mem_corres)
|
|
apply (rule_tac r'="(=)" in corres_split)
|
|
apply (rule corres_gets_machine_state)
|
|
apply (rule_tac F = "dom (rvb \<circ> addrFromPPtr) \<subseteq> - dom rvd" in corres_gen_asm)
|
|
apply (rule_tac F = "dom (rvc \<circ> addrFromPPtr) \<subseteq> dom rvd" in corres_gen_asm)
|
|
apply simp
|
|
apply (rule_tac r'="(=)" in corres_split[OF corres_select])
|
|
apply simp
|
|
apply (rule corres_underlying_split[OF corres_machine_op])
|
|
apply simp
|
|
apply (rule corres_underlying_trivial)
|
|
apply (simp add: user_memory_update_def)
|
|
apply (wp | simp)+
|
|
apply (rule corres_underlying_split[OF corres_machine_op,where Q = dc and Q'=dc])
|
|
apply (rule corres_underlying_trivial)
|
|
apply (wp | simp add: dc_def device_memory_update_def)+
|
|
apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def)
|
|
apply fastforce
|
|
done
|
|
|
|
lemma ct_running_related:
|
|
"\<lbrakk> (a, c) \<in> state_relation; ct_running' c \<rbrakk>
|
|
\<Longrightarrow> ct_running a"
|
|
apply (clarsimp simp: ct_in_state_def ct_in_state'_def
|
|
curthread_relation)
|
|
apply (frule(1) st_tcb_at_coerce_abstract)
|
|
apply (erule st_tcb_weakenE)
|
|
apply (case_tac st, simp_all)[1]
|
|
done
|
|
|
|
lemma ct_idle_related:
|
|
"\<lbrakk> (a, c) \<in> state_relation; ct_idle' c \<rbrakk>
|
|
\<Longrightarrow> ct_idle a"
|
|
apply (clarsimp simp: ct_in_state_def ct_in_state'_def
|
|
curthread_relation)
|
|
apply (frule(1) st_tcb_at_coerce_abstract)
|
|
apply (erule st_tcb_weakenE)
|
|
apply (case_tac st, simp_all)[1]
|
|
done
|
|
|
|
definition
|
|
"full_invs' \<equiv> {((tc,s),m,e). invs' s \<and>
|
|
ex_abs (einvs::det_ext state \<Rightarrow> bool) s \<and>
|
|
ksSchedulerAction s = ResumeCurrentThread \<and>
|
|
(ct_running' s \<or> ct_idle' s) \<and>
|
|
(m = KernelMode \<longrightarrow> e \<noteq> None) \<and>
|
|
(m = UserMode \<longrightarrow> ct_running' s) \<and>
|
|
(m = IdleMode \<longrightarrow> ct_idle' s) \<and>
|
|
(e \<noteq> None \<and> e \<noteq> Some Interrupt \<longrightarrow> ct_running' s) \<and>
|
|
0 < ksDomainTime s \<and> valid_domain_list' s}"
|
|
|
|
lemma check_active_irq_corres':
|
|
"corres (=) \<top> \<top> (check_active_irq) (checkActiveIRQ)"
|
|
apply (simp add: check_active_irq_def checkActiveIRQ_def)
|
|
apply (rule corres_guard_imp)
|
|
apply (rule corres_split[OF corres_machine_op[OF corres_underlying_trivial], where R="\<lambda>_. \<top>" and R'="\<lambda>_. \<top>"])
|
|
apply simp
|
|
apply (rule no_fail_getActiveIRQ)
|
|
apply (wp | simp )+
|
|
done
|
|
|
|
lemma check_active_irq_corres:
|
|
"corres (=)
|
|
(invs and (ct_running or ct_idle) and einvs and (\<lambda>s. scheduler_action s = resume_cur_thread)
|
|
and (\<lambda>s. 0 < domain_time s) and valid_domain_list)
|
|
(invs' and (\<lambda>s. ksSchedulerAction s = ResumeCurrentThread)
|
|
and (\<lambda>s. 0 < ksDomainTime s) and valid_domain_list' and (ct_running' or ct_idle'))
|
|
(check_active_irq) (checkActiveIRQ)"
|
|
apply (rule corres_guard_imp)
|
|
apply (rule check_active_irq_corres', auto)
|
|
done
|
|
|
|
lemma checkActiveIRQ_just_running_corres:
|
|
"corres (=)
|
|
(invs and ct_running and einvs and (\<lambda>s. scheduler_action s = resume_cur_thread)
|
|
and (\<lambda>s. 0 < domain_time s) and valid_domain_list)
|
|
(invs' and ct_running'
|
|
and (\<lambda>s. 0 < ksDomainTime s) and valid_domain_list'
|
|
and (\<lambda>s. ksSchedulerAction s = ResumeCurrentThread))
|
|
(check_active_irq) (checkActiveIRQ)"
|
|
apply (rule corres_guard_imp)
|
|
apply (rule check_active_irq_corres', auto)
|
|
done
|
|
|
|
lemma checkActiveIRQ_just_idle_corres:
|
|
"corres (=)
|
|
(invs and ct_idle and einvs and (\<lambda>s. scheduler_action s = resume_cur_thread)
|
|
and (\<lambda>s. 0 < domain_time s) and valid_domain_list)
|
|
(invs' and ct_idle'
|
|
and (\<lambda>s. 0 < ksDomainTime s) and valid_domain_list'
|
|
and (\<lambda>s. ksSchedulerAction s = ResumeCurrentThread))
|
|
(check_active_irq) (checkActiveIRQ)"
|
|
apply (rule corres_guard_imp)
|
|
apply (rule check_active_irq_corres', auto)
|
|
done
|
|
|
|
lemma checkActiveIRQ_invs':
|
|
"\<lbrace>invs' and ex_abs invs and (ct_running' or ct_idle')
|
|
and (\<lambda>s. ksSchedulerAction s = ResumeCurrentThread)\<rbrace>
|
|
checkActiveIRQ
|
|
\<lbrace>\<lambda>_. invs' and (ct_running' or ct_idle')
|
|
and (\<lambda>s. ksSchedulerAction s = ResumeCurrentThread)\<rbrace>"
|
|
apply (simp add: checkActiveIRQ_def ex_abs_def)
|
|
apply (wp dmo_invs' | simp)+
|
|
done
|
|
|
|
lemma checkActiveIRQ_invs'_just_running:
|
|
"\<lbrace>invs' and ex_abs invs and ct_running'
|
|
and (\<lambda>s. ksSchedulerAction s = ResumeCurrentThread)\<rbrace>
|
|
checkActiveIRQ
|
|
\<lbrace>\<lambda>_. invs' and ct_running'
|
|
and (\<lambda>s. ksSchedulerAction s = ResumeCurrentThread)\<rbrace>"
|
|
apply (simp add: checkActiveIRQ_def)
|
|
apply (wp | simp)+
|
|
done
|
|
|
|
lemma checkActiveIRQ_invs'_just_idle:
|
|
"\<lbrace>invs' and ex_abs invs and ct_idle'
|
|
and (\<lambda>s. ksSchedulerAction s = ResumeCurrentThread)\<rbrace>
|
|
checkActiveIRQ
|
|
\<lbrace>\<lambda>_. invs' and ct_idle'
|
|
and (\<lambda>s. ksSchedulerAction s = ResumeCurrentThread)\<rbrace>"
|
|
apply (simp add: checkActiveIRQ_def)
|
|
apply (wp | simp)+
|
|
done
|
|
|
|
lemma sched_act_rct_related:
|
|
"\<lbrakk> (a, c) \<in> state_relation; ksSchedulerAction c = ResumeCurrentThread\<rbrakk>
|
|
\<Longrightarrow> scheduler_action a = resume_cur_thread"
|
|
by (case_tac "scheduler_action a", simp_all add: state_relation_def)
|
|
|
|
lemma domain_time_rel_eq:
|
|
"(a, c) \<in> state_relation \<Longrightarrow> P (ksDomainTime c) = P (domain_time a)"
|
|
by (clarsimp simp: state_relation_def)
|
|
|
|
lemma domain_list_rel_eq:
|
|
"(a, c) \<in> state_relation \<Longrightarrow> P (ksDomSchedule c) = P (domain_list a)"
|
|
by (clarsimp simp: state_relation_def)
|
|
|
|
crunch valid_objs': doUserOp, checkActiveIRQ valid_objs'
|
|
(wp: crunch_wps)
|
|
|
|
lemma ckernel_invariant:
|
|
"ADT_H uop \<Turnstile> full_invs'"
|
|
unfolding full_invs'_def
|
|
supply word_neq_0_conv[simp]
|
|
supply domain_time_rel_eq[simp] domain_list_rel_eq[simp]
|
|
apply (rule invariantI)
|
|
apply (clarsimp simp add: ADT_H_def)
|
|
apply (subst conj_commute, simp)
|
|
apply (rule conjI)
|
|
apply (frule init_refinement[simplified subset_eq, THEN bspec])
|
|
apply (clarsimp simp: ex_abs_def lift_state_relation_def)
|
|
apply (frule akernel_init_invs[THEN bspec])
|
|
apply (rule_tac x = s in exI)
|
|
apply (clarsimp simp: Init_A_def)
|
|
apply (insert ckernel_init_invs)[1]
|
|
apply clarsimp
|
|
apply (frule ckernel_init_sch_norm)
|
|
apply (frule ckernel_init_ctr)
|
|
apply (frule ckernel_init_domain_time)
|
|
apply (frule ckernel_init_domain_list)
|
|
apply (fastforce simp: Init_H_def valid_domain_list'_def)
|
|
apply (clarsimp simp: ADT_A_def ADT_H_def global_automaton_def)
|
|
|
|
apply (erule_tac P="a \<and> (\<exists>x. b x)" for a b in disjE)
|
|
|
|
apply (clarsimp simp: kernel_call_H_def)
|
|
|
|
apply (drule use_valid[OF _ valid_corres_combined
|
|
[OF kernel_entry_invs entry_corres],
|
|
OF _ kernelEntry_invs'[THEN hoare_weaken_pre]])
|
|
apply fastforce
|
|
apply (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related
|
|
sched_act_rct_related)
|
|
apply (clarsimp simp: kernel_call_H_def)
|
|
apply (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related
|
|
sched_act_rct_related)
|
|
|
|
apply (erule_tac P="a \<and> b" for a b in disjE)
|
|
apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def)
|
|
apply (drule use_valid)
|
|
apply (rule hoare_vcg_conj_lift)
|
|
apply (rule doUserOp_valid_objs')
|
|
apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]])
|
|
apply clarsimp
|
|
apply (rule doUserOp_invs'[THEN hoare_weaken_pre])
|
|
apply (fastforce simp: ex_abs_def)
|
|
apply (clarsimp simp: invs_valid_objs' ex_abs_def, rule_tac x=s in exI,
|
|
clarsimp simp: ct_running_related sched_act_rct_related)
|
|
apply (clarsimp simp: ex_abs_def)
|
|
apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related)
|
|
|
|
apply (erule_tac P="a \<and> b \<and> c \<and> (\<exists>x. d x)" for a b c d in disjE)
|
|
apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def)
|
|
apply (drule use_valid)
|
|
apply (rule hoare_vcg_conj_lift)
|
|
apply (rule doUserOp_valid_objs')
|
|
apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]])
|
|
apply clarsimp
|
|
apply (rule doUserOp_invs'[THEN hoare_weaken_pre])
|
|
apply (fastforce simp: ex_abs_def)
|
|
apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related)
|
|
apply (fastforce simp: ex_abs_def)
|
|
|
|
apply (erule_tac P="a \<and> b" for a b in disjE)
|
|
apply (clarsimp simp: check_active_irq_H_def)
|
|
apply (drule use_valid)
|
|
apply (rule hoare_vcg_conj_lift)
|
|
apply (rule checkActiveIRQ_valid_objs')
|
|
apply (rule valid_corres_combined[OF check_active_irq_invs_just_running checkActiveIRQ_just_running_corres])
|
|
apply (rule checkActiveIRQ_invs'_just_running[THEN hoare_weaken_pre])
|
|
apply (fastforce simp: ex_abs_def)
|
|
apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related)
|
|
apply (fastforce simp: ex_abs_def)
|
|
|
|
apply (erule_tac P="a \<and> b" for a b in disjE)
|
|
apply (clarsimp simp: check_active_irq_H_def)
|
|
apply (drule use_valid)
|
|
apply (rule hoare_vcg_conj_lift)
|
|
apply (rule checkActiveIRQ_valid_objs')
|
|
apply (rule valid_corres_combined[OF check_active_irq_invs_just_idle checkActiveIRQ_just_idle_corres])
|
|
apply (rule checkActiveIRQ_invs'_just_idle[THEN hoare_weaken_pre])
|
|
apply clarsimp
|
|
apply (fastforce simp: ex_abs_def)
|
|
apply (fastforce simp: ex_abs_def ct_idle_related sched_act_rct_related)
|
|
apply (fastforce simp: ex_abs_def)
|
|
|
|
apply (clarsimp simp: check_active_irq_H_def)
|
|
apply (drule use_valid)
|
|
apply (rule hoare_vcg_conj_lift)
|
|
apply (rule checkActiveIRQ_valid_objs')
|
|
apply (rule valid_corres_combined[OF check_active_irq_invs check_active_irq_corres])
|
|
apply (rule checkActiveIRQ_invs'[THEN hoare_weaken_pre])
|
|
apply clarsimp
|
|
apply (fastforce simp: ex_abs_def)
|
|
apply (fastforce simp: ex_abs_def ct_running_related ct_idle_related sched_act_rct_related)
|
|
apply (fastforce simp: ex_abs_def)
|
|
done
|
|
|
|
text \<open>The top-level theorem\<close>
|
|
|
|
lemma fw_sim_A_H:
|
|
"LI (ADT_A uop)
|
|
(ADT_H uop)
|
|
(lift_state_relation state_relation)
|
|
(full_invs \<times> full_invs')"
|
|
apply (unfold LI_def full_invs_def full_invs'_def)
|
|
apply (simp add: ADT_H_def ADT_A_def)
|
|
apply (intro conjI)
|
|
apply (rule init_refinement)
|
|
apply (clarsimp simp: rel_semi_def relcomp_unfold in_lift_state_relation_eq)
|
|
apply (rename_tac tc ak m ev tc' ck' m' ev' ck)
|
|
apply (simp add: global_automaton_def)
|
|
|
|
apply (erule_tac P="a \<and> (\<exists>x. b x)" for a b in disjE)
|
|
apply (clarsimp simp add: kernel_call_H_def kernel_call_A_def)
|
|
apply (rule rev_mp, rule_tac tc=tc and event=x in entry_corres)
|
|
apply (clarsimp simp: corres_underlying_def)
|
|
apply (drule (1) bspec)
|
|
apply (clarsimp simp: sch_act_simple_def)
|
|
apply (drule (1) bspec)
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply clarsimp
|
|
apply (rule_tac x=b in exI)
|
|
apply (rule conjI)
|
|
apply (rule impI, simp)
|
|
apply (frule (2) ct_running_related)
|
|
apply clarsimp
|
|
apply (rule_tac x=b in exI)
|
|
apply (drule use_valid, rule kernelEntry_invs')
|
|
apply (simp add: sch_act_simple_def)
|
|
apply clarsimp
|
|
apply (frule (1) ct_idle_related)
|
|
apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def)
|
|
|
|
apply (erule_tac P="a \<and> b" for a b in disjE)
|
|
apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def)
|
|
apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres])
|
|
apply simp
|
|
apply (clarsimp simp add: corres_underlying_def)
|
|
apply (drule (1) bspec, clarsimp)
|
|
apply (drule (1) bspec, clarsimp)
|
|
apply fastforce
|
|
|
|
apply (erule_tac P="a \<and> b \<and> c \<and> (\<exists>x. d x)" for a b c d in disjE)
|
|
apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def)
|
|
apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres])
|
|
apply simp
|
|
apply (clarsimp simp add: corres_underlying_def)
|
|
apply (drule (1) bspec, clarsimp)
|
|
apply (drule (1) bspec, clarsimp)
|
|
apply fastforce
|
|
|
|
apply (erule_tac P="a \<and> b" for a b in disjE)
|
|
apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def)
|
|
apply (rule rev_mp, rule check_active_irq_corres)
|
|
apply (clarsimp simp: corres_underlying_def)
|
|
apply fastforce
|
|
|
|
apply (erule_tac P="a \<and> b" for a b in disjE)
|
|
apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def)
|
|
apply (rule rev_mp, rule check_active_irq_corres)
|
|
apply (clarsimp simp: corres_underlying_def)
|
|
apply fastforce
|
|
|
|
apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def)
|
|
apply (rule rev_mp, rule check_active_irq_corres)
|
|
apply (clarsimp simp: corres_underlying_def)
|
|
apply fastforce
|
|
|
|
apply (clarsimp simp: absKState_correct dest!: lift_state_relationD)
|
|
done
|
|
|
|
theorem refinement:
|
|
"ADT_H uop \<sqsubseteq> ADT_A uop"
|
|
apply (rule sim_imp_refines)
|
|
apply (rule L_invariantI)
|
|
apply (rule akernel_invariant)
|
|
apply (rule ckernel_invariant)
|
|
apply (rule fw_sim_A_H)
|
|
done
|
|
|
|
end
|
|
|
|
end
|