thread-utils-context 0.3.0.1 → 0.3.0.2

raw patch · 2 files changed

+21/−20 lines, 2 files

Files

• src/Control/Concurrent/Thread/Storage.hs +20/−19
• thread-utils-context.cabal +1/−1

@@ -55,9 +55,10 @@  import Control.Concurrent import Control.Concurrent.Thread.Finalizers-import Control.Monad ( when, void )+import Control.Monad ( when, void, forM_ ) import Control.Monad.IO.Class import Data.Maybe (isNothing, isJust)+import Data.Word (Word64) import GHC.Base (Addr#) import GHC.IO (IO(..), mask_) import GHC.Int@@ -74,24 +75,24 @@  foreign import ccall unsafe "rts_getThreadId" c_getThreadId :: Addr# -> CULLong -numStripes :: Int+numStripes :: Word numStripes = 32 -getThreadId :: ThreadId -> Int+getThreadId :: ThreadId -> Word getThreadId (ThreadId tid#) = fromIntegral (c_getThreadId (unsafeCoerce# tid#)) -stripeHash :: Int -> Int-stripeHash = (`mod` numStripes) . abs+stripeHash :: Word -> Int+stripeHash = fromIntegral . (`mod` numStripes)  readStripe :: ThreadStorageMap a -> ThreadId -> IO (I.IntMap a) readStripe (ThreadStorageMap arr#) t = IO $ \s -> readArray# arr# tid# s   where     (I# tid#) = stripeHash $ getThreadId t -atomicModifyStripe :: ThreadStorageMap a -> Int -> (I.IntMap a -> (I.IntMap a, b)) -> IO b+atomicModifyStripe :: ThreadStorageMap a -> Word -> (I.IntMap a -> (I.IntMap a, b)) -> IO b atomicModifyStripe (ThreadStorageMap arr#) tid f = IO $ \s -> go s   where-    (I# stripe#) = stripeHash tid+    (I# stripe#) = fromIntegral $ stripeHash tid     go s = case readArray# arr# stripe# s of       (# s1, intMap #) ->         let (updatedIntMap, result) = f intMap @@ -113,7 +114,7 @@ newThreadStorageMap = liftIO $ IO $ \s -> case newArray# numStripes# mempty s of   (# s1, ma #) -> (# s1, ThreadStorageMap ma #)   where-    (I# numStripes#) = numStripes+    (I# numStripes#) = fromIntegral numStripes  -- | Retrieve a value if it exists for the current thread lookup :: MonadIO m => ThreadStorageMap a -> m (Maybe a)@@ -127,7 +128,7 @@   m <- readStripe tsm tid   pure $ I.lookup threadAsInt m   where -    threadAsInt = getThreadId tid+    threadAsInt = fromIntegral $ getThreadId tid  -- | Associate the provided value with the current thread. --@@ -160,20 +161,20 @@ updateOnThread :: MonadIO m => ThreadStorageMap a -> ThreadId -> (Maybe a -> (Maybe a, b)) -> m b updateOnThread tsm tid f = liftIO $ mask_ $ do   -- ^ We mask here in order to ensure that the finalizer will always be created-  (isNewThreadEntry, result) <- atomicModifyStripe tsm threadAsInt $ \m -> +  (isNewThreadEntry, result) <- atomicModifyStripe tsm threadAsWord $ \m ->      let (resultWithNewThreadDetection, m') =            I.alterF              (\x -> case f x of               (!x', !y) -> ((isNothing x && isJust x', y), x')             ) -            threadAsInt+            (fromIntegral threadAsWord)             m      in (m', resultWithNewThreadDetection)   when isNewThreadEntry $ do-    addThreadFinalizer tid $ cleanUp tsm threadAsInt+    addThreadFinalizer tid $ cleanUp tsm threadAsWord   pure result   where -    threadAsInt = getThreadId tid+    threadAsWord = getThreadId tid  update :: MonadIO m => ThreadStorageMap a -> (Maybe a -> (Maybe a, b)) -> m b update tsm f = liftIO $ do@@ -189,15 +190,15 @@ -- | 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-  atomicModifyStripe tsm threadAsInt $ \m -> (I.adjust f threadAsInt m, ())+  atomicModifyStripe tsm threadAsWord $ \m -> (I.adjust f (fromIntegral threadAsWord) m, ())   where -    threadAsInt = getThreadId tid +    threadAsWord = getThreadId tid   -- Remove this context for thread from the map on finalization-cleanUp :: ThreadStorageMap a -> Int -> IO ()+cleanUp :: ThreadStorageMap a -> Word -> IO () cleanUp tsm tid = do   atomicModifyStripe tsm tid $ \m -> -    (I.delete tid m, ())+    (I.delete (fromIntegral tid) m, ())  -- | List thread ids with live entries in the 'ThreadStorageMap'. -- @@ -206,7 +207,7 @@ -- items from being freed from a 'ThreadStorageMap'  storedItems :: ThreadStorageMap a -> IO [(Int, a)] storedItems tsm = do-  stripes <- mapM (stripeByIndex tsm) [0..(numStripes - 1)]+  stripes <- mapM (stripeByIndex tsm) [0..(fromIntegral numStripes - 1)]   pure $ concatMap I.toList stripes   where     stripeByIndex :: ThreadStorageMap a -> Int -> IO (I.IntMap a)@@ -215,7 +216,7 @@ #if MIN_VERSION_base(4,18,0) -- | This should generally not be needed, but may be used to remove values prior to GC-triggered finalizers being run from the 'ThreadStorageMap' for threads that have exited. purgeDeadThreads :: MonadIO m => ThreadStorageMap a -> m ()-purgeDeadThreads tsm = do+purgeDeadThreads tsm = liftIO $ do   tids <- listThreads   let threadSet = IS.fromList $ map getThreadId tids   forM_ [0..(numStripes - 1)] $ \stripe ->

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           thread-utils-context-version:        0.3.0.1+version:        0.3.0.2 synopsis:       Garbage-collected thread local storage description:    Please see the README on GitHub at <https://github.com/iand675/thread-utils-context#readme> category:       Concurrency