Syscall_AI.thy

(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

(*
Invariant preservation for all syscalls.
*)

theory Syscall_AI
imports
  ArchBCorres2_AI
  ArchTcb_AI
  ArchArch_AI
  ArchInterrupt_AI
begin

arch_requalify_facts (A)
  data_to_cptr_def

arch_requalify_consts
  is_cnode_or_valid_arch
  valid_arch_inv

arch_requalify_facts
  resetTimer_device_state_inv
  arch_decode_invocation_inv
  arch_post_cap_deletion_cur_thread
  arch_post_cap_deletion_state_refs_of
  arch_invoke_irq_handler_typ_at
  invoke_tcb_typ_at
  invoke_arch_tcb
  invoke_arch_invs
  sts_valid_arch_inv
  arch_decode_inv_wf
  arch_pinv_st_tcb_at

lemmas [wp] =
  arch_decode_invocation_inv
  lookup_cap_and_slot_inv
  invoke_arch_invs
  arch_decode_inv_wf

lemmas [simp] =
  data_to_cptr_def

crunch ethread_get, ethread_get_when
  for inv[wp]: P

lemma schedule_invs[wp]: "\<lbrace>invs\<rbrace> (Schedule_A.schedule :: (unit,det_ext) s_monad) \<lbrace>\<lambda>rv. invs\<rbrace>"
  supply if_split[split del]
  apply (simp add: Schedule_A.schedule_def)
  apply (wp dmo_invs thread_get_inv gts_wp
            do_machine_op_tcb when_def hoare_vcg_all_lift
          | wpc
          | clarsimp simp: guarded_switch_to_def get_tcb_def choose_thread_def ethread_get_def
                           ethread_get_when_def
          | wp (once) hoare_drop_imps
          | simp add: schedule_choose_new_thread_def if_apply_def2)+
  done

lemma schedule_choose_new_thread_ct_activatable[wp]:
  "\<lbrace> invs \<rbrace> schedule_choose_new_thread \<lbrace>\<lambda>_. ct_in_state activatable \<rbrace>"
  proof -
  have P: "\<And>t s. ct_in_state activatable (cur_thread_update (\<lambda>_. t) s) = st_tcb_at activatable t s"
    by (fastforce simp: ct_in_state_def st_tcb_at_def intro: obj_at_pspaceI)
  show ?thesis
  unfolding schedule_choose_new_thread_def choose_thread_def guarded_switch_to_def
    apply (simp add: P set_scheduler_action_def guarded_switch_to_def choose_thread_def
                             next_domain_def Let_def tcb_sched_action_def set_tcb_queue_def
                             get_tcb_queue_def ethread_get_def bind_assoc)
    apply (wpsimp wp: stt_activatable stit_activatable gts_wp)+
    apply (force simp: ct_in_state_def pred_tcb_at_def obj_at_def invs_def valid_state_def
                       valid_idle_def split: if_split_asm)+
  done
qed

lemma guarded_switch_to_ct_in_state_activatable[wp]:
  "\<lbrace>\<top>\<rbrace> guarded_switch_to t \<lbrace>\<lambda>a. ct_in_state activatable\<rbrace>"
  unfolding guarded_switch_to_def
  apply (wp stt_activatable)
  apply (wp hoare_vcg_imp_lift gts_wp)+
  apply (clarsimp simp: pred_tcb_at_def obj_at_def)
  done

lemma schedule_ct_activateable[wp]:
  "\<lbrace>invs\<rbrace> (Schedule_A.schedule :: (unit,det_ext) s_monad) \<lbrace>\<lambda>rv. ct_in_state activatable\<rbrace>"
  apply (simp add: Schedule_A.schedule_def)
  apply wp
      apply wpc
        (* resume current thread *)
        apply wp
       prefer 2
       (* choose new thread *)
       apply wp
      (* switch to thread *)
      apply wpsimp
              apply (simp add: set_scheduler_action_def)
              apply (simp | wp gts_wp | wp (once) hoare_drop_imps)+
  apply (frule invs_valid_idle)
  apply (clarsimp simp: ct_in_state_def pred_tcb_at_def obj_at_def valid_idle_def)
  done

lemma syscall_valid:
  assumes x:
             "\<And>ft. \<lbrace>P_flt ft\<rbrace> h_flt ft \<lbrace>Q\<rbrace>"
             "\<And>err. \<lbrace>P_err err\<rbrace> h_err err \<lbrace>Q\<rbrace>"
             "\<And>rv. \<lbrace>P_no_err rv\<rbrace> m_fin rv \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>"
             "\<And>rv. \<lbrace>P_no_flt rv\<rbrace> m_err rv \<lbrace>P_no_err\<rbrace>, \<lbrace>P_err\<rbrace>"
             "\<lbrace>P\<rbrace> m_flt \<lbrace>P_no_flt\<rbrace>, \<lbrace>P_flt\<rbrace>"
  shows "\<lbrace>P\<rbrace> Syscall_A.syscall m_flt h_flt m_err h_err m_fin \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>"
  apply (simp add: Syscall_A.syscall_def liftE_bindE
             cong: sum.case_cong)
  apply (rule hoare_split_bind_case_sumE)
    apply (wp x)[1]
   apply (rule hoare_split_bind_case_sumE)
     apply (wp x|simp)+
  done


(* In order to assert conditions that must hold for the appropriate
   handleInvocation and handle_invocation calls to succeed, we must have
   some notion of what a valid invocation is.
   This function defines that.
   For example, a InvokeEndpoint requires an endpoint at its first
   constructor argument. *)

primrec
  valid_invocation :: "Invocations_A.invocation \<Rightarrow> 'z::state_ext state \<Rightarrow> bool"
where
  "valid_invocation (InvokeUntyped i) = valid_untyped_inv i"
| "valid_invocation (InvokeEndpoint w w2 b gr) = (ep_at w and ex_nonz_cap_to w)"
| "valid_invocation (InvokeNotification w w2) = (ntfn_at w and ex_nonz_cap_to w)"
| "valid_invocation (InvokeTCB i) = Tcb_AI.tcb_inv_wf i"
| "valid_invocation (InvokeDomain thread domain) = (tcb_at thread and (\<lambda>s. thread \<noteq> idle_thread s))"
| "valid_invocation (InvokeReply thread slot grant) =
       (tcb_at thread and cte_wp_at (\<lambda>cap. \<exists> R. cap = ReplyCap thread False R) slot)"
| "valid_invocation (InvokeIRQControl i) = irq_control_inv_valid i"
| "valid_invocation (InvokeIRQHandler i) = irq_handler_inv_valid i"
| "valid_invocation (InvokeCNode i) = valid_cnode_inv i"
| "valid_invocation (InvokeArchObject i) = valid_arch_inv i"


lemma sts_Restart_invs[wp]:
  "\<lbrace>st_tcb_at active t and invs and ex_nonz_cap_to t\<rbrace>
     set_thread_state t Structures_A.Restart
   \<lbrace>\<lambda>rv. invs\<rbrace>"

  apply (wp sts_invs_minor2)
  apply (auto elim!: pred_tcb_weakenE
           notE [rotated, OF _ idle_no_ex_cap]
           simp: invs_def valid_state_def valid_pspace_def)
  done

lemma invoke_tcb_tcb[wp]:
  "\<lbrace>tcb_at tptr\<rbrace> invoke_tcb i \<lbrace>\<lambda>rv. tcb_at tptr\<rbrace>"
  by (simp add: tcb_at_typ invoke_tcb_typ_at [where P=id, simplified])

lemma invoke_domain_tcb[wp]:
  "\<lbrace>tcb_at tptr\<rbrace> invoke_domain thread domain \<lbrace>\<lambda>rv. tcb_at tptr\<rbrace>"
  by (simp add: tcb_at_typ invoke_domain_typ_at [where P=id, simplified])

lemma simple_from_active:
  "st_tcb_at active t s \<Longrightarrow> st_tcb_at simple t s"
  by (fastforce elim!: pred_tcb_weakenE)

lemma simple_from_running:
  "ct_running s \<Longrightarrow> st_tcb_at simple (cur_thread s) s"
  by (fastforce simp: ct_in_state_def
               elim!: pred_tcb_weakenE)

locale Systemcall_AI_Pre =
  fixes proj:: "itcb \<Rightarrow> 'a"
  fixes state_ext_t :: "'state_ext::state_ext itself"
  assumes handle_arch_fault_reply_pred_tcb_at[wp]:
    "\<And> P t f obj d dl.
      \<lbrace> pred_tcb_at proj P t :: 'state_ext state \<Rightarrow> _\<rbrace>
        handle_arch_fault_reply f obj d dl
      \<lbrace> \<lambda>_ . pred_tcb_at proj P t \<rbrace>"
  assumes handle_arch_fault_reply_invs[wp]:
    "\<And> f obj d dl.
      \<lbrace> invs :: 'state_ext state \<Rightarrow> _ \<rbrace> handle_arch_fault_reply f obj d dl \<lbrace> \<lambda>_ . invs \<rbrace>"
  assumes handle_arch_fault_reply_cap_to[wp]:
    "\<And> f obj d dl c.
      \<lbrace> ex_nonz_cap_to c :: 'state_ext state \<Rightarrow> _ \<rbrace>
        handle_arch_fault_reply f obj d dl
      \<lbrace> \<lambda>_ . ex_nonz_cap_to c \<rbrace>"
  assumes handle_arch_fault_reply_it[wp]:
    "\<And> P f obj d dl.
      \<lbrace> \<lambda>s :: 'state_ext state. P (idle_thread s) \<rbrace>
        handle_arch_fault_reply f obj d dl
      \<lbrace> \<lambda>_ s. P (idle_thread s) \<rbrace>"
  assumes handle_arch_fault_reply_caps[wp]:
    "\<And> P f obj d dl.
      \<lbrace> \<lambda>s  :: 'state_ext state . P (caps_of_state s) \<rbrace>
        handle_arch_fault_reply f obj d dl
      \<lbrace> \<lambda>_ s. P (caps_of_state s) \<rbrace>"
  assumes handle_arch_fault_reply_cte_wp_at[wp]:
     "\<And> P P' p x4 t d dl.
       \<lbrace>\<lambda>s ::'state_ext state . P (cte_wp_at P' p s)\<rbrace>
         handle_arch_fault_reply x4 t d dl
       \<lbrace>\<lambda>_ s. P (cte_wp_at P' p s)\<rbrace>"
  assumes handle_arch_fault_reply_cur_thread[wp]:
    "\<And> P  x4 t d dl.
       \<lbrace>\<lambda>s ::'state_ext state . P (cur_thread s)\<rbrace>
         handle_arch_fault_reply x4 t d dl
       \<lbrace>\<lambda>_ s. P (cur_thread s)\<rbrace>"
  assumes handle_arch_fault_st_tcb_at_simple[wp]:
    "\<And> x4 t' t d dl.
       \<lbrace>st_tcb_at simple t' :: 'state_ext state \<Rightarrow> _\<rbrace>
         handle_arch_fault_reply x4 t d dl
       \<lbrace>\<lambda>_ .st_tcb_at simple t'\<rbrace>"
  assumes handle_arch_fault_valid_objs[wp]:
    "\<And> x4 t d dl.
       \<lbrace> valid_objs :: 'state_ext state \<Rightarrow> _\<rbrace>
         handle_arch_fault_reply x4 t d dl
       \<lbrace>\<lambda>_ .valid_objs\<rbrace>"
  assumes arch_get_sanitise_register_info_pred_tcb_at[wp]:
    "\<And> P t g.
      \<lbrace> pred_tcb_at proj P t :: 'state_ext state \<Rightarrow> _\<rbrace>
        arch_get_sanitise_register_info g
      \<lbrace> \<lambda>_ . pred_tcb_at proj P t \<rbrace>"
  assumes arch_get_sanitise_register_info_invs[wp]:
    "\<And> f.
      \<lbrace> invs :: 'state_ext state \<Rightarrow> _ \<rbrace> arch_get_sanitise_register_info f  \<lbrace> \<lambda>_ . invs \<rbrace>"
  assumes arch_get_sanitise_register_info_cap_to[wp]:
    "\<And> f c.
      \<lbrace> ex_nonz_cap_to c :: 'state_ext state \<Rightarrow> _ \<rbrace>
        arch_get_sanitise_register_info f
      \<lbrace> \<lambda>_ . ex_nonz_cap_to c \<rbrace>"
  assumes arch_get_sanitise_register_info_it[wp]:
    "\<And> P f .
      \<lbrace> \<lambda>s :: 'state_ext state. P (idle_thread s) \<rbrace>
        arch_get_sanitise_register_info f
      \<lbrace> \<lambda>_ s. P (idle_thread s) \<rbrace>"
  assumes arch_get_sanitise_register_info_caps[wp]:
    "\<And> P f .
      \<lbrace> \<lambda>s  :: 'state_ext state . P (caps_of_state s) \<rbrace>
        arch_get_sanitise_register_info f
      \<lbrace> \<lambda>_ s. P (caps_of_state s) \<rbrace>"
  assumes arch_get_sanitise_register_info_cte_wp_at[wp]:
     "\<And> P P' p x4.
       \<lbrace>\<lambda>s ::'state_ext state . P (cte_wp_at P' p s)\<rbrace>
         arch_get_sanitise_register_info x4
       \<lbrace>\<lambda>_ s. P (cte_wp_at P' p s)\<rbrace>"
  assumes arch_get_sanitise_register_info_cur_thread[wp]:
    "\<And> P  x4.
       \<lbrace>\<lambda>s ::'state_ext state . P (cur_thread s)\<rbrace>
         arch_get_sanitise_register_info x4
       \<lbrace>\<lambda>_ s. P (cur_thread s)\<rbrace>"
  assumes arch_get_sanitise_register_info_st_tcb_at_simple[wp]:
    "\<And> x4 t'.
       \<lbrace>st_tcb_at simple t' :: 'state_ext state \<Rightarrow> _\<rbrace>
         arch_get_sanitise_register_info x4
       \<lbrace>\<lambda>_ .st_tcb_at simple t'\<rbrace>"
  assumes arch_get_sanitise_register_info_valid_objs[wp]:
    "\<And> x4.
       \<lbrace> valid_objs :: 'state_ext state \<Rightarrow> _\<rbrace>
         arch_get_sanitise_register_info x4
       \<lbrace>\<lambda>_ .valid_objs\<rbrace>"

begin

crunch handle_fault_reply
  for pred_tcb_at[wp]: "pred_tcb_at proj (P :: 'a \<Rightarrow> _) t :: 'state_ext state \<Rightarrow> _"
crunch handle_fault_reply
  for invs[wp]: "invs :: 'state_ext state \<Rightarrow> _"
crunch handle_fault_reply
  for cap_to[wp]: "ex_nonz_cap_to c :: 'state_ext state \<Rightarrow> _"
crunch handle_fault_reply
  for it[wp]: "\<lambda>s :: 'state_ext state. P (idle_thread s) "
crunch handle_fault_reply
  for caps[wp]: "\<lambda>s :: 'state_ext state. P (caps_of_state s)"

end

lemma st_tcb_at_eq:
  "\<lbrakk> st_tcb_at (\<lambda>s. s = st) t s; st_tcb_at (\<lambda>s. s = st') t s \<rbrakk> \<Longrightarrow> st = st'"
  by (clarsimp simp add: pred_tcb_at_def obj_at_def)

lemma do_ipc_transfer_tcb_at [wp]:
  "\<lbrace>\<lambda>s. P (tcb_at t s)\<rbrace> do_ipc_transfer s ep bg grt r \<lbrace>\<lambda>rv s. P (tcb_at t s)\<rbrace>"
  by (simp add: tcb_at_typ) wp

lemma do_ipc_transfer_emptyable[wp]:
  "\<lbrace>emptyable sl\<rbrace> do_ipc_transfer sender ep badge grant receiver \<lbrace>\<lambda>_. emptyable sl\<rbrace>"
  apply (clarsimp simp add: emptyable_def)
  apply (wp hoare_convert_imp | clarsimp)+
  done

lemma do_ipc_transfer_non_null_cte_wp_at2:
  fixes P
  assumes PNN: "\<And>cap. P cap \<Longrightarrow> cap \<noteq> cap.NullCap"
  assumes PUC: "\<And>cap. P cap \<Longrightarrow> \<not> is_untyped_cap cap"
  shows "\<lbrace>valid_objs and cte_wp_at P ptr\<rbrace> do_ipc_transfer st ep b gr rt \<lbrace>\<lambda>_. cte_wp_at P ptr\<rbrace>"
  proof -
    have PimpQ: "\<And>P Q ptr s. \<lbrakk> cte_wp_at P ptr s; \<And>cap. P cap \<Longrightarrow> Q cap \<rbrakk> \<Longrightarrow> cte_wp_at (P and Q) ptr s"
      by (erule cte_wp_at_weakenE, clarsimp)
    show ?thesis
      apply (rule hoare_chain [OF do_ipc_transfer_non_null_cte_wp_at])
       apply (erule PUC)
       apply (clarsimp )
       apply (erule PimpQ)
       apply (drule PNN, clarsimp)
      apply (erule cte_wp_at_weakenE)
      apply (clarsimp)
      done
  qed


lemma thread_set_cap_to:
  "(\<And>tcb. \<forall>(getF, v)\<in>ran tcb_cap_cases. getF (f tcb) = getF tcb)
  \<Longrightarrow> \<lbrace>ex_nonz_cap_to p\<rbrace> thread_set f tptr \<lbrace>\<lambda>_. ex_nonz_cap_to p\<rbrace>"
  apply (clarsimp simp add: ex_nonz_cap_to_def)
  apply (wpsimp wp: hoare_vcg_ex_lift thread_set_cte_wp_at_trivial
    | fast)+
  done


lemma thread_set_has_no_reply_cap:
  "(\<And>tcb. \<forall>(getF, v)\<in>ran tcb_cap_cases. getF (f tcb) = getF tcb)
  \<Longrightarrow> \<lbrace>\<lambda>s. \<not>has_reply_cap tt s\<rbrace> thread_set f t \<lbrace>\<lambda>_ s. \<not>has_reply_cap tt s\<rbrace>"
  apply (clarsimp simp add: has_reply_cap_def)
  apply (wpsimp wp: hoare_vcg_all_lift thread_set_cte_wp_at_trivial
    | fast)+
  done

lemma (in Systemcall_AI_Pre) handle_fault_reply_cte_wp_at:
  "\<lbrace>\<lambda>s :: 'state_ext state. P (cte_wp_at P' p s)\<rbrace>
     handle_fault_reply f t d dl
   \<lbrace>\<lambda>_ s. P (cte_wp_at P' p s)\<rbrace>"
  proof -
    have SC:
      "\<And>p' s tcb nc. get_tcb p' s = Some tcb
       \<Longrightarrow> obj_at (same_caps (TCB (tcb \<lparr>tcb_arch := arch_tcb_context_set nc (tcb_arch tcb)\<rparr>))) p' s"
      apply (drule get_tcb_ko_at [THEN iffD1])
      apply (erule ko_at_weakenE)
      apply (clarsimp simp add: tcb_cap_cases_def)
      done
    have NC:
      "\<And>p' s tcb P nc. get_tcb p' s = Some tcb
      \<Longrightarrow> cte_wp_at P p (s\<lparr>kheap := (kheap s)(p' \<mapsto> TCB (tcb\<lparr>tcb_arch := arch_tcb_context_set nc (tcb_arch tcb)\<rparr>))\<rparr>)
          = cte_wp_at P p s"
      apply (drule_tac nc=nc in SC)
      apply (drule_tac P=P and p=p in cte_wp_at_after_update)
      apply (drule sym)
      apply (clarsimp)
      apply (rule_tac x="s \<lparr> kheap := p \<rparr>" for p in arg_cong)
      apply (clarsimp)
      done
    show ?thesis
      apply (case_tac f; clarsimp simp: as_user_def)
       apply (wp set_object_wp thread_get_wp' | simp add: split_def NC | wp (once) hoare_drop_imps)+
      done
  qed


lemma (in Systemcall_AI_Pre) handle_fault_reply_has_no_reply_cap:
  "\<lbrace>\<lambda>s :: 'state_ext state. \<not>has_reply_cap t s\<rbrace> handle_fault_reply f t d dl \<lbrace>\<lambda>_ s. \<not>has_reply_cap t s\<rbrace>"
  apply (clarsimp simp add: has_reply_cap_def)
  apply (wpsimp wp: hoare_vcg_all_lift handle_fault_reply_cte_wp_at)
  done

locale Systemcall_AI_Pre2 = Systemcall_AI_Pre itcb_state state_ext_t
  for state_ext_t :: "'state_ext::state_ext itself"

lemma (in Systemcall_AI_Pre2) do_reply_invs[wp]:
  "\<lbrace>tcb_at t and tcb_at t' and cte_wp_at (is_reply_cap_to t) slot and
    invs\<rbrace>
     do_reply_transfer t' t slot grant
   \<lbrace>\<lambda>rv. invs :: 'state_ext state \<Rightarrow> _\<rbrace>"
  apply (simp add: do_reply_transfer_def is_reply_cap_to_def)
  apply (wp | wpc |simp)+
        apply (wp sts_invs_minor)
       apply (clarsimp)
       apply (wp cap_delete_one_st_tcb_at)
       apply (rule_tac Q'="\<lambda>_. invs and if_live_then_nonz_cap and
                                st_tcb_at awaiting_reply t and
                                (\<lambda>s. \<not>has_reply_cap t s)"
                    in hoare_strengthen_post[rotated])
        apply (clarsimp)
        apply (rule conjI, erule(1) st_tcb_ex_cap, clarsimp)
        apply (rule conjI)
         apply (clarsimp simp add: invs_def valid_state_def valid_idle_def)
         apply (drule st_tcb_at_eq, erule pred_tcb_weaken_strongerE, simp)
         apply (clarsimp)
        apply (rule disjI1)
        apply (erule pred_tcb_weakenE)
        apply (clarsimp)
       apply (rule_tac Q'="\<lambda>_. invs and st_tcb_at awaiting_reply t and (\<lambda>s. \<not>has_reply_cap t s)"
                    in hoare_strengthen_post[rotated], clarsimp)
       apply (wp cap_delete_one_reply_st_tcb_at cap_delete_one_deletes_reply | simp)+
      apply (rule_tac Q'="\<lambda>_. valid_reply_caps and cte_wp_at (is_reply_cap_to t) slot"
                   in hoare_strengthen_post[rotated], clarsimp)
       apply (erule cte_wp_at_weakenE, simp)
      apply (wp)
      apply (rule do_ipc_transfer_non_null_cte_wp_at2, clarsimp simp add: is_reply_cap_to_def)
      apply (clarsimp simp: is_cap_simps is_reply_cap_to_def)
     apply (wp sts_invs_minor | simp split del: if_split)+
          apply (wp sts_invs_minor thread_set_no_change_tcb_state)
           apply (clarsimp)
          apply (clarsimp)
          apply (rule conjI)
           apply (clarsimp)
           apply (wp thread_set_cap_to thread_set_it |
                  clarsimp simp add: tcb_cap_cases_def)+
           apply (rule_tac Q'="\<lambda>_. invs and st_tcb_at awaiting_reply t and (\<lambda>s. \<not>has_reply_cap t s)"
                        in hoare_strengthen_post[rotated])
            apply (clarsimp)
            apply (erule pred_tcb_weakenE)
            apply (clarsimp)
           apply (wp thread_set_invs_trivial thread_set_no_change_tcb_state
                     thread_set_has_no_reply_cap | clarsimp simp add: tcb_cap_cases_def)+
         apply (rule_tac Q'="\<lambda>_. st_tcb_at (\<lambda>s. tcb_st_refs_of s = {}) t and invs and
                                 st_tcb_at awaiting_reply t and (\<lambda>s. \<not>has_reply_cap t s)"
                      in hoare_strengthen_post[rotated])
          apply (clarsimp)
          apply (rule conjI)
           apply (erule(1) st_tcb_ex_cap'[where P=awaiting_reply])
           apply (clarsimp)
          apply (clarsimp simp add: invs_def valid_state_def valid_idle_def)
          apply (drule st_tcb_at_eq, erule pred_tcb_weaken_strongerE, simp)
          apply clarsimp
         apply (wp handle_fault_reply_has_no_reply_cap)
     apply (rule_tac Q'="\<lambda>_. st_tcb_at awaiting_reply t and invs and
                         (\<lambda>s. \<not>has_reply_cap t s)" in hoare_strengthen_post[rotated])
      apply (clarsimp)
      apply (erule pred_tcb_weakenE)
      apply (clarsimp)
     apply (wp cap_delete_one_deletes_reply cap_delete_one_reply_st_tcb_at)+
    apply (clarsimp)
    apply (wp hoare_drop_imp hoare_allI)[1]
   apply (wp assert_wp)
  apply (clarsimp)
  apply (rule_tac Q'="\<lambda>rv. st_tcb_at ((=) rv) t and tcb_at t' and invs and
                           emptyable slot and cte_wp_at (is_reply_cap_to t) slot"
               in hoare_strengthen_post[rotated])
   apply (clarsimp simp add: st_tcb_at_tcb_at)
   apply (rule conjI, erule pred_tcb_weakenE, clarsimp)+
   apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def)
   apply (rule conjI, erule pred_tcb_weakenE, clarsimp)
   apply (assumption)
  apply (wp gts_sp)
   apply (clarsimp simp add:is_reply_cap_to_def)+
   apply (erule emptyable_cte_wp_atD)
    apply (clarsimp simp add: invs_def valid_state_def is_master_reply_cap_def)+
  done


lemmas si_invs[wp] = si_invs'[where Q=\<top>,OF hoare_TrueI hoare_TrueI hoare_TrueI hoare_TrueI,simplified]

lemma (in Systemcall_AI_Pre2) pinv_invs[wp]:
  "\<lbrace>invs and ct_active and valid_invocation i\<rbrace>
    perform_invocation blocking call i \<lbrace>\<lambda>rv. invs :: 'state_ext state \<Rightarrow> _\<rbrace>"
  apply (case_tac i, simp_all)
       apply (wp tcbinv_invs send_signal_interrupt_states invoke_domain_invs
         | clarsimp simp:ct_in_state_def is_reply_cap_to_def
         | erule st_tcb_ex_cap
         | fastforce simp:ct_in_state_def is_reply_cap_to_def | rule conjI)+
  done


crunch do_reply_transfer
  for typ_at[wp]: "\<lambda>s. P (typ_at T p s)"
  (wp: hoare_drop_imps)

crunch invoke_irq_handler
  for typ_at[wp]: "\<lambda>s. P (typ_at T p s)"


locale Syscall_AI = Systemcall_AI_Pre:Systemcall_AI_Pre _ state_ext_t
                  + Systemcall_AI_Pre2 state_ext_t
  for state_ext_t :: "'state_ext::state_ext itself" +
  assumes invoke_irq_control_typ_at[wp]:
    "\<And>P T p irq_inv.
      \<lbrace>\<lambda>s::'state_ext state. P (typ_at T p s)\<rbrace> invoke_irq_control irq_inv \<lbrace>\<lambda>_ s. P (typ_at T p s)\<rbrace>"
  assumes obj_refs_cap_rights_update[simp]:
    "\<And>rs cap. obj_refs (cap_rights_update rs cap) = obj_refs cap"
  assumes table_cap_ref_mask_cap:
    "\<And>R cap. table_cap_ref (mask_cap R cap) = table_cap_ref cap"
  assumes eq_no_cap_to_obj_with_diff_ref:
    "\<And>cap p (s::'state_ext state) S.
      \<lbrakk> cte_wp_at ((=) cap) p s; valid_arch_caps s \<rbrakk>
        \<Longrightarrow> no_cap_to_obj_with_diff_ref cap S s"
  assumes hv_invs[wp]:
    "\<And>t' flt. \<lbrace>invs :: 'state_ext state \<Rightarrow> bool\<rbrace> handle_vm_fault t' flt \<lbrace>\<lambda>r. invs\<rbrace>"
  assumes handle_vm_fault_valid_fault[wp]:
    "\<And>thread ft.
      \<lbrace>\<top>::'state_ext state \<Rightarrow> bool\<rbrace> handle_vm_fault thread ft -,\<lbrace>\<lambda>rv s. valid_fault rv\<rbrace>"
  assumes hvmf_active:
    "\<And>t w.
      \<lbrace>st_tcb_at active t::'state_ext state \<Rightarrow> bool\<rbrace> handle_vm_fault t w \<lbrace>\<lambda>rv. st_tcb_at active t\<rbrace>"
  assumes hvmf_ex_cap[wp]:
    "\<And>p t b.
      \<lbrace>ex_nonz_cap_to p::'state_ext state \<Rightarrow> bool\<rbrace> handle_vm_fault t b \<lbrace>\<lambda>rv. ex_nonz_cap_to p\<rbrace>"
  assumes hh_invs[wp]:
  "\<And>thread fault.
    \<lbrace>invs and ct_active and st_tcb_at active thread and ex_nonz_cap_to thread\<rbrace>
      handle_hypervisor_fault thread fault
    \<lbrace>\<lambda>rv. invs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
  assumes make_fault_msg_cur_thread[wp]:
    "\<And>ft t. make_fault_msg ft t \<lbrace>\<lambda>s :: 'state_ext state. P (cur_thread s)\<rbrace>"




context Syscall_AI begin

lemma pinv_tcb[wp]:
  "\<And>tptr blocking call i.
    \<lbrace>invs and st_tcb_at active tptr and ct_active and valid_invocation i\<rbrace>
      perform_invocation blocking call i
    \<lbrace>\<lambda>rv. tcb_at tptr :: 'state_ext state \<Rightarrow> bool\<rbrace>"
  apply (case_tac i, simp_all split:option.splits,
    (wp invoke_arch_tcb
              | simp | clarsimp elim!: st_tcb_at_tcb_at
              | wp (once) tcb_at_typ_at)+
    )
  done

end


lemmas sts_typ_at = set_thread_state_typ_at [where P="\<lambda>x. x"]

lemma cte_wp_cdt_lift:
  assumes c: "\<And>P. \<lbrace>cte_wp_at P p\<rbrace> f \<lbrace>\<lambda>r. cte_wp_at P p\<rbrace>"
  assumes m: "\<And>P. \<lbrace>\<lambda>s. P (cdt s)\<rbrace> f \<lbrace>\<lambda>r s. P (cdt s)\<rbrace>"
  shows "\<lbrace>\<lambda>s. cte_wp_at (P (cdt s)) p s\<rbrace> f \<lbrace>\<lambda>r s. cte_wp_at (P (cdt s)) p s\<rbrace>"
  apply (clarsimp simp add: valid_def)
  apply (frule_tac P1="(=) (cdt s)" in use_valid [OF _  m], rule refl)
  apply simp
  apply (erule use_valid [OF _ c])
  apply simp
  done

lemma sts_cte_wp_cdt [wp]:
  "\<lbrace>\<lambda>s. cte_wp_at (P (cdt s)) p s\<rbrace>
  set_thread_state t st
  \<lbrace>\<lambda>rv s. cte_wp_at (P (cdt s)) p s\<rbrace>"
  by (rule cte_wp_cdt_lift; wp)

lemma sts_nasty_bit:
  shows
  "\<lbrace>\<lambda>s. \<forall>r\<in>obj_refs cap. \<forall>a b. ptr' \<noteq> (a, b) \<and> cte_wp_at (\<lambda>cap'. r \<in> obj_refs cap') (a, b) s
              \<longrightarrow> cte_wp_at (Not \<circ> is_zombie) (a, b) s \<and> \<not> is_zombie cap\<rbrace>
     set_thread_state t st
   \<lbrace>\<lambda>rv s. \<forall>r\<in>obj_refs cap. \<forall>a b. ptr' \<noteq> (a, b) \<and> cte_wp_at (\<lambda>cap'. r \<in> obj_refs cap') (a, b) s
              \<longrightarrow> cte_wp_at (Not \<circ> is_zombie) (a, b) s \<and> \<not> is_zombie cap\<rbrace>"
  apply (intro hoare_vcg_const_Ball_lift hoare_vcg_all_lift)
  apply (wpsimp wp: hoare_vcg_const_Ball_lift hoare_vcg_all_lift
            hoare_vcg_imp_lift hoare_vcg_disj_lift valid_cte_at_neg_typ
          | simp add: cte_wp_at_neg2[where P="\<lambda>c. x \<in> obj_refs c" for x])+
  apply (clarsimp simp: o_def cte_wp_at_def)
  done

crunch set_thread_state
  for is_original_cap[wp]: "\<lambda>s. P (is_original_cap s)"

lemma sts_no_cap_asid[wp]:
  "\<lbrace>no_cap_to_obj_with_diff_ref cap S\<rbrace>
     set_thread_state t st
   \<lbrace>\<lambda>rv. no_cap_to_obj_with_diff_ref cap S\<rbrace>"
  by (simp add: no_cap_to_obj_with_diff_ref_def
                cte_wp_at_caps_of_state, wp)

lemma sts_mcpriority_tcb_at[wp]:
  "\<lbrace>mcpriority_tcb_at P t\<rbrace> set_thread_state p ts \<lbrace>\<lambda>rv. mcpriority_tcb_at P t\<rbrace>"
  apply (simp add: set_thread_state_def set_object_def get_object_def)
  apply (wp | simp)+
  apply (clarsimp simp: pred_tcb_at_def obj_at_def)
  apply (drule get_tcb_SomeD)
  apply clarsimp
  done

lemma sts_mcpriority_tcb_at_ct[wp]:
  "\<lbrace>\<lambda>s. mcpriority_tcb_at P (cur_thread s) s\<rbrace> set_thread_state p ts \<lbrace>\<lambda>rv s. mcpriority_tcb_at P (cur_thread s) s\<rbrace>"
  apply (simp add: set_thread_state_def set_object_def get_object_def)
  apply (wp | simp)+
  apply (clarsimp simp: pred_tcb_at_def obj_at_def)
  apply (drule get_tcb_SomeD)
  apply clarsimp
  done


lemma sts_tcb_inv_wf [wp]:
  "\<lbrace>tcb_inv_wf i\<rbrace> set_thread_state t st \<lbrace>\<lambda>rv. tcb_inv_wf i\<rbrace>"
  apply (case_tac i)
  by (wp set_thread_state_valid_cap hoare_vcg_all_lift hoare_vcg_const_imp_lift
         | simp add: tcb_at_typ split: option.split
         | safe
         | wp sts_obj_at_impossible)+


lemma sts_valid_inv[wp]:
  "\<lbrace>valid_invocation i\<rbrace> set_thread_state t st \<lbrace>\<lambda>rv. valid_invocation i\<rbrace>"
  by (cases i; wpsimp simp: sts_valid_untyped_inv sts_valid_arch_inv;
      rename_tac i'; case_tac i'; simp;
      wpsimp wp: set_thread_state_valid_cap sts_nasty_bit
                 sts_nasty_bit[where ptr'="(p_a, p_b)" for p_a p_b, simplified]
                 hoare_vcg_const_imp_lift hoare_vcg_ex_lift;
      auto)

lemma sts_Restart_stay_simple:
  "\<lbrace>st_tcb_at simple t\<rbrace>
     set_thread_state t' Structures_A.Restart
   \<lbrace>\<lambda>rv. st_tcb_at simple t\<rbrace>"
  apply (rule hoare_pre)
   apply (wp sts_st_tcb_at_cases)
  apply simp
  done

lemma decode_inv_inv[wp]:
  notes if_split [split del]
  shows
  "\<lbrace>P\<rbrace> decode_invocation label args cap_index slot cap excaps \<lbrace>\<lambda>rv. P\<rbrace>"
  apply (case_tac cap, simp_all add: decode_invocation_def,
    (wpsimp wp: decode_tcb_inv_inv decode_domain_inv_inv)+)
  done

lemma cnode_eq_strg:
  "(\<exists>ptr. cte_wp_at ((=) cap) ptr s)
    \<longrightarrow> (is_cnode_cap cap \<longrightarrow> (\<forall>ref \<in> cte_refs cap (interrupt_irq_node s).
                                    ex_cte_cap_wp_to is_cnode_cap ref s))"
  apply (clarsimp simp: ex_cte_cap_wp_to_def)
  by (intro exI, erule cte_wp_at_weakenE, simp)


lemma invs_valid_arch_caps[elim!]:
  "invs s \<Longrightarrow> valid_arch_caps s"
  by (clarsimp simp: invs_def valid_state_def)


context Syscall_AI begin

lemma decode_inv_wf[wp]:
  "\<lbrace>valid_cap cap and invs and cte_wp_at ((=) cap) slot
           and real_cte_at slot
           and ex_cte_cap_to slot
           and (\<lambda>s::'state_ext state. \<forall>r\<in>zobj_refs cap. ex_nonz_cap_to r s)
           and (\<lambda>s. \<forall>r\<in>cte_refs cap (interrupt_irq_node s). ex_cte_cap_to r s)
           and (\<lambda>s. \<forall>cap \<in> set excaps. \<forall>r\<in>cte_refs (fst cap) (interrupt_irq_node s). ex_cte_cap_to r s)
           and (\<lambda>s. \<forall>x \<in> set excaps. s \<turnstile> (fst x))
           and (\<lambda>s. \<forall>x \<in> set excaps. \<forall>r\<in>zobj_refs (fst x). ex_nonz_cap_to r s)
           and (\<lambda>s. \<forall>x \<in> set excaps. cte_wp_at ((=) (fst x)) (snd x) s)
           and (\<lambda>s. \<forall>x \<in> set excaps. real_cte_at (snd x) s)
           and (\<lambda>s. \<forall>x \<in> set excaps. ex_cte_cap_wp_to is_cnode_cap (snd x) s)
           and (\<lambda>s. \<forall>x \<in> set excaps. cte_wp_at (interrupt_derived (fst x)) (snd x) s)\<rbrace>
     decode_invocation label args cap_index slot cap excaps
   \<lbrace>valid_invocation\<rbrace>,-"
  apply (simp add: decode_invocation_def cong: cap.case_cong if_cong split del: if_split)
  apply (rule hoare_pre)
   apply (wp Tcb_AI.decode_tcb_inv_wf decode_domain_inv_wf[simplified split_def] | wpc |
          simp add: o_def uncurry_def split_def del: is_cnode_cap.simps cte_refs.simps)+
  apply (strengthen cnode_eq_strg)
  apply (clarsimp simp: valid_cap_def cte_wp_at_eq_simp is_cap_simps
                        cap_rights_update_def ex_cte_cap_wp_to_weakenE[OF _ TrueI]
                        cte_wp_at_caps_of_state
                 split: cap.splits option.splits)
       apply (thin_tac " \<forall>x\<in>set excaps. P x \<and> Q x" for P Q)+
       apply (drule (1) bspec)+
       apply (subst split_paired_Ex[symmetric], rule exI, simp)
      apply (thin_tac " \<forall>x\<in>set excaps. P x \<and> Q x" for P Q)+
      apply (rule conjI)
       apply (subst split_paired_Ex[symmetric], rule_tac x=slot in exI, simp)
      apply clarsimp
      apply (drule (1) bspec)+
      apply (subst split_paired_Ex[symmetric], rule exI, simp)
     apply (thin_tac " \<forall>x\<in>set excaps. P x \<and> Q x" for P Q)+
     apply (drule (1) bspec)+
     apply (clarsimp simp add: ex_cte_cap_wp_to_weakenE[OF _ TrueI])
     apply (rule eq_no_cap_to_obj_with_diff_ref)
      apply (fastforce simp add: cte_wp_at_caps_of_state)
     apply (simp add: invs_valid_arch_caps)
    apply (simp add: invs_valid_objs invs_valid_global_refs)
   apply (thin_tac " \<forall>x\<in>set excaps. P x \<and> Q x" for P Q)+
   apply (drule (1) bspec)+
   apply (subst split_paired_Ex[symmetric], rule exI, simp)
  apply (thin_tac " \<forall>x\<in>set excaps. P x \<and> Q x" for P Q)+
  apply (subst split_paired_Ex[symmetric], rule exI, simp)
  done

end

lemma lcs_valid [wp]:
  "\<lbrace>invs\<rbrace> lookup_cap_and_slot t xs \<lbrace>\<lambda>x s. s \<turnstile> fst x\<rbrace>, -"
  unfolding lookup_cap_and_slot_def
  apply (rule hoare_pre)
   apply (wp|clarsimp simp: split_def)+
  done

lemma lec_valid_cap [wp]:
  "\<lbrace>invs\<rbrace> lookup_extra_caps t xa mi \<lbrace>\<lambda>rv s. (\<forall>x\<in>set rv. s \<turnstile> fst x)\<rbrace>, -"
  unfolding lookup_extra_caps_def
  by (wpsimp wp: mapME_set)

lemma lcs_ex_cap_to [wp]:
  "\<lbrace>invs\<rbrace> lookup_cap_and_slot t xs \<lbrace>\<lambda>x s. \<forall>r\<in>cte_refs (fst x) (interrupt_irq_node s). ex_cte_cap_to r s\<rbrace>, -"
  unfolding lookup_cap_and_slot_def by wpsimp

lemma lcs_ex_nonz_cap_to [wp]:
  "\<lbrace>invs\<rbrace> lookup_cap_and_slot t xs \<lbrace>\<lambda>x s. \<forall>r\<in>zobj_refs (fst x). ex_nonz_cap_to r s\<rbrace>, -"
  unfolding lookup_cap_and_slot_def by wpsimp

lemma lcs_cte_at[wp]:
  "\<lbrace>valid_objs\<rbrace> lookup_cap_and_slot t xs \<lbrace>\<lambda>rv. cte_at (snd rv)\<rbrace>,-"
  apply (simp add: lookup_cap_and_slot_def split_def)
  apply (wp | simp)+
  done

lemma lcs_real_cte_at[wp]:
  "\<lbrace>valid_objs\<rbrace> lookup_cap_and_slot t xs \<lbrace>\<lambda>rv. real_cte_at (snd rv)\<rbrace>,-"
  by (wpsimp simp: lookup_cap_and_slot_def split_def)

lemma lec_ex_cap_to [wp]:
  "\<lbrace>invs\<rbrace>
  lookup_extra_caps t xa mi
  \<lbrace>\<lambda>rv s. (\<forall>cap \<in> set rv. \<forall>r\<in>cte_refs (fst cap) (interrupt_irq_node s). ex_cte_cap_to r s)\<rbrace>, -"
  unfolding lookup_extra_caps_def
  by (wp mapME_set | simp)+

lemma lec_ex_nonz_cap_to [wp]:
  "\<lbrace>invs\<rbrace>
  lookup_extra_caps t xa mi
  \<lbrace>\<lambda>rv s. (\<forall>cap \<in> set rv. \<forall>r\<in>zobj_refs (fst cap). ex_nonz_cap_to r s)\<rbrace>, -"
  unfolding lookup_extra_caps_def
  by (wp mapME_set | simp)+

lemma lookup_extras_real_ctes[wp]:
  "\<lbrace>valid_objs\<rbrace> lookup_extra_caps t xs info \<lbrace>\<lambda>rv s. \<forall>x \<in> set rv. real_cte_at (snd x) s\<rbrace>,-"
  apply (simp add: lookup_extra_caps_def
              split del: if_split)
  apply (rule hoare_pre)
   apply (wp mapME_set)
      apply (simp add: lookup_cap_and_slot_def split_def)
      apply (wp case_options_weak_wp mapM_wp'
                 | simp add: load_word_offs_word_def)+
  done

lemma lookup_extras_ctes[wp]:
  "\<lbrace>valid_objs\<rbrace> lookup_extra_caps t xs info \<lbrace>\<lambda>rv s. \<forall>x \<in> set rv. cte_at (snd x) s\<rbrace>,-"
  apply (rule hoare_strengthen_postE_R)
   apply (rule lookup_extras_real_ctes)
  apply (simp add: real_cte_at_cte)
  done

lemma lsft_ex_cte_cap_to:
  "\<lbrace>invs and K (\<forall>cap. is_cnode_cap cap \<longrightarrow> P cap)\<rbrace>
     lookup_slot_for_thread t cref
   \<lbrace>\<lambda>rv s. ex_cte_cap_wp_to P (fst rv) s\<rbrace>,-"
  apply (simp add: lookup_slot_for_thread_def)
  apply (wp rab_cte_cap_to)
  apply (clarsimp simp: ex_cte_cap_wp_to_def)
  apply (clarsimp dest!: get_tcb_SomeD)
  apply (frule cte_wp_at_tcbI[where t="(t', tcb_cnode_index 0)" and P="(=) v" for t' v, simplified])
    apply fastforce
   apply fastforce
  apply (intro exI, erule cte_wp_at_weakenE)
  apply clarsimp
  done

(* FIXME: move / generalize lemma in GenericLib *)
lemma mapME_wp:
  assumes x: "\<And>x. x \<in> S \<Longrightarrow> \<lbrace>P\<rbrace> f x \<lbrace>\<lambda>_. P\<rbrace>, \<lbrace>E\<rbrace>"
  shows      "set xs \<subseteq> S \<Longrightarrow> \<lbrace>P\<rbrace> mapME f xs \<lbrace>\<lambda>_. P\<rbrace>, \<lbrace>E\<rbrace>"
  apply (induct xs)
   apply (simp add: mapME_def sequenceE_def)
   apply wp
  apply (simp add: mapME_Cons)
  apply (wpsimp wp: x|assumption)+
  done

lemmas mapME_wp' = mapME_wp [OF _ subset_refl]

(* FIXME: move to CSpace_R *)
lemma resolve_address_bits_valid_fault:
  "\<lbrace> valid_objs and valid_cap (fst param)\<rbrace>
   resolve_address_bits param
   \<lbrace>\<lambda>_. valid_objs\<rbrace>,
   \<lbrace>\<lambda>f s. valid_fault (ExceptionTypes_A.fault.CapFault x y f)\<rbrace>"
unfolding resolve_address_bits_def
proof (induct param rule: resolve_address_bits'.induct)
  case (1 cap cref)
  show ?case
    apply (clarsimp simp: validE_R_def validE_def valid_def  split: sum.split)
    apply (subst (asm) resolve_address_bits'.simps)
    apply (split cap.splits)
              defer 6 (* cnode *)
              apply (simp_all add: spec_validE_def validE_def valid_def
                         throwError_def return_def valid_fault_def)[11]
    apply (simp only: split: cap.splits if_split_asm)
     apply (simp add: fail_def)
    apply (simp only: K_bind_def in_bindE)
    apply (elim conjE exE disjE)
        apply ((clarsimp simp: whenE_def bindE_def bind_def lift_def liftE_def
                    throwError_def returnOk_def return_def valid_fault_def
                    valid_cap_def2 wellformed_cap_def word_bits_def
                  split: if_split_asm cap.splits)+)[4]
    apply (split if_split_asm)
     apply (clarsimp simp: whenE_def bindE_def bind_def lift_def liftE_def
                throwError_def returnOk_def return_def valid_fault_def
                valid_cap_def2 wellformed_cap_def
              split: if_split_asm cap.splits)
    apply (simp only: K_bind_def in_bindE)
    apply (elim conjE exE disjE)
     apply (clarsimp simp: whenE_def bindE_def bind_def lift_def liftE_def
                throwError_def returnOk_def return_def valid_fault_def
                valid_cap_def2 wellformed_cap_def
              split: if_split_asm cap.splits)
    apply (split if_split_asm)
     apply (frule (8) "1.hyps")
     apply (clarsimp simp add: validE_def valid_def whenE_def bindE_def
               bind_def lift_def liftE_def throwError_def
               returnOk_def return_def valid_fault_def
             split: if_split_asm cap.splits sum.splits)
     apply (frule in_inv_by_hoareD [OF get_cap_inv])
     apply simp
     apply (frule (1) post_by_hoare [OF get_cap_valid])
     apply (erule_tac x=s in allE, erule impE, simp)
     apply (drule (1) bspec, clarsimp)
    apply (clarsimp simp add: returnOk_def return_def)
    apply (frule in_inv_by_hoareD [OF get_cap_inv])
    apply (clarsimp simp: whenE_def bindE_def bind_def throwError_def
                          returnOk_def return_def
                    split: if_split_asm cap.splits sum.splits)
    done
qed

lemma resolve_address_bits_valid_fault2:
  "\<lbrace>invs and valid_cap (fst param)\<rbrace>
   resolve_address_bits param
   -,\<lbrace>\<lambda>f s. valid_fault (ExceptionTypes_A.fault.CapFault x y f)\<rbrace>"
  apply (cut_tac resolve_address_bits_valid_fault[of param x y])
  apply (clarsimp simp add: validE_E_def validE_def valid_def
                  split: sum.splits)
  apply (drule invs_valid_objs)
  apply fastforce
  done

lemma lookup_cap_and_slot_valid_fault:
  "\<lbrace>valid_objs\<rbrace> lookup_cap_and_slot thread cptr
   \<lbrace>\<lambda>_. valid_objs\<rbrace>,
   \<lbrace>\<lambda>ft s. valid_fault (ExceptionTypes_A.CapFault (of_bl cptr) rp ft)\<rbrace>"
  apply (simp add: lookup_cap_and_slot_def split_def lookup_slot_for_thread_def
         | wp resolve_address_bits_valid_fault)+
  apply (clarsimp simp: objs_valid_tcb_ctable)
  done

lemma lookup_cap_and_slot_valid_fault2[wp]:
  "\<lbrace>invs\<rbrace> lookup_cap_and_slot thread (to_bl p)
   -,\<lbrace>\<lambda>ft s. valid_fault (ExceptionTypes_A.CapFault p rp ft)\<rbrace>"
  using lookup_cap_and_slot_valid_fault[of thread "to_bl p"]
  apply (clarsimp simp add: validE_E_def validE_def valid_def
                  split: sum.splits)
  apply (drule invs_valid_objs)
  apply fastforce
  done

lemma lec_valid_fault:
  "\<lbrace>valid_objs\<rbrace>
   lookup_extra_caps thread buffer info
   \<lbrace>\<lambda>_. valid_objs\<rbrace>,\<lbrace>\<lambda>rv s. valid_fault rv\<rbrace>"
  apply (simp add: lookup_extra_caps_def split del: if_split)
  apply (wp mapME_wp' lookup_cap_and_slot_valid_fault)
  done

lemma lec_valid_fault2[wp]:
  "\<lbrace>invs\<rbrace> lookup_extra_caps thread buffer info -,\<lbrace>\<lambda>rv s. valid_fault rv\<rbrace>"
  apply (cut_tac lec_valid_fault[of thread buffer info])
  apply (clarsimp simp add: validE_E_def validE_def valid_def
                  split: sum.splits )
  apply (drule invs_valid_objs)
  apply fastforce
  done

lemma lec_caps_to[wp]:
  "\<lbrace>invs and K (\<forall>cap. is_cnode_cap cap \<longrightarrow> P cap)\<rbrace> lookup_extra_caps t buffer info
   \<lbrace>\<lambda>rv s. (\<forall>x\<in>set rv. ex_cte_cap_wp_to P (snd x) s)\<rbrace>,-"
  apply (simp add: lookup_extra_caps_def split del: if_split)
  apply (rule hoare_pre)
   apply (wp mapME_set)
      apply (simp add: lookup_cap_and_slot_def split_def)
      apply (wp lsft_ex_cte_cap_to mapM_wp'
                    | simp add: load_word_offs_word_def | wpc)+
  done

lemma get_cap_int_derived[wp]:
  "\<lbrace>\<top>\<rbrace> get_cap slot \<lbrace>\<lambda>rv. cte_wp_at (interrupt_derived rv) slot\<rbrace>"
  apply (wp get_cap_wp)
  apply (clarsimp simp: cte_wp_at_caps_of_state interrupt_derived_def)
  done

lemma lec_derived[wp]:
  "\<lbrace>invs\<rbrace>
     lookup_extra_caps t buffer info
   \<lbrace>\<lambda>rv s. (\<forall>x\<in>set rv. cte_wp_at (interrupt_derived (fst x)) (snd x) s)\<rbrace>,-"
  apply (simp add: lookup_extra_caps_def split del: if_split)
  apply (rule hoare_pre)
   apply (wp mapME_set)
      apply (simp add: lookup_cap_and_slot_def split_def)
      apply (wp | simp)+
  done

lemma lookup_cap_and_slot_dimished [wp]:
  "\<lbrace>valid_objs\<rbrace>
    lookup_cap_and_slot thread cptr
   \<lbrace>\<lambda>x. cte_wp_at ((=) (fst x)) (snd x)\<rbrace>, -"
  by (wpsimp wp: get_cap_wp simp: lookup_cap_and_slot_def)

lemma lookup_extra_caps_eq [wp]:
  "\<lbrace>valid_objs\<rbrace> lookup_extra_caps thread xb info
  \<lbrace>\<lambda>rv s. (\<forall>x\<in>set rv. cte_wp_at ((=) (fst x)) (snd x) s)\<rbrace>,-"
  by (wpsimp wp: mapME_set simp: lookup_extra_caps_def)


(*FIXME: move to Nondet_VCG.valid_validE_R *)
lemma valid_validE_R_gen:
  "\<lbrakk>\<And>rv s. Q' (Inr rv) s \<Longrightarrow> Q rv s; \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, -"
  by (fastforce simp: validE_R_def validE_def valid_def split_def)

lemma valid_validE_R_eq:
  "\<lbrakk>Q = Q'\<circ>Inr; \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, -"
  by (fastforce simp: validE_R_def validE_def valid_def split_def)


crunch reply_from_kernel
  for tcb_at[wp]: "tcb_at t"
  (simp: crunch_simps)

crunch reply_from_kernel
  for pred_tcb_at[wp]: "pred_tcb_at proj P t"
  (simp: crunch_simps)

crunch reply_from_kernel
  for cap_to[wp]: "ex_nonz_cap_to p"
  (simp: crunch_simps)

crunch reply_from_kernel
  for it[wp]: "\<lambda>s. P (idle_thread s)"
  (simp: crunch_simps)

crunch reply_from_kernel
  for cte_wp_at[wp]: "cte_wp_at P p"
  (simp: crunch_simps)


lemma ts_Restart_case_helper:
  "(case ts of Structures_A.Restart \<Rightarrow> A | _ \<Rightarrow> B)
 = (if ts = Structures_A.Restart then A else B)"
  by (case_tac ts, simp_all)


lemma lcs_ex_cap_to2[wp]:
  "\<lbrace>invs and K (\<forall>cap. is_cnode_cap cap \<longrightarrow> P cap)\<rbrace>
      lookup_cap_and_slot t cref \<lbrace>\<lambda>rv. ex_cte_cap_wp_to P (snd rv)\<rbrace>,-"
  apply (rule hoare_pre)
   apply (simp add: lookup_cap_and_slot_def split_def)
   apply (wp lsft_ex_cte_cap_to | simp)+
  done

(* FIXME AARCH64: this should really not be wp *)
declare hoare_vcg_const_imp_liftE_E[wp]

context Syscall_AI begin

lemma hinv_invs':
  fixes Q :: "'state_ext state \<Rightarrow> bool" and calling blocking
  assumes perform_invocation_Q[wp]:
    "\<And>block class i.
      \<lbrace>invs and Q and ct_active and valid_invocation i\<rbrace>
        perform_invocation block class i
      \<lbrace>\<lambda>_.Q\<rbrace>"
  assumes handle_fault_Q[wp]:
    "\<And>t f.
      \<lbrace>invs and Q and st_tcb_at active t and ex_nonz_cap_to t and (\<lambda>_. valid_fault f)\<rbrace>
        handle_fault t f
      \<lbrace>\<lambda>r. Q\<rbrace>"
  assumes reply_from_kernel_Q[wp]:
    "\<And>a b. \<lbrace>invs and Q\<rbrace> reply_from_kernel a b \<lbrace>\<lambda>_.Q\<rbrace>"
  assumes sts_Q[wp]:
    "\<And>a b. \<lbrace>invs and Q\<rbrace> set_thread_state a b \<lbrace>\<lambda>_.Q\<rbrace>"
  shows
    "\<lbrace>invs and Q and ct_active\<rbrace> handle_invocation calling blocking \<lbrace>\<lambda>rv s. invs s \<and> Q s\<rbrace>"
  apply (simp add: handle_invocation_def ts_Restart_case_helper split_def
                   liftE_liftM_liftME liftME_def bindE_assoc)

  apply (wp syscall_valid sts_invs_minor2 rfk_invs
            hoare_vcg_all_lift hoare_vcg_disj_lift | simp split del: if_split)+
  apply (rule_tac Q'="\<lambda>st. st_tcb_at ((=) st) thread and (invs and Q)" in hoare_post_imp)
  apply (auto elim!: pred_tcb_weakenE st_tcb_ex_cap
              dest: st_tcb_at_idle_thread
              simp: st_tcb_at_tcb_at)[1]
  apply (rule gts_sp)
  apply wp
  apply (simp add: ct_in_state_def conj_commute conj_left_commute)
  apply wp
  apply (rule_tac Q'="\<lambda>rv s. st_tcb_at active thread s \<and> cur_thread s = thread" in hoare_post_imp)
  apply simp
  apply (wp sts_st_tcb_at')
  apply (simp only: simp_thms K_def if_apply_def2)
  apply (rule hoare_vcg_conj_elimE)
  apply (wp | simp add: if_apply_def2)+
  apply (auto simp: ct_in_state_def elim: st_tcb_ex_cap)
  done

lemmas hinv_invs[wp] = hinv_invs'
  [where Q=\<top>,simplified hoare_TrueI, OF TrueI TrueI TrueI TrueI,simplified]

(* FIXME: move *)
lemma hinv_tcb[wp]:
  "\<And>t calling blocking.
    \<lbrace>st_tcb_at active t and invs and ct_active\<rbrace>
      handle_invocation calling blocking
    \<lbrace>\<lambda>rv. tcb_at t :: 'state_ext state \<Rightarrow> bool\<rbrace>"
  apply (simp add: handle_invocation_def split_def
                   ts_Restart_case_helper
                   liftE_liftM_liftME liftME_def bindE_assoc)
  apply (wp syscall_valid sts_st_tcb_at_cases
            ct_in_state_set lec_caps_to
            | simp)+
  apply (clarsimp simp: st_tcb_at_tcb_at invs_valid_objs
                        ct_in_state_def)
  apply (fastforce elim!: st_tcb_ex_cap)
  done

lemma hs_tcb_on_err:
  "\<lbrace>st_tcb_at active t and invs and ct_active\<rbrace>
     handle_send blocking
   -,\<lbrace>\<lambda>e. tcb_at t :: 'state_ext state \<Rightarrow> bool\<rbrace>"
  apply (unfold handle_send_def whenE_def fun_app_def validE_E_def validE_def)
  apply (rule hoare_strengthen_post [OF hinv_tcb])
  apply (clarsimp split: sum.split)
  done

lemma hs_invs[wp]: "\<lbrace>invs and ct_active\<rbrace> handle_send blocking \<lbrace>\<lambda>r. invs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
  apply (rule validE_valid)
  apply (simp add: handle_send_def whenE_def)
  apply (wp | simp add: ct_in_state_def tcb_at_invs)+
  done

end


lemma tcb_cnode_index_3_reply_or_null:
  "\<lbrakk> tcb_at t s; tcb_cap_valid cap (t, tcb_cnode_index 3) s \<rbrakk> \<Longrightarrow> is_reply_cap cap \<or> cap = cap.NullCap"
  apply (clarsimp  simp: tcb_cap_valid_def st_tcb_def2 tcb_at_def)
  apply (clarsimp split: Structures_A.thread_state.split_asm)
  done

lemma ex_nonz_cap_to_tcb_strg:
  "(\<exists>cref. cte_wp_at (\<lambda>cap. is_thread_cap cap \<and> p \<in> zobj_refs cap) cref s)
       \<longrightarrow> ex_nonz_cap_to p s"
  by (fastforce simp: ex_nonz_cap_to_def cte_wp_at_caps_of_state)

lemma ex_tcb_cap_to_tcb_at_strg:
  "ex_nonz_cap_to p s \<and> tcb_at p s \<and> valid_objs s \<longrightarrow>
   (\<exists>cref. cte_wp_at (\<lambda>cap. is_thread_cap cap \<and> p \<in> zobj_refs cap) cref s)"
  apply (clarsimp simp: ex_nonz_cap_to_def cte_wp_at_caps_of_state
                        zobj_refs_to_obj_refs)
  apply (drule(1) caps_of_state_valid_cap[rotated])
  apply (drule(2) valid_cap_tcb_at_tcb_or_zomb)
  apply fastforce
  done

lemma delete_caller_cap_nonz_cap:
  "\<lbrace>ex_nonz_cap_to p and tcb_at t and valid_objs\<rbrace>
      delete_caller_cap t
   \<lbrace>\<lambda>rv. ex_nonz_cap_to p\<rbrace>"
  apply (simp add: delete_caller_cap_def ex_nonz_cap_to_def cte_wp_at_caps_of_state)
  apply (rule hoare_pre)
  apply (wp hoare_vcg_ex_lift cap_delete_one_caps_of_state)
  apply (clarsimp simp: cte_wp_at_caps_of_state)
  apply (rule_tac x=a in exI)
  apply (rule_tac x=b in exI)
  apply clarsimp
  apply (drule (1) tcb_cap_valid_caps_of_stateD)
  apply (drule (1) tcb_cnode_index_3_reply_or_null)
  apply (auto simp: is_cap_simps)
  done

lemma delete_caller_cap_invs[wp]:
  "\<lbrace>invs and tcb_at t\<rbrace> delete_caller_cap t \<lbrace>\<lambda>rv. invs\<rbrace>"
  apply (simp add: delete_caller_cap_def, wp)
  apply (clarsimp simp: emptyable_def)
  done

lemma delete_caller_cap_simple[wp]:
  "\<lbrace>st_tcb_at active t\<rbrace> delete_caller_cap t' \<lbrace>\<lambda>rv. st_tcb_at active t\<rbrace>"
  apply (simp add: delete_caller_cap_def)
  apply (wp cap_delete_one_st_tcb_at)
  apply simp
  done

lemma delete_caller_deletes_caller[wp]:
  "\<lbrace>\<top>\<rbrace> delete_caller_cap t \<lbrace>\<lambda>rv. cte_wp_at ((=) cap.NullCap) (t, tcb_cnode_index 3)\<rbrace>"
  apply (rule_tac Q'="\<lambda>rv. cte_wp_at (\<lambda>c. c = cap.NullCap) (t, tcb_cnode_index 3)"
               in hoare_post_imp,
         clarsimp elim!: cte_wp_at_weakenE)
  apply (simp add: delete_caller_cap_def cap_delete_one_def unless_def, wp)
   apply (simp add: if_apply_def2, wp get_cap_wp)
  apply (clarsimp elim!: cte_wp_at_weakenE)
  done

lemma delete_caller_cap_deleted[wp]:
  "\<lbrace>\<top>\<rbrace> delete_caller_cap thread \<lbrace>\<lambda>rv. cte_wp_at (\<lambda>c. c = cap.NullCap) (thread, tcb_cnode_index 3)\<rbrace>"
  by (simp add: delete_caller_cap_def, wp)

lemma invs_valid_tcb_ctable_strengthen:
  "invs s \<longrightarrow> ((\<exists>y. get_tcb thread s = Some y) \<longrightarrow>
               invs s \<and> s \<turnstile> tcb_ctable (the (get_tcb thread s)))"
  by (clarsimp simp: invs_valid_tcb_ctable)

lemma hw_invs[wp]: "\<lbrace>invs and ct_active\<rbrace> handle_recv is_blocking \<lbrace>\<lambda>r. invs\<rbrace>"
  apply (simp add: handle_recv_def Let_def ep_ntfn_cap_case_helper
    cong: if_cong)
  apply (wp get_simple_ko_wp | clarsimp)+
  apply (wp delete_caller_cap_nonz_cap get_simple_ko_wp hoare_vcg_ball_lift | simp)+
     apply (rule hoare_vcg_conj_elimE)
      apply (simp add: lookup_cap_def lookup_slot_for_thread_def)
      apply wp
       apply (simp add: split_def)
       apply (wp resolve_address_bits_valid_fault2)+
     apply (simp add: valid_fault_def)
     apply ((wp hoare_vcg_all_liftE_R lookup_cap_ex_cap
          | simp add: obj_at_def
          | simp add: conj_disj_distribL ball_conj_distrib
          | wp (once) hoare_drop_imps)+)
  apply (simp add: ct_in_state_def)
  apply (fold obj_at_def)
  apply (fastforce elim!: invs_valid_tcb_ctable st_tcb_ex_cap)
  done

crunch delete_caller_cap
  for typ_at[wp]: "\<lambda>s. P (typ_at T p s)"

lemmas delete_caller_cap_tcb[wp]
  = tcb_at_typ_at [OF delete_caller_cap_typ_at]

lemma hw_tcb[wp]: "\<lbrace>tcb_at t\<rbrace> handle_recv is_blocking \<lbrace>\<lambda>rv. tcb_at t\<rbrace>"
  apply (simp add: handle_recv_def Let_def ep_ntfn_cap_case_helper
             cong: if_cong)
  apply (wp hoare_vcg_if_lift2 hoare_vcg_conj_lift hoare_drop_imps | wpc | simp)+
  done

lemma sts_st_tcb_at'':
  "\<lbrace>K (t = t' \<and> P st)\<rbrace>
     set_thread_state t st
   \<lbrace>\<lambda>rv. st_tcb_at P t'\<rbrace>"
  apply (cases "t = t'")
   apply (simp only: simp_thms)
   apply (rule sts_st_tcb_at')
  apply simp
  done

lemma null_cap_on_failure_wp[wp]:
  assumes x: "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>\<lambda>rv. Q cap.NullCap\<rbrace>"
  shows      "\<lbrace>P\<rbrace> null_cap_on_failure f \<lbrace>Q\<rbrace>"
  unfolding ncof_is_a_catch
  by (wp x)

crunch_ignore (add:null_cap_on_failure)

lemma hy_inv: "(\<And>s f. P (trans_state f s) = P s) \<Longrightarrow> \<lbrace>P\<rbrace> handle_yield \<lbrace>\<lambda>rv. P\<rbrace>"
  apply (simp add: handle_yield_def)
  apply (wp | simp)+
  done

lemma ct_active_simple [elim!]:
  "ct_active s \<Longrightarrow> st_tcb_at simple (cur_thread s) s"
  by (fastforce simp: ct_in_state_def elim!: pred_tcb_weakenE)

lemma active_from_running:
  "ct_running  s  \<Longrightarrow> ct_active  s"
  by (clarsimp elim!: pred_tcb_weakenE
               simp: ct_in_state_def)+

lemma tcb_caller_cap:
  "\<lbrakk>tcb_at t s; valid_objs s\<rbrakk> \<Longrightarrow>
   cte_wp_at (is_reply_cap or (=) cap.NullCap) (t, tcb_cnode_index 3) s"
  by (fastforce intro: tcb_cap_wp_at split: Structures_A.thread_state.split_asm)

lemma (in Syscall_AI) hr_invs[wp]:
  "\<lbrace>invs :: 'state_ext state \<Rightarrow> _\<rbrace> handle_reply \<lbrace>\<lambda>rv. invs\<rbrace>"
  apply (simp add: handle_reply_def)
  apply (rule bind_wp [OF _ gets_sp])
  apply (rule bind_wp [OF _ get_cap_sp])
  apply (rule hoare_pre)
   apply (wp | wpc)+
  apply (clarsimp simp: cte_wp_at_eq_simp)
  apply (frule cte_wp_at_valid_objs_valid_cap)
   apply clarsimp+
  apply (fastforce simp: valid_cap_def is_reply_cap_to_def
                 split: cap.splits
                  elim: cte_wp_at_weakenE)
  done

crunch set_extra_badge
  for cur_thread[wp]: "\<lambda>s. P (cur_thread s)"

crunch (in Syscall_AI) handle_reply
  for cur_thread[wp]: "\<lambda>s :: 'state_ext state. P (cur_thread s)"
  (wp: crunch_wps simp: unless_def crunch_simps
   ignore: make_fault_msg rule: transfer_caps_loop_pres)

lemmas cap_delete_one_st_tcb_at_simple[wp] =
    cap_delete_one_st_tcb_at[where P=simple, simplified]

lemma simple_if_Restart_Inactive:
  "simple (if P then Structures_A.Restart else Structures_A.Inactive)"
  by simp

crunch (in Syscall_AI) handle_reply
  for st_tcb_at_simple[wp]: "st_tcb_at simple t' :: 'state_ext state \<Rightarrow> _"
  (wp: hoare_TrueI crunch_wps sts_st_tcb_at_cases
       thread_set_no_change_tcb_state
     ignore: set_thread_state simp: simple_if_Restart_Inactive)

lemmas (in Syscall_AI) hr_ct_in_state_simple[wp]
    = ct_in_state_thread_state_lift [OF handle_reply_cur_thread
                                       handle_reply_st_tcb_at_simple]

crunch (in Syscall_AI) handle_fault_reply
  for vo[wp]: "valid_objs :: 'state_ext state \<Rightarrow> _"

lemmas handle_fault_reply_typ_ats[wp] =
    abs_typ_at_lifts [OF handle_fault_reply_typ_at]

lemma tcb_state_If_valid[simp]:
  "valid_tcb_state (if P then Structures_A.Restart else Structures_A.Inactive)
      = \<top>"
  by (rule ext, simp add: valid_tcb_state_def)

lemma drop_when_dxo_wp: "(\<And>f s. P (trans_state f s) = P s ) \<Longrightarrow> \<lbrace>P\<rbrace> when b (do_extended_op e) \<lbrace>\<lambda>_.P\<rbrace>"
  apply (clarsimp simp add: when_def)
  apply (wp | simp)+
  done

context Syscall_AI begin

lemma do_reply_transfer_nonz_cap:
  "\<lbrace>\<lambda>s :: 'state_ext state. ex_nonz_cap_to p s \<and> valid_objs s \<and> tcb_at p s \<and> valid_mdb s
            \<and> tcb_at receiver s\<rbrace>
     do_reply_transfer sender receiver slot grant
   \<lbrace>\<lambda>rv. ex_nonz_cap_to p\<rbrace>"
  apply (simp add: do_reply_transfer_def)
  apply (rule bind_wp [OF _ gts_sp])
  apply (rule hoare_pre)
   apply (wp cap_delete_one_cte_wp_at_preserved hoare_vcg_ex_lift | simp split del: if_split
          | wpc | strengthen ex_nonz_cap_to_tcb_strg)+
       apply (clarsimp simp add: tcb_cap_cases_def is_cap_simps can_fast_finalise_def)
      apply (strengthen ex_tcb_cap_to_tcb_at_strg)

      apply (wp drop_when_dxo_wp hoare_vcg_ex_lift
             thread_set_no_change_tcb_state thread_set_cte_wp_at_trivial
             ex_nonz_cap_to_pres [OF thread_set_cte_wp_at_trivial]
             | simp add: tcb_cap_cases_def)+
     apply (wp hoare_vcg_ex_lift cap_delete_one_cte_wp_at_preserved
            | strengthen ex_nonz_cap_to_tcb_strg)+
     apply (clarsimp simp add: tcb_cap_cases_def is_cap_simps can_fast_finalise_def)
    apply (strengthen ex_tcb_cap_to_tcb_at_strg)
    apply (wp hoare_drop_imp hoare_allI)+
  apply (clarsimp)
  done

lemma handle_reply_nonz_cap:
  "\<lbrace>\<lambda>s :: 'state_ext state. ex_nonz_cap_to p s \<and> valid_objs s \<and> valid_mdb s \<and> tcb_at p s\<rbrace>
     handle_reply
   \<lbrace>\<lambda>rv. ex_nonz_cap_to p\<rbrace>"
  apply (simp add: handle_reply_def)
  apply (wp delete_caller_cap_nonz_cap do_reply_transfer_nonz_cap | wpc)+
   apply (wp get_cap_wp)+
  apply clarsimp
  apply (drule(1) cte_wp_valid_cap)
  apply (clarsimp simp: valid_cap_def)
  done

lemma handle_reply_nonz_cap_to_ct:
  "\<lbrace>\<lambda>s. ex_nonz_cap_to (cur_thread s) s \<and> valid_objs s \<and> valid_mdb s \<and> tcb_at (cur_thread s) s\<rbrace>
     handle_reply
   \<lbrace>\<lambda>rv s :: 'state_ext state. ex_nonz_cap_to (cur_thread s) s\<rbrace>"
  apply (rule_tac Q'="\<lambda>rv s. \<exists>ct. (ct = cur_thread s) \<and> ex_nonz_cap_to ct s"
               in hoare_post_imp)
   apply simp
  apply (wp hoare_vcg_ex_lift handle_reply_nonz_cap)
  apply simp
  done

(* FIXME: move *)
lemma do_reply_transfer_st_tcb_at_active:
  "\<lbrace>valid_objs and st_tcb_at active t and st_tcb_at awaiting_reply t' and
    cte_wp_at (is_reply_cap_to t') sl\<rbrace>
    do_reply_transfer t t' sl grant
   \<lbrace>\<lambda>rv. st_tcb_at active t :: 'state_ext state \<Rightarrow> _\<rbrace>"
  apply (simp add: do_reply_transfer_def is_reply_cap_to_def)
  apply (wp drop_when_dxo_wp sts_st_tcb_at' sts_st_tcb_at_neq cap_delete_one_reply_st_tcb_at
            hoare_drop_imps thread_set_no_change_tcb_state
            do_ipc_transfer_non_null_cte_wp_at2
       | wpc | clarsimp simp: is_reply_cap_to_def)+
  apply (wp hoare_allI hoare_drop_imp)+
  apply (fastforce simp add: st_tcb_def2 is_reply_cap_to_def)
  done

lemma hc_invs[wp]:
  "\<lbrace>invs and ct_active\<rbrace> handle_call \<lbrace>\<lambda>rv. invs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
  by (simp add: handle_call_def) wp

lemma hr_ct_active[wp]:
  "\<lbrace>invs and ct_active\<rbrace> handle_reply \<lbrace>\<lambda>rv. ct_active :: 'state_ext state \<Rightarrow> _\<rbrace>"
  apply (simp add: handle_reply_def)
  apply (rule bind_wp)
   apply (rule_tac t=thread in ct_in_state_decomp)
    apply ((wp hoare_drop_imps hoare_vcg_all_lift | wpc | simp)+)[1]
   apply (wp hoare_vcg_all_lift get_cap_wp do_reply_transfer_st_tcb_at_active
        | wpc | simp)+
  apply (fastforce simp: ct_in_state_def cte_wp_at_caps_of_state is_reply_cap_to_def
                  dest: invs_valid_reply_caps
                  elim: valid_reply_caps_of_stateD)
  done

end
(* FIXME: move *) (* FIXME: should we add this to the simpset? *)
lemma select_insert:
  "select (insert x X) = (return x \<sqinter> select X)"
  by (simp add: alternative_def select_def return_def)


context Syscall_AI begin

lemma he_invs[wp]:
  "\<And>e.
    \<lbrace>\<lambda>s. invs s \<and> (e \<noteq> Interrupt \<longrightarrow> ct_active s)\<rbrace>
      handle_event e
    \<lbrace>\<lambda>rv. invs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
  apply (case_tac e, simp_all)
      apply (rename_tac syscall)
      apply (case_tac syscall, simp_all)
      apply (((rule hoare_pre, wp hvmf_active hr_invs hy_inv ) |
                 wpc | wp hoare_drop_imps hoare_vcg_all_lift |
                 simp add: if_apply_def2 |
                 fastforce simp: tcb_at_invs ct_in_state_def valid_fault_def
                         elim!: st_tcb_ex_cap)+)
  done

end

(* Lemmas related to preservation of runnability over handle_recv for woken threads
   these are presently unused, but have proven useful in the past *)
context notes if_cong[cong] begin

lemma complete_signal_state_refs_of:
  "\<lbrace>\<lambda>s. P (state_refs_of s) \<rbrace> complete_signal ntfnc t \<lbrace>\<lambda>rv s. P (state_refs_of s) \<rbrace>"
  unfolding complete_signal_def
  apply (rule hoare_pre)
   apply (wp get_simple_ko_wp | wpc | simp)+
  apply clarsimp
  apply (subgoal_tac " ntfn_bound_refs (ntfn_bound_tcb ntfn) = state_refs_of s ntfnc")
   apply (clarsimp simp: if_apply_def2 split: if_splits if_split_asm)
   subgoal by (subst eq_commute, auto cong: if_cong)
  apply (clarsimp simp: state_refs_of_def obj_at_def)
  done

lemma do_nbrecv_failed_transfer_state_refs_of[wp]:
  "\<lbrace>\<lambda>s. P (state_refs_of s) \<rbrace> do_nbrecv_failed_transfer t \<lbrace>\<lambda>rv s. P (state_refs_of s) \<rbrace>"
  unfolding do_nbrecv_failed_transfer_def
  apply (rule hoare_pre)
   apply (wp get_simple_ko_wp | wpc | simp)+
  done

crunch do_nbrecv_failed_transfer
  for st_tcb_at_runnable[wp]: "st_tcb_at runnable t"

lemma fast_finalise_sym_refs:
  "\<lbrace>invs\<rbrace> fast_finalise cap final \<lbrace>\<lambda>y s. sym_refs (state_refs_of s)\<rbrace>"
  apply (cases cap; clarsimp simp: when_def)
     apply (wp cancel_all_signals_invs cancel_all_ipc_invs unbind_maybe_notification_invs
             | strengthen invs_sym_refs
             | clarsimp)+
  done

crunch empty_slot
  for state_refs_of[wp]: "\<lambda>s::det_ext state. P (state_refs_of s)"
  (wp: crunch_wps simp: crunch_simps interrupt_update.state_refs_update)

lemma delete_caller_cap_sym_refs:
  "\<lbrace>invs\<rbrace> delete_caller_cap t \<lbrace>\<lambda>rv s::det_ext state. sym_refs (state_refs_of s) \<rbrace>"
  apply (simp add: delete_caller_cap_def cap_delete_one_def unless_def)
  apply (wp fast_finalise_sym_refs get_cap_wp)
  apply fastforce
  done

lemmas sts_st_tcb_at_other = sts_st_tcb_at_neq[where proj=itcb_state]

lemma if_pred_distrib: "(if b then f else g) = (\<lambda>s. (b \<longrightarrow> f s) \<and> (\<not> b \<longrightarrow> g s))"
  by simp

lemma send_ipc_st_tcb_at_runnable:
  "\<lbrace>st_tcb_at runnable t and (\<lambda>s. sym_refs (state_refs_of s)) and K (t' \<noteq> t) \<rbrace>
   send_ipc block call badge can_grant can_grant_reply t' epptr
   \<lbrace>\<lambda>rv. st_tcb_at runnable t\<rbrace>"
  unfolding send_ipc_def
  apply (rule hoare_gen_asm)
  apply (wpc | wp sts_st_tcb_at_other | clarsimp)+
          apply (simp add: setup_caller_cap_def)
          apply (rule conjI)
          apply (wpc
                | wp sts_st_tcb_at_other dxo_wp_weak hoare_drop_imps
                | clarsimp simp: if_fun_split)+
  apply (wp get_simple_ko_wp)
  apply clarsimp
  apply (drule st_tcb_at_state_refs_ofD)
  apply (drule (1) sym_refs_ko_atD)
  apply clarsimp
  apply (case_tac ts; clarsimp simp: obj_at_def state_refs_of_def dest!:refs_in_tcb_bound_refs)
  done

lemma receive_ipc_st_tcb_at_runnable:
  "\<lbrace>st_tcb_at runnable t and (\<lambda>s. sym_refs (state_refs_of s)) and K (t' \<noteq> t) \<rbrace>
   receive_ipc t' a b
   \<lbrace>\<lambda>rv. st_tcb_at runnable t\<rbrace>"
  unfolding receive_ipc_def
  apply (rule hoare_gen_asm)
  apply (wpc | wp sts_st_tcb_at_other
        | clarsimp simp: do_nbrecv_failed_transfer_def setup_caller_cap_def | rule conjI)+
               apply (wp hoare_drop_imps)
              apply (wp hoare_drop_imps)
             apply wpc
                    apply ((wp gts_wp gbn_wp  hoare_vcg_all_lift sts_st_tcb_at_other | wpc
                           | simp add: do_nbrecv_failed_transfer_def | wp (once) hoare_drop_imps)+)[8]
            apply clarsimp
            apply (wp gts_wp)
           apply (wp hoare_drop_imps hoare_vcg_all_lift)[1]
          apply ((wp sts_st_tcb_at_other get_simple_ko_wp gbn_wp get_simple_ko_wp | wpc)+)[8]
  apply clarsimp
  apply (rule conjI)
   apply clarsimp
   apply (rename_tac sendq)
   apply (frule list.collapse[symmetric])
   apply (drule st_tcb_at_state_refs_ofD)
   apply (frule (1) sym_refs_ko_atD)
   apply clarsimp
   apply (drule_tac x="hd sendq" in bspec, clarsimp)
   apply (case_tac ts; clarsimp simp: obj_at_def state_refs_of_def dest!: refs_in_tcb_bound_refs)
  apply clarsimp
  apply (rename_tac sendq)
  apply (frule list.collapse[symmetric])
  apply (drule st_tcb_at_state_refs_ofD)
  apply (frule (1) sym_refs_ko_atD)
  apply clarsimp
  apply (drule_tac x="hd sendq" in bspec, clarsimp)
  apply (case_tac ts; clarsimp simp: obj_at_def state_refs_of_def dest!: refs_in_tcb_bound_refs)
  done

lemma send_fault_ipc_st_tcb_at_runnable:
  "\<lbrace>st_tcb_at runnable t and (\<lambda>s. sym_refs (state_refs_of s)) and tcb_at t' and K (t' \<noteq> t)\<rbrace> send_fault_ipc t' f \<lbrace>\<lambda>rv. st_tcb_at runnable t\<rbrace>"
  unfolding send_fault_ipc_def
  apply (rule hoare_pre, wp)
     apply (clarsimp simp: Let_def)
     apply wpc
                apply (wp send_ipc_st_tcb_at_runnable thread_set_no_change_tcb_state thread_set_refs_trivial
                          hoare_vcg_all_liftE_R thread_get_wp
                        | clarsimp
                        | wp (once) hoare_drop_imps)+
  apply (clarsimp simp:  pred_tcb_at_def obj_at_def is_tcb)
  done

lemma handle_fault_st_tcb_at_runnable:
  "\<lbrace>st_tcb_at runnable t and invs and K (t' \<noteq> t) \<rbrace> handle_fault t' x \<lbrace>\<lambda>rv. st_tcb_at runnable t\<rbrace>"
  apply (rule hoare_gen_asm)
  apply (simp add: handle_fault_def handle_double_fault_def)
  apply wp
     apply (simp add: handle_fault_def handle_double_fault_def)
     apply (wp sts_st_tcb_at_other send_fault_ipc_st_tcb_at_runnable | simp)+
  apply (clarsimp dest!: get_tcb_SomeD simp: obj_at_def is_tcb)
  done

lemma delete_caller_cap_runnable[wp]:
  "\<lbrace>st_tcb_at runnable t\<rbrace> delete_caller_cap t' \<lbrace>\<lambda>rv. st_tcb_at runnable t\<rbrace>"
  apply (simp add: delete_caller_cap_def)
  apply (wp cap_delete_one_st_tcb_at)
  apply simp
  done

lemma handle_recv_st_tcb_at:
  "\<lbrace>invs and st_tcb_at runnable t and (\<lambda>s. cur_thread s \<noteq> t)\<rbrace> handle_recv True
  \<lbrace>\<lambda>rv s::det_ext state. st_tcb_at runnable t s\<rbrace>"
  apply (simp add: handle_recv_def Let_def ep_ntfn_cap_case_helper
             cong: if_cong)
  apply (rule hoare_pre)
   apply (wp handle_fault_st_tcb_at_runnable receive_ipc_st_tcb_at_runnable
             delete_caller_cap_sym_refs rai_pred_tcb_neq
             get_simple_ko_wp hoare_drop_imps hoare_vcg_all_liftE_R)
    apply clarsimp
    apply wp+
  apply fastforce
  done

end (* Lemmas related to preservation of runnability over handle_recv for woken threads *)

end