thread-utils-context 0.1.0.0 → 0.2.0.0
raw patch · 4 files changed
+88/−50 lines, 4 filesdep +criteriondep +mtl
Dependencies added: criterion, mtl
Files
- ChangeLog.md +5/−0
- bench/Bench.hs +19/−0
- src/Control/Concurrent/Thread/Storage.hs +45/−49
- thread-utils-context.cabal +19/−1
ChangeLog.md view
@@ -1,3 +1,8 @@ # Changelog for thread-utils-context +## 0.2.0.0++- Significant performance improvements+- 'storedItems' now returns both keys and values.+ ## Unreleased changes
+ bench/Bench.hs view
@@ -0,0 +1,19 @@+import Criterion+import Criterion.Main+import Control.Concurrent+import Control.Concurrent.Thread.Storage +import Control.Monad.Reader++main :: IO ()+main = do+ tsm <- newThreadStorageMap+ defaultMain+ [ bench "attach" $ whnfIO $ do+ attach tsm ()+ -- , bench "myThreadId" $ whnfIO myThreadId+ -- , bench "hashed getThreadId" $ whnfIO $ do+ -- tid <- myThreadId+ -- pure $ threadHash $ getThreadId tid+ -- , bench "local" $ whnfIO $ runReaderT (local (const ()) pure ()) ()+ ]+ -- print =<< storedItemsCount tsm
src/Control/Concurrent/Thread/Storage.hs view
@@ -18,10 +18,13 @@ -- means in practice that any unused contexts will cleaned up upon the next -- garbage collection and may not be actively freed when the program exits. ----- Note that this implementation of context sharing is--- mildly expensive for the garbage collector, hard to reason about without deep--- knowledge of the code you are instrumenting, and has limited guarantees of behavior --- across GHC versions due to internals usage.+-- Note: This library assumes that 'ThreadId's aren't reused before a finalizer runs to+-- clean up the 'ThreadStorageMap', so quick thread churn of this nature.+--+-- Also note: This implementation of context sharing is+-- mildly expensive (~40ns to 'attach' a value) relative to using pure code / idiomatic things +-- like MonadReader, hard to reason about without deep knowledge of threading in the code you are+-- using, and has limited guarantees of behavior across GHC versions due to internals usage. module Control.Concurrent.Thread.Storage ( -- * Create a 'ThreadStorageMap'@@ -47,109 +50,107 @@ import Control.Concurrent.Thread.Finalizers import Control.Monad ( void ) import Control.Monad.IO.Class+import Data.IORef import GHC.IO (IO(..)) import GHC.Int import GHC.Conc.Sync ( ThreadId(..) ) import GHC.Prim-import qualified Data.IntMap.Lazy as I+import qualified Data.IntMap.Strict as I import Foreign.C.Types import Prelude hiding (lookup) foreign import ccall unsafe "rts_getThreadId" c_getThreadId :: ThreadId# -> CInt -numStripes :: Int-numStripes = 32- getThreadId :: ThreadId -> Int getThreadId (ThreadId tid#) = fromIntegral (c_getThreadId tid#)--threadHash :: Int -> Int-threadHash = (`mod` numStripes)--readStripe :: ThreadStorageMap a -> ThreadId -> IO (I.IntMap a)-readStripe (ThreadStorageMap arr#) t = IO $ \s -> readArray# arr# tid# s- where- (I# tid#) = threadHash $ getThreadId t--atomicModifyStripe :: ThreadStorageMap a -> Int -> (I.IntMap a -> (I.IntMap a, b)) -> IO b-atomicModifyStripe (ThreadStorageMap arr#) tid f = IO $ \s -> go s- where- (I# stripe#) = threadHash tid- go s = case readArray# arr# stripe# s of- (# s1, intMap #) -> - let (updatedIntMap, result) = f intMap - in case casArray# arr# stripe# intMap updatedIntMap s1 of- (# s2, outcome, old #) -> case outcome of- 0# -> (# s2, result #)- 1# -> go s2- _ -> error "Got impossible result in atomicModifyStripe"+{-# INLINE getThreadId #-} -- | A storage mechanism for values of a type. This structure retains items -- on per-(green)thread basis, which can be useful in rare cases.-data ThreadStorageMap a = ThreadStorageMap (MutableArray# RealWorld (I.IntMap a))+newtype ThreadStorageMap a = ThreadStorageMap (IORef (I.IntMap a)) -- | Create a new thread storage map. The map is striped by thread -- into 32 sections in order to reduce contention. newThreadStorageMap :: MonadIO m => m (ThreadStorageMap a)-newThreadStorageMap = liftIO $ IO $ \s -> case newArray# numStripes# mempty s of- (# s1, ma #) -> (# s1, ThreadStorageMap ma #)- where- (I# numStripes#) = numStripes+newThreadStorageMap = liftIO (ThreadStorageMap <$> newIORef mempty) +readStripe :: ThreadStorageMap a -> IO (I.IntMap a)+readStripe (ThreadStorageMap tsm) = readIORef tsm+{-# INLINABLE readStripe #-}++atomicModifyStripe :: ThreadStorageMap a -> (I.IntMap a -> (I.IntMap a, b)) -> IO b+atomicModifyStripe (ThreadStorageMap tsm) f = atomicModifyIORef' tsm f+{-# INLINABLE atomicModifyStripe #-}+ -- | Retrieve a value if it exists for the current thread lookup :: MonadIO m => ThreadStorageMap a -> m (Maybe a) lookup tsm = liftIO $ do tid <- myThreadId lookupOnThread tsm tid+{-# INLINABLE lookup #-} -- | Retrieve a value if it exists for the specified thread lookupOnThread :: MonadIO m => ThreadStorageMap a -> ThreadId -> m (Maybe a) lookupOnThread tsm tid = liftIO $ do let threadAsInt = getThreadId tid- m <- readStripe tsm tid+ m <- readStripe tsm pure $ I.lookup threadAsInt m+{-# INLINABLE lookupOnThread #-} -- | Associate the provided value with the current thread-attach :: MonadIO m => ThreadStorageMap a -> a -> m ()+attach :: MonadIO m => ThreadStorageMap a -> a -> m (Maybe a) attach tsm x = liftIO $ do tid <- myThreadId attachOnThread tsm tid x+{-# INLINABLE attach #-} -- | Associate the provided value with the specified thread-attachOnThread :: MonadIO m => ThreadStorageMap a -> ThreadId -> a -> m ()+attachOnThread :: MonadIO m => ThreadStorageMap a -> ThreadId -> a -> m (Maybe a) attachOnThread tsm tid ctxt = liftIO $ do let threadAsInt = getThreadId tid- addThreadFinalizer tid $ cleanUp tsm threadAsInt- atomicModifyStripe tsm threadAsInt $ \m -> (I.insert threadAsInt ctxt m, ())+ old <- atomicModifyStripe tsm $ \m ->+ let (old, updated) = I.insertLookupWithKey (\_ n _ -> n) threadAsInt ctxt m+ in (updated, old) + case old of+ Nothing -> addThreadFinalizer tid $ cleanUp tsm threadAsInt+ Just _ -> pure ()++ pure old+{-# INLINABLE attachOnThread #-}+ -- | Disassociate the associated value from the current thread, returning it if it exists. detach :: MonadIO m => ThreadStorageMap a -> m (Maybe a) detach tsm = liftIO $ do tid <- myThreadId detachFromThread tsm tid+{-# INLINABLE detach #-} -- | Disassociate the associated value from the specified thread, returning it if it exists. detachFromThread :: MonadIO m => ThreadStorageMap a -> ThreadId -> m (Maybe a) detachFromThread tsm tid = liftIO $ do let threadAsInt = getThreadId tid- atomicModifyStripe tsm threadAsInt $ \m -> (I.delete threadAsInt m, I.lookup threadAsInt m)+ atomicModifyStripe tsm $ \m -> (I.delete threadAsInt m, I.lookup threadAsInt m)+{-# INLINABLE detachFromThread #-} -- | Update the associated value for the current thread if it is attached. adjust :: MonadIO m => ThreadStorageMap a -> (a -> a) -> m () adjust tsm f = liftIO $ do tid <- myThreadId adjustOnThread tsm tid f+{-# INLINABLE adjust #-} -- | Update the associated value for the specified thread if it is attached. adjustOnThread :: MonadIO m => ThreadStorageMap a -> ThreadId -> (a -> a) -> m () adjustOnThread tsm tid f = liftIO $ do let threadAsInt = getThreadId tid - atomicModifyStripe tsm threadAsInt $ \m -> (I.adjust f threadAsInt m, ())+ atomicModifyStripe tsm $ \m -> (I.adjust f threadAsInt m, ())+{-# INLINABLE adjustOnThread #-} -- Remove this context for thread from the map on finalization cleanUp :: ThreadStorageMap a -> Int -> IO ()-cleanUp tsm tid = atomicModifyStripe tsm tid $ \m -> +cleanUp (ThreadStorageMap tsm) tid = atomicModifyIORef tsm $ \m -> (I.delete tid m, ()) -- | List thread ids with live entries in the 'ThreadStorageMap'.@@ -157,10 +158,5 @@ -- This is useful for monitoring purposes to verify that there -- are no memory leaks retaining threads and thus preventing -- items from being freed from a 'ThreadStorageMap' -storedItems :: ThreadStorageMap a -> IO [Int]-storedItems tsm = do- stripes <- mapM (stripeByIndex tsm) [0..(numStripes - 1)]- pure $ concatMap I.keys stripes--stripeByIndex :: ThreadStorageMap a -> Int -> IO (I.IntMap a)-stripeByIndex (ThreadStorageMap arr#) (I# i#) = IO $ \s -> readArray# arr# i# s+storedItems :: ThreadStorageMap a -> IO [(Int, a)]+storedItems (ThreadStorageMap tsm) = I.toList <$> readIORef tsm
thread-utils-context.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: thread-utils-context-version: 0.1.0.0+version: 0.2.0.0 synopsis: Garbage-collected thread local storage description: Please see the README on GitHub at <https://github.com/iand675/thread-utils-context#readme> category: Concurrency@@ -51,6 +51,24 @@ base >=4.7 && <5 , containers , ghc-prim+ , thread-utils-context+ , thread-utils-finalizers+ default-language: Haskell2010++benchmark thread-utils-context-benchmarks+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ other-modules:+ Paths_thread_utils_context+ hs-source-dirs:+ bench+ ghc-options: -O2 -rtsopts -threaded -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , containers+ , criterion+ , ghc-prim+ , mtl , thread-utils-context , thread-utils-finalizers default-language: Haskell2010