{-# LINE 1 "src/System/Posix/Thread.hsc" #-}
{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
module System.Posix.Thread
(
create
, create_
, createWithAttributes
, createWithAttributes_
, exit
, exit_
, cancel
, join
, detach
, myThreadId
, Attributes(..)
, AttributesMonoid(..)
, Key
, createKey
, createKey_
, deleteKey
, setSpecific
, getSpecific
) where
import Control.Concurrent (isCurrentThreadBound, rtsSupportsBoundThreads)
import Control.Exception (Exception, bracket_, throwIO)
import Control.Monad (forM_, unless, when)
import Data.Monoid (First(..))
import Data.Semigroup (Semigroup(..))
import Foreign.C.Types
import Foreign.C.Error (Errno(..), errnoToIOError)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (FunPtr, Ptr, castPtr, nullFunPtr, nullPtr)
import Foreign.Storable
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack, callStack, getCallStack, prettySrcLoc)
import Data.Int
import Data.Word
newtype ThreadId = ThreadId Word64
{-# LINE 60 "src/System/Posix/Thread.hsc" #-}
deriving (Eq, Ord, Show, Storable)
foreign import capi unsafe "pthread.h" pthread_create
:: Ptr ThreadId -> Ptr AttributesMonoid -> FunPtr (Ptr a -> IO b) -> Ptr a -> IO CInt
foreign import ccall "wrapper" wrap :: (Ptr a -> IO (Ptr b)) -> IO (FunPtr (Ptr a -> IO (Ptr b)))
create :: IO (Ptr a) -> IO ThreadId
create action =
alloca $ \tidPtr -> do
unless rtsSupportsBoundThreads (error "Use -threaded RTS.")
fptr <- wrap $ \_ -> action
throwIfNonZero_ $ pthread_create tidPtr nullPtr fptr nullPtr
peek tidPtr
create_ :: IO () -> IO ThreadId
create_ action = create (action >> return nullPtr)
foreign import capi unsafe "pthread.h" pthread_attr_init
:: Ptr AttributesMonoid -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_destroy
:: Ptr AttributesMonoid -> IO CInt
createWithAttributes
:: AttributesMonoid
-> IO (Ptr a)
-> IO ThreadId
createWithAttributes attrs action =
alloca $ \tidPtr ->
alloca $ \attrsPtr -> do
unless rtsSupportsBoundThreads (error "Use -threaded RTS.")
bracket_
(throwIfNonZero_ $ pthread_attr_init attrsPtr)
(throwIfNonZero_ $ pthread_attr_destroy attrsPtr) $ do
poke attrsPtr attrs
fptr <- wrap $ \_ -> action
throwIfNonZero_ $ pthread_create tidPtr attrsPtr fptr nullPtr
peek tidPtr
createWithAttributes_ :: AttributesMonoid -> IO () -> IO ThreadId
createWithAttributes_ attrs action =
createWithAttributes attrs (action >> return nullPtr)
foreign import capi safe "pthread.h" pthread_exit :: Ptr a -> IO ()
exit :: Ptr a -> IO ()
exit = pthread_exit
exit_ :: IO ()
exit_ = exit nullPtr
foreign import capi safe "pthread.h" pthread_cancel :: ThreadId -> IO CInt
cancel :: ThreadId -> IO ()
cancel tid = throwIfNonZero_ $ pthread_cancel tid
foreign import capi safe "pthread.h" pthread_join
:: ThreadId -> Ptr (Ptr a) -> IO CInt
join :: ThreadId -> IO (Ptr a)
join tid = alloca $ \ptr -> do
throwIfNonZero_ $ pthread_join tid ptr
peek ptr
foreign import capi unsafe "pthread.h" pthread_detach :: ThreadId -> IO CInt
detach :: ThreadId -> IO ()
detach tid = throwIfNonZero_ $ pthread_detach tid
foreign import capi unsafe "pthread.h" pthread_self :: IO ThreadId
myThreadId :: IO ThreadId
myThreadId = pthread_self
data DetachState = Detached | Joinable
deriving (Eq, Show)
instance Enum DetachState where
toEnum 1 = Detached
{-# LINE 150 "src/System/Posix/Thread.hsc" #-}
toEnum 0 = Joinable
{-# LINE 151 "src/System/Posix/Thread.hsc" #-}
toEnum _ = error "Invalid detach state attribute value"
fromEnum Detached = 1
{-# LINE 154 "src/System/Posix/Thread.hsc" #-}
fromEnum Joinable = 0
{-# LINE 155 "src/System/Posix/Thread.hsc" #-}
data InheritSched = InheritSched | ExplicitSched
deriving (Eq, Show)
instance Enum InheritSched where
toEnum 0 = InheritSched
{-# LINE 161 "src/System/Posix/Thread.hsc" #-}
toEnum 1 = ExplicitSched
{-# LINE 162 "src/System/Posix/Thread.hsc" #-}
toEnum _ = error "Invalid inherit-scheduler attribute value"
fromEnum InheritSched = 0
{-# LINE 165 "src/System/Posix/Thread.hsc" #-}
fromEnum ExplicitSched = 1
{-# LINE 166 "src/System/Posix/Thread.hsc" #-}
data SchedParam = SchedParam
{ schedPriority :: Int32
} deriving (Eq, Show)
instance Storable SchedParam where
sizeOf _ = (4)
{-# LINE 173 "src/System/Posix/Thread.hsc" #-}
alignment _ = 4
{-# LINE 174 "src/System/Posix/Thread.hsc" #-}
peek ptr =
SchedParam <$>
(fromIntegral <$> ((\hsc_ptr -> peekByteOff hsc_ptr 0) ptr :: IO CInt))
{-# LINE 177 "src/System/Posix/Thread.hsc" #-}
poke ptr SchedParam{..} =
(\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (fromIntegral schedPriority :: CInt)
{-# LINE 179 "src/System/Posix/Thread.hsc" #-}
data SchedPolicy = SchedFIFO | SchedRR | SchedOther
deriving (Eq, Show)
instance Enum SchedPolicy where
toEnum 1 = SchedFIFO
{-# LINE 185 "src/System/Posix/Thread.hsc" #-}
toEnum 2 = SchedRR
{-# LINE 186 "src/System/Posix/Thread.hsc" #-}
toEnum 0 = SchedOther
{-# LINE 187 "src/System/Posix/Thread.hsc" #-}
toEnum _ = error "Invalid scheduling policy attribute value"
fromEnum SchedFIFO = 1
{-# LINE 190 "src/System/Posix/Thread.hsc" #-}
fromEnum SchedRR = 2
{-# LINE 191 "src/System/Posix/Thread.hsc" #-}
fromEnum SchedOther = 0
{-# LINE 192 "src/System/Posix/Thread.hsc" #-}
data Scope = ScopeSystem | ScopeProcess
deriving (Eq, Show)
instance Enum Scope where
toEnum 0 = ScopeSystem
{-# LINE 198 "src/System/Posix/Thread.hsc" #-}
toEnum 1 = ScopeProcess
{-# LINE 199 "src/System/Posix/Thread.hsc" #-}
toEnum _ = error "Invalid scope attribute value"
fromEnum ScopeSystem = 0
{-# LINE 202 "src/System/Posix/Thread.hsc" #-}
fromEnum ScopeProcess = 1
{-# LINE 203 "src/System/Posix/Thread.hsc" #-}
data Attributes = Attributes
{ detachState :: DetachState
, guardSize :: CSize
, inheritSched :: InheritSched
, schedParam :: SchedParam
, schedPolicy :: SchedPolicy
, scope :: Scope
, stack :: Ptr ()
, stackSize :: CSize
} deriving (Generic, Show)
data AttributesMonoid = AttributesMonoid
{ detachState :: First DetachState
, guardSize :: First CSize
, inheritSched :: First InheritSched
, schedParam :: First SchedParam
, schedPolicy :: First SchedPolicy
, scope :: First Scope
, stack :: First (Ptr ())
, stackSize :: First CSize
} deriving (Generic, Show)
instance Semigroup AttributesMonoid where
(<>) = mappenddefault
instance Monoid AttributesMonoid where
mempty = memptydefault
mappend = (<>)
monoidFromAttributes :: Attributes -> AttributesMonoid
monoidFromAttributes Attributes{..} =
AttributesMonoid
{ detachState = return detachState
, guardSize = return guardSize
, inheritSched = return inheritSched
, schedParam = return schedParam
, schedPolicy = return schedPolicy
, scope = return scope
, stack = return stack
, stackSize = return stackSize
}
foreign import capi unsafe "pthread.h" pthread_attr_getdetachstate
:: Ptr Attributes -> Ptr CInt -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_getguardsize
:: Ptr Attributes -> Ptr CSize -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_getinheritsched
:: Ptr Attributes -> Ptr CInt -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_getschedparam
:: Ptr Attributes -> Ptr SchedParam -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_getschedpolicy
:: Ptr Attributes -> Ptr CInt -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_getscope
:: Ptr Attributes -> Ptr CInt -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_getstack
:: Ptr Attributes -> Ptr (Ptr ()) -> Ptr CSize -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_setdetachstate
:: Ptr AttributesMonoid -> CInt -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_setguardsize
:: Ptr AttributesMonoid -> CSize -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_setinheritsched
:: Ptr AttributesMonoid -> CInt -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_setschedparam
:: Ptr AttributesMonoid -> Ptr SchedParam -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_setschedpolicy
:: Ptr AttributesMonoid -> CInt -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_setscope
:: Ptr AttributesMonoid -> CInt -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_setstack
:: Ptr AttributesMonoid -> Ptr () -> CSize -> IO CInt
foreign import capi unsafe "pthread.h" pthread_attr_setstacksize
:: Ptr AttributesMonoid -> CSize -> IO CInt
instance Storable AttributesMonoid where
sizeOf _ = (56)
{-# LINE 283 "src/System/Posix/Thread.hsc" #-}
alignment _ = 8
{-# LINE 284 "src/System/Posix/Thread.hsc" #-}
peek attr = monoidFromAttributes <$> peek (castPtr attr)
poke attr AttributesMonoid{..} = do
forM_ detachState $ \x ->
throwIfNonZero_ $ pthread_attr_setdetachstate attr (enum x)
forM_ guardSize $ \x ->
throwIfNonZero_ $ pthread_attr_setguardsize attr x
forM_ inheritSched $ \x ->
throwIfNonZero_ $ pthread_attr_setinheritsched attr (enum x)
forM_ schedParam $ \x ->
throwIfNonZero_ $ alloca $ \sp -> do
poke sp x
pthread_attr_setschedparam attr sp
forM_ schedPolicy $ \x ->
throwIfNonZero_ $ pthread_attr_setschedpolicy attr (enum x)
forM_ scope $ \x ->
throwIfNonZero_ $ pthread_attr_setscope attr (enum x)
case (stack, stackSize) of
(First (Just x), First (Just y)) ->
throwIfNonZero_ $ pthread_attr_setstack attr x y
(First Nothing, First (Just y)) ->
throwIfNonZero_ $ pthread_attr_setstacksize attr y
_ -> return ()
where
enum :: Enum a => a -> CInt
enum = fromIntegral . fromEnum
instance Storable Attributes where
sizeOf _ = (56)
{-# LINE 314 "src/System/Posix/Thread.hsc" #-}
alignment _ = 8
{-# LINE 315 "src/System/Posix/Thread.hsc" #-}
peek attr = do
detachState <- enum <$> alloca (\x -> pthread_attr_getdetachstate attr x >> peek x)
guardSize <- alloca (\x -> pthread_attr_getguardsize attr x >> peek x)
inheritSched <- enum <$> alloca (\x -> pthread_attr_getinheritsched attr x >> peek x)
schedParam <- alloca (\x -> pthread_attr_getschedparam attr x >> peek x)
schedPolicy <- enum <$> alloca (\x -> pthread_attr_getschedpolicy attr x >> peek x)
scope <- enum <$> alloca (\x -> pthread_attr_getscope attr x >> peek x)
(stack, stackSize) <-
alloca $ \x -> alloca $ \y -> do
_ <- pthread_attr_getstack attr x y
(,) <$> peek x <*> peek y
return Attributes{..}
where
enum :: Enum a => CInt -> a
enum = toEnum . fromIntegral
poke attr Attributes{..} = poke (castPtr attr) (monoidFromAttributes Attributes{..})
newtype Key = Key Word32
{-# LINE 336 "src/System/Posix/Thread.hsc" #-}
deriving (Eq, Ord, Show, Storable)
foreign import capi unsafe "pthread.h"
pthread_key_create :: Ptr Key -> FunPtr (Ptr a -> IO ()) -> IO CInt
createKey
:: FunPtr (Ptr a -> IO ())
-> IO Key
createKey destructor = alloca $ \keyPtr -> do
throwIfNonZero_ $ pthread_key_create keyPtr destructor
peek keyPtr
createKey_ :: IO Key
createKey_ = createKey nullFunPtr
foreign import capi unsafe "pthread.h"
pthread_key_delete :: Key -> IO CInt
deleteKey :: Key -> IO ()
deleteKey k = throwIfNonZero_ $ pthread_key_delete k
foreign import capi unsafe "pthread.h"
pthread_setspecific :: Key -> Ptr a -> IO CInt
setSpecific :: Key -> Ptr a -> IO ()
setSpecific k v = do
checkBoundness
throwIfNonZero_ $ pthread_setspecific k v
foreign import capi unsafe "pthread.h"
pthread_getspecific :: Key -> IO (Ptr a)
getSpecific :: Key -> IO (Ptr a)
getSpecific k = do
checkBoundness
pthread_getspecific k
data ThreadNotBound = ThreadNotBound
instance Exception ThreadNotBound
instance Show ThreadNotBound where
show _ = "Calling thread is not bound"
checkBoundness :: IO ()
checkBoundness = when rtsSupportsBoundThreads $ do
bound <- isCurrentThreadBound
unless bound $ throwIO ThreadNotBound
throwIfNonZero_ :: HasCallStack => IO CInt -> IO ()
throwIfNonZero_ m = m >>= \rc -> when (rc /= 0) $
ioError (errnoToIOError (prettySrcLoc loc) (Errno rc) Nothing Nothing)
where
(_, loc):_ = getCallStack callStack