1037 lines
49 KiB
Plaintext
1037 lines
49 KiB
Plaintext
(*
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
|
*
|
|
* SPDX-License-Identifier: GPL-2.0-only
|
|
*)
|
|
|
|
theory Syscall_IF
|
|
imports
|
|
"ArchPasUpdates" (*Only needed for idle thread stuff*)
|
|
"ArchTcb_IF"
|
|
"ArchInterrupt_IF"
|
|
"ArchDecode_IF"
|
|
begin
|
|
|
|
definition authorised_for_globals_inv :: "invocation \<Rightarrow> ('z::state_ext) state \<Rightarrow> bool" where
|
|
"authorised_for_globals_inv oper \<equiv>
|
|
\<lambda>s. case oper of InvokeArchObject ai \<Rightarrow> authorised_for_globals_arch_inv ai s | _ \<Rightarrow> True"
|
|
|
|
definition authorised_invocation_extra where
|
|
"authorised_invocation_extra aag invo \<equiv>
|
|
case invo of InvokeTCB ti \<Rightarrow> authorised_tcb_inv_extra aag ti | _ \<Rightarrow> True"
|
|
|
|
|
|
lemma tcb_context_merge[simp]:
|
|
"arch_tcb_context_get (tcb_arch (tcb_registers_caps_merge tcb tcb')) =
|
|
arch_tcb_context_get (tcb_arch tcb)"
|
|
by (simp add: tcb_registers_caps_merge_def)
|
|
|
|
crunch_ignore (add: OR_choice set_scheduler_action)
|
|
|
|
crunch valid_global_objs[wp]: cap_move valid_global_objs
|
|
(wp: cap_move_ext.valid_global_objs dxo_wp_weak)
|
|
|
|
|
|
locale Syscall_IF_1 =
|
|
fixes aag :: "'a subject_label PAS"
|
|
assumes globals_equiv_irq_state_update[simp]:
|
|
"\<And>f. globals_equiv st (s\<lparr>machine_state :=
|
|
machine_state s\<lparr>irq_state := f (irq_state (machine_state s))\<rparr>\<rparr>) =
|
|
globals_equiv st s"
|
|
and thread_set_globals_equiv':
|
|
"\<And>f. \<lbrace>globals_equiv s and valid_arch_state and (\<lambda>s. tptr \<noteq> idle_thread s)\<rbrace>
|
|
thread_set f tptr
|
|
\<lbrace>\<lambda>_. globals_equiv s\<rbrace>"
|
|
and sts_authorised_for_globals_inv:
|
|
"\<And>f. set_thread_state d f \<lbrace>\<lambda>s :: det_state. authorised_for_globals_inv oper s\<rbrace>"
|
|
and dmo_maskInterrupt_globals_equiv[wp]:
|
|
"do_machine_op (maskInterrupt b irq) \<lbrace>globals_equiv s\<rbrace>"
|
|
and dmo_ackInterrupt_globals_equiv[wp]:
|
|
"do_machine_op (ackInterrupt irq) \<lbrace>globals_equiv s\<rbrace>"
|
|
and dmo_resetTimer_globals_equiv[wp]:
|
|
"do_machine_op resetTimer \<lbrace>globals_equiv s\<rbrace>"
|
|
and arch_mask_irq_signal_globals_equiv[wp]:
|
|
"arch_mask_irq_signal irq \<lbrace>globals_equiv st\<rbrace>"
|
|
and handle_reserved_irq_globals_equiv[wp]:
|
|
"handle_reserved_irq irq \<lbrace>globals_equiv st\<rbrace>"
|
|
and handle_vm_fault_reads_respects:
|
|
"reads_respects aag l (K (is_subject aag thread)) (handle_vm_fault thread vmfault_type)"
|
|
and handle_hypervisor_fault_reads_respects:
|
|
"reads_respects aag l \<top> (handle_hypervisor_fault thread hypfault_type)"
|
|
and handle_vm_fault_globals_equiv:
|
|
"\<lbrace>globals_equiv st and valid_arch_state and (\<lambda>s. thread \<noteq> idle_thread s)\<rbrace>
|
|
handle_vm_fault thread vmfault_type
|
|
\<lbrace>\<lambda>_. globals_equiv st\<rbrace>"
|
|
and handle_hypervisor_fault_globals_equiv:
|
|
"handle_hypervisor_fault thread hypfault_type \<lbrace>globals_equiv st\<rbrace>"
|
|
and arch_activate_idle_thread_globals_equiv[wp]:
|
|
"arch_activate_idle_thread t \<lbrace>globals_equiv st\<rbrace>"
|
|
and select_f_setNextPC_reads_respects[wp]:
|
|
"reads_respects aag l \<top> (select_f (setNextPC pc f))"
|
|
and select_f_getRestartPC_reads_respects[wp]:
|
|
"reads_respects aag l \<top> (select_f (getRestartPC f))"
|
|
and arch_activate_idle_thread_reads_respects[wp]:
|
|
"reads_respects aag l \<top> (arch_activate_idle_thread t)"
|
|
and decode_arch_invocation_authorised_for_globals:
|
|
"\<lbrace>invs and cte_wp_at ((=) (ArchObjectCap acap)) slot
|
|
and (\<lambda>s :: det_state. \<forall>(cap, slot) \<in> set excaps. cte_wp_at ((=) cap) slot s)\<rbrace>
|
|
arch_decode_invocation label msg x_slot slot acap excaps
|
|
\<lbrace>\<lambda>rv. authorised_for_globals_arch_inv rv\<rbrace>, -"
|
|
begin
|
|
|
|
lemma cap_revoke_globals_equiv:
|
|
"\<lbrace>globals_equiv st and invs\<rbrace>
|
|
cap_revoke slot
|
|
\<lbrace>\<lambda>_. globals_equiv st\<rbrace>"
|
|
apply (rule hoare_strengthen_post, rule validE_valid,
|
|
rule cap_revoke_preservation_desc_of[where Q="\<lambda>_. emptyable"])
|
|
by (wp cap_delete_globals_equiv preemption_point_inv
|
|
| fastforce simp: emptyable_def dest: reply_slot_not_descendant)+
|
|
|
|
lemma invoke_cnode_globals_equiv:
|
|
"\<lbrace>globals_equiv st and invs and valid_cnode_inv cinv\<rbrace>
|
|
invoke_cnode cinv
|
|
\<lbrace>\<lambda>_. globals_equiv st\<rbrace>"
|
|
unfolding invoke_cnode_def without_preemption_def fun_app_def
|
|
apply (wp cap_insert_globals_equiv cap_move_globals_equiv cap_revoke_globals_equiv
|
|
cap_delete_globals_equiv cap_swap_globals_equiv hoare_vcg_all_lift
|
|
cancel_badged_sends_globals_equiv
|
|
| wpc | wp (once) hoare_drop_imps | simp add: invs_valid_global_objs)+
|
|
apply (case_tac cinv; clarsimp simp: real_cte_emptyable_strg)
|
|
done
|
|
|
|
end
|
|
|
|
|
|
(* The contents of the delete_confidentiality locale *)
|
|
|
|
lemma cap_delete_reads_respects_f:
|
|
assumes domains_distinct[wp]: "pas_domains_distinct aag"
|
|
shows "reads_respects_f aag l
|
|
(silc_inv aag st and only_timer_irq_inv irq st' and einvs and simple_sched_action
|
|
and emptyable slot and pas_refined aag and cdt_change_allowed' aag slot)
|
|
(cap_delete slot)"
|
|
unfolding cap_delete_def
|
|
by (wp rec_del_CTEDeleteCall_reads_respects_f) force
|
|
|
|
(* FIXME move *)
|
|
lemma spec_gen_asm:
|
|
"(Q \<Longrightarrow> spec_equiv_valid st D A B P f) \<Longrightarrow> spec_equiv_valid st D A B (P and K Q) f"
|
|
by (simp add: spec_equiv_valid_def equiv_valid_2_def)
|
|
|
|
(* FIXME move *)
|
|
lemma select_ev:
|
|
"equiv_valid_inv I A (K(S \<noteq> {} \<longrightarrow> (\<exists>x. S = {x}))) (select S)"
|
|
apply (clarsimp simp: equiv_valid_def spec_equiv_valid_def equiv_valid_2_def select_def)
|
|
apply blast
|
|
done
|
|
|
|
lemma next_revoke_eq:
|
|
notes split_paired_All[simp del] split_paired_Ex[simp del]
|
|
shows
|
|
"equiv_for ((aag_can_read aag or aag_can_affect aag l) \<circ> fst) cdt_list rv rv'
|
|
\<Longrightarrow> is_subject aag (fst src_slot)
|
|
\<Longrightarrow> next_revoke_cap src_slot rv = next_revoke_cap src_slot rv'"
|
|
by (clarsimp simp: next_child_def equiv_for_def next_revoke_cap_def)
|
|
|
|
lemma next_revoke_eq':
|
|
"\<lbrakk> reads_equiv_f aag s t; is_subject aag (fst src_slot) \<rbrakk>
|
|
\<Longrightarrow> next_revoke_cap src_slot s = next_revoke_cap src_slot t"
|
|
apply (rule next_revoke_eq)
|
|
apply (fastforce simp: reads_equiv_f_def reads_equiv_def2 states_equiv_for_def equiv_for_def)
|
|
apply simp
|
|
done
|
|
|
|
lemma cap_revoke_spec_reads_respects_f:
|
|
assumes domains_distinct[wp]: "pas_domains_distinct aag"
|
|
notes drop_spec_valid[wp_split del] drop_spec_validE[wp_split del] drop_spec_ev[wp_split del]
|
|
rec_del.simps[simp del] split_paired_All[simp del] split_paired_Ex[simp del]
|
|
shows "spec_reads_respects_f s aag l (silc_inv aag st and only_timer_irq_inv irq st' and einvs
|
|
and simple_sched_action and pas_refined aag
|
|
and K (is_subject aag (fst slot)))
|
|
(cap_revoke slot)"
|
|
proof (induct rule: cap_revoke.induct[where ?a1.0=s])
|
|
case (1 slot s)
|
|
show ?case
|
|
apply (rule spec_gen_asm)
|
|
apply (rule spec_equiv_valid_guard_imp)
|
|
apply (subst cap_revoke.simps)
|
|
apply (subst spec_equiv_valid_def2)
|
|
apply (subst rel_sum_comb_equals[symmetric])
|
|
apply (rule_tac R'="(=)" in spec_equiv_valid_2_inv_bindE)
|
|
apply (rule_tac R'="equiv_for ((aag_can_read aag or aag_can_affect aag l) \<circ> fst) id"
|
|
in spec_equiv_valid_2_inv_bindE)
|
|
apply (rule_tac R'="(=)" in spec_equiv_valid_2_inv_bindE)
|
|
apply (simp add: rel_sum_comb_equals
|
|
del: Inr_in_liftE_simp without_preemption_def fun_app_def)
|
|
apply (rule spec_equiv_valid_2_inv_by_spec_equiv_valid[OF _ refl refl refl])
|
|
apply (wp whenE_spec_ev)
|
|
apply (rule "1.hyps")
|
|
apply (assumption | erule | simp)+
|
|
apply (wp drop_spec_ev[OF preemption_point_reads_respects_f]
|
|
drop_spec_ev[OF cap_delete_reads_respects_f[where st=st]]
|
|
select_ext_ev preemption_point_inv'
|
|
cap_delete_pas_refined cap_delete_silc_inv[where st=st]
|
|
cap_delete_only_timer_irq_inv[where st=st' and irq=irq]
|
|
drop_spec_ev[OF assertE_ev] drop_spec_ev[OF liftE_ev]
|
|
get_cap_wp select_ev drop_spec_ev2_inv[OF liftE_ev2]
|
|
reads_respects_f[OF get_cap_rev, where st=st and aag=aag]
|
|
| simp (no_asm) add: returnOk_def | rule next_revoke_eq'
|
|
| (simp add: pred_conj_def, erule conjE, assumption)
|
|
| (rule irq_state_independent_A_conjI, simp)+)+
|
|
apply (rule_tac P="K(all_children (\<lambda>x. aag_can_read aag (fst x)) rva)"
|
|
and P'="K(all_children (\<lambda>x. aag_can_read aag (fst x)) rv'a)"
|
|
in drop_spec_ev2_inv[OF return_ev2])
|
|
apply simp
|
|
apply (rule_tac P="\<lambda>x. aag_can_read aag (fst x)" in all_children_descendants_equal)
|
|
apply (frule aag_can_read_self)
|
|
apply (simp add: equiv_for_def split del: if_split)+
|
|
apply (wp drop_spec_ev2_inv[OF liftE_ev2] gets_evrv | simp)+
|
|
apply (wp drop_spec_ev2_inv[OF liftE_ev2] gets_evrv
|
|
reads_respects_f[OF get_cap_rev, where st=st and Q=\<top>,simplified equiv_valid_def2])
|
|
apply clarsimp+
|
|
apply (frule all_children_subjectReads[simplified comp_def])
|
|
apply clarsimp
|
|
apply (rule conjI)
|
|
apply (force simp: reads_equiv_f_def intro: equiv_forI
|
|
elim: reads_equivE affects_equivE equiv_forD)
|
|
apply clarsimp
|
|
apply (rule conjI, erule(1) all_children_descendants_of, force)
|
|
apply (clarsimp simp: conj_comms)
|
|
apply (intro conjI)
|
|
by (case_tac "next_revoke_cap slot s", force simp: emptyable_def dest: reply_slot_not_descendant
|
|
| force elim: all_children_descendants_of[OF cdt_change_allowed_all_children])+
|
|
qed
|
|
|
|
lemmas cap_revoke_reads_respects_f = use_spec_ev[OF cap_revoke_spec_reads_respects_f]
|
|
|
|
lemma cancel_badged_sends_reads_respects_f:
|
|
assumes domains_distinct: "pas_domains_distinct aag"
|
|
shows "reads_respects_f aag l (silc_inv aag st and is_subject aag \<circ> cur_thread and pas_refined aag
|
|
and invs and K (is_subject aag ptr))
|
|
(cancel_badged_sends ptr badge)"
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (rule reads_respects_f)
|
|
apply (rule cancel_badged_sends_reads_respects[OF domains_distinct])
|
|
apply (wp cancel_badged_sends_silc_inv[where st=st] | simp | elim conjE, assumption)+
|
|
apply fastforce
|
|
done
|
|
|
|
lemma cap_revoke_only_timer_irq_inv:
|
|
"\<lbrace>only_timer_irq_inv irq (st :: det_state)\<rbrace>
|
|
cap_revoke slot
|
|
\<lbrace>\<lambda>_. only_timer_irq_inv irq st\<rbrace>"
|
|
apply (simp add: only_timer_irq_inv_def)
|
|
apply (rule hoare_wp_simps)
|
|
apply (rule hoare_conjI)
|
|
apply (wp only_timer_irq_pres[where P="\<top>"] cap_revoke_irq_masks | force)+
|
|
done
|
|
|
|
lemma invoke_cnode_reads_respects_f:
|
|
assumes domains_distinct[wp]: "pas_domains_distinct aag"
|
|
shows "reads_respects_f aag l
|
|
(silc_inv aag st and only_timer_irq_inv irq st' and pas_refined aag and einvs
|
|
and simple_sched_action and valid_cnode_inv ci
|
|
and (\<lambda>s. is_subject aag (cur_thread s))
|
|
and cnode_inv_auth_derivations ci and authorised_cnode_inv aag ci)
|
|
(invoke_cnode ci)"
|
|
unfolding invoke_cnode_def
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (wpc | wp reads_respects_f[OF cap_insert_reads_respects] cap_insert_silc_inv
|
|
reads_respects_f[OF cap_move_reads_respects] cap_move_silc_inv get_cap_auth_wp
|
|
cap_revoke_reads_respects_f cap_delete_reads_respects_f cap_swap_silc_inv
|
|
reads_respects_f[OF cap_swap_reads_respects] cap_move_cte_wp_at_other
|
|
reads_respects_f[OF get_cap_rev] cancel_badged_sends_reads_respects_f
|
|
| simp add: when_def split del: if_split
|
|
| elim conjE, assumption)+
|
|
apply (clarsimp simp: cnode_inv_auth_derivations_def authorised_cnode_inv_def)
|
|
apply (auto intro: real_cte_emptyable_strg[rule_format]
|
|
simp: silc_inv_def reads_equiv_f_def requiv_cur_thread_eq caps_of_state_cteD
|
|
aag_cap_auth_recycle_EndpointCap cte_wp_at_weak_derived_ReplyCap )
|
|
done
|
|
|
|
lemma cap_swap_reads_respects_g:
|
|
"reads_respects_g aag l
|
|
(\<lambda>s. is_subject aag (fst slot1) \<and> is_subject aag (fst slot2) \<and>
|
|
valid_global_objs s \<and> valid_arch_state s)
|
|
(cap_swap cap1 slot1 cap2 slot2)"
|
|
by (wp equiv_valid_guard_imp[OF reads_respects_g] cap_swap_reads_respects
|
|
doesnt_touch_globalsI cap_swap_globals_equiv | simp)+
|
|
|
|
lemma cap_insert_reads_respects_g:
|
|
"reads_respects_g aag l
|
|
(\<lambda>s. is_subject aag (fst src_slot) \<and> is_subject aag (fst dest_slot) \<and>
|
|
valid_global_objs s \<and> valid_arch_state s)
|
|
(cap_insert new_cap src_slot dest_slot)"
|
|
by (wp equiv_valid_guard_imp[OF reads_respects_g] cap_insert_reads_respects
|
|
doesnt_touch_globalsI cap_insert_globals_equiv | simp)+
|
|
|
|
lemma cap_move_reads_respects_g:
|
|
"reads_respects_g aag l
|
|
(\<lambda>s. is_subject aag (fst src_slot) \<and> is_subject aag (fst dest_slot) \<and>
|
|
valid_global_objs s \<and> valid_arch_state s)
|
|
(cap_move new_cap src_slot dest_slot)"
|
|
by (wp equiv_valid_guard_imp[OF reads_respects_g] cap_move_reads_respects
|
|
doesnt_touch_globalsI cap_move_globals_equiv | simp)+
|
|
|
|
(* FIXME: MOVE *)
|
|
lemma reads_respects_f_g':
|
|
"\<lbrakk> reads_respects_g aag l P f; \<lbrace>silc_inv aag st and Q\<rbrace> f \<lbrace>\<lambda>_. silc_inv aag st\<rbrace> \<rbrakk>
|
|
\<Longrightarrow> reads_respects_f_g aag l (silc_inv aag st and P and Q) f"
|
|
apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def reads_equiv_f_g_def reads_equiv_g_def)
|
|
apply (rule conjI, fastforce)
|
|
apply (rule conjI, fastforce)
|
|
apply (rule conjI, fastforce)
|
|
apply (subst conj_commute, rule conjI, fastforce)
|
|
apply (rule silc_dom_equiv_trans)
|
|
apply (rule silc_dom_equiv_sym)
|
|
apply (rule silc_inv_silc_dom_equiv)
|
|
apply (erule (1) use_valid, simp)
|
|
apply (rule silc_inv_silc_dom_equiv)
|
|
apply (erule (1) use_valid, simp)
|
|
done
|
|
|
|
lemma invoke_domain_reads_respects_f_g:
|
|
"reads_respects_f_g aag l \<bottom> (invoke_domain thread domain)"
|
|
by (clarsimp simp: equiv_valid_def spec_equiv_valid_def equiv_valid_2_def)
|
|
|
|
|
|
context Syscall_IF_1 begin
|
|
|
|
lemma invoke_cnode_reads_respects_f_g:
|
|
assumes domains_distinct: "pas_domains_distinct aag"
|
|
shows "reads_respects_f_g aag l
|
|
(silc_inv aag st and only_timer_irq_inv irq st' and pas_refined aag and einvs
|
|
and simple_sched_action and valid_cnode_inv ci
|
|
and (\<lambda>s. is_subject aag (cur_thread s))
|
|
and cnode_inv_auth_derivations ci and authorised_cnode_inv aag ci)
|
|
(invoke_cnode ci)"
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (rule reads_respects_f_g)
|
|
apply (rule invoke_cnode_reads_respects_f[where st=st, OF domains_distinct])
|
|
apply (rule doesnt_touch_globalsI)
|
|
apply (wp invoke_cnode_globals_equiv)
|
|
apply force+
|
|
done
|
|
|
|
lemma perform_invocation_reads_respects_f_g:
|
|
assumes domains_distinct[wp]: "pas_domains_distinct aag"
|
|
shows "reads_respects_f_g aag l
|
|
(silc_inv aag st and only_timer_irq_inv irq st' and pas_refined aag and pas_cur_domain aag
|
|
and einvs and schact_is_rct and valid_invocation oper and ct_active
|
|
and authorised_invocation aag oper and is_subject aag \<circ> cur_thread
|
|
and authorised_for_globals_inv oper
|
|
and K (authorised_invocation_extra aag oper))
|
|
(perform_invocation blocking calling oper)"
|
|
proof (cases oper)
|
|
case InvokeUntyped
|
|
then show ?thesis
|
|
apply simp
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (wpc | simp | wp reads_respects_f_g'[OF invoke_untyped_reads_respects_g]
|
|
invoke_untyped_silc_inv)+
|
|
by (simp add: authorised_invocation_def)
|
|
next
|
|
case InvokeEndpoint
|
|
then show ?thesis
|
|
apply simp
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (wpc | simp | wp reads_respects_f_g'[OF send_ipc_reads_respects_g] send_ipc_silc_inv)+
|
|
by (fastforce intro: read_reply_thread_read_thread_rev[OF reads_lrefl]
|
|
simp: authorised_invocation_def reads_equiv_f_g_def)
|
|
next
|
|
case InvokeNotification
|
|
then show ?thesis
|
|
apply simp
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (wpc | simp | wp reads_respects_f_g'[OF send_signal_reads_respects_g, where Q="\<top>"])+
|
|
by (fastforce simp: authorised_invocation_def valid_sched_def)
|
|
next
|
|
case InvokeReply
|
|
then show ?thesis
|
|
apply simp
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (wpc | simp | wp do_reply_transfer_reads_respects_f_g)+
|
|
by (fastforce intro: read_reply_thread_read_thread_rev[OF reads_lrefl] emptyable_cte_wp_atD
|
|
simp: reads_equiv_f_g_def authorised_invocation_def is_cap_simps
|
|
dest: emptyable_cte_wp_atD)
|
|
next
|
|
case InvokeTCB
|
|
then show ?thesis
|
|
apply simp
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (wpc | simp | wp invoke_tcb_reads_respects_f_g)+
|
|
by (fastforce simp: authorised_invocation_def authorised_invocation_extra_def)
|
|
next
|
|
case InvokeDomain
|
|
then show ?thesis
|
|
apply simp
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (wpc | simp | wp invoke_domain_reads_respects_f_g)+
|
|
by (simp add: authorised_invocation_def)
|
|
next
|
|
case InvokeCNode
|
|
then show ?thesis
|
|
apply simp
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (wpc | simp | wp invoke_cnode_reads_respects_f_g)+
|
|
by (fastforce simp: authorised_invocation_def)
|
|
next
|
|
case InvokeIRQControl
|
|
then show ?thesis
|
|
apply simp
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (wpc | simp | wp reads_respects_f_g'[OF invoke_irq_control_reads_respects_g]
|
|
invoke_irq_control_silc_inv)+
|
|
by (simp add: invs_def valid_state_def authorised_invocation_def)
|
|
next
|
|
case InvokeIRQHandler
|
|
then show ?thesis
|
|
apply simp
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (wpc | simp | wp invoke_irq_handler_reads_respects_f_g)+
|
|
by (fastforce simp: authorised_invocation_def)
|
|
next
|
|
case InvokeArchObject
|
|
then show ?thesis
|
|
apply simp
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (wpc | simp | wp reads_respects_f_g'[OF arch_perform_invocation_reads_respects_g]
|
|
arch_perform_invocation_silc_inv)+
|
|
by (fastforce simp: authorised_invocation_def authorised_for_globals_inv_def)
|
|
qed
|
|
|
|
end
|
|
|
|
|
|
crunch valid_arch_state[wp]: reply_from_kernel valid_arch_state (simp: crunch_simps)
|
|
|
|
lemma syscall_reads_respects_f_g:
|
|
assumes reads_res_m_fault:
|
|
"reads_respects_f_g aag l P m_fault"
|
|
assumes reads_res_m_error:
|
|
"\<And>v. reads_respects_f_g aag l (Q'' v) (m_error v)"
|
|
assumes reads_res_h_fault:
|
|
"\<And>v. reads_respects_f_g aag l (Q' v) (h_fault v)"
|
|
assumes reads_res_m_finalise:
|
|
"\<And>v. reads_respects_f_g aag l (R'' v) (m_finalise v)"
|
|
assumes reads_res_h_error:
|
|
"\<And>v. reads_respects_f_g aag l (R' v) (h_error v)"
|
|
assumes m_fault_hoare:
|
|
"\<lbrace>P\<rbrace> m_fault \<lbrace>case_sum Q' Q''\<rbrace>"
|
|
assumes m_error_hoare:
|
|
"\<And>v. \<lbrace>Q'' v\<rbrace> m_error v \<lbrace>case_sum R' R''\<rbrace>"
|
|
shows "reads_respects_f_g aag l P (syscall m_fault h_fault m_error h_error m_finalise)"
|
|
unfolding Syscall_A.syscall_def without_preemption_def fun_app_def
|
|
by (wp assms equiv_valid_guard_imp[OF liftE_bindE_ev]
|
|
| rule hoare_strengthen_post[OF m_error_hoare]
|
|
| rule hoare_strengthen_post[OF m_fault_hoare]
|
|
| wpc
|
|
| fastforce)+
|
|
|
|
(*FIXME: move *)
|
|
lemma syscall_requiv_f_g:
|
|
"\<lbrakk> reads_respects_f_g aag l P m_fault;
|
|
\<And>v. reads_respects_f_g aag l (R' v) (h_error v);
|
|
\<And>v. reads_respects_f_g aag l (R'' v) (m_finalise v);
|
|
\<And>v. reads_respects_f_g aag l (Q'' v) (m_error v);
|
|
\<And>v. reads_respects_f_g aag l (Q' v) (h_fault v);
|
|
\<And>v. \<lbrace>Q''' v\<rbrace> m_error v \<lbrace>R''\<rbrace>, \<lbrace>R'\<rbrace>;
|
|
\<lbrace>P\<rbrace> m_fault \<lbrace>\<lambda>rv. Q'' rv and Q''' rv\<rbrace>, \<lbrace>Q'\<rbrace> \<rbrakk>
|
|
\<Longrightarrow> reads_respects_f_g aag l P (syscall m_fault h_fault m_error h_error m_finalise)"
|
|
apply (rule syscall_reads_respects_f_g[where Q''="\<lambda>rv. Q'' rv and Q''' rv"])
|
|
apply (unfold validE_def)
|
|
apply (assumption)+
|
|
apply (rule equiv_valid_guard_imp, assumption, simp)
|
|
apply assumption+
|
|
apply (rule hoare_strengthen_post)
|
|
apply assumption
|
|
apply (simp split: sum.splits)
|
|
apply (rule hoare_strengthen_post, rule hoare_pre)
|
|
apply assumption
|
|
apply simp
|
|
apply (simp split: sum.splits)
|
|
done
|
|
|
|
(*FIXME: Move to base*)
|
|
lemma requiv_g_cur_thread_eq:
|
|
"reads_equiv_g aag s t \<Longrightarrow> (cur_thread s) = (cur_thread t)"
|
|
apply (frule reads_equiv_gD)
|
|
apply (clarsimp simp add: requiv_cur_thread_eq)
|
|
done
|
|
|
|
(* Weird hack. Not sure why this is necessary. Something is getting instantiated too early*)
|
|
lemma lookup_cap_and_slot_reads_respects_g':
|
|
"reads_equiv_valid_g_inv (affects_equiv aag l) aag
|
|
(pas_refined aag and K (is_subject aag t) and P)
|
|
(lookup_cap_and_slot t cptr)"
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (rule lookup_cap_and_slot_reads_respects_g)
|
|
apply simp
|
|
done
|
|
|
|
lemma authorised_for_globals_triv:
|
|
"\<forall>x y. f x \<noteq> InvokeArchObject y
|
|
\<Longrightarrow> \<lbrace>\<top>\<rbrace> m \<lbrace>authorised_for_globals_inv \<circ> f\<rbrace>, -"
|
|
by (clarsimp simp: validE_R_def validE_def valid_def authorised_for_globals_inv_def
|
|
split: invocation.splits sum.splits)
|
|
|
|
lemma set_thread_state_reads_respects_g:
|
|
assumes domains_distinct: "pas_domains_distinct aag"
|
|
shows
|
|
"reads_respects_g aag (l :: 'a subject_label) (is_subject aag \<circ> cur_thread and valid_arch_state)
|
|
(set_thread_state ref ts)"
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (rule reads_respects_g)
|
|
apply (rule set_thread_state_reads_respects[OF domains_distinct])
|
|
apply (rule doesnt_touch_globalsI)
|
|
apply (rule set_thread_state_globals_equiv)
|
|
apply simp
|
|
done
|
|
|
|
lemmas get_thread_state_reads_respects_g =
|
|
reads_respects_g_from_inv[OF get_thread_state_rev get_thread_state_inv]
|
|
|
|
lemma decode_invocation_authorised_extra:
|
|
"\<lbrace>K (is_subject aag (fst slot))\<rbrace>
|
|
decode_invocation info_label args ptr slot cap excaps
|
|
\<lbrace>\<lambda>rv s. authorised_invocation_extra aag rv\<rbrace>,-"
|
|
unfolding decode_invocation_def authorised_invocation_extra_def
|
|
apply (rule hoare_pre)
|
|
apply (wp decode_tcb_invocation_authorised_extra | wpc | simp add: split_def o_def uncurry_def)+
|
|
apply auto
|
|
done
|
|
|
|
lemma sts_schact_is_rct_runnable:
|
|
"\<lbrace>schact_is_rct and K (runnable b)\<rbrace>
|
|
set_thread_state a b
|
|
\<lbrace>\<lambda>_. schact_is_rct\<rbrace>"
|
|
apply (simp add: set_thread_state_def set_scheduler_action_def)
|
|
apply (wpsimp wp: set_object_wp)
|
|
apply (simp add: set_thread_state_ext_def)
|
|
apply (wp modify_wp set_scheduler_action_wp gts_wp)
|
|
apply (wpsimp wp: set_object_wp)
|
|
apply wp
|
|
apply (clarsimp simp: schact_is_rct_def st_tcb_at_def obj_at_def gets_the_def gets_def)
|
|
done
|
|
|
|
lemma set_thread_state_only_timer_irq_inv:
|
|
"\<lbrace>only_timer_irq_inv irq (st :: det_state)\<rbrace>
|
|
set_thread_state ref ts
|
|
\<lbrace>\<lambda>_. only_timer_irq_inv irq st\<rbrace>"
|
|
apply (simp add: only_timer_irq_inv_def)
|
|
apply (wp only_timer_irq_pres | force)+
|
|
done
|
|
|
|
lemma ct_active_cur_thread_not_idle_thread:
|
|
"\<lbrakk> valid_idle s; ct_active s \<rbrakk> \<Longrightarrow> cur_thread s \<noteq> idle_thread s"
|
|
by (clarsimp simp: invs_def valid_idle_def ct_in_state_def pred_tcb_at_def obj_at_def)
|
|
|
|
lemma ct_active_not_idle:
|
|
"\<lbrakk> invs s; ct_active s \<rbrakk> \<Longrightarrow> cur_thread s \<noteq> idle_thread s"
|
|
by (clarsimp simp: ct_active_cur_thread_not_idle_thread invs_valid_idle)
|
|
|
|
|
|
context Syscall_IF_1 begin
|
|
|
|
lemma decode_invocation_authorised_globals_inv:
|
|
"\<lbrace>invs and cte_wp_at ((=) cap) slot
|
|
and (\<lambda>s :: det_state. \<forall>x\<in>set excaps. cte_wp_at ((=) (fst x)) (snd x) s)\<rbrace>
|
|
decode_invocation info_label args ptr slot cap excaps
|
|
\<lbrace>authorised_for_globals_inv\<rbrace>, -"
|
|
unfolding decode_invocation_def
|
|
apply (rule hoare_pre)
|
|
apply wpc
|
|
apply ((wp authorised_for_globals_triv | wpc | simp add: uncurry_def)+)[11]
|
|
apply (unfold authorised_for_globals_inv_def)
|
|
apply wp
|
|
apply (unfold comp_def)
|
|
apply simp
|
|
apply (wp decode_arch_invocation_authorised_for_globals)
|
|
apply (intro impI conjI allI | clarsimp simp add: authorised_for_globals_inv_def)+
|
|
apply (erule_tac x="(a, aa, b)" in ballE)
|
|
apply simp+
|
|
done
|
|
|
|
lemma handle_invocation_reads_respects_g:
|
|
assumes domains_distinct[wp]: "pas_domains_distinct aag"
|
|
notes gts_st_tcb[wp del] gts_st_tcb_at[wp del]
|
|
notes get_message_info_reads_respects_g = reads_respects_g_from_inv[OF get_message_info_rev get_mi_inv]
|
|
shows "reads_respects_f_g aag l
|
|
(silc_inv aag st and only_timer_irq_inv irq st' and einvs and schact_is_rct and ct_active
|
|
and pas_refined aag and pas_cur_domain aag
|
|
and is_subject aag \<circ> cur_thread and K (\<not> pasMaySendIrqs aag))
|
|
(handle_invocation calling blocking)"
|
|
apply (rule gen_asm_ev)
|
|
apply (simp add: handle_invocation_def split_def)
|
|
apply (wpc | simp add: tcb_at_st_tcb_at[symmetric] split del: if_split
|
|
| intro impI | erule conjE | rule doesnt_touch_globalsI
|
|
| (wp syscall_requiv_f_g gts_inv when_ev
|
|
reads_respects_f_g'[OF lookup_extra_caps_reads_respects_g, where Q="\<top>" and st=st]
|
|
reads_respects_f_g'[OF lookup_ipc_buffer_reads_respects_g, where Q="\<top>" and st=st]
|
|
reads_respects_f_g'[OF cap_fault_on_failure_rev_g, where Q="\<top>" and st=st]
|
|
valid_validE_R[OF wp_post_taut] lookup_ipc_buffer_has_read_auth'
|
|
lookup_cap_and_slot_reads_respects_g' decode_invocation_reads_respects_f_g
|
|
get_mrs_reads_respects_g handle_fault_reads_respects_g
|
|
reads_respects_f_g'[OF set_thread_state_reads_respects_g, where st=st and Q="\<top>"]
|
|
reads_respects_f_g'[OF get_thread_state_reads_respects_g, where st=st and Q="\<top>"]
|
|
reads_respects_f_g'[OF reads_respects_g[OF reply_from_kernel_reads_respects], where st=st]
|
|
get_thread_state_reads_respects_g perform_invocation_reads_respects_f_g
|
|
set_thread_state_pas_refined sts_first_restart set_thread_state_ct_st
|
|
lookup_extra_caps_authorised lookup_extra_caps_auth handle_fault_globals_equiv
|
|
set_thread_state_globals_equiv reply_from_kernel_globals_equiv)+
|
|
| rule hoare_drop_imps)+
|
|
apply (rule_tac Q'="\<lambda>r s. silc_inv aag st s \<and> invs s \<and> is_subject aag rv \<and>
|
|
is_subject aag (cur_thread s) \<and> rv \<noteq> idle_thread s"
|
|
in hoare_post_imp_R)
|
|
apply (wp pinv_invs perform_invocation_silc_inv)
|
|
apply (simp add: invs_def valid_state_def valid_pspace_def)
|
|
apply (wpsimp wp: reads_respects_f_g'
|
|
set_thread_state_reads_respects_g[OF domains_distinct])
|
|
apply (wp when_ev set_thread_state_only_timer_irq_inv[where st=st']
|
|
set_thread_state_reads_respects_g set_thread_state_globals_equiv
|
|
sts_Restart_invs set_thread_state_pas_refined set_thread_state_ct_st
|
|
set_thread_state_runnable_valid_sched sts_authorised_for_globals_inv
|
|
sts_schact_is_rct_runnable decode_invocation_reads_respects_f_g
|
|
reads_respects_f_g'[OF get_mrs_reads_respects_g, where Q="\<top>" and st=st]
|
|
reads_respects_f_g'[OF handle_fault_reads_respects_g]
|
|
decode_invocation_authorised decode_invocation_authorised_globals_inv
|
|
decode_invocation_authorised_extra lec_valid_fault
|
|
lookup_extra_caps_authorised lookup_extra_caps_auth
|
|
lookup_ipc_buffer_has_read_auth' lookup_cap_and_slot_valid_fault3
|
|
lookup_cap_and_slot_authorised lookup_cap_and_slot_cur_auth as_user_silc_inv
|
|
reads_respects_f_g'[OF reads_respects_g[OF as_user_reads_respects], where Q=\<top> and st=st]
|
|
reads_respects_f_g'[OF get_message_info_reads_respects_g, where Q="\<top>" and st=st]
|
|
as_user_globals_equiv user_getreg_inv get_mi_inv get_mi_length get_mi_length'
|
|
| simp add: o_def
|
|
| rule doesnt_touch_globalsI
|
|
| clarify, assumption
|
|
| wp (once) hoare_drop_imps)+
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: requiv_g_cur_thread_eq simp: reads_equiv_f_g_conj)
|
|
apply (clarsimp simp: det_getRegister invs_sym_refs invs_def valid_state_def
|
|
valid_pspace_vo valid_pspace_distinct)
|
|
apply (rule context_conjI)
|
|
apply (simp add: ct_active_cur_thread_not_idle_thread)
|
|
apply (clarsimp simp: valid_pspace_def ct_in_state_def)
|
|
apply (rule conjI)
|
|
apply (fastforce intro: reads_lrefl)
|
|
apply (rule conjI, fastforce)+
|
|
apply (simp add: conj_comms)
|
|
apply (rule conjI)
|
|
apply (clarsimp elim!: schact_is_rct_simple)
|
|
apply (rule conjI)
|
|
apply (rule st_tcb_ex_cap)
|
|
apply simp+
|
|
apply (case_tac "sta",clarsimp+)
|
|
apply (force simp: only_timer_irq_inv_def runnable_eq_active)
|
|
done
|
|
|
|
end
|
|
|
|
|
|
lemma delete_caller_cap_reads_respects_f:
|
|
assumes domains_distinct: "pas_domains_distinct aag"
|
|
shows "reads_respects_f aag l (silc_inv aag st and invs and pas_refined aag
|
|
and K (is_subject aag (fst (x, tcb_cnode_index 3))))
|
|
(delete_caller_cap x)"
|
|
unfolding delete_caller_cap_def
|
|
by (rule cap_delete_one_reads_respects_f[OF domains_distinct])
|
|
|
|
lemma delete_caller_cap_globals_equiv:
|
|
"\<lbrace>globals_equiv st and valid_arch_state\<rbrace>
|
|
delete_caller_cap x
|
|
\<lbrace>\<lambda>r. globals_equiv st\<rbrace>"
|
|
unfolding delete_caller_cap_def
|
|
by (wp cap_delete_one_globals_equiv)
|
|
|
|
lemma lookup_cap_cap_fault:
|
|
"\<lbrace>invs\<rbrace> lookup_cap c b -, \<lbrace>\<lambda>f s. valid_fault (CapFault x y f)\<rbrace>"
|
|
apply (simp add: lookup_cap_def)
|
|
apply wp
|
|
apply (case_tac xa)
|
|
apply (simp add: validE_E_def)
|
|
apply (wp)
|
|
apply (fold validE_E_def)
|
|
apply (wp lookup_slot_for_thread_cap_fault)
|
|
apply assumption
|
|
done
|
|
|
|
lemma cap_fault_on_failure_ev':
|
|
"equiv_valid_inv (reads_equiv_f aag) A P f \<Longrightarrow>
|
|
equiv_valid_inv (reads_equiv_f aag) A P (cap_fault_on_failure cptr rp f)"
|
|
unfolding cap_fault_on_failure_def handleE'_def
|
|
by (wp | wpc | simp add: o_def)+
|
|
|
|
lemma delete_caller_cap_valid_ep_cap[wp]:
|
|
"delete_caller_cap t \<lbrace>\<lambda>s. s \<turnstile> EndpointCap a b c\<rbrace>"
|
|
apply (clarsimp simp: delete_caller_cap_def valid_cap_def)
|
|
apply (rule hoare_pre)
|
|
apply wp
|
|
apply clarsimp
|
|
done
|
|
|
|
lemma handle_recv_reads_respects_f:
|
|
fixes st aag
|
|
assumes domains_distinct[wp]: "pas_domains_distinct aag"
|
|
notes mywp =
|
|
domains_distinct
|
|
cap_fault_on_failure_ev'
|
|
receive_ipc_silc_inv[where st=st]
|
|
reads_respects_f[OF receive_ipc_reads_respects, where st=st]
|
|
delete_caller_cap_reads_respects_f[where st=st]
|
|
delete_caller_cap_silc_inv[where st=st]
|
|
reads_respects_f_inv[OF receive_signal_reads_respects receive_signal_silc_inv, where st=st]
|
|
reads_respects_f[OF lookup_slot_for_thread_rev, where st=st and Q=\<top>]
|
|
reads_respects_f_inv[OF get_cap_rev get_cap_inv, where st=st]
|
|
get_cap_auth_wp[where aag=aag]
|
|
reads_respects_f[OF get_simple_ko_reads_respects, where st=st and Q=\<top>]
|
|
lookup_slot_for_thread_authorised
|
|
get_simple_ko_wp
|
|
shows
|
|
"reads_respects_f aag l (silc_inv aag st and einvs and ct_active and pas_refined aag
|
|
and pas_cur_domain aag and is_subject aag \<circ> cur_thread)
|
|
(handle_recv is_blocking)"
|
|
apply (simp add: handle_recv_def Let_def lookup_cap_def split_def)
|
|
apply (wp mywp | wpc | assumption | simp | clarsimp
|
|
| strengthen aag_can_read_self[where x ="fst (fst y)" for y])+
|
|
apply (rule_tac Q'="\<lambda>r s. silc_inv aag st s \<and> einvs s \<and> pas_refined aag s \<and> tcb_at rv s \<and>
|
|
pas_cur_domain aag s \<and> cte_wp_at \<top> (fst r) s \<and> is_subject aag rv \<and>
|
|
is_subject aag (cur_thread s) \<and> is_subject aag (fst (fst r))"
|
|
in hoare_post_imp_R)
|
|
apply ((wp lookup_slot_for_thread_authorised lookup_slot_cte_at_wp | simp)+)[1]
|
|
apply (clarsimp simp: silc_inv_not_subject[symmetric] invs_mdb invs_valid_objs)
|
|
apply (auto intro: caps_of_state_valid reads_ep
|
|
simp: aag_cap_auth_def cap_auth_conferred_def cap_rights_to_auth_def)[1]
|
|
apply (wp reads_respects_f[OF handle_fault_reads_respects,where st=st])
|
|
apply (wpsimp wp: get_simple_ko_wp get_cap_wp)+
|
|
apply (rule_tac Q="\<lambda>r s. silc_inv aag st s \<and> einvs s \<and> pas_refined aag s \<and>
|
|
tcb_at rv s \<and> pas_cur_domain aag s \<and> is_subject aag rv \<and>
|
|
is_subject aag (cur_thread s) \<and> is_subject aag (fst (fst r))"
|
|
and E=E and F=E for E in hoare_post_impErr)
|
|
apply (wp lookup_slot_for_thread_authorised lookup_slot_for_thread_cap_fault)
|
|
apply ((fastforce simp add:valid_fault_def)+)[3]
|
|
apply (wp reads_respects_f[OF as_user_reads_respects,where st=st and Q=\<top>])
|
|
apply simp
|
|
apply (wp as_user_silc_inv[where st=st] | simp)+
|
|
by (fastforce simp: det_getRegister invs_valid_objs tcb_at_invs)
|
|
|
|
lemma handle_recv_globals_equiv:
|
|
"\<lbrace>globals_equiv (st :: det_state) and invs and ct_active\<rbrace>
|
|
handle_recv is_blocking
|
|
\<lbrace>\<lambda>_. globals_equiv st\<rbrace>"
|
|
unfolding handle_recv_def
|
|
apply (wp handle_fault_globals_equiv get_simple_ko_wp
|
|
| wpc | simp add: Let_def)+
|
|
apply (rule_tac Q="\<lambda>r s. invs s \<and> globals_equiv st s" and
|
|
E = "\<lambda>r s. valid_fault (CapFault (of_bl ep_cptr) True r)"
|
|
in hoare_post_impErr)
|
|
apply (rule hoare_vcg_E_elim)
|
|
apply (wp lookup_cap_cap_fault receive_ipc_globals_equiv
|
|
receive_signal_globals_equiv delete_caller_cap_invs
|
|
delete_caller_cap_globals_equiv
|
|
| wpc
|
|
| simp add: Let_def invs_imps invs_valid_idle valid_fault_def
|
|
| rule_tac Q="\<lambda>rv s. invs s \<and> thread \<noteq> idle_thread s \<and> globals_equiv st s"
|
|
in hoare_strengthen_post,
|
|
wp,
|
|
clarsimp simp: invs_valid_objs invs_valid_global_objs invs_arch_state invs_distinct)+
|
|
apply (rule_tac Q'="\<lambda>r s. invs s \<and> globals_equiv st s \<and> thread \<noteq> idle_thread s \<and>
|
|
tcb_at thread s \<and> cur_thread s = thread"
|
|
in hoare_post_imp_R)
|
|
apply (wp as_user_globals_equiv | simp add: invs_imps valid_fault_def)+
|
|
apply (wp delete_caller_cap_invs delete_caller_cap_globals_equiv
|
|
| simp add: invs_imps invs_valid_idle ct_active_not_idle)+
|
|
done
|
|
|
|
lemma handle_recv_reads_respects_f_g:
|
|
assumes domains_distinct: "pas_domains_distinct aag"
|
|
shows
|
|
"reads_respects_f_g aag l
|
|
(silc_inv aag st and einvs and ct_active and pas_refined aag
|
|
and pas_cur_domain aag and is_subject aag \<circ> cur_thread)
|
|
(handle_recv is_blocking)"
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (rule reads_respects_f_g)
|
|
apply (wp handle_recv_reads_respects_f[where st=st, OF domains_distinct])
|
|
apply (rule doesnt_touch_globalsI)
|
|
apply (wp handle_recv_globals_equiv)
|
|
apply simp+
|
|
done
|
|
|
|
lemma dmo_return_reads_respects:
|
|
"reads_respects aag l \<top> (do_machine_op (return ()))"
|
|
apply (rule use_spec_ev)
|
|
apply (rule do_machine_op_spec_reads_respects; wp)
|
|
done
|
|
|
|
lemma dmo_return_globals_equiv:
|
|
"do_machine_op (return ()) \<lbrace>globals_equiv st\<rbrace>"
|
|
by simp
|
|
|
|
lemma get_irq_slot_reads_respects':
|
|
"reads_respects aag l (K (aag_can_read_label aag (pasIRQAbs aag irq))) (get_irq_slot irq)"
|
|
unfolding get_irq_slot_def
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (rule gets_ev)
|
|
apply (simp add: reads_equiv_def states_equiv_for_def equiv_for_def affects_equiv_def)
|
|
done
|
|
|
|
lemma get_irq_slot_can_read_from_slot:
|
|
"\<lbrace>K (aag_can_read_label aag (pasIRQAbs aag irq)) and pas_refined aag\<rbrace>
|
|
get_irq_slot irq
|
|
\<lbrace>\<lambda>r. K (aag_can_read_label aag (pasObjectAbs aag (fst r)))\<rbrace>"
|
|
unfolding get_irq_slot_def
|
|
apply (wp gets_wp)
|
|
apply (simp add: pas_refined_def policy_wellformed_def irq_map_wellformed_aux_def)
|
|
done
|
|
|
|
lemma get_irq_state_rev':
|
|
"reads_equiv_valid_inv A aag (K (aag_can_read_label aag (pasIRQAbs aag irq))) (get_irq_state irq)"
|
|
unfolding get_irq_state_def
|
|
apply (rule equiv_valid_guard_imp[OF gets_ev])
|
|
apply (fastforce simp: reads_equiv_def2
|
|
elim: states_equiv_forE_interrupt_states
|
|
intro: aag_can_read_irq_self)
|
|
done
|
|
|
|
lemma handle_yield_reads_respects:
|
|
assumes domains_distinct: "pas_domains_distinct aag"
|
|
shows "reads_respects aag (l :: 'a subject_label) (pas_refined aag) handle_yield"
|
|
by (wpsimp wp: domains_distinct tcb_sched_action_reads_respects
|
|
simp: handle_yield_def reads_equiv_def)
|
|
|
|
crunch silc_inv[wp]: handle_yield "silc_inv aag st"
|
|
|
|
crunch globals_equiv[wp]: handle_yield "globals_equiv st"
|
|
(simp_del: reschedule_required_ext_extended.dxo_eq tcb_sched_action_extended.dxo_eq)
|
|
|
|
lemma equiv_valid_hoist_guard:
|
|
assumes a: "Q \<Longrightarrow> equiv_valid_inv I A P f"
|
|
assumes b: "\<And>s. P s \<Longrightarrow> Q"
|
|
shows "equiv_valid_inv I A P f"
|
|
using assms by (fastforce simp: equiv_valid_def2 equiv_valid_2_def)
|
|
|
|
lemma as_user_reads_respects_g:
|
|
"reads_respects_g aag k
|
|
(valid_arch_state and (\<lambda>s. thread \<noteq> idle_thread s) and K (det f \<and> is_subject aag thread))
|
|
(as_user thread f)"
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (rule reads_respects_g)
|
|
apply (rule as_user_reads_respects)
|
|
apply (rule doesnt_touch_globalsI)
|
|
apply (wp as_user_globals_equiv)
|
|
apply simp+
|
|
done
|
|
|
|
crunch globals_equiv[wp]: invoke_domain "globals_equiv st"
|
|
(wp: dxo_wp_weak ignore: reschedule_required set_domain
|
|
simp_del: set_domain_extended.dxo_eq)
|
|
|
|
lemma handle_fault_globals_equiv':
|
|
"\<lbrace>invs and globals_equiv st and K (valid_fault ex)\<rbrace>
|
|
handle_fault thread ex
|
|
\<lbrace>\<lambda>_. globals_equiv st\<rbrace>"
|
|
by (wpsimp wp: handle_fault_globals_equiv simp: invs_imps)
|
|
|
|
|
|
context Syscall_IF_1 begin
|
|
|
|
lemma handle_interrupt_globals_equiv:
|
|
"\<lbrace>globals_equiv (st :: det_state) and invs\<rbrace>
|
|
handle_interrupt irq
|
|
\<lbrace>\<lambda>_. globals_equiv st\<rbrace>"
|
|
unfolding handle_interrupt_def
|
|
apply (rule hoare_if)
|
|
apply (wp dmo_maskInterrupt_globals_equiv dmo_return_globals_equiv send_signal_globals_equiv
|
|
hoare_vcg_if_lift2 hoare_drop_imps dxo_wp_weak no_fail_bind bind_known_operation_eq
|
|
| wpc
|
|
| simp add: dmo_bind_valid invs_imps invs_valid_idle)+
|
|
done
|
|
|
|
lemma handle_vm_fault_reads_respects_g:
|
|
"reads_respects_g aag l (K (is_subject aag t) and (valid_arch_state and (\<lambda>s. t \<noteq> idle_thread s)))
|
|
(handle_vm_fault t vmfault_type)"
|
|
apply (rule reads_respects_g)
|
|
apply (rule handle_vm_fault_reads_respects)
|
|
apply (rule doesnt_touch_globalsI)
|
|
apply (wp handle_vm_fault_globals_equiv)
|
|
apply simp
|
|
done
|
|
|
|
lemma handle_hypervisor_fault_reads_respects_g:
|
|
"reads_respects_g aag l \<top> (handle_hypervisor_fault thread hyp)"
|
|
apply (rule reads_respects_g[where P="\<top>" and Q="\<top>", simplified])
|
|
apply (rule handle_hypervisor_fault_reads_respects)
|
|
apply (rule doesnt_touch_globalsI)
|
|
apply (wp handle_hypervisor_fault_globals_equiv)
|
|
apply simp
|
|
done
|
|
|
|
(* we explicitly exclude the case where ev is Interrupt since this is a scheduler action *)
|
|
lemma handle_event_reads_respects_f_g:
|
|
assumes domains_distinct[wp]: "pas_domains_distinct aag"
|
|
shows "reads_respects_f_g aag l (silc_inv aag st and only_timer_irq_inv irq st' and einvs
|
|
and schact_is_rct and is_subject aag \<circ> cur_thread
|
|
and domain_sep_inv (pasMaySendIrqs aag) st'
|
|
and (\<lambda>s. ev \<noteq> Interrupt \<and> (ct_active s))
|
|
and pas_refined aag and pas_cur_domain aag
|
|
and K (\<not> pasMaySendIrqs aag))
|
|
(handle_event ev)"
|
|
apply (rule gen_asm_ev)
|
|
apply (rule_tac Q="ev \<noteq> Interrupt" in equiv_valid_hoist_guard)
|
|
prefer 2
|
|
apply fastforce
|
|
apply (case_tac ev; simp)
|
|
apply (rename_tac syscall)
|
|
apply (case_tac syscall, simp_all add: handle_send_def handle_call_def)
|
|
apply ((wp handle_invocation_reads_respects_g[simplified]
|
|
handle_recv_reads_respects_f_g[where st=st]
|
|
handle_reply_valid_sched
|
|
reads_respects_f_g[OF reads_respects_f[where st=st and aag=aag and Q=\<top>,
|
|
OF handle_yield_reads_respects]
|
|
doesnt_touch_globalsI]
|
|
handle_reply_reads_respects_g handle_reply_silc_inv[where st=st]
|
|
| simp add: invs_imps | rule equiv_valid_guard_imp | force)+)[8]
|
|
apply ((wp reads_respects_f_g'[OF handle_fault_reads_respects_g, where st=st]
|
|
| clarsimp simp: reads_equiv_f_g_conj requiv_g_cur_thread_eq schact_is_rct_simple
|
|
| wpc | intro impI conjI allI)+)[3]
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply ((wp reads_respects_f_g'[OF handle_vm_fault_reads_respects_g, where Q="\<top>" and st=st]
|
|
handle_vm_fault_silc_inv
|
|
| simp)+)[1]
|
|
prefer 2
|
|
apply ((wp reads_respects_f_g'[OF handle_fault_reads_respects_g, where st=st] | simp)+)[1]
|
|
prefer 2
|
|
apply (simp add: validE_E_def)
|
|
apply (rule_tac E="\<lambda>r s. invs s \<and> is_subject aag rv \<and> is_subject aag (cur_thread s)
|
|
\<and> valid_fault r \<and> pas_refined aag s \<and> pas_cur_domain aag s
|
|
\<and> silc_inv aag st s \<and> rv \<noteq> idle_thread s"
|
|
and Q="\<top>\<top>" in hoare_post_impErr)
|
|
apply (rule hoare_vcg_E_conj)
|
|
apply (wp hv_invs handle_vm_fault_silc_inv)+
|
|
apply (simp add: invs_imps invs_mdb invs_valid_idle)+
|
|
apply wp+
|
|
apply (clarsimp simp: requiv_g_cur_thread_eq reads_equiv_f_g_conj ct_active_not_idle)
|
|
apply (wp reads_respects_f_g'[OF handle_fault_reads_respects_g, where st=st]
|
|
| clarsimp simp: reads_equiv_f_g_conj requiv_g_cur_thread_eq schact_is_rct_simple
|
|
| wpc | intro impI conjI allI)+
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply ((wp reads_respects_f_g'[OF handle_hypervisor_fault_reads_respects_g, where Q=\<top>]
|
|
handle_hypervisor_fault_silc_inv
|
|
| simp)+)[1]
|
|
prefer 2
|
|
apply ((wp reads_respects_f_g'[OF handle_fault_reads_respects_g, where st=st] | simp)+)[1]
|
|
apply (simp add: validE_E_def)
|
|
apply (wp hv_invs handle_vm_fault_silc_inv)+
|
|
apply (simp add: invs_imps invs_mdb invs_valid_idle)+
|
|
apply (fastforce simp: requiv_g_cur_thread_eq reads_equiv_f_g_conj ct_active_not_idle)
|
|
done
|
|
|
|
lemma activate_thread_reads_respects:
|
|
assumes domains_distinct[wp]: "pas_domains_distinct aag"
|
|
shows "reads_respects aag (l :: 'a subject_label)
|
|
(cur_tcb and (\<lambda>s. aag_can_read_label aag (pasObjectAbs aag (cur_thread s))))
|
|
activate_thread"
|
|
apply (simp add: activate_thread_def)
|
|
apply (wpsimp wp: set_thread_state_runnable_reads_respects get_thread_state_rev)
|
|
by (wp set_object_reads_respects get_thread_state_rev
|
|
| simp add: as_user_def select_f_returns tcb_at_st_tcb_at[symmetric] cur_tcb_def
|
|
| rule hoare_drop_imps conjI requiv_cur_thread_eq requiv_get_tcb_eq'
|
|
| clarsimp simp: st_tcb_at_def obj_at_def is_tcb_def)+
|
|
|
|
lemma activate_thread_globals_equiv:
|
|
"\<lbrace>globals_equiv st and valid_arch_state and valid_idle\<rbrace>
|
|
activate_thread
|
|
\<lbrace>\<lambda>_. globals_equiv st\<rbrace>"
|
|
unfolding activate_thread_def
|
|
by (wpsimp wp: set_thread_state_globals_equiv gts_wp
|
|
simp: valid_idle_def pred_tcb_at_def obj_at_def)
|
|
|
|
lemma activate_thread_reads_respects_g:
|
|
assumes domains_distinct: "pas_domains_distinct aag"
|
|
shows "reads_respects_g aag (l :: 'a subject_label)
|
|
(invs and (\<lambda>s. aag_can_read_label aag (pasObjectAbs aag (cur_thread s))))
|
|
activate_thread"
|
|
apply (rule equiv_valid_guard_imp)
|
|
apply (rule reads_respects_g)
|
|
apply (rule activate_thread_reads_respects[OF domains_distinct])
|
|
apply (rule doesnt_touch_globalsI)
|
|
apply (rule hoare_pre)
|
|
apply (rule activate_thread_globals_equiv)
|
|
apply (simp add: invs_imps invs_valid_idle)+
|
|
done
|
|
|
|
lemma perform_invocation_globals_equiv:
|
|
"\<lbrace>invs and ct_active and valid_invocation oper and globals_equiv (st :: det_state)
|
|
and authorised_for_globals_inv oper\<rbrace>
|
|
perform_invocation blocking calling oper
|
|
\<lbrace>\<lambda>_. globals_equiv st\<rbrace>"
|
|
by (cases oper
|
|
; wpsimp wp: invoke_untyped_globals_equiv send_ipc_globals_equiv send_signal_globals_equiv
|
|
arch_perform_invocation_globals_equiv do_reply_transfer_globals_equiv
|
|
invoke_tcb_globals_equiv invoke_irq_control_globals_equiv
|
|
invoke_cnode_globals_equiv invoke_irq_handler_globals_equiv
|
|
; fastforce simp: invs_imps authorised_for_globals_inv_def)
|
|
|
|
lemma handle_invocation_globals_equiv:
|
|
"\<lbrace>invs and ct_active and globals_equiv st\<rbrace>
|
|
handle_invocation calling blocking
|
|
\<lbrace>\<lambda>_. globals_equiv (st :: det_state)\<rbrace>"
|
|
apply (simp add: handle_invocation_def ts_Restart_case_helper
|
|
liftE_liftM_liftME liftME_def bindE_assoc)
|
|
apply (wp syscall_valid handle_fault_globals_equiv reply_from_kernel_globals_equiv
|
|
set_thread_state_globals_equiv hoare_vcg_all_lift
|
|
| simp split del: if_split
|
|
| wp (once) hoare_drop_imps)+
|
|
apply (rule_tac Q="\<lambda>r. invs and globals_equiv st and (\<lambda>s. thread \<noteq> idle_thread s)"
|
|
and E="\<lambda>_. globals_equiv st" in hoare_post_impErr)
|
|
apply (wp pinv_invs perform_invocation_globals_equiv
|
|
requiv_get_tcb_eq' set_thread_state_globals_equiv
|
|
sts_authorised_for_globals_inv
|
|
decode_invocation_authorised_globals_inv
|
|
| simp add: crunch_simps invs_imps)+
|
|
apply (auto intro: st_tcb_ex_cap simp: ct_active_not_idle ct_in_state_def)
|
|
done
|
|
|
|
lemma handle_event_globals_equiv:
|
|
"\<lbrace>invs and (\<lambda>s. ev \<noteq> Interrupt \<longrightarrow> ct_active s) and globals_equiv st\<rbrace>
|
|
handle_event ev
|
|
\<lbrace>\<lambda>_. globals_equiv (st :: det_state)\<rbrace>"
|
|
apply (case_tac ev)
|
|
by (wp hoare_weaken_pre[OF receive_ipc_globals_equiv, where P="globals_equiv st and invs"]
|
|
hoare_weaken_pre[OF receive_signal_globals_equiv, where P="globals_equiv st and invs"]
|
|
handle_invocation_globals_equiv handle_fault_globals_equiv' handle_recv_globals_equiv
|
|
handle_reply_globals_equiv handle_interrupt_globals_equiv handle_vm_fault_globals_equiv
|
|
handle_hypervisor_fault_globals_equiv
|
|
| wpc
|
|
| simp add: handle_send_def handle_call_def Let_def
|
|
| wp (once) hoare_drop_imps
|
|
| clarsimp simp: invs_imps invs_valid_idle ct_active_not_idle)+
|
|
|
|
end
|
|
|
|
lemma dmo_ev:
|
|
"(\<And>s s'. equiv_valid (\<lambda>ms ms'. I (s\<lparr>machine_state := ms\<rparr>) (s'\<lparr>machine_state := ms'\<rparr>))
|
|
(\<lambda>ms ms'. A (s\<lparr>machine_state := ms\<rparr>) (s'\<lparr>machine_state := ms'\<rparr>))
|
|
(\<lambda>ms ms'. B (s\<lparr>machine_state := ms\<rparr>) (s'\<lparr>machine_state := ms'\<rparr>))
|
|
(K (P s \<and> P s')) f)
|
|
\<Longrightarrow> equiv_valid I A B P (do_machine_op f)"
|
|
apply (clarsimp simp: do_machine_op_def bind_def equiv_valid_def2 equiv_valid_2_def
|
|
gets_def get_def select_f_def modify_def put_def return_def split_def)
|
|
apply atomize
|
|
apply (erule_tac x=s in allE)
|
|
apply (erule_tac x=t in allE)
|
|
apply simp
|
|
apply (erule_tac x="machine_state s" in allE)
|
|
apply (erule_tac x="machine_state t" in allE)
|
|
apply fastforce
|
|
done
|
|
|
|
lemma ev_modify:
|
|
"(\<And>s t. \<lbrakk>P s; P t; A s t; I s t\<rbrakk> \<Longrightarrow> I (f s) (f t) \<and> B (f s) (f t))
|
|
\<Longrightarrow> equiv_valid I A B P (modify f)"
|
|
by (clarsimp simp: equiv_valid_def2 equiv_valid_2_def simpler_modify_def)
|
|
|
|
end
|