(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

(*
 * Operations on endpoints.
 *)

theory Endpoint_D
imports Invocations_D CSpace_D Tcb_D
begin

(* Inject the reply cap into the target TCB *)
definition
  inject_reply_cap :: "cdl_object_id \<Rightarrow> cdl_object_id \<Rightarrow> bool \<Rightarrow> unit k_monad"
where
  "inject_reply_cap src_tcb_id dst_tcb_id can_grant \<equiv> do
     set_cap (src_tcb_id, tcb_pending_op_slot) $
         cdl_cap.PendingSyncRecvCap src_tcb_id True False;
     insert_cap_child (ReplyCap src_tcb_id (if can_grant then {Grant, Write} else {Write}))
                      (src_tcb_id, tcb_replycap_slot)
                      (dst_tcb_id, tcb_caller_slot);
     return ()
  od"

(*
 * Get the slot where we should place an incoming cap for a
 * particular thread.
 *)

definition
  get_receive_slot :: "cdl_object_id \<Rightarrow> cdl_cap_ref option k_monad"
where
  "get_receive_slot thread \<equiv>
    do
      tcb \<leftarrow> get_thread thread;
      recv_slot \<leftarrow> (case (cdl_tcb_caps tcb tcb_ipcbuffer_slot) of (Some (FrameCap _ _ rights _ _ _)) \<Rightarrow>
        if (Read \<in> rights \<and> Write \<in> rights)
          then return (cdl_intent_recv_slot (cdl_tcb_intent tcb))
        else
          return None
      | _ \<Rightarrow> return None);
      case ( recv_slot ) of
          None \<Rightarrow>
            return None
        | Some (croot, index, depth) \<Rightarrow>
            doE
              \<comment> \<open>Lookup the slot.\<close>
              cspace_root \<leftarrow> unify_failure $ lookup_cap thread croot;
              result \<leftarrow> unify_failure $ lookup_slot_for_cnode_op cspace_root index depth;

              \<comment> \<open>Ensure nothing is already in it.\<close>
              cap \<leftarrow> liftE $ get_cap result;
              whenE (cap \<noteq> NullCap) throw;

              returnOk $ Some result
            odE <catch> (\<lambda>_. return None)
    od
  "

(* Get the cptr's that the given thread wishes to transfer. *)
definition
  get_send_slots :: "cdl_object_id \<Rightarrow> cdl_cptr list k_monad"
where
  "get_send_slots thread \<equiv>
    do
      tcb \<leftarrow> get_thread thread;
      return $ cdl_intent_extras (cdl_tcb_intent tcb)
    od
  "

definition
  get_ipc_buffer :: "cdl_object_id \<Rightarrow> bool \<Rightarrow> cdl_object_id option k_monad"
where
  "get_ipc_buffer oid in_receive \<equiv> do
    frame_cap \<leftarrow> get_cap (oid,tcb_ipcbuffer_slot);
    (case frame_cap of
        Types_D.FrameCap _ a rights _ _ _ \<Rightarrow> if (Write \<in> rights \<and> Read \<in> rights) \<or> (Read\<in> rights \<and> \<not> in_receive)
          then return (Some a)
          else return None
        | _ \<Rightarrow> return None)
   od"

definition
  corrupt_ipc_buffer :: "cdl_object_id \<Rightarrow> bool \<Rightarrow> unit k_monad"
  where
  "corrupt_ipc_buffer oid in_receive \<equiv> do
    buffer \<leftarrow> get_ipc_buffer oid in_receive;
    (case buffer of
        Some a \<Rightarrow> corrupt_frame a
      | None \<Rightarrow> corrupt_tcb_intent oid)
  od"

(*
 * Transfers at most one cap in addition to a number of endpoint badges.
 *
 * Endpoint badges are transferred if the cap to be transferred is to
 * the endpoint used in the transfer.
 *)
fun
  transfer_caps_loop :: "cdl_object_id option \<Rightarrow> cdl_object_id \<Rightarrow>
                         (cdl_cap \<times> cdl_cap_ref) list \<Rightarrow> cdl_cap_ref option
                         \<Rightarrow> unit k_monad"
where
  "transfer_caps_loop ep receiver [] dest = return ()"
| "transfer_caps_loop ep receiver ((cap,slot)#caps) dest =
      \<comment> \<open>Transfer badge, transfer cap, or abort early if more than
         one cap to transfer\<close>
      (if is_ep_cap cap \<and> ep = Some (cap_object cap)
      then do
        \<comment> \<open>transfer badge\<close>
        corrupt_ipc_buffer receiver True;
        \<comment> \<open>transfer rest of badges or cap\<close>
        transfer_caps_loop ep receiver caps dest
      od
      else if dest \<noteq> None then doE
        new_cap \<leftarrow> returnOk (update_cap_rights (cap_rights cap - {Write}) cap) \<sqinter>
                  returnOk cap;

        \<comment> \<open>Target cap is derived. This may abort transfer early.\<close>
        target_cap \<leftarrow> derive_cap slot new_cap;
        whenE (target_cap = NullCap) throw;

        \<comment> \<open>Copy the cap across as either a child or sibling.\<close>
        liftE (insert_cap_child target_cap slot (the dest)
               \<sqinter> insert_cap_sibling target_cap slot (the dest));

        \<comment> \<open>Transfer rest of badges\<close>
        liftE $ transfer_caps_loop ep receiver caps None
      odE <catch> (\<lambda>_. return ())
      else
        return ())"


(*
 * Transfer caps from src to dest.
 *
 * In theory, the source thread specifies a list of caps to send, and
 * the destination thread specifies a list of cap slots to put them in.
 *
 * In the true spirit of L4 Pistachio, what _actually_ occurs during the
 * IPC transfer is hard to determine without knowing intricate details
 * of the kernel's implementation. In particular:
 *
 *   - Caps often just won't send, but still 'burn' the receive slot
 *     (ZombieCaps, ReplyCaps, IrqControlCap);
 *
 *   - Caps may not send, but still allow later caps to
 *     use the receive slot (Unwrapped endpoints);
 *
 *   - Cap sending may stop half way (cap lookup faults);
 *
 *   - The new cap may either be a sibling or child of source cap,
 *     depending on where in the CDT the source cap is.
 *
 *   - In reality, no more than one cap will ever be sent, because only
 *     one destination cap slot is supported elsewhere in the code.
 *
 * We remove some of the details, replacing them with nondeterminism.
 *)
definition
  transfer_caps :: "cdl_object_id option \<Rightarrow> (cdl_cap \<times> cdl_cap_ref) list \<Rightarrow>
                    cdl_object_id \<Rightarrow> cdl_object_id \<Rightarrow> unit k_monad"
where
  "transfer_caps ep caps sender receiver \<equiv>
    do
      dest_slot \<leftarrow> get_receive_slot receiver \<sqinter> return None;
      transfer_caps_loop ep receiver caps dest_slot
    od"

(*
 * Get the set of threads waiting to receive on the given notification.
 *)
definition
  get_waiting_ntfn_recv_threads :: "cdl_object_id \<Rightarrow> cdl_state \<Rightarrow> cdl_object_id set"
where
  "get_waiting_ntfn_recv_threads target state \<equiv>
     {x. \<exists>a. (cdl_objects state) x = Some (Tcb a) \<and>
         (((cdl_tcb_caps a) tcb_pending_op_slot) = Some (PendingNtfnRecvCap target)) }"

(* Get the set of threads waiting to receive on the given sync endpoint. *)
definition
  get_waiting_sync_recv_threads :: "cdl_object_id \<Rightarrow> cdl_state \<Rightarrow> cdl_object_id set"
where
  "get_waiting_sync_recv_threads target state \<equiv>
     {x. \<exists>a. (cdl_objects state) x = Some (Tcb a) \<and>
         (\<exists>can_grant. (cdl_tcb_caps a) tcb_pending_op_slot = Some (PendingSyncRecvCap target False can_grant)) }"

(*
 * Get the set of threads waiting to send to the given sync endpoint.
 *)
definition
  get_waiting_sync_send_threads :: "cdl_object_id \<Rightarrow> cdl_state \<Rightarrow> cdl_object_id set"
where
  "get_waiting_sync_send_threads target state \<equiv>
     {t. \<exists>fault a b. (cdl_objects state) t = Some (Tcb a) \<and>
         (\<exists>call can_grant can_grant_reply. (cdl_tcb_caps a) tcb_pending_op_slot =
                    Some (PendingSyncSendCap target b call can_grant can_grant_reply fault)) }"

(*
 * Get the set of threads which are bound to the given ntfn, but are
 * also waiting on sync IPC
 *)
definition
  get_waiting_sync_bound_ntfn_threads :: "cdl_object_id \<Rightarrow> cdl_state \<Rightarrow> cdl_object_id set"
where
  "get_waiting_sync_bound_ntfn_threads ntfn_id state \<equiv>
     {x. \<exists>a ep_id. (cdl_objects state) x = Some (Tcb a) \<and>
         (\<exists>can_grant. (cdl_tcb_caps a) tcb_pending_op_slot = Some (PendingSyncRecvCap ep_id False can_grant)) \<and>
         ((cdl_tcb_caps a) tcb_boundntfn_slot = Some (BoundNotificationCap ntfn_id))}"

(*
 * Mark a thread blocked on IPC.
 *
 * Theads get a new implicit "send once" or "receive once" capability
 * when they block on an IPC. This is because if the capability they
 * used to start the send/receive is revoked, the transfer will still be
 * allowed to proceed (even if it is at a much later point in time).
 *)

definition
  block_thread_on_ipc :: "cdl_object_id \<Rightarrow> cdl_cap \<Rightarrow> unit k_monad"
where
  "block_thread_on_ipc tcb cap \<equiv> set_cap (tcb, tcb_pending_op_slot) cap" (* Might need to do some check here *)

definition
  lookup_extra_caps :: "cdl_object_id \<Rightarrow> cdl_cptr list \<Rightarrow> (cdl_cap \<times> cdl_cap_ref) list fault_monad"
where
  "lookup_extra_caps thread cptrs \<equiv>
     mapME (\<lambda>cptr. lookup_cap_and_slot thread cptr) cptrs"

(*
 * Transfer a message from "sender" to "receiver", possibly copying caps
 * over in the process. If a fault is pending in receiver, send fault instead.
 *)
definition
  do_ipc_transfer :: "cdl_object_id option \<Rightarrow> cdl_object_id \<Rightarrow> cdl_object_id \<Rightarrow> bool \<Rightarrow> unit k_monad"
where
  "do_ipc_transfer ep_id sender_id receiver_id can_grant \<equiv> do
      \<comment> \<open>look up cap transfer\<close>
      src_slots \<leftarrow> get_send_slots sender_id;
      do \<comment> \<open>do normal transfer\<close>
        caps \<leftarrow> if can_grant then
                lookup_extra_caps sender_id src_slots <catch> (\<lambda>_. return [])
              else
                return [];
        \<comment> \<open>copy registers, transfer message or fault\<close>
        corrupt_ipc_buffer receiver_id True;
        \<comment> \<open>transfer caps if no fault occured\<close>
        transfer_caps ep_id caps sender_id receiver_id
      od  \<sqinter>  \<comment> \<open>fault transfer\<close>
      corrupt_ipc_buffer receiver_id True;
      \<comment> \<open>set message info\<close>
      corrupt_tcb_intent receiver_id
  od"


(*
 * Transfer a message from "sender" to "receiver" using a reply capability.
 *
 * The sender may have the right to grant caps over the channel.
 *
 * If a fault is pending in the receiver, the fault is transferred.
 *)

definition
  do_reply_transfer :: "cdl_object_id \<Rightarrow> cdl_object_id \<Rightarrow> cdl_cap_ref \<Rightarrow> bool \<Rightarrow> unit k_monad"
where
  "do_reply_transfer sender_id receiver_id reply_cap_slot can_grant \<equiv>
    do
      has_fault \<leftarrow> get_thread_fault receiver_id;
      when (\<not> has_fault) $ do_ipc_transfer None sender_id receiver_id can_grant;
      \<comment> \<open>Clear out any pending operation caps.\<close>
      delete_cap_simple reply_cap_slot;
      when (has_fault) $ (do corrupt_tcb_intent receiver_id;
        update_thread_fault receiver_id (\<lambda>_. False) od );
      if ( \<not> has_fault) then set_cap (receiver_id, tcb_pending_op_slot) RunningCap
      else
         (set_cap (receiver_id,tcb_pending_op_slot) NullCap
        \<sqinter> set_cap (receiver_id,tcb_pending_op_slot) RestartCap)
    od"

(* Wake-up a thread waiting on an notification. *)
definition
  do_notification_transfer :: "cdl_object_id \<Rightarrow> unit k_monad"
where
  "do_notification_transfer receiver_id \<equiv> do
      set_cap (receiver_id,tcb_pending_op_slot) RunningCap;
      corrupt_tcb_intent receiver_id
   od"

(*
 * Signal on a notification.
 *
 * If someone is blocked on the notifications, we wake them up. Otherwise,
 * this is a no-(.)
 *)

definition
  send_signal_bound :: "cdl_object_id \<Rightarrow> unit k_monad"
where
  "send_signal_bound ntfn_id \<equiv> do
      bound_tcbs \<leftarrow> gets $ get_waiting_sync_bound_ntfn_threads ntfn_id;
      if (bound_tcbs \<noteq> {}) then do
          t \<leftarrow> select bound_tcbs;
          set_cap (t, tcb_pending_op_slot) NullCap;
          do_notification_transfer t
        od
      else return ()
    od"

definition
  send_signal :: "cdl_object_id \<Rightarrow> unit k_monad"
where
  "send_signal ep_id \<equiv>
    (do waiters \<leftarrow> gets $ get_waiting_ntfn_recv_threads ep_id;
          t \<leftarrow> option_select waiters;
          case t of
              None \<Rightarrow> return ()
            | Some receiver \<Rightarrow> do_notification_transfer receiver
     od)
            \<sqinter> send_signal_bound ep_id"

(*
 * Receive a signal (receive from a notification).
 *
 * We will either receive data or block waiting.
 *)
definition
  recv_signal :: "cdl_object_id \<Rightarrow> cdl_cap \<Rightarrow> unit k_monad"
where
  "recv_signal tcb_id_receiver ep_cap  \<equiv> do
     ep_id \<leftarrow> return $ cap_object ep_cap;
     block_thread_on_ipc tcb_id_receiver (PendingNtfnRecvCap ep_id) \<sqinter> corrupt_tcb_intent tcb_id_receiver
   od"

(*
 * Send an IPC to the given endpoint. If someone is waiting, we wake
 * them up. Otherwise, we put the sender to sleep.
 *)
definition
  send_ipc :: "bool \<Rightarrow> bool \<Rightarrow> cdl_badge \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> cdl_object_id \<Rightarrow> cdl_object_id \<Rightarrow> unit k_monad"
where
  "send_ipc block call badge can_grant can_grant_reply tcb_id_sender ep_id \<equiv>
    do
      waiters \<leftarrow> gets $ get_waiting_sync_recv_threads ep_id;
      t \<leftarrow> option_select waiters;
      case t of
          None \<Rightarrow>
            if block then
              block_thread_on_ipc tcb_id_sender
                  (PendingSyncSendCap ep_id badge call can_grant can_grant_reply False)
            else
              return ()
        | Some tcb_id_receiver \<Rightarrow> do
             \<comment> \<open>liftM instead of bind+return avoids early unfolding in send_ipc_corres\<close>
             recv_state \<leftarrow> liftM (\<lambda>tcb. the (cdl_tcb_caps tcb tcb_pending_op_slot)) $
                              get_thread tcb_id_receiver;
             reply_can_grant \<leftarrow>
               (case recv_state of
                    PendingSyncRecvCap target False receiver_grant \<Rightarrow> do
                      do_ipc_transfer (Some ep_id) tcb_id_sender tcb_id_receiver can_grant;
                      return receiver_grant od
                  | _ \<Rightarrow> fail);
             set_cap (tcb_id_receiver,tcb_pending_op_slot) RunningCap;
             (when (can_grant \<or> can_grant_reply) $
                  (inject_reply_cap tcb_id_sender tcb_id_receiver reply_can_grant))
               \<sqinter> set_cap (tcb_id_sender,tcb_pending_op_slot) NullCap \<sqinter> return ()
          od
    od"

(*
 * Receive an IPC from the given endpoint. If someone is waiting, we
 * wake them up. Otherwise, we put the receiver to sleep.
 *)
definition
  receive_sync :: "cdl_object_id \<Rightarrow> cdl_object_id \<Rightarrow> bool \<Rightarrow> unit k_monad"
where
  "receive_sync thread ep_id receiver_can_grant \<equiv> do
    waiters \<leftarrow> gets $ get_waiting_sync_send_threads ep_id;
      waiter \<leftarrow> option_select waiters;
      (case waiter of
          None \<Rightarrow>
            block_thread_on_ipc thread (PendingSyncRecvCap ep_id False receiver_can_grant)
             \<sqinter> corrupt_tcb_intent thread
        | Some tcb_id_sender \<Rightarrow> (do
            tcb \<leftarrow> get_thread tcb_id_sender;
            case ((cdl_tcb_caps tcb) tcb_pending_op_slot) of
              Some (PendingSyncSendCap target _ call can_grant can_grant_reply fault) \<Rightarrow> (do
                 do_ipc_transfer (Some ep_id) tcb_id_sender thread can_grant;
                 (when (can_grant \<or> can_grant_reply) $
                    (inject_reply_cap tcb_id_sender thread receiver_can_grant)) \<sqinter>
                 set_cap (tcb_id_sender, tcb_pending_op_slot) RunningCap \<sqinter>
                 set_cap (tcb_id_sender, tcb_pending_op_slot) NullCap
              od)
        od)
      )
    od"

(* This is more nonderministic than is really required, but
   it makes the refinement proofs much easier *)
definition
  receive_ipc :: "cdl_object_id \<Rightarrow> cdl_object_id \<Rightarrow> bool \<Rightarrow> unit k_monad"
where
  "receive_ipc thread ep_id can_grant \<equiv> corrupt_tcb_intent thread \<sqinter> receive_sync thread ep_id can_grant"

definition
  invoke_endpoint :: "bool \<Rightarrow> bool \<Rightarrow> cdl_endpoint_invocation \<Rightarrow> unit k_monad"
where
  "invoke_endpoint is_call can_block params \<equiv> case params of
    SyncMessage badge can_grant can_grant_reply ep_id \<Rightarrow> do
      thread \<leftarrow> gets_the cdl_current_thread;
      send_ipc can_block is_call badge can_grant can_grant_reply thread ep_id
    od"

definition
  invoke_notification :: "cdl_notification_invocation \<Rightarrow> unit k_monad"
where
  "invoke_notification params \<equiv> case params of
    Signal badge ep_id \<Rightarrow>
      send_signal ep_id"

definition
  invoke_reply :: "cdl_reply_invocation \<Rightarrow> unit k_monad"
where
  "invoke_reply params \<equiv> case params of
    ReplyMessage recv reply_cap_ref rights \<Rightarrow> do
      send \<leftarrow> gets_the cdl_current_thread;
      do_reply_transfer send recv reply_cap_ref rights
    od"


(*
 * Send a fault IPC to the given thread's fault handler.
 *)
definition
  send_fault_ipc :: "cdl_object_id \<Rightarrow> unit fault_monad"
  where
  "send_fault_ipc tcb_id \<equiv>
    doE
      \<comment> \<open>Lookup where we should send the fault IPC to.\<close>
      tcb \<leftarrow> liftE $ get_thread tcb_id;
      target_ep_cptr \<leftarrow> returnOk $ cdl_tcb_fault_endpoint tcb;
      handler_cap \<leftarrow> lookup_cap tcb_id target_ep_cptr;
      (case handler_cap of
          EndpointCap ref badge rights \<Rightarrow>
            if Write \<in> rights \<and> (Grant \<in> rights \<or> GrantReply \<in> rights) then
              liftE $ do
                update_thread_fault tcb_id (\<lambda>_. True);
                send_ipc True True badge (Grant \<in> rights) True tcb_id ref
              od
            else
               throw
        | _ \<Rightarrow> throw)
    odE"

(*
 * Handle a fault caused by the current thread.
 *
 * The abstract spec adds two additional parameters:
 *
 *    1. The fault type (which we abstract away);
 *
 *    2. The thread causing the fault (which always turns out
 *       to be the current thread).
 *)
definition
  handle_fault :: "unit k_monad"
where
  "handle_fault \<equiv> do
    tcb_id \<leftarrow> gets_the cdl_current_thread;
    (send_fault_ipc tcb_id
      <catch> (\<lambda>_. KHeap_D.set_cap (tcb_id,tcb_pending_op_slot) cdl_cap.NullCap))
  od"

end