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 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
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
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
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
toEnum 0 = Joinable
toEnum _ = error "Invalid detach state attribute value"
fromEnum Detached = 1
fromEnum Joinable = 0
data InheritSched = InheritSched | ExplicitSched
deriving (Eq, Show)
instance Enum InheritSched where
toEnum 0 = InheritSched
toEnum 1 = ExplicitSched
toEnum _ = error "Invalid inherit-scheduler attribute value"
fromEnum InheritSched = 0
fromEnum ExplicitSched = 1
data SchedParam = SchedParam
{ schedPriority :: Int32
} deriving (Eq, Show)
instance Storable SchedParam where
sizeOf _ = (4)
alignment _ = (4)
peek ptr =
SchedParam <$>
(fromIntegral <$> ((\hsc_ptr -> peekByteOff hsc_ptr 0) ptr :: IO CInt))
poke ptr SchedParam{..} =
(\hsc_ptr -> pokeByteOff hsc_ptr 0) ptr (fromIntegral schedPriority :: CInt)
data SchedPolicy = SchedFIFO | SchedRR | SchedOther
deriving (Eq, Show)
instance Enum SchedPolicy where
toEnum 1 = SchedFIFO
toEnum 2 = SchedRR
toEnum 0 = SchedOther
toEnum _ = error "Invalid scheduling policy attribute value"
fromEnum SchedFIFO = 1
fromEnum SchedRR = 2
fromEnum SchedOther = 0
data Scope = ScopeSystem | ScopeProcess
deriving (Eq, Show)
instance Enum Scope where
toEnum 0 = ScopeSystem
toEnum 1 = ScopeProcess
toEnum _ = error "Invalid scope attribute value"
fromEnum ScopeSystem = 0
fromEnum ScopeProcess = 1
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 Monoid AttributesMonoid where
mempty = memptydefault
mappend = mappenddefault
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)
alignment _ = (8)
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)
alignment _ = (8)
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
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