(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(GD_GPL)
 *)

theory Ipc_C
imports
  Finalise_C
  CSpace_All
  SyscallArgs_C
  IsolatedThreadAction
begin

context begin interpretation Arch . (*FIXME: arch_split*)

definition
  "replyFromKernel_success_empty thread \<equiv> do
     VSpace_H.lookupIPCBuffer True thread;
     asUser thread $ setRegister ARM_H.badgeRegister 0;
     setMessageInfo thread $ (Types_H.MI 0 0 0 0)
   od"

lemma replyFromKernel_success_empty:
  "replyFromKernel thread (0, []) = replyFromKernel_success_empty thread"
  unfolding replyFromKernel_def replyFromKernel_success_empty_def
  by (simp add: setMRs_Nil submonad_asUser.fn_stateAssert)

crunch valid_queues[wp]: handleFaultReply valid_queues

crunch valid_queues'[wp]: handleFaultReply valid_queues'

crunch sch_act_wf: handleFaultReply "\<lambda>s. sch_act_wf (ksSchedulerAction s) s"

crunch valid_ipc_buffer_ptr' [wp]: copyMRs "valid_ipc_buffer_ptr' p"
  (rule: hoare_valid_ipc_buffer_ptr_typ_at' wp: crunch_wps)

lemma threadSet_obj_at'_nontcb:
  "koType TYPE('a::pspace_storable) \<noteq> koType TYPE(Structures_H.tcb) \<Longrightarrow>
   \<lbrace>obj_at' (P :: 'a \<Rightarrow> bool) t'\<rbrace> threadSet f t \<lbrace>\<lambda>rv. obj_at' P t'\<rbrace>"
  apply (simp add: threadSet_def)
  apply (wp obj_at_setObject2 hoare_drop_imps
       | clarsimp simp: updateObject_tcb updateObject_default_def in_monad)+
  done

lemma setMRs_ntfn_at[wp]:
  "\<lbrace>ko_at' (ntfn :: Structures_H.notification) p\<rbrace>
    setMRs badge val thread
   \<lbrace>\<lambda>_. ko_at' ntfn p\<rbrace>"
  apply (simp add: setMRs_def
                   zipWithM_x_mapM_x split_def storeWordUser_def
                   setThreadState_def asUser_def)
  apply (wp threadSet_obj_at'_nontcb mapM_x_wp hoare_drop_imps
       | simp | rule subset_refl)+
  done

lemma asUser_ntfn_at[wp]:
  "\<lbrace>ko_at' (ntfn :: Structures_H.notification) p\<rbrace>
    asUser tptr f \<lbrace>\<lambda>_. ko_at' ntfn p\<rbrace>"
  apply (simp add: asUser_def split_def)
  apply (wp threadSet_obj_at'_nontcb hoare_drop_imps | simp | rule subset_refl)+
  done

definition
  "lookup_fault_get_lufType luf \<equiv> case luf of
     InvalidRoot \<Rightarrow> 0
   | MissingCapability _ \<Rightarrow> 1
   | DepthMismatch _ _ \<Rightarrow> 2
   | GuardMismatch _ _ _ \<Rightarrow> 3"

definition
  "setMR thread buffer \<equiv> \<lambda>idx value.
   if idx < length msgRegisters
   then do
     asUser thread (setRegister (msgRegisters ! idx) value);
     return (idx + 1)
   od
   else case buffer of None \<Rightarrow> return (length msgRegisters)
     | Some buf \<Rightarrow> do
         storeWordUser (buf + (of_nat (idx + 1) * word_size)) value;
         return (idx + 1)
   od"

lemmas msgMaxLength_unfold
    = msgMaxLength_def[where 'a=nat, unfolded msgLengthBits_def, simplified,
                       unfolded shiftL_nat, simplified]

lemma registers_less_maxlength:
  "length msgRegisters < msgMaxLength"
  by (simp add: msgRegisters_unfold msgMaxLength_unfold)

lemma setMRs_to_setMR':
notes
  wordSize_def' [simp]
shows
  "setMRs thread buffer xs
   = (do
    stateAssert (tcb_at' thread) [];
    ys \<leftarrow> zipWithM (setMR thread buffer) [0 ..< msgMaxLength] xs;
    return (of_nat (min (length xs) (length msgRegisters +
              (case buffer of None \<Rightarrow> 0 | _ \<Rightarrow> Suc (unat (msgMaxLength :: word32))
                  - unat ((1 :: word32) + of_nat (length msgRegisters))))))
  od)"
  apply (simp add: setMRs_def setMR_def split_def
                   zipWithM_x_mapM_x asUser_mapM_x bind_assoc
                   zipWithM_If_cut)
  apply (simp add: zipWithM_mapM)
  apply (simp add: split_def mapM_liftM_const[unfolded liftM_def]
                   mapM_return mapM_Nil mapM_x_Nil asUser_mapM_x
                   zip_is_empty last_append map_replicate_const
            split: option.split split del: if_split)
  apply (simp add: mapM_discarded mapM_x_def split del: if_split)
  apply (intro allI conjI impI bind_cong bind_apply_cong refl
               arg_cong2[where f=sequence_x]
               map_length_cong,
         insert registers_less_maxlength, simp_all)
     apply (clarsimp simp: set_zip)
    apply (clarsimp simp: set_zip)
   apply (simp add: msgRegisters_unfold msgMaxLength_def
                   msgLengthBits_def shiftL_nat)
  apply (clarsimp simp only: set_zip min_less_iff_conj length_zip
                             length_map nth_zip fst_conv nth_map
                             snd_conv upto_enum_word length_drop
                             length_take nth_drop nth_upt)
  apply (subst nth_take)
   apply (simp add: less_diff_conv)
  apply (simp add: word_size word_size_def field_simps)
  done

lemma setMRs_to_setMR:
  "setMRs thread buffer xs
   = (do
    stateAssert (tcb_at' thread) [];
    ys \<leftarrow> zipWithM (setMR thread buffer) [0 ..< msgMaxLength] xs;
    return (of_nat (last (0 # ys)))
  od)"
  apply (simp add: setMRs_to_setMR' zipWithM_mapM split_def mapM_discarded
              del: last.simps)
  apply (subst mapM_last_Cons)
    prefer 3
    apply simp
   apply (simp add: zip_is_empty msgMaxLength_unfold)
  apply (simp add: fst_last_zip_upt)
  apply (subgoal_tac "msgMaxLength - Suc 0 \<ge> length msgRegisters
                           \<and> of_nat (length xs - Suc 0) = of_nat (length xs) - (1 :: word32)
                           \<and> unat ((1 :: word32) + of_nat (length msgRegisters)) = Suc (length msgRegisters)")
   apply (simp add: setMR_def split: option.split)
   apply (intro impI conjI allI)
      apply clarsimp
     apply clarsimp
    apply (clarsimp simp add: msgRegisters_unfold)
    apply (clarsimp simp: linorder_not_less linorder_not_le)
    apply (clarsimp simp: msgRegisters_unfold msgMaxLength_def
                          msgLengthBits_def shiftL_nat)
   apply (clarsimp simp: msgRegisters_unfold msgMaxLength_def
                         msgLengthBits_def shiftL_nat)
  apply (simp add: msgRegisters_unfold msgMaxLength_unfold)
  apply (case_tac xs, simp_all)
  done

lemma asUser_comm:
  assumes neq: "a \<noteq> b"
  assumes efa: "empty_fail fa" and efb: "empty_fail fb"
  shows
  "\<And>ra rb. do
     ra \<leftarrow> asUser a fa;
     rb \<leftarrow> asUser b fb;
     c ra rb
   od = do
     rb \<leftarrow> asUser b fb;
     ra \<leftarrow> asUser a fa;
     c ra rb
   od"
  apply (rule submonad_comm' [OF submonad_asUser submonad_asUser])
      apply (clarsimp simp: neq asUser_replace_def Let_def fun_upd_twist [OF neq])
     apply (clarsimp simp: neq asUser_replace_def Let_def obj_at'_real_def
                           ko_wp_at'_def ps_clear_upd_None ps_clear_upd
                    split: option.split kernel_object.split)
    apply (clarsimp simp: neq[symmetric] asUser_replace_def Let_def
                          obj_at'_real_def ko_wp_at'_def ps_clear_upd_None
                          ps_clear_upd
                   split: option.split kernel_object.split)
   apply (rule efa efb)+
  done

(* FIXME move the thread_submonad stuff to SubMonad_R and use it for asUser *)
definition
  "thread_fetch \<equiv> \<lambda>ext t s. case (ksPSpace s t) of
      Some (KOTCB tcb) \<Rightarrow> ext tcb
    | None \<Rightarrow> undefined"

definition
  "thread_fetch_option \<equiv> \<lambda>ext t s. case (ksPSpace s t) of
      Some (KOTCB tcb) \<Rightarrow> ext tcb
    | None \<Rightarrow> None"

definition
  "thread_replace \<equiv> \<lambda>upd t nv s.
      let obj = case (ksPSpace s t) of
                   Some (KOTCB tcb) \<Rightarrow> Some (KOTCB (upd (\<lambda>_. nv) tcb))
                 | obj \<Rightarrow> obj
      in s \<lparr> ksPSpace := (ksPSpace s) (t := obj) \<rparr>"

lemma thread_submonad_args:
  "\<lbrakk> \<And>f v. ext (upd f v) = f (ext v);
     \<And>f1 f2 v. upd f1 (upd f2 v) = upd (f1 \<circ> f2) v;
     \<And>f v. upd (\<lambda>_. ext v) v = v \<rbrakk> \<Longrightarrow>
   submonad_args (thread_fetch ext t) (thread_replace upd t) (tcb_at' t)"
  apply unfold_locales
     apply (clarsimp simp: thread_fetch_def thread_replace_def
                           Let_def obj_at'_def projectKOs
                    split: kernel_object.split option.split)
    apply (clarsimp simp: thread_replace_def Let_def
                   split: kernel_object.split option.split)
   apply (clarsimp simp: thread_fetch_def thread_replace_def Let_def
                         fun_upd_idem
                  split: kernel_object.splits option.splits)
  apply (clarsimp simp: obj_at'_def thread_replace_def Let_def projectKOs
                 split: kernel_object.splits option.splits)
  apply (rename_tac tcb)
  apply (case_tac tcb, simp add: objBitsKO_def ps_clear_def)
  done

lemma tcbFault_submonad_args:
  "submonad_args (thread_fetch tcbFault t) (thread_replace tcbFault_update t)
                 (tcb_at' t)"
  apply (rule thread_submonad_args)
    apply (case_tac v, simp)+
  done

lemma threadGet_stateAssert_gets:
  "threadGet ext t = do stateAssert (tcb_at' t) []; gets (thread_fetch ext t) od"
  including no_pre
  apply (rule is_stateAssert_gets [OF _ _ empty_fail_threadGet no_fail_threadGet])
    apply (clarsimp simp: threadGet_def liftM_def, wp+)[1]
   apply (simp add: threadGet_def liftM_def, (wp getObject_tcb_at')+)
  apply (simp add: threadGet_def liftM_def, wp+)
  apply (rule hoare_strengthen_post, (wp getObject_obj_at')+)
     apply (simp add: objBits_def objBitsKO_def)+
  apply (clarsimp simp: obj_at'_def thread_fetch_def projectKOs)
  done

lemma threadGet_tcbFault_submonad_fn:
  "threadGet tcbFault t =
   submonad_fn (thread_fetch tcbFault t) (thread_replace tcbFault_update t)
               (tcb_at' t) get"
  apply (rule ext)
  apply (clarsimp simp: submonad_fn_def bind_assoc split_def)
  apply (subst threadGet_stateAssert_gets, simp)
  apply (rule bind_apply_cong [OF refl])
  apply (clarsimp simp: in_monad bind_def gets_def get_def return_def
                        submonad_args.args(3) [OF tcbFault_submonad_args]
                        select_f_def modify_def put_def)
  done

lemma asUser_threadGet_tcbFault_comm:
  "empty_fail im \<Longrightarrow>
   do y \<leftarrow> asUser t im;
      x \<leftarrow> threadGet tcbFault t';
      n x y
   od =
   do x \<leftarrow> threadGet tcbFault t';
      asUser t im >>= n x
   od"
  apply (rule submonad_comm2 [OF tcbFault_submonad_args
                                 threadGet_tcbFault_submonad_fn
                                 submonad_asUser, symmetric])
      apply (clarsimp simp: thread_replace_def asUser_replace_def Let_def
                     split: option.split)
      apply (clarsimp simp: fun_upd_idem fun_upd_twist
                     split: kernel_object.split)
      apply (rename_tac tcb)
      apply (case_tac tcb, simp)
     apply (clarsimp simp: asUser_replace_def Let_def obj_at'_real_def
                           ko_wp_at'_def ps_clear_upd_None ps_clear_upd
                           objBitsKO_def projectKOs
                    split: option.split kernel_object.split)
    apply (clarsimp simp: thread_replace_def Let_def obj_at'_real_def
                          ko_wp_at'_def ps_clear_upd_None
                          ps_clear_upd objBitsKO_def projectKOs
                   split: option.split kernel_object.split)
   apply (simp add: get_def empty_fail_def)
  apply assumption
  done

lemma asUser_getRegister_threadGet_comm:
  "do
     ra \<leftarrow> asUser a (getRegister r);
     rb \<leftarrow> threadGet fb b;
     c ra rb
   od = do
     rb \<leftarrow> threadGet fb b;
     ra \<leftarrow> asUser a (getRegister r);
     c ra rb
   od"
  by (rule bind_inv_inv_comm, auto; wp)

crunch inv[wp]: getSanitiseRegisterInfo P
  (ignore: getObject)

lemma empty_fail_getSanitiseRegisterInfo[wp, simp]:
  "empty_fail (getSanitiseRegisterInfo t)"
  by (wpsimp simp: getSanitiseRegisterInfo_def)

lemma asUser_getRegister_getSanitiseRegisterInfo_comm:
  "do
     ra \<leftarrow> asUser a (getRegister r);
     rb \<leftarrow> getSanitiseRegisterInfo b;
     c ra rb
   od = do
     rb \<leftarrow> getSanitiseRegisterInfo b;
     ra \<leftarrow> asUser a (getRegister r);
     c ra rb
   od"
  by (rule bind_inv_inv_comm; wpsimp)

lemma asUser_mapMloadWordUser_threadGet_comm:
  "do
     ra \<leftarrow> mapM loadWordUser xs;
     rb \<leftarrow> threadGet fb b;
     c ra rb
   od = do
     rb \<leftarrow> threadGet fb b;
     ra \<leftarrow> mapM loadWordUser xs;
     c ra rb
   od"
  by (rule bind_inv_inv_comm, auto; wp mapM_wp')

lemma asUser_mapMloadWordUser_getSanitiseRegisterInfo_comm:
  "do
     ra \<leftarrow> mapM loadWordUser xs;
     rb \<leftarrow> getSanitiseRegisterInfo b;
     c ra rb
   od = do
     rb \<leftarrow> getSanitiseRegisterInfo b;
     ra \<leftarrow> mapM loadWordUser xs;
     c ra rb
   od"
  by (rule bind_inv_inv_comm, auto; wp mapM_wp')


lemma threadGet_tcbFault_doMachineOp_comm:
  "\<lbrakk> empty_fail m' \<rbrakk> \<Longrightarrow>
   do x \<leftarrow> threadGet tcbFault t; y \<leftarrow> doMachineOp m'; n x y od =
   do y \<leftarrow> doMachineOp m'; x \<leftarrow> threadGet tcbFault t; n x y od"
  apply (rule submonad_comm2 [OF tcbFault_submonad_args
                                 threadGet_tcbFault_submonad_fn
                                 submonad_doMachineOp])
      apply (simp add: thread_replace_def Let_def)
     apply simp
    apply (rule refl)
   apply (simp add: get_def empty_fail_def)
  apply assumption
  done

lemma getObject_tcb_det:
  "(r::tcb,s') \<in> fst (getObject p s) \<Longrightarrow> fst (getObject p s) = {(r,s)} \<and> s' = s"
  apply (clarsimp simp add: getObject_def bind_def get_def gets_def
                            return_def loadObject_default_def split_def)
  apply (clarsimp split: kernel_object.split_asm if_split_asm option.split_asm
                   simp: in_monad typeError_def alignError_def magnitudeCheck_def
                         objBits_def objBitsKO_def projectKOs
                         lookupAround2_def Let_def o_def)
   apply (simp_all add: bind_def return_def assert_opt_def split_def projectKOs
                        alignCheck_def is_aligned_mask[symmetric]
                        unless_def when_def magnitudeCheck_def)
  done

lemma threadGet_again:
  "\<And>rv s s' n. (rv, s') \<in> fst (threadGet ext t s) \<Longrightarrow>
   (threadGet ext t >>= n) s' = n rv s'"
  apply (clarsimp simp add: threadGet_def liftM_def in_monad)
  apply (frule use_valid [OF _ getObject_obj_at'])
     apply (simp add: objBits_def objBitsKO_def)+
  apply (frule getObject_tcb_det)
  apply (clarsimp simp: bind_def split_def)
  apply (insert no_fail_getObject_tcb)
  apply (clarsimp simp: no_fail_def obj_at'_def is_tcb)
  done

lemma asUser_getRegister_discarded:
  "(asUser t (getRegister r)) >>= (\<lambda>_. n) =
   stateAssert (tcb_at' t) [] >>= (\<lambda>_. n)"
  apply (rule ext)
  apply (clarsimp simp: submonad_asUser.fn_is_sm submonad_fn_def
                        submonad_asUser.args assert_def select_f_def
                        gets_def get_def modify_def put_def
                        getRegister_def bind_def split_def
                        return_def fail_def stateAssert_def)
  done

lemma loadWordUser_submonad_fn:
  "loadWordUser p = submonad_fn ksMachineState (ksMachineState_update \<circ> K)
                                (pointerInUserData p) (loadWord p)"
  by (simp add: loadWordUser_def submonad_doMachineOp.fn_is_sm submonad_fn_def)

lemma storeWordUser_submonad_fn:
  "storeWordUser p v = submonad_fn ksMachineState (ksMachineState_update \<circ> K)
                                   (pointerInUserData p) (storeWord p v)"
  by (simp add: storeWordUser_def submonad_doMachineOp.fn_is_sm submonad_fn_def)

lemma threadGet_tcbFault_loadWordUser_comm:
  "do x \<leftarrow> threadGet tcbFault t; y \<leftarrow> loadWordUser p; n x y od =
   do y \<leftarrow> loadWordUser p; x \<leftarrow> threadGet tcbFault t; n x y od"
  apply (rule submonad_comm [OF tcbFault_submonad_args _
                                threadGet_tcbFault_submonad_fn
                                loadWordUser_submonad_fn])
       apply (simp add: submonad_args_def pointerInUserData_def)
      apply (simp add: thread_replace_def Let_def)
     apply simp
    apply (clarsimp simp: thread_replace_def Let_def typ_at'_def ko_wp_at'_def
                          ps_clear_upd ps_clear_upd_None pointerInUserData_def
                   split: option.split kernel_object.split)
   apply (simp add: get_def empty_fail_def)
  apply (simp add: ef_loadWord)
  done

lemma threadGet_tcbFault_storeWordUser_comm:
  "do x \<leftarrow> threadGet tcbFault t; y \<leftarrow> storeWordUser p v; n x y od =
   do y \<leftarrow> storeWordUser p v; x \<leftarrow> threadGet tcbFault t; n x y od"
  apply (rule submonad_comm [OF tcbFault_submonad_args _
                                threadGet_tcbFault_submonad_fn
                                storeWordUser_submonad_fn])
       apply (simp add: submonad_args_def pointerInUserData_def)
      apply (simp add: thread_replace_def Let_def)
     apply simp
    apply (clarsimp simp: thread_replace_def Let_def typ_at'_def ko_wp_at'_def
                          ps_clear_upd ps_clear_upd_None pointerInUserData_def
                   split: option.split kernel_object.split)
   apply (simp add: get_def empty_fail_def)
  apply (simp add: ef_storeWord)
  done

lemma asUser_loadWordUser_comm:
  "empty_fail m \<Longrightarrow>
   do x \<leftarrow> asUser t m; y \<leftarrow> loadWordUser p; n x y od =
   do y \<leftarrow> loadWordUser p; x \<leftarrow> asUser t m; n x y od"
  apply (rule submonad_comm2 [OF _ loadWordUser_submonad_fn
                                 submonad_asUser, symmetric])
       apply (simp add: submonad_args_def pointerInUserData_def)
      apply (simp add: asUser_replace_def Let_def)
     apply (clarsimp simp: asUser_replace_def Let_def typ_at'_def ko_wp_at'_def
                           ps_clear_upd ps_clear_upd_None pointerInUserData_def
                    split: option.split kernel_object.split)
    apply simp
   apply (simp add: ef_loadWord)
  apply assumption
  done

lemma asUser_storeWordUser_comm:
  "empty_fail m \<Longrightarrow>
   do x \<leftarrow> asUser t m; y \<leftarrow> storeWordUser p v; n x y od =
   do y \<leftarrow> storeWordUser p v; x \<leftarrow> asUser t m; n x y od"
  apply (rule submonad_comm2 [OF _ storeWordUser_submonad_fn
                                 submonad_asUser, symmetric])
       apply (simp add: submonad_args_def pointerInUserData_def)
      apply (simp add: asUser_replace_def Let_def)
     apply (clarsimp simp: asUser_replace_def Let_def typ_at'_def ko_wp_at'_def
                           ps_clear_upd ps_clear_upd_None pointerInUserData_def
                    split: option.split kernel_object.split)
    apply simp
   apply (simp add: ef_storeWord)
  apply assumption
  done

lemma length_syscallMessage:
  "length ARM_H.syscallMessage = unat n_syscallMessage"
  apply (simp add: syscallMessage_def ARM.syscallMessage_def
                msgRegisters_unfold n_syscallMessage_def)
  apply (simp add: upto_enum_def)
  apply (simp add: fromEnum_def enum_register)
  done

end

context kernel_m begin

(*FIXME: arch_split: C kernel names hidden by Haskell names *)
(*FIXME: fupdate simplification issues for 2D arrays *)
abbreviation "syscallMessageC \<equiv>  kernel_all_global_addresses.fault_messages.[unat MessageID_Syscall]"
lemmas syscallMessageC_def = kernel_all_substitute.fault_messages_def
abbreviation "exceptionMessageC \<equiv> kernel_all_substitute.fault_messages.[unat MessageID_Exception]"
lemmas exceptionMessageC_def = kernel_all_substitute.fault_messages_def

lemma syscallMessage_ccorres:
  "n < unat n_syscallMessage
      \<Longrightarrow> register_from_H (ARM_H.syscallMessage ! n)
           = index syscallMessageC n"
  apply (simp add: ARM_H.syscallMessage_def syscallMessageC_def
                   ARM.syscallMessage_def
                   MessageID_Exception_def MessageID_Syscall_def
                   n_syscallMessage_def msgRegisters_unfold)
  apply (simp add: upto_enum_def fromEnum_def enum_register)
  apply (simp add: toEnum_def enum_register)
  apply (clarsimp simp: fupdate_def Kernel_C.CPSR_def
              | drule nat_less_cases' | erule disjE)+
  done

end

context begin interpretation Arch . (*FIXME: arch_split*)

definition
  "handleArchFaultReply' f sender receiver tag \<equiv> do
     label \<leftarrow> return $ msgLabel tag;
     mlen \<leftarrow> return $ msgLength tag;
     case f of
       VMFault _ _ \<Rightarrow> do
         sendBuf \<leftarrow> lookupIPCBuffer False sender;
         stateAssert (tcb_at' sender) [];
         case sendBuf of
           None \<Rightarrow> return ()
         | Some bufferPtr \<Rightarrow> do
             mapM loadWordUser
               (map (\<lambda>i. bufferPtr + PPtr (i * 4))
                    [(scast n_msgRegisters :: word32) + 1.e. msgMaxLength]);
             return ()
           od;
         return True
       od
    od"

definition
  "handleFaultReply' f sender receiver \<equiv> do
     tag \<leftarrow> getMessageInfo sender;
     label \<leftarrow> return $ msgLabel tag;
     mlen \<leftarrow> return $ msgLength tag;
     case f of
       CapFault _ _ _ \<Rightarrow> return True
     | ArchFault af \<Rightarrow> handleArchFaultReply' af sender receiver tag
     | UnknownSyscallException _ \<Rightarrow> do
         t \<leftarrow> getSanitiseRegisterInfo receiver;
         regs \<leftarrow> return $ take (unat mlen) syscallMessage;
         zipWithM_x (\<lambda>rs rd. do
           v \<leftarrow> asUser sender $ getRegister rs;
           asUser receiver $ setRegister rd $ sanitiseRegister t rd v
         od) msgRegisters regs;
         sendBuf \<leftarrow> lookupIPCBuffer False sender;
         case sendBuf of
           None \<Rightarrow> return ()
         | Some bufferPtr \<Rightarrow>
             zipWithM_x (\<lambda>i rd. do
               v \<leftarrow> loadWordUser (bufferPtr + PPtr (i * 4));
               asUser receiver $ setRegister rd $ sanitiseRegister t rd v
             od) [(scast n_msgRegisters :: word32) + 1.e. scast n_syscallMessage] (drop (unat (scast n_msgRegisters :: word32)) regs);
         return (label = 0)
       od
     | UserException _ _ \<Rightarrow> do
         t \<leftarrow> getSanitiseRegisterInfo receiver;
         regs \<leftarrow> return $ take (unat mlen) exceptionMessage;
         zipWithM_x (\<lambda>rs rd. do
           v \<leftarrow> asUser sender $ getRegister rs;
           asUser receiver $ setRegister rd $ sanitiseRegister t rd v
         od) msgRegisters regs;
         return (label = 0)
       od
  od"

lemma loadWordUser_discarded:
  "loadWordUser p >>= (\<lambda>_. n) =
   stateAssert (pointerInUserData p and K (p && mask 2 = 0)) [] >>= (\<lambda>_. n)"
  apply (rule ext)
  apply (clarsimp simp: loadWordUser_def loadWord_def bind_def assert_def
                        stateAssert_def split_def return_def fail_def
                        doMachineOp_def gets_def get_def select_f_def
                        modify_def put_def)
  done

lemma stateAssert_mapM_loadWordUser_comm:
  "do x \<leftarrow> stateAssert P []; y \<leftarrow> mapM loadWordUser ptrs; n od =
   do y \<leftarrow> mapM loadWordUser ptrs; x \<leftarrow> stateAssert P []; n od"
  apply (rule bind_inv_inv_comm)
     apply (wp stateAssert_inv)
    apply (wp mapM_wp_inv)+
  apply simp
  done

lemmas syscallMessage_unfold
  = ARM_H.syscallMessage_def
    ARM.syscallMessage_def
        [unfolded upto_enum_def, simplified,
         unfolded fromEnum_def enum_register, simplified,
         unfolded toEnum_def enum_register, simplified]

lemma handleArchFaultReply':
  notes option.case_cong_weak [cong] wordSize_def'[simp]
  shows "(do
    sb \<leftarrow> lookupIPCBuffer False s;
    msg \<leftarrow> getMRs s sb tag;
    handleArchFaultReply f r (msgLabel tag) msg
  od) x' = handleArchFaultReply' f s r tag x'"
  apply (unfold handleArchFaultReply'_def getMRs_def msgMaxLength_def
                bit_def msgLengthBits_def msgRegisters_unfold
                fromIntegral_simp1 fromIntegral_simp2
                shiftL_word)
  apply (simp add: bind_assoc)
  apply (clarsimp simp: mapM_def sequence_def bind_assoc asUser_bind_distrib
                        asUser_return submonad_asUser.fn_stateAssert)
  apply (case_tac f)
  apply (clarsimp simp: handleArchFaultReply_def asUser_getRegister_discarded
                          bind_subst_lift [OF stateAssert_stateAssert]
                          pred_conj_def)
  apply (rule bind_apply_cong [OF refl], rename_tac sb s'')
  apply (rule bind_apply_cong [OF refl], rename_tac rv r'')
  apply (case_tac sb, simp_all add: word_size n_msgRegisters_def)[1]
  done

lemmas lookup_uset_getreg_swap = bind_inv_inv_comm[OF lookupIPCBuffer_inv'
                                 user_getreg_inv'
                                 empty_fail_lookupIPCBuffer
                                 empty_fail_asUser[OF getRegister_empty_fail]]

end

lemma mapM_x_zip_take_Cons_append:
  "n = 0 \<longrightarrow> zs = []
  \<Longrightarrow> mapM_x f (zip (x # xs) (take n (y # ys) @ zs))
      = do
        when (n > 0) (f (x, y));
        mapM_x f (zip xs (take (n - 1) ys @ zs))
      od"
  by (cases n, simp_all add: mapM_x_Cons)

lemma threadGet_lookupIPCBuffer_comm:
  "do
     a \<leftarrow> lookupIPCBuffer x y;
     t \<leftarrow> threadGet id r;
     c a t
   od = do
     t \<leftarrow> threadGet id r;
     a \<leftarrow> lookupIPCBuffer x y;
     c a t
  od"
  by (rule bind_inv_inv_comm; wp?; auto)

lemma getSanitiseRegisterInfo_lookupIPCBuffer_comm:
  "do
     a \<leftarrow> lookupIPCBuffer x y;
     t \<leftarrow> getSanitiseRegisterInfo r;
     c a t
   od = do
     t \<leftarrow> getSanitiseRegisterInfo r;
     a \<leftarrow> lookupIPCBuffer x y;
     c a t
  od"
  by (rule bind_inv_inv_comm; wp?; auto)


lemma threadGet_moreMapM_comm:
  "do
     a \<leftarrow>
       case sb of None \<Rightarrow> return []
       | Some bufferPtr \<Rightarrow> return (xs bufferPtr) >>= mapM loadWordUser;
     t \<leftarrow> threadGet id r;
     c a t
   od = do
     t \<leftarrow> threadGet id r;
     a \<leftarrow>
       case sb of None \<Rightarrow> return []
       | Some bufferPtr \<Rightarrow> return (xs bufferPtr) >>= mapM loadWordUser;
     c a t
  od"
  apply (rule bind_inv_inv_comm)
     apply (rule hoare_pre, wpc; (wp mapM_wp')?)
     apply simp
    apply wp
   apply (auto split: option.splits)
  done

lemma getSanitiseRegisterInfo_moreMapM_comm:
  "do
     a \<leftarrow>
       case sb of None \<Rightarrow> return []
       | Some bufferPtr \<Rightarrow> return (xs bufferPtr) >>= mapM loadWordUser;
     t \<leftarrow> getSanitiseRegisterInfo r;
     c a t
   od = do
     t \<leftarrow> getSanitiseRegisterInfo r;
     a \<leftarrow>
       case sb of None \<Rightarrow> return []
       | Some bufferPtr \<Rightarrow> return (xs bufferPtr) >>= mapM loadWordUser;
     c a t
  od"
  apply (rule bind_inv_inv_comm)
     apply (rule hoare_pre, wpc; (wp mapM_wp')?)
     apply simp
    apply wp
   apply (auto split: option.splits)
  done


lemma monadic_rewrite_symb_exec_r':
  "\<lbrakk> \<And>s. \<lbrace>op = s\<rbrace> m \<lbrace>\<lambda>r. op = s\<rbrace>; no_fail P m;
     \<And>rv. monadic_rewrite F False (Q rv) x (y rv);
     \<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace> \<rbrakk>
      \<Longrightarrow> monadic_rewrite F False P x (m >>= y)"
  apply (rule monadic_rewrite_imp)
   apply (rule monadic_rewrite_symb_exec_r; assumption)
  apply simp
  done

lemma monadic_rewrite_threadGet_return:
  "monadic_rewrite True False (tcb_at' r) (return x) (do t \<leftarrow> threadGet f r; return x od)"
  apply (rule monadic_rewrite_symb_exec_r')
     apply wp+
   apply (rule monadic_rewrite_refl)
  apply wp
  done

context begin interpretation Arch .

lemma no_fail_getSanitiseRegisterInfo[wp, simp]:
  "no_fail (tcb_at' r) (getSanitiseRegisterInfo r)"
  apply (simp add: getSanitiseRegisterInfo_def)
  by wpsimp

end


lemma monadic_rewrite_getSanitiseRegisterInfo_return:
  "monadic_rewrite True False (tcb_at' r) (return x) (do t \<leftarrow> getSanitiseRegisterInfo r; return x od)"
  apply (rule monadic_rewrite_symb_exec_r')
     apply wp+
   apply (rule monadic_rewrite_refl)
  apply wp
  done

lemma monadic_rewrite_getSanitiseRegisterInfo_drop:
  "monadic_rewrite True False (tcb_at' r) (d) (do t \<leftarrow> getSanitiseRegisterInfo r; d od)"
  apply (rule monadic_rewrite_symb_exec_r')
     apply wp+
   apply (rule monadic_rewrite_refl)
  apply wp
  done


lemma monadic_rewrite_inst: "monadic_rewrite F E P f g \<Longrightarrow> monadic_rewrite F E P f g"
  by simp

context kernel_m begin interpretation Arch .

lemma threadGet_discarded:
  "(threadGet f t >>= (\<lambda>_. n)) = stateAssert (tcb_at' t) [] >>= (\<lambda>_. n)"
  apply (simp add: threadGet_def getObject_get_assert liftM_def bind_assoc stateAssert_def)
  apply (rule ext)
  apply (simp add: bind_def simpler_gets_def get_def)
  done

lemma monadic_rewrite_do_flip:
  "monadic_rewrite E F P (do c \<leftarrow> j; a \<leftarrow> f; b \<leftarrow> g c; return (a, c) od)
    (do c \<leftarrow> j; b \<leftarrow> g c; a \<leftarrow> f; return (a, c) od)
    \<Longrightarrow> monadic_rewrite E F P (do c \<leftarrow> j; a \<leftarrow> f; b \<leftarrow> g c; h a c od)
    (do c \<leftarrow> j; b \<leftarrow> g c; a \<leftarrow> f; h a c od)"
  apply (drule_tac h="\<lambda>(a, b). h a b" in monadic_rewrite_bind_head)
  apply (simp add: bind_assoc)
  done

lemma handleFaultReply':
  notes option.case_cong_weak [cong] wordSize_def'[simp] take_append[simp del]
  assumes neq: "s \<noteq> r"
  shows "monadic_rewrite True False (tcb_at' s and tcb_at' r) (do
    tag \<leftarrow> getMessageInfo s;
    sb \<leftarrow> lookupIPCBuffer False s;
    msg \<leftarrow> getMRs s sb tag;
    handleFaultReply f r (msgLabel tag) msg
  od) (handleFaultReply' f s r)"
  apply (unfold handleFaultReply'_def getMRs_def msgMaxLength_def
                bit_def msgLengthBits_def msgRegisters_unfold
                fromIntegral_simp1 fromIntegral_simp2
                shiftL_word)
  apply (simp add: bind_assoc)
  apply (rule monadic_rewrite_bind_tail)
   apply (clarsimp simp: mapM_def sequence_def bind_assoc asUser_bind_distrib
                         asUser_return submonad_asUser.fn_stateAssert)
   apply (case_tac f, simp_all add: handleFaultReply_def zipWithM_x_mapM_x zip_take)
   (* UserException *)
      apply (clarsimp simp: handleFaultReply_def zipWithM_x_mapM_x
                            zip_Cons ARM_H.exceptionMessage_def
                            ARM.exceptionMessage_def
                            mapM_x_Cons mapM_x_Nil)
      apply (rule monadic_rewrite_symb_exec_l, wp+)
       apply (rule_tac P="tcb_at' s and tcb_at' r" in monadic_rewrite_inst)
       apply (case_tac rv; (case_tac "msgLength tag < scast n_msgRegisters",
               (erule disjE[OF word_less_cases],
                 ( clarsimp simp: n_msgRegisters_def asUser_bind_distrib
                                  mapM_x_Cons mapM_x_Nil bind_assoc
                                  asUser_getRegister_discarded asUser_mapMloadWordUser_threadGet_comm
                                  asUser_getRegister_getSanitiseRegisterInfo_comm
                                  asUser_mapMloadWordUser_getSanitiseRegisterInfo_comm
                                  asUser_comm[OF neq] asUser_getRegister_threadGet_comm
                                  bind_comm_mapM_comm [OF asUser_loadWordUser_comm, symmetric]
                                  word_le_nat_alt[of 4, simplified linorder_not_less[symmetric, of 4]]
                                  asUser_return submonad_asUser.fn_stateAssert
                 | rule monadic_rewrite_bind_tail monadic_rewrite_refl
                        monadic_rewrite_symb_exec_l[OF stateAssert_inv]
                        monadic_rewrite_symb_exec_l[OF mapM_x_mapM_valid[OF mapM_x_wp']]
                 | wp asUser_tcb_at' lookupIPCBuffer_inv' )+)+))
      apply wp
     (* capFault *)
     apply (rule monadic_rewrite_symb_exec_l, (wp empty_fail_asUser)+)+
          apply(case_tac rv)
          apply (clarsimp
                | rule monadic_rewrite_bind_tail monadic_rewrite_refl
                       monadic_rewrite_symb_exec_l[OF mapM_x_mapM_valid[OF mapM_x_wp']]
                | wp mapM_x_mapM_valid[OF mapM_x_wp'[OF loadWordUser_inv]]
                     empty_fail_loadWordUser)+
    (* UnknownSyscallExceptio *)
    apply (simp add: zip_append2 mapM_x_append asUser_bind_distrib split_def bind_assoc)
    apply (rule monadic_rewrite_imp)
     apply (rule monadic_rewrite_trans[rotated])
      apply (rule monadic_rewrite_do_flip)
      apply (rule monadic_rewrite_bind_tail)
       apply (rule_tac P="inj (case_bool s r)" in monadic_rewrite_gen_asm)
       apply (rule monadic_rewrite_trans[OF _ monadic_rewrite_transverse])
         apply (rule monadic_rewrite_weaken[where F=False and E=True], simp)
         apply (rule isolate_thread_actions_rewrite_bind
                     bool.simps setRegister_simple
                     zipWithM_setRegister_simple
                     thread_actions_isolatable_bind lookupIPCBuffer_isolatable
                     lookupIPCBuffer_isolatable[THEN thread_actions_isolatableD]
                     copy_registers_isolate_general thread_actions_isolatable_return
                     thread_actions_isolatable_return[THEN thread_actions_isolatableD]
               | assumption
               | wp assert_inv)+
       apply (rule monadic_rewrite_isolate_final[where P="\<top>"])
         apply simp+
      apply wp
     (* swap ends *)
     apply (clarsimp simp: handleFaultReply_def zipWithM_x_mapM_x
                            zip_Cons syscallMessage_unfold
                            n_syscallMessage_def
                            upto_enum_word mapM_x_Cons mapM_x_Nil)
     apply (simp add: getSanitiseRegisterInfo_moreMapM_comm asUser_getRegister_getSanitiseRegisterInfo_comm getSanitiseRegisterInfo_lookupIPCBuffer_comm)
     apply (rule monadic_rewrite_bind_tail)
     apply (rule monadic_rewrite_bind_tail [where Q="\<lambda>_. tcb_at' r"])
      apply (case_tac sb)
       apply (case_tac "msgLength tag < scast n_msgRegisters")
        apply (erule disjE[OF word_less_cases],
                 ( clarsimp simp: n_msgRegisters_def asUser_bind_distrib
                                  mapM_x_Cons mapM_x_Nil bind_assoc
                                  asUser_getRegister_discarded
                                  asUser_comm[OF neq] take_zip
                                  word_le_nat_alt[of 4, simplified linorder_not_less[symmetric, of 4]]
                                  asUser_return submonad_asUser.fn_stateAssert
                 | rule monadic_rewrite_bind_tail monadic_rewrite_refl
                        monadic_rewrite_symb_exec_l[OF stateAssert_inv]
                 | wp asUser_tcb_at')+)+
      apply (case_tac "msgLength tag < scast n_msgRegisters")
       apply (erule disjE[OF word_less_cases],
                 ( clarsimp simp: n_msgRegisters_def asUser_bind_distrib
                                  mapM_x_Cons mapM_x_Nil bind_assoc
                                  zipWithM_x_Nil
                                  asUser_getRegister_discarded
                                  asUser_comm[OF neq] take_zip
                                  bind_comm_mapM_comm [OF asUser_loadWordUser_comm, symmetric]
                                  asUser_return submonad_asUser.fn_stateAssert
                 | rule monadic_rewrite_bind_tail monadic_rewrite_refl
                        monadic_rewrite_symb_exec_l[OF mapM_x_mapM_valid[OF mapM_x_wp']]
                        monadic_rewrite_symb_exec_l[OF stateAssert_inv]
                        monadic_rewrite_threadGet_return
                        monadic_rewrite_getSanitiseRegisterInfo_return
                 | wp asUser_tcb_at' mapM_wp')+)+
      apply (simp add: n_msgRegisters_def word_le_nat_alt n_syscallMessage_def
                       linorder_not_less syscallMessage_unfold)
      apply (clarsimp | frule neq0_conv[THEN iffD2, THEN not0_implies_Suc,
                                        OF order_less_le_trans, rotated])+
      apply (subgoal_tac "\<forall>n :: word32. n \<le> scast n_syscallMessage \<longrightarrow> [n .e. msgMaxLength]
                                = [n .e. scast n_syscallMessage]
                                    @ [scast n_syscallMessage + 1 .e. msgMaxLength]")
       apply (simp only: upto_enum_word[where y="scast n_syscallMessage :: word32"]
                         upto_enum_word[where y="scast n_syscallMessage + 1 :: word32"])
       apply (clarsimp simp: bind_assoc asUser_bind_distrib asUser_getRegister_threadGet_comm
                             mapM_x_Cons mapM_x_Nil threadGet_discarded
                             asUser_comm [OF neq] asUser_getRegister_discarded
                             submonad_asUser.fn_stateAssert take_zip
                             bind_subst_lift [OF submonad_asUser.stateAssert_fn]
                             word_less_nat_alt ARM_H.sanitiseRegister_def
                             split_def n_msgRegisters_def msgMaxLength_def
                             bind_comm_mapM_comm [OF asUser_loadWordUser_comm, symmetric]
                             word_size msgLengthBits_def n_syscallMessage_def
                  split del: if_split
                       cong: if_weak_cong)
       apply (rule monadic_rewrite_bind_tail)+
               apply (subst (2) upto_enum_word)
               apply (case_tac "ma < unat n_syscallMessage - 4")
                apply (erule disjE[OF nat_less_cases'],
                       ( clarsimp simp: n_syscallMessage_def bind_assoc asUser_bind_distrib
                                        mapM_x_Cons mapM_x_Nil zipWithM_x_mapM_x mapM_Cons
                                        bind_comm_mapM_comm [OF asUser_loadWordUser_comm, symmetric]
                                        asUser_loadWordUser_comm loadWordUser_discarded asUser_return
                                        zip_take_triv2 msgMaxLength_def
                                  cong: if_weak_cong
                       | simp
                       | rule monadic_rewrite_bind_tail
                              monadic_rewrite_refl
                              monadic_rewrite_symb_exec_l[OF stateAssert_inv]
                              monadic_rewrite_symb_exec_l[OF mapM_x_mapM_valid[OF mapM_x_wp']]
                              monadic_rewrite_threadGet_return
                              monadic_rewrite_getSanitiseRegisterInfo_return
                              monadic_rewrite_getSanitiseRegisterInfo_drop
                       | wp empty_fail_loadWordUser)+)+
      apply (clarsimp simp: upto_enum_word word_le_nat_alt simp del: upt.simps cong: if_weak_cong)
      apply (cut_tac i="unat n" and j="Suc (unat (scast n_syscallMessage :: word32))"
                                and k="Suc msgMaxLength" in upt_add_eq_append')
        apply (simp add: n_syscallMessage_def)
       apply (simp add: n_syscallMessage_def msgMaxLength_unfold)
      apply (simp add: n_syscallMessage_def msgMaxLength_def
                       msgLengthBits_def shiftL_nat
                  del: upt.simps upt_rec_numeral)
      apply (simp add: upto_enum_word cong: if_weak_cong)
     apply wp+
    (* ArchFault *)
    apply (simp add: neq inj_case_bool split: bool.split)
   apply (rule monadic_rewrite_imp)
    apply (rule monadic_rewrite_is_refl)
    apply (rule ext)
    apply (unfold handleArchFaultReply'[symmetric] getMRs_def msgMaxLength_def
                  bit_def msgLengthBits_def msgRegisters_unfold
                  fromIntegral_simp1 fromIntegral_simp2 shiftL_word)
    apply (clarsimp simp: mapM_def sequence_def bind_assoc asUser_bind_distrib
                          asUser_return submonad_asUser.fn_stateAssert)
   apply wpsimp+
  done

end

context kernel_m
begin

(* FIXME: move *)
lemma ccorres_merge_return:
  "ccorres (\<lambda>a c. r (f a) c) xf P P' hs H C \<Longrightarrow>
   ccorres r xf P P' hs (do x \<leftarrow> H; return (f x) od) C"
  by (rule ccorres_return_into_rel)

(* FIXME: move *)
lemma ccorres_break:
  assumes r: "\<And>s s'. \<lbrakk> (s,s') \<in> rf_sr; P s; s' \<in> P' \<rbrakk> \<Longrightarrow> r (Inl e) (xf s')"
  assumes xf: "\<And>s. xf (global_exn_var_'_update (\<lambda>_. Break) s) = xf s"
  shows "ccorres r xf P P' (catchbrk_C#hs) (throwError e) break_C"
  apply (simp add: throwError_def cbreak_def)
  apply (clarsimp simp: ccorres_underlying_def return_def split: xstate.splits)
  apply (frule (2) r)
  apply (rule conjI)
   apply clarsimp
   apply (erule exec_handlers.cases, simp_all)[1]
    apply clarsimp
    apply (erule exec_elim_cases, simp_all)[1]
    apply (erule exec_elim_cases, simp_all)[1]
    apply clarsimp
    apply (erule exec_elim_cases, simp_all)[1]
    apply clarsimp
    apply (erule exec_handlers.cases, simp_all)[1]
     apply (clarsimp simp: catchbrk_C_def)
     apply (erule exec_elim_cases, simp_all)[1]
      apply (erule exec_elim_cases, simp_all)[1]
     apply clarsimp
    apply (clarsimp simp: catchbrk_C_def)
    apply (erule exec_elim_cases, simp_all)[1]
     apply clarsimp
     apply (erule exec_elim_cases, simp_all)[1]
     apply (clarsimp simp: unif_rrel_def xf)
    apply clarsimp
   apply clarsimp
   apply (erule exec_elim_cases, simp_all)[1]
   apply (erule exec_elim_cases, simp_all)[1]
   apply (erule exec_elim_cases, simp_all)[1]
  apply (rule conjI, clarsimp)
   apply (erule exec_handlers.cases, simp_all)[1]
    apply clarsimp
    apply ((erule exec_elim_cases, simp_all)[1])+
    apply (clarsimp simp: catchbrk_C_def)
    apply (erule exec_handlers.cases, simp_all)[1]
     apply (auto elim: exec_elim_cases)[3]
  apply (rule conjI, clarsimp)
   apply (erule exec_handlers.cases, simp_all)[1]
    apply clarsimp
    apply ((erule exec_elim_cases, simp_all)[1])+
    apply (clarsimp simp: catchbrk_C_def)
    apply (erule exec_handlers.cases, simp_all)[1]
     apply (auto elim: exec_elim_cases)[3]
  apply clarsimp
  apply (erule exec_handlers.cases, simp_all)[1]
   apply clarsimp
   apply ((erule exec_elim_cases, simp_all)[1])+
   apply (clarsimp simp: catchbrk_C_def)
   apply (erule exec_handlers.cases, simp_all)[1]
   apply (auto elim!: exec_elim_cases)
  done

(* FIXME: move *)
lemma ccorres_break_return:
  assumes r: "\<And>s s'. \<lbrakk> (s,s') \<in> rf_sr; P s; s' \<in> P' \<rbrakk> \<Longrightarrow> r n (xf s')"
  assumes xf: "\<And>s. xf (global_exn_var_'_update (\<lambda>_. Break) s) = xf s"
  shows "ccorres r xf P P' (catchbrk_C#hs) (return n) break_C"
  apply (simp add: throwError_def cbreak_def)
  apply (clarsimp simp: ccorres_underlying_def return_def split: xstate.splits)
  apply (frule (2) r)
  apply (rule conjI)
   apply clarsimp
   apply (erule exec_handlers.cases, simp_all)[1]
    apply clarsimp
    apply (erule exec_elim_cases, simp_all)[1]
    apply (erule exec_elim_cases, simp_all)[1]
    apply clarsimp
    apply (erule exec_elim_cases, simp_all)[1]
    apply clarsimp
    apply (erule exec_handlers.cases, simp_all)[1]
     apply (clarsimp simp: catchbrk_C_def)
     apply (erule exec_elim_cases, simp_all)[1]
      apply (erule exec_elim_cases, simp_all)[1]
     apply clarsimp
    apply (clarsimp simp: catchbrk_C_def)
    apply (erule exec_elim_cases, simp_all)[1]
     apply clarsimp
     apply (erule exec_elim_cases, simp_all)[1]
     apply (clarsimp simp: unif_rrel_def xf)
    apply clarsimp
   apply clarsimp
   apply (erule exec_elim_cases, simp_all)[1]
   apply (erule exec_elim_cases, simp_all)[1]
   apply (erule exec_elim_cases, simp_all)[1]
  apply (rule conjI, clarsimp)
   apply (erule exec_handlers.cases, simp_all)[1]
    apply clarsimp
    apply ((erule exec_elim_cases, simp_all)[1])+
    apply (clarsimp simp: catchbrk_C_def)
    apply (erule exec_handlers.cases, simp_all)[1]
     apply (auto elim: exec_elim_cases)[3]
  apply (rule conjI, clarsimp)
   apply (erule exec_handlers.cases, simp_all)[1]
    apply clarsimp
    apply ((erule exec_elim_cases, simp_all)[1])+
    apply (clarsimp simp: catchbrk_C_def)
    apply (erule exec_handlers.cases, simp_all)[1]
     apply (auto elim: exec_elim_cases)[3]
  apply clarsimp
  apply (erule exec_handlers.cases, simp_all)[1]
   apply clarsimp
   apply ((erule exec_elim_cases, simp_all)[1])+
   apply (clarsimp simp: catchbrk_C_def)
   apply (erule exec_handlers.cases, simp_all)[1]
   apply (auto elim!: exec_elim_cases)
  done

lemma messageInfoFromWord_spec:
  "\<forall>s. \<Gamma> \<turnstile> {s} Call messageInfoFromWord_'proc {t. seL4_MessageInfo_lift (ret__struct_seL4_MessageInfo_C_' t) =
            \<lparr>label_CL = (w_' s >> 12) && 0xFFFFF, capsUnwrapped_CL = (w_' s >> 9) && 7,
                 extraCaps_CL = (w_' s >> 7) && 3, length_CL = let v = w_' s && 0x7F in if v > msgMaxLength then msgMaxLength else v\<rparr>}"
  apply vcg
  apply (simp add: seL4_MessageInfo_lift_def Let_def msgMaxLength_def mask_def word_sle_def
                   word_sless_def seL4_MsgMaxLength_def
         split: if_split)
  done

lemma messageInfoFromWord_ccorres [corres]:
  "ccorres (\<lambda>r r'. r = message_info_to_H r') ret__struct_seL4_MessageInfo_C_' \<top> {s. w_' s = w} []
           (return (messageInfoFromWord w)) (Call messageInfoFromWord_'proc)"
  apply (rule ccorres_from_spec_modifies [where P = \<top>, simplified])
      apply (rule messageInfoFromWord_spec)
     apply (rule messageInfoFromWord_modifies)
    apply simp
   apply simp
  apply (simp add: return_def messageInfoFromWord_def Let_def message_info_to_H_def
    Types_H.msgLengthBits_def Types_H.msgExtraCapBits_def msgMaxExtraCaps_def
    shiftL_nat msgMaxLength_def)
  apply (rule shiftr_mask_eq' [symmetric, where m = 20, simplified mask_def, simplified])
  apply (simp add: word_size)
  done

lemma getMessageInfo_ccorres:
  "ccorres (\<lambda>r r'. r = message_info_to_H r') ret__struct_seL4_MessageInfo_C_'
           (tcb_at' sender) UNIV hs (getMessageInfo sender)
           (\<acute>ret__unsigned_long :== CALL getRegister(tcb_ptr_to_ctcb_ptr sender,scast Kernel_C.msgInfoRegister);;
            \<acute>ret__struct_seL4_MessageInfo_C :== CALL messageInfoFromWord(\<acute>ret__unsigned_long))"
  unfolding getMessageInfo_def
  apply simp
  apply (rule ccorres_guard_imp2)
  apply ctac
  apply ctac
    apply wp
   apply vcg
  apply (frule (1) obj_at_cslift_tcb)
  apply (clarsimp simp: typ_heap_simps ARM_H.msgInfoRegister_def ARM.msgInfoRegister_def
    Kernel_C.msgInfoRegister_def Kernel_C.R1_def dest!: c_guard_clift)
  done

lemma getMessageInfo_ccorres':
  "ccorres (\<lambda>r r'. r = message_info_to_H r') tag_'
           (tcb_at' sender) UNIV hs (getMessageInfo sender)
           (\<acute>ret__unsigned_long :== CALL getRegister(tcb_ptr_to_ctcb_ptr sender,scast Kernel_C.msgInfoRegister);;
            \<acute>tag :== CALL messageInfoFromWord(\<acute>ret__unsigned_long))"
  unfolding getMessageInfo_def
  apply simp
  apply (rule ccorres_guard_imp2)
  apply ctac
  apply ctac
    apply wp
   apply vcg
  apply (frule (1) obj_at_cslift_tcb)
  apply (clarsimp simp: typ_heap_simps ARM_H.msgInfoRegister_def ARM.msgInfoRegister_def
    Kernel_C.msgInfoRegister_def Kernel_C.R1_def dest!: c_guard_clift)
  done

lemma replyFromKernel_success_empty_ccorres [corres]:
  "ccorres dc xfdc \<top> (UNIV \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>) hs
     (replyFromKernel thread (0, []))
     (Call replyFromKernel_success_empty_'proc)"
  apply (subst replyFromKernel_success_empty)
  apply (cinit lift: thread_')
   apply (rule ccorres_symb_exec_l [OF _ _ _ empty_fail_lookupIPCBuffer])
     apply (ctac add: setRegister_ccorres)
       apply (unfold setMessageInfo_def)
       apply csymbr
       apply ctac
         apply (simp only: fun_app_def)
         apply (ctac add: setRegister_ccorres)
        apply wp
       apply vcg
      apply wp
     apply vcg
    apply wp+
  apply (simp add: ARM_H.msgInfoRegister_def ARM.msgInfoRegister_def
                   Kernel_C.msgInfoRegister_def Kernel_C.R1_def
                   ARM_H.badgeRegister_def ARM.badgeRegister_def
                   Kernel_C.badgeRegister_def Kernel_C.R0_def
                   message_info_to_H_def)
  done

lemma msgRegisters_offset_conv:
  "\<And>offset i. \<lbrakk> offset + i < length ARM_H.msgRegisters \<rbrakk> \<Longrightarrow>
   index msgRegistersC (unat ((of_nat offset :: word32) + of_nat i)) =
   register_from_H (ARM_H.msgRegisters ! (offset + i))"
  apply (simp add: msgRegistersC_def msgRegisters_unfold fupdate_def)
  apply (subst of_nat_add [symmetric])
  apply (case_tac "offset + i", simp_all del: of_nat_add)
  apply (case_tac nat, simp, rename_tac nat, simp)+
  done

lemmas ccorres_pre_stateAssert =
         ccorres_symb_exec_l [OF _ stateAssert_inv stateAssert_wp
                                 empty_fail_stateAssert]

declare setRegister_ccorres[corres]

lemma setMR_ccorres:
  notes if_cong[cong]
  shows
  "ccorres (\<lambda>r r'. r = unat (r' && mask msgLengthBits)) ret__unsigned_'
     (valid_pspace' and  case_option \<top> valid_ipc_buffer_ptr' buf
           and (\<lambda>s. offset < msgMaxLength))
     (UNIV \<inter> {s. offset_' s = of_nat offset} \<inter> {s. reg_' s = v}
             \<inter> {s. receiver_' s = tcb_ptr_to_ctcb_ptr thread}
             \<inter> {s. receiveIPCBuffer_' s = option_to_ptr buf}) []
     (setMR thread buf offset v) (Call setMR_'proc)"
  apply (rule ccorres_gen_asm)
  apply (cinit lift: offset_' reg_' receiver_' receiveIPCBuffer_')
   apply (rule ccorres_cond2'[where R=\<top>])
     apply (simp add: msgRegisters_unfold n_msgRegisters_def Collect_const_mem
                      linorder_not_less word_le_nat_alt unat_of_nat32
                      word_bits_def msgMaxLength_unfold)
     apply arith
    apply wpc
     apply (simp add: option_to_ptr_def option_to_0_def Collect_False
                      ccorres_cond_iffs
                 del: Collect_const)
     apply (rule ccorres_return_C, simp+)[1]
    apply (simp add: option_to_ptr_def option_to_0_def Collect_True
                     ccorres_cond_iffs
                del: Collect_const ptr_add_def')
    apply (rule ccorres_cond_true)
    apply (rule ccorres_split_nothrow_novcg)
        apply (rule ccorres_move_array_assertion_ipc_buffer
               | (rule ccorres_flip_Guard, rule ccorres_move_array_assertion_ipc_buffer))+
        apply (rule storeWordUser_ccorres)
       apply ceqv
      apply (rule ccorres_return_C, simp+)[1]
     apply wp
    apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
    apply (simp add: msgLengthBits_def msgMaxLength_def
                     unat_arith_simps less_mask_eq unat_of_nat
                del: Collect_const)
   apply ctac
     apply (rule ccorres_return_C, simp+)[1]
    apply wp
   apply (simp del: Collect_const)
   apply (vcg exspec=setRegister_modifies)
  apply (simp add: Collect_const_mem option_to_0_def
                   unat_gt_0 option_to_ptr_def)
  apply (intro impI conjI allI, simp_all)
          apply (clarsimp simp: valid_ipc_buffer_ptr'_def)
          apply (erule aligned_add_aligned)
           apply (simp only: word_size_def is_aligned_mult_triv2[where n=2, simplified])
          apply (simp add: msg_align_bits_def)
         apply (simp add: n_msgRegisters_def length_msgRegisters msgLengthBits_def mask_def)
        apply (simp add: msg_align_bits word_size_def msgMaxLength_def
                         length_msgRegisters n_msgRegisters_def)
       apply (simp add: unat_word_ariths msg_align_bits msgMaxLength_def
                        word_less_nat_alt unat_of_nat)
      apply (simp add: unat_word_ariths msg_align_bits msgMaxLength_def
                       word_less_nat_alt unat_of_nat)
     apply (clarsimp simp: valid_ipc_buffer_ptr'_def)
    apply (simp add: unat_of_nat32 word_bits_def msgMaxLength_unfold
                     word_le_nat_alt msgRegisters_ccorres n_msgRegisters_def)
   apply (simp add: unat_of_nat32 msgMaxLength_unfold word_bits_def
                    unat_add_lem[THEN iffD1] less_mask_eq msgLengthBits_def
                    word_less_nat_alt)
  apply (simp add: linorder_not_le n_msgRegisters_def)
  done

lemma setMR_ccorres_dc:
  "ccorres dc xfdc
     (valid_pspace' and  case_option \<top> valid_ipc_buffer_ptr' buf
           and (\<lambda>s. offset < msgMaxLength))
     (UNIV \<inter> {s. offset_' s = of_nat offset} \<inter> {s. reg_' s = v}
             \<inter> {s. receiver_' s = tcb_ptr_to_ctcb_ptr thread}
             \<inter> {s. receiveIPCBuffer_' s = option_to_ptr buf}) []
     (setMR thread buf offset v) (Call setMR_'proc)"
  by (rule ccorres_rel_imp, rule setMR_ccorres, simp)

end

(* FIXME: move *)
context begin interpretation Arch . (*FIXME: arch_split*)
crunch valid_pspace'[wp]: setMR "valid_pspace'"
crunch valid_ipc_buffer_ptr'[wp]: setMR "valid_ipc_buffer_ptr' p"
end

context kernel_m begin

lemma setMRs_lookup_failure_ccorres:
  shows
  "ccorres (\<lambda>r r'. r \<noteq> [] \<and> last r = unat (r' && mask msgLengthBits))
           ret__unsigned_'
     (valid_pspace'
               and (case buf of None \<Rightarrow> \<top> | Some x \<Rightarrow> valid_ipc_buffer_ptr' x)
               and (\<lambda>_. n + length (msgFromLookupFailure lf) < msgMaxLength))
           (UNIV \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr thread\<rbrace>
                 \<inter> \<lbrace>\<acute>receiveIPCBuffer = option_to_ptr buf\<rbrace>
                 \<inter> \<lbrace>map_option lookup_fault_to_H
                        (lookup_fault_lift \<acute>luf) = Some lf\<rbrace>
                 \<inter> \<lbrace>n = unat \<acute>offset\<rbrace>) hs
    (mapM (\<lambda>(x, y). setMR thread buf x y)
        (zip [n ..< msgMaxLength] (msgFromLookupFailure lf)))
    (Call setMRs_lookup_failure_'proc)"
  apply (rule ccorres_gen_asm)+
  apply (cinit' lift: receiver_' receiveIPCBuffer_' luf_' offset_')
   apply csymbr
   apply (rule_tac P="valid_pspace'
                  and (case buf of None \<Rightarrow> \<top> | Some x \<Rightarrow> valid_ipc_buffer_ptr' x)" and P'=UNIV
                in ccorres_inst)
   apply (clarsimp simp: msgFromLookupFailure_def lookup_fault_lift_def
                         Let_def zip_upt_Cons msgMaxLength_unfold
                         mapM_Cons mapM_Nil bind_assoc
               simp del: Collect_const
                  split: if_split_asm)
      apply (rule ccorres_guard_imp2)
       apply csymbr
       apply (ctac add: setMR_ccorres)
         apply (ccorres_rewrite)
         apply (simp add: ccorres_cond_iffs)
         apply (rule ccorres_return_C, simp+)[1]
        apply wp
       apply (simp del: Collect_const)
       apply (vcg exspec=setMR_modifies)
      apply (clarsimp simp: msgMaxLength_unfold Collect_const_mem)
      apply (simp add: lookup_fault_tag_defs)
     apply (rule ccorres_guard_imp2)
      apply csymbr
      apply (ctac add: setMR_ccorres)
        apply (simp add: ccorres_cond_iffs)
        apply (ccorres_rewrite)
        apply (rule ccorres_rhs_assoc)+
        apply csymbr
        apply (ctac add: setMR_ccorres)
          apply (rule ccorres_return_C, simp+)[1]
         apply wp
        apply simp
        apply (vcg exspec=setMR_modifies)
       apply (wp hoare_case_option_wp)
      apply (simp add: Collect_const_mem)
      apply (vcg exspec=setMR_modifies)
     apply (clarsimp simp: msgMaxLength_unfold Collect_const_mem)
     apply (simp add: lookup_fault_missing_capability_lift_def
                      lookup_fault_lift_missing_capability)
     apply (simp add: lookup_fault_tag_defs)
    apply (rule ccorres_guard_imp2)
     apply csymbr
     apply (ctac add: setMR_ccorres)
       apply (simp add: ccorres_cond_iffs)
       apply (ccorres_rewrite)
       apply (rule ccorres_rhs_assoc)+
       apply csymbr
       apply (ctac add: setMR_ccorres_dc)
         apply csymbr
         apply (ctac add: setMR_ccorres)
           apply (rule ccorres_return_C, simp+)[1]
          apply wp
         apply simp
         apply (vcg exspec=setMR_modifies)
        apply (wp hoare_case_option_wp)
       apply (simp add: Collect_const_mem)
       apply (vcg exspec=setMR_modifies)
      apply (wp hoare_case_option_wp)
     apply (simp add: Collect_const_mem)
     apply (vcg exspec=setMR_modifies)
    apply (clarsimp simp: msgMaxLength_unfold Collect_const_mem)
    apply (simp add: lookup_fault_depth_mismatch_lift_def
                     lookup_fault_lift_depth_mismatch)
    apply (simp add: lookup_fault_tag_defs)
   apply (rule ccorres_guard_imp2)
    apply csymbr
    apply (ctac add: setMR_ccorres)
      apply (simp add: ccorres_cond_iffs)
     apply (ccorres_rewrite)
      apply (rule ccorres_rhs_assoc)+
      apply csymbr
      apply (ctac add: setMR_ccorres_dc)
        apply csymbr
        apply (ctac add: setMR_ccorres_dc)
          apply csymbr
          apply (ctac add: setMR_ccorres)
            apply (rule ccorres_return_C, simp+)[1]
           apply (wp hoare_case_option_wp
              | (simp add: Collect_const_mem, vcg exspec=setMR_modifies))+
   apply (clarsimp simp: msgMaxLength_unfold Collect_const_mem)
   apply (simp add: lookup_fault_guard_mismatch_lift_def
                    lookup_fault_lift_guard_mismatch)
   apply (simp add: lookup_fault_tag_defs)
  apply simp
  done

lemma setMRs_syscall_error_ccorres:
  "ccorres (\<lambda>r r'. r = r' && mask msgLengthBits) ret__unsigned_long_'
     (valid_pspace'
               and (case buf of None \<Rightarrow> \<top> | Some x \<Rightarrow> valid_ipc_buffer_ptr' x)
               and (\<lambda>_. msg = snd (msgFromSyscallError err)))
           (UNIV \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>
                 \<inter> \<lbrace>\<acute>receiveIPCBuffer = option_to_ptr buf\<rbrace>
                 \<inter> \<lbrace>syscall_error_to_H \<acute>current_syscall_error
                          (lookup_fault_lift \<acute>current_lookup_fault)
                       = Some err\<rbrace>) hs
     (setMRs thread buf msg)
     (Call setMRs_syscall_error_'proc)"
  (is "ccorres ?r ret__unsigned_long_' ?P ?P' hs ?a ?c")
  apply (rule ccorres_gen_asm)
  apply (cinit')
   apply (rule_tac xf' = "\<lambda>s. current_syscall_error_' (globals s)"
                in ccorres_abstract)
    apply (rule ceqv_rules, rule rewrite_xfI,  simp,  rule ceqv_refl)+
    apply (rule ceqv_refl)
   apply (rename_tac err')
   apply (rule_tac xf' = "\<lambda>s. current_lookup_fault_' (globals s)"
                in ccorres_abstract)
    apply (rule ceqv_rules, rule rewrite_xfI,  simp,  rule ceqv_refl)+
    apply (rule ceqv_refl)
   apply (rename_tac luf')
   apply (rule_tac P="Some err = syscall_error_to_H err' (lookup_fault_lift luf')"
                in ccorres_gen_asm2)
   apply (rule_tac A="?P" and A'="?P'" in ccorres_guard_imp2)
    apply (simp add: setMRs_to_setMR del: Collect_const)
    apply (rule ccorres_stateAssert)
    apply (rule ccorres_Cond_rhs[rotated])+
            apply (rule ccorres_inst[where P=\<top> and P'=UNIV])
            apply simp
           apply (rule ccorres_inst[where P=\<top> and P'=UNIV])
           apply (simp add: syscall_error_to_H_def)
          apply (simp_all add: syscall_error_to_H_def msgFromSyscallError_def
                               zipWithM_mapM mapM_Nil mapM_Cons
                               msgMaxLength_unfold zip_upt_Cons bind_assoc)
           apply (ctac add:setMR_ccorres)
             apply (rule ccorres_return_C,simp+)[1]
            apply (wp | (simp add: Collect_const_mem,
              vcg exspec=setMR_modifies exspec=setMRs_lookup_failure_modifies))+
          apply (subgoal_tac "msg = []")
           apply (simp add: zipWithM_mapM mapM_Nil)
           apply (rule ccorres_return_C, simp+)[1]
          apply (simp split: if_split_asm)
         apply (subgoal_tac "err = FailedLookup (to_bool (failedLookupWasSource_C err'))
                                      (lookup_fault_to_H (the (lookup_fault_lift luf')))")
          apply (simp add: zip_upt_Cons mapM_Cons bind_assoc)
          apply (rule ccorres_rhs_assoc)+
          apply (ctac add: setMR_ccorres_dc)
            apply (ctac add: setMRs_lookup_failure_ccorres[unfolded msgMaxLength_unfold])
              apply (rule ccorres_return_C, simp+)[1]
             apply (wp hoare_case_option_wp
                | (simp add: Collect_const_mem,
                          vcg exspec=setMR_modifies exspec=setMRs_lookup_failure_modifies))+
         apply (clarsimp simp: map_option_Some_eq2)
        apply (rule ccorres_return_C, simp+)[1]
       apply (rule ccorres_rhs_assoc
                 | (rule ccorres_inst, ctac add: setMR_ccorres_dc)
                 | (rule ccorres_inst, ctac add: setMR_ccorres)
                 | (rule ccorres_return_C, simp+)[1]
                 | wp hoare_case_option_wp
                 | (simp del: Collect_const, vcg exspec=setMR_modifies)
               )+
   apply (simp add: msgMaxLength_unfold if_1_0_0 true_def false_def)
   apply (clarsimp split:if_split_asm simp:syscall_error_to_H_def map_option_Some_eq2)
   apply (simp add: msgFromLookupFailure_def
                 split: lookup_failure.split
            | simp add: to_bool_def split: if_split)+
  done

lemma lookupIPCBuffer_aligned_option_to_0:
  "\<lbrace>valid_objs'\<rbrace> lookupIPCBuffer b s \<lbrace>\<lambda>rv s. is_aligned (option_to_0 rv) msg_align_bits\<rbrace>"
  apply (rule hoare_strengthen_post, rule lookupIPCBuffer_valid_ipc_buffer)
  apply (simp add: option_to_0_def valid_ipc_buffer_ptr'_def split: option.split_asm)
  done

lemma Cond_if_mem:
   "(Cond (if P then UNIV else {})) = (Cond {s. P})"
   by simp

lemma copyMRs_register_loop_helper:
  fixes n
  defines regs: "regs \<equiv> take (unat n) ARM_H.msgRegisters"
  shows
  "\<forall>i. i<length regs \<longrightarrow>
   ccorres dc xfdc \<top> \<lbrace>\<acute>i = of_nat i\<rbrace> hs
     (do v \<leftarrow> asUser sender (getRegister (regs ! i));
         asUser receiver (setRegister (regs ! i) v)
      od)
     (Guard ArrayBounds \<lbrace>\<acute>i < 4\<rbrace>
      (\<acute>ret__unsigned_long :== CALL getRegister(tcb_ptr_to_ctcb_ptr sender,
               ucast (index msgRegistersC (unat \<acute>i))));;
      Guard ArrayBounds \<lbrace>\<acute>i < 4\<rbrace>
      (CALL setRegister(tcb_ptr_to_ctcb_ptr receiver,
               ucast (index msgRegistersC (unat \<acute>i)),
               \<acute>ret__unsigned_long)))"
  apply clarsimp
  apply (rule ccorres_guard_imp)
    apply ctac
      apply ctac
     apply wp
    apply vcg
   apply simp
  apply (clarsimp simp: regs msgRegistersC_def msgRegisters_unfold)
  apply (simp |
         (case_tac i,
          clarsimp simp: fupdate_def index_update index_update2 Kernel_C.R2_def
                         Kernel_C.R3_def Kernel_C.R4_def Kernel_C.R5_def
                         Kernel_C.R6_def Kernel_C.R7_def,
          rename_tac i))+
  done

lemma mab_gt_2 [simp]:
  "2 \<le> msg_align_bits" by (simp add: msg_align_bits)

lemma wb_gt_2:
  "2 < word_bits" by (simp add: word_bits_conv)

(* FIXME move *)
lemma mapM_only_length:
  "do ys \<leftarrow> mapM f xs;
      g (length ys)
   od =
   do _ \<leftarrow> mapM_x f xs;
      g (length xs)
   od"
  by (subst bind_return_subst [OF mapM_length])
     (rule mapM_discarded)


lemma length_upto_enum_cases:
  fixes a :: word32
  shows "length [a .e. b] = (if a \<le> b then Suc (unat b) - unat a else 0)"
  apply (case_tac "a \<le> b")
   apply (clarsimp simp: length_upto_enum)
  apply (clarsimp simp: upto_enum_def)
  apply unat_arith
  done

(* FIXME move *)
lemma copyMRs_ccorres [corres]:
notes
  wordSize_def'[simp]
shows
  "ccorres (\<lambda>r r'. r = r' && mask msgLengthBits) ret__unsigned_long_'
    (valid_pspace' and tcb_at' sender and tcb_at' receiver
        and (case sendBuffer of None \<Rightarrow> \<top> | Some x \<Rightarrow> valid_ipc_buffer_ptr' x)
        and (case recvBuffer of None \<Rightarrow> \<top> | Some x \<Rightarrow> valid_ipc_buffer_ptr' x)
        and K (sendBuffer \<noteq> Some 0) and K (recvBuffer \<noteq> Some 0)
        and K (unat n \<le> msgMaxLength))
    (UNIV \<inter> \<lbrace>\<acute>n = \<acute>n && mask msgLengthBits \<and> \<acute>n = n\<rbrace>
          \<inter> \<lbrace>\<acute>sendBuf = Ptr (option_to_0 sendBuffer)\<rbrace>
          \<inter> \<lbrace>\<acute>recvBuf = Ptr (option_to_0 recvBuffer)\<rbrace>
          \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
          \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>) []
    (copyMRs sender sendBuffer receiver recvBuffer n)
    (Call copyMRs_'proc)"
  apply (unfold K_def, intro ccorres_gen_asm)
  apply (cinit lift: n_' sendBuf_' recvBuf_' sender_' receiver_'
               simp: whileAnno_def)
   apply (simp only: mapM_discarded)
   apply (rule ccorres_rhs_assoc2)
   apply (rule_tac P = "length (take (unat n) ARM_H.msgRegisters) <
                        2 ^ word_bits"
                in ccorres_gen_asm)
   apply (rule ccorres_split_nothrow_novcg)
       apply (rule ccorres_mapM_x_while [OF copyMRs_register_loop_helper[unfolded ucast_id]])
          apply (clarsimp simp: n_msgRegisters_def
                                length_msgRegisters min_def
                         split: if_split)
          apply unat_arith
         apply vcg
         apply simp
        apply wp
       apply assumption
      apply ceqv
     apply (wpc, simp add: option_to_0_def)
      apply (rule ccorres_split_throws, rule ccorres_return_C, simp+)
      apply vcg
     apply (wpc, simp_all add: option_to_0_def)[1]
      apply (rule ccorres_split_throws, rule ccorres_return_C, simp+)
      apply vcg
     apply (subst mapM_only_length)
     apply (rule_tac P="unat n \<le> length ARM_H.msgRegisters" in ccorres_cases)
      apply (simp add: upto_enum_def length_msgRegisters n_msgRegisters_def
                       mapM_x_Nil)
      apply (rule ccorres_expand_while_iff_Seq[THEN iffD1])
      apply (rule ccorres_cond_false)
      apply (rule ccorres_return_C, simp+)
     apply (rule ccorres_split_nothrow_novcg)
         apply (rule_tac i="length ARM_H.msgRegisters"
               and F="\<lambda>_. valid_ipc_buffer_ptr' (the sendBuffer)
                 and valid_ipc_buffer_ptr' (the recvBuffer)
                 and valid_pspace'"
               in ccorres_mapM_x_while')
             apply clarsimp
             apply (rule ccorres_guard_imp)
               apply (rule ccorres_pre_loadWordUser)
               apply (unfold storeWordUser_def)
               apply (rule ccorres_pre_stateAssert)
               apply (unfold K_bind_def)
               apply (rule ccorres_move_array_assertion_ipc_buffer
                           ccorres_Guard[where S="{s. h_t_valid (htd s) c_guard (ptr s)}" for ptr htd])+
               apply (ctac add: storeWord_ccorres)
              apply (clarsimp simp: word_size valid_ipc_buffer_ptr'_def
                                    msg_align_bits
                                    aligned_add_aligned[OF _ is_aligned_mult_triv2[where n=2, simplified]])
             apply (clarsimp simp: msgRegisters_unfold upto_enum_word word_size
                                   pointerInUserData_h_t_valid pointerInUserData_c_guard
                                   typ_heap_simps'
                split: if_split_asm simp del: upt.simps)
             apply (simp only: unat_arith_simps unat_of_nat msg_align_bits
                               msgMaxLength_def, simp split: if_split)
             apply arith
            apply (simp add: n_msgRegisters_def length_msgRegisters)
           apply (rule allI, rule conseqPre, vcg)
           apply clarsimp
          apply (rule hoare_pre, wp hoare_valid_ipc_buffer_ptr_typ_at')
          apply clarsimp
         apply (simp add: length_msgRegisters n_msgRegisters_def msgMaxLength_def
                          word_bits_def)
        apply ceqv
       apply simp
       apply (rule ccorres_return_C, simp_all)[1]
      apply wp
     apply clarsimp
     apply (clarsimp simp: guard_is_UNIV_def upto_enum_def
                           min_def word_le_nat_alt
                           length_msgRegisters n_msgRegisters_def
                           msgLengthBits_def mask_def
                           linorder_not_le)
    apply simp
    apply (wp mapM_x_wp' hoare_vcg_all_lift hoare_vcg_const_imp_lift | simp)+
   apply (clarsimp simp: guard_is_UNIV_def
                         length_msgRegisters n_msgRegisters_def mask_def
                         Types_H.msgLengthBits_def min_def word_le_nat_alt
                  split: if_split)
   apply unat_arith
  apply (clarsimp simp: length_msgRegisters n_msgRegisters_def
                        msgLengthBits_def min_def word_bits_def)
  apply (auto split: if_split)
  done

declare zipWith_Nil2[simp]

declare zipWithM_x_Nil2[simp]

lemma getRestartPC_ccorres [corres]:
  "ccorres (op =) ret__unsigned_long_' \<top>
     (UNIV \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>) hs
     (asUser thread (getRegister register.FaultInstruction))
     (Call getRestartPC_'proc)"
  apply (cinit' lift: thread_')
   apply (rule ccorres_trim_return, simp, simp)
   apply ctac
  apply clarsimp
  done

lemma asUser_tcbFault_obj_at:
  "\<lbrace>obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace> asUser t' m
   \<lbrace>\<lambda>rv. obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>"
  apply (simp add: asUser_def split_def)
  apply (wp threadGet_wp)
  apply simp
  done

lemma asUser_atcbContext_obj_at:
  "t \<noteq> t' \<Longrightarrow>
    \<lbrace>obj_at' (\<lambda>tcb. P ((atcbContextGet o tcbArch) tcb)) t\<rbrace>
      asUser t' m
    \<lbrace>\<lambda>rv. obj_at' (\<lambda>tcb. P ((atcbContextGet o tcbArch) tcb)) t\<rbrace>"
  apply (simp add: asUser_def split_def atcbContextGet_def atcbContextSet_def)
  apply (wp threadGet_wp)
  apply simp
  done

lemma asUser_tcbFault_inv:
  "\<lbrace>\<lambda>s. \<exists>t. ko_at' t p' s \<and> tcbFault t = f\<rbrace> asUser p m
   \<lbrace>\<lambda>rv s. \<exists>t. ko_at' t p' s \<and> tcbFault t = f\<rbrace>"
  apply (rule_tac Q="\<lambda>rv. obj_at' (\<lambda>t. tcbFault t = f) p'"
               in hoare_strengthen_post)
   apply (wp asUser_tcbFault_obj_at)
   apply (clarsimp simp: obj_at'_def)+
  done

lemma setMR_atcbContext_obj_at:
  "t \<noteq> t' \<Longrightarrow>
    \<lbrace>obj_at' (\<lambda>tcb. P ((atcbContextGet o tcbArch) tcb)) t\<rbrace>
      setMR t' b r v
    \<lbrace>\<lambda>rv. obj_at' (\<lambda>tcb. P ((atcbContextGet o tcbArch) tcb)) t\<rbrace>"
  apply (simp add: setMR_def split del: if_split)
  apply (rule hoare_pre)
   apply (wp asUser_atcbContext_obj_at[simplified] | simp | wpc)+
  done

lemma setMR_tcbFault_obj_at:
  "\<lbrace>obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace> setMR t' b r v
   \<lbrace>\<lambda>rv. obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>"
  apply (simp add: setMR_def split del: if_split)
  apply (rule hoare_pre)
   apply (wp asUser_tcbFault_obj_at | wpc)+
  apply simp
  done

(* FIXME move *)
lemma from_bool_to_bool_and_1 [simp]:
  assumes r_size: "1 < size r"
  shows "from_bool (to_bool (r && 1)) = r && 1"
proof -
  from r_size have "r && 1 < 2"
    by (simp add: and_mask_less_size [where n=1, unfolded mask_def, simplified])
  thus ?thesis
    by (fastforce simp add: from_bool_def to_bool_def dest: word_less_cases)
qed

(* FIXME move to Corres_C and remove from Tcb_C *)
lemma ccorres_abstract_known:
  "\<lbrakk> \<And>rv' t t'. ceqv \<Gamma> xf' rv' t t' g (g' rv'); ccorres rvr xf P P' hs f (g' val) \<rbrakk>
     \<Longrightarrow> ccorres rvr xf P (P' \<inter> {s. xf' s = val}) hs f g"
  apply (rule ccorres_guard_imp2)
   apply (rule_tac xf'=xf' in ccorres_abstract)
    apply assumption
   apply (rule_tac P="rv' = val" in ccorres_gen_asm2)
   apply simp
  apply simp
  done

lemma ccorres_add_getRegister:
  "ccorres rv xf P P' hs (asUser t (getRegister r) >>= (\<lambda>_. a)) c
    \<Longrightarrow> ccorres rv xf (P and tcb_at' t) P' hs a c"
  apply (simp add: asUser_getRegister_discarded)
  apply (simp add: ccorres_underlying_def)
  apply (elim ballEI | clarsimp del: allI)+
  apply (drule mp)
   apply (simp add: stateAssert_def bind_assoc exec_get)
  apply (elim allEI)
  apply (clarsimp simp: in_monad stateAssert_def split: xstate.split_asm)
  apply fastforce
  done

lemma user_getreg_rv:
  "\<lbrace>obj_at' (\<lambda>tcb. P ((atcbContextGet o tcbArch) tcb r)) t\<rbrace> asUser t (getRegister r) \<lbrace>\<lambda>rv s. P rv\<rbrace>"
  apply (simp add: asUser_def split_def)
  apply (wp threadGet_wp)
  apply (clarsimp simp: obj_at'_def projectKOs getRegister_def in_monad atcbContextGet_def)
  done

lemma exceptionMessage_ccorres:
  "n < unat n_exceptionMessage
      \<Longrightarrow> register_from_H (ARM_H.exceptionMessage ! n)
             = index exceptionMessageC n"
  apply (simp add: exceptionMessageC_def ARM_H.exceptionMessage_def
                   ARM.exceptionMessage_def MessageID_Exception_def)
  by (simp add: Arrays.update_def n_exceptionMessage_def fcp_beta nth_Cons'
                fupdate_def
         split: if_split)

lemma asUser_obj_at_elsewhere:
  "\<lbrace>obj_at' (P :: tcb \<Rightarrow> bool) t' and (\<lambda>_. t \<noteq> t')\<rbrace> asUser t m \<lbrace>\<lambda>rv. obj_at' P t'\<rbrace>"
  apply (rule hoare_gen_asm')
  apply (simp add: asUser_def split_def)
  apply (wp threadGet_wp)
  apply clarsimp
  done

lemma exceptionMessage_length_aux :
  "\<And>n. n < length ARM_H.exceptionMessage \<Longrightarrow> n < unat n_exceptionMessage"
  by (simp add: ARM.exceptionMessage_def ARM_H.exceptionMessage_def n_exceptionMessage_def)

lemma copyMRsFault_ccorres_exception:
  "ccorres dc xfdc
           (valid_pspace'
             and obj_at' (\<lambda>tcb. map (atcbContext (tcbArch tcb)) ARM_H.exceptionMessage = msg) sender
             and K (length msg = 3)
             and K (recvBuffer \<noteq> Some 0)
             and K (sender \<noteq> receiver))
           (UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
                 \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
                 \<inter> \<lbrace>\<acute>receiveIPCBuffer = Ptr (option_to_0 recvBuffer)\<rbrace>
                 \<inter> \<lbrace> \<acute>length___unsigned_long = 3 \<rbrace>
                 \<inter> \<lbrace> \<acute>id___anonymous_enum = MessageID_Exception \<rbrace>)
           hs
           (mapM_x (\<lambda>(x, y). setMR receiver recvBuffer x y) (zip [0..<120] msg))
           (Call copyMRsFault_'proc)"
  apply (unfold K_def)
  apply (intro ccorres_gen_asm)
  apply (cinit' lift: sender_' receiver_' receiveIPCBuffer_'
                     length___unsigned_long_' id___anonymous_enum_'
                simp: whileAnno_def)
   apply (simp only: mapM_x_append[where xs="take (unat n_msgRegisters) (zip as bs)"
                                         and ys="drop (unat n_msgRegisters) (zip as bs)"
                                         for as bs, simplified] bind_assoc)
   apply (rule ccorres_rhs_assoc2, rule ccorres_split_nothrow_novcg)

       apply (rule_tac F="K $ obj_at' (\<lambda>tcb. map ((atcbContext o tcbArch) tcb) ARM_H.exceptionMessage = msg) sender"
                     in ccorres_mapM_x_while)
           apply (clarsimp simp: n_msgRegisters_def)
           apply (rule ccorres_guard_imp2)
            apply (rule_tac t=sender and r="ARM_H.exceptionMessage ! n"
                            in ccorres_add_getRegister)
            apply (ctac(no_vcg))
             apply (rule_tac P="\<lambda>s. rv = msg ! n" in ccorres_cross_over_guard)
             apply (simp add: setMR_def length_msgRegisters n_msgRegisters_def
                                    liftM_def[symmetric])
             apply ctac
            apply (wp user_getreg_rv)
           apply (clarsimp simp: msgRegisters_ccorres n_msgRegisters_def
                                 syscallMessage_ccorres n_syscallMessage_def
                                 obj_at'_def projectKOs
                                 atcbContextGet_def unat_of_nat32[unfolded word_bits_def])
           apply (clarsimp simp: exceptionMessage_ccorres[simplified,symmetric,OF exceptionMessage_length_aux])
           apply (clarsimp simp: word_of_nat_less MessageID_Exception_def)
          apply (clarsimp simp: n_msgRegisters_def foo)
         apply (rule allI, rule conseqPre, vcg exspec=setRegister_modifies exspec=getRegister_modifies)
         apply simp
        apply (simp add: setMR_def split del: if_split)
        apply (rule hoare_pre)
         apply (wp asUser_obj_at_elsewhere | wpc)+
        apply simp
       apply (simp add: word_bits_def)
      apply ceqv
     apply (rule ccorres_Cond_rhs)
      apply (simp del: Collect_const)
      apply (simp add: n_msgRegisters_def mapM_x_Nil)
      apply (subst ccorres_expand_while_iff[symmetric])
      apply (rule ccorres_cond_false)
      apply (rule ccorres_return_Skip')
     apply (simp add: n_msgRegisters_def mapM_x_Nil)
     apply (rule ccorres_return_Skip')
    apply wp
    apply (simp add: guard_is_UNIV_def)
    apply (clarsimp)
    done

lemma mapM_cong: "\<lbrakk> \<forall>x. elem x xs \<longrightarrow> f x = g x \<rbrakk> \<Longrightarrow> mapM_x f xs =  mapM_x g xs"
  by (induction xs, (simp add: mapM_x_Nil mapM_x_Cons)+)

lemma copyMRsFault_ccorres_syscall:
  "ccorres dc xfdc
           (valid_pspace'
             and obj_at' (\<lambda>tcb. map (atcbContext (tcbArch tcb)) ARM_H.syscallMessage = msg) sender
             and (case recvBuffer of Some x \<Rightarrow> valid_ipc_buffer_ptr' x | None \<Rightarrow> \<top>)
             and K (length msg = 12)
             and K (recvBuffer \<noteq> Some 0)
             and K (sender \<noteq> receiver))
           (UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
                 \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
                 \<inter> \<lbrace>\<acute>receiveIPCBuffer = Ptr (option_to_0 recvBuffer)\<rbrace>
                 \<inter> \<lbrace>\<acute>length___unsigned_long = 12 \<rbrace>
                 \<inter> \<lbrace> \<acute>id___anonymous_enum = MessageID_Syscall \<rbrace>)
           hs
           (mapM_x (\<lambda>(x, y). setMR receiver recvBuffer x y) (zip [0..<120] msg))
           (Call copyMRsFault_'proc)"
proof -
  (* auxiliary lemmas *)
  have option_to_0_imp : "\<lbrakk> option_to_0 recvBuffer= 0 ; recvBuffer \<noteq> Some 0 \<rbrakk> \<Longrightarrow> recvBuffer = None"
    by (simp add: option_to_0_def; cases recvBuffer; simp+)
  have drop_n: "\<And>n m. drop n [0..<m] = [n..<m]"
    by simp
  have less_than_4: "\<And>x y n m. elem (x, y) (zip [n..<120] m) \<Longrightarrow> \<not> x < n "
    by (simp | erule in_set_zipE)+
  have msg_aux: "\<forall>p. elem p (zip [4..<120] (drop 4 msg))
                    \<longrightarrow> (\<lambda>(x1,y1). setMR receiver None x1 y1) p = (\<lambda>_ . return (length msgRegisters)) p"
    by (fastforce simp add: numeral_eqs setMR_def less_than_4 n_msgRegisters_def length_msgRegisters)
  have mapM_x_return_gen: "\<And>v w xs. mapM_x (\<lambda>_. return v) xs = return w" (* FIXME mapM_x_return *)
    by (induct_tac xs; simp add: mapM_x_Nil mapM_x_Cons)
  show ?thesis
  including no_pre
  apply (unfold K_def)
  apply (intro ccorres_gen_asm)
  apply (cinit' lift: sender_' receiver_' receiveIPCBuffer_'
                     length___unsigned_long_' id___anonymous_enum_'
                simp: whileAnno_def)
   apply (simp only: mapM_x_append[where xs="take (unat n_msgRegisters) (zip as bs)"
                                         and ys="drop (unat n_msgRegisters) (zip as bs)"
                                         for as bs, simplified] bind_assoc)
   apply (rule ccorres_rhs_assoc2, rule ccorres_split_nothrow_novcg)
       apply (rule_tac F="K $ obj_at' (\<lambda>tcb. map ((atcbContext o tcbArch) tcb) ARM_H.syscallMessage = msg) sender"
                     in ccorres_mapM_x_while)
           apply (clarsimp simp: n_msgRegisters_def)
           apply (rule ccorres_guard_imp2)
            apply (rule_tac t=sender and r="ARM_H.syscallMessage ! n"
                            in ccorres_add_getRegister)
            apply (ctac(no_vcg))
             apply (rule_tac P="\<lambda>s. rv = msg ! n" in ccorres_cross_over_guard)
             apply (simp add: setMR_def length_msgRegisters n_msgRegisters_def
                                    liftM_def[symmetric])
             apply ctac
            apply (wp user_getreg_rv)
           apply (clarsimp simp: msgRegisters_ccorres n_msgRegisters_def
                                 syscallMessage_ccorres n_syscallMessage_def
                                 obj_at'_def projectKOs
                                 atcbContextGet_def unat_of_nat32[unfolded word_bits_def])
           apply (clarsimp simp: word_of_nat_less MessageID_Syscall_def)
          apply (simp add: n_msgRegisters_def)
         apply (rule allI, rule conseqPre, vcg exspec=setRegister_modifies exspec=getRegister_modifies)
         apply simp
        apply (simp add: setMR_def split del: if_split)
        apply (rule hoare_pre)
         apply (wp asUser_obj_at_elsewhere | wpc)+
        apply simp
       apply (simp add: word_bits_def)
      apply ceqv
     apply (rule ccorres_Cond_rhs)
      apply (simp del: Collect_const)
      apply (rule ccorres_rel_imp[where r = "\<lambda>rv rv'. True", simplified])
      apply (rule_tac F="\<lambda>_. obj_at' (\<lambda>tcb. map ((atcbContext o tcbArch) tcb) ARM_H.syscallMessage = msg)
                                       sender and valid_pspace'
                                       and (case recvBuffer of Some x \<Rightarrow> valid_ipc_buffer_ptr' x | None \<Rightarrow> \<top>)"
                           in ccorres_mapM_x_while'[where i="unat n_msgRegisters"])
          apply (clarsimp simp: setMR_def n_msgRegisters_def length_msgRegisters
                                          option_to_0_def liftM_def[symmetric]
                                   split: option.split_asm)
          apply (rule ccorres_guard_imp2)
          apply (rule_tac t=sender and r="ARM_H.syscallMessage ! (n + unat n_msgRegisters)"
                                   in ccorres_add_getRegister)
          apply (ctac(no_vcg))
           apply (rule_tac P="\<lambda>s. rv = msg ! (n + unat n_msgRegisters)"
                           in ccorres_cross_over_guard)
           apply (rule ccorres_move_array_assertion_ipc_buffer
                 | (rule ccorres_flip_Guard, rule ccorres_move_array_assertion_ipc_buffer))+
           apply (simp add: storeWordUser_def)
           apply (rule ccorres_pre_stateAssert)
           apply (ctac add: storeWord_ccorres[unfolded fun_app_def])
          apply (simp add: pred_conj_def)
          apply (wp user_getreg_rv)
         apply (clarsimp simp: n_syscallMessage_def n_msgRegisters_def
                               syscallMessage_ccorres msgRegisters_ccorres
                               unat_add_lem[THEN iffD1] unat_of_nat32
                               word_bits_def word_size_def)
         apply (simp only:field_simps imp_ex imp_conjL)
         apply (clarsimp simp: pointerInUserData_c_guard obj_at'_def
                               pointerInUserData_h_t_valid
                               atcbContextGet_def
                               projectKOs objBits_simps word_less_nat_alt
                               unat_add_lem[THEN iffD1] unat_of_nat)
         apply (clarsimp simp: pointerInUserData_h_t_valid rf_sr_def
                               MessageID_Syscall_def
                               msg_align_bits valid_ipc_buffer_ptr'_def)
         apply (erule aligned_add_aligned)
          apply (rule aligned_add_aligned[where n=2])
            apply (simp add: is_aligned_def)
           apply (rule is_aligned_mult_triv2 [where n=2, simplified])
           apply (simp add: wb_gt_2)+
         apply (simp add: n_msgRegisters_def)
        apply (vcg exspec=getRegister_modifies)
        apply simp
       apply (simp add: setMR_def n_msgRegisters_def length_msgRegisters)
       apply (rule hoare_pre)
        apply (wp hoare_case_option_wp | wpc)+
       apply clarsimp
      apply (simp add: n_msgRegisters_def word_bits_def)
     apply (simp add: n_msgRegisters_def)
     apply (frule (1) option_to_0_imp)
     apply (subst drop_zip)
     apply (subst drop_n)
     apply (clarsimp simp:  n_msgRegisters_def numeral_eqs
                            mapM_cong[OF msg_aux, simplified numeral_eqs]
                            mapM_x_return_gen)
     apply (subst mapM_x_return_gen[where w2="()"])
     apply (rule ccorres_return_Skip[simplified dc_def])
    apply (clarsimp)
    apply (rule hoare_impI)
    apply (wp mapM_x_wp_inv setMR_atcbContext_obj_at[simplified atcbContextGet_def, simplified]
              | clarsimp
              | wpc)+
    apply (cases recvBuffer; simp add: option_to_0_def )
    apply wp
   apply (clarsimp simp: guard_is_UNIV_def n_msgRegisters_def msgLengthBits_def
                         mask_def)+
  done
  qed

lemma Arch_setMRs_fault_ccorres:
  "ccorres (\<lambda>r r'. r = r' && mask msgLengthBits) ret__unsigned_long_'
           (valid_pspace' and obj_at' (\<lambda>tcb. tcbFault tcb = Some ft) sender
                          and K (ft = ArchFault aft)
                          and (case buffer of Some x \<Rightarrow> valid_ipc_buffer_ptr' x | None \<Rightarrow> \<top>)
                          and K (buffer \<noteq> Some 0)
                          and K (sender \<noteq> receiver))
           (UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
                 \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
                 \<inter> \<lbrace>\<acute>faultType = fault_to_fault_tag ft \<rbrace>
                 \<inter> \<lbrace>\<acute>receiveIPCBuffer = Ptr (option_to_0 buffer)\<rbrace>) hs
    (makeArchFaultMessage aft sender >>= (\<lambda>ms. setMRs receiver buffer (snd ms)))
    (Call Arch_setMRs_fault_'proc)"
proof -
  let ?obj_at_ft = "obj_at' (\<lambda>tcb. tcbFault tcb = Some ft) sender"
  note symb_exec_r_fault = ccorres_symb_exec_r_known_rv_UNIV
          [where xf'=ret__unsigned_' and R="?obj_at_ft" and R'=UNIV]
  show ?thesis
    apply (unfold K_def)
    using [[goals_limit = 1]]
    apply (intro ccorres_gen_asm)
    apply (cinit' lift: sender_' receiver_' faultType_' receiveIPCBuffer_')
     apply (simp only: makeArchFaultMessage_def setMRs_to_setMR
                 del:  Collect_const split del: if_split)
     apply (rule_tac P="ft = ArchFault aft" in ccorres_gen_asm)
     apply wpc
     apply (rename_tac list)
     apply (rule_tac P="zip [Suc (Suc 0) ..< msgMaxLength] list = [(2, hd list), (3, hd (tl list))]"
                     in ccorres_gen_asm)
     apply (simp add: Collect_True Collect_False ccorres_cond_iffs
                      zip_upt_Cons msgMaxLength_unfold
                      zipWithM_mapM mapM_Cons bind_assoc
                      seL4_Fault_tag_defs
                 del: Collect_const)
     apply (rule ccorres_rhs_assoc)+
     apply (ctac (no_vcg))
      apply (rule ccorres_stateAssert)
      apply (ctac(no_vcg) add: setMR_ccorres_dc)
       apply (rule ccorres_move_c_guard_tcb)
       apply (rule_tac val="vmFaultAddress aft" in symb_exec_r_fault)
          apply (rule conseqPre, vcg, clarsimp)
          apply (drule(1) obj_at_cslift_tcb)
          apply (clarsimp simp: ctcb_relation_def typ_heap_simps
                                   cfault_rel_def seL4_Fault_lift_def
                                   seL4_Fault_VMFault_lift_def Let_def
                            split: if_split_asm)
        apply ceqv
       apply (ctac(no_vcg) add: setMR_ccorres_dc)
        apply (rule_tac val="hd (vmFaultArchData aft)" in symb_exec_r_fault)
           apply (rule conseqPre, vcg, clarsimp)
           apply (drule(1) obj_at_cslift_tcb)
           apply (clarsimp simp: typ_heap_simps')
           apply (clarsimp simp: ctcb_relation_def
                                     cfault_rel_def seL4_Fault_lift_def
                                     seL4_Fault_VMFault_lift_def Let_def
                              split: if_split_asm)
          apply ceqv
         apply (ctac(no_vcg) add: setMR_ccorres_dc)
          apply (rule_tac val="vmFaultArchData aft ! 1" in symb_exec_r_fault)
              apply (rule conseqPre, vcg, clarsimp)
              apply (drule(1) obj_at_cslift_tcb)
              apply (clarsimp simp: typ_heap_simps')
              apply (clarsimp simp: ctcb_relation_def
                                    cfault_rel_def seL4_Fault_lift_def
                                    seL4_Fault_VMFault_lift_def Let_def
                             split: if_split_asm)
             apply ceqv
            apply (ctac(no_vcg) add: setMR_ccorres)
            apply (simp add: mapM_Nil)
             apply (rule ccorres_return_C, simp+)[1]
            apply wp
           apply (clarsimp simp: option_to_ptr_def)
           apply (subgoal_tac "case list of [a, b] \<Rightarrow> True | _ \<Rightarrow> True")
            apply (simp add: zip_upt_Cons guard_is_UNIVI seL4_VMFault_FSR_def split: list.split_asm)
           apply (simp split: list.split)
          apply (wp setMR_tcbFault_obj_at asUser_inv[OF getRestartPC_inv]
                       hoare_case_option_wp
                     | simp add: option_to_ptr_def guard_is_UNIVI
                                 seL4_VMFault_PrefetchFault_def
                                 seL4_VMFault_Addr_def
                                 seL4_VMFault_IP_def
                                 msgMaxLength_def
                            del: Collect_const split del: if_split)+
    apply clarsimp
    apply (drule(1) obj_at_cslift_tcb[where thread=sender])
    apply (clarsimp simp: obj_at'_def projectKOs objBits_simps)
    apply (clarsimp simp: ctcb_relation_def cfault_rel_def seL4_Fault_lift_def
                        Let_def zip_upt_Cons
                  split: if_split_asm)
  done
qed

lemmas seL4_Faults = seL4_Fault_UserException_def
                     seL4_Fault_UnknownSyscall_def
                     seL4_Fault_CapFault_def

lemmas seL4_Arch_Faults =  seL4_Fault_VMFault_def

lemma setMRs_fault_ccorres [corres]:
  "ccorres (\<lambda>r r'. r = r' && mask msgLengthBits) ret__unsigned_long_'
           (valid_pspace' and obj_at' (\<lambda>tcb. tcbFault tcb = Some ft) sender
                          and tcb_at' receiver
                          and (case buffer of Some x \<Rightarrow> valid_ipc_buffer_ptr' x | None \<Rightarrow> \<top>)
                          and K (buffer \<noteq> Some 0)
                          and K (sender \<noteq> receiver))
           (UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
                 \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
                 \<inter> \<lbrace>\<acute>receiveIPCBuffer = Ptr (option_to_0 buffer)\<rbrace>) hs
    (makeFaultMessage ft sender >>= (\<lambda>ms. setMRs receiver buffer (snd ms)))
    (Call setMRs_fault_'proc)"
proof -
  let ?obj_at_ft = "obj_at' (\<lambda>tcb. tcbFault tcb = Some ft) sender"
  note symb_exec_r_fault = ccorres_symb_exec_r_known_rv_UNIV
          [where xf'=ret__unsigned_' and R="?obj_at_ft" and R'=UNIV]
  show ?thesis
    apply (unfold K_def)
    apply (intro ccorres_gen_asm)
    apply (cinit' lift: sender_' receiver_' receiveIPCBuffer_' simp: whileAnno_def)
     apply (simp add: makeFaultMessage_def setMRs_to_setMR
                 del: Collect_const split del: if_split)
     apply (rule_tac val="fault_to_fault_tag ft" in symb_exec_r_fault)
        apply (vcg, clarsimp)
        apply (drule(1) obj_at_cslift_tcb)
        apply (clarsimp simp: ctcb_relation_def typ_heap_simps'
                              cfault_rel_def seL4_Fault_lift_def Let_def
                       split: if_split_asm)
       apply ceqv
      (* UserException *)
      apply wpc
         apply (simp add: bind_assoc seL4_Fault_tag_defs ccorres_cond_iffs
                          Collect_True Collect_False
                          zipWithM_mapM zip_append2 mapM_append
                     del: Collect_const split del: if_split)
         apply (rule ccorres_symb_exec_l)
            apply (rule ccorres_stateAssert)
            apply (rule_tac P="length msg = unat n_exceptionMessage"
                       in ccorres_gen_asm)
            apply (simp add: n_exceptionMessage_def msgMaxLength_unfold
                             zip_upt_Cons mapM_Nil mapM_Cons bind_assoc
                             mapM_discarded
                        del: Collect_const upt.simps upt_rec_numeral
                        split del: if_split)
            apply (rule ccorres_rhs_assoc)+
            apply (ctac add: copyMRsFault_ccorres_exception)
              apply (rule ccorres_move_c_guard_tcb)
              apply (rule_tac val="userExceptionNumber ft" in symb_exec_r_fault)
                 apply (vcg, clarsimp)
                 apply (drule(1) obj_at_cslift_tcb)
                 apply (clarsimp simp: ctcb_relation_def typ_heap_simps
                                       cfault_rel_def seL4_Fault_lift_def
                                       seL4_Fault_UserException_lift_def Let_def
                                split: if_split_asm)
                apply ceqv
               apply (ctac add: setMR_ccorres_dc)
                 apply (rule ccorres_move_c_guard_tcb)
                 apply (rule_tac val="userExceptionErrorCode ft" in symb_exec_r_fault)
                    apply (vcg, clarsimp)
                    apply (drule(1) obj_at_cslift_tcb)
                    apply (clarsimp simp: ctcb_relation_def typ_heap_simps
                                          cfault_rel_def seL4_Fault_lift_def
                                          seL4_Fault_UserException_lift_def Let_def
                                   split: if_split_asm)
                   apply ceqv
                  apply (ctac add: setMR_ccorres)
                    apply (rule ccorres_return_C, simp+)[1]
                   apply wp
                  apply (simp del: Collect_const)
                  apply (vcg exspec=setMR_modifies)
                 apply (clarsimp simp: option_to_ptr_def guard_is_UNIVI)
                apply (wp setMR_tcbFault_obj_at
                          hoare_case_option_wp)
               apply simp
               apply (vcg exspec=setMR_modifies)
              apply (clarsimp simp: option_to_ptr_def guard_is_UNIVI)
             apply (simp add: split_def)
             apply (wp mapM_x_wp' setMR_tcbFault_obj_at
                       hoare_case_option_wp
                         | simp)+
            apply (vcg exspec=copyMRsFault_modifies exspect=setRegister_modifies)
           apply (wp asUser_inv mapM_wp' getRegister_inv)
          apply simp
          apply (wp asUser_inv mapM_wp' getRegister_inv hoare_drop_imps asUser_const_rv
                    asUser_get_registers[simplified atcbContextGet_def comp_def])
         apply simp
         (* CapFault *)
        apply (simp add: Collect_True Collect_False ccorres_cond_iffs
                         zip_upt_Cons msgMaxLength_unfold
                         zipWithM_mapM mapM_Cons bind_assoc
                    del: Collect_const)
        apply (rule ccorres_rhs_assoc)+
        apply (ctac(no_vcg))
         apply (rule ccorres_stateAssert)
         apply (ctac(no_vcg) add: setMR_ccorres_dc)
          apply (rule_tac val="capFaultAddress ft" in symb_exec_r_fault)
             apply (rule conseqPre, vcg, clarsimp)
             apply (drule(1) obj_at_cslift_tcb)
             apply (clarsimp simp: typ_heap_simps' ctcb_relation_def
                                   cfault_rel_def seL4_Fault_lift_def Let_def
                                   seL4_Fault_CapFault_lift_def
                            split: if_split_asm)
            apply ceqv
           apply (ctac(no_vcg) add: setMR_ccorres_dc)
            apply (rule_tac val="from_bool (capFaultInReceivePhase ft)" in symb_exec_r_fault)
               apply (rule conseqPre, vcg, clarsimp)
               apply (drule(1) obj_at_cslift_tcb)
               apply (clarsimp simp: typ_heap_simps' ctcb_relation_def
                                     cfault_rel_def seL4_Fault_lift_def Let_def
                                     seL4_Fault_CapFault_lift_def
                                     from_bool_to_bool_and_1 word_size
                              split: if_split_asm)
              apply ceqv
             apply (ctac(no_vcg) add: setMR_ccorres_dc)
              apply (rule ccorres_move_c_guard_tcb)
              apply (rule_tac P="obj_at' (\<lambda>tcb. tcbFault tcb = Some ft) sender"
                           in ccorres_cross_over_guard)
              apply (ctac(no_vcg) add: setMRs_lookup_failure_ccorres[unfolded msgMaxLength_unfold])
               apply simp
               apply (rule ccorres_return_C, simp+)[1]
              apply (wp setMR_tcbFault_obj_at hoare_case_option_wp)+
            apply (clarsimp simp: option_to_ptr_def Collect_const_mem guard_is_UNIV_def)
            apply (rule conjI)
             apply (simp add: seL4_CapFault_InRecvPhase_def)
            apply (rule conjI)
             apply (simp add: from_bool_def split: bool.split)
            apply clarsimp
            apply (drule(1) obj_at_cslift_tcb)
            apply (clarsimp simp: typ_heap_simps' ctcb_relation_def
                                  cfault_rel_def seL4_Fault_lift_def Let_def
                                  seL4_Fault_CapFault_lift_def is_cap_fault_def
                                  seL4_CapFault_LookupFailureType_def
                           split: if_split_asm)
           apply (wp setMR_tcbFault_obj_at hoare_case_option_wp
                     asUser_inv[OF getRestartPC_inv]
                     | (rule guard_is_UNIVI, clarsimp simp: option_to_ptr_def
                                                            seL4_CapFault_Addr_def))+
      (* UnknowSyscall *)
      apply (rename_tac syscall_number)
      apply (simp add: seL4_Fault_tag_defs Collect_True Collect_False
                       ccorres_cond_iffs zipWithM_mapM mapM_append
                       zip_append2 bind_assoc
                  del: Collect_const)
      apply (rule ccorres_symb_exec_l)
         apply (rule ccorres_stateAssert)
         apply (rule_tac P="length msg = unat n_syscallMessage" in ccorres_gen_asm)
         apply (simp add: msgMaxLength_unfold n_syscallMessage_def zip_upt_Cons
                          mapM_Cons mapM_Nil mapM_discarded
                     del: Collect_const upt_rec_numeral)
         apply (rule ccorres_rhs_assoc)+
         apply (ctac add: copyMRsFault_ccorres_syscall)
           apply (rule ccorres_move_c_guard_tcb)
           apply (rule_tac val="syscall_number" in symb_exec_r_fault)
              apply (vcg, clarsimp)
              apply (drule(1) obj_at_cslift_tcb)
              apply (clarsimp simp: ctcb_relation_def typ_heap_simps'
                                    cfault_rel_def seL4_Fault_lift_def Let_def
                                    seL4_Fault_UnknownSyscall_def
                                    seL4_Fault_UnknownSyscall_lift_def
                              split: if_split_asm)
             apply ceqv
            apply (ctac add: setMR_ccorres)
              apply (rule ccorres_return_C, simp+)[1]
             apply wp
            apply (simp del: Collect_const)
            apply (vcg exspec=setMR_modifies)
           apply (clarsimp simp: option_to_ptr_def guard_is_UNIVI)
          apply (wp setMR_tcbFault_obj_at mapM_x_wp_inv hoare_case_option_wp
                | clarsimp
                | wpc)+
         apply (vcg exspec=copyMRsFault_modifies)
        apply (wp asUser_inv mapM_wp' getRegister_inv)
       apply simp
       apply (wp asUser_inv mapM_wp' getRegister_inv hoare_drop_imps asUser_const_rv
                 asUser_get_registers[simplified atcbContextGet_def comp_def])
       apply simp
      (* ArchFault *)
      apply (rule ccorres_cond_false)
      apply (rule ccorres_cond_false)
      apply (rule ccorres_cond_false)
      apply (simp add: Collect_True Collect_False ccorres_cond_iffs
                         zip_upt_Cons
                         mapM_Cons bind_assoc
                         seL4_Fault_tag_defs
                    del: Collect_const)
      apply (rule ccorres_rhs_assoc)+
      apply (rule ccorres_move_c_guard_tcb)
      apply (rule_tac val="fault_to_fault_tag ft" in symb_exec_r_fault)
        apply (vcg, clarsimp)
        apply (drule(1) obj_at_cslift_tcb)
        apply (clarsimp simp: ctcb_relation_def typ_heap_simps'
                              cfault_rel_def seL4_Fault_lift_def Let_def
                              seL4_Fault_UnknownSyscall_def
                              seL4_Fault_UnknownSyscall_lift_def
                       split: if_split_asm)
       apply ceqv
      apply (rule ccorres_add_return2)
      apply (ctac add: Arch_setMRs_fault_ccorres[simplified setMRs_to_setMR last.simps K_bind_def])
        apply (ctac add: ccorres_return_C)
       apply wp
      apply (vcg exspec=Arch_setMRs_fault_modifies)
     apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
     apply (rule  fault_to_fault_tag.simps(2)[symmetric])
     (* done *)
     apply (rule guard_is_UNIVI, clarsimp simp: option_to_ptr_def seL4_CapFault_IP_def)
     apply (case_tac x)
     apply (simp add: seL4_Faults seL4_Arch_Faults)
     apply (clarsimp simp: msgMaxLength_unfold length_syscallMessage
                          ARM_H.exceptionMessage_def
                          ARM.exceptionMessage_def
                          n_exceptionMessage_def
                          n_syscallMessage_def)
    apply (drule(1) obj_at_cslift_tcb[where thread=sender])
    apply (clarsimp simp: obj_at'_def projectKOs objBits_simps)
    apply (clarsimp simp: msgFromLookupFailure_def split: lookup_failure.split)
  done
qed


definition
  makeArchFaultMessage2 :: "arch_fault \<Rightarrow> 32 word"
where
  "makeArchFaultMessage2 \<equiv> \<lambda>aft. case aft of VMFault _ _ \<Rightarrow> 5"

lemma makeFaultMessage2:
  "makeFaultMessage ft thread
    = (do x \<leftarrow> makeFaultMessage ft thread;
       return (case ft of CapFault _ _ _ \<Rightarrow> 1
                   | UnknownSyscallException _ \<Rightarrow> 2
                   | UserException _ _ \<Rightarrow> 3
                   | ArchFault aft \<Rightarrow> makeArchFaultMessage2 aft, snd x) od)"
  by (simp add: makeFaultMessage_def makeArchFaultMessage2_def makeArchFaultMessage_def
           split: fault.split arch_fault.split)

lemma doFaultTransfer_ccorres [corres]:
  "ccorres dc xfdc (valid_pspace' and tcb_at' sender and tcb_at' receiver
                    and (case buffer of Some x \<Rightarrow> valid_ipc_buffer_ptr' x | None \<Rightarrow> \<top>)
                    and K (buffer \<noteq> Some 0) and K (receiver \<noteq> sender))
    (UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
          \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
          \<inter> \<lbrace>\<acute>receiverIPCBuffer = Ptr (option_to_0 buffer)\<rbrace>
          \<inter> \<lbrace>\<acute>badge = badge\<rbrace>) []
    (doFaultTransfer badge sender receiver buffer)
    (Call doFaultTransfer_'proc)"
  apply (unfold K_def)
  apply (intro ccorres_gen_asm)
  apply (simp add: doFaultTransfer_def)
  apply (subst makeFaultMessage2)
  apply (simp only: makeArchFaultMessage2_def)
  apply (cinit' lift: sender_' receiver_' receiverIPCBuffer_' badge_')
   apply (rule ccorres_pre_threadGet)
   apply (rename_tac ft)
   apply wpc
    apply (simp del: Collect_const, rule ccorres_fail)
   apply (simp add: split_def bind_assoc del: Collect_const)
   apply (simp only: bind_assoc[symmetric, where m="makeFaultMessage ft t" for ft t])
   apply (ctac(no_vcg) add: setMRs_fault_ccorres)
    apply (rule_tac R="obj_at' (\<lambda>tcb. tcbFault tcb = ft) sender"
              and val="case (the ft) of CapFault _ _ _ \<Rightarrow> 1
                  | ArchFault (VMFault _ _) \<Rightarrow> 5 | UnknownSyscallException _ \<Rightarrow> 2
                  | UserException _ _ \<Rightarrow> 3"
              in ccorres_symb_exec_r_known_rv_UNIV
                   [where xf'=ret__unsigned_' and R'=UNIV])
       apply (rule conseqPre, vcg, clarsimp)
       apply (drule(1) obj_at_cslift_tcb)
       apply (clarsimp simp: typ_heap_simps' ctcb_relation_def
                             cfault_rel_def seL4_Fault_lift_def Let_def
                             seL4_Fault_tag_defs
                      split: if_split_asm)
      apply ceqv
     apply csymbr
     apply (ctac (no_vcg, c_lines 2) add: setMessageInfo_ccorres)
       apply (ctac add: setRegister_ccorres[unfolded dc_def])
      apply wp
     apply (simp add: badgeRegister_def ARM.badgeRegister_def
                      Kernel_C.badgeRegister_def "StrictC'_register_defs")
    apply (clarsimp simp: message_info_to_H_def guard_is_UNIVI
                          mask_def msgLengthBits_def
                   split: fault.split arch_fault.split)
   apply wp
    apply (simp add: setMRs_to_setMR zipWithM_mapM split_def)
    apply (wp mapM_wp' setMR_tcbFault_obj_at | simp)+
  apply (clarsimp simp: obj_at'_def projectKOs)
  done

lemma ccorres_emptyOnFailure:
  assumes corr_ac: "ccorres (\<lambda>f c. case f of Inl _ \<Rightarrow> r [] c | Inr xs \<Rightarrow> r xs c)
                            xf
                            P P' hs a c"
  shows "ccorres r xf P P' hs (emptyOnFailure a) c" using corr_ac
  apply (simp add: emptyOnFailure_def catch_def const_def bind_def split_def)
  apply (clarsimp simp: ccorres_underlying_def return_def split: xstate.splits sum.splits)
  apply (drule (1) bspec)
  apply (rule conjI, clarsimp)
   apply (erule_tac x=n in allE)
   apply (rename_tac s)
   apply (erule_tac x="Normal s" in allE)
   apply clarsimp
   apply (rule bexI)
    prefer 2
    apply assumption
   apply clarsimp
   apply (rule conjI, clarsimp simp: unif_rrel_def)
   apply (clarsimp simp: unif_rrel_def)
  apply fastforce
  done

lemma unifyFailure_ccorres:
  assumes corr_ac: "ccorres (f \<currency> r) xf P P' hs a c"
  shows "ccorres ((\<lambda>_. dc) \<currency> r) xf P P' hs (unifyFailure a) c"
  using corr_ac
  apply (simp add: unifyFailure_def rethrowFailure_def const_def o_def
                   handleE'_def throwError_def)
  apply (clarsimp simp: ccorres_underlying_def bind_def split_def return_def
                  split: xstate.splits sum.splits)
  apply (drule (1) bspec)
  apply clarsimp
  apply (rule conjI)
   apply clarsimp
   apply (erule_tac x=n in allE)
   apply (rename_tac s)
   apply (erule_tac x="Normal s" in allE)
   apply clarsimp
   apply (rule bexI)
    prefer 2
    apply assumption
   apply (clarsimp simp: unif_rrel_def)
   apply fastforce
  apply fastforce
  done

definition
cct_relation:: "cap_transfer \<Rightarrow> cap_transfer_C \<Rightarrow> bool"
where
"cct_relation atc ctc \<equiv>
  case atc of
    (CT croot idx dpt) \<Rightarrow>  ctReceiveRoot_C ctc = croot \<and>
                           ctReceiveIndex_C  ctc= idx \<and>
                           unat (ctReceiveDepth_C ctc) = dpt"

lemma capTransferFromWords_ccorres [corres]:
  "ccorres cct_relation ret__struct_cap_transfer_C_'
           (valid_pspace' and K (is_aligned ptr 2))
           (UNIV \<inter> \<lbrace>array_assertion (Ptr ptr :: word32 ptr) 3 (hrs_htd \<acute>t_hrs)\<rbrace>
              \<inter> \<lbrace>\<acute>wptr = Ptr ptr\<rbrace>) hs
           (capTransferFromWords ptr)
           (Call capTransferFromWords_'proc)"
  apply (cinit lift: wptr_')
   apply (rule ccorres_pre_loadWordUser)+
   apply (rule_tac P=\<top>
               and P'="{s. array_assertion (Ptr ptr :: word32 ptr)
                              3 (hrs_htd (t_hrs_' (globals s))) \<and>
                           cslift s (Ptr ptr) = Some rv \<and>
                           cslift s (Ptr (ptr + 4)) = Some rva \<and>
                           cslift s (Ptr (ptr + 8)) = Some rvb}"
                in ccorres_from_vcg_throws)
   apply (rule allI, rule conseqPre, vcg)
   apply (clarsimp simp: typ_heap_simps' ptr_add_assertion_positive
                         array_assertion_shrink_right)
   apply (simp add: return_def)
   apply (simp add: cct_relation_def)
  apply (clarsimp simp: word_size valid_ipc_buffer_ptr'_def wordSize_def')
  apply safe
   apply (erule aligned_add_aligned | simp add: is_aligned_def word_bits_conv)+
  done

lemma array_assertion_shrink_left_add:
  "array_assertion (Ptr ptr :: ('a :: wf_type) ptr) j htd
    \<Longrightarrow> n = of_nat (k * size_of TYPE('a)) \<and> k + i \<le> j \<and> 0 < i
    \<Longrightarrow> array_assertion (Ptr (ptr + n) :: 'a ptr) i htd"
  apply (cases "k = 0")
   apply (simp add: unat_eq_0)
   apply (erule array_assertion_shrink_right, simp)
  apply (drule_tac j=k in array_assertion_shrink_leftD)
   apply simp
  apply simp
  apply (erule array_assertion_shrink_right)
  apply arith
  done

lemma array_assertion_shrink_left_add_div:
  "array_assertion (Ptr ptr :: ('a :: wf_type) ptr) j htd
    \<Longrightarrow> n = of_nat (unat n div size_of TYPE('a)) * of_nat (size_of TYPE('a))
        \<and> i + (unat n div size_of TYPE('a)) \<le> j \<and> 0 < i
    \<Longrightarrow> array_assertion (Ptr (ptr + n) :: 'a ptr) i htd"
  apply (erule_tac k="unat n div size_of TYPE('a)"
    in array_assertion_shrink_left_add)
  apply simp
  done

lemma loadCapTransfer_ccorres [corres]:
  "ccorres  cct_relation ret__struct_cap_transfer_C_'
           (valid_pspace' and valid_ipc_buffer_ptr' buffer)
           (UNIV \<inter> \<lbrace>\<acute>buffer = Ptr buffer\<rbrace>) hs
           (loadCapTransfer buffer)
           (Call loadCapTransfer_'proc)"
  apply (cinit lift: buffer_')
   apply (rule ccorres_Guard_Seq)+
   apply csymbr
   apply (simp add: seL4_MsgLengthBits_def
                    seL4_MsgExtraCapBits_def
                    seL4_MsgMaxLength_def
                    ptr_add_assertion_positive)
   apply (rule ccorres_move_array_assertion_ipc_buffer
               ccorres_rhs_assoc)+
   apply (rule ccorres_add_return2)
   apply (ctac(no_vcg))
    apply (rule ccorres_move_array_assertion_ipc_buffer)
    apply simp
    apply (ctac (no_vcg) add: ccorres_return_C)
   apply (wp capTransferFromWords_inv | simp)+
  apply (clarsimp simp: word_size)
  apply (simp add: seL4_MsgLengthBits_def
                   seL4_MsgExtraCapBits_def
                   seL4_MsgMaxLength_def
                   word_size word_sle_def
                   msgMaxLength_def msgMaxExtraCaps_def
                   msgLengthBits_def msgExtraCapBits_def
                   Collect_const_mem msg_align_bits)
  apply (frule(1) valid_ipc_buffer_ptr_array[where p="Ptr p'" for p', simplified],
    rule order_refl, simp_all add: msg_align_bits)
  apply (clarsimp simp: valid_ipc_buffer_ptr'_def wordSize_def')
  apply (subst array_assertion_shrink_left_add_div, assumption)
   apply (simp add: msgMaxLength_def msgExtraCaps_def msgMaxExtraCaps_def msgExtraCapBits_def
                    shiftL_nat)
  apply simp
  apply (erule aligned_add_aligned, simp_all add: is_aligned_def)
  done

lemma loadCapTransfer_ctReceiveDepth:
  "\<lbrace>\<top>\<rbrace> loadCapTransfer buffer \<lbrace>\<lambda>rv s. ctReceiveDepth rv < 2 ^ word_bits\<rbrace>"
  apply (simp add: loadCapTransfer_def capTransferFromWords_def)
  apply wp
    apply (rule_tac Q'="\<lambda>_ _. True" in hoare_post_eq)
     apply simp
     apply (simp only: word_bits_len_of[symmetric])
     apply (subst unat_lt2p, simp)
    apply wpsimp+
  done

(* FIXME: move *)
lemma cte_at_0' [dest!]:
  "\<lbrakk> cte_at' 0 s; no_0_obj' s \<rbrakk> \<Longrightarrow> False"
  apply (clarsimp simp: cte_wp_at_obj_cases')
  by (auto simp: tcb_cte_cases_def is_aligned_def dest!:tcb_aligned' split: if_split_asm)

lemma getReceiveSlots_ccorres:
  "ccorres (\<lambda>a c. (a = [] \<or> (\<exists>slot. a = [slot])) \<and>
           ((a \<noteq> []) = (c \<noteq> NULL)) \<and> (a\<noteq>[] \<longrightarrow> c = cte_Ptr (hd a) \<and> c \<noteq> NULL))
           ret__ptr_to_struct_cte_C_'
           (valid_ipc_buffer_ptr' buffer and
              valid_pspace'  and
              tcb_at' thread
             and (\<lambda>s. buffer \<noteq> 0))
           (UNIV \<inter> \<lbrace>\<acute>buffer = Ptr buffer\<rbrace> \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>) hs
           (getReceiveSlots thread (Some buffer))
           (Call getReceiveSlots_'proc)"
  apply (rule ccorres_gen_asm)
  apply (cinit lift: buffer_' thread_')
   apply (simp add: split_def)
   apply (ctac (no_vcg))
    apply (rule ccorres_emptyOnFailure)
    apply csymbr
    apply (rule ccorres_split_nothrowE)
         apply (rule unifyFailure_ccorres)
         apply (ctac (no_vcg) add: lookupCap_ccorres')
        apply ceqv
       apply simp
       apply csymbr
       apply (fold lookupTargetSlot_def)
       apply (rule ccorres_split_nothrow_novcgE)
             apply (rule unifyFailure_ccorres)
             apply (ctac (no_vcg) add: lookupTargetSlot_ccorres')
            apply ceqv
           apply (rename_tac slot slot_c)
           apply (simp add: liftE_bindE)
           apply csymbr
           apply (rule_tac P="cte_at' slot and no_0_obj'"
                      in ccorres_from_vcg_throws[where P'=UNIV])
           apply (rule allI, rule conseqPre, vcg)
           apply (clarsimp simp: in_monad cte_wp_at_ctes_of Bex_def in_getCTE2)
           apply (rule cmap_relationE1[OF cmap_relation_cte], assumption+)
           apply (clarsimp simp: typ_heap_simps' cap_get_tag_isCap in_monad
                          dest!: ccte_relation_ccap_relation)
           apply (erule cte_at_0'[rotated], simp add: cte_wp_at_ctes_of)
          apply clarsimp
          apply (rule ccorres_split_throws)
           apply (rule_tac P=\<top> and P'=UNIV in ccorres_from_vcg_throws)
           apply (rule allI, rule conseqPre, vcg)
           apply (clarsimp simp: throwError_def return_def)
          apply (rule conseqPre, vcg, clarsimp)
         apply clarsimp
         apply (wp lsfco_cte_at')
        apply (clarsimp simp: guard_is_UNIV_def)
       apply (clarsimp simp: guard_is_UNIV_def)
       apply (rule UNIV_I)
      apply simp
      apply clarsimp
      apply (rule ccorres_split_throws)
       apply (rule_tac P=\<top> and P'=UNIV in ccorres_from_vcg_throws)
       apply (rule allI, rule conseqPre, vcg)
       apply (clarsimp simp: throwError_def return_def)
      apply (rule conseqPre, vcg, clarsimp)
     apply clarsimp
     apply wp
    apply (vcg exspec=lookupCap_modifies)
   apply clarsimp
   apply (wp loadCapTransfer_ctReceiveDepth)
  apply clarsimp
  apply (intro conjI)
    apply fastforce
   apply fastforce
  apply clarsimp
  apply (simp add: cct_relation_def)
  apply (case_tac rv, clarsimp)
  apply (rule UNIV_I)  -- "still a schematic here ..."
  done


lemma setExtraBadge_ccorres:
  "ccorres dc xfdc
           (valid_pspace' and valid_ipc_buffer_ptr' buffer and (\<lambda>_. msg_max_length + 2 + n < unat max_ipc_words))
           (UNIV \<inter> \<lbrace>\<acute>bufferPtr = Ptr buffer\<rbrace> \<inter> \<lbrace>\<acute>badge = badge\<rbrace> \<inter> \<lbrace>\<acute>i = of_nat n\<rbrace>)
           hs
           (setExtraBadge buffer badge n)
           (Call setExtraBadge_'proc)"
  apply (rule ccorres_gen_asm)
  apply (cinit lift: bufferPtr_' badge_' i_')
   apply (unfold storeWordUser_def)
   apply (rule ccorres_pre_stateAssert)
   apply (simp only: K_bind_def)
   apply (rule ccorres_move_array_assertion_ipc_buffer
               ccorres_Guard[where F=C_Guard]
               ccorres_Guard[where F=SignedArithmetic]
               )+
   apply (ctac add: storeWord_ccorres)
  apply (clarsimp simp: bufferCPtrOffset_def word_size msgMaxLength_def wordSize_def'
                        seL4_MsgLengthBits_def seL4_MsgMaxLength_def Types_H.msgLengthBits_def
                        field_simps Collect_const_mem)
  apply (subgoal_tac " is_aligned (buffer + (of_nat n * 4 + 0x1E8)) 2")
   apply clarsimp
   prefer 2
   apply (clarsimp simp: valid_ipc_buffer_ptr'_def)
   apply (erule aligned_add_aligned, simp_all add: word_bits_def)
    apply (rule_tac n=2 in aligned_add_aligned, simp_all add: word_bits_def)
     apply (rule is_aligned_mult_triv2 [where n = 2, simplified])
    apply (simp add: is_aligned_def)
  apply (auto simp: pointerInUserData_c_guard pointerInUserData_h_t_valid
                    msg_align_bits max_ipc_words_def msg_max_length_def
                    capTransferDataSize_def msgMaxLength_def msgMaxExtraCaps_def
                    msgExtraCapBits_def unat_word_ariths unat_of_nat)
  done

lemma option_to_0_Some:
  "option_to_0 (Some x) = x"
  by (simp add: option_to_0_def)

(* FIXME: move *)
lemma ccorres_constOnFailure:
  assumes corr_ac: "ccorres (\<lambda>f c. case f of Inl x \<Rightarrow> r n c | Inr n \<Rightarrow> r n c)
                            xf
                            P P' hs a c"
  shows "ccorres r xf P P' hs (constOnFailure n a) c" using corr_ac
  apply (simp add: constOnFailure_def catch_def const_def bind_def split_def)
  apply (clarsimp simp: ccorres_underlying_def return_def split: xstate.splits sum.splits)
  apply (drule (1) bspec)
  apply (rule conjI, clarsimp)
   apply (erule_tac x=na in allE)
   apply (rename_tac s)
   apply (erule_tac x="Normal s" in allE)
   apply clarsimp
   apply (rule bexI)
    prefer 2
    apply assumption
   apply clarsimp
   apply (rule conjI, clarsimp simp: unif_rrel_def)
   apply (clarsimp simp: unif_rrel_def)
  apply fastforce
  done

(* FIXME: move *)
lemma ccorres_case_sum_liftE:
  "ccorres r xf P P' hs H C \<Longrightarrow> ccorres (\<lambda>a c. case_sum (\<lambda>x. r' x c) (\<lambda>y. r y c) a) xf P P' hs (liftE H) C"
  apply (clarsimp simp: ccorres_underlying_def split: xstate.splits)
  apply (drule (1) bspec)
  apply (clarsimp simp: split_def liftE_def bind_def return_def)
  apply (fastforce simp: unif_rrel_def)
  done

(* FIXME: move *)
lemma ccorres_case_bools_rhs:
  assumes P: "ccorres r xf P P' hs a c"
  assumes Q: "ccorres r xf Q Q' hs a c"
  shows "ccorres r xf (P and Q)
                      ({s. s \<in> B \<longrightarrow> s \<in> P'} \<inter> {s. s \<notin> B \<longrightarrow> s \<in> Q'})
                      hs a c" using P Q
  apply (clarsimp simp: ccorres_underlying_def)
  apply (drule (1) bspec)+
  apply clarsimp
  apply (case_tac "b \<in> B", auto)
  done

(* FIXME: move *)
lemma ccorres_return_bind_add:
  "ccorres r xf P P' hs (do z \<leftarrow> return (f x); H z od) C \<Longrightarrow> ccorres r xf P P' hs (H (f x)) C"
  by simp


(* FIXME: move *)
lemma ccorres_if_cond_throws_break:
  fixes e :: 'e
  assumes abs: "\<forall>s s'. (s, s') \<in> sr \<and> Q s \<and> Q' s' \<longrightarrow> P = (s' \<in> P')"
  and     ac: "P \<Longrightarrow> ccorres_underlying sr \<Gamma> r xf arrel axf R R' (catchbrk_C # hs) a c"
  and     bd: "\<not> P \<Longrightarrow> ccorres_underlying sr \<Gamma> r xf arrel axf U U' (catchbrk_C # hs) b d"
  and cthrows: "\<Gamma> \<turnstile>\<^bsub>/UNIV\<^esub> PT' c {}, UNIV" -- "c always throws"
  shows  "ccorres_underlying sr \<Gamma> r xf arrel axf
          (Q and (\<lambda>s. P \<longrightarrow> R s) and (\<lambda>s. \<not> P \<longrightarrow> U s))
          (Collect Q' \<inter> {s. (s \<in> P' \<longrightarrow> s \<in> R' \<inter> PT') \<and> (s \<notin> P' \<longrightarrow> s \<in> U')})
          (catchbrk_C # hs)
          (if P then a else b) (Cond P' c SKIP ;; d)"
  (is "ccorres_underlying sr \<Gamma> r xf arrel axf ?G ?G' ?hs ?a ?c")
proof (cases P)
  case True

  thus ?thesis
    apply simp
    apply (rule ccorres_guard_imp2)
    apply (rule ccorres_split_throws)
    apply (rule ccorres_cond_true [OF ac [OF True]])
    apply (rule HoarePartial.Cond [where P = "P' \<inter> PT'", OF _ cthrows])
    apply clarsimp
    apply (rule HoarePartial.Skip)
    apply (rule subset_refl)
    apply (clarsimp simp: abs [rule_format, OF conjI])
    done
next
  case False

  thus ?thesis
    apply simp
    apply (rule ccorres_guard_imp2)
    apply (rule ccorres_add_return)
    apply (rule ccorres_split_nothrow)
    apply (rule ccorres_cond_false)
       apply (rule ccorres_return_Skip)
      apply (rule ceqv_refl)
     apply (rule bd [OF False])
    apply wp
   apply simp
   apply (rule Cond_false)
   apply (rule HoarePartial.Skip [OF subset_refl])
   apply (clarsimp simp: abs [rule_format, OF conjI])
   done
qed


(* FIXME: move *)
lemma ccorres_if_cond_throws_break2:
  fixes e :: 'e
  assumes abs: "\<forall>s s'. (s, s') \<in> sr \<and> Q s \<and> Q' s' \<longrightarrow> (\<not> P) = (s' \<in> P')"
  and     ac: "\<not> P \<Longrightarrow> ccorres_underlying sr \<Gamma> r xf arrel axf R R' (catchbrk_C # hs) a c"
  and     bd: "P \<Longrightarrow> ccorres_underlying sr \<Gamma> r xf arrel axf U U' (catchbrk_C # hs) b d"
  and cthrows: "\<Gamma> \<turnstile>\<^bsub>/UNIV\<^esub> PT' c {}, UNIV" -- "c always throws"
  shows  "ccorres_underlying sr \<Gamma> r xf arrel axf
          (Q and (\<lambda>s. \<not> P \<longrightarrow> R s) and (\<lambda>s. P \<longrightarrow> U s))
          (Collect Q' \<inter> {s. (s \<in> P' \<longrightarrow> s \<in> R' \<inter> PT') \<and> (s \<notin> P' \<longrightarrow> s \<in> U')})
          (catchbrk_C # hs)
          (if P then b else a) (Cond P' c SKIP ;; d)"
  apply (subst if_swap)
  apply (rule ccorres_guard_imp2)
   apply (rule ccorres_if_cond_throws_break [OF abs ac bd cthrows])
    apply assumption
   apply simp
  apply clarsimp
  done

(* FIXME : move *)
lemma scast_bit_test [simp]:
    "scast ((1 :: 'a::len signed word) << n) = (1 :: 'a word) << n"
  by (clarsimp simp: word_eq_iff)

(* FIXME: move *)
lemma ccorres_split_when_throwError_cond_break:
  fixes e :: 'e
  assumes abs: "\<forall>s s'. (s, s') \<in> sr \<and> Q s \<and> Q' s' \<longrightarrow> P = (s' \<in> P')"
  and     cc: "P \<Longrightarrow> ccorres_underlying sr \<Gamma> r xf ar axf
                        R R' (catchbrk_C # hs) (throwError e) c"
  and     bd: "\<not> P \<Longrightarrow> ccorres_underlying sr \<Gamma> r xf ar axf
                        U U' (catchbrk_C # hs) b d"
  and cthrows: "\<Gamma> \<turnstile>\<^bsub>/UNIV\<^esub> PT' c {}, UNIV" -- "c always throws"
  shows  "ccorres_underlying sr \<Gamma> r xf ar axf
          (Q and (\<lambda>s. P \<longrightarrow> R s) and (\<lambda>s. \<not> P \<longrightarrow> U s))
          (Collect Q' \<inter> {s. (s \<in> P' \<longrightarrow> s \<in> R' \<inter> PT') \<and> (s \<notin> P' \<longrightarrow> s \<in> U')})
          (catchbrk_C # hs)
          (whenE P (throwError e) >>=E (\<lambda>_. b)) (Cond P' c SKIP ;; d)"
  apply (subst whenE_bindE_throwError_to_if)
  apply (rule ccorres_if_cond_throws_break [OF abs cc bd cthrows])
   apply assumption
  apply assumption
  done

lemma maskAsFull_isEndpoint[simp]:
  "isEndpointCap a \<Longrightarrow> maskedAsFull a b = a"
   by (clarsimp simp:isCap_simps maskedAsFull_def)

lemma maskAsFull_eq_ep:
  "maskedAsFull cap cap =
          EndpointCap a b c d e \<Longrightarrow> cap = EndpointCap a b c d e"
  by (clarsimp simp:maskedAsFull_def isCap_simps split:if_splits)

lemma is_derived_capMasterCap:
  "is_derived' m slot cap cap'
         \<Longrightarrow> capMasterCap cap = capMasterCap cap'"
 by (clarsimp simp:is_derived'_def badge_derived'_def)

lemma maskedAsFull_misc:
  "badge_derived' a (maskedAsFull a b)"
  "capASID (maskedAsFull a b) = capASID a"
  "cap_asid_base' (maskedAsFull a b) = cap_asid_base' a"
  "cap_vptr' (maskedAsFull a b) = cap_vptr' a"
  "capMasterCap (maskedAsFull a b) = capMasterCap a"
  by (auto simp:maskedAsFull_def isCap_simps badge_derived'_def
          split:if_split)

lemma maskedAsFull_again:
  "maskedAsFull (maskedAsFull aa aa) r = maskedAsFull aa aa"
  apply (case_tac aa)
  apply (simp_all add:maskedAsFull_def isCap_simps split: if_split)+
  done

lemma ccap_relation_lift:
  "ccap_relation cap cap'
   \<Longrightarrow> (cap_to_H (the (cap_lift cap'))) = cap"
  apply (case_tac "cap_lift cap'")
   apply (auto simp:ccap_relation_def split:option.splits)
  done

lemma ccap_relation_inject:
  "\<lbrakk>ccap_relation acap cap; ccap_relation bcap cap\<rbrakk> \<Longrightarrow> acap = bcap"
  apply (case_tac "cap_lift cap")
   apply (auto simp:ccap_relation_def split:option.splits)
  done

lemma t2n_mask_eq_if:
  "(2 ^ n && mask m) = (if n < m then 2 ^ n else 0)"
  by (rule word_eqI, auto simp add: word_size nth_w2p split: if_split)

lemma transferCapsLoop_ccorres:
  assumes conds:
    "rcv_buffer \<noteq> 0"
    "ep \<noteq> Some 0"
  defines "check1 \<equiv>
    Guard ShiftError \<lbrace>0 <=s seL4_MsgExtraCapBits\<rbrace>
     (Guard ShiftError \<lbrace>seL4_MsgExtraCapBits <s 0x20\<rbrace>
       (\<acute>ret__int :==
          (if \<acute>i < 2 ^ unat seL4_MsgExtraCapBits - 1 then 1
           else 0)))"
      and "check2 \<equiv> \<lambda>caps.
    IF \<acute>ret__int \<noteq> 0 THEN
      Guard ArrayBounds \<lbrace>\<acute>i < 3\<rbrace> (\<acute>ret__int :==
        (if index (excaprefs_C caps) (unat \<acute>i) \<noteq> cte_Ptr 0 then 1
         else 0))
    FI"
  defines "W \<equiv> \<lambda>ep caps.
           check1;; check2 caps;;
           (While \<lbrace>\<acute>ret__int \<noteq> 0\<rbrace>
             (Guard ArrayBounds \<lbrace>\<acute>i < 3\<rbrace> (\<acute>slot :== index (excaprefs_C caps) (unat \<acute>i));;
              Guard C_Guard \<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t \<acute>slot\<rbrace>
               (\<acute>cap :== h_val (hrs_mem \<acute>t_hrs) (cap_Ptr &(\<acute>slot\<rightarrow>[''cap_C''])));;
              \<acute>ret__unsigned :== CALL cap_get_capType(\<acute>cap);;
              \<acute>ret__int :== (if \<acute>ret__unsigned = scast cap_endpoint_cap then 1 else 0);;
              IF \<acute>ret__int \<noteq> 0 THEN
                \<acute>ret__unsigned :== CALL cap_endpoint_cap_get_capEPPtr(\<acute>cap);;
                \<acute>ret__int :== (if ep_Ptr \<acute>ret__unsigned = option_to_ptr ep then 1 else 0)
              FI;;
              IF \<acute>ret__int \<noteq> 0 THEN
                \<acute>ret__unsigned :== CALL cap_endpoint_cap_get_capEPBadge(\<acute>cap);;
                CALL setExtraBadge(Ptr rcv_buffer, ucast \<acute>ret__unsigned,\<acute>i);;
                \<acute>ret__unsigned :== CALL seL4_MessageInfo_get_capsUnwrapped(\<acute>info);;
                Guard ShiftError \<lbrace>unat \<acute>i < 31 \<and> 0 <=s (1 :: sword32)\<rbrace>
                 (\<acute>info :== CALL seL4_MessageInfo_set_capsUnwrapped(\<acute>info,
                  \<acute>ret__unsigned || scast ((1 :: sword32) << unat \<acute>i)))
              ELSE
                lvar_nondet_init dc_ret_' dc_ret_'_update;;
                IF \<acute>destSlot = cte_Ptr 0 THEN
                  break_C
                FI;;
                \<acute>dc_ret :== CALL deriveCap(\<acute>slot,\<acute>cap);;
                IF deriveCap_ret_C.status_C \<acute>dc_ret \<noteq> scast EXCEPTION_NONE THEN
                  break_C
                FI;;
                \<acute>ret__unsigned :== CALL cap_get_capType(deriveCap_ret_C.cap_C \<acute>dc_ret);;
                IF \<acute>ret__unsigned = scast cap_null_cap THEN
                  break_C
                FI;;
                CALL cteInsert(deriveCap_ret_C.cap_C \<acute>dc_ret,\<acute>slot,\<acute>destSlot);;
                \<acute>destSlot :== cte_Ptr 0
              FI;;
              \<acute>i :== \<acute>i + 1;; check1;; check2 caps))"
  defines "precond n mi slots \<equiv> (UNIV \<inter> \<lbrace>\<acute>i = of_nat n\<rbrace>
                 \<inter> \<lbrace>mi = message_info_to_H (\<acute>info)\<rbrace>
                 \<inter> \<lbrace>\<acute>destSlot = (if slots = [] then NULL else cte_Ptr (hd slots))
                                \<and> length slots \<le> 1 \<and> slots \<noteq> [0]\<rbrace>)"
  defines "is_the_ep \<equiv> \<lambda>cap. isEndpointCap cap \<and> ep \<noteq> None \<and> capEPPtr cap = the ep"
  defines "stable \<equiv> \<lambda>scap excap. excap \<noteq> scap \<longrightarrow> excap = maskedAsFull scap scap"
  defines "relative_at  \<equiv> \<lambda>scap slot s. cte_wp_at'
                                 (\<lambda>cte. badge_derived' scap (cteCap cte) \<and>
                                        capASID scap = capASID (cteCap cte) \<and>
                                        cap_asid_base' scap = cap_asid_base' (cteCap cte) \<and>
                                        cap_vptr' scap = cap_vptr' (cteCap cte)) slot s"
  shows "drop n (interpret_excaps caps') = excaps_map caps
            \<and> n \<le> length (interpret_excaps caps')
         \<Longrightarrow> ccorresG rf_sr \<Gamma>
           (\<lambda>r (i, info). r = msgExtraCaps_update (\<lambda>_. i) (message_info_to_H info)
                       \<and> i \<le> 3) (\<lambda>s. (i_' s, info_' s))
           (valid_pspace' and valid_ipc_buffer_ptr' rcv_buffer and
           (\<lambda>s.  (\<forall>x \<in> set caps. s \<turnstile>' fst x
             \<and> cte_wp_at' (\<lambda>cte. slots \<noteq> [] \<or> is_the_ep (cteCap cte)
               \<longrightarrow> (fst x) =  (cteCap cte)) (snd x) s
             \<and> cte_wp_at' (\<lambda>cte. fst x \<noteq> NullCap  \<longrightarrow> stable (fst x) (cteCap cte)) (snd x) s)) and
           (\<lambda>s. \<forall> sl \<in> (set slots). cte_wp_at' (isNullCap o cteCap) sl s) and
           (\<lambda>_. n + length caps \<le> 3 \<and> distinct slots ))
           (precond n mi slots)
           [catchbrk_C]
           (transferCapsToSlots ep rcv_buffer n caps slots mi)
           (W ep caps')"
unfolding W_def check1_def check2_def split_def
proof (rule ccorres_gen_asm, induct caps arbitrary: n slots mi)
  note if_split[split]
  case Nil
  thus ?case
    apply (simp only: transferCapsToSlots.simps)
    apply (rule ccorres_guard_imp2)
     apply (rule ccorres_Guard_Seq ccorres_rhs_assoc)+
     apply (rule ccorres_rhs_assoc2, rule ccorres_symb_exec_r)
       apply (rule ccorres_expand_while_iff [THEN iffD1])
       apply (rule ccorres_cond_false)
       apply (rule_tac P="\<lambda>_. n \<le> 3" and P'="\<lbrace>\<acute>i=of_nat n \<and> mi=message_info_to_H \<acute>info\<rbrace>"
                 in ccorres_from_vcg)
       apply (rule allI, rule conseqPre, vcg)
       apply (clarsimp simp: return_def msgExtraCapBits_def word_le_nat_alt unat_of_nat)
      apply vcg
     apply (rule conseqPre, vcg, clarsimp)
     apply (simp add: seL4_MsgExtraCapBits_def)
    apply (clarsimp simp: excaps_map_def seL4_MsgExtraCapBits_def word_sle_def
                          precond_def)
    apply (subst (asm) interpret_excaps_test_null)
      apply (simp add: unat_of_nat)
     apply (simp add: unat_of_nat)
     apply (erule le_neq_trans, clarsimp)
    apply (simp add: unat_of_nat)
    done
next
  note if_split[split]
  case (Cons x xs')
  let ?S="\<lbrace>\<acute>i=of_nat n \<and> mi=message_info_to_H \<acute>info\<rbrace>"
  have n3: "n \<le> 3" using Cons.prems by simp
  hence of_nat_n3[intro!]: "of_nat n \<le> (3 :: word32)"
    by (simp add: word_le_nat_alt unat_of_nat)
  have drop_n_foo: "\<And>xs n y ys. drop n xs = y # ys
     \<Longrightarrow> \<exists>xs'. length xs' = n \<and> xs = xs' @ (y # ys)"
    apply (frule_tac f=length in arg_cong, simp(no_asm_use))
    apply (cut_tac n=n and xs=xs in append_take_drop_id)
    apply (rule_tac x="take n xs" in exI)
    apply simp
    done

  have ep_cap_not_null: "\<And>cap. isEndpointCap cap \<Longrightarrow> cap \<noteq> NullCap"
    by (clarsimp simp: isCap_simps)

  have is_the_ep_maskedAsFull[simp]:"\<And>a b. is_the_ep (maskedAsFull a b) = is_the_ep a"
    apply (case_tac a)
     apply (simp add:maskedAsFull_def is_the_ep_def isCap_simps)+
    done

  have is_the_ep_fold:
  "(isEndpointCap (fst x) \<and> (\<exists>y. ep = Some y) \<and> capEPPtr (fst x) = the ep)
    = is_the_ep (fst x)"
    by (simp add:is_the_ep_def)

  have relative_fold:
   "\<And>scap slot s. (cte_wp_at'
    (\<lambda>cte. badge_derived' scap (cteCap cte) \<and>
    capASID scap = capASID (cteCap cte) \<and>
    cap_asid_base' scap = cap_asid_base' (cteCap cte) \<and>
    cap_vptr' scap = cap_vptr' (cteCap cte)) slot s) = relative_at scap slot s"
    by (simp add:relative_at_def)

  have stableD:
    "\<And>scap excap. stable scap excap
    \<Longrightarrow> (badge_derived' scap excap \<and>
                 capASID scap = capASID excap \<and>
                 cap_asid_base' scap = cap_asid_base' excap \<and> cap_vptr' scap = cap_vptr' excap)"
    apply (clarsimp simp:stable_def)
    apply (case_tac "excap = scap",simp+)
    apply (simp add:maskedAsFull_misc)
    done

  have stable_eq:
    "\<And>scap excap. \<lbrakk>stable scap excap; isEndpointCap excap\<rbrakk> \<Longrightarrow> scap = excap"
     by (simp add:isCap_simps stable_def maskedAsFull_def split:if_splits)

  have is_the_ep_stable:
    "\<And>a b. \<lbrakk>a \<noteq> NullCap \<longrightarrow> stable a b; \<not> is_the_ep b \<rbrakk> \<Longrightarrow> \<not> is_the_ep a"
    apply (clarsimp simp:stable_def maskedAsFull_def is_the_ep_def isCap_simps split:if_splits)
    apply auto
    done

  have is_the_ep_maskCapRights:
    "\<And>rights cap. is_the_ep (maskCapRights rights cap) = is_the_ep cap"
    apply (case_tac "isEndpointCap cap")
      apply (simp_all add:is_the_ep_def maskCapRights_def)
     apply (clarsimp simp:isCap_simps)
    apply (case_tac cap)
     apply (simp_all add:isCap_simps)
    apply (rename_tac acap)
    apply (case_tac acap)
     apply (clarsimp simp:ARM_H.maskCapRights_def isPageCap_def)+
    done

  have is_the_ep_deriveCap:
  "\<And>slot cap. \<lbrace>\<lambda>s. \<not> (is_the_ep cap)\<rbrace> deriveCap slot cap \<lbrace>\<lambda>rv s. \<not> (is_the_ep rv)\<rbrace>, -"
    apply (case_tac cap)
     apply (simp_all add:deriveCap_def Let_def isCap_simps is_the_ep_def)
      apply (wp,clarsimp)+
      defer
     apply (wp,clarsimp)+
    apply (rename_tac acap)
    apply (case_tac acap)
     apply (simp_all add:ARM_H.deriveCap_def Let_def isCap_simps is_the_ep_def)
    apply (wp |clarsimp|rule conjI)+
    done

  have mask_right_eq_null:
    "\<And>r cap. (maskCapRights r cap = NullCap) = (cap = NullCap)"
    apply (case_tac cap)
     apply (simp_all add:maskCapRights_def isCap_simps)
    apply (rename_tac acap)
    apply (case_tac acap)
     apply (simp add:ARM_H.maskCapRights_def isPageCap_def)+
    done
  note if_split[split del]
  note if_cong[cong]
  note extra_sle_sless_unfolds [simp del]
  from Cons.prems
  show ?case
    apply (clarsimp simp: Let_def word_sle_def[where b=5] split_def
                    cong: call_ignore_cong
                simp del: Collect_const)
    apply (rule ccorres_constOnFailure)
    apply (rule ccorres_guard_imp2)
     apply (rule ccorres_symb_exec_r)
       apply (rule ccorres_expand_while_iff [THEN iffD1])
       apply (rule ccorres_cond_true)
       apply (rule ccorres_rhs_assoc)+
       apply (rule_tac xf'=i_' in ccorres_abstract, ceqv)
       apply (rule ccorres_Guard_Seq)
       apply csymbr
       apply (rule ccorres_symb_exec_r)
         apply (rule_tac xf'=cap_' in ccorres_abstract,ceqv)
         apply (rename_tac n' cap')
         apply (rule_tac P="\<exists>acap. ccap_relation acap cap'
                     \<and> (isEndpointCap acap \<longrightarrow> capEPPtr acap \<noteq> 0)" in ccorres_gen_asm2)
         apply csymbr+
         apply (rule ccorres_symb_exec_r)
           apply (rule ccorres_seq_cond_raise[THEN iffD2])
           apply (rule_tac xf'=ret__int_' in ccorres_abstract_known, ceqv)
           apply (rule ccorres_cond2[where R=\<top>])
             apply (clarsimp simp: Collect_const_mem)
             apply (rule sym, rule from_bool_neq_0)

            -- "case where a badge is sent"
            apply (rule ccorres_rhs_assoc)+
            apply csymbr
            apply (simp only: Let_def liftE_bindE withoutFailure_def fun_app_def)
            apply (ctac add: setExtraBadge_ccorres)
              apply (simp only: K_bind_def)
              apply (rule ccorres_case_sum_liftE)
              apply (csymbr, rule ccorres_abstract_cleanup)
              apply (rule ccorres_Guard_Seq)
              apply (csymbr, rule ccorres_abstract_cleanup)
              apply (rule ccorres_symb_exec_r)
                apply (rule ccorres_rhs_assoc2)
                apply (rule Cons.hyps)
                 apply (clarsimp simp: excaps_map_def dest!: drop_n_foo)
                apply simp
               apply vcg
              apply (rule conseqPre, vcg, clarsimp)
             apply (wp hoare_vcg_ball_lift)
            apply (simp split del: if_split)
            apply (vcg exspec=setExtraBadge_modifies)

           -- "case where a cap is sent (or rather a send is attempted)"
           apply (simp add: split_def del: Collect_const
                      cong: call_ignore_cong split del: if_split)
           apply (rule ccorres_rhs_assoc)+
           apply csymbr
           apply wpc
            apply (rule ccorres_cond_true_seq)
            apply (simp add: returnOk_liftE)
            apply (rule ccorres_case_sum_liftE)
            apply (rule ccorres_split_throws)
             apply (rule_tac P=\<top> and P'="?S" in ccorres_break_return)
              apply clarsimp
             apply simp
            apply vcg
           apply (rule ccorres_cond_false_seq)
           apply (simp)

           -- "case not diminish"
           apply (rule ccorres_split_nothrowE)
                apply (rule unifyFailure_ccorres)
                apply (ctac add: deriveCap_ccorres')
               apply ceqv
              apply (simp only: refl not_True_eq_False Collect_False ccorres_seq_simps)
              apply csymbr
              apply (rule_tac Q=\<top> and Q'=\<top> in ccorres_split_when_throwError_cond_break)
                 apply (clarsimp simp: cap_get_tag_isCap Collect_const_mem)
                apply (rule_tac P=\<top> and P'="?S" in ccorres_break)
                 apply clarsimp
                apply simp
               apply (simp(no_asm) add: liftE_bindE split del: if_split)
               apply (ctac add: cteInsert_ccorres)
                 apply (rule ccorres_case_sum_liftE)
                 apply csymbr
                 apply (rule ccorres_symb_exec_r)
                   apply (rule ccorres_rhs_assoc2)
                   apply (rule_tac P="ccorresG rf_sr \<Gamma> r xf Pre Pre' hs a" for r xf Pre Pre' hs a in rsubst)
                    apply (rule Cons.hyps)
                     apply (clarsimp simp: excaps_map_def dest!: drop_n_foo)
                    apply simp
                   apply simp
                  apply vcg
                 apply (rule conseqPre, vcg)
                 apply clarsimp
                apply (rule cteInsert_assume_Null)
                apply simp
                apply (wp cteInsert_valid_pspace hoare_valid_ipc_buffer_ptr_typ_at'
                          hoare_vcg_const_Ball_lift cteInsert_cte_wp_at)
               apply (vcg exspec=cteInsert_modifies)
              apply vcg
             apply (simp)
             apply (rule ccorres_split_throws)
              apply (rule_tac P=\<top> and P'="?S" in ccorres_break)
               apply clarsimp
              apply simp
             apply vcg
            apply wp
            apply (simp cong: conj_cong)
               apply (rule_tac Q' ="\<lambda>rcap s. s \<turnstile>' rcap
                 \<and> (rcap\<noteq> NullCap \<longrightarrow> cte_wp_at' (is_derived' (ctes_of s) (snd x) rcap \<circ> cteCap) (snd x) s)
                 \<and> valid_pspace' s \<and> valid_ipc_buffer_ptr' rcv_buffer s \<and> length slots = 1
                 \<and> \<not> is_the_ep rcap
                 \<and> (\<forall>x\<in>set slots. cte_wp_at' (isNullCap \<circ> cteCap) x s)
                 \<and> (\<forall>x\<in>set xs'. s \<turnstile>' fst x
                    \<and> cte_wp_at' (\<lambda>c. is_the_ep (cteCap c) \<longrightarrow> fst x = cteCap c) (snd x) s
                    \<and> cte_wp_at' (\<lambda>c. fst x \<noteq> NullCap \<longrightarrow> stable (fst x) (cteCap c)) (snd x) s)"
                 in hoare_post_imp_R)
                prefer 2
                 apply (clarsimp simp:cte_wp_at_ctes_of valid_pspace_mdb' valid_pspace'_splits
                   valid_pspace_valid_objs' is_derived_capMasterCap image_def)
                 apply (clarsimp split:if_splits)
                 apply (rule conjI)
                  apply clarsimp+
                 apply (rule conjI)
                  apply (drule(1) bspec)+
                  apply (rule conjI | clarsimp)+
                   apply (clarsimp simp:is_the_ep_def isCap_simps stable_def)
                  apply (drule(1) bspec)+
                  apply (rule conjI | clarsimp)+
                   apply (clarsimp simp:is_the_ep_def stable_def split:if_splits)+
                 apply (case_tac "a = cteCap cteb",clarsimp)
                  apply (simp add:maskedAsFull_def split:if_splits)
                 apply (simp add:maskedAsFull_again)
               apply (wp deriveCap_derived is_the_ep_deriveCap)
            apply (vcg exspec=deriveCap_modifies)

          --"remaining non ccorres subgoals"
           apply (clarsimp simp: Collect_const_mem if_1_0_0
                     split del: if_split)
           apply (rule_tac Q'="\<lbrace>\<acute>ret__int = from_bool (cap_get_tag cap' = scast cap_endpoint_cap
                                        \<and> ep_Ptr (capEPPtr_CL (cap_endpoint_cap_lift cap')) = option_to_ptr ep)
                  \<and> n' = of_nat n \<and> ((slots \<noteq> [] \<or> isEndpointCap (fst x) \<or> is_the_ep (cap_to_H (the (cap_lift cap'))))
                                       \<longrightarrow> ccap_relation (fst x) cap' )
                  \<and> (isEndpointCap (fst x) \<longrightarrow> capEPPtr (fst x) \<noteq> 0)\<rbrace>
                    \<inter> precond n mi slots"
              in conseqPost[OF _ _ order_refl])
             apply vcg
            apply (rule subsetI)
            apply (clarsimp simp: word_of_nat_less from_bool_0 precond_def
                                cap_get_tag_isCap unat_of_nat)
            apply (rule conjI)
             apply (clarsimp simp: cap_get_tag_EndpointCap cap_get_tag_isCap[symmetric]
                                 ep_cap_not_null)
             apply (clarsimp simp: ccap_relation_def map_option_Some_eq2)
             apply (simp add: message_info_to_H_def word_ao_dist)
             apply (fold shiftl_1)[1]
             apply (subst and_mask_eq_iff_shiftr_0[THEN iffD2],
                  subst shiftl_shiftr2, simp, simp)
             apply (simp add: seL4_MessageInfo_lift_def word_bw_assocs
                              word_sle_def t2n_mask_eq_if)
             apply (simp add: mask_def)
            apply (rule conjI)
             apply (clarsimp simp: ccap_rights_relation_def cap_rights_to_H_def
                                 false_def true_def to_bool_def allRights_def
                                 excaps_map_def split_def
                          dest!: drop_n_foo interpret_excaps_eq)
            apply (clarsimp simp:from_bool_def split:bool.splits)
             apply (case_tac "isEndpointCap (fst x)")
              apply (clarsimp simp: cap_get_tag_EndpointCap ep_cap_not_null cap_get_tag_isCap[symmetric])
              apply (clarsimp simp: option_to_ptr_def option_to_0_def split:option.splits)
             apply (clarsimp simp: cap_get_tag_EndpointCap ep_cap_not_null cap_get_tag_isCap[symmetric])
             apply (case_tac "ccap_relation (fst x) cap'")
              apply (simp add:ccap_relation_lift)
              apply (drule(1) ccap_relation_inject)
              apply (drule sym[where t = "fst x"])
              apply (clarsimp simp:isCap_simps)
             apply (clarsimp simp: is_the_ep_def ccap_relation_lift isCap_simps)
             apply (clarsimp simp: option_to_ptr_def option_to_0_def split:option.splits)
            apply (clarsimp simp:option_to_ptr_def option_to_0_def)
            apply (case_tac "isEndpointCap (fst x)")
             apply (clarsimp simp: isCap_simps)
             apply (drule_tac acap = acap in ccap_relation_inject)
              apply assumption
             apply clarsimp
             apply (clarsimp simp: ccap_relation_def map_option_Some_eq2 split:option.splits)
             apply (clarsimp simp: cap_endpoint_cap_lift_def option_to_ptr_def
                                option_to_0_def cap_to_H_def Let_def split:cap_CL.splits split:if_splits)
            apply clarsimp
           apply (simp only:badge_derived_mask capASID_mask cap_asid_base_mask'
             cap_vptr_mask' maskCap_valid mask_right_eq_null)
           apply (simp only:is_the_ep_fold relative_fold)
           apply (clarsimp simp:Collect_const_mem if_1_0_0
             split del:if_split)
           apply (rule conseqPre, vcg, clarsimp simp: Collect_const_mem)
          apply (clarsimp simp: if_1_0_0 Collect_const_mem
                              trans[OF eq_commute from_bool_eq_if]
                              from_bool_0
                   split del: if_split simp del: Collect_const)
          apply vcg
         apply (simp only:is_the_ep_fold)
         apply (clarsimp simp:Collect_const_mem if_1_0_0
            split del:if_split)
         apply (rule conseqPre, vcg)
         apply (clarsimp split del: if_split)
        apply (clarsimp split del: if_split
                       simp add: Collect_const[symmetric] precond_def true_def false_def
                       simp del: Collect_const)
        apply (rule HoarePartial.Seq[rotated] HoarePartial.Cond[OF order_refl]
                  HoarePartial.Basic[OF order_refl] HoarePartial.Skip[OF order_refl]
                  HoarePartial.Guard[OF order_refl])+
       apply (simp only:is_the_ep_fold)
       apply (clarsimp simp:Collect_const_mem if_1_0_0
            split del:if_split)
       apply (rule conseqPre, vcg, rule subsetI, clarsimp)
    apply (simp only:is_the_ep_fold)
    apply (clarsimp simp: Collect_const_mem seL4_MsgExtraCapBits_def
                          word_sle_def if_1_0_0 precond_def
                          msg_max_length_def max_ipc_words word_of_nat_less
                          excaps_map_def unat_of_nat valid_pspace'_def
                          cte_wp_at_ctes_of
                   dest!: drop_n_foo interpret_excaps_eq)
    apply (frule(1) ctes_of_valid')
    apply (rule cmap_relationE1[OF cmap_relation_cte], assumption+)
    apply (clarsimp simp: typ_heap_simps' split_def is_the_ep_maskCapRights)
    apply (frule ccte_relation_ccap_relation)
    apply (intro conjI impI)
         apply (intro allI impI)
         apply clarsimp
         apply fastforce
        apply (subgoal_tac "fst x = cteCap cte",simp)
        apply clarsimp
        apply (elim disjE)
         apply (clarsimp simp:ep_cap_not_null stable_def)
        apply (clarsimp dest!:ccap_relation_lift stable_eq simp: cap_get_tag_isCap)
       apply (clarsimp simp:valid_cap_simps' isCap_simps)
       apply (subgoal_tac "slots \<noteq> []")
        apply simp
       apply clarsimp
       apply (elim disjE)
        apply (clarsimp simp:ep_cap_not_null stable_def)
        apply (clarsimp dest!:ccap_relation_lift stable_eq simp: cap_get_tag_isCap)
       apply (clarsimp dest!:ccap_relation_lift simp:cap_get_tag_isCap is_the_ep_def)
      apply (clarsimp simp:valid_cap_simps' isCap_simps)
     apply (intro exI conjI,assumption)
    apply (clarsimp simp: ccap_relation_def map_option_Some_eq2
                            isCap_simps valid_cap_simps')+
    done
qed

lemma cte_wp_at_imp_consequent':
  "cte_wp_at' Q p s \<longrightarrow> cte_wp_at' (\<lambda>cte. P cte \<longrightarrow> Q cte) p s"
  by (clarsimp simp: cte_wp_at_ctes_of)

lemma lookupExtraCaps_srcs2:
  "\<lbrace>\<top>\<rbrace> lookupExtraCaps t buf mi \<lbrace>\<lambda>caps s. \<forall>x \<in> set caps. cte_wp_at'
              (\<lambda>cte. cteCap cte = fst x) (snd x) s\<rbrace>,-"
  apply (simp add: lookupExtraCaps_def lookupCapAndSlot_def
                   split_def lookupSlotForThread_def
                   getSlotCap_def)
  apply (wp mapME_set[where R=\<top>] getCTE_wp'
             | simp add: cte_wp_at_ctes_of
             | wp_once hoare_drop_imps
             | (rule hoare_strengthen_post [OF hoare_TrueI], rule allI, rule impI, rule TrueI))+
  done

lemma transferCaps_ccorres [corres]:
  notes if_cong[cong]
  notes extra_sle_sless_unfolds[simp del]
  shows
  "ccorres (\<lambda>r r'. r = message_info_to_H r') ret__struct_seL4_MessageInfo_C_'
    (valid_pspace' and tcb_at' receiver
     and (case_option \<top> valid_ipc_buffer_ptr') receiveBuffer
     and (excaps_in_mem caps \<circ> ctes_of)
     and K (length caps \<le> 3)
     and K (ep \<noteq> Some 0)
     and K (receiveBuffer \<noteq> Some 0)
     and K (unat (msgExtraCaps mi) \<le> 3))
    (UNIV \<inter> \<lbrace>interpret_excaps (\<acute>caps) = excaps_map caps\<rbrace>
          \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
          \<inter> \<lbrace> mi = message_info_to_H \<acute>info\<rbrace>
          \<inter> \<lbrace>\<acute>receiveBuffer = Ptr (option_to_0 receiveBuffer)\<rbrace>
          \<inter> \<lbrace>\<acute>endpoint = option_to_ptr ep\<rbrace>) []
    (transferCaps mi caps ep receiver receiveBuffer)
    (Call transferCaps_'proc)" (is "ccorres _ _ ?P _ _ _ _")
  apply (unfold K_def, intro ccorres_gen_asm)
  apply (cinit lift: caps_' receiver_' info_' receiveBuffer_' endpoint_'
    simp: getThreadCSpaceRoot_def locateSlot_conv whileAnno_def)
   apply csymbr+
   apply (rule_tac P="?P" and P'="{s. info_' s = info}" in ccorres_inst)
   apply (cases "receiveBuffer = None")
    apply (clarsimp simp: option_to_0_def getReceiveSlots_def
                simp del: Collect_const)
    apply (rule ccorres_guard_imp2)
     apply (rule ccorres_move_const_guards)+
     apply (simp (no_asm))
     apply (rule_tac R'=UNIV in ccorres_split_throws [OF ccorres_return_C], simp_all)[1]
     apply vcg
     apply simp
    apply (simp add: message_info_to_H_def word_sless_def word_sle_def)
   apply (cases "caps = []")
    apply (clarsimp simp: interpret_excaps_test_null excaps_map_def
                simp del: Collect_const not_None_eq)
    apply (erule notE, rule ccorres_guard_imp2)
     apply (rule ccorres_move_const_guards)+
     apply (simp (no_asm))
     apply (rule ccorres_symb_exec_l)
        apply (rule_tac R'=UNIV in ccorres_split_throws [OF ccorres_return_C], simp_all)[1]
        apply vcg
        apply simp
       apply ((wp empty_fail_getReceiveSlots)+)[3]
    apply (simp add: message_info_to_H_def word_sless_def word_sle_def)
   apply (simp add: option_to_0_def ccorres_cond_iffs
                    interpret_excaps_test_null excaps_map_def
               del: Collect_const
               cong: call_ignore_cong)
   apply (elim exE)
   apply (clarsimp simp: Collect_const[symmetric] Collect_False
                         signed_shift_guard_simpler_32
               simp del: Collect_const
                   cong: call_ignore_cong)
   apply (rule ccorres_guard_imp2)
    apply (rule ccorres_move_const_guards)+
    apply (simp (no_asm) only: ccorres_seq_cond_empty ccorres_seq_skip)
    apply (ctac add: getReceiveSlots_ccorres)
      apply (elim conjE)
      apply (rule ccorres_symb_exec_r)
        apply (rule ccorres_add_return2)
        apply (rule ccorres_split_nothrow_novcg)
            apply (rule ccorres_Catch)
            apply (rule_tac caps=caps and caps'=capsa in transferCapsLoop_ccorres, simp+)
            apply (simp add: excaps_map_def)
           apply ceqv
          apply csymbr
          apply (rule ccorres_abstract_cleanup)
          apply (rule ccorres_return_C, simp+)[1]
         apply wp
        apply (simp add: guard_is_UNIV_def)
        apply (clarsimp simp: message_info_to_H_def split: if_split)
        apply (erule notE, (rule sym)?, rule less_mask_eq)
        apply (simp add: minus_one_helper5)
       apply (subgoal_tac "rv \<noteq> [0]")
        apply simp
        apply vcg
       apply clarsimp
      apply (rule conseqPre, vcg, clarsimp)
     apply (simp add: o_def pred_conj_def)
     apply (strengthen cte_wp_at_imp_consequent')
     apply wp
    apply (simp only: mem_simps simp_thms split: if_split)
    apply (vcg exspec=getReceiveSlots_modifies)
   apply (clarsimp simp: message_info_to_H_def excaps_in_mem_def
                         slotcap_in_mem_def split_def cte_wp_at_ctes_of
                         word_sless_def word_sle_def)
   apply fastforce
  apply clarsimp
  done

(* FIXME: move *)
lemma getMessageInfo_le3:
  "\<lbrace>\<top>\<rbrace> getMessageInfo sender \<lbrace>\<lambda>rv s. unat (msgExtraCaps rv) \<le> 3\<rbrace>"
  including no_pre
  apply (simp add: getMessageInfo_def)
  apply wp
  apply (rule_tac Q="\<lambda>_. \<top>" in hoare_strengthen_post)
   apply wp
  apply (simp add: messageInfoFromWord_def Let_def msgExtraCapBits_def)
  apply (cut_tac y="r >> Types_H.msgLengthBits" in word_and_le1 [where a=3])
  apply (simp add: word_le_nat_alt)
  done

lemma getMessageInfo_msgLength:
  "\<lbrace>\<top>\<rbrace> getMessageInfo sender \<lbrace>\<lambda>rv. K (unat (msgLength rv) \<le> msgMaxLength)\<rbrace>"
  including no_pre
  apply (simp add: getMessageInfo_def)
  apply wp
  apply (rule_tac Q="\<lambda>_. \<top>" in hoare_strengthen_post)
   apply wp
  apply (simp add: messageInfoFromWord_def Let_def not_less msgMaxLength_def msgLengthBits_def
            split: if_split)
  apply (cut_tac y="r" in word_and_le1 [where a="0x7F"])
  apply (simp add: word_le_nat_alt)
  done

definition
  mi_from_H :: "Types_H.message_info \<Rightarrow> seL4_MessageInfo_CL"
where
 "mi_from_H mi \<equiv>
     \<lparr> label_CL = msgLabel mi,
       capsUnwrapped_CL = msgCapsUnwrapped mi,
       extraCaps_CL = msgExtraCaps mi,
       length_CL = msgLength mi \<rparr>"

lemma ccorres_add_returnOk2:
  "ccorres_underlying rf_sr G r xf arrel axf P P' hs (a >>=E returnOk) c
    \<Longrightarrow> ccorres_underlying rf_sr G r xf arrel axf P P' hs a c"
  by (rule ccorres_add_returnOk)

lemma capFaultOnFailure_ccorres:
  "ccorres (f \<currency> r) xf P P' hs a c
    \<Longrightarrow> ccorres ((\<lambda>x y z. \<exists>w. x = CapFault addr b w \<and> f w y z) \<currency> r)
             xf P P' hs
             (capFaultOnFailure addr b a) c"
  apply (simp add: capFault_injection injection_handler_liftM)
  apply (erule ccorres_rel_imp)
  apply (auto split: sum.split)
  done

definition
 "cfault_rel2 \<equiv> \<lambda>ft exnvar err. exnvar = (scast EXCEPTION_FAULT :: word32) \<and>
                   cfault_rel (Some ft) (errfault err) (errlookup_fault err)"

lemma takeWhile_eq:
  "\<lbrakk> \<And>m. \<lbrakk> m < length ys \<rbrakk> \<Longrightarrow> P (xs ! m);
       length ys < length xs \<Longrightarrow> \<not> P (xs ! length ys);
       length ys \<le> length xs;
     \<And>m. m < length ys \<Longrightarrow> xs ! m = ys ! m \<rbrakk>
    \<Longrightarrow> takeWhile P xs = ys"
proof (induct xs arbitrary: n ys)
  case Nil
  thus ?case by simp
next
  case (Cons x xs' ys')
  have P: "\<And>v m. \<lbrakk> (x # xs') ! m = v; m < length ys' \<rbrakk>
                     \<Longrightarrow> P v"
    using Cons.prems by clarsimp
  show ?case using Cons.prems(2-3)
    apply simp
    apply (cases ys')
     apply simp
    apply (subst P[where m1=0])
       apply simp+
    apply (rule conjI)
     apply (cut_tac m1=0 in Cons.prems(4), simp+)
    apply (rule Cons.hyps)
       apply (rule_tac m1="Suc m" in P, simp+)
    apply (cut_tac m1="Suc m" in Cons.prems(4), simp+)
    done
qed

lemma ccorres_sequenceE_while':
  fixes axf :: "globals myvars \<Rightarrow> 'e" shows
  "\<lbrakk>\<And>ys. length ys < length xs \<Longrightarrow>
        ccorres_underlying sr \<Gamma> (inr_rrel (\<lambda>rv rv'. r' (ys @ [rv]) rv')) xf'
                            (inl_rrel arrel) axf
                            (F (length ys)) (Q \<inter> {s. i_' s = of_nat (length ys) \<and> r' ys (xf' s)}) hs
                            (xs ! length ys) body;
    \<And>n. P n = (n < of_nat (length xs));
    \<And>s. s \<in> Q \<Longrightarrow> \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {s} body (Q \<inter> {t. i_' t = i_' s}),UNIV;
    \<And>n. n < length xs \<Longrightarrow> \<lbrace>F n\<rbrace> xs ! n \<lbrace>\<lambda>_. F (Suc n)\<rbrace>, -;
     length xs < 2 ^ word_bits;
     \<forall>s f. xf' (i_'_update f s) = xf' s
                 \<and> ((i_'_update f s \<in> Q) = (s \<in> Q))
                 \<and> (\<forall>s'. ((s', i_'_update f s) \<in> sr) = ((s', s) \<in> sr)) \<rbrakk>
    \<Longrightarrow> ccorres_underlying sr \<Gamma> (inr_rrel (\<lambda>rv (i', rv'). r' rv rv' \<and> i' = of_nat (length xs)))
                  (\<lambda>s. (i_' s, xf' s)) arrel axf
                  (F 0) (Q \<inter> {s. r' [] (xf' s)}) hs
          (sequenceE xs)
          (Basic (\<lambda>s. i_'_update (\<lambda>_. 0) s) ;;
           While {s. P (i_' s)} (body;;
             Basic (\<lambda>s. i_'_update (\<lambda>_. i_' s + 1) s)))"
  apply (rule ccorres_guard_imp2)
   apply (rule ccorres_symb_exec_r)
     apply (rule ccorres_sequenceE_while_gen'[where i=0, simplified, where xf_update=i_'_update],
            (assumption | simp)+)
       apply (simp add: word_bits_def)
      apply simp+
    apply vcg
   apply (rule conseqPre, vcg)
   apply clarsimp
  apply simp
  done

lemma lookupExtraCaps_ccorres:
  notes if_cong[cong] nat_min_simps [simp del]
  shows
  "ccorres
     ((\<lambda>ft _ err.
                   cfault_rel (Some ft) (errfault err) (errlookup_fault err))
          \<currency> (\<lambda>xs ys. interpret_excaps ys = excaps_map xs))
      (liftxf errstate fst snd
           (\<lambda>s. (ret__unsigned_long_' s, current_extra_caps_' (globals s))))
      (valid_pspace' and tcb_at' thread
             and (case buffer of Some x\<Rightarrow> valid_ipc_buffer_ptr' x | _ \<Rightarrow> \<top>)
             and (\<lambda>s. unat (msgExtraCaps info) <= 3))
      (UNIV \<inter> {s. thread_' s = tcb_ptr_to_ctcb_ptr thread}
            \<inter> {s. bufferPtr_' s = option_to_ptr buffer}
            \<inter> {s. seL4_MessageInfo_lift (info_' s) = mi_from_H info
                  }) []
      (lookupExtraCaps thread buffer info) (Call lookupExtraCaps_'proc)"
proof -
  let ?curr = "\<lambda>s. current_extra_caps_' (globals s)"
  let ?EXCNONE = "{s. ret__unsigned_long_' s = scast EXCEPTION_NONE}"
  let ?interpret = "\<lambda>v n. take n (array_to_list (excaprefs_C v))"
  note if_split[split del]
  show ?thesis
  apply (rule ccorres_gen_asm)+
  apply (cinit(no_subst_asm) lift: thread_' bufferPtr_' info_' simp: whileAnno_def)
   apply (clarsimp simp add: getExtraCPtrs_def lookupCapAndSlot_def
                             capFault_bindE
                   simp del: Collect_const)
   apply (simp add: liftE_bindE del: Collect_const)
   apply wpc
   apply (rename_tac word1 word2 word3 word4)
   apply (simp del: Collect_const)
   apply wpc
    apply (simp add: option_to_ptr_def option_to_0_def)
    apply (rule ccorres_rhs_assoc2, rule ccorres_split_throws)
     apply (rule ccorres_from_vcg_throws[where P=\<top> and P'=UNIV])
     apply (rule allI, rule conseqPre, vcg)
     apply (clarsimp simp: returnOk_def return_def)
     apply (simp add: excaps_map_def)
     apply (subst interpret_excaps_test_null[where n=0, simplified, symmetric])
     apply (simp add: word_sle_def word_sless_def)
    apply vcg
   apply (simp add: id_def[symmetric] del: Collect_const)
   apply (rule ccorres_symb_exec_r)
     apply (simp add: option_to_ptr_def option_to_0_def Collect_False
                      ccorres_cond_iffs
                 del: Collect_const)
     apply csymbr
     apply (rename_tac "lngth")
     apply (simp add: mi_from_H_def mapME_def del: Collect_const cong: bind_apply_cong)
     apply (rule ccorres_symb_exec_l)
        apply (rule_tac P="length rv = unat word2" in ccorres_gen_asm)
        apply (rule ccorres_rhs_assoc2)
        apply (rule ccorres_add_returnOk2,
               rule ccorres_splitE_novcg)
             apply (rule_tac xf'="?curr"
                       and  r'="\<lambda>xs v. excaps_map xs = ?interpret v (length xs)"
                       and   Q="UNIV"
                       and   F="\<lambda>n s. valid_pspace' s \<and> tcb_at' thread s \<and>
                                      (case buffer of Some x \<Rightarrow> valid_ipc_buffer_ptr' x | _ \<Rightarrow> \<top>) s \<and>
                                       (\<forall>m < length rv. user_word_at (rv ! m)
                                                     (x2 + (of_nat m + (msgMaxLength + 2)) * 4) s)"
                          in ccorres_sequenceE_while')
                  apply (simp add: split_def)
                  apply (rule ccorres_rhs_assoc)+
                  apply (rule ccorres_guard_imp2)
                   apply (rule ccorres_symb_exec_r)
                     apply (rule_tac xf'=cptr_' in ccorres_abstract, ceqv)
                     apply (ctac add: capFaultOnFailure_ccorres
                               [OF lookupSlotForThread_ccorres'])
                        apply (rule_tac P="is_aligned rva 4" in ccorres_gen_asm)
                        apply (simp add: ccorres_cond_iffs liftE_bindE)
                        apply (rule ccorres_symb_exec_l [OF _ _ _ empty_fail_getSlotCap])
                          apply (rule_tac P'="UNIV \<inter> {s. excaps_map ys
                                                         = ?interpret (?curr s) (length ys)}
                                                   \<inter> {s. i_' s = of_nat (length ys)}"
                                     in ccorres_from_vcg[where P=\<top>])
                          apply (rule allI, rule conseqPre, vcg)
                          apply (simp add: returnOk_liftE)
                          apply (clarsimp simp: Bex_def in_monad)
                          apply (clarsimp simp: excaps_map_def array_to_list_def
                                                lookupSlot_raw_rel_def)
                          apply (subgoal_tac "length ys < 3")
                           apply (simp add: take_Suc_conv_app_nth take_map
                                            unat_of_nat32[unfolded word_bits_conv]
                                            word_of_nat_less)
                          apply (simp add: word_less_nat_alt)
                         apply wp+
                       apply (clarsimp simp: ccorres_cond_iffs)
                       apply (rule_tac  P= \<top>
                                and P'="{x. errstate x= lu_ret___struct_lookupSlot_raw_ret_C \<and>
                                            rv' = (rv ! length ys)}"
                                  in ccorres_from_vcg_throws)
                       apply (rule allI, rule conseqPre, vcg)
                       apply (clarsimp simp: throwError_def return_def)
                       apply (frule lookup_failure_rel_fault_lift, assumption)
                       apply (clarsimp simp: cfault_rel2_def)
                       apply (clarsimp simp: cfault_rel_def)
                       apply (simp add: seL4_Fault_CapFault_lift)
                       apply (clarsimp simp: is_cap_fault_def to_bool_def false_def)
                      apply wp
                      apply (rule hoare_post_imp_R, rule lsft_real_cte)
                      apply (clarsimp simp: obj_at'_def projectKOs objBits_simps)
                     apply (vcg exspec=lookupSlot_modifies)
                    apply vcg
                   apply (rule conseqPre, vcg)
                   apply clarsimp
                  apply (clarsimp simp: valid_pspace'_def)
                  apply (drule spec, drule(1) mp)
                  apply (drule(1) user_word_at_cross_over [OF _ _ refl])
                  apply (simp add: field_simps msgMaxLength_def
                                   seL4_MsgLengthBits_def
                                   seL4_MsgMaxLength_def
                                   msgLengthBits_def)
                  apply (subst valid_ipc_buffer_ptr_array, simp+,
                    simp add: msg_align_bits unat_word_ariths unat_of_nat,
                    simp add: msg_align_bits unat_word_ariths unat_of_nat)+
                  apply clarsimp
                 apply simp
                apply (rule conseqPre)
                 apply (vcg exspec=lookupSlot_modifies)
                apply clarsimp
               apply (simp add: split_def)
               apply (rule hoare_pre, wp)
               apply simp
              apply (simp add: word_less_nat_alt word_bits_def)
             apply simp
            apply (rule ceqv_tuple2)
             apply ceqv
            apply ceqv
           apply (simp del: Collect_const)
           apply (rule_tac P'="{s. snd rv'=?curr s}"
                   and P="\<lambda>s. length rva = length rv
                               \<and> (\<forall>x \<in> set rva. snd x \<noteq> 0)"
                   in ccorres_from_vcg_throws)
           apply (rule allI, rule conseqPre, vcg)
           apply (clarsimp simp: returnOk_def return_def
                                 seL4_MsgExtraCapBits_def)
           apply (simp add: word_sle_def interpret_excaps_def
                            excaps_map_def)
           apply (rule conjI)
            apply (clarsimp simp: array_to_list_def)
            apply (rule takeWhile_eq, simp_all)[1]
             apply (drule_tac f="\<lambda>xs. xs ! m" in arg_cong)
             apply (clarsimp simp: split_def NULL_ptr_val[symmetric])
            apply (simp add: word_less_nat_alt min.absorb2)
           apply (clarsimp simp: array_to_list_def)
           apply (rule takeWhile_eq, simp_all)[1]
            apply (drule_tac f="\<lambda>xs. xs ! m" in arg_cong)
            apply (clarsimp simp: split_def NULL_ptr_val[symmetric])
           apply (simp add: min.absorb1 word_less_nat_alt)
          apply simp
         apply (simp add: mapME_def[symmetric] split_def
                          liftE_bindE[symmetric])
         apply (wp mapME_length mapME_set | simp)+
           apply (rule_tac Q'="\<lambda>rv. no_0_obj' and real_cte_at' rv"
                      in hoare_post_imp_R, wp lsft_real_cte)
           apply (clarsimp simp: cte_wp_at_ctes_of)
          apply (wpsimp)+
        apply (clarsimp simp: guard_is_UNIV_def
                       elim!: inl_inrE)
       apply (rule hoare_pre, (wp mapM_wp' | simp)+)
      apply (rule mapM_loadWordUser_user_words_at)
     apply simp
    apply vcg
   apply (rule conseqPre, vcg, clarsimp)
  apply clarsimp
  apply (rule conjI)
   apply (clarsimp simp add: valid_pspace'_def)
   apply (simp add: upto_enum_step_def
             split: if_split_asm)
   apply (simp add: word_size upto_enum_word field_simps wordSize_def'
               del: upt.simps)
  apply (clarsimp simp: excaps_map_def option_to_ptr_def option_to_0_def
                        valid_ipc_buffer_ptr'_def)
  done
qed

lemma interpret_excaps_empty:
  "(interpret_excaps caps = []) = (index (excaprefs_C caps) 0 = NULL)"
  by (simp add: interpret_excaps_test_null)

lemma getSlotCap_slotcap_in_mem:
  "\<lbrace>\<top>\<rbrace> getSlotCap slot \<lbrace>\<lambda>cap s. slotcap_in_mem cap slot (ctes_of s)\<rbrace>"
  apply (simp add: getSlotCap_def)
  apply (wp getCTE_wp')
  apply (clarsimp simp: cte_wp_at_ctes_of slotcap_in_mem_def)
  done

lemma lookupExtraCaps_excaps_in_mem[wp]:
  "\<lbrace>\<top>\<rbrace> lookupExtraCaps thread buffer info \<lbrace>\<lambda>rv s. excaps_in_mem rv (ctes_of s)\<rbrace>,-"
  apply (simp add: excaps_in_mem_def lookupExtraCaps_def lookupCapAndSlot_def
                   split_def)
  apply (wp mapME_set)
      apply (wpsimp wp: getSlotCap_slotcap_in_mem)+
  done

lemma doNormalTransfer_ccorres [corres]:
  "ccorres dc xfdc
    (valid_pspace' and cur_tcb' and tcb_at' sender
        and tcb_at' receiver
        and K (endpoint \<noteq> Some 0)
        and (case_option \<top> valid_ipc_buffer_ptr' sendBuffer)
        and (case_option \<top> valid_ipc_buffer_ptr' receiveBuffer))
    (UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
          \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
          \<inter> \<lbrace>\<acute>sendBuffer = Ptr (option_to_0 sendBuffer)\<rbrace>
          \<inter> \<lbrace>\<acute>receiveBuffer = Ptr (option_to_0 receiveBuffer)\<rbrace>
          \<inter> \<lbrace>canGrant = to_bool \<acute>canGrant\<rbrace>
          \<inter> \<lbrace>\<acute>badge = badge\<rbrace>
          \<inter> \<lbrace>\<acute>endpoint = option_to_ptr endpoint\<rbrace>)  []
    (doNormalTransfer sender sendBuffer endpoint badge canGrant
                      receiver receiveBuffer)
    (Call doNormalTransfer_'proc)"
proof -
  note if_split[split del]
  have word_0_le_helper:
    "\<And>i :: sword32. \<lbrakk> i <s (1 << unat (scast seL4_MsgExtraCapBits :: word32)) - 1; 0 <=s i \<rbrakk>
           \<Longrightarrow> 0 <=s i + 1"
    apply (simp add: seL4_MsgExtraCapBits_def word_sle_msb_le
                                 word_sless_msb_less msb_nth)
    apply (clarsimp simp: word_eq_iff)
    apply (drule bang_is_le)
    apply unat_arith
    done

  show ?thesis
    apply (cinit lift: sender_' receiver_' sendBuffer_' receiveBuffer_'
                       canGrant_' badge_' endpoint_'
                 cong: call_ignore_cong)
     apply (clarsimp cong: call_ignore_cong simp del: dc_simp)
     apply (ctac(c_lines 2, no_vcg) add: getMessageInfo_ccorres')
       apply (rule_tac xf'=caps_' and r'="\<lambda>c c'. interpret_excaps c' = excaps_map c"
                  in ccorres_split_nothrow_novcg)
           apply (rule ccorres_if_lhs)
            apply (simp add: catch_def to_bool_def ccorres_cond_iffs)
            apply (rule ccorres_rhs_assoc)+
            apply (rule_tac xf'="\<lambda>s. (status_' s,
                                current_extra_caps_' (globals s))"
                             and ef'=fst and vf'=snd and es=errstate
                        in ccorres_split_nothrow_case_sum)
                 apply (rule ccorres_call, rule lookupExtraCaps_ccorres, simp+)
                apply (rule ceqv_tuple2, ceqv, ceqv)
               apply (simp add: ccorres_cond_iffs)
               apply (rule ccorres_from_vcg[where P=\<top> and P'=UNIV])
               apply (rule allI, rule conseqPre, vcg)
               apply (clarsimp simp: return_def)
              apply (simp add: ccorres_cond_iffs)
              apply (rule ccorres_from_vcg[where P=\<top> and P'=UNIV])
              apply (rule allI, rule conseqPre, vcg)
              apply (clarsimp simp: return_def excaps_map_def interpret_excaps_empty
                                    word_sless_def word_sle_def)
             apply wp
            apply simp
            apply (vcg exspec=lookupExtraCaps_modifies)
           apply (simp add: to_bool_def ccorres_cond_iffs)
           apply (rule ccorres_from_vcg[where P=\<top> and P'=UNIV])
           apply (rule allI, rule conseqPre, vcg)
           apply (clarsimp simp: return_def excaps_map_def interpret_excaps_empty
                                 word_sle_def word_sless_def)
          apply ceqv
         apply csymbr
         apply (ctac(no_vcg) add: copyMRs_ccorres)
          apply (ctac(no_vcg) add: transferCaps_ccorres)
           apply csymbr
           apply (ctac(c_lines 2, no_vcg) add: setMessageInfo_ccorres)
             apply ctac
            apply wp
           apply (clarsimp simp: Kernel_C.badgeRegister_def ARM_H.badgeRegister_def
                              ARM.badgeRegister_def Kernel_C.R0_def)
          apply wp
         apply simp
         apply (wp hoare_case_option_wp getMessageInfo_le3
                   getMessageInfo_msgLength lookupExtraCaps_excaps_in_mem
                   lookupExtraCaps_length
                    | simp)+
       apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem)
       apply (clarsimp simp: seL4_MessageInfo_lift_def message_info_to_H_def mask_def
                             msgLengthBits_def word_bw_assocs)
      apply (wp getMessageInfo_le3 getMessageInfo_msgLength[unfolded K_def] static_imp_wp
                  | simp)+
     apply (simp add: Collect_const_mem)
    apply (auto simp: excaps_in_mem_def valid_ipc_buffer_ptr'_def
                      option_to_0_def option_to_ptr_def
                      seL4_MessageInfo_lift_def mi_from_H_def message_info_to_H_def
               split: option.split)
    done
qed

lemma lookupIPCBuffer_not_Some_0:
  "\<lbrace>\<top>\<rbrace> lookupIPCBuffer r t \<lbrace>\<lambda>rv. K (rv \<noteq> Some 0)\<rbrace>"
  apply (simp add: lookupIPCBuffer_def ARM_H.lookupIPCBuffer_def)
  apply (wp hoare_post_taut haskell_assert_wp
    | simp add: Let_def getThreadBufferSlot_def locateSlotTCB_def
    | intro conjI impI | wpc)+
  done

lemma pageBitsForSize_2 [simp]:
  "2 \<le> pageBitsForSize sz"
  by (cases sz, auto)

lemma pbfs_msg_align_bits [simp]:
  "msg_align_bits \<le> pageBitsForSize sz"
  by (cases sz, auto simp: msg_align_bits)

lemma lookupIPCBuffer_aligned:
  "\<lbrace>valid_objs'\<rbrace> lookupIPCBuffer r t \<lbrace>\<lambda>rv. K (case_option True (\<lambda>x. is_aligned x msg_align_bits) rv)\<rbrace>"
  apply (simp add: lookupIPCBuffer_def ARM_H.lookupIPCBuffer_def
                   getThreadBufferSlot_def locateSlot_conv
                   Let_def getSlotCap_def cong: if_cong)
  apply (rule hoare_pre)
  apply (wp getCTE_wp' threadGet_wp | wpc)+
  apply clarsimp
  apply (drule (1) ctes_of_valid)
  apply (drule (1) ko_at_valid_objs', simp add: projectKOs)
  apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def valid_obj'_def valid_tcb'_def)
  apply (auto elim: aligned_add_aligned intro: is_aligned_andI1)
  done


lemma isArchPageCap_def2:
  "\<And>cap. isArchPageCap cap = (isArchObjectCap cap \<and> isPageCap (capCap cap))"
  by (fastforce simp: isCap_simps)


lemma replyFromKernel_error_ccorres [corres]:
  "ccorres dc xfdc (valid_pspace' and tcb_at' thread)
     (UNIV \<inter> \<lbrace>syscall_error_to_H \<acute>current_syscall_error
                          (lookup_fault_lift \<acute>current_lookup_fault)
                       = Some err\<rbrace>
           \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>) hs
     (replyFromKernel thread (msgFromSyscallError err))
     (Call replyFromKernel_error_'proc)"
  apply (cinit lift: thread_')
   apply clarsimp
   apply wpc
   apply (ctac add: lookupIPCBuffer_ccorres)
     apply simp
     apply ctac
       apply (ctac add: setMRs_syscall_error_ccorres[where err=err])
         apply ((rule ccorres_Guard_Seq)+)?
         apply csymbr
         apply (rule ccorres_abstract_cleanup)
         apply (fold dc_def)[1]
         apply (rule setMessageInfo_ccorres)
        apply wp
       apply (simp add: Collect_const_mem)
       apply (vcg exspec=setMRs_syscall_error_modifies)
      apply (wp hoare_case_option_wp)
     apply (vcg exspec=setRegister_modifies)
    apply simp
    apply (wp lookupIPCBuffer_aligned_option_to_0)
   apply (simp del: Collect_const)
   apply (vcg exspec=lookupIPCBuffer_modifies)
  apply (simp add: msgInfoRegister_def
                   Kernel_C.msgInfoRegister_def Kernel_C.R1_def
                   ARM_H.badgeRegister_def ARM.badgeRegister_def
                   Kernel_C.badgeRegister_def Kernel_C.R0_def
                   message_info_to_H_def valid_pspace_valid_objs')
  apply (clarsimp simp: msgLengthBits_def msgFromSyscallError_def
                        syscall_error_to_H_def syscall_error_type_defs
                        mask_def true_def option_to_ptr_def
                 split: if_split_asm)
  done

lemma fault_to_fault_tag_nonzero:
  "fault_to_fault_tag f \<noteq> 0"
  apply (case_tac f; simp add: seL4_Fault_tag_defs)
  apply (rename_tac af)
  apply (case_tac af; simp add: seL4_Fault_tag_defs)
  done

lemma doIPCTransfer_ccorres [corres]:
  "ccorres dc xfdc
    (valid_pspace' and cur_tcb' and tcb_at' sender and tcb_at' receiver
                   and K (receiver \<noteq> sender \<and> endpoint \<noteq> Some 0))
    (UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
          \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
          \<inter> \<lbrace>canGrant = to_bool \<acute>grant\<rbrace>
          \<inter> \<lbrace>\<acute>badge = badge\<rbrace>
          \<inter> \<lbrace>\<acute>endpoint = option_to_ptr endpoint\<rbrace>)  []
    (doIPCTransfer sender endpoint badge canGrant receiver)
    (Call doIPCTransfer_'proc)"
  apply (cinit lift: sender_' receiver_' grant_' badge_' endpoint_')
   apply (rule_tac xf'="\<lambda>s. ptr_coerce (receiveBuffer___ptr_to_void_' s)"
                in ccorres_split_nothrow_call_novcg)
         apply (rule lookupIPCBuffer_ccorres)
        apply simp_all[3]
     apply ceqv
    apply (rule ccorres_pre_threadGet)
    apply (rename_tac fault)
    apply (rule ccorres_move_c_guard_tcb)
    apply (rule_tac val="case_option (scast seL4_Fault_NullFault) fault_to_fault_tag fault"
                and xf'=ret__unsigned_'
                and R="\<lambda>s. \<exists>t. ko_at' t sender s \<and> tcbFault t = fault"
                 in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
       apply (vcg, clarsimp)
       apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
       apply (fastforce simp: ctcb_relation_def typ_heap_simps
                             cfault_rel_def seL4_Fault_lift_def Let_def
                      split: if_split_asm option.split)
      apply ceqv
     apply wpc
      apply (clarsimp simp: seL4_Fault_NullFault_def ccorres_cond_univ_iff)
      apply (rule_tac xf'="ptr_coerce \<circ> sendBuffer___ptr_to_void_'"
                   in ccorres_split_nothrow_call_novcg)
            apply (rule lookupIPCBuffer_ccorres)
           apply simp_all[3]
        apply ceqv
       apply (fold dc_def)[1]
       apply ctac
      apply (wp lookupIPCBuffer_not_Some_0 lookupIPCBuffer_aligned)
     apply (clarsimp simp: seL4_Fault_NullFault_def ccorres_cond_iffs
                           fault_to_fault_tag_nonzero)
     apply (fold dc_def)[1]
     apply ctac
    apply (clarsimp simp: guard_is_UNIV_def false_def option_to_ptr_def split: option.splits)
   apply (rule_tac Q="\<lambda>rv. valid_pspace' and cur_tcb' and tcb_at' sender
                       and tcb_at' receiver and K (rv \<noteq> Some 0)
                       and (case_option \<top> valid_ipc_buffer_ptr' rv)
                       and K (receiver \<noteq> sender \<and> endpoint \<noteq> Some 0)"
                in hoare_post_imp)
    apply (auto simp: valid_ipc_buffer_ptr'_def option_to_0_def
                   split: option.splits)[1]
   apply (wp lookupIPCBuffer_not_Some_0 lookupIPCBuffer_aligned)
  apply (auto simp: to_bool_def true_def)
  done

lemma fault_case_absorb_bind:
  "(do x \<leftarrow> f; case_fault (p x) (q x) (r x) (s x) ft od)
    = case_fault (\<lambda>a b. f >>= (\<lambda>x. p x a b)) (\<lambda>a b c. f >>= (\<lambda>x. q x a b c))
          (\<lambda>a. f >>= (\<lambda>x. r x a)) (\<lambda>a. f >>= (\<lambda>x. s x a)) ft"
  by (simp split: fault.split)

lemma length_exceptionMessage:
  "length ARM_H.exceptionMessage = unat n_exceptionMessage"
  by (simp add: ARM_H.exceptionMessage_def ARM.exceptionMessage_def n_exceptionMessage_def)

lemma Arch_getSanitiseRegisterInfo_ccorres:
  "ccorres (op = \<circ> from_bool) ret__unsigned_long_'
     (\<top>)
     (UNIV \<inter> {s. thread_' s = tcb_ptr_to_ctcb_ptr r}) hs
     (getSanitiseRegisterInfo r)
     (Call Arch_getSanitiseRegisterInfo_'proc)"
  apply (cinit' lift: thread_' simp: getSanitiseRegisterInfo_def)
   apply (rule ccorres_return_C, simp+)
  apply (clarsimp simp: false_def)
  done

lemma copyMRsFaultReply_ccorres_exception:
  "ccorres dc xfdc
           (valid_pspace' and tcb_at' s
                          and tcb_at' r
                          and obj_at' (\<lambda>t. tcbFault t = Some f) r
                          and K (r \<noteq> s)
                          and K (len \<le> unat n_exceptionMessage))
           (UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr s\<rbrace>
                 \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr r\<rbrace>
                 \<inter> \<lbrace>\<acute>id___anonymous_enum = MessageID_Exception \<rbrace>
                 \<inter> \<lbrace>\<acute>length___unsigned_long = of_nat len \<rbrace>) hs
           (do t \<leftarrow> getSanitiseRegisterInfo r;
               zipWithM_x (\<lambda>rs rd. do v \<leftarrow> asUser s (getRegister rs);
                                        asUser r (setRegister rd (ARM_H.sanitiseRegister t rd v))
                                        od)
               ARM_H.msgRegisters (take len ARM_H.exceptionMessage)
            od)
           (Call copyMRsFaultReply_'proc)"
proof -
  show ?thesis
    apply (unfold K_def, rule ccorres_gen_asm)
    apply (cinit' lift: sender_' receiver_'
                        id___anonymous_enum_'
                        length___unsigned_long_'
                  simp: whileAnno_def)
     apply (ctac(no_vcg) add: Arch_getSanitiseRegisterInfo_ccorres)
     apply (rule ccorres_rhs_assoc2)
     apply (simp add: MessageID_Exception_def)
     apply ccorres_rewrite
     apply (subst bind_return_unit)
     apply (rule ccorres_split_nothrow_novcg)
         apply (rule ccorres_zipWithM_x_while)
             apply clarsimp
             apply (intro ccorres_rhs_assoc)
             apply (rule ccorres_symb_exec_r)
               apply ctac
                 apply (rule ccorres_symb_exec_r)
                   apply ctac
                  apply vcg
                 apply (rule conseqPre, vcg)
                 apply fastforce
                apply wp
               apply vcg
              apply vcg
              apply (rule conjI, simp add: ARM_H.exceptionMessage_def
                                           ARM.exceptionMessage_def word_of_nat_less)
              apply (simp add: msgRegisters_ccorres n_msgRegisters_def length_msgRegisters
                               unat_of_nat exceptionMessage_ccorres[symmetric,simplified MessageID_Exception_def,simplified]
                               n_exceptionMessage_def length_exceptionMessage sanitiseRegister_def)
              apply (simp add: word_less_nat_alt unat_of_nat)
             apply (rule conseqPre, vcg)
             apply (clarsimp simp: word_of_nat_less ARM_H.exceptionMessage_def
                                   ARM.exceptionMessage_def)
            apply (simp add: min_def length_msgRegisters)
            apply (clarsimp simp: min_def n_exceptionMessage_def
                                  ARM_H.exceptionMessage_def
                                  ARM.exceptionMessage_def
                                  length_msgRegisters n_msgRegisters_def
                                  message_info_to_H_def word_of_nat_less
                           split: if_split)
            apply (fastforce dest!: le_antisym)
           apply clarsimp
           apply (vcg spec=TrueI)
           apply clarsimp
          apply wp
            apply simp+
         apply (clarsimp simp: ARM_H.exceptionMessage_def
                               ARM.exceptionMessage_def
                               word_bits_def)
         apply unat_arith
        apply ceqv
       apply (simp add: length_exceptionMessage
                        length_msgRegisters
                        n_exceptionMessage_def
                        msgMaxLength_def
                        n_msgRegisters_def
                        of_nat_less_iff)
       apply ccorres_rewrite
       apply (rule ccorres_return_Skip[simplified dc_def])
      apply (wp mapM_wp')
     apply clarsimp+
     apply (clarsimp simp: guard_is_UNIV_def message_info_to_H_def
                           Collect_const_mem
                    split: if_split)
    apply wpsimp+
    done
qed

lemma valid_drop_case: "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. P' rv s\<rbrace> \<rbrakk>
                       \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. case rv of None \<Rightarrow> True | Some x \<Rightarrow> P' rv s\<rbrace>"
   apply (simp only: valid_def Ball_def split: prod.split)
     apply (rule allI impI)+
     apply (case_tac x1)
     apply simp+
  done

lemma copyMRsFaultReply_ccorres_syscall:
  fixes word_size :: "'a::len"
  shows "ccorres dc xfdc
           (valid_pspace' and tcb_at' s
                          and tcb_at' r
                          and obj_at' (\<lambda>t. tcbFault t = Some f) r
                          and K (r \<noteq> s)
                          and K (len \<le> unat n_syscallMessage))
           (UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr s\<rbrace>
                 \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr r\<rbrace>
                 \<inter> \<lbrace>\<acute>id___anonymous_enum = MessageID_Syscall \<rbrace>
                 \<inter> \<lbrace>\<acute>length___unsigned_long = of_nat len \<rbrace>) hs
           (do t \<leftarrow> getSanitiseRegisterInfo r;
               a \<leftarrow> zipWithM_x (\<lambda>rs rd. do v \<leftarrow> asUser s (getRegister rs);
                                           asUser r (setRegister rd (ARM_H.sanitiseRegister t rd v))
                                        od)
               ARM_H.msgRegisters (take len ARM_H.syscallMessage);
               sendBuf \<leftarrow> lookupIPCBuffer False s;
               case sendBuf of None \<Rightarrow> return ()
                            | Some bufferPtr \<Rightarrow>
                                   zipWithM_x (\<lambda>i rd. do v \<leftarrow> loadWordUser (bufferPtr + i * 4);
                                                         asUser r (setRegister rd (ARM_H.sanitiseRegister t rd v))
                                                      od)
                                      [scast n_msgRegisters + 1.e.scast n_syscallMessage]
                                      (drop (unat (scast n_msgRegisters :: word32))
                                            (take len  ARM_H.syscallMessage))
            od)
           (Call copyMRsFaultReply_'proc)"
  proof -
  let ?obj_at_ft = "obj_at' (\<lambda>tcb. tcbFault tcb = Some f) s"
  note symb_exec_r_fault = ccorres_symb_exec_r_known_rv_UNIV
          [where xf'=ret__unsigned_' and R="?obj_at_ft" and R'=UNIV]
  show ?thesis
    apply (unfold K_def, rule ccorres_gen_asm)
    apply (cinit' lift: sender_' receiver_'
                        id___anonymous_enum_'
                        length___unsigned_long_'
                  simp: whileAnno_def)
     apply (ctac(no_vcg) add: Arch_getSanitiseRegisterInfo_ccorres)
     apply (rule ccorres_rhs_assoc2)
     apply (simp add: MessageID_Syscall_def)
     apply ccorres_rewrite
     apply (rule ccorres_split_nothrow_novcg)
         apply (rule ccorres_zipWithM_x_while)
             apply clarsimp
             apply (intro ccorres_rhs_assoc)
             apply (rule ccorres_symb_exec_r)
               apply ctac
                 apply (rule ccorres_symb_exec_r)
                   apply ctac
                  apply vcg
                 apply (rule conseqPre, vcg)
                 apply fastforce
                apply wp
               apply vcg
              apply vcg
              apply (rule conjI, simp add: ARM_H.syscallMessage_def
                                           ARM.syscallMessage_def word_of_nat_less
                                           unat_of_nat msgRegisters_ccorres n_msgRegisters_def
                                           length_msgRegisters)
              apply (simp add: msgRegisters_ccorres n_msgRegisters_def length_msgRegisters unat_of_nat
                               syscallMessage_ccorres[symmetric,simplified MessageID_Syscall_def,simplified]
                               n_syscallMessage_def length_syscallMessage sanitiseRegister_def)
              apply (simp add: word_less_nat_alt unat_of_nat)
             apply (rule conseqPre, vcg)
             apply (clarsimp simp: word_of_nat_less syscallMessage_unfold length_msgRegisters
                                   n_syscallMessage_def n_msgRegisters_def)
            apply (simp add: min_def length_msgRegisters)
            apply (clarsimp simp:   min_def n_syscallMessage_def
                                    length_msgRegisters n_msgRegisters_def
                                    length_syscallMessage
                                    message_info_to_H_def word_of_nat_less
                             split: if_split)
            apply (simp add: word_less_nat_alt unat_of_nat not_le)
           apply clarsimp
           apply (vcg spec=TrueI)
           apply clarsimp
          apply wp
            apply simp+
         apply (clarsimp simp: length_syscallMessage
                               length_msgRegisters
                               n_msgRegisters_def n_syscallMessage_def
                               word_bits_def min_def
                         split: if_split)
        apply ceqv
       apply (rule_tac P'="if 4 < len then _ else _" in ccorres_inst)
       apply (cases "4 < len" ; simp)
        apply (clarsimp simp: unat_ucast_less_no_overflow n_syscallMessage_def
                              length_syscallMessage msgRegisters_unfold
                              word_of_nat_less unat_of_nat unat_less_helper)
        apply ccorres_rewrite
        apply (ctac(no_vcg))
         apply (rename_tac sb sb')
         apply wpc
          apply (simp add: option_to_0_def ccorres_cond_iffs option_to_ptr_def)
          apply (rule ccorres_return_Skip')
            apply (rule_tac P="sb \<noteq> Some 0" in ccorres_gen_asm)
            apply (rule_tac P="case_option True (\<lambda>x. is_aligned x msg_align_bits) sb"
                            in ccorres_gen_asm)
            apply (simp add: option_to_0_def option_to_ptr_def)
            apply (subgoal_tac "sb'\<noteq> NULL") prefer 2
             apply clarsimp
            apply (simp add: ccorres_cond_iffs)
            apply (subst ccorres_seq_skip' [symmetric])
            apply (rule_tac r'="\<lambda>rv rv'. rv' = of_nat (unat  n_msgRegisters) + _" in ccorres_rel_imp)
             apply (drule_tac s="sb" in sym)
             apply (simp only: zipWithM_x_mapM_x)
             apply ccorres_rewrite
             apply (rule_tac F="\<lambda>_. valid_pspace'
                                     and (case sb of None \<Rightarrow> \<top>
                                                   | Some x \<Rightarrow> valid_ipc_buffer_ptr' x)
                                     and tcb_at' r"
                             in ccorres_mapM_x_while')
                 apply clarsimp
                 apply (rule ccorres_guard_imp2)
                  apply (rule ccorres_pre_loadWordUser)
                  apply (intro ccorres_rhs_assoc)
                  apply (rule ccorres_symb_exec_r)
                    apply (rule ccorres_move_array_assertion_ipc_buffer
                                ccorres_Guard_Seq[where S="{s. h_t_valid (htd s) c_guard (ptr s)}" for ptr htd])+
                    apply (rule ccorres_symb_exec_r)
                      apply (rule ccorres_symb_exec_r)
                        apply ctac
                       apply vcg
                      apply (rule conseqPre, vcg)
                      apply fastforce
                     apply vcg
                    apply (rule conseqPre, vcg)
                    apply clarsimp
                   apply vcg
                  apply (rule conseqPre, vcg)
                  apply clarsimp
                 apply clarsimp
                 apply (subst aligned_add_aligned, assumption)
                   apply (rule is_aligned_mult_triv2[where n=2, simplified])
                  apply (simp add: msg_align_bits)
                 apply (simp add: of_nat_unat[simplified comp_def])
                 apply (simp only: n_msgRegisters_def)
                 apply (clarsimp simp: n_syscallMessage_def n_msgRegisters_def
                                       word_unat.Rep_inverse[of "scast _ :: 'a word"]
                                       msgRegisters_ccorres[symmetric]
                                       length_msgRegisters[symmetric]
                                       syscallMessage_ccorres[symmetric]
                                       length_msgRegisters length_syscallMessage
                                       syscallMessage_ccorres[symmetric, simplified MessageID_Syscall_def, simplified]
                                       unat_of_nat32 word_bits_def
                                       MessageID_Syscall_def
                                       min_def message_info_to_H_def
                                       upto_enum_def typ_heap_simps'
                                       unat_add_lem[THEN iffD1]
                                       msg_align_bits sanitiseRegister_def
                             simp del: upt_rec_numeral,
                        simp_all add: word_less_nat_alt unat_add_lem[THEN iffD1] unat_of_nat)[1]
                apply (clarsimp simp: n_syscallMessage_def n_msgRegisters_def
                                      msgRegisters_ccorres
                                      syscallMessage_ccorres
                                      length_syscallMessage length_msgRegisters
                                      message_info_to_H_def min_def
                               split: if_split)
                apply (fastforce dest!: le_antisym)
               apply (vcg spec=TrueI)
               apply clarsimp
              apply (simp add: split_def)
              apply (wp hoare_case_option_wp)
              apply (fastforce elim: aligned_add_aligned
                               intro: is_aligned_mult_triv2 [where n=2,simplified]
                               simp: word_bits_def msg_align_bits)
             apply (clarsimp simp: msgRegisters_unfold
                                   n_msgRegisters_def
                                   word_bits_def not_less)
             apply (simp add: n_syscallMessage_def)
            apply simp
        apply (subst option.split[symmetric,where P=id, simplified])
        apply (rule valid_drop_case)
        apply (wp hoare_drop_imps hoare_vcg_all_lift lookupIPCBuffer_aligned[simplified K_def]
                  lookupIPCBuffer_not_Some_0[simplified K_def])
       apply (simp add: length_syscallMessage
                        length_msgRegisters
                        n_syscallMessage_def
                        msgMaxLength_def
                        n_msgRegisters_def
                        of_nat_less_iff)
       apply (rule_tac P'="{s. i_' s = of_nat len}" in ccorres_inst)
       apply ccorres_rewrite
       apply (rule ccorres_guard_imp)
         apply (rule ccorres_symb_exec_l)
            apply (case_tac rva; clarsimp)
             apply (rule ccorres_return_Skip[simplified dc_def])+
                apply (wp mapM_x_wp_inv user_getreg_inv'
                       | clarsimp simp: zipWithM_x_mapM_x split: prod.split)+
     apply (cases  "4 < len")
      apply ((fastforce simp: guard_is_UNIV_def
                            msgRegisters_unfold
                            syscallMessage_unfold
                            n_syscallMessage_def
                            n_msgRegisters_def
                       intro: obj_tcb_at')+)[2]
    apply wpsimp+
  done
qed

lemma handleArchFaultReply_corres:
  "ccorres (\<lambda>rv rv'. rv = to_bool rv') ret__unsigned_long_'
           (valid_pspace' and tcb_at' sender
                          and tcb_at' receiver
                          and K (f = ArchFault af)
                          and K (sender \<noteq> receiver))
           (UNIV \<inter> \<lbrace> \<acute>faultType = fault_to_fault_tag f \<rbrace>
           \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
           \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>)
           hs
           (handleArchFaultReply' af sender receiver msg)
           (Call Arch_handleFaultReply_'proc)"
  apply (unfold K_def)
  apply (rule ccorres_gen_asm)+
  apply (cinit lift: faultType_' sender_' receiver_')
   apply (clarsimp simp: bind_assoc seL4_Fault_tag_defs ccorres_cond_iffs
                   split del: if_split split: arch_fault.split)
   apply (rule ccorres_symb_exec_l)
      apply (rule ccorres_stateAssert)
      apply wpc
       apply (clarsimp simp: ccorres_cond_iffs)
       apply (rule ccorres_return_C)
         apply simp+
      apply (rule ccorres_symb_exec_l)
         apply (ctac add: ccorres_return_C)
        apply (wp mapM_wp' empty_fail_loadWordUser | clarsimp simp: to_bool_def true_def)+
  done

(* MOVE *)
lemma monadic_rewrite_ccorres_assemble_nodrop:
  assumes cc: "ccorres_underlying sr G r xf ar axf (P and Q) P' hs f c"
  assumes mr: "monadic_rewrite True False Q g f"
  shows       "ccorres_underlying sr G r xf ar axf (P and Q) P' hs g c"
proof -
  have snd: "\<And>s. \<lbrakk> Q s; \<not> snd (g s) \<rbrakk> \<Longrightarrow> \<not> snd (f s)"
    using mr
    by (simp add: monadic_rewrite_def)

  have fst: "\<And>s v. \<lbrakk> Q s; \<not> snd (g s); v \<in> fst (f s) \<rbrakk> \<Longrightarrow> v \<in> fst (g s)"
    using mr
    by (auto simp add: monadic_rewrite_def)

  show ?thesis
    apply (rule ccorresI')
    apply (erule ccorresE[OF cc], (simp add: snd)+)
    apply clarsimp
    apply (rule rev_bexI[OF fst], assumption+)
    apply simp
    done
qed

schematic_goal arch_fault_to_fault_tag_range:
  "arch_fault_to_fault_tag x \<in> ?X"
  by (case_tac x, fastforce simp: seL4_Fault_VMFault_def)

lemma handleFaultReply_ccorres [corres]:
  "ccorres (\<lambda>rv rv'. rv = to_bool rv') ret__unsigned_long_'
           (valid_pspace' and obj_at' (\<lambda>t. tcbFault t = Some f) r
                          and (tcb_at' s and tcb_at' r)
                          and K (r \<noteq> s))
           (UNIV  \<inter> \<lbrace>cfault_rel (Some f)
                      (seL4_Fault_lift (h_val (hrs_mem \<acute>t_hrs)
                         (Ptr &(tcb_ptr_to_ctcb_ptr r\<rightarrow>[''tcbFault_C'']))))
                      (lookup_fault_lift (h_val (hrs_mem \<acute>t_hrs)
                         (Ptr &(tcb_ptr_to_ctcb_ptr r\<rightarrow>[''tcbLookupFailure_C'']))))\<rbrace>
                  \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr s\<rbrace>
                  \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr r\<rbrace>) hs
           (do
              tag \<leftarrow> getMessageInfo s;
              sb \<leftarrow> lookupIPCBuffer False s;
              msg \<leftarrow> getMRs s sb tag;
              handleFaultReply f r (msgLabel tag) msg
            od) (Call handleFaultReply_'proc)"
  apply (unfold K_def, rule ccorres_gen_asm)
  apply (rule monadic_rewrite_ccorres_assemble_nodrop[OF _ handleFaultReply',rotated], simp)
  apply (cinit lift: sender_' receiver_' simp: whileAnno_def)
   apply (clarsimp simp del: dc_simp)
   apply (ctac(c_lines 2) add: getMessageInfo_ccorres')
     apply (rename_tac tag tag')
     apply csymbr
     apply csymbr
     apply (rule ccorres_move_c_guard_tcb)
     apply (rule ccorres_symb_exec_r)
       apply (rule_tac val="fault_to_fault_tag f"
                   and xf'=ret__unsigned_'
                   and R="\<lambda>s. \<exists>t. ko_at' t r s \<and> tcbFault t = Some f"
                   and R'="\<lbrace>cfault_rel (Some f) (seL4_Fault_lift \<acute>fault)
                        (lookup_fault_lift (h_val (hrs_mem \<acute>t_hrs)
                           (Ptr &(tcb_ptr_to_ctcb_ptr r\<rightarrow>[''tcbLookupFailure_C'']))))\<rbrace>"
                    in ccorres_symb_exec_r_known_rv)
          apply (rule conseqPre, vcg, clarsimp)
          apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
          apply (clarsimp simp: ctcb_relation_def typ_heap_simps
                                cfault_rel_def seL4_Fault_lift_def Let_def
                         split: if_split_asm)
         apply ceqv
        apply (simp add: handleFaultReply_def fault_case_absorb_bind
                    del: Collect_const split del: if_split)
        apply wpc
           (* UserException *)
           apply (rename_tac number code)
           apply (clarsimp simp: bind_assoc seL4_Fault_tag_defs ccorres_cond_iffs
                           split del: if_split)
              apply (subst take_min_len[symmetric,where n="unat (msgLength _)"])
              apply (simp add: bind_assoc[symmetric])
              apply (ctac add: copyMRsFaultReply_ccorres_exception)
                apply (ctac add: ccorres_return_C)
               apply wp
              apply (vcg exspec=copyMRsFaultReply_modifies)
             apply (wpsimp wp: threadGet_wp)+
          (* CapFault *)
          apply (clarsimp simp: bind_assoc seL4_Fault_tag_defs ccorres_cond_iffs
                          split del: if_split)
          apply (ctac add: ccorres_return_C)
         (* UnknowSyscall *)
         apply (rename_tac number)
         apply (clarsimp simp: seL4_Fault_tag_defs ccorres_cond_iffs
                         split del: if_split)
            apply (subst take_min_len[symmetric,where n="unat (msgLength _)"])
            apply (subst take_min_len[symmetric,where n="unat (msgLength _)"])
            apply (fold bind_assoc id_def)
            apply (ctac add: copyMRsFaultReply_ccorres_syscall[simplified bind_assoc[symmetric]])
              apply (ctac add: ccorres_return_C)
             apply wp
            apply (vcg exspec=copyMRsFaultReply_modifies)
           apply (wpsimp wp: threadGet_wp)+

        (* ArchFault *)
        apply (rule ccorres_cond_false)
        apply (rule ccorres_cond_false)
        apply (rule ccorres_cond_false)
        apply (rule ccorres_rhs_assoc)
        (* apply (rule_tac P="\<lambda>s. \<exists>t. ko_at' t r s" in ccorres_cross_over_guard) *)
        apply (rule_tac val="fault_to_fault_tag f"
                   and xf'=ret__unsigned_'
                   and R="\<lambda>s. \<exists>t. ko_at' t r s \<and> tcbFault t = Some f"
                   and R'="\<lbrace>cfault_rel (Some f) (seL4_Fault_lift \<acute>fault)
                        (lookup_fault_lift (h_val (hrs_mem \<acute>t_hrs)
                           (Ptr &(tcb_ptr_to_ctcb_ptr r\<rightarrow>[''tcbLookupFailure_C'']))))\<rbrace>"
                    in ccorres_symb_exec_r_known_rv_UNIV)
           apply (rule conseqPre, vcg, clarsimp)
           apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
           apply (clarsimp simp: ctcb_relation_def typ_heap_simps
                                 cfault_rel_def seL4_Fault_lift_def Let_def
                           split: if_split_asm)
          apply ceqv
         apply (rule ccorres_add_return2)
         apply (ctac add: handleArchFaultReply_corres)
           apply (rule ccorres_return_C)
             apply simp+
          apply wp
         apply (vcg exspec=Arch_handleFaultReply_modifies)
        apply (clarsimp simp: guard_is_UNIV_def)
        apply (subst fault_to_fault_tag.simps(2))
        apply (clarsimp split: if_split)
        apply simp+
       (* Done *)
       apply clarsimp
       apply vcg
      apply vcg
     apply clarsimp
     apply vcg_step
     apply (clarsimp simp: n_exceptionMessage_def n_syscallMessage_def
                           message_info_to_H_def to_bool_def scast_def
                           length_exceptionMessage length_syscallMessage
                           min_def word_less_nat_alt true_def
                           guard_is_UNIV_def seL4_Faults seL4_Arch_Faults
                       split: if_split)
    apply (simp add: length_exceptionMessage length_syscallMessage)
    apply wp
   apply clarsimp
   apply (vcg exspec=getRegister_modifies)
  apply (clarsimp simp: n_exceptionMessage_def n_syscallMessage_def
                        message_info_to_H_def to_bool_def scast_def
                        length_exceptionMessage length_syscallMessage
                        min_def word_less_nat_alt true_def
                        obj_at'_def
                 split: if_split)
  using arch_fault_to_fault_tag_range
  apply (fastforce simp: seL4_Faults seL4_Arch_Faults)
  done

(* FIXME: move *)
lemma cancelAllIPC_sch_act_wf:
  "\<lbrace>\<lambda>s. sch_act_wf (ksSchedulerAction s) s\<rbrace>
  cancelAllIPC ep
  \<lbrace>\<lambda>rv s. sch_act_wf (ksSchedulerAction s) s\<rbrace>"
  apply (simp add: cancelAllIPC_def)
  apply (rule hoare_TrueI|wp getEndpoint_wp|wpc|simp)+
  apply fastforce?
  done

(* FIXME: move *)
lemma cancelAllSignals_sch_act_wf:
  "\<lbrace>\<lambda>s. sch_act_wf (ksSchedulerAction s) s\<rbrace>
  cancelAllSignals ep
  \<lbrace>\<lambda>rv s. sch_act_wf (ksSchedulerAction s) s\<rbrace>"
  apply (simp add: cancelAllSignals_def)
  apply (rule hoare_TrueI|wp getNotification_wp|wpc|simp)+
  apply fastforce?
  done

(* FIXME: move *)
lemma cteDeleteOne_sch_act_wf:
  "\<lbrace>\<lambda>s. sch_act_wf (ksSchedulerAction s) s\<rbrace>
  cteDeleteOne slot
  \<lbrace>\<lambda>rv s. sch_act_wf (ksSchedulerAction s) s\<rbrace>"
  apply (simp add: cteDeleteOne_def unless_when split_def)
  apply (simp add: finaliseCapTrue_standin_def Let_def)
  apply (rule hoare_pre)
  apply (wp isFinalCapability_inv cancelAllSignals_sch_act_wf
            cancelAllIPC_sch_act_wf getCTE_wp' static_imp_wp
 | wpc
                    | simp add: Let_def split: if_split)+
  done

(* FIXME: move *)
lemma vp_invs_strg': "invs' s \<longrightarrow> valid_pspace' s" by auto

(* FIXME: move *)
lemma setCTE_tcbFault:
  "\<lbrace>obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>
  setCTE slot cte
  \<lbrace>\<lambda>rv. obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>"
  apply (simp add: setCTE_def)
  apply (rule setObject_cte_obj_at_tcb', simp_all)
  done

crunch tcbFault: emptySlot, tcbSchedEnqueue, rescheduleRequired
          "obj_at' (\<lambda>tcb. P (tcbFault tcb)) t"
  (wp: threadSet_obj_at'_strongish crunch_wps
    simp: crunch_simps unless_def)

(* FIXME: move *)
lemmas threadSet_obj_at' = threadSet_obj_at'_strongish

crunch tcbFault: setThreadState, cancelAllIPC, cancelAllSignals
          "obj_at' (\<lambda>tcb. P (tcbFault tcb)) t"
  (wp: threadSet_obj_at'_strongish crunch_wps)

(* FIXME: move *)
lemmas setEndpoint_tcb = KHeap_R.setEndpoint_obj_at'_tcb

(* FIXME: move *)
lemma setNotification_tcb:
  "\<lbrace>obj_at' (\<lambda>tcb::tcb. P tcb) t\<rbrace>
  setNotification ntfn e
  \<lbrace>\<lambda>_. obj_at' P t\<rbrace>"
  apply (simp add: setNotification_def)
  apply (rule obj_at_setObject2)
  apply (clarsimp simp: updateObject_default_def in_monad)
  done

lemma sbn_tcbFault:
  "\<lbrace>obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>
  setBoundNotification st t'
  \<lbrace>\<lambda>_. obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>"
  apply (simp add: setBoundNotification_def)
  apply (wp threadSet_obj_at' | simp)+
  done

crunch tcbFault: unbindNotification, unbindMaybeNotification "obj_at' (\<lambda>tcb. P (tcbFault tcb)) t"
(ignore: threadSet setObject wp: sbn_tcbFault)

(* FIXME: move *)
lemma cteDeleteOne_tcbFault:
  "\<lbrace>obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>
  cteDeleteOne slot
  \<lbrace>\<lambda>_. obj_at' (\<lambda>tcb. P (tcbFault tcb)) t\<rbrace>"
  apply (simp add: cteDeleteOne_def unless_when split_def)
  apply (simp add: finaliseCapTrue_standin_def Let_def)
  apply (rule hoare_pre)
  apply (wp emptySlot_tcbFault cancelAllIPC_tcbFault getCTE_wp'
            cancelAllSignals_tcbFault unbindNotification_tcbFault
            isFinalCapability_inv unbindMaybeNotification_tcbFault
            static_imp_wp
          | wpc | simp add: Let_def)+
  apply (clarsimp split: if_split)
  done

lemma transferCapsToSlots_local_slots:
  assumes weak: "\<And>c cap. P (maskedAsFull c cap) = P c"
  shows
  "\<lbrace> cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot and K (slot \<notin> set destSlots) \<rbrace>
    transferCapsToSlots ep rcvBuffer x caps destSlots mi
   \<lbrace>\<lambda>tag'. cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot\<rbrace>"
proof (rule hoare_gen_asm, induct caps arbitrary: x mi destSlots)
  case Nil show ?case by simp
next
  case (Cons cp cps)
  show ?case using Cons.prems
    apply (clarsimp simp: Let_def split del: if_split)
    apply (rule hoare_pre)
     apply (wp Cons.hyps cteInsert_weak_cte_wp_at2
         | wpc | simp add: weak whenE_def split del: if_split)+
    done
qed

lemma transferCaps_local_slots:
  assumes weak: "\<And>c cap. P (maskedAsFull c cap) = P c"
  shows "\<lbrace> valid_objs' and (Not o real_cte_at' slot) and cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot \<rbrace>
    transferCaps tag caps ep receiver receiveBuffer
   \<lbrace>\<lambda>tag'. cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot\<rbrace>"
  apply (simp add: transferCaps_def pred_conj_def)
  apply (rule hoare_seq_ext[rotated])
   apply (rule hoare_vcg_conj_lift)
    apply (rule get_rs_real_cte_at')
   apply (rule get_recv_slot_inv')
  apply (rule hoare_pre)
   apply (wp transferCapsToSlots_local_slots weak | wpc)+
  apply clarsimp
  done

lemma doNormalTransfer_local_slots:
  assumes weak: "\<And>c cap. P (maskedAsFull c cap) = P c"
  shows "\<lbrace> valid_objs' and (Not o real_cte_at' slot)
        and cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot \<rbrace>
    doNormalTransfer sender sendBuffer ep badge grant receiver receiveBuffer
   \<lbrace>\<lambda>rv. cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot\<rbrace>"
  apply (simp add: doNormalTransfer_def)
  apply (wp transferCaps_local_slots weak copyMRs_typ_at'[where T=CTET, unfolded typ_at_cte]
    | simp)+
  done

lemma doIPCTransfer_local_slots:
  assumes weak: "\<And>c cap. P (maskedAsFull c cap) = P c"
  shows "\<lbrace> valid_objs' and (Not o real_cte_at' slot)
        and cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot \<rbrace>
    doIPCTransfer sender ep badge grant receiver
    \<lbrace> \<lambda>rv. cte_wp_at' (\<lambda>cte. P (cteCap cte)) slot \<rbrace>"
  apply (simp add: doIPCTransfer_def)
  apply (wp doNormalTransfer_local_slots weak threadGet_wp | wpc)+
  apply simp
  done

lemma doIPCTransfer_reply_or_replyslot:
  "\<lbrace> cte_wp_at' (\<lambda>cte. isReplyCap (cteCap cte)) slot
      or (valid_objs' and (Not o real_cte_at' slot)
          and  cte_wp_at' (\<lambda>cte. cteCap cte = capability.NullCap \<or> isReplyCap (cteCap cte)) slot)\<rbrace>
    doIPCTransfer sender ep badge grant receiver
    \<lbrace> \<lambda>rv. cte_wp_at' (\<lambda>cte. cteCap cte = capability.NullCap \<or> isReplyCap (cteCap cte)) slot\<rbrace>"
  apply (rule hoare_name_pre_state)
  apply (case_tac "cte_wp_at' (\<lambda>cte. isReplyCap (cteCap cte)) slot s")
   apply (rule hoare_pre, rule hoare_strengthen_post,
        rule_tac P="isReplyCap" and ptr=slot in doIPCTransfer_non_null_cte_wp_at2')
      apply (clarsimp simp: isCap_simps)
     apply (clarsimp simp: isCap_simps)
    apply (clarsimp simp: cte_wp_at_ctes_of)
   apply simp
  apply (wp doIPCTransfer_local_slots)
   apply (clarsimp simp: maskedAsFull_def cap_get_tag_isCap isCap_simps
                  split: if_split)
  apply simp
  done

lemma doReplyTransfer_ccorres [corres]:
  "ccorres dc xfdc
    (invs' and st_tcb_at' (Not \<circ> isReply) sender
        and tcb_at' receiver and sch_act_simple
        and ((Not o real_cte_at' slot) or cte_wp_at' (\<lambda>cte. isReplyCap (cteCap cte)) slot)
        and cte_wp_at' (\<lambda>cte. cteCap cte = capability.NullCap \<or> isReplyCap (cteCap cte))
         slot)
    (UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
          \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>
          \<inter> \<lbrace>\<acute>slot = Ptr slot\<rbrace>)  []
    (doReplyTransfer sender receiver slot)
    (Call doReplyTransfer_'proc)"
proof -
  have invs_valid_queues_strg: "\<And>s. invs' s \<longrightarrow> valid_queues s"
    by clarsimp
  show ?thesis
  apply (cinit lift: sender_' receiver_' slot_')
   apply (rule getThreadState_ccorres_foo)
   apply (rule ccorres_assert2)
   apply (simp add: liftM_def getSlotCap_def
               del: Collect_const split del: if_split)
   apply (rule ccorres_pre_getCTE)
   apply (rule ccorres_assert2)
   apply (rule ccorres_pre_getCTE)
   apply (rule ccorres_assert2)
   apply (rule ccorres_pre_threadGet)
   apply (rename_tac fault)
   apply (rule ccorres_move_c_guard_tcb)
   apply (rule_tac val="case_option (scast seL4_Fault_NullFault) fault_to_fault_tag fault"
               and xf'=ret__unsigned_'
               and R="\<lambda>s. \<exists>t. ko_at' t receiver s \<and> tcbFault t = fault"
                in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
      apply (vcg, clarsimp)
      apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
      apply (fastforce simp: ctcb_relation_def typ_heap_simps
                            cfault_rel_def seL4_Fault_lift_def Let_def
                     split: if_split_asm option.split)
     apply ceqv
    apply wpc
     apply (clarsimp simp: ccorres_cond_iffs split del: if_split)
     apply (fold dc_def)[1]
     apply (rule ccorres_rhs_assoc)+
     apply (ctac(no_vcg))
      apply (rule ccorres_symb_exec_r)
        apply (ctac(no_vcg) add: cteDeleteOne_ccorres[where w="scast cap_reply_cap"])
         apply (ctac(no_vcg) add: setThreadState_ccorres)
          apply (ctac add: attemptSwitchTo_ccorres)
         apply (wp sts_running_valid_queues setThreadState_st_tcb | simp)+
        apply (wp cteDeleteOne_sch_act_wf)
       apply vcg
      apply (rule conseqPre, vcg)
      apply (simp(no_asm_use) add: gs_set_assn_Delete_cstate_relation[unfolded o_def]
                                   subset_iff rf_sr_def)
     apply wp
     apply (simp add: cap_get_tag_isCap)
     apply (strengthen invs_weak_sch_act_wf_strg
                       cte_wp_at_imp_consequent'[where P="\<lambda>ct. Ex (ccap_relation (cteCap ct))" for ct]
                       invs_valid_queues_strg)
     apply (simp add: cap_reply_cap_def)
     apply (wp doIPCTransfer_reply_or_replyslot)
    apply (clarsimp simp: seL4_Fault_NullFault_def ccorres_cond_iffs
                          fault_to_fault_tag_nonzero
               split del: if_split)
    apply (rule ccorres_rhs_assoc)+
    apply (fold dc_def)[1]
    apply csymbr
    apply (rule ccorres_symb_exec_r)
      apply (ctac (no_vcg) add: cteDeleteOne_ccorres[where w="scast cap_reply_cap"])
       apply (rule_tac A'=UNIV in stronger_ccorres_guard_imp)
         apply (rule ccorres_split_nothrow_novcg [OF ccorres_call,
                                                  OF handleFaultReply_ccorres,
                                                  unfolded bind_assoc,
                                                  where xf'=restart_'])
               apply simp_all[3]
            apply ceqv
           apply csymbr
           apply (rule ccorres_split_nothrow_novcg)
               apply (rule threadSet_ccorres_lemma2[where P=\<top>])
                apply vcg
               apply (clarsimp simp: typ_heap_simps')
               apply (erule(1) rf_sr_tcb_update_no_queue2,
                      (simp add: typ_heap_simps')+, simp_all?)[1]
                apply (rule ball_tcb_cte_casesI, simp+)
               apply (clarsimp simp: ctcb_relation_def
                                     seL4_Fault_lift_NullFault
                                     cfault_rel_def is_cap_fault_def
                                     cthread_state_relation_def)
               apply (case_tac "tcbState tcb", simp_all add: is_cap_fault_def)[1]
              apply ceqv
             apply (rule_tac R=\<top> in ccorres_cond2)
               apply (clarsimp simp: to_bool_def Collect_const_mem)
              apply (ctac (no_vcg))
               apply (simp only: K_bind_def)
               apply (ctac)
              apply (wp sts_running_valid_queues setThreadState_st_tcb | simp)+
             apply (fold dc_def)[1]
             apply (ctac add: setThreadState_ccorres_valid_queues'_simple)
            apply ((wp threadSet_valid_queues threadSet_sch_act threadSet_valid_queues' static_imp_wp
                       threadSet_valid_objs' threadSet_weak_sch_act_wf
                         | simp add: valid_tcb_state'_def)+)[1]
           apply (clarsimp simp: guard_is_UNIV_def ThreadState_Restart_def
                                 ThreadState_Inactive_def mask_def to_bool_def)
          apply (rule_tac Q="\<lambda>rv. valid_queues and tcb_at' receiver and valid_queues' and
                                valid_objs' and sch_act_simple and
                                (\<lambda>s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp)
           apply (clarsimp simp: inQ_def weak_sch_act_wf_def)
          apply (wp threadSet_valid_queues threadSet_sch_act handleFaultReply_sch_act_wf)
         apply (clarsimp simp: guard_is_UNIV_def)
        apply assumption
       apply clarsimp
       apply (drule_tac p=receiver in obj_at_ko_at')
       apply clarsimp
       apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
       apply (clarsimp simp: ctcb_relation_def typ_heap_simps)
      apply wp
      apply (strengthen vp_invs_strg' invs_valid_queues')
      apply (wp cteDeleteOne_tcbFault cteDeleteOne_sch_act_wf)
     apply vcg
    apply (rule conseqPre, vcg)
    apply (simp(no_asm_use) add: gs_set_assn_Delete_cstate_relation[unfolded o_def]
                                 subset_iff rf_sr_def)
   apply (clarsimp simp: guard_is_UNIV_def to_bool_def true_def
                         option_to_ptr_def option_to_0_def false_def
                         ThreadState_Running_def mask_def
                         ghost_assertion_data_get_def ghost_assertion_data_set_def
                         cap_tag_defs
                  split: option.splits)
  apply (clarsimp simp: pred_tcb_at' invs_valid_objs')
  apply (clarsimp simp: pred_tcb_at'_def obj_at'_def cte_wp_at_ctes_of
                        cap_get_tag_isCap)
  apply fastforce
  done
qed

lemma ccorres_getCTE_cte_at:
  "ccorresG rf_sr \<Gamma> r xf P P' hs (getCTE p >>= f) c
     \<Longrightarrow> ccorresG rf_sr \<Gamma> r xf (\<lambda>s. cte_at' p s \<longrightarrow> P s) P' hs
            (getCTE p >>= f) c"
  apply (rule ccorres_guard_imp)
    apply (subst gets_bind_ign[where f="cte_at' p", symmetric],
           rule ccorres_symb_exec_l[OF _ _ gets_wp])
      apply (rule_tac b=x in ccorres_case_bools)
       apply assumption
      apply (rule ccorres_getCTE)
      apply (rule ccorres_False[where P'=UNIV])
     apply wp
    apply simp
   apply (clarsimp simp: cte_wp_at_ctes_of)
  apply simp
  done

lemma setupCallerCap_ccorres [corres]:
  "ccorres dc xfdc (valid_queues and valid_pspace' and (\<lambda>s. \<forall>d p. sender \<notin> set (ksReadyQueues s (d, p)))
                    and (\<lambda>s. sch_act_wf (ksSchedulerAction s) s) and sch_act_not sender
                    and tcb_at' sender and tcb_at' receiver
                    and tcb_at' sender and tcb_at' receiver)
        (UNIV \<inter> \<lbrace>\<acute>sender = tcb_ptr_to_ctcb_ptr sender\<rbrace>
              \<inter> \<lbrace>\<acute>receiver = tcb_ptr_to_ctcb_ptr receiver\<rbrace>) hs
        (setupCallerCap sender receiver)
        (Call setupCallerCap_'proc)"
  apply (rule ccorres_gen_asm_state, rule ccorres_gen_asm_state)
  apply (frule_tac p=sender in is_aligned_tcb_ptr_to_ctcb_ptr)
  apply (cinit lift: sender_' receiver_')
   apply (clarsimp simp: word_sle_def
                         tcb_cnode_index_defs[THEN ptr_add_assertion_positive[OF ptr_add_assertion_positive_helper]]
                         , fold dc_def)[1]
   apply ccorres_remove_UNIV_guard
   apply (ctac(no_vcg))
    apply (rule ccorres_move_array_assertion_tcb_ctes)
    apply (simp only: getThreadReplySlot_def getThreadCallerSlot_def)
    apply (ctac(no_vcg))
      apply (rename_tac replySlot replySlot')
      apply (simp del: Collect_const)
      apply (rule ccorres_getCTE_cte_at)
      apply (rule ccorres_move_c_guard_cte)
      apply (ctac(no_vcg) add:  getSlotCap_h_val_ccorres[unfolded getSlotCap_def fun_app_def,
                                                         folded liftM_def, simplified ccorres_liftM_simp])
        apply (rule ccorres_assert2)+
        apply (simp add: ccorres_seq_skip locateSlot_conv
                         )
        apply (rule ccorres_move_array_assertion_tcb_ctes)
        apply csymbr
        apply (rule ccorres_getSlotCap_cte_at)
        apply (rule ccorres_move_c_guard_cte)
        apply (ctac(no_vcg))
         apply (rule ccorres_assert)
         apply (simp only: ccorres_seq_skip dc_def[symmetric])
         apply csymbr
         apply (ctac add: cteInsert_ccorres)
        apply simp
        apply (wp getSlotCap_cte_wp_at)
       apply (clarsimp simp: ccap_relation_def cap_lift_reply_cap
                             cap_to_H_simps cap_reply_cap_lift_def
                             false_def tcbSlots Kernel_C.tcbCaller_def
                             size_of_def cte_level_bits_def)
        apply (simp add: is_aligned_neg_mask)
       apply (wp getCTE_wp')
      apply (simp add: tcbSlots Kernel_C.tcbCaller_def
                       size_of_def cte_level_bits_def
                       ptr_add_assertion_positive Collect_const_mem
                       tcb_cnode_index_defs)
     apply simp
     apply (rule_tac Q="\<lambda>rv. valid_pspace' and tcb_at' receiver" in hoare_post_imp)
      apply (auto simp: cte_wp_at_ctes_of isCap_simps
                        tcbSlots Kernel_C.tcbCaller_def size_of_def
                        cte_level_bits_def)[1]
      apply (case_tac cte,clarsimp)
      apply (drule ctes_of_valid_cap')
       apply fastforce
      apply (simp add:valid_cap'_def capAligned_def)
     apply (simp add: locateSlot_conv)
     apply wp
    apply (clarsimp simp: ccap_rights_relation_def allRights_def
                          mask_def true_def cap_rights_to_H_def tcbCallerSlot_def
                          Kernel_C.tcbCaller_def)
   apply simp
   apply wp
  apply (clarsimp simp: Kernel_C.ThreadState_BlockedOnReply_def mask_def
                        valid_pspace'_def tcbReplySlot_def
                        valid_tcb_state'_def Collect_const_mem
                        tcb_cnode_index_defs)
  done

lemma sendIPC_dequeue_ccorres_helper:
  "ep_ptr = Ptr ep ==>
  ccorres (\<lambda>rv rv'. rv' = tcb_ptr_to_ctcb_ptr dest) dest_'
           (invs' and st_tcb_at' (\<lambda>st. isBlockedOnReceive st \<and>
                                       blockingObject st = ep) dest
                  and ko_at' (RecvEP (dest#rest)) ep) UNIV hs
           (setEndpoint ep $ case rest of [] \<Rightarrow> Structures_H.IdleEP
                                        | (a#list) \<Rightarrow> Structures_H.RecvEP rest)
        (\<acute>queue :== CALL ep_ptr_get_queue(ep_ptr);;
         \<acute>dest :== head_C \<acute>queue;;
         \<acute>queue :== CALL tcbEPDequeue(\<acute>dest,\<acute>queue);;
         CALL ep_ptr_set_queue(ep_ptr,\<acute>queue);;
         IF head_C \<acute>queue = Ptr 0 THEN
             CALL endpoint_ptr_set_state(ep_ptr,scast EPState_Idle)
         FI)"
  apply (rule ccorres_from_vcg)
  apply (rule allI)
  apply (rule conseqPre, vcg)
  apply (clarsimp split del: if_split simp del: comp_def)
  apply (frule ep_blocked_in_queueD [OF pred_tcb'_weakenE])
     apply simp
    apply assumption+
  apply (frule (1) ko_at_valid_ep' [OF _ invs_valid_objs'])
  apply (elim conjE)
  apply (frule (1) valid_ep_blockedD)
  apply (elim conjE)
  apply (frule cmap_relation_ep)
  apply (erule (1) cmap_relation_ko_atE)
  apply (intro conjI)
   apply (erule h_t_valid_clift)
  apply (rule impI)
  apply (rule exI)
  apply (rule conjI)
   apply (rule_tac x=\<sigma> in exI)
   apply (intro conjI)
       apply assumption+
    apply (drule (2) ep_to_ep_queue)
    apply (simp add: tcb_queue_relation'_def)
   apply (clarsimp simp: typ_heap_simps cendpoint_relation_def Let_def
              cong: imp_cong split del: if_split simp del: comp_def)
  apply (intro conjI impI allI)
     apply (fastforce simp: h_t_valid_clift)
    apply (fastforce simp: h_t_valid_clift)
   -- "empty case"
   apply clarsimp
   apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
   apply (frule iffD1 [OF tcb_queue_head_empty_iff
                          [OF tcb_queue_relation'_queue_rel]])
     apply (rule ballI, erule bspec)
     apply (erule subsetD [rotated])
     apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
    apply simp
   apply (simp add: setEndpoint_def split_def)
   apply (rule conjI)
    apply (rule bexI [OF _ setObject_eq])
        apply (simp add: rf_sr_def cstate_relation_def Let_def
                         cpspace_relation_def update_ep_map_tos
                         typ_heap_simps')
        apply (elim conjE)
        apply (intro conjI)
             -- "tcb relation"
             apply (erule ctcb_relation_null_queue_ptrs)
             apply (clarsimp simp: comp_def)
            -- "ep relation"
            apply (rule cpspace_relation_ep_update_ep, assumption+)
             apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def
                              tcb_queue_relation'_def)
            apply simp
           -- "ntfn relation"
           apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
           apply simp
           apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+)
            apply simp
           apply (erule (1) map_to_ko_atI')
          -- "queue relation"
          apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
          apply (clarsimp simp: comp_def)
         apply (simp add: carch_state_relation_def typ_heap_simps')
        apply (simp add: cmachine_state_relation_def)
       apply (simp add: h_t_valid_clift_Some_iff)
      apply (simp add: objBits_simps)
     apply (simp add: objBits_simps)
    apply assumption
   apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
  -- "non-empty case"
  apply clarsimp
  apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
  apply (frule tcb_queue_head_empty_iff [OF tcb_queue_relation'_queue_rel])
   apply (rule ballI, erule bspec)
   apply (erule subsetD [rotated])
   apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
  apply (simp add: setEndpoint_def split_def)
  apply (rule conjI)
   apply (rule bexI [OF _ setObject_eq])
       apply (frule(1) st_tcb_at_h_t_valid)
       apply (simp add: rf_sr_def cstate_relation_def Let_def
                        cpspace_relation_def update_ep_map_tos
                        typ_heap_simps')
       apply (elim conjE)
       apply (intro conjI)
             -- "tcb relation"
            apply (erule ctcb_relation_null_queue_ptrs)
            apply (clarsimp simp: comp_def)
           -- "ep relation"
           apply (rule cpspace_relation_ep_update_ep, assumption+)
            apply (clarsimp simp: cendpoint_relation_def Let_def
                                  isRecvEP_def isSendEP_def
                                  tcb_queue_relation'_def valid_ep'_def
                           split: endpoint.splits list.splits
                       split del: if_split)
            apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \<sigma>")
             apply (clarsimp simp: is_aligned_neg_mask
                            dest!: is_aligned_tcb_ptr_to_ctcb_ptr
                        split del: if_split)
            apply (clarsimp split: if_split)
           apply simp
          -- "ntfn relation"
          apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
          apply simp
          apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+)
           apply simp
          apply (erule (1) map_to_ko_atI')
         -- "queue relation"
         apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
         apply (clarsimp simp: comp_def)
        apply (simp add: carch_state_relation_def typ_heap_simps')
       apply (simp add: cmachine_state_relation_def)
      apply (simp add: h_t_valid_clift_Some_iff)
     apply (simp add: objBits_simps)
    apply (simp add: objBits_simps)
   apply assumption
  apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
  done

lemma rf_sr_tcb_update_twice:
  "h_t_valid (hrs_htd hrs) c_guard ptr
    \<Longrightarrow> ((s, s'\<lparr>globals := globals s''\<lparr>t_hrs_' :=
        hrs_mem_update (heap_update (ptr :: tcb_C ptr) v)
            (hrs_mem_update (heap_update ptr v') hrs)\<rparr>\<rparr>) \<in> rf_sr)
    = ((s, s'\<lparr>globals := globals s''\<lparr>t_hrs_' :=
        hrs_mem_update (heap_update (ptr :: tcb_C ptr) v) hrs\<rparr>\<rparr>) \<in> rf_sr)"
  by (simp add: rf_sr_def cstate_relation_def Let_def
                cpspace_relation_def typ_heap_simps'
                carch_state_relation_def
                cmachine_state_relation_def)

lemma sendIPC_block_ccorres_helper:
  "ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and
                    sch_act_not thread and ep_at' epptr and
                    (\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
                         (\<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))) and
                    K (bos = ThreadState_BlockedOnSend
                      \<and> epptr' = epptr \<and> badge' = badge
                      \<and> cg = from_bool canGrant \<and> dc' = from_bool do_call) and
                    K (epptr = epptr && ~~ mask 4) and
                    K (badge = badge && mask 28))
                   UNIV hs
           (setThreadState (Structures_H.thread_state.BlockedOnSend
                                epptr badge canGrant do_call) thread)
           (Guard C_Guard
             \<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
             (CALL thread_state_ptr_set_tsType(Ptr
              &(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']),
              scast bos));;
            Guard C_Guard
             \<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
             (CALL thread_state_ptr_set_blockingObject(Ptr
                           &(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']), epptr'));;
            Guard C_Guard
             \<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
             (CALL thread_state_ptr_set_blockingIPCBadge(Ptr
                        &(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']), badge'));;
            Guard C_Guard
             \<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
             (CALL thread_state_ptr_set_blockingIPCCanGrant(Ptr
                           &(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']), cg));;
            Guard C_Guard
             \<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
             (CALL thread_state_ptr_set_blockingIPCIsCall(Ptr
                         &(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']), dc'));;
            CALL scheduleTCB(tcb_ptr_to_ctcb_ptr thread))"
  unfolding K_def setThreadState_def
  apply (intro ccorres_gen_asm)
  apply (rule ccorres_guard_imp)
    apply (rule ccorres_split_nothrow_novcg)
        apply (rule_tac P=\<top> and P'="tcb_at' thread"
                     in threadSet_ccorres_lemma3)
         apply vcg
        apply clarsimp
        apply (frule(1) tcb_at_h_t_valid)
        apply (frule h_t_valid_c_guard)
        apply (clarsimp simp: typ_heap_simps'
                              rf_sr_tcb_update_twice)
        apply (erule(1) rf_sr_tcb_update_no_queue_gen,
          (simp add: typ_heap_simps')+)[1]
         apply (simp add: tcb_cte_cases_def)
        apply (simp add: ctcb_relation_def cthread_state_relation_def
                         ThreadState_BlockedOnSend_def mask_def
                         from_bool_def to_bool_def)
        apply (clarsimp split: bool.split)
       apply ceqv
      apply clarsimp
      apply ctac
     apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues
               threadSet_valid_objs')
    apply (clarsimp simp: guard_is_UNIV_def)
   apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def
                         tcb_cte_cases_def)
  apply clarsimp
  done

lemma tcb_queue_relation_last_not_NULL:
  assumes   tq: "tcb_queue_relation getNext getPrev mp queue qprev qhead"
  and valid_ep: "\<forall>t\<in>set queue. tcb_at' t s" "distinct queue"
  and     tcbs: "queue \<noteq> []"
  shows "tcb_ptr_to_ctcb_ptr (last queue) \<noteq> NULL"
proof -
  note last_in_set [where as = queue]

  with tq valid_ep(1) show ?thesis
    by (rule tcb_queue_relation_not_NULL') fact+
qed

lemma tcb_queue_relation_update_end:
  fixes getNext_update :: "(tcb_C ptr \<Rightarrow> tcb_C ptr) \<Rightarrow> tcb_C \<Rightarrow> tcb_C" and
  getPrev_update :: "(tcb_C ptr \<Rightarrow> tcb_C ptr) \<Rightarrow> tcb_C \<Rightarrow> tcb_C"
  assumes qr: "tcb_queue_relation getNext getPrev mp queue qprev qhead"
  and      qe: "qend = (if queue = [] then NULL
                                      else tcb_ptr_to_ctcb_ptr (last queue))"
  and     qe': "qend' \<notin> tcb_ptr_to_ctcb_ptr ` set queue"
  and  cs_tcb: "mp qend' = Some tcb"
  and valid_ep: "\<forall>t\<in>set queue. tcb_at' t s" "distinct queue"
  and     qeN: "qend' \<noteq> NULL"
  and     qpN: "queue = [] \<longrightarrow> qprev = NULL"
  and     fgN: "fg_cons getNext (getNext_update \<circ> (\<lambda>x _. x))"
  and     fgP: "fg_cons getPrev (getPrev_update \<circ> (\<lambda>x _. x))"
  and     npu: "\<And>f t. getNext (getPrev_update f t) = getNext t"
  and     pnu: "\<And>f t. getPrev (getNext_update f t) = getPrev t"
  shows   "tcb_queue_relation getNext getPrev
                 (upd_unless_null qend (getNext_update (\<lambda>_. qend') (the (mp qend)))
                       (mp(qend' := Some (getNext_update (\<lambda>_. NULL) (getPrev_update (\<lambda>_. qend)  tcb)))))
                 (queue @ [ctcb_ptr_to_tcb_ptr qend'])
                 qprev (if qhead = NULL then qend' else qhead)"
  using qr qe qe' cs_tcb valid_ep qeN qpN
proof (induct queue arbitrary: qhead qprev qend)
  case Nil
  thus ?case
    by (clarsimp simp: upd_unless_null_def fg_consD1 [OF fgN]
                       fg_consD1 [OF fgP] pnu npu)
next
  case (Cons tcb' tcbs)
  have not_NULL[simplified]: "tcb_ptr_to_ctcb_ptr (last (tcb'#tcbs)) \<noteq> NULL"
                             "qhead \<noteq> NULL"
    using tcb_queue_relation_next_not_NULL tcb_queue_relation_last_not_NULL
          Cons tcb_at_not_NULL
    by (auto split: if_split)
  thus ?case using Cons.prems
    apply (clarsimp simp: upd_unless_null_def fg_consD1 [OF fgN]
                          fg_consD1 [OF fgP] pnu npu
                   split: if_split)
    apply (rule conjI, clarsimp)
    apply (rule impI)
    apply (subst tcb_queue_relation_cong)
        prefer 5
        apply (erule Cons.hyps [OF _ refl], simp_all add: upd_unless_null_def)
    apply (frule(3) tcb_queue_relation_next_not_NULL, simp)
    done
qed

lemma tcbEPAppend_update:
  assumes sr: "ep_queue_relation' mp queue qhead qend"
  and    qe': "qend' \<notin> tcb_ptr_to_ctcb_ptr ` set queue"
  and  cs_tcb: "mp qend' = Some tcb"
  and valid_ep: "\<forall>t\<in>set queue. tcb_at' t s" "distinct queue"
  and     qeN: "qend' \<noteq> NULL"
  shows "ep_queue_relation'
                   (upd_unless_null qend (tcbEPNext_C_update (\<lambda>_. qend') (the (mp qend)))
                (mp(qend' \<mapsto> tcb\<lparr>tcbEPPrev_C := qend, tcbEPNext_C := NULL\<rparr>)))
            (queue @ [ctcb_ptr_to_tcb_ptr qend'])
            (if qhead = NULL then qend' else qhead) qend'"
  using sr qe' cs_tcb valid_ep qeN
  apply -
  apply (erule tcb_queue_relationE')
  apply (rule tcb_queue_relationI')
   apply (erule(6) tcb_queue_relation_update_end
             [where getNext_update = tcbEPNext_C_update
                and getPrev_update = tcbEPPrev_C_update])
       apply simp_all
  done

lemma tcb_queue_relation_qend_mem':
  "\<lbrakk> tcb_queue_relation' getNext getPrev mp queue qhead qend;
  (\<forall>tcb\<in>set queue. tcb_at' tcb t) \<rbrakk>
  \<Longrightarrow> qend \<noteq> NULL \<longrightarrow> ctcb_ptr_to_tcb_ptr qend \<in> set queue"
  by (clarsimp simp: tcb_queue_head_empty_iff tcb_queue_relation'_def
              split: if_split)

lemma tcb_queue_relation_qend_valid':
  "\<lbrakk> tcb_queue_relation' getNext getPrev (cslift s') queue qhead qend;
  (s, s') \<in> rf_sr; (\<forall>tcb\<in>set queue. tcb_at' tcb s) \<rbrakk>
  \<Longrightarrow> qend \<noteq> NULL \<longrightarrow> s' \<Turnstile>\<^sub>c qend"
  apply (frule (1) tcb_queue_relation_qend_mem')
  apply clarsimp
  apply (drule (3) tcb_queue_memberD [OF tcb_queue_relation'_queue_rel])
  apply (simp add: h_t_valid_clift_Some_iff)
  done

lemma tcbEPAppend_spec:
  "\<forall>s queue. \<Gamma> \<turnstile> \<lbrace>s. \<exists>t. (t, s) \<in> rf_sr
                      \<and> (\<forall>tcb\<in>set queue. tcb_at' tcb t) \<and> distinct queue
                      \<and> tcb_at' (ctcb_ptr_to_tcb_ptr \<acute>tcb) t
                      \<and> (ctcb_ptr_to_tcb_ptr \<acute>tcb \<notin> set queue)
                      \<and> ep_queue_relation' (cslift s) queue
                          (head_C \<acute>queue) (end_C \<acute>queue)\<rbrace>
                  Call tcbEPAppend_'proc
                  {t. head_C (ret__struct_tcb_queue_C_' t) =
                       (if head_C \<^bsup>s\<^esup>queue = tcb_Ptr 0
                           then \<^bsup>s\<^esup>tcb
                           else head_C \<^bsup>s\<^esup>queue)
                   \<and> end_C (ret__struct_tcb_queue_C_' t) = \<^bsup>s\<^esup>tcb
                   \<and> ep_queue_relation' (cslift t)
                       (queue @ [ctcb_ptr_to_tcb_ptr \<^bsup>s\<^esup>tcb])
                       (head_C (ret__struct_tcb_queue_C_' t))
                       (end_C (ret__struct_tcb_queue_C_' t))
                   \<and> (cslift t |` (- tcb_ptr_to_ctcb_ptr ` set
                          ((ctcb_ptr_to_tcb_ptr \<^bsup>s\<^esup>tcb) # queue))) =
                  (cslift s |` (- tcb_ptr_to_ctcb_ptr ` set
                          ((ctcb_ptr_to_tcb_ptr \<^bsup>s\<^esup>tcb) # queue)))
                   \<and> option_map tcb_null_ep_ptrs \<circ> (cslift t) =
                       option_map tcb_null_ep_ptrs \<circ> (cslift s)
                   \<and> cslift_all_but_tcb_C t s  \<and> (hrs_htd \<^bsup>t\<^esup>t_hrs) = (hrs_htd \<^bsup>s\<^esup>t_hrs)
                   \<and> (\<forall>rs. zero_ranges_are_zero rs (\<^bsup>s\<^esup>t_hrs)
                       \<longrightarrow> zero_ranges_are_zero rs (\<^bsup>t\<^esup>t_hrs))}"
  apply (intro allI)
  apply (rule conseqPre, vcg)
  apply (clarsimp split del: if_split)
  apply (frule obj_at_ko_at')
  apply clarsimp
  apply (frule cmap_relation_tcb)
  apply (drule (1) cmap_relation_ko_atD)
  apply clarsimp
  apply (frule c_guard_clift)
  apply (frule (1) tcb_queue'_head_end_NULL)
  apply (frule (1) tcb_queue_relation_qend_mem')
  apply (frule (2) tcb_queue_relation_qend_valid')
  apply (subgoal_tac "end_C (queue_' x) \<noteq> tcb_' x")
   prefer 2
   apply clarsimp
  apply (frule tcbEPAppend_update)
       apply (erule contrapos_nn, erule tcb_ptr_to_ctcb_ptr_imageD)
      apply assumption+
   apply (drule tcb_at_not_NULL, simp)
  apply (unfold upd_unless_null_def)
  apply (clarsimp split: if_split_asm)
   apply (simp add: typ_heap_simps')
   apply (rule ext)
   apply (clarsimp simp add: typ_heap_simps tcb_null_ep_ptrs_def
                      split: if_split)
  apply (simp add: typ_heap_simps')
  apply (intro conjI)
    apply (clarsimp simp add: typ_heap_simps h_t_valid_clift_Some_iff)
    apply (erule iffD1 [OF tcb_queue_relation'_cong, OF refl refl refl, rotated -1])
    apply (clarsimp split: if_split)
   apply (rule ext)
   apply (clarsimp dest!: ctcb_ptr_to_tcb_ptr_imageI simp add: typ_heap_simps h_t_valid_clift_Some_iff)
  apply (rule ext)
  apply (clarsimp simp add: tcb_null_ep_ptrs_def typ_heap_simps h_t_valid_clift_Some_iff
                   split: if_split)
  done

(* FIXME: move up to SR_lemmas_C and remove from Retype_C *)
lemma map_to_ko_atI2:
  "\<lbrakk>(projectKO_opt \<circ>\<^sub>m (ksPSpace s)) x = Some v; pspace_aligned' s; pspace_distinct' s\<rbrakk> \<Longrightarrow> ko_at' v x s"
  apply (clarsimp simp: map_comp_Some_iff)
  apply (erule (2) aligned_distinct_obj_atI')
  apply (simp add: project_inject)
  done

lemma map_to_ko_at_updI':
  "\<And>x x' y y' y''.
   \<lbrakk> (projectKO_opt \<circ>\<^sub>m (ksPSpace s)) x = Some y;
     valid_pspace' s; ko_at' y' x' s;
     objBitsKO (injectKO y') = objBitsKO y''; x \<noteq> x' \<rbrakk> \<Longrightarrow>
   ko_at' y x (s\<lparr>ksPSpace := ksPSpace s(x' \<mapsto> y'')\<rparr>)"
  by (fastforce simp: obj_at'_def projectKOs objBitsKO_def ps_clear_upd
               dest: map_to_ko_atI2)

(* FIXME: move *)
lemma state_refs_of'_upd:
  "\<lbrakk> valid_pspace' s; ko_wp_at' (\<lambda>ko. objBitsKO ko = objBitsKO ko') ptr s \<rbrakk> \<Longrightarrow>
   state_refs_of' (s\<lparr>ksPSpace := ksPSpace s(ptr \<mapsto> ko')\<rparr>) =
   (state_refs_of' s)(ptr := refs_of' ko')"
  apply (rule ext)
  apply (clarsimp simp: ps_clear_upd valid_pspace'_def pspace_aligned'_def
                        obj_at'_def ko_wp_at'_def state_refs_of'_def
                 split: option.split if_split)
  done

lemma sendIPC_enqueue_ccorres_helper:
  "ccorres dc xfdc (valid_pspace'
                and (\<lambda>s. sym_refs ((state_refs_of' s)(epptr := set queue \<times> {EPSend})))
                and st_tcb_at'  (\<lambda>st. isBlockedOnSend st \<and>
                                      blockingObject st = epptr) thread
                and ko_at' (ep::Structures_H.endpoint) epptr
                and K ((ep = IdleEP \<and> queue = [thread]) \<or>
                       (\<exists>q. ep = SendEP q \<and> thread \<notin> set q \<and>
                            queue = q @ [thread])))
           UNIV hs
           (setEndpoint epptr (Structures_H.endpoint.SendEP queue))
           (\<acute>queue :== CALL ep_ptr_get_queue(ep_Ptr epptr);;
            (\<acute>queue :== CALL tcbEPAppend(tcb_ptr_to_ctcb_ptr thread,\<acute>queue);;
             (CALL endpoint_ptr_set_state(ep_Ptr epptr, scast EPState_Send);;
              CALL ep_ptr_set_queue(ep_Ptr epptr,\<acute>queue))))"
  unfolding K_def
  apply (rule ccorres_gen_asm)
  apply (rule ccorres_from_vcg)
  apply (rule allI, rule conseqPre, vcg)
  apply (clarsimp split del: if_split simp del: comp_def)
  apply (frule cmap_relation_ep)
  apply (erule (1) cmap_relation_ko_atE)
  apply (rule conjI)
   apply (erule h_t_valid_clift)
  apply (frule(1) st_tcb_at_h_t_valid)
  apply (frule pred_tcb_at')
  apply (rule impI)
  apply (rule_tac x="init queue" in exI)
  apply (frule(1) ko_at_valid_ep' [OF _ valid_pspace_valid_objs'])
  apply (frule is_aligned_tcb_ptr_to_ctcb_ptr)
  apply (rule conjI)
   apply (rule_tac x=\<sigma> in exI)
   apply (simp add: cendpoint_relation_def Let_def)
   apply (case_tac ep, simp_all add: init_def valid_ep'_def)[1]
  apply (subgoal_tac "sym_refs (state_refs_of' (\<sigma>\<lparr>ksPSpace :=
                          ksPSpace \<sigma>(epptr \<mapsto> KOEndpoint (SendEP queue))\<rparr>))")
   prefer 2
   apply (clarsimp simp: state_refs_of'_upd ko_wp_at'_def
                         obj_at'_def projectKOs objBitsKO_def)
  apply (subgoal_tac "ko_at' (SendEP queue) epptr (\<sigma>\<lparr>ksPSpace :=
                          ksPSpace \<sigma>(epptr \<mapsto> KOEndpoint (SendEP queue))\<rparr>)")
   prefer 2
   apply (clarsimp simp: obj_at'_def projectKOs objBitsKO_def ps_clear_upd)
  apply (intro conjI impI allI)
    apply (fastforce simp: h_t_valid_clift)
   apply (fastforce simp: h_t_valid_clift)
  apply (case_tac ep, simp_all add: EPState_Idle_def EPState_Send_def)[1]
   -- "IdleEP case"
   apply clarsimp
   apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
   apply (simp add: setEndpoint_def split_def)
   apply (rule bexI [OF _ setObject_eq])
       apply (simp add: rf_sr_def cstate_relation_def init_def Let_def
                        cpspace_relation_def update_ep_map_tos
                        typ_heap_simps')
       apply (elim conjE)
       apply (intro conjI)
            -- "tcb relation"
            apply (erule ctcb_relation_null_queue_ptrs)
            apply (clarsimp simp: comp_def)
           -- "ep relation"
           apply (rule cpspace_relation_ep_update_ep', assumption+)
            apply (clarsimp simp: cendpoint_relation_def Let_def
                                  mask_def [where n=2] EPState_Send_def)
            apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask)
           apply (simp add: isSendEP_def isRecvEP_def)
          -- "ntfn relation"
          apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
          apply simp
          apply (rule cnotification_relation_ep_queue, assumption+)
            apply (simp add: isSendEP_def isRecvEP_def)
           apply simp
          apply (frule_tac x=p in map_to_ko_atI2, clarsimp, clarsimp)
          apply (erule(2) map_to_ko_at_updI')
           apply (simp only:projectKOs injectKO_ep objBits_simps)
           apply clarsimp
          apply (clarsimp simp: obj_at'_def projectKOs)
         -- "queue relation"
         apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
         apply (clarsimp simp: comp_def)
        apply (simp add: carch_state_relation_def typ_heap_simps')
       apply (simp add: cmachine_state_relation_def)
      apply (simp add: typ_heap_simps')
     apply (simp add: objBits_simps)
    apply (simp add: objBits_simps)
   apply assumption
  -- "SendEP case"
  apply clarsimp
  apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
  apply (simp add: setEndpoint_def split_def)
  apply (rule bexI [OF _ setObject_eq])
      apply (simp add: rf_sr_def cstate_relation_def Let_def init_def
                       cpspace_relation_def update_ep_map_tos
                       typ_heap_simps')
      apply (elim conjE)
      apply (intro conjI)
           -- "tcb relation"
           apply (erule ctcb_relation_null_queue_ptrs)
           apply (clarsimp simp: comp_def)
          -- "ep relation"
          apply (rule cpspace_relation_ep_update_ep', assumption+)
           apply (clarsimp simp: cendpoint_relation_def Let_def
                                 mask_def [where n=2] EPState_Send_def
                          split: if_split)
           apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask
                                 valid_ep'_def
                           dest: tcb_queue_relation_next_not_NULL)
          apply (simp add: isSendEP_def isRecvEP_def)
         -- "ntfn relation"
         apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
         apply simp
         apply (rule cnotification_relation_ep_queue, assumption+)
           apply (simp add: isSendEP_def isRecvEP_def)
          apply simp
         apply (frule_tac x=p in map_to_ko_atI2, clarsimp, clarsimp)
         apply (erule(2) map_to_ko_at_updI')
          apply (clarsimp simp: objBitsKO_def)
         apply (clarsimp simp: obj_at'_def projectKOs)
        -- "queue relation"
        apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
        apply (clarsimp simp: comp_def)
       apply (simp add: carch_state_relation_def typ_heap_simps')
      apply (simp add: cmachine_state_relation_def)
     apply (simp add: h_t_valid_clift_Some_iff)
    apply (simp add: objBits_simps)
   apply (simp add: objBits_simps)
  apply assumption
  done

lemmas attemptSwitchTo_sch_act_not
    = possibleSwitchTo_sch_act_not[where b=True, folded attemptSwitchTo_def]

lemma sendIPC_ccorres [corres]:
  "ccorres dc xfdc (invs' and st_tcb_at' simple' thread
                          and sch_act_not thread and ep_at' epptr and
                          (\<lambda>s. \<forall>d p. thread \<notin> set (ksReadyQueues s (d, p))))
     (UNIV \<inter> \<lbrace>\<acute>blocking = from_bool blocking\<rbrace>
           \<inter> \<lbrace>\<acute>do_call = from_bool do_call\<rbrace>
           \<inter> \<lbrace>\<acute>badge = badge\<rbrace>
           \<inter> \<lbrace>\<acute>canGrant = from_bool canGrant\<rbrace>
           \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>
           \<inter> \<lbrace>\<acute>epptr = Ptr epptr\<rbrace>
           \<inter> \<lbrace>badge && mask 28 = badge\<rbrace>) hs
     (sendIPC blocking do_call badge canGrant thread epptr)
     (Call sendIPC_'proc)"
  unfolding K_def
  apply (rule ccorres_gen_asm2)
  apply (cinit' lift: blocking_' do_call_' badge_' canGrant_' thread_' epptr_')
   apply (unfold sendIPC_def)[1]
   apply (rule ccorres_pre_getEndpoint)
   apply (rename_tac ep)
   apply (rule_tac xf'=ret__unsigned_'
               and val="case ep of IdleEP \<Rightarrow> scast EPState_Idle
                           | RecvEP _ \<Rightarrow> scast EPState_Recv
                           | SendEP _ \<Rightarrow> scast EPState_Send"
               and R="ko_at' ep epptr"
                in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
      apply (vcg, clarsimp)
      apply (erule cmap_relationE1 [OF cmap_relation_ep])
       apply (erule ko_at_projectKO_opt)
      apply (clarsimp simp: typ_heap_simps cendpoint_relation_def Let_def
                     split: endpoint.split_asm)
     apply ceqv
    apply (rule_tac A="invs' and st_tcb_at' simple' thread
                          and sch_act_not thread and ko_at' ep epptr
                          and ep_at' epptr
                          and (\<lambda>s. \<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))"
                 in ccorres_guard_imp2 [where A'=UNIV])
     apply wpc
       -- "RecvEP case"
       apply (rule ccorres_cond_false)
       apply (rule ccorres_cond_true)
       apply (intro ccorres_rhs_assoc)
       apply (csymbr, csymbr)
       apply wpc
        apply (simp only: haskell_fail_def)
        apply (rule ccorres_fail)
       apply (rename_tac dest rest)
       apply (rule ccorres_rhs_assoc2)
       apply (rule ccorres_rhs_assoc2)
       apply (rule ccorres_rhs_assoc2)
       apply (rule ccorres_rhs_assoc2)
      apply (rule ccorres_split_nothrow_novcg)
           apply (rule_tac dest=dest in sendIPC_dequeue_ccorres_helper)
           apply simp
          apply ceqv
         apply (rename_tac dest')
         apply (simp only: K_bind_def haskell_assert_def return_bind)

         apply (rule getThreadState_ccorres_foo)
         apply (rename_tac recvState)
         apply (rule ccorres_assert)

          apply (ctac(no_vcg))
           apply (ctac(no_vcg))
            apply (ctac(no_vcg))
             apply (rule ccorres_pre_threadGet)
             apply (rename_tac fault)
             apply (clarsimp split del: if_split)
             apply wpc
              apply (clarsimp simp: from_bool_def split del: if_split)
              apply (fold dc_def)[1]
              apply (rule ccorres_symb_exec_r)
                apply (rule ccorres_cond_true_seq)
                apply (simp only: ccorres_seq_skip)
                apply (rule ccorres_cond_true)
                apply (simp only: case_bool_If Collect_const[symmetric])
                apply (rule_tac R=\<top> in ccorres_cond)
                  apply (clarsimp simp: if_1_0_0 Collect_const_mem)
                 apply (ctac add: setupCallerCap_ccorres)
                apply (ctac add: setThreadState_ccorres)
               apply vcg
              apply (rule conseqPre, vcg, clarsimp) (* do_call = False *)
             apply (clarsimp simp: from_bool_def split del: if_split)
             apply (fold dc_def)[1]
             apply (rule ccorres_symb_exec_r)
               apply (rule ccorres_cond_false_seq)
               apply (intro ccorres_rhs_assoc)
               apply (rule ccorres_move_c_guard_tcb [simplified])
               apply (rule_tac val="case_option (scast seL4_Fault_NullFault)
                                                fault_to_fault_tag fault"
                           and xf'=ret__unsigned_'
                           and R="\<lambda>s. \<exists>t. ko_at' t thread s \<and> tcbFault t = fault"
                            in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
                  apply (rule conseqPre, vcg, clarsimp)
                  apply (erule(1) cmap_relation_ko_atE[OF cmap_relation_tcb])
                  apply (fastforce simp: ctcb_relation_def typ_heap_simps
                                         cfault_rel_def seL4_Fault_lift_def Let_def
                                  split: if_split_asm option.split)
                 apply ceqv
                apply wpc
                 apply (clarsimp split del: if_split)
                 apply (rule ccorres_symb_exec_r)
                   apply (rule ccorres_cond_false)
                   apply (fold dc_def)[1]
                   apply (rule ccorres_return_Skip)
                  apply vcg
                 apply (rule conseqPre, vcg, clarsimp)
                apply (clarsimp split del: if_split)
                apply (fold dc_def)[1]
                apply (rule ccorres_symb_exec_r)
                  apply (rule ccorres_cond_true)
                  apply (simp only: case_bool_If)
                  apply (rule_tac R=\<top> in ccorres_cond)
                    apply (clarsimp simp: Collect_const_mem if_1_0_0)
                   apply (ctac add: setupCallerCap_ccorres)
                  apply (ctac add: setThreadState_ccorres)
                 apply vcg
                apply (rule conseqPre, vcg, clarsimp)
               apply (clarsimp simp: fault_to_fault_tag_nonzero seL4_Fault_NullFault_def
                                     guard_is_UNIV_def ThreadState_Inactive_def)
              apply vcg
             apply (rule conseqPre, vcg, clarsimp)

            apply (rule_tac Q="\<lambda>rv. valid_queues and valid_pspace' and valid_objs'
                                    and sch_act_not thread and tcb_at' thread
                                    and tcb_at' dest and
                                    (\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
                                    (\<forall>d p. thread \<notin> set (ksReadyQueues s (d, p))))"
                     in hoare_post_imp)
             apply (fastforce simp: weak_sch_act_wf_def valid_tcb_state'_def
                              elim: obj_at'_weakenE)
            apply (wp attemptSwitchTo_sch_act_not sts_st_tcb' hoare_vcg_all_lift
                      attemptSwitchTo_ksQ sts_valid_queues sts_ksQ')+
          apply (clarsimp simp: valid_tcb_state'_def)
          apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift)+
        apply (rule_tac Q="\<lambda>rv. valid_queues and valid_pspace' and valid_objs'
                            and valid_mdb' and tcb_at' dest and cur_tcb'
                            and tcb_at' thread and K (dest \<noteq> thread)
                            and sch_act_not thread and K (epptr \<noteq> 0)
                            and (\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
                                (\<forall>d p. thread \<notin> set (ksReadyQueues s (d, p))))"
                     in hoare_post_imp)
         apply (clarsimp simp: st_tcb_at'_def obj_at'_def is_tcb weak_sch_act_wf_def)
        apply (wp setEndpoint_ksQ hoare_vcg_all_lift set_ep_valid_objs'
                  setEndpoint_valid_mdb')+
  apply (clarsimp simp: guard_is_UNIV_def ThreadState_Inactive_def
                               ThreadState_Running_def mask_def from_bool_def
                               option_to_ptr_def option_to_0_def
                        split: bool.split_asm)

      -- "IdleEP case"
      apply (rule ccorres_cond_true)
      apply (rule ccorres_cond)
        apply (clarsimp simp: from_bool_def split: bool.split)
       -- "blocking case"
       apply (intro ccorres_rhs_assoc)
       apply csymbr
       apply (simp only:)
       -- "apply (ctac (trace, no_vcg,c_lines 6) add: sendIPC_block_ccorres_helper)"
       apply (rule ccorres_rhs_assoc2)
       apply (rule ccorres_rhs_assoc2)
       apply (rule ccorres_rhs_assoc2)
       apply (rule ccorres_rhs_assoc2)
       apply (rule ccorres_rhs_assoc2)
       apply (rule ccorres_split_nothrow_novcg)
           apply (rule sendIPC_block_ccorres_helper)
          apply ceqv
         apply (simp only: K_bind_def fun_app_def)
         apply (rule_tac ep=IdleEP in sendIPC_enqueue_ccorres_helper)
        apply (simp add: valid_ep'_def)
        apply (wp sts_st_tcb')
        apply (rule_tac Q="\<lambda>rv. ko_wp_at' (\<lambda>x. projectKO_opt x = Some IdleEP
                                  \<and> projectKO_opt x = (None::tcb option)) epptr"
                     in hoare_post_imp)
         apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs)
        apply wp
       apply (clarsimp simp: guard_is_UNIV_def)
      apply (rule ccorres_return_Skip)
     -- "SendEP case"
     apply (rule ccorres_cond_true)
     apply (rule ccorres_cond)
       apply (clarsimp simp: from_bool_def split: bool.split)
      -- "blocking case"
      apply (intro ccorres_rhs_assoc)
      apply csymbr
      -- "apply (ctac (no_vcg,c_lines 6) add: sendIPC_block_ccorres_helper)"
      apply (rule ccorres_rhs_assoc2)
      apply (rule ccorres_rhs_assoc2)
      apply (rule ccorres_rhs_assoc2)
      apply (rule ccorres_rhs_assoc2)
      apply (rule ccorres_rhs_assoc2)
      apply (rename_tac list)
      apply (rule ccorres_split_nothrow_novcg)
          apply (simp only: )
          apply (rule sendIPC_block_ccorres_helper)
         apply ceqv
        apply (simp only: K_bind_def fun_app_def)
        apply (rule_tac ep="SendEP list" in sendIPC_enqueue_ccorres_helper)
       apply (simp add: valid_ep'_def)
       apply (wp sts_st_tcb')
       apply (rule_tac Q="\<lambda>rv. ko_wp_at' (\<lambda>x. projectKO_opt x = Some (SendEP list)
                                 \<and> projectKO_opt x = (None::tcb option)) epptr
                          and K (thread \<notin> set list)"
                    in hoare_post_imp)
        apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs)
       apply wp
      apply (clarsimp simp: guard_is_UNIV_def)
     apply (rule ccorres_return_Skip)
    apply (clarsimp simp: EPState_Recv_def EPState_Send_def EPState_Idle_def
                   split: if_split)
    apply (frule(1) ko_at_valid_objs'[OF _ invs_valid_objs'])
     apply (clarsimp simp: projectKO_opt_ep split: kernel_object.split_asm)
    apply (subgoal_tac "epptr \<noteq> thread \<and> bound_tcb_at' (\<lambda>x. tcb_bound_refs' x =
                          state_refs_of' s thread) thread s \<and> (\<forall>r. (thread, r) \<notin>
                            ep_q_refs_of' ep)")
     apply (clarsimp simp: valid_obj'_def valid_ep'_def refs_of'_def
                    split: endpoint.splits)
       apply (frule(1) sym_refs_obj_atD'[OF _ invs_sym'])
       apply (clarsimp simp: st_tcb_at_refs_of_rev' isBlockedOnReceive_def)
       apply (auto split: list.splits elim!: pred_tcb'_weakenE)[1]
      apply (subgoal_tac "state_refs_of' s epptr = {}")
       apply (clarsimp simp: obj_at'_def is_aligned_neg_mask objBitsKO_def
                             projectKOs invs'_def valid_state'_def
                             st_tcb_at'_def valid_tcb_state'_def ko_wp_at'_def
                             isBlockedOnSend_def projectKO_opt_tcb
                      split: if_split_asm if_split)
       apply (rule conjI, simp, rule impI, clarsimp simp: valid_pspace_valid_objs')
       apply (erule delta_sym_refs)
        apply (clarsimp split: if_split_asm
                        dest!: symreftype_inverse')+
        apply (clarsimp simp: pred_tcb_at'_def obj_at'_def tcb_bound_refs'_def
                              projectKOs eq_sym_conv
                       dest!: symreftype_inverse'
                       split: if_split_asm)
       apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs
                             tcb_bound_refs'_def eq_sym_conv)
      apply (clarsimp simp: obj_at'_def state_refs_of'_def projectKOs)
     apply (frule(1) sym_refs_obj_atD'[OF _ invs_sym'])
     apply clarsimp
     apply (rule conjI, assumption)
     apply (clarsimp dest!: st_tcb_strg'[rule_format]
                      simp: invs'_def valid_state'_def obj_at'_def objBits_simps
                            projectKOs valid_tcb_state'_def)
     apply (rule conjI[rotated])
      apply (clarsimp simp: isBlockedOnSend_def ko_wp_at'_def obj_at'_def
                            projectKOs projectKO_opt_tcb objBits_simps)
     apply (fastforce split: if_split_asm
                       elim: delta_sym_refs
                       simp: pred_tcb_at'_def obj_at'_def projectKOs
                             tcb_bound_refs'_def eq_sym_conv symreftype_def)
    apply clarsimp
    apply (frule(1) sym_refs_obj_atD'[OF _ invs_sym'])
    apply (frule simple_st_tcb_at_state_refs_ofD')
    apply (case_tac ep, auto simp: st_tcb_at_refs_of_rev' st_tcb_at'_def
                                   obj_at'_def projectKOs)[1]
   apply (clarsimp simp: guard_is_UNIV_def)
   apply (clarsimp simp: guard_is_UNIV_def)
done

lemma receiveIPC_block_ccorres_helper:
  "ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and
                    sch_act_not thread and ep_at' epptr and
                    (\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
                     (\<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))) and
                    K (epptr = epptr && ~~ mask 4))
                   UNIV hs
           (setThreadState (Structures_H.thread_state.BlockedOnReceive
                                epptr) thread)
           (Guard C_Guard \<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
             (CALL thread_state_ptr_set_tsType(Ptr
              &(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']),
              scast ThreadState_BlockedOnReceive));;
            Guard C_Guard \<lbrace>hrs_htd \<acute>t_hrs \<Turnstile>\<^sub>t tcb_ptr_to_ctcb_ptr thread\<rbrace>
             (CALL thread_state_ptr_set_blockingObject(Ptr
                           &(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']),
              ucast (ptr_val (ep_Ptr epptr))));;
            CALL scheduleTCB(tcb_ptr_to_ctcb_ptr thread))"
  unfolding K_def setThreadState_def
  apply (intro ccorres_gen_asm)
  apply (rule ccorres_guard_imp)
    apply (rule ccorres_split_nothrow_novcg)
        apply (rule_tac P=\<top> and P'="tcb_at' thread"
                     in threadSet_ccorres_lemma3)
         apply vcg
        apply clarsimp
        apply (frule(1) tcb_at_h_t_valid)
        apply (frule h_t_valid_c_guard)
        apply (clarsimp simp: typ_heap_simps' rf_sr_tcb_update_twice)
        apply (erule(1) rf_sr_tcb_update_no_queue_gen, (simp add: typ_heap_simps)+)
         apply (simp add: tcb_cte_cases_def)
        apply (simp add: ctcb_relation_def cthread_state_relation_def
                         ThreadState_BlockedOnReceive_def mask_def
                         from_bool_def to_bool_def)
       apply ceqv
      apply clarsimp
      apply ctac
     apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs'
               threadSet_weak_sch_act_wf_runnable')
    apply (clarsimp simp: guard_is_UNIV_def)
   apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def
                         tcb_cte_cases_def)
  apply clarsimp
  done

lemma receiveIPC_enqueue_ccorres_helper:
  "ccorres dc xfdc (valid_pspace'
                and (\<lambda>s. sym_refs ((state_refs_of' s)(epptr := set queue \<times> {EPRecv})))
                and st_tcb_at'  (\<lambda>st. isBlockedOnReceive st \<and>
                                      blockingObject st = epptr) thread
                and ko_at' (ep::Structures_H.endpoint) epptr
                and K ((ep = IdleEP \<and> queue = [thread]) \<or>
                       (\<exists>q. ep = RecvEP q \<and> thread \<notin> set q \<and>
                            queue = q @ [thread])))
           UNIV hs
           (setEndpoint epptr (Structures_H.endpoint.RecvEP queue))
           (\<acute>queue :== CALL ep_ptr_get_queue(ep_Ptr epptr);;
            (\<acute>queue :== CALL tcbEPAppend(tcb_ptr_to_ctcb_ptr thread,\<acute>queue);;
             (CALL endpoint_ptr_set_state(ep_Ptr epptr, scast EPState_Recv);;
              CALL ep_ptr_set_queue(ep_Ptr epptr,\<acute>queue))))"
  unfolding K_def
  apply (rule ccorres_gen_asm)
  apply (rule ccorres_from_vcg)
  apply (rule allI, rule conseqPre, vcg)
  apply (clarsimp split del: if_split simp del: comp_def)
  apply (frule cmap_relation_ep)
  apply (erule (1) cmap_relation_ko_atE)
  apply (rule conjI)
   apply (erule h_t_valid_clift)
  apply (frule(1) st_tcb_at_h_t_valid)
  apply (frule pred_tcb_at')
  apply (rule impI)
  apply (rule_tac x="init queue" in exI)
  apply (frule(1) ko_at_valid_ep' [OF _ valid_pspace_valid_objs'])
  apply (frule is_aligned_tcb_ptr_to_ctcb_ptr)
  apply (rule conjI)
   apply (rule_tac x=\<sigma> in exI)
   apply (simp add: cendpoint_relation_def Let_def)
   apply (case_tac ep, simp_all add: init_def valid_ep'_def)[1]
  apply (subgoal_tac "sym_refs (state_refs_of' (\<sigma>\<lparr>ksPSpace :=
                          ksPSpace \<sigma>(epptr \<mapsto> KOEndpoint (RecvEP queue))\<rparr>))")
   prefer 2
   apply (clarsimp simp: state_refs_of'_upd ko_wp_at'_def
                         obj_at'_def projectKOs objBitsKO_def)
  apply (subgoal_tac "ko_at' (RecvEP queue) epptr (\<sigma>\<lparr>ksPSpace :=
                          ksPSpace \<sigma>(epptr \<mapsto> KOEndpoint (RecvEP queue))\<rparr>)")
   prefer 2
   apply (clarsimp simp: obj_at'_def projectKOs objBitsKO_def ps_clear_upd)
  apply (intro conjI impI allI)
    apply (fastforce simp: h_t_valid_clift)
   apply (fastforce simp: h_t_valid_clift)
  apply (case_tac ep, simp_all add: EPState_Idle_def EPState_Recv_def)[1]
   -- "RecvEP case"
   apply clarsimp
   apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
   apply (simp add: setEndpoint_def split_def)
   apply (rule bexI [OF _ setObject_eq])
       apply (simp add: rf_sr_def cstate_relation_def Let_def init_def
                        cpspace_relation_def update_ep_map_tos
                        typ_heap_simps')
       apply (elim conjE)
       apply (intro conjI)
             -- "tcb relation"
            apply (erule ctcb_relation_null_queue_ptrs)
            apply (clarsimp simp: comp_def)
           -- "ep relation"
           apply (rule cpspace_relation_ep_update_ep', assumption+)
            apply (clarsimp simp: cendpoint_relation_def Let_def
                                  mask_def [where n=2] EPState_Recv_def
                           split: if_split)
            apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask
                                  valid_ep'_def
                            dest: tcb_queue_relation_next_not_NULL)
           apply (simp add: isSendEP_def isRecvEP_def)
          -- "ntfn relation"
          apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
          apply simp
          apply (rule cnotification_relation_ep_queue, assumption+)
            apply (simp add: isSendEP_def isRecvEP_def)
           apply simp
          apply (frule_tac x=p in map_to_ko_atI2, clarsimp, clarsimp)
          apply (erule(2) map_to_ko_at_updI')
           apply (clarsimp simp: objBitsKO_def)
          apply (clarsimp simp: obj_at'_def projectKOs)
         -- "queue relation"
         apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
         apply (clarsimp simp: comp_def)
        apply (simp add: carch_state_relation_def typ_heap_simps')
       apply (simp add: cmachine_state_relation_def)
      apply (simp add: h_t_valid_clift_Some_iff)
     apply (simp add: objBits_simps)
    apply (simp add: objBits_simps)
   apply assumption
  -- "IdleEP case"
  apply clarsimp
  apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
  apply (simp add: setEndpoint_def split_def)
  apply (rule bexI [OF _ setObject_eq])
      apply (simp add: rf_sr_def cstate_relation_def init_def Let_def
                       cpspace_relation_def update_ep_map_tos
                       typ_heap_simps')
      apply (elim conjE)
      apply (intro conjI)
           -- "tcb relation"
           apply (erule ctcb_relation_null_queue_ptrs)
           apply (clarsimp simp: comp_def)
          -- "ep relation"
          apply (rule cpspace_relation_ep_update_ep', assumption+)
           apply (clarsimp simp: cendpoint_relation_def Let_def
                                 mask_def [where n=2] EPState_Recv_def)
           apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask)
          apply (simp add: isSendEP_def isRecvEP_def)
         -- "ntfn relation"
         apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
         apply simp
         apply (rule cnotification_relation_ep_queue, assumption+)
           apply (simp add: isSendEP_def isRecvEP_def)
          apply simp
         apply (frule_tac x=p in map_to_ko_atI2, clarsimp, clarsimp)
         apply (erule(2) map_to_ko_at_updI')
          apply (clarsimp simp: objBitsKO_def)
         apply (clarsimp simp: obj_at'_def projectKOs)
        -- "queue relation"
        apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
        apply (clarsimp simp: comp_def)
       apply (simp add: carch_state_relation_def typ_heap_simps')
      apply (simp add: cmachine_state_relation_def)
     apply (simp add: typ_heap_simps')
    apply (simp add: objBits_simps)
   apply (simp add: objBits_simps)
  apply assumption
  done

lemma receiveIPC_dequeue_ccorres_helper:
  "ccorres (\<lambda>rv rv'. rv' = tcb_ptr_to_ctcb_ptr sender) sender_'
           (invs' and st_tcb_at' (\<lambda>st. isBlockedOnSend st \<and>
                                       blockingObject st = ep) sender
                  and ko_at' (SendEP (sender#rest)) ep) UNIV hs
           (setEndpoint ep (case rest of [] \<Rightarrow> Structures_H.IdleEP
                                       | (a#list) \<Rightarrow> Structures_H.SendEP rest))
        (\<acute>queue :== CALL ep_ptr_get_queue(Ptr ep);;
         \<acute>sender :== head_C \<acute>queue;;
         \<acute>queue :== CALL tcbEPDequeue(\<acute>sender,\<acute>queue);;
         CALL ep_ptr_set_queue(Ptr ep,\<acute>queue);;
         IF head_C \<acute>queue = Ptr 0 THEN
             CALL endpoint_ptr_set_state(Ptr ep,scast EPState_Idle)
         FI)"
  apply (rule ccorres_from_vcg)
  apply (rule allI)
  apply (rule conseqPre, vcg)
  apply (clarsimp split del: if_split simp del: comp_def)
  apply (frule ep_blocked_in_queueD [OF pred_tcb'_weakenE])
     apply simp
    apply assumption+
  apply (frule (1) ko_at_valid_ep' [OF _ invs_valid_objs'])
  apply (elim conjE)
  apply (frule (1) valid_ep_blockedD)
  apply (elim conjE)
  apply (frule cmap_relation_ep)
  apply (erule (1) cmap_relation_ko_atE)
  apply (intro conjI)
   apply (erule h_t_valid_clift)
  apply (rule impI)
  apply (rule exI)
  apply (rule conjI)
   apply (rule_tac x=\<sigma> in exI)
   apply (intro conjI)
       apply assumption+
    apply (drule (2) ep_to_ep_queue)
    apply (simp add: tcb_queue_relation'_def)
   apply (clarsimp simp: typ_heap_simps cendpoint_relation_def Let_def
              cong: imp_cong split del: if_split simp del: comp_def)
  apply (intro conjI impI allI)
     apply (fastforce simp: h_t_valid_clift)
    apply (fastforce simp: h_t_valid_clift)
   -- "empty case"
   apply clarsimp
   apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
   apply (frule iffD1 [OF tcb_queue_head_empty_iff
                          [OF tcb_queue_relation'_queue_rel]])
     apply (rule ballI, erule bspec)
     apply (erule subsetD [rotated])
     apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
    apply simp
   apply (simp add: setEndpoint_def split_def)
   apply (rule conjI)
    apply (rule bexI [OF _ setObject_eq])
        apply (simp add: rf_sr_def cstate_relation_def Let_def
                         cpspace_relation_def update_ep_map_tos
                         typ_heap_simps')
        apply (elim conjE)
        apply (intro conjI)
             -- "tcb relation"
             apply (erule ctcb_relation_null_queue_ptrs)
             apply (clarsimp simp: comp_def)
            -- "ep relation"
            apply (rule cpspace_relation_ep_update_ep, assumption+)
             apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def
                              tcb_queue_relation'_def)
            apply simp
           -- "ntfn relation"
           apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
           apply simp
           apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+)
           apply simp
          apply (erule (1) map_to_ko_atI')
          -- "queue relation"
          apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
          apply (clarsimp simp: comp_def)
         apply (simp add: carch_state_relation_def typ_heap_simps')
        apply (simp add: cmachine_state_relation_def)
       apply (simp add: typ_heap_simps')
      apply (simp add: objBits_simps)
     apply (simp add: objBits_simps)
    apply assumption
   apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
  -- "non-empty case"
  apply clarsimp
  apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
  apply (frule tcb_queue_head_empty_iff [OF tcb_queue_relation'_queue_rel])
   apply (rule ballI, erule bspec)
   apply (erule subsetD [rotated])
   apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
  apply (simp add: setEndpoint_def split_def)
  apply (rule conjI)
   apply (rule bexI [OF _ setObject_eq])
       apply (frule(1) st_tcb_at_h_t_valid)
       apply (simp add: rf_sr_def cstate_relation_def Let_def
                        cpspace_relation_def update_ep_map_tos
                        typ_heap_simps')
       apply (elim conjE)
       apply (intro conjI)
            -- "tcb relation"
            apply (erule ctcb_relation_null_queue_ptrs)
            apply (clarsimp simp: comp_def)
           -- "ep relation"
           apply (rule cpspace_relation_ep_update_ep, assumption+)
            apply (clarsimp simp: cendpoint_relation_def Let_def
                                  isRecvEP_def isSendEP_def
                                  tcb_queue_relation'_def valid_ep'_def
                           split: endpoint.splits list.splits
                       split del: if_split)
            apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \<sigma>")
             apply (clarsimp simp: is_aligned_neg_mask
                            dest!: is_aligned_tcb_ptr_to_ctcb_ptr
                        split del: if_split)
            apply (clarsimp split: if_split)
           apply simp
          -- "ntfn relation"
          apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
          apply simp
          apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+)
           apply simp
          apply (erule (1) map_to_ko_atI')
         -- "queue relation"
         apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
         apply (clarsimp simp: comp_def)
        apply (simp add: carch_state_relation_def typ_heap_simps')
       apply (simp add: cmachine_state_relation_def)
      apply (simp add: typ_heap_simps')
     apply (simp add: objBits_simps)
    apply (simp add: objBits_simps)
   apply assumption
  apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def)
  done

lemmas ccorres_pre_getBoundNotification = ccorres_pre_threadGet[where f=tcbBoundNotification, folded getBoundNotification_def]

lemma completeSignal_ccorres:
  notes if_split[split del]
  shows
  "ccorres dc xfdc (invs' and tcb_at' thread)
     (UNIV \<inter> \<lbrace>\<acute>tcb = tcb_ptr_to_ctcb_ptr thread\<rbrace>
           \<inter> \<lbrace>\<acute>ntfnPtr = Ptr ntfnptr\<rbrace>) hs
     (completeSignal ntfnptr thread)
     (Call completeSignal_'proc)"
   apply (cinit lift: tcb_' ntfnPtr_')
   apply (rule_tac P="invs' and tcb_at' thread" in ccorres_gen_asm_state)
   apply clarsimp
   apply (subgoal_tac "tcb_ptr_to_ctcb_ptr thread \<noteq> NULL")
    prefer 2
    apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def
                          tcb_ptr_to_ctcb_ptr_def)
    apply (drule sum_to_zero)
    apply (clarsimp simp: obj_at'_def ctcb_offset_def projectKOs objBitsKO_def
                          is_aligned_def)
   apply clarsimp
   apply csymbr
   apply simp
   apply (rule ccorres_rhs_assoc)+
   apply (rule ccorres_pre_getNotification, rename_tac ntfn)
   apply (rule_tac xf'=ret__unsigned_'
                and val="case ntfnObj ntfn of IdleNtfn \<Rightarrow> scast NtfnState_Idle
                                  | WaitingNtfn _ \<Rightarrow> scast NtfnState_Waiting
                                  | ActiveNtfn _ \<Rightarrow> scast NtfnState_Active"
                and R="ko_at' ntfn ntfnptr"
                 in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
      apply vcg
      apply clarsimp
      apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_ntfn])
      apply (clarsimp simp: cnotification_relation_def Let_def typ_heap_simps
                     split: Structures_H.ntfn.splits)
     apply ceqv
    apply wpc
    -- "IdleNtfn case"
      apply (clarsimp simp: NtfnState_Idle_def NtfnState_Active_def)
      apply csymbr
      apply (rule ccorres_cond_false)
      apply (rule ccorres_fail)
      -- "ActiveNtfn case"
     apply (clarsimp, csymbr, rule ccorres_cond_true)
     apply (rule ccorres_rhs_assoc)+
     apply (rename_tac word)
     apply (rule_tac val=word and xf'=badge_' and R="ko_at' ntfn ntfnptr"
                   in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
        apply (vcg, clarsimp)
        apply (erule(1) cmap_relation_ko_atE[OF cmap_relation_ntfn])
        apply (clarsimp simp: cnotification_relation_def Let_def typ_heap_simps)
       apply ceqv
      apply (fold dc_def, ctac(no_vcg))
       apply (rule_tac P="invs' and ko_at' ntfn ntfnptr" and P'=UNIV in ccorres_from_vcg)
       apply (rule allI, rule conseqPre, vcg)
       apply (clarsimp)
       apply (frule(1) cmap_relation_ko_atD [OF cmap_relation_ntfn])
       apply (clarsimp simp: typ_heap_simps setNotification_def)
       apply (rule bexI [OF _ setObject_eq])
           apply (simp add: rf_sr_def cstate_relation_def Let_def update_ntfn_map_tos
                            cpspace_relation_def typ_heap_simps')
           apply (elim conjE)
           apply (intro conjI)
             apply (rule cpspace_relation_ntfn_update_ntfn, assumption+)
              apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def mask_def)
             apply simp
            apply (simp add: carch_state_relation_def typ_heap_simps')
           apply (simp add: cmachine_state_relation_def)
          apply (simp add: h_t_valid_clift_Some_iff)
         apply (simp add: objBits_simps)
        apply (simp add: objBits_simps)
       apply assumption
      apply wp
     apply (clarsimp simp: guard_is_UNIV_def ARM_H.badgeRegister_def
                           ARM.badgeRegister_def Kernel_C.badgeRegister_def
                           Kernel_C.R0_def)
    -- "WaitingNtfn case"
    apply (clarsimp simp: NtfnState_Active_def NtfnState_Waiting_def)
    apply csymbr
    apply (rule ccorres_cond_false)
    apply (rule ccorres_fail)
   apply (clarsimp simp: guard_is_UNIV_def)
  apply (clarsimp)
  done

lemma doNBRecvFailedTransfer_ccorres[corres]:
  "ccorres dc xfdc
            \<top>
            (UNIV \<inter> {s. thread_' s = tcb_ptr_to_ctcb_ptr thread})
            [] (doNBRecvFailedTransfer thread)
            (Call doNBRecvFailedTransfer_'proc)"
  apply (cinit lift: thread_')
   apply (ctac add: setRegister_ccorres)
  by (clarsimp simp: Kernel_C.badgeRegister_def ARM_H.badgeRegister_def
                        ARM.badgeRegister_def Kernel_C.R0_def)

lemma receiveIPC_ccorres [corres]:
  notes option.case_cong_weak [cong]
  shows
  "ccorres dc xfdc (invs' and st_tcb_at' simple' thread and sch_act_not thread
                          and (\<lambda>s. \<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))
                          and valid_cap' cap and K (isEndpointCap cap))
     (UNIV \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>
           \<inter> \<lbrace>ccap_relation cap \<acute>cap\<rbrace>
           \<inter> \<lbrace>\<acute>isBlocking = from_bool isBlocking\<rbrace>) hs
     (receiveIPC thread cap isBlocking)
     (Call receiveIPC_'proc)"
  unfolding K_def
  apply (rule ccorres_gen_asm)
  apply (cinit lift: thread_' cap_' isBlocking_')
   apply (rule ccorres_pre_getEndpoint)
   apply (rename_tac ep)
   apply (simp only: ccorres_seq_skip)
   apply (rule_tac xf'=ret__unsigned_'
               and val="capEPPtr cap"
               and R=\<top>
                in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
      apply vcg
      apply (clarsimp simp: cap_get_tag_isCap isCap_simps)
      apply (frule cap_get_tag_isCap_unfolded_H_cap)
      apply (simp add: cap_endpoint_cap_lift ccap_relation_def cap_to_H_def)
     apply ceqv
    apply csymbr
     apply (rule ccorres_move_c_guard_tcb)
     apply (rule_tac xf'=ntfnPtr_'
                 and r'="\<lambda>rv rv'. rv' = option_to_ptr rv \<and> rv \<noteq> Some 0"
                 in ccorres_split_nothrow_novcg)
         apply (simp add: getBoundNotification_def)
         apply (rule_tac P="no_0_obj' and valid_objs'" in threadGet_vcg_corres_P)
         apply (rule allI, rule conseqPre, vcg)
         apply clarsimp
         apply (drule obj_at_ko_at', clarsimp)
         apply (drule spec, drule(1) mp, clarsimp)
         apply (clarsimp simp: typ_heap_simps ctcb_relation_def)
         apply (drule(1) ko_at_valid_objs', simp add: projectKOs)
         apply (clarsimp simp: option_to_ptr_def option_to_0_def projectKOs
                               valid_obj'_def valid_tcb'_def)
        apply ceqv
       apply (rename_tac ntfnptr ntfnptr')
       apply (simp del: Collect_const split del: if_split cong: call_ignore_cong)
       apply (rule ccorres_rhs_assoc2)
       apply (rule_tac xf'=ret__int_'
                    and r'="\<lambda>rv rv'. (rv' = 0) = (ntfnptr = None \<or> \<not> isActive rv)"
                     in ccorres_split_nothrow_novcg)
           apply wpc
            apply (rule ccorres_from_vcg[where P=\<top> and P'=UNIV])
            apply (rule allI, rule conseqPre, vcg)
            apply (clarsimp simp: option_to_ptr_def option_to_0_def in_monad Bex_def)
           apply (rule ccorres_pre_getNotification[where f=return, simplified])
           apply (rule_tac P="\<lambda>s. ko_at' rv (the ntfnptr) s"
                      in ccorres_from_vcg[where P'=UNIV])
           apply (rule allI, rule conseqPre, vcg)
           apply (clarsimp simp: option_to_ptr_def option_to_0_def in_monad Bex_def)
           apply (erule cmap_relationE1[OF cmap_relation_ntfn])
            apply (erule ko_at_projectKO_opt)
           apply (clarsimp simp: typ_heap_simps cnotification_relation_def Let_def
                                 notification_state_defs isActive_def
                          split: Structures_H.ntfn.split_asm Structures_H.notification.splits)
          apply ceqv
         apply (rule ccorres_cond[where R=\<top>])
           apply (simp add: Collect_const_mem)
          apply (ctac add: completeSignal_ccorres[unfolded dc_def])
         apply (rule_tac xf'=ret__unsigned_'
                     and val="case ep of IdleEP \<Rightarrow> scast EPState_Idle
                             | RecvEP _ \<Rightarrow> scast EPState_Recv
                             | SendEP _ \<Rightarrow> scast EPState_Send"
                     and R="ko_at' ep (capEPPtr cap)"
                     in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
            apply (vcg, clarsimp)
            apply (erule cmap_relationE1 [OF cmap_relation_ep])
             apply (erule ko_at_projectKO_opt)
            apply (clarsimp simp: typ_heap_simps cendpoint_relation_def Let_def
                           split: endpoint.split_asm)
           apply ceqv
          apply (rule_tac A="invs' and st_tcb_at' simple' thread
                                   and sch_act_not thread
                               and (\<lambda>s. \<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))
                                   and ko_at' ep (capEPPtr cap)"
                      in ccorres_guard_imp2 [where A'=UNIV])
           apply wpc
          -- "RecvEP case"
             apply (rule ccorres_cond_true)
             apply csymbr
             apply (simp only: case_bool_If from_bool_neq_0)
             apply (rule ccorres_Cond_rhs, simp cong: Collect_cong split del: if_split)
              apply (intro ccorres_rhs_assoc)
              apply (rule ccorres_rhs_assoc2)
              apply (rule ccorres_rhs_assoc2)
              apply (rule ccorres_split_nothrow_novcg)
                  apply (simp split del: if_split)
                  apply (rule receiveIPC_block_ccorres_helper[unfolded ptr_val_def, simplified])
                 apply ceqv
                apply simp
                apply (rename_tac list NOo)
                apply (rule_tac ep="RecvEP list"
                                in receiveIPC_enqueue_ccorres_helper[simplified, unfolded dc_def])
               apply (simp add: valid_ep'_def)
               apply (wp sts_st_tcb')
               apply (rename_tac list)
               apply (rule_tac Q="\<lambda>rv. ko_wp_at' (\<lambda>x. projectKO_opt x = Some (RecvEP list)
                                                \<and> projectKO_opt x = (None::tcb option))
                                                       (capEPPtr cap)
                                    and K (thread \<notin> set list)"
                                 in hoare_post_imp)
                apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs)
               apply wp
              apply (clarsimp simp: guard_is_UNIV_def)
             apply simp
             apply (ctac add: doNBRecvFailedTransfer_ccorres[unfolded dc_def])
            -- "IdleEP case"
            apply (rule ccorres_cond_true)
            apply csymbr
            apply (simp only: case_bool_If from_bool_neq_0)
            apply (rule ccorres_Cond_rhs, simp cong: Collect_cong split del: if_split)
             apply (intro ccorres_rhs_assoc)
             apply (rule ccorres_rhs_assoc2)
             apply (rule ccorres_rhs_assoc2)
             apply (rule ccorres_split_nothrow_novcg)
                 apply (simp split del: if_split)
                 apply (rule receiveIPC_block_ccorres_helper[unfolded ptr_val_def, simplified])
                apply ceqv
               apply simp
               apply (rule_tac ep=IdleEP
                         in receiveIPC_enqueue_ccorres_helper[simplified, unfolded dc_def])
              apply (simp add: valid_ep'_def)
              apply (wp sts_st_tcb')
              apply (rule_tac Q="\<lambda>rv. ko_wp_at' (\<lambda>x. projectKO_opt x = Some IdleEP
                                   \<and> projectKO_opt x = (None::tcb option))
                                (capEPPtr cap)"
                                  in hoare_post_imp)
               apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs)
              apply wp
             apply (clarsimp simp: guard_is_UNIV_def)
            apply simp
            apply (ctac add: doNBRecvFailedTransfer_ccorres[unfolded dc_def])
           -- "SendEP case"
           apply (thin_tac "isBlockinga = from_bool P" for P)
           apply (rule ccorres_cond_false)
           apply (rule ccorres_cond_true)
           apply (intro ccorres_rhs_assoc)
           apply (csymbr, csymbr, csymbr, csymbr, csymbr)
           apply wpc
            apply (simp only: haskell_fail_def)
            apply (rule ccorres_fail)
           apply (rename_tac sender rest)
           apply (rule ccorres_rhs_assoc2)
           apply (rule ccorres_rhs_assoc2)
           apply (rule ccorres_rhs_assoc2)
           apply (rule ccorres_rhs_assoc2)
           apply (rule ccorres_split_nothrow_novcg)
               apply simp
               apply (rule_tac sender=sender in receiveIPC_dequeue_ccorres_helper[simplified])
              apply ceqv
             apply (rename_tac sender')
             apply (simp only: K_bind_def haskell_assert_def return_bind)
             apply (rule ccorres_move_c_guard_tcb)
             apply (rule getThreadState_ccorres_foo)
             apply (rename_tac sendState)
             apply (rule ccorres_assert)
             apply (rule_tac val="blockingIPCBadge sendState"
                         and xf'=badge_'
                         and R="\<lambda>s. \<exists>t. ko_at' t sender s \<and> tcbState t = sendState"
                          in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
                apply (vcg, clarsimp)
                apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
                apply (clarsimp simp: ctcb_relation_def typ_heap_simps
                                      cthread_state_relation_def word_size
                                      isSend_def thread_state_lift_def
                               split: Structures_H.thread_state.splits)
               apply ceqv
              apply (simp split del: if_split)
              apply (rule ccorres_move_c_guard_tcb)
              apply (rule_tac val="from_bool (blockingIPCCanGrant sendState)"
                          and xf'=canGrant_'
                          and R="\<lambda>s. \<exists>t. ko_at' t sender s \<and> tcbState t = sendState"
                           in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
                 apply (vcg, clarsimp)
                 apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
                 apply (clarsimp simp: ctcb_relation_def typ_heap_simps
                                       cthread_state_relation_def word_size
                                       isSend_def thread_state_lift_def
                                split: Structures_H.thread_state.splits)
                apply ceqv
               apply (ctac(no_vcg))
                apply (rule ccorres_move_c_guard_tcb)
                apply (rule_tac val="from_bool (blockingIPCIsCall sendState)"
                            and xf'=do_call_'
                            and R="\<lambda>s. \<exists>t. ko_at' t sender s \<and> tcbState t = sendState"
                             in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
                   apply (vcg, clarsimp)
                   apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
                   apply (clarsimp simp: ctcb_relation_def typ_heap_simps
                                         cthread_state_relation_def word_size
                                         isSend_def thread_state_lift_def
                                  split: Structures_H.thread_state.splits)
                  apply ceqv
                 apply (rule ccorres_pre_threadGet)
                 apply (rename_tac fault)
                 apply (clarsimp split del: if_split)
                 apply wpc
                  apply (clarsimp simp: from_bool_def split del: if_split)
                  apply (fold dc_def)[1]
                  apply (rule ccorres_symb_exec_r)
                    apply (rule ccorres_cond_true_seq)
                    apply (simp only: ccorres_seq_skip)
                    apply (rule ccorres_cond_true)
                    apply (simp only: case_bool_If)
                    apply (rule ccorres_cond)
                  apply (clarsimp simp: to_bool_def Collect_const_mem
                                 split: if_split)
                     apply ctac
                    apply ctac
                   apply vcg
                  apply (rule conseqPre, vcg)
                  apply clarsimp
                 apply (clarsimp simp: from_bool_def split del: if_split)
                 apply (fold dc_def)[1]
                 apply (rule ccorres_symb_exec_r)
                   apply (rule ccorres_cond_false_seq)
                   apply (intro ccorres_rhs_assoc)
                   apply (rule ccorres_move_c_guard_tcb [simplified])
                   apply (rule_tac val="case_option (scast seL4_Fault_NullFault)
                                                    fault_to_fault_tag fault"
                               and xf'=ret__unsigned_'
                               and R="\<lambda>s. \<exists>t. ko_at' t sender s \<and> tcbFault t = fault"
                                in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
                      apply (rule conseqPre, vcg, clarsimp)
                      apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb])
                      apply (auto simp: ctcb_relation_def typ_heap_simps
                                            cfault_rel_def seL4_Fault_lift_def Let_def
                                     split: if_split_asm option.split)[1]
                     apply ceqv
                    apply wpc
                     apply (clarsimp split del: if_split)
                     apply (fold dc_def)[1]
                     apply (rule ccorres_symb_exec_r)
                       apply (rule ccorres_cond_false)
                       apply (ctac(no_vcg))
                        apply ctac
                       apply (wp sts_st_tcb' sts_valid_queues)
                      apply vcg
                     apply (rule conseqPre, vcg, clarsimp)
                    apply (clarsimp split del: if_split)
                    apply (fold dc_def)[1]
                    apply (rule ccorres_symb_exec_r)
                      apply (rule ccorres_cond_true)
                      apply (simp only: case_bool_If)
                      apply (rule ccorres_cond)
                    apply (clarsimp simp: to_bool_def split: if_split)
                       apply ctac
                      apply ctac
                     apply vcg
                    apply (rule conseqPre, vcg, clarsimp)
                   apply (clarsimp simp: fault_to_fault_tag_nonzero seL4_Fault_NullFault_def
                                         guard_is_UNIV_def ThreadState_Inactive_def
                                         mask_def ThreadState_Running_def)
                  apply vcg
                 apply (rule conseqPre, vcg, clarsimp)
                apply (clarsimp simp: guard_is_UNIV_def ThreadState_Inactive_def)
           apply (rule_tac Q="\<lambda>rv. valid_queues and valid_pspace' and valid_objs'
                                   and st_tcb_at' (op = sendState) sender
                                   and tcb_at' thread and sch_act_not sender
                                   and (\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
                                    (\<forall>d p. sender \<notin> set (ksReadyQueues s (d, p))))"
                            in hoare_post_imp)
            apply (auto simp: sch_act_wf_weak obj_at'_def st_tcb_at'_def
                                   valid_tcb_state'_def cong: if_cong)[1] (*Long*)
               apply wp
              apply (clarsimp simp: guard_is_UNIV_def option_to_ptr_def option_to_0_def)
              apply (clarsimp simp add: to_bool_def split: if_split)
             apply (clarsimp simp: guard_is_UNIV_def)
        apply (rule_tac Q="\<lambda>rv. valid_queues and valid_pspace' and valid_objs'
                            and cur_tcb' and tcb_at' sender and tcb_at' thread
                            and sch_act_not sender and K (thread \<noteq> sender)
                            and ep_at' (capEPPtr cap)
                                and (\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
                                    (\<forall>d p. sender \<notin> set (ksReadyQueues s (d, p))))"
                         in hoare_post_imp)
             subgoal by (auto, auto simp: st_tcb_at'_def obj_at'_def)
        apply (wp hoare_vcg_all_lift set_ep_valid_objs')
           apply (clarsimp simp: guard_is_UNIV_def)
          apply (clarsimp simp: EPState_Recv_def EPState_Send_def EPState_Idle_def)
          apply (frule(1) ko_at_valid_objs' [OF _ invs_valid_objs'])
           apply (clarsimp simp: projectKO_opt_ep split: kernel_object.split_asm)
          apply (subgoal_tac "(capEPPtr cap) \<noteq> thread
                       \<and> state_refs_of' s thread = {r \<in> state_refs_of' s thread. snd r = TCBBound}")
           apply (clarsimp simp: valid_obj'_def valid_ep'_def refs_of'_def
                          split: endpoint.splits)
             apply (rename_tac list)
             apply (subgoal_tac "state_refs_of' s (capEPPtr cap) = (set list) \<times> {EPRecv}
                                 \<and> thread \<notin> (set list)")
              subgoal by (fastforce simp: obj_at'_def is_aligned_neg_mask objBitsKO_def
                                    projectKOs invs'_def valid_state'_def st_tcb_at'_def
                                valid_tcb_state'_def ko_wp_at'_def invs_valid_objs'
                                    isBlockedOnReceive_def projectKO_opt_tcb
                                    from_bool_def to_bool_def
                              elim!: delta_sym_refs
                             split: if_split_asm bool.splits) (*very long*)
             apply (frule(1) sym_refs_obj_atD' [OF _ invs_sym'])
             apply (clarsimp simp: st_tcb_at'_def ko_wp_at'_def obj_at'_def projectKOs
                            split: if_split_asm)
             apply (drule(1) bspec)+
             apply (case_tac "tcbState obj", simp_all add: tcb_bound_refs'_def)[1]
            apply (subgoal_tac "state_refs_of' s (capEPPtr cap) = {}")
             subgoal by (fastforce simp: obj_at'_def is_aligned_neg_mask objBitsKO_def
                                   projectKOs invs'_def valid_state'_def st_tcb_at'_def
                               valid_tcb_state'_def ko_wp_at'_def invs_valid_objs'
                                   isBlockedOnReceive_def projectKO_opt_tcb
                                   from_bool_def to_bool_def
                             elim: delta_sym_refs
                            split: if_split_asm bool.splits) (*very long *)
            apply (clarsimp simp: obj_at'_def state_refs_of'_def projectKOs)
           apply (frule(1) sym_refs_ko_atD' [OF _ invs_sym'])
           apply (frule invs_queues)
           apply clarsimp
           apply (rename_tac list x xa)
           apply (rule_tac P="x\<in>set list" in case_split)
            apply (clarsimp simp:st_tcb_at_refs_of_rev')
            apply (erule_tac x=x and P="\<lambda>x. st_tcb_at' P x s" for P in ballE)
             apply (drule_tac t=x in valid_queues_not_runnable'_not_ksQ)
              apply (clarsimp simp: st_tcb_at'_def obj_at'_def o_def)
             apply (subgoal_tac "sch_act_not x s")
              prefer 2
              apply (frule invs_sch_act_wf')
              apply (clarsimp simp:sch_act_wf_def)
              apply (clarsimp simp: st_tcb_at'_def obj_at'_def o_def)
             apply (clarsimp simp: obj_at'_def st_tcb_at'_def
                                   projectKOs isBlockedOnSend_def
                             split: list.split | rule conjI)+
          apply (clarsimp simp: state_refs_of'_def )
          apply (case_tac "tcbState obj", clarsimp+)[1]
         apply (clarsimp simp: guard_is_UNIV_def)+
        apply (wp getNotification_wp | wpc)+
       apply (clarsimp simp add: guard_is_UNIV_def option_to_ptr_def option_to_0_def
                          split: if_split)
      apply (wp gbn_wp' | simp add: guard_is_UNIV_def)+
  apply (auto simp:  isCap_simps valid_cap'_def)
  done

lemma sendSignal_dequeue_ccorres_helper:
  "ccorres (\<lambda>rv rv'. rv' = tcb_ptr_to_ctcb_ptr dest) dest_'
           (invs' and st_tcb_at' (op = (BlockedOnNotification ntfn)) dest
                  and ko_at' nTFN ntfn
                  and K (ntfnObj nTFN = WaitingNtfn (dest # rest))) UNIV hs
           (setNotification ntfn $ ntfnObj_update (\<lambda>_. case rest of [] \<Rightarrow> Structures_H.ntfn.IdleNtfn
                                        | (a#list) \<Rightarrow> Structures_H.ntfn.WaitingNtfn rest) nTFN)
        (\<acute>ntfn_queue :== CALL ntfn_ptr_get_queue(Ptr ntfn);;
         \<acute>dest :== head_C \<acute>ntfn_queue;;
         \<acute>ntfn_queue :== CALL tcbEPDequeue(\<acute>dest,\<acute>ntfn_queue);;
         CALL ntfn_ptr_set_queue(Ptr ntfn,\<acute>ntfn_queue);;
         IF head_C \<acute>ntfn_queue = Ptr 0 THEN
             CALL notification_ptr_set_state(Ptr ntfn,scast NtfnState_Idle)
         FI)"

  apply (rule ccorres_from_vcg)
  apply (rule allI)
  apply (rule conseqPre, vcg)
  apply (clarsimp split del: if_split simp del: comp_def)
  apply (frule (2) ntfn_blocked_in_queueD)
  apply (frule (1) ko_at_valid_ntfn' [OF _ invs_valid_objs'])
  apply (elim conjE)
  apply (frule (1) valid_ntfn_isWaitingNtfnD)
  apply (elim conjE)
  apply (frule cmap_relation_ntfn)
  apply (erule (1) cmap_relation_ko_atE)
  apply (intro conjI)
   apply (erule h_t_valid_clift)
  apply (rule impI)
  apply (rule exI)
  apply (rule conjI)
   apply (rule_tac x=\<sigma> in exI)
   apply (intro conjI)
       apply assumption+
    apply clarsimp
    apply (drule ntfn_to_ep_queue, (simp add: isWaitingNtfn_def)+)
    apply (simp add: tcb_queue_relation'_def)
   apply (clarsimp simp: typ_heap_simps cnotification_relation_def Let_def
              cong: imp_cong split del: if_split simp del: comp_def)
  apply (intro conjI impI allI)
     apply (fastforce simp: h_t_valid_clift)
    apply (fastforce simp: h_t_valid_clift)
   -- "empty case"
   apply clarsimp
   apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
   apply (frule iffD1 [OF tcb_queue_head_empty_iff
                          [OF tcb_queue_relation'_queue_rel]])
     apply (rule ballI, erule bspec)
     apply (erule subsetD [rotated])
     apply (clarsimp simp: cnotification_relation_def Let_def
                           tcb_queue_relation'_def)
    apply simp
   apply (simp add: setNotification_def split_def)
   apply (rule conjI)
    apply (rule bexI [OF _ setObject_eq])
        apply (simp add: rf_sr_def cstate_relation_def Let_def
                         cpspace_relation_def update_ntfn_map_tos
                         typ_heap_simps')
        apply (elim conjE)
        apply (intro conjI)
             -- "tcb relation"
             apply (erule ctcb_relation_null_queue_ptrs)
             apply (clarsimp simp: comp_def)
            -- "ep relation"
            apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
            apply simp
            apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+)
             apply simp+
            apply (erule (1) map_to_ko_atI')
           -- "ntfn relation"
           apply (rule cpspace_relation_ntfn_update_ntfn, assumption+)
            apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def
                             tcb_queue_relation'_def)
           apply simp
          -- "queue relation"
          apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
          apply (clarsimp simp: comp_def)
         apply (simp add: carch_state_relation_def typ_heap_simps')
        apply (simp add: cmachine_state_relation_def)
       apply (simp add: h_t_valid_clift_Some_iff)
      apply (simp add: objBits_simps)
     apply (simp add: objBits_simps)
    apply assumption
   apply (clarsimp simp: cnotification_relation_def Let_def
                         tcb_queue_relation'_def)
  -- "non-empty case"
  apply clarsimp
  apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
  apply (frule tcb_queue_head_empty_iff [OF tcb_queue_relation'_queue_rel])
   apply (rule ballI, erule bspec)
   apply (erule subsetD [rotated])
   apply (clarsimp simp: cnotification_relation_def Let_def
                         tcb_queue_relation'_def)
  apply (simp add: setNotification_def split_def)
  apply (rule conjI)
   apply (rule bexI [OF _ setObject_eq])
       apply (frule(1) st_tcb_at_h_t_valid)
       apply (simp add: rf_sr_def cstate_relation_def Let_def
                        cpspace_relation_def update_ntfn_map_tos
                        typ_heap_simps')
       apply (elim conjE)
       apply (intro conjI)
            -- "tcb relation"
            apply (erule ctcb_relation_null_queue_ptrs)
            apply (clarsimp simp: comp_def)
           -- "ep relation"
           apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
           apply simp
           apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+)
            apply simp+
           apply (erule (1) map_to_ko_atI')
          -- "ntfn relation"
          apply (rule cpspace_relation_ntfn_update_ntfn, assumption+)
           apply (clarsimp simp: cnotification_relation_def Let_def
                                 isWaitingNtfn_def
                                 tcb_queue_relation'_def valid_ntfn'_def
                          split: Structures_H.notification.splits list.splits
                      split del: if_split)
           apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \<sigma>")
            apply (clarsimp simp: is_aligned_neg_mask
                           dest!: is_aligned_tcb_ptr_to_ctcb_ptr
                       split del: if_split)
           apply (clarsimp split: if_split)
          apply simp
         -- "queue relation"
         apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
         apply (clarsimp simp: comp_def)
        apply (simp add: carch_state_relation_def typ_heap_simps')
       apply (simp add: cmachine_state_relation_def)
      apply (simp add: h_t_valid_clift_Some_iff)
     apply (simp add: objBits_simps)
    apply (simp add: objBits_simps)
   apply assumption
  apply (clarsimp simp: cnotification_relation_def Let_def
                        tcb_queue_relation'_def)
  done

lemma ntfn_set_active_ccorres:
  "ccorres dc xfdc (invs' and ko_at' ntfn ntfnptr
                          and (\<lambda>_. \<not> isWaitingNtfn (ntfnObj ntfn)))
     (UNIV \<inter> {s. ntfnPtr_' s = Ptr ntfnptr} \<inter> {s. badge_' s = badge}) hs
     (setNotification ntfnptr
          (ntfnObj_update (\<lambda>_. Structures_H.ntfn.ActiveNtfn badge) ntfn))
     (Call ntfn_set_active_'proc)"
  apply (rule ccorres_gen_asm)
  apply (cinit lift: ntfnPtr_' badge_')
   apply (simp only: setNotification_def)
   apply (rule_tac P="ko_at' ntfn ntfnptr and invs'"
            in ccorres_from_vcg[where P'=UNIV])
   apply (rule allI, rule conseqPre, vcg)
   apply clarsimp
   apply (rule cmap_relation_ko_atE [OF cmap_relation_ntfn], assumption+)
   apply (clarsimp simp: typ_heap_simps)
   apply (rule bexI[OF _ setObject_eq], simp_all)
    apply (clarsimp simp: typ_heap_simps' rf_sr_def cstate_relation_def Let_def
                          cpspace_relation_def update_ntfn_map_tos
                          carch_state_relation_def cmachine_state_relation_def)
    apply (rule cpspace_relation_ntfn_update_ntfn, assumption+)
     apply (simp add: cnotification_relation_def Let_def NtfnState_Active_def
                      isWaitingNtfn_def mask_def
               split: Structures_H.ntfn.split_asm)
    apply (simp add: objBits_simps)+
  done

lemma sts_runnable:
  "\<lbrace>if t \<noteq> dest then st_tcb_at' runnable' t else st_tcb_at' \<top> t\<rbrace>
  setThreadState Structures_H.thread_state.Running dest
          \<lbrace>\<lambda>rv. st_tcb_at' runnable' t\<rbrace>"
  apply (rule hoare_pre)
  apply (wp sts_st_tcb_at'_cases)
  apply auto
  done

lemma st_tcb'_iff:
  "st_tcb_at' \<top> t = tcb_at' t"
  by (auto simp:st_tcb_at'_def)

lemma sendSignal_ccorres [corres]:
  "ccorres dc xfdc (invs')
     (UNIV \<inter> \<lbrace>\<acute>ntfnPtr = Ptr ntfnptr\<rbrace> \<inter> \<lbrace>\<acute>badge = badge\<rbrace>) hs
     (sendSignal ntfnptr badge)
     (Call sendSignal_'proc)"
  apply (cinit lift: ntfnPtr_' badge_')
   apply (rule ccorres_pre_getNotification, rename_tac ntfn)
   apply (rule_tac xf'=ret__unsigned_'
               and val="case ntfnObj ntfn of IdleNtfn \<Rightarrow> scast NtfnState_Idle
                                 | WaitingNtfn _ \<Rightarrow> scast NtfnState_Waiting
                                 | ActiveNtfn _ \<Rightarrow> scast NtfnState_Active"
               and R="ko_at' ntfn ntfnptr"
                in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
      apply (vcg, clarsimp)
      apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_ntfn])
      apply (clarsimp simp: cnotification_relation_def Let_def typ_heap_simps
                     split: Structures_H.ntfn.splits)
     apply ceqv
    apply (rule_tac P="ntfnBoundTCB ntfn \<noteq> None \<longrightarrow>
                         option_to_ctcb_ptr (ntfnBoundTCB ntfn) \<noteq> NULL"
                 in ccorres_gen_asm)
    apply wpc
      -- "IdleNtfn case"
      apply (rule ccorres_cond_true)
      apply (rule ccorres_rhs_assoc)+
      apply (rule_tac xf'=ret__unsigned_'
                 and val="ptr_val (option_to_ctcb_ptr (ntfnBoundTCB ntfn))"
                 and R="ko_at' ntfn ntfnptr"
                 in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
         apply (rule conseqPre, vcg)
         apply clarsimp
         apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_ntfn])
         apply (clarsimp simp: cnotification_relation_def Let_def typ_heap_simps
                        split: Structures_H.ntfn.splits)
        apply ceqv
       apply csymbr
       apply wpc
        apply (simp add: option_to_ctcb_ptr_def split del: if_split)
        apply (rule ccorres_cond_false)
        apply (ctac add: ntfn_set_active_ccorres[unfolded dc_def])
       apply (rule ccorres_cond_true)
       apply (rule getThreadState_ccorres_foo)
       apply (rule ccorres_Guard_Seq)
       apply csymbr
       apply (rule ccorres_abstract_cleanup)
       apply (rule_tac P="(ret__unsigned = scast ThreadState_BlockedOnReceive)
                 = receiveBlocked rv" in ccorres_gen_asm2)
       apply (rule ccorres_cond[where R=\<top>])
         apply (simp add: Collect_const_mem)
        apply (rule ccorres_rhs_assoc)+
        apply simp
        apply (ctac(no_vcg) add: cancelIPC_ccorres1[OF cteDeleteOne_ccorres])
         apply (ctac(no_vcg) add: setThreadState_ccorres)
          apply (ctac(no_vcg) add: setRegister_ccorres)
           apply (ctac add: switchIfRequiredTo_ccorres[unfolded dc_def])
          apply (wp sts_running_valid_queues sts_st_tcb_at'_cases
                 | simp add: option_to_ctcb_ptr_def split del: if_split)+
        apply (rule_tac Q="\<lambda>_. tcb_at' (the (ntfnBoundTCB ntfn)) and invs'"
                 in hoare_post_imp)
         apply auto[1]
        apply wp
       apply simp
       apply (ctac add: ntfn_set_active_ccorres[unfolded dc_def])
      apply (clarsimp simp: guard_is_UNIV_def option_to_ctcb_ptr_def
                            ARM_H.badgeRegister_def Kernel_C.badgeRegister_def
                            ARM.badgeRegister_def Kernel_C.R0_def
                            "StrictC'_thread_state_defs"less_mask_eq
                            Collect_const_mem)
      apply (case_tac ts, simp_all add: receiveBlocked_def typ_heap_simps
                       cthread_state_relation_def "StrictC'_thread_state_defs")[1]
      -- "ActiveNtfn case"
     apply (rename_tac old_badge)
     apply (rule ccorres_cond_false)
     apply (rule ccorres_cond_false)
     apply (rule ccorres_cond_true)
     apply (clarsimp simp: setNotification_def)
     apply (rule_tac P="invs' and ko_at' ntfn ntfnptr"
                 and P'=UNIV
                  in ccorres_from_vcg)
     apply (rule allI)
     apply (rule conseqPre, vcg)
     apply clarsimp
     apply (frule(1) cmap_relation_ko_atD [OF cmap_relation_ntfn])
     apply (clarsimp simp: typ_heap_simps)
     apply (rule bexI [OF _ setObject_eq])
         apply (simp add: rf_sr_def cstate_relation_def Let_def
                          cpspace_relation_def update_ntfn_map_tos
                          typ_heap_simps')
         apply (elim conjE)
         apply (intro conjI)
           apply (rule cpspace_relation_ntfn_update_ntfn, assumption+)
            apply (simp add: cnotification_relation_def Let_def
                             NtfnState_Active_def mask_def word_bw_comms)
           apply simp
          apply (simp add: carch_state_relation_def typ_heap_simps')
         apply (simp add: cmachine_state_relation_def)
        apply (simp add: h_t_valid_clift_Some_iff)
       apply (simp add: objBits_simps)
      apply (simp add: objBits_simps)
     apply assumption
    -- "WaitingNtfn case"
    apply (rule ccorres_cond_false)
    apply (rule ccorres_cond_true)
    apply wpc
     apply (simp only: haskell_fail_def)
     apply (rule ccorres_fail)
    apply (rename_tac dest rest)
    apply (intro ccorres_rhs_assoc)
    apply (csymbr, csymbr)
    apply (intro ccorres_rhs_assoc2)
    apply (rule ccorres_rhs_assoc)
    apply (rule ccorres_rhs_assoc)
    apply (rule ccorres_split_nothrow_novcg)
        apply (simp only: )
        apply (rule_tac dest=dest in sendSignal_dequeue_ccorres_helper)
       apply ceqv
      apply (simp only: K_bind_def)
      apply (ctac (no_vcg))
       apply (simp, fold dc_def)
       apply (ctac (no_vcg))
        apply ctac
       apply (simp)
       apply (wp weak_sch_act_wf_lift_linear
         setThreadState_oa_queued
         sts_valid_queues tcb_in_cur_domain'_lift)[1]
      apply (wp sts_valid_queues sts_runnable)
     apply (wp setThreadState_st_tcb set_ntfn_valid_objs' | clarsimp)+
    apply (clarsimp simp: guard_is_UNIV_def ThreadState_Running_def mask_def
                          badgeRegister_def Kernel_C.badgeRegister_def
                          ARM.badgeRegister_def Kernel_C.R0_def)
   apply (clarsimp simp: guard_is_UNIV_def NtfnState_Idle_def
                         NtfnState_Active_def NtfnState_Waiting_def)
  apply clarsimp
  apply (simp only: conj_assoc[symmetric])
  apply (rule conjI)
   apply (frule ko_at_valid_objs', (clarsimp simp: projectKOs)+)
   apply (clarsimp simp: valid_obj'_def)
   apply (auto simp: isWaitingNtfn_def st_tcb_at_refs_of_rev' valid_obj'_def valid_ntfn'_def
               dest!: sym_refs_obj_atD' [OF _ invs_sym']
                elim: pred_tcb'_weakenE
               split: list.splits option.splits)[1]
  apply (clarsimp simp: option_to_ctcb_ptr_def tcb_ptr_to_ctcb_ptr_def
                        ctcb_offset_def
                 dest!: sum_to_zero)
  apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs'])
  apply (auto simp: valid_ntfn'_def valid_bound_tcb'_def obj_at'_def projectKOs
                    objBitsKO_def is_aligned_def)
  done

lemma receiveSignal_block_ccorres_helper:
  "ccorres dc xfdc (tcb_at' thread and valid_queues and sch_act_not thread and
                    valid_objs' and ntfn_at' ntfnptr and
                    (\<lambda>s. sch_act_wf (ksSchedulerAction s) s \<and>
                        (\<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))) and
                    K (ntfnptr = ntfnptr && ~~ mask 4))
                   UNIV hs
           (setThreadState (Structures_H.thread_state.BlockedOnNotification
                                ntfnptr) thread)
           (Guard C_Guard {s. s \<Turnstile>\<^sub>c tcb_ptr_to_ctcb_ptr thread}
             (CALL thread_state_ptr_set_tsType(Ptr
              &(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']),
              scast ThreadState_BlockedOnNotification));;
            Guard C_Guard {s. s \<Turnstile>\<^sub>c tcb_ptr_to_ctcb_ptr thread}
             (CALL thread_state_ptr_set_blockingObject(Ptr
                           &(tcb_ptr_to_ctcb_ptr thread\<rightarrow>[''tcbState_C'']),
              ucast (ptr_val (ntfn_Ptr ntfnptr))));;
            CALL scheduleTCB(tcb_ptr_to_ctcb_ptr thread))"
  unfolding K_def setThreadState_def
  apply (intro ccorres_gen_asm)
  apply (rule ccorres_guard_imp)
    apply (rule ccorres_split_nothrow_novcg)
        apply (rule_tac P=\<top> and P'="tcb_at' thread"
                     in threadSet_ccorres_lemma3)
         apply vcg
        apply clarsimp
        apply (frule(1) tcb_at_h_t_valid)
        apply (frule h_t_valid_c_guard)
        apply (clarsimp simp: typ_heap_simps' rf_sr_tcb_update_twice)
        apply (erule(1) rf_sr_tcb_update_no_queue_gen,
          (simp add: typ_heap_simps')+)
         apply (simp add: tcb_cte_cases_def)
        apply (simp add: ctcb_relation_def cthread_state_relation_def
                         ThreadState_BlockedOnNotification_def mask_def
                         from_bool_def to_bool_def)
       apply ceqv
      apply clarsimp
      apply ctac
     apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs'
               threadSet_weak_sch_act_wf_runnable')
    apply (clarsimp simp: guard_is_UNIV_def)
   apply (auto simp: weak_sch_act_wf_def valid_tcb'_def tcb_cte_cases_def
                     valid_tcb_state'_def)
  done

lemma cpspace_relation_ntfn_update_ntfn':
  fixes ntfn :: "Structures_H.notification" and ntfn' :: "Structures_H.notification"
    and ntfnptr :: "word32" and s :: "kernel_state"
  defines "qs \<equiv> if isWaitingNtfn (ntfnObj ntfn') then set (ntfnQueue (ntfnObj ntfn')) else {}"
  defines "s' \<equiv> s\<lparr>ksPSpace := ksPSpace s(ntfnptr \<mapsto> KONotification ntfn')\<rparr>"
  assumes koat: "ko_at' ntfn ntfnptr s"
  and       vp: "valid_pspace' s"
  and      cp: "cmap_relation (map_to_ntfns (ksPSpace s)) (cslift t) Ptr (cnotification_relation (cslift t))"
  and      srs: "sym_refs (state_refs_of' s')"
  and     rel: "cnotification_relation (cslift t') ntfn' notification"
  and    mpeq: "(cslift t' |` (- (tcb_ptr_to_ctcb_ptr ` qs))) = (cslift t |` (- (tcb_ptr_to_ctcb_ptr ` qs)))"
  shows "cmap_relation (map_to_ntfns (ksPSpace s(ntfnptr \<mapsto> KONotification ntfn')))
           (cslift t(Ptr ntfnptr \<mapsto> notification)) Ptr
            (cnotification_relation (cslift t'))"
proof -
  from koat have koat': "ko_at' ntfn' ntfnptr s'"
    by (clarsimp simp: obj_at'_def s'_def objBitsKO_def ps_clear_def projectKOs)

  have ntfns':
    "\<And>x. x \<noteq> ntfnptr \<Longrightarrow> map_to_ntfns (ksPSpace s) x =
                         map_to_ntfns (ksPSpace s') x"
    unfolding s'_def
    by (fastforce intro: ssubst [OF map_comp_update] simp: projectKO_opt_ntfn)

  from koat have map_to_ko_atI'':
    "\<And>x y. \<lbrakk> x \<noteq> ntfnptr; map_to_ntfns (ksPSpace s) x = Some y \<rbrakk> \<Longrightarrow> ko_at' y x s'"
    using vp unfolding s'_def
    by (simp add: map_to_ko_at_updI' injectKO_ntfn objBitsKO_def)

  thus ?thesis using vp srs cp rel mpeq unfolding cmap_relation_def
    apply -
    apply (elim conjE)
    apply (clarsimp elim!: obj_atE' simp: map_comp_update projectKO_opts_defs
                   split: if_split)
    apply (drule (1) bspec [OF _ domI])
    apply simp
    apply (erule(1) cnotification_relation_ntfn_queue [OF _ _ koat'])
      apply (erule(1) map_to_ko_atI'')
     apply (fold qs_def, rule mpeq)
    apply assumption
    done
qed

lemma ntfn_q_refs_of_no_NTFNBound':
  "(x, NTFNBound) \<notin> ntfn_q_refs_of' ntfn"
  by (auto simp: ntfn_q_refs_of'_def split: Structures_H.ntfn.splits)

lemma ntfnBound_state_refs_equivalence:
  "ko_at' ntfn ntfnptr s \<Longrightarrow> {r \<in> state_refs_of' s ntfnptr. snd r = NTFNBound} = ntfn_bound_refs' (ntfnBoundTCB ntfn)"
  by (auto simp: ko_at_state_refs_ofD' set_eq_subset ntfn_q_refs_of_no_NTFNBound' ntfn_bound_refs'_def)


lemma receiveSignal_enqueue_ccorres_helper:
  notes option.case_cong_weak [cong]
  shows
  "ccorres dc xfdc (valid_pspace'
                and (\<lambda>s. sym_refs ((state_refs_of' s)(ntfnptr := set queue \<times> {NTFNSignal} \<union> {r \<in> state_refs_of' s ntfnptr. snd r = NTFNBound})))
                and st_tcb_at'  (\<lambda>st. isBlockedOnNotification st \<and>
                                      waitingOnNotification st = ntfnptr) thread
                and ko_at' (ntfn::Structures_H.notification) ntfnptr
                and K ((ntfnObj ntfn = IdleNtfn \<and> queue = [thread]) \<or>
                       (\<exists>q. ntfnObj ntfn = WaitingNtfn q \<and> thread \<notin> set q \<and>
                            queue = q @ [thread])))
           UNIV hs
           (setNotification ntfnptr $ ntfnObj_update (\<lambda>_. Structures_H.WaitingNtfn queue) ntfn)
           (\<acute>ntfn_queue :== CALL ntfn_ptr_get_queue(ntfn_Ptr ntfnptr);;
            (\<acute>ntfn_queue :== CALL tcbEPAppend(tcb_ptr_to_ctcb_ptr thread,\<acute>ntfn_queue);;
             (CALL notification_ptr_set_state(ntfn_Ptr ntfnptr, scast NtfnState_Waiting);;
              CALL ntfn_ptr_set_queue(ntfn_Ptr ntfnptr,\<acute>ntfn_queue))))"
  unfolding K_def
  apply (rule ccorres_gen_asm)
  apply (rule ccorres_from_vcg)
  apply (rule allI, rule conseqPre, vcg)
  apply (clarsimp split del: if_split simp del: comp_def)
  apply (frule cmap_relation_ntfn)
  apply (erule (1) cmap_relation_ko_atE)
  apply (rule conjI)
   apply (erule h_t_valid_clift)
  apply (frule(1) st_tcb_at_h_t_valid)
  apply (frule pred_tcb_at')
  apply (rule impI)
  apply (rule_tac x="init queue" in exI)
  apply (frule(1) ko_at_valid_ntfn' [OF _ valid_pspace_valid_objs'])
  apply (frule is_aligned_tcb_ptr_to_ctcb_ptr)
  apply (rule conjI)
   apply (rule_tac x=\<sigma> in exI)
   apply (simp add: cnotification_relation_def Let_def)
   apply (case_tac "ntfnObj ntfn", simp_all add: init_def valid_ntfn'_def)[1]
  apply (subgoal_tac "sym_refs (state_refs_of' (\<sigma>\<lparr>ksPSpace :=
                          ksPSpace \<sigma>(ntfnptr \<mapsto> KONotification (NTFN (WaitingNtfn queue) (ntfnBoundTCB ntfn)))\<rparr>))")
   prefer 2
   apply (clarsimp simp: state_refs_of'_upd ko_wp_at'_def ntfnBound_state_refs_equivalence
                         obj_at'_def projectKOs objBitsKO_def)
  apply (subgoal_tac "ko_at' (NTFN (WaitingNtfn queue) (ntfnBoundTCB ntfn)) ntfnptr (\<sigma>\<lparr>ksPSpace :=
                          ksPSpace \<sigma>(ntfnptr \<mapsto> KONotification (NTFN (WaitingNtfn queue) (ntfnBoundTCB ntfn)))\<rparr>)")
   prefer 2
   apply (clarsimp simp: obj_at'_def projectKOs objBitsKO_def ps_clear_upd)
  apply (intro conjI impI allI)
    apply (fastforce simp: h_t_valid_clift)
   apply (fastforce simp: h_t_valid_clift)
  apply (case_tac "ntfnObj ntfn", simp_all add: NtfnState_Idle_def NtfnState_Waiting_def)[1]
   -- "IdleNtfn case"
   apply clarsimp
   apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
   apply (simp add: setNotification_def split_def)
   apply (rule bexI [OF _ setObject_eq])
       apply (simp add: rf_sr_def cstate_relation_def Let_def init_def
                        cpspace_relation_def update_ntfn_map_tos
                        typ_heap_simps')
       apply (elim conjE)
       apply (intro conjI)
            -- "tcb relation"
            apply (erule ctcb_relation_null_queue_ptrs)
            apply (clarsimp simp: comp_def)
           -- "ep relation"
           apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
           apply simp
           apply (rule cendpoint_relation_ntfn_queue, assumption+)
             apply (simp add: isWaitingNtfn_def)
            apply simp
           apply (frule_tac x=p in map_to_ko_atI2, clarsimp, clarsimp)
           apply (erule(2) map_to_ko_at_updI')
            apply (clarsimp simp: objBitsKO_def)
           apply (clarsimp simp: obj_at'_def projectKOs)
          -- "ntfn relation"
          apply (rule cpspace_relation_ntfn_update_ntfn', assumption+)
            apply (case_tac "ntfn", simp_all)[1]
           apply (clarsimp simp: cnotification_relation_def Let_def
                                 mask_def [where n=2] NtfnState_Waiting_def)
           subgoal by (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask
                                 valid_ntfn'_def
                           dest: tcb_queue_relation_next_not_NULL)
          apply (simp add: isWaitingNtfn_def)
         -- "queue relation"
         apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
         subgoal by (clarsimp simp: comp_def)
        apply (simp add: carch_state_relation_def typ_heap_simps')
       apply (simp add: cmachine_state_relation_def)
      apply (simp add: h_t_valid_clift_Some_iff)
     apply (simp add: objBits_simps)
    apply (simp add: objBits_simps)
   apply assumption
  -- "WaitingNtfn case"
  apply clarsimp
  apply (frule null_ep_queue [simplified comp_def] null_ep_queue)
  apply (simp add: setNotification_def split_def)
  apply (rule bexI [OF _ setObject_eq])
      apply (simp add: rf_sr_def cstate_relation_def init_def Let_def
                       cpspace_relation_def update_ntfn_map_tos
                       typ_heap_simps')
      apply (elim conjE)
      apply (intro conjI)
           -- "tcb relation"
           apply (erule ctcb_relation_null_queue_ptrs)
           apply (clarsimp simp: comp_def)
          -- "ep relation"
          apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1])
          apply simp
          apply (rule cendpoint_relation_ntfn_queue, assumption+)
            apply (simp add: isWaitingNtfn_def)
           apply simp
          apply (frule_tac x=p in map_to_ko_atI2, clarsimp, clarsimp)
          apply (erule(2) map_to_ko_at_updI')
           apply (clarsimp simp: objBitsKO_def)
          apply (clarsimp simp: obj_at'_def projectKOs)
         -- "ntfn relation"
         apply (rule cpspace_relation_ntfn_update_ntfn', assumption+)
           apply (case_tac "ntfn", simp_all)[1]
          apply (clarsimp simp: cnotification_relation_def Let_def
                                mask_def [where n=2] NtfnState_Waiting_def
                         split: if_split)
          apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask)
         apply (simp add: isWaitingNtfn_def)
        -- "queue relation"
        apply (rule cready_queues_relation_null_queue_ptrs, assumption+)
        apply (clarsimp simp: comp_def)
       apply (simp add: carch_state_relation_def typ_heap_simps')
      apply (simp add: cmachine_state_relation_def)
     apply (simp add: h_t_valid_clift_Some_iff)
    apply (simp add: objBits_simps)
   apply (simp add: objBits_simps)
  apply assumption
  done

lemma receiveSignal_ccorres [corres]:
  "ccorres dc xfdc (invs' and valid_cap' cap and st_tcb_at' simple' thread
                    and sch_act_not thread
                    and (\<lambda>s. \<forall>d p. thread \<notin> set (ksReadyQueues s (d, p)))
                    and K (isNotificationCap cap))
     (UNIV \<inter> \<lbrace>\<acute>thread = tcb_ptr_to_ctcb_ptr thread\<rbrace>
           \<inter> \<lbrace>ccap_relation cap \<acute>cap\<rbrace>
           \<inter> {s. isBlocking_' s = from_bool is_blocking}) hs
     (receiveSignal thread cap is_blocking)
     (Call receiveSignal_'proc)"
  unfolding K_def
  apply (rule ccorres_gen_asm)
  apply (cinit lift: thread_' cap_' isBlocking_')
   apply (rule ccorres_pre_getNotification, rename_tac ntfn)
   apply (rule_tac xf'=ret__unsigned_'
               and val="capNtfnPtr cap"
               and R=\<top>
                in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
      apply vcg
      apply (clarsimp simp: cap_get_tag_isCap isCap_simps)
      apply (frule cap_get_tag_isCap_unfolded_H_cap)
      apply (simp add: cap_notification_cap_lift ccap_relation_def cap_to_H_def)
     apply ceqv
    apply csymbr
    apply (rule_tac xf'=ret__unsigned_'
                and val="case ntfnObj ntfn of IdleNtfn \<Rightarrow> scast NtfnState_Idle
                                  | WaitingNtfn _ \<Rightarrow> scast NtfnState_Waiting
                                  | ActiveNtfn _ \<Rightarrow> scast NtfnState_Active"
                and R="ko_at' ntfn (capNtfnPtr cap)"
                 in ccorres_symb_exec_r_known_rv_UNIV[where R'=UNIV])
       apply (vcg, clarsimp)
       apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_ntfn])
       apply (clarsimp simp: cnotification_relation_def Let_def typ_heap_simps
                      split: Structures_H.ntfn.splits)

      apply ceqv
     apply wpc
       -- "IdleNtfn case"
       apply (rule ccorres_cond_true)
       apply csymbr
       apply (simp only: case_bool_If from_bool_neq_0)
       apply (rule ccorres_Cond_rhs, simp cong: Collect_cong)
        apply (intro ccorres_rhs_assoc)
        apply (rule ccorres_rhs_assoc2)
        apply (rule ccorres_rhs_assoc2)
        apply (rule ccorres_split_nothrow_novcg)
            apply (simp)
            apply (rule receiveSignal_block_ccorres_helper[simplified])
           apply ceqv
          apply (simp only: K_bind_def)
          apply (rule receiveSignal_enqueue_ccorres_helper[unfolded dc_def, simplified])
         apply (simp add: valid_ntfn'_def)
         apply (wp sts_st_tcb')
         apply (rule_tac Q="\<lambda>rv. ko_wp_at' (\<lambda>x. projectKO_opt x = Some ntfn
                               \<and> projectKO_opt x = (None::tcb option))
                                  (capNtfnPtr cap)"
                       in hoare_post_imp)
          apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs)
         apply wp
        apply (clarsimp simp: guard_is_UNIV_def)
       apply simp
       apply (ctac add: doNBRecvFailedTransfer_ccorres[unfolded dc_def])
      -- "ActiveNtfn case"
      apply (rename_tac badge)
      apply (rule ccorres_cond_false)
      apply (rule ccorres_cond_true)
      apply (intro ccorres_rhs_assoc)
      apply (rule_tac val=badge
                  and xf'=ret__unsigned_'
                  and R="ko_at' ntfn (capNtfnPtr cap)"
                   in ccorres_symb_exec_r_known_rv_UNIV [where R'=UNIV])
         apply (vcg, clarsimp)
         apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_ntfn])
         apply (clarsimp simp: cnotification_relation_def Let_def typ_heap_simps
                        split: Structures_H.notification.splits)
        apply ceqv
       apply (clarsimp simp: badgeRegister_def Kernel_C.badgeRegister_def, ctac(no_vcg))
        apply (rule_tac P="invs' and ko_at' ntfn (capNtfnPtr cap)"
                    and P'=UNIV
                     in ccorres_from_vcg)
        apply (rule allI, rule conseqPre, vcg)
        apply clarsimp
        apply (frule(1) cmap_relation_ko_atD [OF cmap_relation_ntfn])
        apply (clarsimp simp: typ_heap_simps setNotification_def)
        apply (rule bexI [OF _ setObject_eq])
            apply (simp add: rf_sr_def cstate_relation_def Let_def
                             cpspace_relation_def update_ntfn_map_tos
                             typ_heap_simps')
            apply (elim conjE)
            apply (intro conjI)
              apply (rule cpspace_relation_ntfn_update_ntfn, assumption+)
               apply (simp add: cnotification_relation_def Let_def
                                NtfnState_Idle_def mask_def)
              apply simp
             apply (simp add: carch_state_relation_def typ_heap_simps')
            apply (simp add: cmachine_state_relation_def)
           apply (simp add: h_t_valid_clift_Some_iff)
          apply (simp add: objBits_simps)
         apply (simp add: objBits_simps)
        apply assumption
       apply wp
      apply (clarsimp simp: guard_is_UNIV_def)
      apply (clarsimp simp: ARM.badgeRegister_def Kernel_C.R0_def)
     -- "WaitingNtfn case"
     apply (rename_tac list)
     apply (rule ccorres_cond_true)
     apply csymbr
     apply (simp only: case_bool_If from_bool_neq_0)
     apply (rule ccorres_Cond_rhs, simp cong: Collect_cong)
      apply (intro ccorres_rhs_assoc)
      apply (rule ccorres_rhs_assoc2)
      apply (rule ccorres_rhs_assoc2)
      apply (rule ccorres_split_nothrow_novcg)
          apply (simp only: )
          apply (rule receiveSignal_block_ccorres_helper[simplified])
         apply ceqv
        apply (simp only: K_bind_def)
        apply (rule_tac ntfn="ntfn"
                           in receiveSignal_enqueue_ccorres_helper[unfolded dc_def, simplified])
       apply (simp add: valid_ntfn'_def)
       apply (wp sts_st_tcb')
       apply (rule_tac Q="\<lambda>rv. ko_wp_at' (\<lambda>x. projectKO_opt x = Some ntfn
                             \<and> projectKO_opt x = (None::tcb option))
                                    (capNtfnPtr cap)
                      and K (thread \<notin> set list)"
                       in hoare_post_imp)
        apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs)
       apply wp
      apply (clarsimp simp: guard_is_UNIV_def)
     apply simp
     apply (ctac add: doNBRecvFailedTransfer_ccorres[unfolded dc_def])
    apply (clarsimp simp: guard_is_UNIV_def NtfnState_Active_def
                          NtfnState_Waiting_def NtfnState_Idle_def)
   apply (clarsimp simp: guard_is_UNIV_def)
  apply (clarsimp split: if_split)
  apply (rule conjI)
   apply (clarsimp dest!: st_tcb_strg'[rule_format]
                    simp: isNotificationCap_def valid_cap'_def obj_at'_def projectKOs
                   split: capability.splits split del: if_split)
  apply clarsimp
  apply (frule(1) ko_at_valid_objs' [OF _ invs_valid_objs'])
   apply (clarsimp simp: projectKO_opt_ntfn split: kernel_object.split_asm)
  apply (subgoal_tac "state_refs_of' s thread = {r \<in> state_refs_of' s thread. snd r = TCBBound}")
   apply (clarsimp simp: valid_obj'_def valid_ntfn'_def refs_of'_def
                  split: ntfn.splits)
    apply (subgoal_tac "state_refs_of' s (capNtfnPtr cap) =
                             {r \<in> state_refs_of' s (capNtfnPtr cap). snd r = NTFNBound}")
     subgoal by (fastforce simp: obj_at'_def is_aligned_neg_mask objBitsKO_def
                           projectKOs invs'_def valid_state'_def st_tcb_at'_def
                           valid_tcb_state'_def ko_wp_at'_def
                           isBlockedOnNotification_def projectKO_opt_tcb
                     elim: delta_sym_refs
                    split: if_split_asm if_split)
    apply (auto simp: obj_at'_def state_refs_of'_def projectKOs ntfn_bound_refs'_def)[1]
   apply (rename_tac list)
   apply (subgoal_tac "state_refs_of' s (capNtfnPtr cap) = (set list) \<times> {NTFNSignal}
                                       \<union> {r \<in> state_refs_of' s (capNtfnPtr cap). snd r = NTFNBound}
                              \<and> thread \<notin> (set list)")
    subgoal by (fastforce simp: obj_at'_def is_aligned_neg_mask objBitsKO_def
                          projectKOs invs'_def valid_state'_def st_tcb_at'_def
                          valid_tcb_state'_def ko_wp_at'_def
                          isBlockedOnNotification_def projectKO_opt_tcb
                    elim: delta_sym_refs
                   split: if_split_asm if_split)
   apply (frule(1) sym_refs_obj_atD' [OF _ invs_sym'])
   apply (rule conjI, clarsimp simp: ko_wp_at'_def dest!: ntfnBound_state_refs_equivalence)
   apply (clarsimp simp: st_tcb_at'_def ko_wp_at'_def obj_at'_def projectKOs
                  split: if_split_asm)
   apply (drule(1) bspec)+
   apply (drule_tac x="(thread, NTFNSignal)" in bspec, clarsimp)
   apply (clarsimp simp: tcb_bound_refs'_def)
   apply (case_tac "tcbState obj", simp_all)[1]
  apply (frule(1) st_tcb_idle' [OF invs_valid_idle'], simp)
  apply (clarsimp simp: st_tcb_at'_def obj_at'_def state_refs_of'_def projectKOs
                 split: if_split_asm)
  apply (case_tac "tcbState obj", clarsimp+)[1]
  done

end
end
