module Ki.Internal.Thread
  ( Thread,
    makeThread,
    await,
    Tid,
    ThreadAffinity (..),
    forkWithAffinity,
    ThreadOptions (..),
    defaultThreadOptions,
    ThreadFailed (..),
    unwrapThreadFailed,
  )
where

import Control.Concurrent (ThreadId, forkOS)
import Control.Exception
  ( BlockedIndefinitelyOnSTM (..),
    Exception (fromException, toException),
    MaskingState (..),
    SomeException,
    asyncExceptionFromException,
    asyncExceptionToException,
  )
import GHC.Conc (STM)
import Ki.Internal.ByteCount
import Ki.Internal.IO (forkIO, forkOn, tryEitherSTM)

-- | A thread.
--
-- ==== __👉 Details__
--
-- * A thread's lifetime is delimited by the scope in which it was created.
--
-- * The thread that creates a scope is considered the parent of all threads created within it.
--
-- * If an exception is raised in a child thread, the child either propagates the exception to its parent (see
--   'Ki.fork'), or returns the exception as a value (see 'Ki.forkTry').
--
-- * All threads created within a scope are terminated when the scope closes.
data Thread a = Thread
  { forall a. Thread a -> ThreadId
threadId :: {-# UNPACK #-} !ThreadId,
    forall a. Thread a -> STM a
await_ :: !(STM a)
  }
  deriving stock (forall a b. a -> Thread b -> Thread a
forall a b. (a -> b) -> Thread a -> Thread b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Thread b -> Thread a
$c<$ :: forall a b. a -> Thread b -> Thread a
fmap :: forall a b. (a -> b) -> Thread a -> Thread b
$cfmap :: forall a b. (a -> b) -> Thread a -> Thread b
Functor)

instance Eq (Thread a) where
  Thread ThreadId
ix STM a
_ == :: Thread a -> Thread a -> Bool
== Thread ThreadId
iy STM a
_ =
    ThreadId
ix forall a. Eq a => a -> a -> Bool
== ThreadId
iy

instance Ord (Thread a) where
  compare :: Thread a -> Thread a -> Ordering
compare (Thread ThreadId
ix STM a
_) (Thread ThreadId
iy STM a
_) =
    forall a. Ord a => a -> a -> Ordering
compare ThreadId
ix ThreadId
iy

makeThread :: ThreadId -> STM a -> Thread a
makeThread :: forall a. ThreadId -> STM a -> Thread a
makeThread ThreadId
threadId STM a
action =
  Thread
    { ThreadId
threadId :: ThreadId
$sel:threadId:Thread :: ThreadId
threadId,
      -- If *they* are deadlocked, we will *both* will be delivered a wakeup from the RTS. We want to shrug this
      -- exception off, because afterwards they'll have put to the result var. But don't shield indefinitely, once will
      -- cover this use case and prevent any accidental infinite loops.
      $sel:await_:Thread :: STM a
await_ = forall e b a.
Exception e =>
(e -> STM b) -> (a -> STM b) -> STM a -> STM b
tryEitherSTM (\BlockedIndefinitelyOnSTM
BlockedIndefinitelyOnSTM -> STM a
action) forall (f :: * -> *) a. Applicative f => a -> f a
pure STM a
action
    }

-- A unique identifier for a thread within a scope. (Internal type alias)
type Tid =
  Int

-- | What, if anything, a thread is bound to.
data ThreadAffinity
  = -- | Unbound.
    Unbound
  | -- | Bound to a capability.
    Capability Int
  | -- | Bound to an OS thread.
    OsThread
  deriving stock (ThreadAffinity -> ThreadAffinity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThreadAffinity -> ThreadAffinity -> Bool
$c/= :: ThreadAffinity -> ThreadAffinity -> Bool
== :: ThreadAffinity -> ThreadAffinity -> Bool
$c== :: ThreadAffinity -> ThreadAffinity -> Bool
Eq, Int -> ThreadAffinity -> ShowS
[ThreadAffinity] -> ShowS
ThreadAffinity -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThreadAffinity] -> ShowS
$cshowList :: [ThreadAffinity] -> ShowS
show :: ThreadAffinity -> String
$cshow :: ThreadAffinity -> String
showsPrec :: Int -> ThreadAffinity -> ShowS
$cshowsPrec :: Int -> ThreadAffinity -> ShowS
Show)

-- forkIO/forkOn/forkOS, switching on affinity
forkWithAffinity :: ThreadAffinity -> IO () -> IO ThreadId
forkWithAffinity :: ThreadAffinity -> IO () -> IO ThreadId
forkWithAffinity = \case
  ThreadAffinity
Unbound -> IO () -> IO ThreadId
forkIO
  Capability Int
n -> Int -> IO () -> IO ThreadId
forkOn Int
n
  ThreadAffinity
OsThread -> IO () -> IO ThreadId
Control.Concurrent.forkOS

-- |
--
-- [@affinity@]:
--
--     The affinity of a thread. A thread can be unbound, bound to a specific capability, or bound to a specific OS
--     thread.
--
--     Default: 'Unbound'
--
-- [@allocationLimit@]:
--
--     The maximum number of bytes a thread may allocate before it is delivered an
--     'Control.Exception.AllocationLimitExceeded' exception. If caught, the thread is allowed to allocate an additional
--     100kb (tunable with @+RTS -xq@) to perform any necessary cleanup actions; if exceeded, the thread is delivered
--     another.
--
--     Default: @Nothing@ (no limit)
--
-- [@label@]:
--
--     The label of a thread, visible in the [event log](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/runtime_control.html#rts-eventlog) (@+RTS -l@).
--
--     Default: @""@ (no label)
--
-- [@maskingState@]:
--
--     The masking state a thread is created in. To unmask, use 'GHC.IO.unsafeUnmask'.
--
--     Default: @Unmasked@
data ThreadOptions = ThreadOptions
  { ThreadOptions -> ThreadAffinity
affinity :: ThreadAffinity,
    ThreadOptions -> Maybe ByteCount
allocationLimit :: Maybe ByteCount,
    ThreadOptions -> String
label :: String,
    ThreadOptions -> MaskingState
maskingState :: MaskingState
  }
  deriving stock (ThreadOptions -> ThreadOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThreadOptions -> ThreadOptions -> Bool
$c/= :: ThreadOptions -> ThreadOptions -> Bool
== :: ThreadOptions -> ThreadOptions -> Bool
$c== :: ThreadOptions -> ThreadOptions -> Bool
Eq, Int -> ThreadOptions -> ShowS
[ThreadOptions] -> ShowS
ThreadOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThreadOptions] -> ShowS
$cshowList :: [ThreadOptions] -> ShowS
show :: ThreadOptions -> String
$cshow :: ThreadOptions -> String
showsPrec :: Int -> ThreadOptions -> ShowS
$cshowsPrec :: Int -> ThreadOptions -> ShowS
Show)

-- | Default thread options.
--
-- @
-- 'Ki.ThreadOptions'
--   { 'Ki.affinity' = 'Ki.Unbound'
--   , 'Ki.allocationLimit' = Nothing
--   , 'Ki.label' = ""
--   , 'Ki.maskingState' = 'Unmasked'
--   }
-- @
defaultThreadOptions :: ThreadOptions
defaultThreadOptions :: ThreadOptions
defaultThreadOptions =
  ThreadOptions
    { $sel:affinity:ThreadOptions :: ThreadAffinity
affinity = ThreadAffinity
Unbound,
      $sel:allocationLimit:ThreadOptions :: Maybe ByteCount
allocationLimit = forall a. Maybe a
Nothing,
      $sel:label:ThreadOptions :: String
label = String
"",
      $sel:maskingState:ThreadOptions :: MaskingState
maskingState = MaskingState
Unmasked
    }

-- Internal exception type thrown by a child thread to its parent, if it fails unexpectedly.
data ThreadFailed = ThreadFailed
  { ThreadFailed -> Int
childId :: {-# UNPACK #-} !Tid,
    ThreadFailed -> SomeException
exception :: !SomeException
  }
  deriving stock (Int -> ThreadFailed -> ShowS
[ThreadFailed] -> ShowS
ThreadFailed -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThreadFailed] -> ShowS
$cshowList :: [ThreadFailed] -> ShowS
show :: ThreadFailed -> String
$cshow :: ThreadFailed -> String
showsPrec :: Int -> ThreadFailed -> ShowS
$cshowsPrec :: Int -> ThreadFailed -> ShowS
Show)

instance Exception ThreadFailed where
  toException :: ThreadFailed -> SomeException
toException = forall e. Exception e => e -> SomeException
asyncExceptionToException
  fromException :: SomeException -> Maybe ThreadFailed
fromException = forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException

-- Peel an outer ThreadFailed layer off of some exception, if there is one.
unwrapThreadFailed :: SomeException -> SomeException
unwrapThreadFailed :: SomeException -> SomeException
unwrapThreadFailed SomeException
e0 =
  case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e0 of
    Just (ThreadFailed Int
_ SomeException
e1) -> SomeException
e1
    Maybe ThreadFailed
Nothing -> SomeException
e0

-- | Wait for a thread to terminate.
await :: Thread a -> STM a
await :: forall a. Thread a -> STM a
await =
  forall a. Thread a -> STM a
await_