adbrucker
/
lh-l4v
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

SELFOUR-1198: update proofs for correct restart PC 

Fixes a case where a thread can go from Running->Inactive->Restart and
use a restart PC that is out of date. An out of date restart PC occurs
when a thread was transitioned to running after being in a blocked
state, but was never scheduled and so did not execute the traps code
that updates the restart PC.

This also renames relevant register names for consistency across
architectures (FaultIP and NextIP).
This commit is contained in:
Michael McInerney 2019-06-12 16:42:24 +10:00
parent 4a07af9d9d
commit 4463e9750e
67 changed files with 958 additions and 292 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
proof/access-control/Access.thy
View File

@ -1176,8 +1176,8 @@ inductive integrity_obj_atomic for aag activate subjects l ko ko'
| troa_tcb_activate:
"\<lbrakk>ko = Some (TCB tcb); ko' = Some (TCB tcb');
tcb' = tcb\<lparr>tcb_arch := arch_tcb_context_set
((arch_tcb_context_get (tcb_arch tcb))(LR_svc :=
(arch_tcb_context_get (tcb_arch tcb)) FaultInstruction)
((arch_tcb_context_get (tcb_arch tcb))(NextIP :=
(arch_tcb_context_get (tcb_arch tcb)) FaultIP)
) (tcb_arch tcb),
tcb_state := Running\<rparr>;
tcb_state tcb = Restart;
@ -1416,7 +1416,7 @@ where
(tcb_state tcb' = Running \<and>
arch_tcb_context_get (tcb_arch tcb')
= (arch_tcb_context_get (tcb_arch tcb))
(LR_svc := arch_tcb_context_get (tcb_arch tcb) FaultInstruction));
(NextIP := arch_tcb_context_get (tcb_arch tcb) FaultIP));
tcb_bound_notification_reset_integrity (tcb_bound_notification tcb) ntfn' subjects aag;
reply_cap_deletion_integrity subjects aag (tcb_caller tcb) cap';
reply_cap_deletion_integrity subjects aag (tcb_ctable tcb) ccap';
@ -1437,8 +1437,8 @@ where
| tro_alt_tcb_activate:
"\<lbrakk>tro_tag TCBActivate; ko = Some (TCB tcb); ko' = Some (TCB tcb');
tcb' = tcb \<lparr> tcb_arch := arch_tcb_context_set
((arch_tcb_context_get (tcb_arch tcb))(LR_svc :=
(arch_tcb_context_get (tcb_arch tcb)) FaultInstruction)
((arch_tcb_context_get (tcb_arch tcb))(NextIP :=
(arch_tcb_context_get (tcb_arch tcb)) FaultIP)
) (tcb_arch tcb),
tcb_caller := cap', tcb_ctable := ccap',
tcb_state := Running, tcb_bound_notification := ntfn'\<rparr>;

5
proof/access-control/DomainSepInv.thy
View File

@ -463,6 +463,11 @@ lemma set_asid_pool_neg_cte_wp_at[wp]:
crunch domain_sep_inv[wp]: set_asid_pool "domain_sep_inv irqs st"
(wp: domain_sep_inv_triv)
lemma as_user_domain_sep_inv[wp]:
"\<lbrace>\<lambda>s. domain_sep_inv irqs st s\<rbrace> as_user a b \<lbrace>\<lambda>_ s. domain_sep_inv irqs st s\<rbrace>"
by (wpsimp simp: domain_sep_inv_def
wp: as_user_cte_wp_at as_user_interrupt_states hoare_vcg_conj_lift
hoare_vcg_all_lift hoare_vcg_disj_lift)
crunch domain_sep_inv[wp]: finalise_cap "domain_sep_inv irqs st"
(wp: crunch_wps dxo_wp_weak simp: crunch_simps ignore: set_object tcb_sched_action)

13
proof/access-control/Finalise_AC.thy
View File

@ -538,13 +538,24 @@ lemma cancel_ipc_respects[wp]:
apply (fastforce simp: obj_at_def is_ep_def dest: pas_refined_mem[OF sta_ts_mem])
done
lemma update_restart_pc_integrity_autarch[wp]:
"\<lbrace>integrity aag X st and K (is_subject aag t)\<rbrace> update_restart_pc t
\<lbrace>\<lambda>_. integrity aag X st\<rbrace>"
apply (simp add: get_thread_state_def thread_get_def)
unfolding update_restart_pc_def
apply (wp as_user_integrity_autarch)
apply simp
done
lemma suspend_respects[wp]:
"\<lbrace>integrity aag X st and pas_refined aag and einvs and tcb_at t and
K (is_subject aag t)\<rbrace>
suspend t \<lbrace>\<lambda>_. integrity aag X st\<rbrace>"
apply (simp add: suspend_def)
apply (wp set_thread_state_integrity_autarch set_thread_state_pas_refined)
apply simp_all
apply (rule hoare_conjI)
apply (wp hoare_drop_imps)+
apply wpsimp+
done
lemma finalise_is_fast_finalise:

55
proof/access-control/Syscall_AC.thy
View File

@ -1279,13 +1279,35 @@ lemma set_asid_pool_current_ipc_buffer_register[wp]:
split: kernel_object.splits)
done
lemma set_tcb_context_current_ipc_buffer_register:
"\<lbrace>\<lambda>s. (f = cur_thread s \<longrightarrow> (P (cxt TPIDRURW) = P (arch_tcb_context_get (tcb_arch tcb) TPIDRURW) \<and>
obj_at (\<lambda>obj. obj = TCB tcb) f s)) \<and> P (current_ipc_buffer_register s)\<rbrace>
set_object f (TCB (tcb\<lparr>tcb_arch := arch_tcb_context_set cxt (tcb_arch tcb)\<rparr>))
\<lbrace>\<lambda>_ s. P (current_ipc_buffer_register s)\<rbrace>"
apply (wpsimp wp: set_object_wp)
by (auto simp: current_ipc_buffer_register_def get_tcb_def obj_at_def)
lemma as_user_current_ipc_buffer_register[wp]:
assumes uc: "\<And>P. \<lbrace>\<lambda>s. P (s TPIDRURW)\<rbrace> a \<lbrace>\<lambda>r s. P (s TPIDRURW)\<rbrace>"
shows "\<lbrace>\<lambda>s. P (current_ipc_buffer_register s)\<rbrace> as_user f a
\<lbrace>\<lambda>_ s. P (current_ipc_buffer_register s)\<rbrace>"
apply (simp add: as_user_def)
apply (wp select_f_wp set_tcb_context_current_ipc_buffer_register | wpc | simp)+
apply (clarsimp dest!: get_tcb_SomeD)
apply (simp add: obj_at_def get_tcb_def)
apply (drule use_valid[OF _ uc])
apply (clarsimp simp: current_ipc_buffer_register_def get_tcb_def)
apply assumption
apply (clarsimp simp: current_ipc_buffer_register_def get_tcb_def)
done
crunch current_ipc_buffer_register [wp]: finalise_cap "\<lambda>s. P (current_ipc_buffer_register s)"
(wp: crunch_wps without_preemption_wp syscall_valid do_machine_op_arch
hoare_unless_wp select_wp
simp: crunch_simps
simp: crunch_simps setRegister_def getRegister_def
ARM.faultRegister_def ARM.nextInstructionRegister_def
ignore: do_machine_op clearMemory empty_slot_ext reschedule_required
tcb_sched_action)
tcb_sched_action set_object as_user)
lemma rec_del_current_ipc_buffer_register [wp]:
"invariant (rec_del call) (\<lambda>s. P (current_ipc_buffer_register s))"
@ -1325,28 +1347,6 @@ lemma transfer_caps_loop_current_ipc_buffer_register:
crunch current_ipc_buffer_register [wp]: transfer_caps "\<lambda>s. P (current_ipc_buffer_register s)"
lemma set_tcb_context_current_ipc_buffer_register:
"\<lbrace>\<lambda>s. (f = cur_thread s \<longrightarrow> (P (cxt TPIDRURW) = P (arch_tcb_context_get (tcb_arch tcb) TPIDRURW) \<and>
obj_at (\<lambda>obj. obj = TCB tcb) f s)) \<and> P (current_ipc_buffer_register s)\<rbrace>
set_object f (TCB (tcb\<lparr>tcb_arch := arch_tcb_context_set cxt (tcb_arch tcb)\<rparr>))
\<lbrace>\<lambda>_ s. P (current_ipc_buffer_register s)\<rbrace>"
apply (wpsimp wp: set_object_wp)
by (auto simp: current_ipc_buffer_register_def get_tcb_def obj_at_def)
lemma as_user_current_ipc_buffer_register[wp]:
assumes uc: "\<And>P. \<lbrace>\<lambda>s. P (s TPIDRURW)\<rbrace> a \<lbrace>\<lambda>r s. P (s TPIDRURW)\<rbrace>"
shows "\<lbrace>\<lambda>s. P (current_ipc_buffer_register s)\<rbrace> as_user f a
\<lbrace>\<lambda>_ s. P (current_ipc_buffer_register s)\<rbrace>"
apply (simp add: as_user_def)
apply (wp select_f_wp set_tcb_context_current_ipc_buffer_register | wpc | simp)+
apply (clarsimp dest!: get_tcb_SomeD)
apply (simp add: obj_at_def get_tcb_def)
apply (drule use_valid[OF _ uc])
apply (clarsimp simp: current_ipc_buffer_register_def get_tcb_def)
apply assumption
apply (clarsimp simp: current_ipc_buffer_register_def get_tcb_def)
done
lemma set_register_tpidrurw_inv[wp]:
"r \<noteq> TPIDRURW \<Longrightarrow> \<lbrace>\<lambda>s. P (s TPIDRURW)\<rbrace> setRegister r v\<lbrace>\<lambda>r s. P (s TPIDRURW)\<rbrace>"
by (simp add: setRegister_def simpler_modify_def valid_def)
@ -1383,7 +1383,7 @@ lemma set_mrs_current_ipc_buffer_register:
apply (simp add: set_mrs_def msg_registers_def)
apply (subst zipWithM_x_mapM_x)
apply (rule hoare_pre)
apply (wp mapM_x_wp[where S = UNIV] | wpc | simp)+
apply (wp mapM_x_wp[where S = UNIV] | wpc | simp)+
apply (rule hoare_pre)
apply (wp set_object_wp | wpc | simp)+
apply (auto simp: current_ipc_buffer_register_def arch_tcb_set_registers_def
@ -1415,7 +1415,8 @@ crunch current_ipc_buffer_register [wp]: set_message_info "\<lambda>s. P (curren
(wp: crunch_wps simp: crunch_simps )
crunch current_ipc_buffer_register [wp]: do_ipc_transfer "\<lambda>s. P (current_ipc_buffer_register s)"
(wp: crunch_wps simp: crunch_simps msg_registers_def)
(wp: crunch_wps simp: crunch_simps msg_registers_def
ignore: set_object as_user)
crunch current_ipc_buffer_register [wp]: send_ipc "\<lambda>s. P (current_ipc_buffer_register s)"
(wp: crunch_wps simp: crunch_simps )

69
proof/crefine/ARM/Finalise_C.thy
View File

@ -550,6 +550,25 @@ lemma setThreadState_ccorres_valid_queues'_simple:
apply (clarsimp simp: weak_sch_act_wf_def valid_queues'_def)
done
lemma updateRestartPC_ccorres:
"ccorres dc xfdc (tcb_at' thread) \<lbrace> \<acute>tcb = tcb_ptr_to_ctcb_ptr thread \<rbrace> hs
(updateRestartPC thread) (Call updateRestartPC_'proc)"
apply (cinit lift: tcb_')
apply (subst asUser_bind_distrib; (wp add: empty_fail_getRegister)?)
apply (ctac (no_vcg) add: getRegister_ccorres)
apply (ctac (no_vcg) add: setRegister_ccorres)
apply wpsimp+
apply (simp add: ARM_H.faultRegister_def ARM_H.nextInstructionRegister_def
ARM.faultRegister_def ARM.nextInstructionRegister_def)
done
crunches updateRestartPC
for valid_queues'[wp]: valid_queues'
and sch_act_simple[wp]: sch_act_simple
and valid_queues[wp]: Invariants_H.valid_queues
and valid_objs'[wp]: valid_objs'
and tcb_at'[wp]: "tcb_at' p"
lemma suspend_ccorres:
assumes cteDeleteOne_ccorres:
"\<And>w slot. ccorres dc xfdc
@ -565,21 +584,54 @@ lemma suspend_ccorres:
(suspend thread) (Call suspend_'proc)"
apply (cinit lift: target_')
apply (ctac(no_vcg) add: cancelIPC_ccorres1 [OF cteDeleteOne_ccorres])
apply (ctac(no_vcg) add: setThreadState_ccorres_valid_queues'_simple)
apply (ctac add: tcbSchedDequeue_ccorres')
apply (rule_tac Q="\<lambda>_.
apply (rule getThreadState_ccorres_foo)
apply (rename_tac threadState)
apply (rule ccorres_move_c_guard_tcb)
apply (rule_tac xf'=ret__unsigned_'
and val="thread_state_to_tsType threadState"
and R="st_tcb_at' ((=) threadState) thread"
and R'=UNIV
in
ccorres_symb_exec_r_known_rv)
apply clarsimp
apply (rule conseqPre, vcg)
apply (clarsimp simp: st_tcb_at'_def)
apply (frule (1) obj_at_cslift_tcb)
apply (clarsimp simp: typ_heap_simps ctcb_relation_thread_state_to_tsType)
apply ceqv
supply Collect_const[simp del]
apply (rule ccorres_split_nothrow)
apply (rule ccorres_cond[where R=\<top> and xf=xfdc])
apply clarsimp
apply (rule iffI)
apply simp
apply (erule thread_state_to_tsType.elims; simp add: StrictC'_thread_state_defs)
apply (ctac (no_vcg) add: updateRestartPC_ccorres)
apply (rule ccorres_return_Skip)
apply ceqv
apply (ctac(no_vcg) add: setThreadState_ccorres_valid_queues'_simple)
apply (ctac add: tcbSchedDequeue_ccorres')
apply (rule_tac Q="\<lambda>_.
(\<lambda>s. \<forall>t' d p. (t' \<in> set (ksReadyQueues s (d, p)) \<longrightarrow>
obj_at' (\<lambda>tcb. tcbQueued tcb \<and> tcbDomain tcb = d
\<and> tcbPriority tcb = p) t' s \<and>
(t' \<noteq> thread \<longrightarrow> st_tcb_at' runnable' t' s)) \<and>
distinct (ksReadyQueues s (d, p))) and valid_queues' and valid_objs' and tcb_at' thread"
in hoare_post_imp)
apply clarsimp
apply (drule_tac x="t" in spec)
apply (drule_tac x=d in spec)
apply (drule_tac x=p in spec)
apply (clarsimp elim!: obj_at'_weakenE simp: inQ_def)
apply (wp_trace sts_valid_queues_partial)[1]
apply clarsimp
apply (wpsimp simp: valid_tcb_state'_def)
apply clarsimp
apply (drule_tac x="t" in spec)
apply (drule_tac x=d in spec)
apply (drule_tac x=p in spec)
apply (clarsimp elim!: obj_at'_weakenE simp: inQ_def)
apply (wp_trace sts_valid_queues_partial)[1]
apply (rule conseqPre, vcg exspec=updateRestartPC_modifies)
apply (rule subset_refl)
apply clarsimp
apply (rule conseqPre, vcg)
apply (rule subset_refl)
apply (rule hoare_strengthen_post)
apply (rule hoare_vcg_conj_lift)
apply (rule hoare_vcg_conj_lift)
@ -588,6 +640,7 @@ lemma suspend_ccorres:
apply (rule delete_one_conc_fr.cancelIPC_invs)
apply (fastforce simp: invs_valid_queues' invs_queues invs_valid_objs'
valid_tcb_state'_def)
apply clarsimp
apply (auto simp: "StrictC'_thread_state_defs")
done

1
proof/crefine/ARM/Move.thy
View File

@ -53,6 +53,7 @@ lemma suspend_st_tcb_at':
suspend t
\<lbrace>\<lambda>_. st_tcb_at' P t'\<rbrace>"
apply (simp add: suspend_def unless_def)
unfolding updateRestartPC_def
apply (cases "t=t'")
apply (simp|wp cancelIPC_st_tcb_at' sts_st_tcb')+
done

4
proof/crefine/ARM/StateRelation_C.thy
View File

@ -234,11 +234,11 @@ fun
| "register_from_H ARM.IP = scast Kernel_C.R12"
| "register_from_H ARM.SP = scast Kernel_C.SP"
| "register_from_H ARM.LR = scast Kernel_C.LR"
| "register_from_H ARM.LR_svc = scast Kernel_C.NextIP"
| "register_from_H ARM.NextIP = scast Kernel_C.NextIP"
| "register_from_H ARM.CPSR = scast Kernel_C.CPSR"
| "register_from_H ARM.TLS_BASE = scast Kernel_C.TLS_BASE"
| "register_from_H ARM.TPIDRURW = scast Kernel_C.TPIDRURW"
| "register_from_H ARM.FaultInstruction = scast Kernel_C.FaultIP"
| "register_from_H ARM.FaultIP = scast Kernel_C.FaultIP"
definition
ccontext_relation :: "(MachineTypes.register \<Rightarrow> word32) \<Rightarrow> user_context_C \<Rightarrow> bool"

69
proof/crefine/ARM_HYP/Finalise_C.thy
View File

@ -584,6 +584,25 @@ lemma setThreadState_ccorres_valid_queues'_simple:
apply (clarsimp simp: weak_sch_act_wf_def valid_queues'_def)
done
lemma updateRestartPC_ccorres:
"ccorres dc xfdc (tcb_at' thread) \<lbrace> \<acute>tcb = tcb_ptr_to_ctcb_ptr thread \<rbrace> hs
(updateRestartPC thread) (Call updateRestartPC_'proc)"
apply (cinit lift: tcb_')
apply (subst asUser_bind_distrib; (wp add: empty_fail_getRegister)?)
apply (ctac (no_vcg) add: getRegister_ccorres)
apply (ctac (no_vcg) add: setRegister_ccorres)
apply wpsimp+
apply (simp add: ARM_HYP_H.faultRegister_def ARM_HYP_H.nextInstructionRegister_def
ARM_HYP.faultRegister_def ARM_HYP.nextInstructionRegister_def)
done
crunches updateRestartPC
for valid_queues'[wp]: valid_queues'
and sch_act_simple[wp]: sch_act_simple
and valid_queues[wp]: Invariants_H.valid_queues
and valid_objs'[wp]: valid_objs'
and tcb_at'[wp]: "tcb_at' p"
lemma suspend_ccorres:
assumes cteDeleteOne_ccorres:
"\<And>w slot. ccorres dc xfdc
@ -599,21 +618,54 @@ lemma suspend_ccorres:
(suspend thread) (Call suspend_'proc)"
apply (cinit lift: target_')
apply (ctac(no_vcg) add: cancelIPC_ccorres1 [OF cteDeleteOne_ccorres])
apply (ctac(no_vcg) add: setThreadState_ccorres_valid_queues'_simple)
apply (ctac add: tcbSchedDequeue_ccorres')
apply (rule_tac Q="\<lambda>_.
apply (rule getThreadState_ccorres_foo)
apply (rename_tac threadState)
apply (rule ccorres_move_c_guard_tcb)
apply (rule_tac xf'=ret__unsigned_'
and val="thread_state_to_tsType threadState"
and R="st_tcb_at' ((=) threadState) thread"
and R'=UNIV
in
ccorres_symb_exec_r_known_rv)
apply clarsimp
apply (rule conseqPre, vcg)
apply (clarsimp simp: st_tcb_at'_def)
apply (frule (1) obj_at_cslift_tcb)
apply (clarsimp simp: typ_heap_simps ctcb_relation_thread_state_to_tsType)
apply ceqv
supply Collect_const[simp del]
apply (rule ccorres_split_nothrow)
apply (rule ccorres_cond[where R=\<top> and xf=xfdc])
apply clarsimp
apply (rule iffI)
apply simp
apply (erule thread_state_to_tsType.elims; simp add: StrictC'_thread_state_defs)
apply (ctac (no_vcg) add: updateRestartPC_ccorres)
apply (rule ccorres_return_Skip)
apply ceqv
apply (ctac(no_vcg) add: setThreadState_ccorres_valid_queues'_simple)
apply (ctac add: tcbSchedDequeue_ccorres')
apply (rule_tac Q="\<lambda>_.
(\<lambda>s. \<forall>t' d p. (t' \<in> set (ksReadyQueues s (d, p)) \<longrightarrow>
obj_at' (\<lambda>tcb. tcbQueued tcb \<and> tcbDomain tcb = d
\<and> tcbPriority tcb = p) t' s \<and>
(t' \<noteq> thread \<longrightarrow> st_tcb_at' runnable' t' s)) \<and>
distinct (ksReadyQueues s (d, p))) and valid_queues' and valid_objs' and tcb_at' thread"
in hoare_post_imp)
apply clarsimp
apply (drule_tac x="t" in spec)
apply (drule_tac x=d in spec)
apply (drule_tac x=p in spec)
apply (clarsimp elim!: obj_at'_weakenE simp: inQ_def)
apply (wp_trace sts_valid_queues_partial)[1]
apply clarsimp
apply (wpsimp simp: valid_tcb_state'_def)
apply clarsimp
apply (drule_tac x="t" in spec)
apply (drule_tac x=d in spec)
apply (drule_tac x=p in spec)
apply (clarsimp elim!: obj_at'_weakenE simp: inQ_def)
apply (wp_trace sts_valid_queues_partial)[1]
apply (rule conseqPre, vcg exspec=updateRestartPC_modifies)
apply (rule subset_refl)
apply clarsimp
apply (rule conseqPre, vcg)
apply (rule subset_refl)
apply (rule hoare_strengthen_post)
apply (rule hoare_vcg_conj_lift)
apply (rule hoare_vcg_conj_lift)
@ -622,6 +674,7 @@ lemma suspend_ccorres:
apply (rule delete_one_conc_fr.cancelIPC_invs)
apply (fastforce simp: invs_valid_queues' invs_queues invs_valid_objs'
valid_tcb_state'_def)
apply clarsimp
apply (auto simp: "StrictC'_thread_state_defs")
done

2
proof/crefine/ARM_HYP/Ipc_C.thy
View File

@ -1631,7 +1631,7 @@ declare zipWithM_x_Nil2[simp]
lemma getRestartPC_ccorres [corres]:
"ccorres (=) ret__unsigned_long_' \<top>
(UNIV \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>) hs
(asUser thread (getRegister register.FaultInstruction))
(asUser thread (getRegister register.FaultIP))
(Call getRestartPC_'proc)"
apply (cinit' lift: thread_')
apply (rule ccorres_trim_return, simp, simp)

3
proof/crefine/ARM_HYP/Move.thy
View File

@ -56,7 +56,8 @@ lemma suspend_st_tcb_at':
"\<lbrace>\<lambda>s. (t\<noteq>t' \<longrightarrow> st_tcb_at' P t' s) \<and> (t=t' \<longrightarrow> P Inactive)\<rbrace>
suspend t
\<lbrace>\<lambda>_. st_tcb_at' P t'\<rbrace>"
apply (simp add: suspend_def unless_def)
apply (simp add: suspend_def)
unfolding updateRestartPC_def
apply (cases "t=t'")
apply (simp|wp cancelIPC_st_tcb_at' sts_st_tcb')+
done

4
proof/crefine/ARM_HYP/StateRelation_C.thy
View File

@ -248,11 +248,11 @@ fun
| "register_from_H ARM_HYP.IP = scast Kernel_C.R12"
| "register_from_H ARM_HYP.SP = scast Kernel_C.SP"
| "register_from_H ARM_HYP.LR = scast Kernel_C.LR"
| "register_from_H ARM_HYP.LR_svc = scast Kernel_C.NextIP"
| "register_from_H ARM_HYP.NextIP = scast Kernel_C.NextIP"
| "register_from_H ARM_HYP.CPSR = scast Kernel_C.CPSR"
| "register_from_H ARM_HYP.TLS_BASE = scast Kernel_C.TLS_BASE"
| "register_from_H ARM_HYP.TPIDRURW = scast Kernel_C.TPIDRURW"
| "register_from_H ARM_HYP.FaultInstruction = scast Kernel_C.FaultIP"
| "register_from_H ARM_HYP.FaultIP = scast Kernel_C.FaultIP"
definition
ccontext_relation :: "(MachineTypes.register \<Rightarrow> word32) \<Rightarrow> user_context_C \<Rightarrow> bool"

82
proof/crefine/X64/Finalise_C.thy
View File

@ -590,6 +590,25 @@ lemma setThreadState_ccorres_valid_queues'_simple:
apply (clarsimp simp: weak_sch_act_wf_def valid_queues'_def)
done
lemma updateRestartPC_ccorres:
"ccorres dc xfdc (tcb_at' thread) \<lbrace>\<acute>tcb = tcb_ptr_to_ctcb_ptr thread \<rbrace> hs
(updateRestartPC thread) (Call updateRestartPC_'proc)"
apply (cinit lift: tcb_')
apply (subst asUser_bind_distrib; (wp add: empty_fail_getRegister)?)
apply (ctac (no_vcg) add: getRegister_ccorres)
apply (ctac (no_vcg) add: setRegister_ccorres)
apply wpsimp+
apply (simp add: X64_H.faultRegister_def X64_H.nextInstructionRegister_def
X64.faultRegister_def X64.nextInstructionRegister_def)
done
crunches updateRestartPC
for valid_queues'[wp]: valid_queues'
and sch_act_simple[wp]: sch_act_simple
and valid_queues[wp]: Invariants_H.valid_queues
and valid_objs'[wp]: valid_objs'
and tcb_at'[wp]: "tcb_at' p"
lemma suspend_ccorres:
assumes cteDeleteOne_ccorres:
"\<And>w slot. ccorres dc xfdc
@ -605,22 +624,55 @@ lemma suspend_ccorres:
(suspend thread) (Call suspend_'proc)"
apply (cinit lift: target_')
apply (ctac(no_vcg) add: cancelIPC_ccorres1 [OF cteDeleteOne_ccorres])
apply (ctac(no_vcg) add: setThreadState_ccorres_valid_queues'_simple)
apply (ctac add: tcbSchedDequeue_ccorres')
apply (rule_tac Q="\<lambda>_.
(\<lambda>s. \<forall>t' d p. (t' \<in> set (ksReadyQueues s (d, p)) \<longrightarrow>
obj_at' (\<lambda>tcb. tcbQueued tcb \<and> tcbDomain tcb = d
\<and> tcbPriority tcb = p) t' s \<and>
(t' \<noteq> thread \<longrightarrow> st_tcb_at' runnable' t' s)) \<and>
distinct (ksReadyQueues s (d, p))) and valid_queues' and valid_objs' and tcb_at' thread"
in hoare_post_imp)
apply (rule getThreadState_ccorres_foo)
apply (rename_tac threadState)
apply (rule ccorres_move_c_guard_tcb)
apply (rule_tac xf'=ret__unsigned_longlong_'
and val="thread_state_to_tsType threadState"
and R="st_tcb_at' ((=) threadState) thread"
and R'=UNIV
in
ccorres_symb_exec_r_known_rv)
apply clarsimp
apply (rule conseqPre, vcg)
apply (clarsimp simp: st_tcb_at'_def)
apply (frule (1) obj_at_cslift_tcb)
apply (clarsimp simp: typ_heap_simps ctcb_relation_thread_state_to_tsType)
apply ceqv
supply Collect_const[simp del]
apply (rule ccorres_split_nothrow)
apply (rule ccorres_cond[where R=\<top> and xf=xfdc])
apply clarsimp
apply (rule iffI)
apply simp
apply (erule thread_state_to_tsType.elims; simp add: StrictC'_thread_state_defs)
apply (ctac (no_vcg) add: updateRestartPC_ccorres)
apply (rule ccorres_return_Skip)
apply ceqv
apply (ctac(no_vcg) add: setThreadState_ccorres_valid_queues'_simple)
apply (ctac add: tcbSchedDequeue_ccorres')
apply (rule_tac Q="\<lambda>_.
(\<lambda>s. \<forall>t' d p. (t' \<in> set (ksReadyQueues s (d, p)) \<longrightarrow>
obj_at' (\<lambda>tcb. tcbQueued tcb \<and> tcbDomain tcb = d
\<and> tcbPriority tcb = p) t' s \<and>
(t' \<noteq> thread \<longrightarrow> st_tcb_at' runnable' t' s)) \<and>
distinct (ksReadyQueues s (d, p))) and valid_queues' and valid_objs' and tcb_at' thread"
in hoare_post_imp)
apply clarsimp
apply (drule_tac x="t" in spec)
apply (drule_tac x=d in spec)
apply (drule_tac x=p in spec)
apply (clarsimp elim!: obj_at'_weakenE simp: inQ_def)
apply (wp_trace sts_valid_queues_partial)[1]
apply clarsimp
apply (wpsimp simp: valid_tcb_state'_def)
apply clarsimp
apply (drule_tac x="t" in spec)
apply (drule_tac x=d in spec)
apply (drule_tac x=p in spec)
apply (clarsimp elim!: obj_at'_weakenE simp: inQ_def)
apply (wp_trace sts_valid_queues_partial)[1]
apply (rule hoare_strengthen_post)
apply (rule conseqPre, vcg exspec=updateRestartPC_modifies)
apply (rule subset_refl)
apply clarsimp
apply (rule conseqPre, vcg)
apply (rule subset_refl)
apply (rule hoare_strengthen_post)
apply (rule hoare_vcg_conj_lift)
apply (rule hoare_vcg_conj_lift)
apply (rule cancelIPC_sch_act_simple)

1
proof/crefine/X64/Move.thy
View File

@ -53,6 +53,7 @@ lemma suspend_st_tcb_at':
suspend t
\<lbrace>\<lambda>_. st_tcb_at' P t'\<rbrace>"
apply (simp add: suspend_def unless_def)
unfolding updateRestartPC_def
apply (cases "t=t'")
apply (simp|wp cancelIPC_st_tcb_at' sts_st_tcb')+
done

24
proof/drefine/Finalise_DR.thy
View File

@ -2583,6 +2583,23 @@ lemma prepare_thread_delete_dcorres: "dcorres dc P P' (CSpace_D.prepare_thread_d
apply (clarsimp simp: CSpace_D.prepare_thread_delete_def prepare_thread_delete_def)
done
lemma update_restart_pc_dcorres: "dcorres dc P P' (return ()) (update_restart_pc t)"
apply (monad_eq simp: update_restart_pc_def as_user_def gets_the_def
getRegister_def setRegister_def set_object_def get_object_def
corres_underlying_def return_def select_f_def)
apply (clarsimp simp: get_tcb_def split: option.splits kernel_object.splits)
apply (clarsimp simp: transform_def transform_objects_def)
apply (intro impI conjI)
apply (rule ext)
apply (clarsimp simp: map_add_def restrict_map_def transform_tcb_def
transform_full_intent_def cap_register_def capRegister_def
get_tcb_message_info_def msg_info_register_def msgInfoRegister_def
get_tcb_mrs_def msgRegisters_A_unfold
get_ipc_buffer_words_def transform_current_thread_def
ARM.faultRegister_def ARM.nextInstructionRegister_def
split: option.splits)+
done
lemma dcorres_finalise_cap:
"cdlcap = transform_cap cap \<Longrightarrow>
dcorres (\<lambda>r r'. fst r = transform_cap (fst r'))
@ -2605,6 +2622,11 @@ lemma dcorres_finalise_cap:
apply (rule corres_guard_imp)
apply (rule corres_split[OF _ dcorres_unbind_notification])
apply (rule corres_split[OF _ finalise_cancel_ipc])
apply (rule dcorres_symb_exec_r[OF _ gts_inv gts_inv])
apply (rule dcorres_rhs_noop_above)
apply (case_tac "rv = Running"; simp)
apply (rule update_restart_pc_dcorres)
apply simp
apply (rule corres_split)
unfolding K_bind_def
apply (rule dcorres_rhs_noop_above_True[OF tcb_sched_action_dcorres[where P=\<top> and P'=\<top>]])
@ -2615,6 +2637,8 @@ lemma dcorres_finalise_cap:
apply (rule set_cap_set_thread_state_inactive)
apply wp+
apply (simp add:not_idle_thread_def)
apply (case_tac "rv = Running"; simp)
apply (wp update_restart_pc_dcorres)
apply (wp unbind_notification_invs | simp add: not_idle_thread_def)+
apply clarsimp
apply (drule(1) thread_in_thread_cap_not_idle[OF invs_valid_global_refs])

16
proof/drefine/Schedule_DR.thy
View File

@ -592,11 +592,11 @@ lemma schedule_dcorres:
done
(*
* The next few lemmas show that updating the register LR_svc in the
* The next few lemmas show that updating the register NextIP in the
* tcb context of a thread does affect the state translation to capDL
*)
lemma get_tcb_message_info_nextPC [simp]:
"get_tcb_message_info (tcb_arch_update (tcb_context_update (\<lambda>ctx. ctx(LR_svc := pc))) tcb) =
"get_tcb_message_info (tcb_arch_update (tcb_context_update (\<lambda>ctx. ctx(NextIP := pc))) tcb) =
get_tcb_message_info tcb"
by (simp add: get_tcb_message_info_def
arch_tcb_context_get_def
@ -604,23 +604,23 @@ lemma get_tcb_message_info_nextPC [simp]:
ARM.msgInfoRegister_def)
lemma map_msg_registers_nextPC [simp]:
"map ((tcb_context tcb)(LR_svc := pc)) msg_registers =
"map ((tcb_context tcb)(NextIP := pc)) msg_registers =
map (tcb_context tcb) msg_registers"
by (simp add: msg_registers_def ARM.msgRegisters_def
upto_enum_red fromEnum_def toEnum_def enum_register)
lemma get_ipc_buffer_words_nextPC [simp]:
"get_ipc_buffer_words m (tcb_arch_update (tcb_context_update (\<lambda>ctx. ctx(LR_svc := pc))) tcb) =
"get_ipc_buffer_words m (tcb_arch_update (tcb_context_update (\<lambda>ctx. ctx(NextIP := pc))) tcb) =
get_ipc_buffer_words m tcb"
by (rule ext) (simp add: get_ipc_buffer_words_def)
lemma get_tcb_mrs_nextPC [simp]:
"get_tcb_mrs m (tcb_arch_update (tcb_context_update (\<lambda>ctx. ctx(LR_svc := pc))) tcb) =
"get_tcb_mrs m (tcb_arch_update (tcb_context_update (\<lambda>ctx. ctx(NextIP := pc))) tcb) =
get_tcb_mrs m tcb"
by (simp add: get_tcb_mrs_def Let_def arch_tcb_context_get_def)
lemma transform_tcb_LR_svc:
"transform_tcb m t (tcb_arch_update (tcb_context_update (\<lambda>ctx. ctx(LR_svc := pc))) tcb)
lemma transform_tcb_NextIP:
"transform_tcb m t (tcb_arch_update (tcb_context_update (\<lambda>ctx. ctx(NextIP:= pc))) tcb)
= transform_tcb m t tcb"
by (auto simp add: transform_tcb_def transform_full_intent_def Let_def
cap_register_def ARM.capRegister_def
@ -640,7 +640,7 @@ lemma as_user_setNextPC_corres:
apply (subst tcb_context_update_aux)
apply (simp add: transform_def transform_current_thread_def)
apply (clarsimp simp: transform_objects_update_kheap_same_caps
transform_tcb_LR_svc transform_objects_update_same
transform_tcb_NextIP transform_objects_update_same
arch_tcb_update_aux3)
done

22
proof/drefine/Tcb_DR.thy
View File

@ -441,16 +441,18 @@ lemma suspend_corres:
(Tcb_D.suspend obj_id) (IpcCancel_A.suspend obj_id)"
apply (rule corres_guard_imp)
apply (clarsimp simp: IpcCancel_A.suspend_def Tcb_D.suspend_def)
apply (rule corres_split[OF _ finalise_cancel_ipc])
apply (rule dcorres_rhs_noop_below_True[OF tcb_sched_action_dcorres])
apply (rule set_thread_state_corres)
apply wp
apply (clarsimp simp:not_idle_thread_def conj_comms)
apply wp
apply simp
apply (clarsimp simp:st_tcb_at_def not_idle_thread_def
obj_at_def generates_pending_def
split:Structures_A.thread_state.split_asm)
apply (rule corres_split[OF _ finalise_cancel_ipc])
apply (rule dcorres_symb_exec_r[OF _ gts_inv gts_inv])
apply (rule dcorres_rhs_noop_above)
apply (case_tac "rv = Running"; simp)
apply (rule update_restart_pc_dcorres)
apply simp
apply (rule dcorres_rhs_noop_below_True[OF tcb_sched_action_dcorres])
apply (rule set_thread_state_corres)
apply wp
apply (case_tac "rv = Running"; simp)
apply wp+
apply (wpsimp simp: not_idle_thread_def conj_comms)+
done
lemma dcorres_setup_reply_master:

7
proof/infoflow/Arch_IF.thy
View File

@ -980,6 +980,13 @@ lemma as_user_set_register_reads_respects':
apply(simp add: labels_are_invisible_def)
done
lemma as_user_get_register_reads_respects:
"reads_respects aag l (K (is_subject aag thread)) (as_user thread (getRegister reg))"
apply (simp add: as_user_def split_def)
apply (wp set_object_reads_respects select_f_ev gets_the_ev)
apply (auto intro: reads_affects_equiv_get_tcb_eq det_getRegister)[1]
done
lemma set_message_info_reads_respects:
assumes domains_distinct: "pas_domains_distinct aag"
shows

12
proof/infoflow/FinalCaps.thy
View File

@ -1432,6 +1432,18 @@ lemma is_subject_not_silc_inv:
"\<lbrakk>silc_inv aag st s; is_subject aag ptr\<rbrakk> \<Longrightarrow> pasObjectAbs aag ptr \<noteq> SilcLabel"
using silc_inv_not_subject by fastforce
lemma update_restart_pc_silc_inv[wp]:
"\<lbrace>silc_inv aag st\<rbrace> update_restart_pc t \<lbrace>\<lambda>_. silc_inv aag st\<rbrace>"
unfolding update_restart_pc_def
apply(rule silc_inv_pres)
apply (simp add: as_user_def)
apply(wpsimp simp: set_object_wp)
apply(wp set_object_wp)+
apply clarsimp+
apply (fastforce simp: silc_inv_def dest: get_tcb_SomeD simp: obj_at_def is_cap_table_def)
apply wp+
done
lemma finalise_cap_silc_inv:
"\<lbrace>silc_inv aag st and valid_mdb and pas_refined aag and K (pas_cap_cur_auth aag cap)\<rbrace>
finalise_cap cap final

23
proof/infoflow/Finalise_IF.thy
View File

@ -1208,6 +1208,15 @@ lemma cancel_ipc_reads_respects_f:
apply (simp add: st_tcb_at_def obj_at_def | blast)+
done
lemma update_restart_pc_reads_respects[wp]:
assumes domains_distinct[wp]: "pas_domains_distinct aag"
shows
"reads_respects aag l (silc_inv aag s and K (is_subject aag thread))
(update_restart_pc thread)"
unfolding update_restart_pc_def
apply (subst as_user_bind)
apply (wpsimp wp: as_user_set_register_reads_respects' as_user_get_register_reads_respects)
done
lemma suspend_reads_respects_f:
assumes domains_distinct[wp]: "pas_domains_distinct aag"
@ -1215,9 +1224,19 @@ lemma suspend_reads_respects_f:
"reads_respects_f aag l (silc_inv aag st and pas_refined aag and invs and tcb_at thread and
(K (is_subject aag thread))) (suspend thread)"
unfolding suspend_def
apply(wp reads_respects_f[OF set_thread_state_owned_reads_respects, where st=st and Q="\<top>"] reads_respects_f[OF tcb_sched_action_reads_respects, where st=st and Q=\<top>] set_thread_state_pas_refined| simp)+
apply(wp reads_respects_f[OF set_thread_state_owned_reads_respects, where st=st and Q="\<top>"]
reads_respects_f[OF tcb_sched_action_reads_respects, where st=st and Q=\<top>]
reads_respects_f[OF get_thread_state_rev, where st=st and Q="\<top>"]
reads_respects_f[OF update_restart_pc_reads_respects, where st=st and Q="\<top>"]
gts_wp
set_thread_state_pas_refined| simp)+
apply(wp cancel_ipc_reads_respects_f[where st=st] cancel_ipc_silc_inv)+
by force
apply clarsimp
apply (wp hoare_allI hoare_drop_imps)
apply clarsimp
apply(wp cancel_ipc_silc_inv)+
apply auto
done
lemma prepare_thread_delete_reads_respects_f:
"reads_respects_f aag l \<top> (prepare_thread_delete thread)"

76
proof/infoflow/Tcb_IF.thy
View File

@ -116,27 +116,53 @@ lemma flush_space_valid_arch_state[wp]: "\<lbrace>valid_arch_state \<rbrace> flu
apply (wp load_hw_asid_wp | wpc | simp)+
done
crunch globals_equiv[wp]: suspend,prepare_thread_delete "globals_equiv st"
lemma get_thread_state_globals_equiv[wp]:
"\<lbrace>globals_equiv s and valid_ko_at_arm\<rbrace> get_thread_state ref \<lbrace>\<lambda>_. globals_equiv s\<rbrace>"
unfolding get_thread_state_def
apply(wp set_object_globals_equiv dxo_wp_weak |simp)+
done
lemma suspend_globals_equiv[wp]:
"\<lbrace>globals_equiv st and (\<lambda>s. t \<noteq> idle_thread s) and valid_ko_at_arm\<rbrace> suspend t \<lbrace>\<lambda>_. globals_equiv st\<rbrace>"
unfolding suspend_def
apply (wp tcb_sched_action_extended.globals_equiv dxo_wp_weak)
apply simp
apply (wp set_thread_state_globals_equiv)
apply wp+
unfolding update_restart_pc_def
apply wp+
apply clarsimp
apply (rule hoare_vcg_conj_lift)
prefer 2
apply (rule hoare_drop_imps)
apply wp+
apply (rule hoare_drop_imps)
apply wp+
apply auto
done
crunch globals_equiv[wp]: prepare_thread_delete "globals_equiv st"
(wp: dxo_wp_weak)
lemma finalise_cap_globals_equiv:
"\<lbrace>globals_equiv st and valid_global_objs and valid_arch_state and pspace_aligned and valid_vspace_objs and valid_global_refs and valid_vs_lookup\<rbrace>
"\<lbrace>globals_equiv st and (\<lambda>s. \<forall>p. cap = ThreadCap p \<longrightarrow> p \<noteq> idle_thread s)
and valid_global_objs and valid_arch_state and pspace_aligned and valid_vspace_objs and valid_global_refs and valid_vs_lookup\<rbrace>
finalise_cap cap b
\<lbrace>\<lambda> _. globals_equiv st\<rbrace>"
apply (induct cap)
apply (simp_all add:finalise_cap.simps)
apply (wp liftM_wp when_def cancel_all_ipc_globals_equiv cancel_all_ipc_valid_global_objs
cancel_all_signals_globals_equiv cancel_all_signals_valid_global_objs
arch_finalise_cap_globals_equiv unbind_maybe_notification_globals_equiv
unbind_notification_globals_equiv
| simp add: valid_arch_state_ko_at_arm | intro impI conjI)+
apply (simp_all add:finalise_cap.simps)
apply (wp liftM_wp when_def cancel_all_ipc_globals_equiv cancel_all_ipc_valid_global_objs
cancel_all_signals_globals_equiv cancel_all_signals_valid_global_objs
arch_finalise_cap_globals_equiv unbind_maybe_notification_globals_equiv
unbind_notification_globals_equiv
| clarsimp simp add: valid_arch_state_ko_at_arm | intro impI conjI)+
done
crunch valid_ko_at_arm[wp]: cap_swap_for_delete, restart "valid_ko_at_arm"
(wp: dxo_wp_weak ignore: cap_swap_ext)
lemma rec_del_preservation2':
assumes finalise_cap_P: "\<And>cap final. \<lbrace>R and P\<rbrace> finalise_cap cap final \<lbrace>\<lambda>_.P\<rbrace>"
assumes finalise_cap_P: "\<And>cap final. \<lbrace>R cap and P\<rbrace> finalise_cap cap final \<lbrace>\<lambda>_.P\<rbrace>"
assumes set_cap_P : "\<And> cap b. \<lbrace>Q and P\<rbrace> set_cap cap b \<lbrace>\<lambda>_.P\<rbrace>"
assumes set_cap_Q : "\<And> cap b. \<lbrace>Q\<rbrace> set_cap cap b \<lbrace>\<lambda>_.Q\<rbrace>"
assumes empty_slot_P: "\<And> slot free. \<lbrace>Q and P\<rbrace> empty_slot slot free \<lbrace>\<lambda>_. P\<rbrace>"
@ -146,7 +172,7 @@ lemma rec_del_preservation2':
assumes preemption_point_Q: "\<And> a b. \<lbrace>Q\<rbrace> preemption_point \<lbrace>\<lambda>_. Q\<rbrace>"
assumes preemption_point_P: "\<And> a b. \<lbrace>Q and P\<rbrace> preemption_point \<lbrace>\<lambda>_. P\<rbrace>"
assumes invs_Q: "\<And> s. invs s \<Longrightarrow> Q s"
assumes invs_R: "\<And> s. invs s \<Longrightarrow> R s"
assumes invs_R: " \<And>s slot cap. invs s \<Longrightarrow> caps_of_state s slot = Some cap \<Longrightarrow> R cap s"
shows
"s \<turnstile> \<lbrace>\<lambda>s. invs s \<and> P s \<and> Q s \<and> emptyable (slot_rdcall call) s \<and> valid_rec_del_call call s\<rbrace>
rec_del call
@ -248,10 +274,11 @@ done
qed
lemma rec_del_preservation2:
"\<lbrakk>\<And>cap final. \<lbrace>R and P\<rbrace> finalise_cap cap final \<lbrace>\<lambda>_. P\<rbrace>; \<And>cap b. \<lbrace>Q and P\<rbrace> set_cap cap b \<lbrace>\<lambda>_. P\<rbrace>;
"\<lbrakk>\<And>cap final. \<lbrace>R cap and P\<rbrace> finalise_cap cap final \<lbrace>\<lambda>_. P\<rbrace>; \<And>cap b. \<lbrace>Q and P\<rbrace> set_cap cap b \<lbrace>\<lambda>_. P\<rbrace>;
\<And>cap b. invariant (set_cap cap b) Q; \<And>slot free. \<lbrace>Q and P\<rbrace> empty_slot slot free \<lbrace>\<lambda>_. P\<rbrace>;
\<And>slot free. invariant (empty_slot slot free) Q; \<And>a b. invariant (cap_swap_for_delete a b) Q;
\<And>a b. \<lbrace>Q and P\<rbrace> cap_swap_for_delete a b \<lbrace>\<lambda>_. P\<rbrace>; \<And>s. invs s \<Longrightarrow> Q s; \<And>s. invs s \<Longrightarrow> R s;
\<And>a b. \<lbrace>Q and P\<rbrace> cap_swap_for_delete a b \<lbrace>\<lambda>_. P\<rbrace>; \<And>s. invs s \<Longrightarrow> Q s;
\<And>s slot cap. invs s \<Longrightarrow> caps_of_state s slot = Some cap \<Longrightarrow> R cap s;
invariant preemption_point Q; \<lbrace>Q and P\<rbrace> preemption_point \<lbrace>\<lambda>_. P\<rbrace>\<rbrakk>
\<Longrightarrow> \<lbrace>\<lambda>s. invs s \<and> P s \<and> emptyable (slot_rdcall call) s \<and> valid_rec_del_call call s\<rbrace> rec_del call
\<lbrace>\<lambda>r. P\<rbrace>"
@ -260,8 +287,8 @@ lemma rec_del_preservation2:
apply (rule_tac Q="\<lambda>rv s. P s \<and> Q s" in hoare_strengthen_post)
apply (rule validE_valid)
apply (rule use_spec)
apply (rule rec_del_preservation2' [where R=R],simp+)
done
apply (rule rec_del_preservation2' [where R=R],simp+)
done
lemma globals_equiv_irq_state_independent_A[simp, intro!]:
"irq_state_independent_A (globals_equiv st)"
@ -273,13 +300,24 @@ lemma valid_ko_at_arm_irq_state_independent_A[simp, intro!]:
apply(auto simp: irq_state_independent_A_def valid_ko_at_arm_def)
done
lemma no_cap_to_idle_thread'': "valid_global_refs s \<Longrightarrow> caps_of_state s ref \<noteq> Some (ThreadCap (idle_thread s))"
apply (clarsimp simp add: valid_global_refs_def valid_refs_def cte_wp_at_caps_of_state)
apply (drule_tac x="fst ref" in spec)
apply (drule_tac x="snd ref" in spec)
apply (simp add: cap_range_def global_refs_def)
done
lemma rec_del_globals_equiv:
"\<lbrace>\<lambda>s. invs s \<and> globals_equiv st s \<and> emptyable (slot_rdcall call) s \<and> valid_rec_del_call call s\<rbrace>
"\<lbrace>\<lambda>s. invs s \<and> globals_equiv st s \<and> emptyable (slot_rdcall call) s
\<and> valid_rec_del_call call s\<rbrace>
rec_del call
\<lbrace>\<lambda>_. globals_equiv st\<rbrace>"
apply (wp rec_del_preservation2[where Q="valid_ko_at_arm" and R="valid_global_objs and valid_arch_state and pspace_aligned and valid_vspace_objs and
valid_global_refs and
valid_vs_lookup"] finalise_cap_globals_equiv)
apply (wp rec_del_preservation2[where Q="valid_ko_at_arm"
and R="\<lambda>cap s. valid_global_objs s \<and> valid_arch_state s
\<and> pspace_aligned s \<and> valid_vspace_objs s
\<and> valid_global_refs s \<and> valid_vs_lookup s
\<and> (\<forall>p. cap = ThreadCap p \<longrightarrow> p \<noteq> idle_thread s)
"] finalise_cap_globals_equiv)
apply simp
apply (wp set_cap_globals_equiv'')
apply simp
@ -288,7 +326,7 @@ lemma rec_del_globals_equiv:
apply (wp empty_slot_valid_ko_at_arm)+
apply simp
apply (simp add: invs_valid_ko_at_arm)
apply (simp add: invs_def valid_state_def valid_arch_caps_def valid_pspace_def)
apply (clarsimp simp: invs_def valid_state_def valid_arch_caps_def valid_pspace_def no_cap_to_idle_thread'')
apply (wp preemption_point_inv | simp)+
done

14
proof/invariant-abstract/ARM/ArchFinalise_AI.thy
View File

@ -514,11 +514,17 @@ lemma suspend_unlive':
suspend t
\<lbrace>\<lambda>rv. obj_at (Not \<circ> live) t\<rbrace>"
apply (simp add: suspend_def set_thread_state_def set_object_def get_object_def)
supply hoare_vcg_if_split[wp_split del] if_splits[split del]
apply (wp | simp only: obj_at_exst_update)+
apply (simp add: obj_at_def)
apply (rule_tac Q="\<lambda>_. bound_tcb_at ((=) None) t" in hoare_strengthen_post)
apply wp
apply (auto simp: pred_tcb_def2 live_def hyp_live_def dest: refs_of_live)
apply (simp add: obj_at_def live_def hyp_live_def)
apply (rule_tac Q="\<lambda>_. bound_tcb_at ((=) None) t" in hoare_strengthen_post)
supply hoare_vcg_if_split[wp_split]
apply wp
apply (auto simp: pred_tcb_def2)[1]
apply (simp flip: if_split)
apply wp
apply wp
apply simp
done
lemma (* finalise_cap_replaceable *) [Finalise_AI_asms]:

11
proof/invariant-abstract/ARM/ArchInvariants_AI.thy
View File

@ -2398,8 +2398,19 @@ lemma valid_arch_mdb_eqI:
shows "valid_arch_mdb (is original_cap s') (caps_of_state s')"
by (clarsimp simp: valid_arch_mdb_def)
lemma arch_tcb_context_absorbs[simp]:
"arch_tcb_context_set uc2 (arch_tcb_context_set uc1 a_tcb) \<equiv> arch_tcb_context_set uc2 a_tcb"
by (simp add: arch_tcb_context_set_def)
lemma arch_tcb_context_get_set[simp]:
"arch_tcb_context_get (arch_tcb_context_set uc a_tcb) = uc"
by (simp add: arch_tcb_context_get_def arch_tcb_context_set_def)
end
declare ARM.arch_tcb_context_absorbs[simp]
declare ARM.arch_tcb_context_get_set[simp]
setup {* Add_Locale_Code_Defs.setup "ARM" *}
setup {* Add_Locale_Code_Defs.setup "ARM_A" *}

8
proof/invariant-abstract/ARM/Machine_AI.thy
View File

@ -766,6 +766,14 @@ lemma empty_fail_clearMemory [simp, intro!]:
by (simp add: clearMemory_def mapM_x_mapM ef_storeWord)
end
lemmas msgRegisters_A_unfold
= msg_registers_def
msgRegisters_def
[unfolded upto_enum_def, simplified,
unfolded fromEnum_def enum_register, simplified,
unfolded toEnum_def enum_register, simplified]
end
end

19
proof/invariant-abstract/ARM_HYP/ArchInvariants_AI.thy
View File

@ -2513,9 +2513,22 @@ lemma valid_arch_mdb_eqI:
shows "valid_arch_mdb (is original_cap s') (caps_of_state s')"
by (clarsimp simp: valid_arch_mdb_def)
end
lemma arch_tcb_context_absorbs[simp]:
"arch_tcb_context_set uc2 (arch_tcb_context_set uc1 a_tcb) \<equiv> arch_tcb_context_set uc2 a_tcb"
apply (simp add: arch_tcb_context_set_def)
done
setup {* Add_Locale_Code_Defs.setup "ARM" *}
setup {* Add_Locale_Code_Defs.setup "ARM_A" *}
lemma arch_tcb_context_get_set[simp]:
"arch_tcb_context_get (arch_tcb_context_set uc a_tcb) = uc"
apply (simp add: arch_tcb_context_get_def arch_tcb_context_set_def)
done
end
declare ARM_HYP.arch_tcb_context_absorbs[simp]
declare ARM_HYP.arch_tcb_context_get_set[simp]
setup {* Add_Locale_Code_Defs.setup "ARM_HYP" *}
setup {* Add_Locale_Code_Defs.setup "ARM_HYP_A" *}
end

30
proof/invariant-abstract/BCorres2_AI.thy
View File

@ -33,13 +33,16 @@ locale BCorres2_AI =
"bcorres (arch_switch_to_idle_thread :: 'a state \<Rightarrow> _)
arch_switch_to_idle_thread"
crunch (bcorres)bcorres[wp]: "IpcCancel_A.suspend",deleting_irq_handler truncate_state
crunch (bcorres)bcorres[wp]: deleting_irq_handler truncate_state
(simp: gets_the_def swp_def)
lemma finalise_cap_bcorres[wp]: "bcorres (finalise_cap a b) (finalise_cap a b)"
apply (cases a)
apply (wp | wpc | simp | intro impI allI conjI)+
done
lemma update_restart_pc_bcorres[wp]:
"bcorres (update_restart_pc t) (update_restart_pc t)"
by (wp
| clarsimp simp: update_restart_pc_def as_user_def bind_select_f_bind'
split: prod.splits)+
crunch (bcorres)bcorres[wp]: suspend, finalise_cap truncate_state
definition all_but_exst where
"all_but_exst P \<equiv> (\<lambda>s. P (kheap s) (cdt s) (is_original_cap s)
@ -274,8 +277,7 @@ global_interpretation cap_move_ext: is_extended "cap_move_ext a b c d"
lemmas rec_del_simps_ext =
rec_del.simps [THEN ext[where f="rec_del args" for args]]
lemma rec_del_s_bcorres:
lemma rec_del_s_bcorres[wp]:
notes rec_del.simps[simp del]
shows
"s_bcorres (rec_del c) (rec_del c) s"
@ -311,9 +313,17 @@ shows
qed
lemmas rec_del_bcorres = use_sbcorres_underlying[OF rec_del_s_bcorres]
lemmas rec_del_bcorres[wp] = use_sbcorres_underlying[OF rec_del_s_bcorres]
crunch (bcorres)bcorres[wp]: cap_delete truncate_state
lemma cap_delete_bcorres'[wp]:
assumes finalise_cap_bcorres[wp]:
"\<And>r ra. bcorres (finalise_cap r ra :: 'a::state_ext state \<Rightarrow> _) (finalise_cap r ra)"
shows "bcorres (cap_delete slot :: 'a state \<Rightarrow> _) (cap_delete slot)"
unfolding cap_delete_def
apply wp
apply (simp add: returnOk_bcorres_underlying)
apply (wp rec_del_bcorres)
done
lemma cap_revoke_s_bcorres:
shows
@ -332,7 +342,7 @@ proof (induct rule: cap_revoke.induct[where ?a1.0=s])
done
qed
lemmas cap_revoke_bcorres = use_sbcorres_underlying[OF cap_revoke_s_bcorres]
lemmas cap_revoke_bcorres[wp] = use_sbcorres_underlying[OF cap_revoke_s_bcorres]
crunch (bcorres)bcorres[wp]: "Tcb_A.restart",as_user,option_update_thread truncate_state (simp: gets_the_def ignore: clearMemory check_cap_at gets_the getRegister setRegister getRestartPC setNextPC)

11
proof/invariant-abstract/CNodeInv_AI.thy
View File

@ -2393,16 +2393,17 @@ lemma reply_cancel_ipc_emptyable[wp]:
crunch emptyable[wp]: cancel_ipc "emptyable sl"
crunch emptyable[wp]: update_restart_pc "emptyable sl"
(rule: emptyable_lift)
lemma suspend_emptyable[wp]:
"\<lbrace>invs and emptyable sl and valid_mdb\<rbrace> IpcCancel_A.suspend l \<lbrace>\<lambda>_. emptyable sl\<rbrace>"
"\<lbrace>invs and emptyable sl and valid_mdb\<rbrace> suspend l \<lbrace>\<lambda>_. emptyable sl\<rbrace>"
apply (simp add: IpcCancel_A.suspend_def)
apply (wp|simp)+
apply (wp emptyable_lift sts_st_tcb_at_cases)+
apply simp
apply (wp set_thread_state_cte_wp_at | simp)+
apply (wp emptyable_lift sts_st_tcb_at_cases)+
apply (wpsimp wp: set_thread_state_cte_wp_at)+
done
crunch emptyable[wp]: do_machine_op "emptyable sl"
(rule: emptyable_lift)

4
proof/invariant-abstract/DetSchedDomainTime_AI.thy
View File

@ -97,6 +97,10 @@ locale DetSchedDomainTime_AI =
assumes arch_post_cap_deletion_domain_list_inv'[wp]:
"\<And>P ft. \<lbrace>\<lambda>s. P (domain_list s)\<rbrace> arch_post_cap_deletion ft \<lbrace>\<lambda>_ s. P (domain_list s)\<rbrace>"
crunches update_restart_pc
for domain_list[wp]: "\<lambda>s. P (domain_list s)"
and domain_time[wp]: "\<lambda>s. P (domain_time s)"
locale DetSchedDomainTime_AI_2 = DetSchedDomainTime_AI +
assumes handle_hypervisor_fault_domain_list_inv'[wp]:
"\<And>P t f. \<lbrace>\<lambda>s. P (domain_list s)\<rbrace> handle_hypervisor_fault t f \<lbrace>\<lambda>_ s. P (domain_list s)\<rbrace>"

53
proof/invariant-abstract/DetSchedSchedule_AI.thy
View File

@ -1356,6 +1356,13 @@ lemma schedule_valid_sched:
st_tcb_at_def obj_at_def)?)
done
crunch ct_not_in_q[wp]: as_user ct_not_in_q
(wp: ct_not_in_q_lift)
crunches update_restart_pc
for ct_not_in_q[wp]: "\<lambda>s. ct_not_in_q s"
crunch ct_not_in_q[wp]: finalise_cap ct_not_in_q
(wp: crunch_wps hoare_drop_imps hoare_unless_wp select_inv mapM_wp
subset_refl if_fun_split simp: crunch_simps ignore: tcb_sched_action)
@ -1454,6 +1461,9 @@ lemma unbind_notification_valid_sched[wp]:
apply (wp set_bound_notification_valid_sched, clarsimp)
done
crunches update_restart_pc
for valid_etcbs[wp]: "valid_etcbs"
context DetSchedSchedule_AI begin
crunch valid_etcbs[wp]: finalise_cap valid_etcbs
@ -1594,28 +1604,38 @@ crunch simple_sched_action[wp]: tcb_sched_action, update_cdt_list simple_sched_a
context DetSchedSchedule_AI begin
crunches update_restart_pc
for simple_sched_action[wp]: "simple_sched_action"
and valid_sched[wp]: "valid_sched"
(simp: crunch_simps ignore: set_object)
crunch simple_sched_action[wp]: finalise_cap simple_sched_action
(wp: hoare_drop_imps mapM_x_wp mapM_wp select_wp subset_refl
simp: unless_def if_fun_split)
lemma suspend_valid_sched[wp]:
"\<lbrace>valid_sched and simple_sched_action\<rbrace> suspend t \<lbrace>\<lambda>rv. valid_sched\<rbrace>"
apply (simp add: suspend_def)
apply (rule seq_ext)
apply (rule_tac R="K $ valid_sched and simple_sched_action" in hoare_strengthen_post[rotated])
notes seq_ext_inv = seq_ext[where A=I and B="\<lambda>_. I" for I]
shows "\<lbrace>valid_sched and simple_sched_action\<rbrace> suspend t \<lbrace>\<lambda>rv. valid_sched\<rbrace>"
apply (simp add: suspend_def)
apply (rule seq_ext_inv)
apply wpsimp
apply (rule seq_ext_inv)
apply wp
apply (rule seq_ext_inv)
apply wpsimp
apply (wp tcb_sched_action_dequeue_strong_valid_sched
| simp)+
apply (simp add: set_thread_state_def)
apply (wp gts_wp | wpc |
simp add: set_thread_state_def set_thread_state_ext_def
reschedule_required_def set_scheduler_action_def
tcb_sched_action_def set_object_def get_object_def)+
apply (simp only: st_tcb_at_kh_simp[symmetric])
apply (clarsimp simp: valid_sched_def valid_queues_def st_tcb_at_kh_if_split
valid_sched_action_def simple_sched_action_def
is_activatable_def valid_blocked_def
split: scheduler_action.splits)+
done
apply (simp add: set_thread_state_def)
apply (wp gts_wp | wpc |
simp add: set_thread_state_def set_thread_state_ext_def
reschedule_required_def set_scheduler_action_def
tcb_sched_action_def set_object_def get_object_def)+
apply (simp only: st_tcb_at_kh_simp[symmetric])
apply (clarsimp simp: valid_sched_def valid_queues_def st_tcb_at_kh_if_split
valid_sched_action_def simple_sched_action_def
is_activatable_def valid_blocked_def
split: scheduler_action.splits)+
done
crunch valid_sched[wp]: finalise_cap valid_sched
(wp: crunch_wps simp: crunch_simps)
@ -1958,9 +1978,6 @@ crunch valid_sched[wp]: store_word_offs valid_sched
crunch exst[wp]: set_mrs, as_user "\<lambda>s. P (exst s)"
(simp: crunch_simps wp: crunch_wps)
crunch ct_not_in_q[wp]: as_user ct_not_in_q
(wp: ct_not_in_q_lift)
crunch valid_sched[wp]: set_mrs valid_sched
(wp: valid_sched_lift)

2
proof/invariant-abstract/Deterministic_AI.thy
View File

@ -3979,6 +3979,8 @@ crunch (empty_fail) empty_fail[wp]: dec_domain_time
global_interpretation dec_domain_time_extended: is_extended "dec_domain_time"
by (unfold_locales; wp)
crunch valid_list[wp]: update_restart_pc "valid_list"
context Deterministic_AI_1 begin
crunch valid_list[wp]: invoke_tcb valid_list
(wp: mapM_x_wp' ignore: check_cap_at simp: check_cap_at_def)

15
proof/invariant-abstract/Finalise_AI.thy
View File

@ -51,6 +51,10 @@ definition
| ArchObjectCap acap \<Rightarrow> arch_post_cap_delete_pre cap cs
| _ \<Rightarrow> False"
lemma update_restart_pc_caps_of_state[wp]:
"\<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> update_restart_pc t \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
by (simp add: update_restart_pc_def as_user_caps)
locale Finalise_AI_1 =
fixes state_ext_type1 :: "('a :: state_ext) itself"
fixes state_ext_type2 :: "('b :: state_ext) itself"
@ -143,6 +147,7 @@ locale Finalise_AI_1 =
assumes prepare_thread_delete_caps_of_state:
"\<And>P t. \<lbrace>\<lambda>(s :: 'a state). P (caps_of_state s)\<rbrace> prepare_thread_delete t \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
text {* Properties about empty_slot *}
definition
@ -511,16 +516,13 @@ lemma cancel_ipc_caps_of_state:
apply (clarsimp simp: fun_upd_def[symmetric] cte_wp_at_caps_of_state)
done
lemma suspend_caps_of_state:
"\<lbrace>\<lambda>s. (\<forall>p. cte_wp_at can_fast_finalise p s
\<longrightarrow> P ((caps_of_state s) (p \<mapsto> cap.NullCap)))
\<and> P (caps_of_state s)\<rbrace>
suspend t
\<lbrace>\<lambda>rv s. P (caps_of_state s)\<rbrace>"
unfolding suspend_def
by (wpsimp wp: cancel_ipc_caps_of_state simp: fun_upd_def[symmetric])
by (wpsimp wp: cancel_ipc_caps_of_state simp: suspend_def fun_upd_def[symmetric])+
lemma suspend_final_cap:
"\<lbrace>\<lambda>s. is_final_cap' cap s \<and> \<not> can_fast_finalise cap
@ -821,7 +823,7 @@ lemma cap_delete_one_cte_wp_at_preserved:
done
interpretation delete_one_pre
by (unfold_locales, wp cap_delete_one_cte_wp_at_preserved)
by (unfold_locales; wpsimp wp: cap_delete_one_cte_wp_at_preserved)
lemma (in Finalise_AI_1) finalise_cap_equal_cap[wp]:
"\<lbrace>cte_wp_at ((=) cap) sl\<rbrace>
@ -1038,7 +1040,8 @@ locale Finalise_AI_3 = Finalise_AI_2 a b
prepare_thread_delete t
\<lbrace>\<lambda>_ s. P (interrupt_irq_node s)\<rbrace>"
crunch irq_node[wp]: suspend, unbind_maybe_notification, unbind_notification "\<lambda>s. P (interrupt_irq_node s)"
crunches suspend, unbind_maybe_notification, unbind_notification
for irq_node[wp]: "\<lambda>s. P (interrupt_irq_node s)"
(wp: crunch_wps select_wp simp: crunch_simps)
crunch irq_node[wp]: deleting_irq_handler "\<lambda>s. P (interrupt_irq_node s)"

54
proof/invariant-abstract/IpcCancel_AI.thy
View File

@ -180,9 +180,23 @@ lemma fast_finalise_misc[wp]:
locale IpcCancel_AI =
fixes state_ext :: "('a::state_ext) itself"
assumes arch_post_cap_deletion_typ_at[wp]:
"\<And>P T p. \<lbrace>\<lambda>(s :: 'a state). P (typ_at T p s)\<rbrace> arch_post_cap_deletion acap \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
"\<And>P T p acap. \<lbrace>\<lambda>(s :: 'a state). P (typ_at T p s)\<rbrace> arch_post_cap_deletion acap \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
assumes arch_post_cap_deletion_idle_thread[wp]:
"\<And>P. \<lbrace>\<lambda>(s :: 'a state). P (idle_thread s)\<rbrace> arch_post_cap_deletion acap \<lbrace>\<lambda>rv s. P (idle_thread s)\<rbrace>"
"\<And>P acap. \<lbrace>\<lambda>(s :: 'a state). P (idle_thread s)\<rbrace> arch_post_cap_deletion acap \<lbrace>\<lambda>rv s. P (idle_thread s)\<rbrace>"
crunches update_restart_pc
for typ_at[wp]: "\<lambda>s. P (typ_at ty ptr s)"
(* NB: Q needed for following has_reply_cap proof *)
and cte_wp_at[wp]: "\<lambda>s. Q (cte_wp_at P cte s)"
and idle_thread[wp]: "\<lambda>s. P (idle_thread s)"
and pred_tcb_at[wp]: "\<lambda>s. pred_tcb_at P proj tcb s"
and invs[wp]: "\<lambda>s. invs s"
lemma update_restart_pc_has_reply_cap[wp]:
"\<lbrace>\<lambda>s. \<not> has_reply_cap t s\<rbrace> update_restart_pc t \<lbrace>\<lambda>_ s. \<not> has_reply_cap t s\<rbrace>"
apply (simp add: has_reply_cap_def)
apply (wp hoare_vcg_all_lift)
done
crunch st_tcb_at_simple[wp]: reply_cancel_ipc "st_tcb_at simple t"
(wp: crunch_wps select_wp sts_st_tcb_at_cases thread_set_no_change_tcb_state
@ -587,27 +601,24 @@ lemma (in delete_one_abs) cancel_ipc_no_reply_cap[wp]:
elim!: pred_tcb_weakenE)+
done
lemma (in delete_one_abs) suspend_invs[wp]:
"\<lbrace>invs and tcb_at t and (\<lambda>s. t \<noteq> idle_thread s)\<rbrace>
(suspend t :: (unit,'a) s_monad) \<lbrace>\<lambda>rv. invs\<rbrace>"
apply (simp add: suspend_def)
apply (wp sts_invs_minor cancel_ipc_invs cancel_ipc_no_reply_cap
| strengthen no_refs_simple_strg | simp)+
done
by (wp sts_invs_minor user_getreg_inv as_user_invs sts_invs_minor cancel_ipc_invs
cancel_ipc_no_reply_cap
| strengthen no_refs_simple_strg
| simp add: suspend_def)+
context IpcCancel_AI begin
lemma suspend_typ_at [wp]:
"\<lbrace>\<lambda>(s::'a state). P (typ_at T p s)\<rbrace> suspend t \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
by (simp add: suspend_def | wp)+
by (wpsimp simp: suspend_def)
lemma suspend_valid_cap:
"\<lbrace>valid_cap c\<rbrace> suspend tcb \<lbrace>\<lambda>_. (valid_cap c) :: 'a state \<Rightarrow> bool\<rbrace>"
by (wp valid_cap_typ)
lemma suspend_tcb[wp]:
"\<lbrace>tcb_at t'\<rbrace> suspend t \<lbrace>\<lambda>rv. (tcb_at t') :: 'a state \<Rightarrow> bool\<rbrace>"
by (simp add: tcb_at_typ) wp
@ -629,7 +640,6 @@ locale delete_one_pre =
"(\<And>cap. P cap \<Longrightarrow> \<not> can_fast_finalise cap) \<Longrightarrow>
\<lbrace>cte_wp_at P sl\<rbrace> (cap_delete_one sl' :: (unit,'a) s_monad) \<lbrace>\<lambda>rv. cte_wp_at P sl\<rbrace>"
lemma (in delete_one_pre) reply_cancel_ipc_cte_wp_at_preserved:
"(\<And>cap. P cap \<Longrightarrow> \<not> can_fast_finalise cap) \<Longrightarrow>
\<lbrace>cte_wp_at P p\<rbrace> (reply_cancel_ipc t :: (unit,'a) s_monad) \<lbrace>\<lambda>rv. cte_wp_at P p\<rbrace>"
@ -649,11 +659,10 @@ lemma (in delete_one_pre) cancel_ipc_cte_wp_at_preserved:
apply (wp reply_cancel_ipc_cte_wp_at_preserved | wpcw | simp)+
done
lemma (in delete_one_pre) suspend_cte_wp_at_preserved:
"(\<And>cap. P cap \<Longrightarrow> \<not> can_fast_finalise cap) \<Longrightarrow>
\<lbrace>cte_wp_at P p\<rbrace> (suspend tcb :: (unit,'a) s_monad) \<lbrace>\<lambda>_. cte_wp_at P p\<rbrace>"
by (simp add: suspend_def) (wpsimp wp: cancel_ipc_cte_wp_at_preserved)
by (simp add: suspend_def) (wpsimp wp: cancel_ipc_cte_wp_at_preserved)+
(* FIXME - eliminate *)
@ -758,17 +767,26 @@ lemma reply_cancel_ipc_bound_tcb_at[wp]:
crunch bound_tcb_at[wp]: cancel_ipc "bound_tcb_at P t"
(ignore: set_object thread_set wp: mapM_x_wp_inv)
context IpcCancel_AI begin
lemma suspend_unlive:
"\<lbrace>bound_tcb_at ((=) None) t and valid_mdb and valid_objs and tcb_at t \<rbrace>
"\<lbrace>\<lambda>(s::'a state).
(bound_tcb_at ((=) None) t and valid_mdb and valid_objs) s \<rbrace>
suspend t
\<lbrace>\<lambda>rv. obj_at (Not \<circ> live0) t\<rbrace>"
apply (simp add: suspend_def set_thread_state_def set_object_def get_object_def)
(* avoid creating two copies of obj_at *)
supply hoare_vcg_if_split[wp_split del] if_splits[split del]
apply (wp | simp only: obj_at_exst_update)+
apply (simp add: obj_at_def)
apply (rule_tac Q="\<lambda>_. bound_tcb_at ((=) None) t" in hoare_strengthen_post)
apply wp
apply (auto simp: pred_tcb_def2 dest: refs_of_live)
apply (simp add: obj_at_def)
apply (rule_tac Q="\<lambda>_. bound_tcb_at ((=) None) t" in hoare_strengthen_post)
supply hoare_vcg_if_split[wp_split]
apply wp
apply (auto simp: pred_tcb_def2)[1]
apply (simp flip: if_split)
apply wpsimp+
apply (simp add: pred_tcb_at_tcb_at)
done
end
definition bound_refs_of_tcb :: "'a state \<Rightarrow> machine_word \<Rightarrow> (machine_word \<times> reftype) set"
where

12
proof/invariant-abstract/Tcb_AI.thy
View File

@ -151,15 +151,15 @@ lemma restart_tcb[wp]:
"\<lbrace>tcb_at t'\<rbrace> Tcb_A.restart t \<lbrace>\<lambda>rv. tcb_at t'\<rbrace>"
by (wpsimp simp: tcb_at_typ wp: restart_typ_at)
lemmas suspend_tcb_at[wp] = tcb_at_typ_at [OF suspend_typ_at]
crunch ex_nonz_cap_to[wp]: update_restart_pc "ex_nonz_cap_to t"
lemma suspend_nonz_cap_to_tcb:
lemma suspend_nonz_cap_to_tcb[wp]:
"\<lbrace>\<lambda>s. ex_nonz_cap_to t s \<and> tcb_at t s \<and> valid_objs s\<rbrace>
suspend t'
\<lbrace>\<lambda>rv s. ex_nonz_cap_to t s\<rbrace>"
apply (simp add: suspend_def)
apply (wp cancel_ipc_ex_nonz_cap_to_tcb|simp)+
done
by (wp cancel_ipc_ex_nonz_cap_to_tcb | simp add: suspend_def)+
lemmas suspend_tcb_at[wp] = tcb_at_typ_at [OF suspend_typ_at]
lemma readreg_invs:
"\<lbrace>invs and tcb_at src and ex_nonz_cap_to src\<rbrace>
@ -182,7 +182,7 @@ lemma (in Tcb_AI_1) copyreg_invs:
\<lbrace>\<lambda>rv. invs\<rbrace>"
apply (wpsimp simp: if_apply_def2
wp: mapM_x_wp' suspend_nonz_cap_to_tcb static_imp_wp)
apply (clarsimp simp: invs_def valid_state_def valid_pspace_def
apply (clarsimp simp: invs_def valid_state_def valid_pspace_def suspend_def
dest!: idle_no_ex_cap)
done

2
proof/invariant-abstract/X64/ArchDetSchedSchedule_AI.thy
View File

@ -28,7 +28,7 @@ crunch weak_valid_sched_action [wp, DetSchedSchedule_AI_assms]:
switch_to_idle_thread, switch_to_thread, arch_get_sanitise_register_info, arch_post_modify_registers "weak_valid_sched_action"
(simp: crunch_simps ignore: )
crunch ct_not_in_q[wp]: set_vm_root "ct_not_in_q"
crunch ct_not_in_q[wp, DetSchedSchedule_AI_assms]: set_vm_root "ct_not_in_q"
(wp: crunch_wps simp: crunch_simps)
crunch ct_not_in_q'[wp]: set_vm_root "\<lambda>s. ct_not_in_q_2 (ready_queues s) (scheduler_action s) t"

19
proof/invariant-abstract/X64/ArchFinalise_AI.thy
View File

@ -513,12 +513,16 @@ lemma suspend_unlive':
"\<lbrace>bound_tcb_at ((=) None) t and valid_mdb and valid_objs and tcb_at t \<rbrace>
suspend t
\<lbrace>\<lambda>rv. obj_at (Not \<circ> live) t\<rbrace>"
apply (simp add: suspend_def set_thread_state_def)
apply (wpsimp wp: set_object_wp | simp only: obj_at_exst_update)+
apply (simp add: obj_at_def)
apply (rule_tac Q="\<lambda>_. bound_tcb_at ((=) None) t" in hoare_strengthen_post)
apply wp
apply (auto simp: pred_tcb_def2 live_def hyp_live_def dest: refs_of_live)
apply (simp add: suspend_def set_thread_state_def set_object_def get_object_def)
supply hoare_vcg_if_split[wp_split del] if_splits[split del]
apply (wp | simp only: obj_at_exst_update)+
apply (simp add: obj_at_def live_def hyp_live_def)
apply (rule_tac Q="\<lambda>_. bound_tcb_at ((=) None) t" in hoare_strengthen_post)
supply hoare_vcg_if_split[wp_split]
apply wp
apply (auto simp: pred_tcb_def2)[1]
apply (simp flip: if_split)
apply wpsimp+
done
crunch obj_at[wp]: fpu_thread_delete
@ -1256,6 +1260,9 @@ lemma (* finalise_cap_invs *)[Finalise_AI_asms]:
apply (auto dest: cte_wp_at_valid_objs_valid_cap)
done
crunch irq_node[wp, Finalise_AI_asms]: suspend "\<lambda>s. P (interrupt_irq_node s)"
(wp: crunch_wps select_wp simp: crunch_simps)
lemma (* finalise_cap_irq_node *)[Finalise_AI_asms]:
"\<lbrace>\<lambda>s. P (interrupt_irq_node s)\<rbrace> finalise_cap a b \<lbrace>\<lambda>_ s. P (interrupt_irq_node s)\<rbrace>"
apply (case_tac a,simp_all)

13
proof/invariant-abstract/X64/ArchInvariants_AI.thy
View File

@ -3346,8 +3346,21 @@ lemma asid_low_bits_of_mask_eq:
lemmas asid_low_bits_of_p2m1_eq =
asid_low_bits_of_mask_eq[simplified mask_2pm1]
lemma arch_tcb_context_absorbs[simp]:
"arch_tcb_context_set uc2 (arch_tcb_context_set uc1 a_tcb) \<equiv> arch_tcb_context_set uc2 a_tcb"
apply (simp add: arch_tcb_context_set_def)
done
lemma arch_tcb_context_get_set[simp]:
"arch_tcb_context_get (arch_tcb_context_set uc a_tcb) = uc"
apply (simp add: arch_tcb_context_get_def arch_tcb_context_set_def)
done
end
declare X64.arch_tcb_context_absorbs[simp]
declare X64.arch_tcb_context_get_set[simp]
setup {* Add_Locale_Code_Defs.setup "X64" *}
setup {* Add_Locale_Code_Defs.setup "X64_A" *}

5
proof/refine/ARM/CNodeInv_R.thy
View File

@ -637,9 +637,10 @@ lemma suspend_not_recursive_ctes:
suspend t
\<lbrace>\<lambda>rv s. P (not_recursive_ctes s)\<rbrace>"
apply (simp only: suspend_def not_recursive_ctes_def cteCaps_of_def)
unfolding updateRestartPC_def
apply (wp threadSet_ctes_of | simp add: unless_def del: o_apply)+
apply (fold cteCaps_of_def)
apply (wp cancelIPC_cteCaps_of)
apply (fold cteCaps_of_def)
apply (wp cancelIPC_cteCaps_of)
apply (clarsimp elim!: rsubst[where P=P] intro!: set_eqI)
apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def)
apply (auto simp: isCap_simps finaliseCap_def Let_def)

5
proof/refine/ARM/EmptyFail_H.thy
View File

@ -169,10 +169,7 @@ lemma ignoreFailure_empty_fail[intro!, wp, simp]:
crunch (empty_fail) empty_fail[intro!, wp, simp]: cancelIPC, setThreadState, tcbSchedDequeue, setupReplyMaster, isBlocked, possibleSwitchTo, tcbSchedAppend
(simp: Let_def)
crunch (empty_fail) "_H_empty_fail": "ThreadDecls_H.suspend"
lemma ThreadDecls_H_suspend_empty_fail[intro!, wp, simp]:
"empty_fail (ThreadDecls_H.suspend target)"
by (simp add:suspend_def)
crunch (empty_fail) "_H_empty_fail"[intro!, wp, simp]: "ThreadDecls_H.suspend"
lemma ThreadDecls_H_restart_empty_fail[intro!, wp, simp]:
"empty_fail (ThreadDecls_H.restart target)"

5
proof/refine/ARM/Finalise_R.thy
View File

@ -2840,10 +2840,11 @@ lemma suspend_cte_wp_at':
shows "\<lbrace>cte_wp_at' (\<lambda>cte. P (cteCap cte)) p\<rbrace>
suspend t
\<lbrace>\<lambda>rv. cte_wp_at' (\<lambda>cte. P (cteCap cte)) p\<rbrace>"
apply (simp add: suspend_def unless_def)
apply (simp add: suspend_def)
unfolding updateRestartPC_def
apply (rule hoare_pre)
apply (wp threadSet_cte_wp_at' cancelIPC_cte_wp_at'
| simp add: x)+
| simp add: x)+
done
context begin interpretation Arch . (*FIXME: arch_split*)

87
proof/refine/ARM/IpcCancel_R.thy
View File

@ -1392,16 +1392,56 @@ lemma valid_queues_inQ_queues:
by (force simp: Invariants_H.valid_queues_def valid_inQ_queues_def obj_at'_def
valid_queues_no_bitmap_def)
lemma asUser_tcbQueued_inv[wp]:
"\<lbrace>obj_at' (\<lambda>tcb. P (tcbQueued tcb)) t'\<rbrace> asUser t m \<lbrace>\<lambda>_. obj_at' (\<lambda>tcb. P (tcbQueued tcb)) t'\<rbrace>"
apply (simp add: asUser_def tcb_in_cur_domain'_def threadGet_def)
apply (wp threadSet_obj_at'_strongish getObject_tcb_wp | wpc | simp | clarsimp simp: obj_at'_def)+
done
lemma asUser_valid_inQ_queues[wp]:
"\<lbrace> valid_inQ_queues \<rbrace> asUser t f \<lbrace>\<lambda>rv. valid_inQ_queues \<rbrace>"
unfolding valid_inQ_queues_def Ball_def
apply (wpsimp wp: hoare_vcg_all_lift)
defer
apply (wp asUser_ksQ)
apply assumption
apply (simp add: inQ_def[abs_def] obj_at'_conj)
apply (rule hoare_convert_imp)
apply (wp asUser_ksQ)
apply wp
done
lemma (in delete_one) suspend_corres:
"corres dc (einvs and tcb_at t) (invs' and tcb_at' t)
(IpcCancel_A.suspend t) (ThreadDecls_H.suspend t)"
apply (simp add: IpcCancel_A.suspend_def Thread_H.suspend_def)
apply (rule corres_guard_imp)
apply (rule corres_split_nor [OF _ cancel_ipc_corres])
apply (rule corres_split_nor [OF _ sts_corres])
apply (rule tcbSchedDequeue_corres')
apply (rule corres_split [OF _ gts_corres])
apply (rule corres_split_nor)
apply (rule corres_split_nor [OF _ sts_corres])
apply (rule tcbSchedDequeue_corres')
apply wpsimp
apply wp
apply wpsimp
apply (rule corres_if)
apply (case_tac state; simp)
apply (simp add: update_restart_pc_def updateRestartPC_def)
apply (rule corres_as_user')
apply (simp add: ARM.nextInstructionRegister_def ARM.faultRegister_def
ARM_H.nextInstructionRegister_def ARM_H.faultRegister_def)
apply (simp add: ARM_H.Register_def)
apply (subst unit_dc_is_eq)
apply (rule corres_underlying_trivial)
apply (wpsimp simp: ARM.setRegister_def ARM.getRegister_def)
apply (rule corres_return_trivial)
apply (wpsimp simp: update_restart_pc_def updateRestartPC_def)+
apply (rule hoare_post_imp[where Q = "\<lambda>rv s. tcb_at t s \<and> is_etcb_at t s"])
apply simp
apply (wp | simp)+
apply wp
apply (rule hoare_post_imp[where Q = "\<lambda>rv s. tcb_at' t s \<and> valid_inQ_queues s"])
apply (wpsimp simp: valid_queues_inQ_queues)
apply wp+
apply (force simp: valid_sched_def tcb_at_is_etcb_at)
apply (clarsimp simp add: invs'_def valid_state'_def valid_queues_inQ_queues)
done
@ -1672,30 +1712,40 @@ lemmas sts_tcbSchedDequeue_invs' =
sts_invs_minor'_no_valid_queues
tcbSchedDequeue_invs'_no_valid_queues
lemma asUser_sch_act_simple[wp]:
"\<lbrace>sch_act_simple\<rbrace> asUser s t \<lbrace>\<lambda>_. sch_act_simple\<rbrace>"
unfolding sch_act_simple_def
apply (rule asUser_nosch)
done
lemma (in delete_one_conc) suspend_invs'[wp]:
"\<lbrace>invs' and sch_act_simple and tcb_at' t and (\<lambda>s. t \<noteq> ksIdleThread s)\<rbrace>
ThreadDecls_H.suspend t \<lbrace>\<lambda>rv. invs'\<rbrace>"
apply (simp add: suspend_def)
apply (wp_trace sts_tcbSchedDequeue_invs')
apply (simp | strengthen no_refs_simple_strg')+
apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift
cancelIPC_simple [simplified] cancelIPC_invs
cancelIPC_it cancelIPC_tcb_at' cancelIPC_sch_act_simple)
apply simp+
apply (simp add: updateRestartPC_def | strengthen no_refs_simple_strg')+
prefer 2
apply (wpsimp wp: hoare_drop_imps hoare_vcg_imp_lift'
| strengthen no_refs_simple_strg')+
done
lemma (in delete_one_conc_pre) suspend_tcb'[wp]:
"\<lbrace>tcb_at' t'\<rbrace> ThreadDecls_H.suspend t \<lbrace>\<lambda>rv. tcb_at' t'\<rbrace>"
apply (simp add: suspend_def unless_def)
apply (wp hoare_drop_imps |clarsimp|rule conjI)+
apply wp
apply (wpsimp simp: updateRestartPC_def)
apply (wp hoare_drop_imps |clarsimp|rule conjI)+
done
lemma (in delete_one_conc_pre) suspend_sch_act_simple[wp]:
"\<lbrace>sch_act_simple\<rbrace>
ThreadDecls_H.suspend t \<lbrace>\<lambda>rv. sch_act_simple\<rbrace>"
apply (simp add: suspend_def when_def)
apply (simp add: suspend_def when_def updateRestartPC_def)
apply (wp cancelIPC_sch_act_simple | simp add: unless_def
| rule sch_act_simple_lift)+
apply (simp add: updateRestartPC_def)
apply (rule asUser_nosch)
apply wpsimp+
done
lemma (in delete_one_conc) suspend_objs':
@ -1711,9 +1761,9 @@ lemma (in delete_one_conc_pre) suspend_st_tcb_at':
"\<lbrace>st_tcb_at' P t\<rbrace>
suspend thread
\<lbrace>\<lambda>rv. st_tcb_at' P t\<rbrace>"
apply (simp add: suspend_def unless_def)
unfolding suspend_def updateRestartPC_def
apply (wp sts_st_tcb_at'_cases threadSet_pred_tcb_no_state
cancelIPC_st_tcb_at hoare_drop_imps
cancelIPC_st_tcb_at hoare_drop_imps asUser_pred_tcb_at' x
| simp)+
apply clarsimp
done
@ -1819,8 +1869,9 @@ lemma (in delete_one_conc_pre) suspend_nonq:
\<lbrace>\<lambda>rv s. \<forall>d p. t' \<notin> set (ksReadyQueues s (d, p))\<rbrace>"
apply (rule hoare_gen_asm)
apply (simp add: suspend_def unless_def)
unfolding updateRestartPC_def
apply (wp hoare_allI tcbSchedDequeue_t_notksQ sts_ksQ_oaQ)
apply (clarsimp)
apply wpsimp+
done
lemma suspend_makes_inactive:
@ -2620,11 +2671,11 @@ lemma suspend_unqueued:
"\<lbrace>\<top>\<rbrace> suspend t \<lbrace>\<lambda>rv. obj_at' (Not \<circ> tcbQueued) t\<rbrace>"
apply (simp add: suspend_def unless_def tcbSchedDequeue_def)
apply (wp hoare_vcg_if_lift hoare_vcg_conj_lift hoare_vcg_imp_lift)
apply (simp add: threadGet_def| wp getObject_tcb_wp)+
apply (rule hoare_strengthen_post, rule hoare_post_taut)
apply (fastforce simp: obj_at'_def projectKOs)
apply (rule hoare_post_taut)
apply (rule TrueI)
apply (simp add: threadGet_def| wp getObject_tcb_wp)+
apply (rule hoare_strengthen_post, rule hoare_post_taut)
apply (fastforce simp: obj_at'_def projectKOs)
apply (rule hoare_post_taut)
apply wp+
done
crunch unqueued: prepareThreadDelete "obj_at' (Not \<circ> tcbQueued) t"

27
proof/refine/ARM/Orphanage.thy
View File

@ -1686,15 +1686,36 @@ lemma handleInterrupt_no_orphans [wp]:
handleReservedIRQ_def)+
done
lemma updateRestartPC_no_orphans[wp]:
"\<lbrace> \<lambda>s. no_orphans s \<and> invs' s \<rbrace>
updateRestartPC t
\<lbrace> \<lambda>rv s. no_orphans s \<rbrace>"
by (wpsimp simp: updateRestartPC_def asUser_no_orphans)
lemma updateRestartPC_valid_queues'[wp]:
"\<lbrace> \<lambda>s. valid_queues' s \<rbrace>
updateRestartPC t
\<lbrace> \<lambda>rv s. valid_queues' s \<rbrace>"
unfolding updateRestartPC_def
apply (rule asUser_valid_queues')
done
lemma updateRestartPC_no_orphans_invs'_valid_queues'[wp]:
"\<lbrace>\<lambda>s. no_orphans s \<and> invs' s \<and> valid_queues' s \<rbrace>
updateRestartPC t
\<lbrace>\<lambda>rv s. no_orphans s \<and> valid_queues' s \<rbrace>"
by (wpsimp simp: updateRestartPC_def asUser_no_orphans)
lemma suspend_no_orphans [wp]:
"\<lbrace> \<lambda>s. no_orphans s \<and> invs' s \<and> sch_act_simple s \<and> tcb_at' t s \<rbrace>
suspend t
\<lbrace> \<lambda>rv s. no_orphans s \<rbrace>"
unfolding suspend_def
apply (wp | clarsimp simp: unless_def | rule conjI)+
apply (clarsimp simp: is_active_tcb_ptr_def is_active_thread_state_def st_tcb_at_neg2)
apply (wp setThreadState_not_active_no_orphans hoare_disjI1 setThreadState_st_tcb
| clarsimp simp: is_active_thread_state_def isRunning_def isRestart_def)+
apply (clarsimp simp: is_active_tcb_ptr_def is_active_thread_state_def st_tcb_at_neg2)
apply (wp setThreadState_not_active_no_orphans hoare_disjI1 setThreadState_st_tcb
| clarsimp simp: is_active_thread_state_def isRunning_def isRestart_def)+
apply (wp hoare_drop_imp)+
apply auto
done

28
proof/refine/ARM/Tcb_R.thy
View File

@ -262,9 +262,15 @@ lemma restart_tcb'[wp]:
lemma no_fail_setRegister: "no_fail \<top> (setRegister r v)"
by (simp add: setRegister_def)
lemma updateRestartPC_ex_nonz_cap_to'[wp]:
"\<lbrace>ex_nonz_cap_to' p\<rbrace> updateRestartPC t \<lbrace>\<lambda>rv. ex_nonz_cap_to' p\<rbrace>"
unfolding updateRestartPC_def
apply (rule asUser_cap_to')
done
lemma suspend_cap_to'[wp]:
"\<lbrace>ex_nonz_cap_to' p\<rbrace> suspend t \<lbrace>\<lambda>rv. ex_nonz_cap_to' p\<rbrace>"
apply (simp add: suspend_def unless_def)
apply (simp add: suspend_def)
apply (wp threadSet_cap_to' | simp)+
done
@ -364,6 +370,26 @@ lemma writereg_corres:
crunch it[wp]: suspend "\<lambda>s. P (ksIdleThread s)"
lemma tcbSchedDequeue_ResumeCurrentThread_imp_notct[wp]:
"\<lbrace>\<lambda>s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>
tcbSchedDequeue t
\<lbrace>\<lambda>rv s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>"
by (wp hoare_convert_imp)
lemma updateRestartPC_ResumeCurrentThread_imp_notct[wp]:
"\<lbrace>\<lambda>s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>
updateRestartPC t
\<lbrace>\<lambda>rv s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>"
unfolding updateRestartPC_def
apply (wp hoare_convert_imp)
done
lemma suspend_ResumeCurrentThread_imp_notct[wp]:
"\<lbrace>\<lambda>s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>
suspend t
\<lbrace>\<lambda>rv s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>"
by (wpsimp simp: suspend_def)
lemma copyreg_corres:
"corres (intr \<oplus> (=))
(einvs and simple_sched_action and tcb_at dest and tcb_at src and ex_nonz_cap_to src and

1
proof/refine/ARM_HYP/CNodeInv_R.thy
View File

@ -641,6 +641,7 @@ lemma suspend_not_recursive_ctes:
suspend t
\<lbrace>\<lambda>rv s. P (not_recursive_ctes s)\<rbrace>"
apply (simp only: suspend_def not_recursive_ctes_def cteCaps_of_def)
unfolding updateRestartPC_def
apply (wp threadSet_ctes_of | simp add: unless_def del: o_apply)+
apply (fold cteCaps_of_def)
apply (wp cancelIPC_cteCaps_of)

5
proof/refine/ARM_HYP/EmptyFail_H.thy
View File

@ -173,10 +173,7 @@ lemma ignoreFailure_empty_fail[intro!, wp, simp]:
crunch (empty_fail) empty_fail[intro!, wp, simp]: cancelIPC, setThreadState, tcbSchedDequeue, setupReplyMaster, isBlocked, possibleSwitchTo, tcbSchedAppend
(simp: Let_def)
crunch (empty_fail) "_H_empty_fail": "ThreadDecls_H.suspend"
lemma ThreadDecls_H_suspend_empty_fail[intro!, wp, simp]:
"empty_fail (ThreadDecls_H.suspend target)"
by (simp add:suspend_def)
crunch (empty_fail) "_H_empty_fail"[intro!, wp, simp]: "ThreadDecls_H.suspend"
lemma ThreadDecls_H_restart_empty_fail[intro!, wp, simp]:
"empty_fail (ThreadDecls_H.restart target)"

5
proof/refine/ARM_HYP/Finalise_R.thy
View File

@ -3277,7 +3277,8 @@ lemma suspend_cte_wp_at':
shows "\<lbrace>cte_wp_at' (\<lambda>cte. P (cteCap cte)) p\<rbrace>
suspend t
\<lbrace>\<lambda>rv. cte_wp_at' (\<lambda>cte. P (cteCap cte)) p\<rbrace>"
apply (simp add: suspend_def unless_def)
apply (simp add: suspend_def)
unfolding updateRestartPC_def
apply (rule hoare_pre)
apply (wp threadSet_cte_wp_at' cancelIPC_cte_wp_at'
| simp add: x)+
@ -4042,9 +4043,11 @@ lemmas getCTE_no_0_obj'_helper
= getCTE_inv
hoare_strengthen_post[where Q="\<lambda>_. no_0_obj'" and P=no_0_obj' and a="getCTE slot" for slot]
context begin interpretation Arch . (*FIXME: arch_split*)
crunches ThreadDecls_H.suspend, unbindNotification
for no_0_obj'[wp]: no_0_obj'
(simp: crunch_simps wp: crunch_wps getCTE_no_0_obj'_helper)
end
lemma finalise_cap_corres:
"\<lbrakk> final_matters' cap' \<Longrightarrow> final = final'; cap_relation cap cap';

91
proof/refine/ARM_HYP/IpcCancel_R.thy
View File

@ -1403,16 +1403,56 @@ lemma valid_queues_inQ_queues:
by (force simp: Invariants_H.valid_queues_def valid_inQ_queues_def obj_at'_def
valid_queues_no_bitmap_def)
lemma asUser_tcbQueued_inv[wp]:
"\<lbrace>obj_at' (\<lambda>tcb. P (tcbQueued tcb)) t'\<rbrace> asUser t m \<lbrace>\<lambda>_. obj_at' (\<lambda>tcb. P (tcbQueued tcb)) t'\<rbrace>"
apply (simp add: asUser_def tcb_in_cur_domain'_def threadGet_def)
apply (wp threadSet_obj_at'_strongish getObject_tcb_wp | wpc | simp | clarsimp simp: obj_at'_def)+
done
lemma asUser_valid_inQ_queues[wp]:
"\<lbrace> valid_inQ_queues \<rbrace> asUser t f \<lbrace>\<lambda>rv. valid_inQ_queues \<rbrace>"
unfolding valid_inQ_queues_def Ball_def
apply (wpsimp wp: hoare_vcg_all_lift)
defer
apply (wp asUser_ksQ)
apply assumption
apply (simp add: inQ_def[abs_def] obj_at'_conj)
apply (rule hoare_convert_imp)
apply (wp asUser_ksQ)
apply wp
done
lemma (in delete_one) suspend_corres:
"corres dc (einvs and tcb_at t) (invs' and tcb_at' t)
(IpcCancel_A.suspend t) (ThreadDecls_H.suspend t)"
apply (simp add: IpcCancel_A.suspend_def Thread_H.suspend_def)
apply (rule corres_guard_imp)
apply (rule corres_split_nor [OF _ cancel_ipc_corres])
apply (rule corres_split_nor [OF _ sts_corres])
apply (rule tcbSchedDequeue_corres')
apply (rule corres_split [OF _ gts_corres])
apply (rule corres_split_nor)
apply (rule corres_split_nor [OF _ sts_corres])
apply (rule tcbSchedDequeue_corres')
apply wpsimp
apply wp
apply wpsimp
apply (rule corres_if)
apply (case_tac state; simp)
apply (simp add: update_restart_pc_def updateRestartPC_def)
apply (rule corres_as_user')
apply (simp add: ARM_HYP.nextInstructionRegister_def ARM_HYP.faultRegister_def
ARM_HYP_H.nextInstructionRegister_def ARM_HYP_H.faultRegister_def)
apply (simp add: ARM_HYP_H.Register_def)
apply (subst unit_dc_is_eq)
apply (rule corres_underlying_trivial)
apply (wpsimp simp: ARM_HYP.setRegister_def ARM_HYP.getRegister_def)
apply (rule corres_return_trivial)
apply (wpsimp simp: update_restart_pc_def updateRestartPC_def)+
apply (rule hoare_post_imp[where Q = "\<lambda>rv s. tcb_at t s \<and> is_etcb_at t s"])
apply simp
apply (wp | simp)+
apply wp
apply (rule hoare_post_imp[where Q = "\<lambda>rv s. tcb_at' t s \<and> valid_inQ_queues s"])
apply (wpsimp simp: valid_queues_inQ_queues)
apply wp+
apply (force simp: valid_sched_def tcb_at_is_etcb_at)
apply (clarsimp simp add: invs'_def valid_state'_def valid_queues_inQ_queues)
done
@ -1840,30 +1880,40 @@ lemmas sts_tcbSchedDequeue_invs' =
sts_invs_minor'_no_valid_queues
tcbSchedDequeue_invs'_no_valid_queues
lemma asUser_sch_act_simple[wp]:
"\<lbrace>sch_act_simple\<rbrace> asUser s t \<lbrace>\<lambda>_. sch_act_simple\<rbrace>"
unfolding sch_act_simple_def
apply (rule asUser_nosch)
done
lemma (in delete_one_conc) suspend_invs'[wp]:
"\<lbrace>invs' and sch_act_simple and tcb_at' t and (\<lambda>s. t \<noteq> ksIdleThread s)\<rbrace>
ThreadDecls_H.suspend t \<lbrace>\<lambda>rv. invs'\<rbrace>"
apply (simp add: suspend_def)
apply (wp sts_tcbSchedDequeue_invs')
apply (simp | strengthen no_refs_simple_strg')+
apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift
cancelIPC_simple [simplified] cancelIPC_invs
cancelIPC_it cancelIPC_tcb_at' cancelIPC_sch_act_simple)
apply simp+
apply (wp_trace sts_tcbSchedDequeue_invs')
apply (simp add: updateRestartPC_def | strengthen no_refs_simple_strg')+
prefer 2
apply (wpsimp wp: hoare_drop_imps hoare_vcg_imp_lift'
| strengthen no_refs_simple_strg')+
done
lemma (in delete_one_conc_pre) suspend_tcb'[wp]:
"\<lbrace>tcb_at' t'\<rbrace> ThreadDecls_H.suspend t \<lbrace>\<lambda>rv. tcb_at' t'\<rbrace>"
apply (simp add: suspend_def unless_def)
apply (wp hoare_drop_imps |clarsimp|rule conjI)+
apply (simp add: suspend_def)
apply wp
apply (wpsimp simp: updateRestartPC_def)
apply (wp hoare_drop_imps |clarsimp|rule conjI)+
done
lemma (in delete_one_conc_pre) suspend_sch_act_simple[wp]:
"\<lbrace>sch_act_simple\<rbrace>
ThreadDecls_H.suspend t \<lbrace>\<lambda>rv. sch_act_simple\<rbrace>"
apply (simp add: suspend_def when_def)
apply (simp add: suspend_def when_def updateRestartPC_def)
apply (wp cancelIPC_sch_act_simple | simp add: unless_def
| rule sch_act_simple_lift)+
apply (simp add: updateRestartPC_def)
apply (rule asUser_nosch)
apply wpsimp+
done
lemma (in delete_one_conc) suspend_objs':
@ -1879,9 +1929,9 @@ lemma (in delete_one_conc_pre) suspend_st_tcb_at':
"\<lbrace>st_tcb_at' P t\<rbrace>
suspend thread
\<lbrace>\<lambda>rv. st_tcb_at' P t\<rbrace>"
apply (simp add: suspend_def unless_def)
unfolding suspend_def updateRestartPC_def
apply (wp sts_st_tcb_at'_cases threadSet_pred_tcb_no_state
cancelIPC_st_tcb_at hoare_drop_imps
cancelIPC_st_tcb_at hoare_drop_imps asUser_pred_tcb_at' x
| simp)+
apply clarsimp
done
@ -1987,8 +2037,9 @@ lemma (in delete_one_conc_pre) suspend_nonq:
\<lbrace>\<lambda>rv s. \<forall>d p. t' \<notin> set (ksReadyQueues s (d, p))\<rbrace>"
apply (rule hoare_gen_asm)
apply (simp add: suspend_def unless_def)
unfolding updateRestartPC_def
apply (wp hoare_allI tcbSchedDequeue_t_notksQ sts_ksQ_oaQ)
apply (clarsimp)
apply wpsimp+
done
lemma suspend_makes_inactive:
@ -2797,11 +2848,11 @@ lemma suspend_unqueued:
"\<lbrace>\<top>\<rbrace> suspend t \<lbrace>\<lambda>rv. obj_at' (Not \<circ> tcbQueued) t\<rbrace>"
apply (simp add: suspend_def unless_def tcbSchedDequeue_def)
apply (wp hoare_vcg_if_lift hoare_vcg_conj_lift hoare_vcg_imp_lift)
apply (simp add: threadGet_def| wp getObject_tcb_wp)+
apply (rule hoare_strengthen_post, rule hoare_post_taut)
apply (fastforce simp: obj_at'_def projectKOs)
apply (rule hoare_post_taut)
apply (rule TrueI)
apply (simp add: threadGet_def| wp getObject_tcb_wp)+
apply (rule hoare_strengthen_post, rule hoare_post_taut)
apply (fastforce simp: obj_at'_def projectKOs)
apply (rule hoare_post_taut)
apply wp+
done
crunch no_vcpu[wp]: vcpuInvalidateActive "obj_at' (P::'a:: no_vcpu \<Rightarrow> bool) t"

22
proof/refine/ARM_HYP/Tcb_R.thy
View File

@ -259,9 +259,15 @@ lemma restart_tcb'[wp]:
apply wpsimp
done
lemma updateRestartPC_ex_nonz_cap_to'[wp]:
"\<lbrace>ex_nonz_cap_to' p\<rbrace> updateRestartPC t \<lbrace>\<lambda>rv. ex_nonz_cap_to' p\<rbrace>"
unfolding updateRestartPC_def
apply (rule asUser_cap_to')
done
lemma suspend_cap_to'[wp]:
"\<lbrace>ex_nonz_cap_to' p\<rbrace> suspend t \<lbrace>\<lambda>rv. ex_nonz_cap_to' p\<rbrace>"
apply (simp add: suspend_def unless_def)
apply (simp add: suspend_def)
apply (wp threadSet_cap_to' | simp)+
done
@ -368,6 +374,20 @@ lemma tcbSchedDequeue_ResumeCurrentThread_imp_notct[wp]:
\<lbrace>\<lambda>rv s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>"
by (wp hoare_convert_imp)
lemma updateRestartPC_ResumeCurrentThread_imp_notct[wp]:
"\<lbrace>\<lambda>s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>
updateRestartPC t
\<lbrace>\<lambda>rv s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>"
unfolding updateRestartPC_def
apply (wp hoare_convert_imp)
done
lemma suspend_ResumeCurrentThread_imp_notct[wp]:
"\<lbrace>\<lambda>s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>
suspend t
\<lbrace>\<lambda>rv s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>"
by (wpsimp simp: suspend_def)
lemma copyreg_corres:
"corres (intr \<oplus> (=))
(einvs and simple_sched_action and tcb_at dest and tcb_at src and ex_nonz_cap_to src and

6
proof/refine/X64/CNodeInv_R.thy
View File

@ -637,10 +637,10 @@ lemma suspend_not_recursive_ctes:
"\<lbrace>\<lambda>s. P (not_recursive_ctes s)\<rbrace>
suspend t
\<lbrace>\<lambda>rv s. P (not_recursive_ctes s)\<rbrace>"
apply (simp only: suspend_def not_recursive_ctes_def cteCaps_of_def)
apply (simp only: suspend_def not_recursive_ctes_def cteCaps_of_def updateRestartPC_def)
apply (wp threadSet_ctes_of | simp add: unless_def del: o_apply)+
apply (fold cteCaps_of_def)
apply (wp cancelIPC_cteCaps_of)
apply (fold cteCaps_of_def)
apply (wp cancelIPC_cteCaps_of)
apply (clarsimp elim!: rsubst[where P=P] intro!: set_eqI)
apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def)
apply (auto simp: isCap_simps finaliseCap_def Let_def)

5
proof/refine/X64/EmptyFail_H.thy
View File

@ -176,10 +176,7 @@ lemma ignoreFailure_empty_fail[intro!, wp, simp]:
crunch (empty_fail) empty_fail[intro!, wp, simp]: cancelIPC, setThreadState, tcbSchedDequeue, setupReplyMaster, isBlocked, possibleSwitchTo, tcbSchedAppend
(simp: Let_def)
crunch (empty_fail) "_H_empty_fail": "ThreadDecls_H.suspend"
lemma ThreadDecls_H_suspend_empty_fail[intro!, wp, simp]:
"empty_fail (ThreadDecls_H.suspend target)"
by (simp add:suspend_def)
crunch (empty_fail) "_H_empty_fail"[intro!, wp, simp]: "ThreadDecls_H.suspend"
lemma ThreadDecls_H_restart_empty_fail[intro!, wp, simp]:
"empty_fail (ThreadDecls_H.restart target)"

2
proof/refine/X64/Finalise_R.thy
View File

@ -3033,7 +3033,7 @@ lemma suspend_cte_wp_at':
shows "\<lbrace>cte_wp_at' (\<lambda>cte. P (cteCap cte)) p\<rbrace>
suspend t
\<lbrace>\<lambda>rv. cte_wp_at' (\<lambda>cte. P (cteCap cte)) p\<rbrace>"
apply (simp add: suspend_def unless_def)
apply (simp add: suspend_def updateRestartPC_def)
apply (rule hoare_pre)
apply (wp threadSet_cte_wp_at' cancelIPC_cte_wp_at'
| simp add: x)+

78
proof/refine/X64/IpcCancel_R.thy
View File

@ -1390,16 +1390,56 @@ lemma valid_queues_inQ_queues:
by (force simp: Invariants_H.valid_queues_def valid_inQ_queues_def obj_at'_def
valid_queues_no_bitmap_def)
lemma asUser_tcbQueued_inv[wp]:
"\<lbrace>obj_at' (\<lambda>tcb. P (tcbQueued tcb)) t'\<rbrace> asUser t m \<lbrace>\<lambda>_. obj_at' (\<lambda>tcb. P (tcbQueued tcb)) t'\<rbrace>"
apply (simp add: asUser_def tcb_in_cur_domain'_def threadGet_def)
apply (wp threadSet_obj_at'_strongish getObject_tcb_wp | wpc | simp | clarsimp simp: obj_at'_def)+
done
lemma asUser_valid_inQ_queues[wp]:
"\<lbrace>valid_inQ_queues\<rbrace> asUser t f \<lbrace>\<lambda>rv. valid_inQ_queues\<rbrace>"
unfolding valid_inQ_queues_def Ball_def
apply (wpsimp wp: hoare_vcg_all_lift)
defer
apply (wp asUser_ksQ)
apply assumption
apply (simp add: inQ_def[abs_def] obj_at'_conj)
apply (rule hoare_convert_imp)
apply (wp asUser_ksQ)
apply wp
done
lemma (in delete_one) suspend_corres:
"corres dc (einvs and tcb_at t) (invs' and tcb_at' t)
(IpcCancel_A.suspend t) (ThreadDecls_H.suspend t)"
apply (simp add: IpcCancel_A.suspend_def Thread_H.suspend_def)
apply (rule corres_guard_imp)
apply (rule corres_split_nor [OF _ cancel_ipc_corres])
apply (rule corres_split_nor [OF _ sts_corres])
apply (rule tcbSchedDequeue_corres')
apply (rule corres_split [OF _ gts_corres])
apply (rule corres_split_nor)
apply (rule corres_split_nor [OF _ sts_corres])
apply (rule tcbSchedDequeue_corres')
apply wpsimp
apply wp
apply wpsimp
apply (rule corres_if)
apply (case_tac state; simp)
apply (simp add: update_restart_pc_def updateRestartPC_def)
apply (rule corres_as_user')
apply (simp add: X64.nextInstructionRegister_def X64.faultRegister_def
X64_H.nextInstructionRegister_def X64_H.faultRegister_def)
apply (simp add: X64_H.Register_def)
apply (subst unit_dc_is_eq)
apply (rule corres_underlying_trivial)
apply (wpsimp simp: X64.setRegister_def X64.getRegister_def)
apply (rule corres_return_trivial)
apply (wpsimp simp: update_restart_pc_def updateRestartPC_def)+
apply (rule hoare_post_imp[where Q = "\<lambda>rv s. tcb_at t s \<and> is_etcb_at t s"])
apply simp
apply (wp | simp)+
apply (rule hoare_post_imp[where Q = "\<lambda>rv s. tcb_at' t s \<and> valid_inQ_queues s"])
apply (wpsimp simp: valid_queues_inQ_queues)
apply wp+
apply (force simp: valid_sched_def tcb_at_is_etcb_at)
apply (clarsimp simp add: invs'_def valid_state'_def valid_queues_inQ_queues)
done
@ -1715,30 +1755,38 @@ lemmas sts_tcbSchedDequeue_invs' =
sts_invs_minor'_no_valid_queues
tcbSchedDequeue_invs'_no_valid_queues
lemma asUser_sch_act_simple[wp]:
"\<lbrace>sch_act_simple\<rbrace> asUser s t \<lbrace>\<lambda>_. sch_act_simple\<rbrace>"
unfolding sch_act_simple_def
apply (rule asUser_nosch)
done
lemma (in delete_one_conc) suspend_invs'[wp]:
"\<lbrace>invs' and sch_act_simple and tcb_at' t and (\<lambda>s. t \<noteq> ksIdleThread s)\<rbrace>
ThreadDecls_H.suspend t \<lbrace>\<lambda>rv. invs'\<rbrace>"
apply (simp add: suspend_def)
apply (wp_trace sts_tcbSchedDequeue_invs')
apply (simp | strengthen no_refs_simple_strg')+
apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift
cancelIPC_simple [simplified] cancelIPC_invs
cancelIPC_it cancelIPC_tcb_at' cancelIPC_sch_act_simple)
apply simp+
apply (simp add: updateRestartPC_def | strengthen no_refs_simple_strg')+
prefer 2
apply (wpsimp wp: hoare_drop_imps hoare_vcg_imp_lift'
| strengthen no_refs_simple_strg')+
done
lemma (in delete_one_conc_pre) suspend_tcb'[wp]:
"\<lbrace>tcb_at' t'\<rbrace> ThreadDecls_H.suspend t \<lbrace>\<lambda>rv. tcb_at' t'\<rbrace>"
apply (simp add: suspend_def unless_def)
apply (wp hoare_drop_imps |clarsimp|rule conjI)+
apply (simp add: suspend_def)
apply (wpsimp simp: updateRestartPC_def)
done
lemma (in delete_one_conc_pre) suspend_sch_act_simple[wp]:
"\<lbrace>sch_act_simple\<rbrace>
ThreadDecls_H.suspend t \<lbrace>\<lambda>rv. sch_act_simple\<rbrace>"
apply (simp add: suspend_def when_def)
apply (simp add: suspend_def when_def updateRestartPC_def)
apply (wp cancelIPC_sch_act_simple | simp add: unless_def
| rule sch_act_simple_lift)+
apply (simp add: updateRestartPC_def)
apply (rule asUser_nosch)
apply wpsimp+
done
lemma (in delete_one_conc) suspend_objs':
@ -1754,7 +1802,8 @@ lemma (in delete_one_conc_pre) suspend_st_tcb_at':
"\<lbrace>st_tcb_at' P t\<rbrace>
suspend thread
\<lbrace>\<lambda>rv. st_tcb_at' P t\<rbrace>"
apply (simp add: suspend_def unless_def)
apply (simp add: suspend_def)
unfolding updateRestartPC_def
apply (wp sts_st_tcb_at'_cases threadSet_pred_tcb_no_state
cancelIPC_st_tcb_at hoare_drop_imps
| simp)+
@ -1861,9 +1910,10 @@ lemma (in delete_one_conc_pre) suspend_nonq:
suspend t
\<lbrace>\<lambda>rv s. \<forall>d p. t' \<notin> set (ksReadyQueues s (d, p))\<rbrace>"
apply (rule hoare_gen_asm)
apply (simp add: suspend_def unless_def)
apply (simp add: suspend_def)
unfolding updateRestartPC_def
apply (wp hoare_allI tcbSchedDequeue_t_notksQ sts_ksQ_oaQ)
apply (clarsimp)
apply wpsimp+
done
lemma suspend_makes_inactive:
@ -2676,7 +2726,7 @@ lemma suspend_unqueued:
apply (rule hoare_strengthen_post, rule hoare_post_taut)
apply (fastforce simp: obj_at'_def projectKOs)
apply (rule hoare_post_taut)
apply (rule TrueI)
apply wp+
done
crunch unqueued: prepareThreadDelete "obj_at' (\<lambda>a. \<not> tcbQueued a) t"

17
proof/refine/X64/Tcb_R.thy
View File

@ -264,7 +264,8 @@ lemma no_fail_setRegister: "no_fail \<top> (setRegister r v)"
lemma suspend_cap_to'[wp]:
"\<lbrace>ex_nonz_cap_to' p\<rbrace> suspend t \<lbrace>\<lambda>rv. ex_nonz_cap_to' p\<rbrace>"
apply (simp add: suspend_def unless_def)
apply (simp add: suspend_def)
unfolding updateRestartPC_def
apply (wp threadSet_cap_to' | simp)+
done
@ -377,6 +378,20 @@ lemma tcbSchedDequeue_ResumeCurrentThread_imp_notct[wp]:
\<lbrace>\<lambda>rv s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>"
by (wp hoare_convert_imp)
lemma updateRestartPC_ResumeCurrentThread_imp_notct[wp]:
"\<lbrace>\<lambda>s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>
updateRestartPC t
\<lbrace>\<lambda>rv s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>"
unfolding updateRestartPC_def
apply (wp hoare_convert_imp)
done
lemma suspend_ResumeCurrentThread_imp_notct[wp]:
"\<lbrace>\<lambda>s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>
suspend t
\<lbrace>\<lambda>rv s. ksSchedulerAction s = ResumeCurrentThread \<longrightarrow> ksCurThread s \<noteq> t'\<rbrace>"
by (wpsimp simp: suspend_def)
lemma copyreg_corres:
"corres (intr \<oplus> (=))
(einvs and simple_sched_action and tcb_at dest and tcb_at src and ex_nonz_cap_to src and

13
spec/abstract/IpcCancel_A.thy
View File

@ -25,6 +25,8 @@ requalify_consts
arch_post_cap_deletion
arch_gen_obj_refs
arch_cap_cleanup_opt
faultRegister
nextInstructionRegister
requalify_types
arch_gen_obj_ref
@ -358,6 +360,15 @@ where
| _ \<Rightarrow> return ()
od"
text {* Currently, @{text update_restart_pc} can be defined generically up to
the actual register numbers. *}
definition
update_restart_pc :: "obj_ref \<Rightarrow> (unit, 'z::state_ext) s_monad"
where
"update_restart_pc thread_ptr =
as_user thread_ptr (getRegister nextInstructionRegister
>>= setRegister faultRegister)"
text {* Suspend a thread, cancelling any pending operations and preventing it
from further execution by setting it to the Inactive state. *}
definition
@ -365,6 +376,8 @@ definition
where
"suspend thread \<equiv> do
cancel_ipc thread;
state \<leftarrow> get_thread_state thread;
(if state = Running then update_restart_pc thread else return ());
set_thread_state thread Inactive;
do_extended_op (tcb_sched_action (tcb_sched_dequeue) thread)
od"

4
spec/abstract/RISCV64/ArchVSpace_A.thy
View File

@ -73,8 +73,8 @@ fun handle_vm_fault :: "obj_ref \<Rightarrow> vmfault_type \<Rightarrow> (unit,'
storef = (\<lambda>a. throwError $ ArchFault $ VMFault a [0, vmFaultTypeFSR RISCVStoreAccessFault]);
instrf = (\<lambda>a. throwError $ ArchFault $ VMFault a [1, vmFaultTypeFSR RISCVInstructionAccessFault]);
set_pc = do
sepc \<leftarrow> as_user thread $ getRegister SEPC;
as_user thread $ setRegister NEXTPC sepc
faultip \<leftarrow> as_user thread $ getRegister FaultIP;
as_user thread $ setRegister NextIP faultip
od
in
case fault_type of

2
spec/design/skel/Thread_H.thy
View File

@ -42,6 +42,8 @@ context begin interpretation Arch .
requalify_consts
capRegister
faultRegister
nextInstructionRegister
end

7
spec/haskell/src/SEL4/Kernel/Thread.lhs
View File

@ -120,9 +120,16 @@ Note that the idle thread is not considered runnable; this is to prevent it bein
When a thread is suspended, either explicitly by a TCB invocation or implicitly when it is being destroyed, any operation that it is currently performing must be cancelled.
> updateRestartPC :: PPtr TCB -> Kernel ()
> updateRestartPC tcb =
> asUser tcb (getRegister nextInstructionRegister
> >>= setRegister faultRegister)
> suspend :: PPtr TCB -> Kernel ()
> suspend target = do
> cancelIPC target
> state <- getThreadState target
> if state == Running then updateRestartPC target else return ()
> setThreadState Inactive target
> tcbSchedDequeue target

2
spec/haskell/src/SEL4/Kernel/Thread/ARM.lhs
View File

@ -47,7 +47,7 @@ The ARM idle thread runs in system mode with interrupts enabled, with the PC poi
> configureIdleThread tcb = do
> doKernelOp $ asUser tcb $ do
> setRegister (Register CPSR) 0x1f
> setRegister (Register LR_svc) $ fromVPtr idleThreadStart
> setRegister (Register NextIP) $ fromVPtr idleThreadStart
When switching to the idle thread, we ensure that it runs in the address space of the kernel to prevent the possibility of a user-level address space being deleted whilst the idle thread is running (which is possible in a multi-core scenario).

4
spec/haskell/src/SEL4/Kernel/VSpace/RISCV64.hs
View File

@ -182,8 +182,8 @@ handleVMFault thread f = do
storef a = ArchFault $ VMFault a [0, vmFaultTypeFSR RISCVStoreAccessFault]
instrf a = ArchFault $ VMFault a [1, vmFaultTypeFSR RISCVInstructionAccessFault]
setPC = do
sepc <- asUser thread $ getRegister (Register SEPC)
asUser thread $ setRegister (Register NEXTPC) sepc
faultip <- asUser thread $ getRegister (Register FaultIP)
asUser thread $ setRegister (Register NextIP) faultip
{- Unmapping and Deletion -}

4
spec/haskell/src/SEL4/Machine/Hardware/ARM.lhs
View File

@ -182,8 +182,8 @@ The following functions define the ARM-specific interface between the kernel and
> debugPrint :: String -> MachineMonad ()
> debugPrint str = liftIO $ putStrLn str
> getRestartPC = getRegister (Register ARM.FaultInstruction)
> setNextPC = setRegister (Register ARM.LR_svc)
> getRestartPC = getRegister (Register ARM.FaultIP)
> setNextPC = setRegister (Register ARM.NextIP)
\subsection{ARM Memory Management}

4
spec/haskell/src/SEL4/Machine/Hardware/RISCV64.hs
View File

@ -132,8 +132,8 @@ resetTimer = do
cbptr <- ask
liftIO $ Platform.resetTimer cbptr
getRestartPC = getRegister (Register RISCV64.SEPC)
setNextPC = setRegister (Register RISCV64.NEXTPC)
getRestartPC = getRegister (Register RISCV64.FaultIP)
setNextPC = setRegister (Register RISCV64.NextIP)
{- Memory Management -}

10
spec/haskell/src/SEL4/Machine/RegisterSet.lhs
View File

@ -136,6 +136,16 @@ This list may be empty, though it should contain as many registers as possible.
> tlsBaseRegister :: Register
> tlsBaseRegister = Register Arch.tlsBaseRegister
\item[The fault register] holds the instruction which was being executed when the fault occured.
> faultRegister :: Register
> faultRegister = Register Arch.faultRegister
\item[The next instruction register] holds the instruction that will be executed upon resumption.
> nextInstructionRegister :: Register
> nextInstructionRegister = Register Arch.nextInstructionRegister
\end{description}

12
spec/haskell/src/SEL4/Machine/RegisterSet/ARM.lhs
View File

@ -30,7 +30,7 @@ This module defines the ARM register set.
> data Register =
> R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 | SL | FP | IP | SP |
> LR | LR_svc | FaultInstruction | CPSR | TLS_BASE | TPIDRURW
> LR | NextIP | FaultIP | CPSR | TLS_BASE | TPIDRURW
> deriving (Eq, Enum, Bounded, Ord, Ix, Show)
> type Word = Data.Word.Word32
@ -39,14 +39,16 @@ This module defines the ARM register set.
> msgInfoRegister = R1
> msgRegisters = [R2 .. R5]
> badgeRegister = R0
> frameRegisters = FaultInstruction : SP : CPSR : [R0, R1] ++ [R8 .. IP]
> faultRegister = FaultIP
> nextInstructionRegister = NextIP
> frameRegisters = FaultIP : SP : CPSR : [R0, R1] ++ [R8 .. IP]
> gpRegisters = [R2, R3, R4, R5, R6, R7, LR]
> exceptionMessage = [FaultInstruction, SP, CPSR]
> syscallMessage = [R0 .. R7] ++ [FaultInstruction, SP, LR, CPSR]
> exceptionMessage = [FaultIP, SP, CPSR]
> syscallMessage = [R0 .. R7] ++ [FaultIP, SP, LR, CPSR]
> tlsBaseRegister = TLS_BASE
#ifdef CONFIG_ARM_HYPERVISOR_SUPPORT
> elr_hyp = LR_svc
> elr_hyp = NextIP
\subsection{VCPU-saved Registers}

14
spec/haskell/src/SEL4/Machine/RegisterSet/RISCV64.hs
View File

@ -25,7 +25,7 @@ data Register
| A0 | A1 | A2 | A3 | A4 | A5 | A6 | A7
| S2 | S3 | S4 | S5 | S6 | S7 | S8 | S9 | S10 | S11
| T3 | T4 | T5 | T6
| SCAUSE | SSTATUS | SEPC | NEXTPC
| SCAUSE | SSTATUS | FaultIP | NextIP
deriving (Eq, Enum, Bounded, Ord, Ix, Show)
type Word = Data.Word.Word64
@ -43,16 +43,16 @@ badgeRegister :: Register
badgeRegister = A0
frameRegisters :: [Register]
frameRegisters = SEPC : [LR .. A6]
frameRegisters = FaultIP : [LR .. A6]
gpRegisters :: [Register]
gpRegisters = []
exceptionMessage :: [Register]
exceptionMessage = [SEPC, SP, A7]
exceptionMessage = [FaultIP, SP, A7]
syscallMessage :: [Register]
syscallMessage = SEPC : SP : LR : [A0 .. A6]
syscallMessage = FaultIP : SP : LR : [A0 .. A6]
tlsBaseRegister :: Register
tlsBaseRegister = TP -- note: used for IPC buffer until TLS is used
@ -63,6 +63,12 @@ sstatusSPIE = 0x20
initContext :: [(Register, Word)]
initContext = [ (SSTATUS , sstatusSPIE) ]
faultRegister :: Register
faultRegister = FaultIP
nextInstructionRegister :: Register
nextInstructionRegister = NextIP
{- User-level Context -}
-- On RISC-V the representation of the user-level context of a thread is an array

2
spec/haskell/src/SEL4/Machine/RegisterSet/X64.lhs
View File

@ -39,6 +39,8 @@ This module defines the x86 64-bit register set.
> msgInfoRegister = RSI
> msgRegisters = [R10, R8, R9, R15]
> badgeRegister = capRegister
> faultRegister = FaultIP
> nextInstructionRegister = NextIP
> frameRegisters = FaultIP : RSP : FLAGS : [RAX .. R15]
> gpRegisters = [TLS_BASE]
> exceptionMessage = [FaultIP, RSP, FLAGS]

6
spec/haskell/src/Simulation/FFIBindings.hs
View File

@ -238,8 +238,8 @@ seL4SaveContext breakFlag errorFlag errorString
asUser thread $ do
zipWithM_ setRegister [Register R.R0 .. Register R.LR] regs
setRegister (Register R.CPSR) cpsr
setRegister (Register R.LR_svc) lr
setRegister (Register R.FaultInstruction) fault
setRegister (Register R.NextIP) lr
setRegister (Register R.FaultIP) fault
---- seL4RestoreContext ----
-- Restore the CPU exception context from the current thread's TCB. This
@ -260,7 +260,7 @@ seL4RestoreContext breakFlag errorFlag errorString
regs <- asUser thread $
mapM getRegister [Register R.R0 .. Register R.LR]
cpsr <- asUser thread $ getRegister $ Register R.CPSR
lr <- asUser thread $ getRegister $ Register R.LR_svc
lr <- asUser thread $ getRegister $ Register R.NextIP
return (regs, cpsr, lr)
zipWithM_ (pokeElemOff regptr) [0,1..] regs
poke cpsrptr cpsr

4
spec/machine/ARM/MachineOps.thy
View File

@ -514,10 +514,10 @@ where
"setRegister r v \<equiv> modify (\<lambda>uc. uc (r := v))"
definition
"getRestartPC \<equiv> getRegister FaultInstruction"
"getRestartPC \<equiv> getRegister FaultIP"
definition
"setNextPC \<equiv> setRegister LR_svc"
"setNextPC \<equiv> setRegister NextIP"
end

4
spec/machine/ARM_HYP/MachineOps.thy
View File

@ -689,10 +689,10 @@ where
"setRegister r v \<equiv> modify (\<lambda>uc. uc (r := v))"
definition
"getRestartPC \<equiv> getRegister FaultInstruction"
"getRestartPC \<equiv> getRegister FaultIP"
definition
"setNextPC \<equiv> setRegister LR_svc"
"setNextPC \<equiv> setRegister NextIP"
end

4
spec/machine/RISCV64/MachineOps.thy
View File

@ -192,11 +192,11 @@ definition setRegister :: "register \<Rightarrow> machine_word \<Rightarrow> uni
definition getRestartPC :: "machine_word user_monad"
where
"getRestartPC \<equiv> getRegister SEPC"
"getRestartPC \<equiv> getRegister FaultIP"
definition setNextPC :: "machine_word \<Rightarrow> unit user_monad"
where
"setNextPC \<equiv> setRegister NEXTPC"
"setNextPC \<equiv> setRegister NextIP"
subsection "Caches, Barriers, and Flushing"