module Foreign.Concurrent.PThread
(
Key
, keyCreate
, keyDelete
, setSpecific
, getSpecific
) where
import Control.Concurrent (isCurrentThreadBound, rtsSupportsBoundThreads)
import Control.Monad ((>=>), unless, when)
import Foreign.C.Types
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr
import Foreign.Storable
import Data.Int
import Data.Word
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
keyCreate :: FunPtr (Ptr a -> IO ()) -> IO Key
keyCreate destructor = alloca $ \keyPtr ->
pthread_key_create keyPtr destructor >>= checkReturnCode >> peek keyPtr
foreign import capi unsafe "pthread.h"
pthread_key_delete :: Key -> IO CInt
keyDelete :: Key -> IO ()
keyDelete = pthread_key_delete >=> checkReturnCode
foreign import capi unsafe "pthread.h"
pthread_setspecific :: Key -> Ptr a -> IO CInt
setSpecific :: Key -> Ptr a -> IO ()
setSpecific k v = checkBoundness >> pthread_setspecific k v >>= checkReturnCode
foreign import capi unsafe "pthread.h"
pthread_getspecific :: Key -> IO (Ptr a)
getSpecific :: Key -> IO (Ptr a)
getSpecific k = do
checkBoundness
pthread_getspecific k
checkBoundness :: IO ()
checkBoundness = when rtsSupportsBoundThreads $ do
bound <- isCurrentThreadBound
unless bound $
fail "pthread: checkBoundness: Calling thread is not bound"
checkReturnCode :: CInt -> IO ()
checkReturnCode rc = when (rc /= 0) $
fail $ "pthread: checkReturnCode: non-zero return code: " ++ show rc