pthread 0.1.1 → 0.1.2

raw patch · 8 files changed

+470/−85 lines, 8 filesdep +generic-derivingdep +hspecdep +hspec-discoverdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: generic-deriving, hspec, hspec-discover, pthread

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−2
• LICENSE +2/−2
• pthread.cabal +21/−5
• src/Foreign/Concurrent/PThread.hsc +0/−76
• src/System/Posix/Thread.hsc +399/−0
• tests/Main.hs +7/−0
• tests/Spec.hs +1/−0
• tests/System/Posix/ThreadSpec.hs +30/−0

@@ -4,13 +4,21 @@  The format is based on [Keep a Changelog](http://keepachangelog.com/). -## [0.1.1] - 2017-09-08+## [0.1.2] - 2019-06-17 +### Added++* Compatibility with ghc-8.6.+* Bind API for attributes and basic thread operations.+* Check for -threaded.++## [0.1.1] - 2017-09-28+ ### Changed  * Fixed the URL to the pthread repo in the cabal file. -## [0.1] - 2017-09-08+## [0.1] - 2017-09-28  ### Added 

@@ -1,5 +1,5 @@-Copyright EURL Tweag (c) 2017-Copyright LeapYear Tecnologies (c) 2017+Copyright (c) 2017 Tweag I/O Limited+Copyright (c) 2017 LeapYear Tecnologies  All rights reserved. 

@@ -1,13 +1,13 @@ name:                pthread-version:             0.1.1+version:             0.1.2 synopsis:            Bindings for the pthread library. homepage:            http://github.com/tweag/pthread license:             BSD3 license-file:        LICENSE author:              Tweag I/O maintainer:          facundo.dominguez@tweag.io-copyright:           2017 EURL Tweag-                     2017 LeapYear Technologies.+copyright:           © 2017 EURL Tweag,+                     © 2017 LeapYear Technologies. category:            FFI, System build-type:          Simple cabal-version:       >=1.10@@ -23,7 +23,23 @@   hs-source-dirs: src   extra-libraries: pthread   exposed-modules:-    Foreign.Concurrent.PThread+    System.Posix.Thread   build-depends:-    base > 4.9.0.0 && < 5+    base >= 4.9.0.0 && < 5,+    generic-deriving >= 1.11   default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is: Main.hs+  other-modules:+    System.Posix.ThreadSpec+    Spec+  build-depends:+    base,+    hspec >= 2.2,+    hspec-discover >= 2.2,+    pthread+  default-language: Haskell2010+  ghc-options: -threaded -rtsopts

@@ -1,76 +0,0 @@--- | PThread bindings--{-# LANGUAGE CApiFFI #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- see comment on the imports of Data.Int and Data.Word-{-# OPTIONS_GHC -Wno-unused-imports #-}-module Foreign.Concurrent.PThread-  ( -- * thread local storage-    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---- These two might be used depending on what the Key representation expands to.-import Data.Int-import Data.Word--#include <pthread.h>---- | Stands for @pthread_key_t@.-newtype Key = Key #{type pthread_key_t}-  deriving (Eq, Ord, Show, Storable)--- We check in cbits/checks.c that the size of pthread_key_t fits unsigned int.--foreign import capi unsafe "pthread.h"-   pthread_key_create :: Ptr Key -> FunPtr (Ptr a -> IO ()) -> IO CInt---- | Stands for @pthread_key_create@.-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---- | Stands for @pthread_key_delete@.-keyDelete :: Key -> IO ()-keyDelete = pthread_key_delete >=> checkReturnCode--foreign import capi unsafe "pthread.h"-   pthread_setspecific :: Key -> Ptr a -> IO CInt---- | Stands for @pthread_setspecific@.-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)---- | Stands for @pthread_getspecific@.-getSpecific :: Key -> IO (Ptr a)-getSpecific k = do-    checkBoundness-    pthread_getspecific k---- | Yields an error if the calling thread is not bound.-checkBoundness :: IO ()-checkBoundness = when rtsSupportsBoundThreads $ do-    bound <- isCurrentThreadBound-    unless bound $-      fail "pthread: checkBoundness: Calling thread is not bound"---- | Yields an error if the passed integer is not zero.-checkReturnCode :: CInt -> IO ()-checkReturnCode rc = when (rc /= 0) $-    fail $ "pthread: checkReturnCode: non-zero return code: " ++ show rc

@@ -0,0 +1,399 @@+-- | Bindings to the POSIX threads library.+--+-- Requires linking with the @-threaded@ RTS.++{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}++-- see comment on the imports of Data.Int and Data.Word+{-# OPTIONS_GHC -Wno-unused-imports #-}++module System.Posix.Thread+  ( -- * Threads+    create+  , create_+  , createWithAttributes+  , createWithAttributes_+  , exit+  , exit_+  , cancel+  , join+  , detach+  , myThreadId+    -- * Attributes+  , Attributes(..)+  , AttributesMonoid(..)+    -- * Thread local storage+  , 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)++-- These two might be used depending on what the Key representation expands to.+import Data.Int+import Data.Word++#include <pthread.h>++newtype ThreadId = ThreadId #{type pthread_t}+  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 a new thread.+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++-- | Like 'create', but with an 'IO' computation that returns nothing.+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++-- | Create a new thread.+createWithAttributes+  :: AttributesMonoid+  -> IO (Ptr a) -- ^ Created thread runs this IO computation.+  -> 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++-- | Like 'createWithAttributes', but with an 'IO' computation that returns+-- nothing.+createWithAttributes_ :: AttributesMonoid -> IO () -> IO ThreadId+createWithAttributes_ attrs action =+    createWithAttributes attrs (action >> return nullPtr)++foreign import capi safe "pthread.h" pthread_exit :: Ptr a -> IO ()++-- | Terminate calling thread.+exit :: Ptr a -> IO ()+exit = pthread_exit++-- | Like 'exit', but don't return anything.+exit_ :: IO ()+exit_ = exit nullPtr++foreign import capi safe "pthread.h" pthread_cancel :: ThreadId -> IO CInt++-- | Send a cancellation request to a thread.+cancel :: ThreadId -> IO ()+cancel tid = throwIfNonZero_ $ pthread_cancel tid++foreign import capi safe "pthread.h" pthread_join+  :: ThreadId -> Ptr (Ptr a) -> IO CInt++-- | Join with a terminated thread.+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 a thread.+detach :: ThreadId -> IO ()+detach tid = throwIfNonZero_ $ pthread_detach tid++foreign import capi unsafe "pthread.h" pthread_self :: IO ThreadId++-- | Obtain ID of the calling thread.+myThreadId :: IO ThreadId+myThreadId = pthread_self++data DetachState = Detached | Joinable+  deriving (Eq, Show)++instance Enum DetachState where+  toEnum #{const PTHREAD_CREATE_DETACHED} = Detached+  toEnum #{const PTHREAD_CREATE_JOINABLE} = Joinable+  toEnum _ = error "Invalid detach state attribute value"++  fromEnum Detached = #{const PTHREAD_CREATE_DETACHED}+  fromEnum Joinable = #{const PTHREAD_CREATE_JOINABLE}++data InheritSched = InheritSched | ExplicitSched+  deriving (Eq, Show)++instance Enum InheritSched where+  toEnum #{const PTHREAD_INHERIT_SCHED} = InheritSched+  toEnum #{const PTHREAD_EXPLICIT_SCHED} = ExplicitSched+  toEnum _ = error "Invalid inherit-scheduler attribute value"++  fromEnum InheritSched = #{const PTHREAD_INHERIT_SCHED}+  fromEnum ExplicitSched = #{const PTHREAD_EXPLICIT_SCHED}++data SchedParam = SchedParam+  { schedPriority :: Int32+  } deriving (Eq, Show)++instance Storable SchedParam where+  sizeOf _ = #{size struct sched_param}+  alignment _ = #{alignment struct sched_param}+  peek ptr =+    SchedParam <$>+      (fromIntegral <$> (#{peek struct sched_param, sched_priority} ptr :: IO CInt))+  poke ptr SchedParam{..} =+    #{poke struct sched_param, sched_priority} ptr (fromIntegral schedPriority :: CInt)++data SchedPolicy = SchedFIFO | SchedRR | SchedOther+  deriving (Eq, Show)++instance Enum SchedPolicy where+  toEnum #{const SCHED_FIFO} = SchedFIFO+  toEnum #{const SCHED_RR} = SchedRR+  toEnum #{const SCHED_OTHER} = SchedOther+  toEnum _ = error "Invalid scheduling policy attribute value"++  fromEnum SchedFIFO = #{const SCHED_FIFO}+  fromEnum SchedRR = #{const SCHED_RR}+  fromEnum SchedOther = #{const SCHED_OTHER}++data Scope = ScopeSystem | ScopeProcess+  deriving (Eq, Show)++instance Enum Scope where+  toEnum #{const PTHREAD_SCOPE_SYSTEM} = ScopeSystem+  toEnum #{const PTHREAD_SCOPE_PROCESS} = ScopeProcess+  toEnum _ = error "Invalid scope attribute value"++  fromEnum ScopeSystem = #{const PTHREAD_SCOPE_SYSTEM}+  fromEnum ScopeProcess = #{const PTHREAD_SCOPE_PROCESS}++-- | Thread attributes.+data Attributes = Attributes+  { detachState :: DetachState+  , guardSize :: CSize+  , inheritSched :: InheritSched+  , schedParam :: SchedParam+  , schedPolicy :: SchedPolicy+  , scope :: Scope+  , stack :: Ptr ()+  , stackSize :: CSize+  } deriving (Generic, Show)++-- | Partial set of thread attributes. Think of it as a diff to apply to the+-- default attributes object.+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 _ = #{size pthread_attr_t}+  alignment _ = #{alignment pthread_attr_t}++  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 _ = #{size pthread_attr_t}+  alignment _ = #{alignment pthread_attr_t}++  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{..})++-- | Opaque objects used to locate thread-specific data.+newtype Key = Key #{type pthread_key_t}+  deriving (Eq, Ord, Show, Storable)+-- We check in cbits/checks.c that the size of pthread_key_t fits unsigned int.++foreign import capi unsafe "pthread.h"+   pthread_key_create :: Ptr Key -> FunPtr (Ptr a -> IO ()) -> IO CInt++-- | Thread-specific data key creation.+createKey+  :: FunPtr (Ptr a -> IO ()) -- ^ Finalizer+  -> IO Key+createKey destructor = alloca $ \keyPtr -> do+    throwIfNonZero_ $ pthread_key_create keyPtr destructor+    peek keyPtr++-- | Like 'createKey', but with no finalizer.+createKey_ :: IO Key+createKey_ = createKey nullFunPtr++foreign import capi unsafe "pthread.h"+   pthread_key_delete :: Key -> IO CInt++-- | Thread-specific data key deletion.+deleteKey :: Key -> IO ()+deleteKey k = throwIfNonZero_ $ pthread_key_delete k++foreign import capi unsafe "pthread.h"+   pthread_setspecific :: Key -> Ptr a -> IO CInt++-- | Associate a thread-specific /value/ with a /key/ obtained via a previous+-- call to 'createKey'.+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)++-- | Return the value currently bound to the specified key on behalf of the+-- calling thread.+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"++-- | Yields an error if the calling thread is not bound.+checkBoundness :: IO ()+checkBoundness = when rtsSupportsBoundThreads $ do+    bound <- isCurrentThreadBound+    unless bound $ throwIO ThreadNotBound++-- | Yields an error if the passed integer is not zero.+throwIfNonZero_ :: HasCallStack => IO CInt -> IO ()+throwIfNonZero_ m = m >>= \rc -> when (rc /= 0) $+    ioError (errnoToIOError (prettySrcLoc loc) (Errno rc) Nothing Nothing)+  where+    (_, loc):_ = getCallStack callStack

@@ -0,0 +1,7 @@+module Main where++import qualified Spec+import Test.Hspec++main :: IO ()+main = hspec Spec.spec

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

@@ -0,0 +1,30 @@+{-# LANGUAGE ScopedTypeVariables #-}++module System.Posix.ThreadSpec (spec) where++import Control.Monad (forM_, replicateM, replicateM_)+import Foreign.Ptr (Ptr)+import Foreign.Marshal.Alloc (alloca)+import qualified System.Posix.Thread as Posix+import Test.Hspec++spec :: Spec+spec = do+    describe "create" $ do+      it "creates 1 threads successfully" $ do+        tid <- Posix.create_ (return ())+        Posix.detach tid+      it "creates 1000 threads successfully" $ do+        replicateM_ 1000 $ do+          tid <- Posix.create_ (return ())+          Posix.detach tid+    describe "join" $ do+      it "Joins 1000 threads successfully" $ do+        alloca $ \(ptr :: Ptr Int) -> do+          tids <- replicateM 1000 $ Posix.create (return ptr)+          forM_ tids $ \tid -> Posix.join tid `shouldReturn` ptr+    describe "exit" $ do+      it "Exits 1000 threads successfully" $ do+        replicateM_ 1000 $ do+          tid <- Posix.create_ Posix.exit_+          Posix.detach tid