{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
-- | A perilous implementation of thread-local storage for Haskell.
-- This module uses a fair amount of GHC internals to enable performing
-- lookups of context for any threads that are alive. Caution should be
-- taken for consumers of this module to not retain ThreadId references
-- indefinitely, as that could delay cleanup of thread-local state.
--
-- Thread-local contexts have the following semantics:
--
-- - A value 'attach'ed to a 'ThreadId' will remain alive at least as long
--   as the 'ThreadId'. 
-- - A value may be detached from a 'ThreadId' via 'detach' by the
--   library consumer without detriment.
-- - No guarantees are made about when a value will be garbage-collected
--   once all references to 'ThreadId' have been dropped. However, this simply
--   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.
module Control.Concurrent.Thread.Storage 
  ( 
    -- * Create a 'ThreadStorageMap'
    ThreadStorageMap
  , newThreadStorageMap
    -- * Retrieve values from a 'ThreadStorageMap'
  , lookup
  , lookupOnThread
    -- * Update values in a 'ThreadStorageMap'
  , update
  , updateOnThread
    -- * Associate values with a thread in a 'ThreadStorageMap'
  , attach
  , attachOnThread
    -- * Remove values from a thread in a 'ThreadStorageMap'
  , detach
  , detachFromThread
    -- * Update values for a thread in a 'ThreadStorageMap'
  , adjust
  , adjustOnThread
    -- * Monitoring utilities
  , storedItems
    -- * Thread ID manipulation
  , getThreadId
#if MIN_VERSION_base(4,18,0)
  , purgeDeadThreads
#endif
  ) where

import Control.Concurrent
import Control.Concurrent.Thread.Finalizers
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
#if MIN_VERSION_base(4,18,0)
import GHC.Conc (listThreads)
#endif
import GHC.Conc.Sync ( ThreadId(..) )
import GHC.Prim
import qualified Data.IntMap.Strict as I
import qualified Data.IntSet as IS
import Foreign.C.Types
import Prelude hiding (lookup)
import GHC.Exts (unsafeCoerce#)

foreign import ccall unsafe "rts_getThreadId" c_getThreadId :: Addr# -> CULLong

numStripes :: Word
numStripes :: Word
numStripes = Word
32

getThreadId :: ThreadId -> Word
getThreadId :: ThreadId -> Word
getThreadId (ThreadId ThreadId#
tid#) = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Addr# -> CULLong
c_getThreadId (unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# ThreadId#
tid#))

stripeHash :: Word -> Int
stripeHash :: Word -> Int
stripeHash = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Integral a => a -> a -> a
`mod` Word
numStripes)

readStripe :: ThreadStorageMap a -> ThreadId -> IO (I.IntMap a)
readStripe :: forall a. ThreadStorageMap a -> ThreadId -> IO (IntMap a)
readStripe (ThreadStorageMap MutableArray# RealWorld (IntMap a)
arr#) ThreadId
t = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> forall d a.
MutableArray# d a -> Int# -> State# d -> (# State# d, a #)
readArray# MutableArray# RealWorld (IntMap a)
arr# Int#
tid# State# RealWorld
s
  where
    (I# Int#
tid#) = Word -> Int
stripeHash forall a b. (a -> b) -> a -> b
$ ThreadId -> Word
getThreadId ThreadId
t

atomicModifyStripe :: ThreadStorageMap a -> Word -> (I.IntMap a -> (I.IntMap a, b)) -> IO b
atomicModifyStripe :: forall a b.
ThreadStorageMap a -> Word -> (IntMap a -> (IntMap a, b)) -> IO b
atomicModifyStripe (ThreadStorageMap MutableArray# RealWorld (IntMap a)
arr#) Word
tid IntMap a -> (IntMap a, b)
f = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> State# RealWorld -> (# State# RealWorld, b #)
go State# RealWorld
s
  where
    (I# Int#
stripe#) = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word -> Int
stripeHash Word
tid
    go :: State# RealWorld -> (# State# RealWorld, b #)
go State# RealWorld
s = case forall d a.
MutableArray# d a -> Int# -> State# d -> (# State# d, a #)
readArray# MutableArray# RealWorld (IntMap a)
arr# Int#
stripe# State# RealWorld
s of
      (# State# RealWorld
s1, IntMap a
intMap #) ->
        let (IntMap a
updatedIntMap, b
result) = IntMap a -> (IntMap a, b)
f IntMap a
intMap 
        in case forall d a.
MutableArray# d a
-> Int# -> a -> a -> State# d -> (# State# d, Int#, a #)
casArray# MutableArray# RealWorld (IntMap a)
arr# Int#
stripe# IntMap a
intMap IntMap a
updatedIntMap State# RealWorld
s1 of
             (# State# RealWorld
s2, Int#
outcome, IntMap a
old #) -> case Int#
outcome of
               Int#
0# -> (# State# RealWorld
s2, b
result #)
               Int#
1# -> State# RealWorld -> (# State# RealWorld, b #)
go State# RealWorld
s2
               Int#
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Got impossible result in atomicModifyStripe"
          
-- | 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))

-- | 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 :: forall (m :: * -> *) a. MonadIO m => m (ThreadStorageMap a)
newThreadStorageMap = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case forall a d.
Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArray# Int#
numStripes# forall a. Monoid a => a
mempty State# RealWorld
s of
  (# State# RealWorld
s1, MutableArray# RealWorld (IntMap a)
ma #) -> (# State# RealWorld
s1, forall a. MutableArray# RealWorld (IntMap a) -> ThreadStorageMap a
ThreadStorageMap MutableArray# RealWorld (IntMap a)
ma #)
  where
    (I# Int#
numStripes#) = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
numStripes

-- | Retrieve a value if it exists for the current thread
lookup :: MonadIO m => ThreadStorageMap a -> m (Maybe a)
lookup :: forall (m :: * -> *) a.
MonadIO m =>
ThreadStorageMap a -> m (Maybe a)
lookup ThreadStorageMap a
tsm = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  ThreadId
tid <- IO ThreadId
myThreadId
  forall (m :: * -> *) a.
MonadIO m =>
ThreadStorageMap a -> ThreadId -> m (Maybe a)
lookupOnThread ThreadStorageMap a
tsm ThreadId
tid

-- | Retrieve a value if it exists for the specified thread
lookupOnThread :: MonadIO m => ThreadStorageMap a -> ThreadId -> m (Maybe a)
lookupOnThread :: forall (m :: * -> *) a.
MonadIO m =>
ThreadStorageMap a -> ThreadId -> m (Maybe a)
lookupOnThread ThreadStorageMap a
tsm ThreadId
tid = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  IntMap a
m <- forall a. ThreadStorageMap a -> ThreadId -> IO (IntMap a)
readStripe ThreadStorageMap a
tsm ThreadId
tid
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
I.lookup Int
threadAsInt IntMap a
m
  where 
    threadAsInt :: Int
threadAsInt = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ThreadId -> Word
getThreadId ThreadId
tid

-- | Associate the provided value with the current thread.
--
-- Returns the previous value if it was set.
attach :: MonadIO m => ThreadStorageMap a -> a -> m (Maybe a)
attach :: forall (m :: * -> *) a.
MonadIO m =>
ThreadStorageMap a -> a -> m (Maybe a)
attach ThreadStorageMap a
tsm a
x = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  ThreadId
tid <- IO ThreadId
myThreadId
  forall (m :: * -> *) a.
MonadIO m =>
ThreadStorageMap a -> ThreadId -> a -> m (Maybe a)
attachOnThread ThreadStorageMap a
tsm ThreadId
tid a
x

-- | Associate the provided value with the specified thread. This replaces
-- any values already associated with the 'ThreadId'.
attachOnThread :: MonadIO m => ThreadStorageMap a -> ThreadId -> a -> m (Maybe a)
attachOnThread :: forall (m :: * -> *) a.
MonadIO m =>
ThreadStorageMap a -> ThreadId -> a -> m (Maybe a)
attachOnThread ThreadStorageMap a
tsm ThreadId
tid a
ctxt = 
  forall (m :: * -> *) a b.
MonadIO m =>
ThreadStorageMap a -> ThreadId -> (Maybe a -> (Maybe a, b)) -> m b
updateOnThread ThreadStorageMap a
tsm ThreadId
tid (\Maybe a
prev -> (forall a. a -> Maybe a
Just a
ctxt, Maybe a
prev))

-- | Disassociate the associated value from the current thread, returning it if it exists.
detach :: MonadIO m => ThreadStorageMap a -> m (Maybe a)
detach :: forall (m :: * -> *) a.
MonadIO m =>
ThreadStorageMap a -> m (Maybe a)
detach ThreadStorageMap a
tsm = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  ThreadId
tid <- IO ThreadId
myThreadId
  forall (m :: * -> *) a.
MonadIO m =>
ThreadStorageMap a -> ThreadId -> m (Maybe a)
detachFromThread ThreadStorageMap a
tsm ThreadId
tid

-- | Disassociate the associated value from the specified thread, returning it if it exists.
detachFromThread :: MonadIO m => ThreadStorageMap a -> ThreadId -> m (Maybe a)
detachFromThread :: forall (m :: * -> *) a.
MonadIO m =>
ThreadStorageMap a -> ThreadId -> m (Maybe a)
detachFromThread ThreadStorageMap a
tsm ThreadId
tid = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  let threadAsInt :: Word
threadAsInt = ThreadId -> Word
getThreadId ThreadId
tid
  forall (m :: * -> *) a b.
MonadIO m =>
ThreadStorageMap a -> ThreadId -> (Maybe a -> (Maybe a, b)) -> m b
updateOnThread ThreadStorageMap a
tsm ThreadId
tid (\Maybe a
prev -> (forall a. Maybe a
Nothing, Maybe a
prev))

-- | The most general function in this library. Update a 'ThreadStorageMap' on a given thread,
-- with the ability to add or remove values and return some sort of result.
updateOnThread :: MonadIO m => ThreadStorageMap a -> ThreadId -> (Maybe a -> (Maybe a, b)) -> m b
updateOnThread :: forall (m :: * -> *) a b.
MonadIO m =>
ThreadStorageMap a -> ThreadId -> (Maybe a -> (Maybe a, b)) -> m b
updateOnThread ThreadStorageMap a
tsm ThreadId
tid Maybe a -> (Maybe a, b)
f = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
  -- ^ We mask here in order to ensure that the finalizer will always be created
  (Bool
isNewThreadEntry, b
result) <- forall a b.
ThreadStorageMap a -> Word -> (IntMap a -> (IntMap a, b)) -> IO b
atomicModifyStripe ThreadStorageMap a
tsm Word
threadAsWord forall a b. (a -> b) -> a -> b
$ \IntMap a
m -> 
    let ((Bool, b)
resultWithNewThreadDetection, IntMap a
m') = 
          forall (f :: * -> *) a.
Functor f =>
(Maybe a -> f (Maybe a)) -> Int -> IntMap a -> f (IntMap a)
I.alterF 
            (\Maybe a
x -> case Maybe a -> (Maybe a, b)
f Maybe a
x of
              (!Maybe a
x', !b
y) -> ((forall a. Maybe a -> Bool
isNothing Maybe a
x Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe a
x', b
y), Maybe a
x')
            ) 
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
threadAsWord)
            IntMap a
m
     in (IntMap a
m', (Bool, b)
resultWithNewThreadDetection)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isNewThreadEntry forall a b. (a -> b) -> a -> b
$ do
    ThreadId -> IO () -> IO ()
addThreadFinalizer ThreadId
tid forall a b. (a -> b) -> a -> b
$ forall a. ThreadStorageMap a -> Word -> IO ()
cleanUp ThreadStorageMap a
tsm Word
threadAsWord
  forall (f :: * -> *) a. Applicative f => a -> f a
pure b
result
  where 
    threadAsWord :: Word
threadAsWord = ThreadId -> Word
getThreadId ThreadId
tid

update :: MonadIO m => ThreadStorageMap a -> (Maybe a -> (Maybe a, b)) -> m b
update :: forall (m :: * -> *) a b.
MonadIO m =>
ThreadStorageMap a -> (Maybe a -> (Maybe a, b)) -> m b
update ThreadStorageMap a
tsm Maybe a -> (Maybe a, b)
f = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  ThreadId
tid <- IO ThreadId
myThreadId
  forall (m :: * -> *) a b.
MonadIO m =>
ThreadStorageMap a -> ThreadId -> (Maybe a -> (Maybe a, b)) -> m b
updateOnThread ThreadStorageMap a
tsm ThreadId
tid Maybe a -> (Maybe a, b)
f

-- | Update the associated value for the current thread if it is attached.
adjust :: MonadIO m => ThreadStorageMap a -> (a -> a) -> m ()
adjust :: forall (m :: * -> *) a.
MonadIO m =>
ThreadStorageMap a -> (a -> a) -> m ()
adjust ThreadStorageMap a
tsm a -> a
f = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  ThreadId
tid <- IO ThreadId
myThreadId
  forall (m :: * -> *) a.
MonadIO m =>
ThreadStorageMap a -> ThreadId -> (a -> a) -> m ()
adjustOnThread ThreadStorageMap a
tsm ThreadId
tid a -> a
f

-- | Update the associated value for the specified thread if it is attached.
adjustOnThread :: MonadIO m => ThreadStorageMap a -> ThreadId -> (a -> a) -> m ()
adjustOnThread :: forall (m :: * -> *) a.
MonadIO m =>
ThreadStorageMap a -> ThreadId -> (a -> a) -> m ()
adjustOnThread ThreadStorageMap a
tsm ThreadId
tid a -> a
f = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  forall a b.
ThreadStorageMap a -> Word -> (IntMap a -> (IntMap a, b)) -> IO b
atomicModifyStripe ThreadStorageMap a
tsm Word
threadAsWord forall a b. (a -> b) -> a -> b
$ \IntMap a
m -> (forall a. (a -> a) -> Int -> IntMap a -> IntMap a
I.adjust a -> a
f (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
threadAsWord) IntMap a
m, ())
  where 
    threadAsWord :: Word
threadAsWord = ThreadId -> Word
getThreadId ThreadId
tid 

-- Remove this context for thread from the map on finalization
cleanUp :: ThreadStorageMap a -> Word -> IO ()
cleanUp :: forall a. ThreadStorageMap a -> Word -> IO ()
cleanUp ThreadStorageMap a
tsm Word
tid = do
  forall a b.
ThreadStorageMap a -> Word -> (IntMap a -> (IntMap a, b)) -> IO b
atomicModifyStripe ThreadStorageMap a
tsm Word
tid forall a b. (a -> b) -> a -> b
$ \IntMap a
m -> 
    (forall a. Int -> IntMap a -> IntMap a
I.delete (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
tid) IntMap a
m, ())

-- | List thread ids with live entries in the 'ThreadStorageMap'.
-- 
-- 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, a)]
storedItems :: forall a. ThreadStorageMap a -> IO [(Int, a)]
storedItems ThreadStorageMap a
tsm = do
  [IntMap a]
stripes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. ThreadStorageMap a -> Int -> IO (IntMap a)
stripeByIndex ThreadStorageMap a
tsm) [Int
0..(forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
numStripes forall a. Num a => a -> a -> a
- Int
1)]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. IntMap a -> [(Int, a)]
I.toList [IntMap a]
stripes
  where
    stripeByIndex :: ThreadStorageMap a -> Int -> IO (I.IntMap a)
    stripeByIndex :: forall a. ThreadStorageMap a -> Int -> IO (IntMap a)
stripeByIndex (ThreadStorageMap MutableArray# RealWorld (IntMap a)
arr#) (I# Int#
i#) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> forall d a.
MutableArray# d a -> Int# -> State# d -> (# State# d, a #)
readArray# MutableArray# RealWorld (IntMap a)
arr# Int#
i# State# RealWorld
s

#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 = liftIO $ do
  tids <- listThreads
  let threadSet = IS.fromList $ map (fromIntegral . getThreadId) tids
  forM_ [0..(numStripes - 1)] $ \stripe ->
    atomicModifyStripe tsm stripe $ \im -> (I.restrictKeys im threadSet, ())
#endif