{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE UnboxedTuples #-}
-- | 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
    -- * 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
  ) where

import Control.Concurrent
import Control.Concurrent.Thread.Finalizers
import Control.Monad ( void )
import Control.Monad.IO.Class
import GHC.IO (IO(..))
import GHC.Int
import GHC.Conc.Sync ( ThreadId(..) )
import GHC.Prim
import qualified Data.IntMap.Lazy as I
import Foreign.C.Types
import Prelude hiding (lookup)

foreign import ccall unsafe "rts_getThreadId" c_getThreadId :: ThreadId# -> CInt

numStripes :: Int
numStripes :: Int
numStripes = Int
32

getThreadId :: ThreadId -> Int
getThreadId :: ThreadId -> Int
getThreadId (ThreadId ThreadId#
tid#) = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ThreadId# -> CInt
c_getThreadId ThreadId#
tid#)

threadHash :: Int -> Int
threadHash :: Int -> Int
threadHash = (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
numStripes)

readStripe :: ThreadStorageMap a -> ThreadId -> IO (I.IntMap a)
readStripe :: ThreadStorageMap a -> ThreadId -> IO (IntMap a)
readStripe (ThreadStorageMap MutableArray# RealWorld (IntMap a)
arr#) ThreadId
t = (State# RealWorld -> (# State# RealWorld, IntMap a #))
-> IO (IntMap a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, IntMap a #))
 -> IO (IntMap a))
-> (State# RealWorld -> (# State# RealWorld, IntMap a #))
-> IO (IntMap a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> MutableArray# RealWorld (IntMap a)
-> Int# -> State# RealWorld -> (# State# RealWorld, IntMap a #)
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#) = Int -> Int
threadHash (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ ThreadId -> Int
getThreadId ThreadId
t

atomicModifyStripe :: ThreadStorageMap a -> Int -> (I.IntMap a -> (I.IntMap a, b)) -> IO b
atomicModifyStripe :: ThreadStorageMap a -> Int -> (IntMap a -> (IntMap a, b)) -> IO b
atomicModifyStripe (ThreadStorageMap MutableArray# RealWorld (IntMap a)
arr#) Int
tid IntMap a -> (IntMap a, b)
f = (State# RealWorld -> (# State# RealWorld, b #)) -> IO b
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, b #)) -> IO b)
-> (State# RealWorld -> (# State# RealWorld, b #)) -> IO b
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> State# RealWorld -> (# State# RealWorld, b #)
go State# RealWorld
s
  where
    (I# Int#
stripe#) = Int -> Int
threadHash Int
tid
    go :: State# RealWorld -> (# State# RealWorld, b #)
go State# RealWorld
s = case MutableArray# RealWorld (IntMap a)
-> Int# -> State# RealWorld -> (# State# RealWorld, IntMap a #)
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 MutableArray# RealWorld (IntMap a)
-> Int#
-> IntMap a
-> IntMap a
-> State# RealWorld
-> (# State# RealWorld, Int#, IntMap a #)
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#
_ -> [Char] -> (# State# RealWorld, b #)
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 :: m (ThreadStorageMap a)
newThreadStorageMap = IO (ThreadStorageMap a) -> m (ThreadStorageMap a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ThreadStorageMap a) -> m (ThreadStorageMap a))
-> IO (ThreadStorageMap a) -> m (ThreadStorageMap a)
forall a b. (a -> b) -> a -> b
$ (State# RealWorld -> (# State# RealWorld, ThreadStorageMap a #))
-> IO (ThreadStorageMap a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, ThreadStorageMap a #))
 -> IO (ThreadStorageMap a))
-> (State# RealWorld -> (# State# RealWorld, ThreadStorageMap a #))
-> IO (ThreadStorageMap a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case Int#
-> IntMap a
-> State# RealWorld
-> (# State# RealWorld, MutableArray# RealWorld (IntMap a) #)
forall a d.
Int# -> a -> State# d -> (# State# d, MutableArray# d a #)
newArray# Int#
numStripes# IntMap a
forall a. Monoid a => a
mempty State# RealWorld
s of
  (# State# RealWorld
s1, MutableArray# RealWorld (IntMap a)
ma #) -> (# State# RealWorld
s1, MutableArray# RealWorld (IntMap a) -> ThreadStorageMap a
forall a. MutableArray# RealWorld (IntMap a) -> ThreadStorageMap a
ThreadStorageMap MutableArray# RealWorld (IntMap a)
ma #)
  where
    (I# Int#
numStripes#) = Int
numStripes

-- | Retrieve a value if it exists for the current thread
lookup :: MonadIO m => ThreadStorageMap a -> m (Maybe a)
lookup :: ThreadStorageMap a -> m (Maybe a)
lookup ThreadStorageMap a
tsm = IO (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> m (Maybe a)) -> IO (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
  ThreadId
tid <- IO ThreadId
myThreadId
  ThreadStorageMap a -> ThreadId -> IO (Maybe a)
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 :: ThreadStorageMap a -> ThreadId -> m (Maybe a)
lookupOnThread ThreadStorageMap a
tsm ThreadId
tid = IO (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> m (Maybe a)) -> IO (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
  let threadAsInt :: Int
threadAsInt = ThreadId -> Int
getThreadId ThreadId
tid
  IntMap a
m <- ThreadStorageMap a -> ThreadId -> IO (IntMap a)
forall a. ThreadStorageMap a -> ThreadId -> IO (IntMap a)
readStripe ThreadStorageMap a
tsm ThreadId
tid
  Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
I.lookup Int
threadAsInt IntMap a
m

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

-- | Associate the provided value with the specified thread
attachOnThread :: MonadIO m => ThreadStorageMap a -> ThreadId -> a -> m ()
attachOnThread :: ThreadStorageMap a -> ThreadId -> a -> m ()
attachOnThread ThreadStorageMap a
tsm ThreadId
tid a
ctxt = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  let threadAsInt :: Int
threadAsInt = ThreadId -> Int
getThreadId ThreadId
tid
  ThreadId -> IO () -> IO ()
addThreadFinalizer ThreadId
tid (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadStorageMap a -> Int -> IO ()
forall a. ThreadStorageMap a -> Int -> IO ()
cleanUp ThreadStorageMap a
tsm Int
threadAsInt
  ThreadStorageMap a -> Int -> (IntMap a -> (IntMap a, ())) -> IO ()
forall a b.
ThreadStorageMap a -> Int -> (IntMap a -> (IntMap a, b)) -> IO b
atomicModifyStripe ThreadStorageMap a
tsm Int
threadAsInt ((IntMap a -> (IntMap a, ())) -> IO ())
-> (IntMap a -> (IntMap a, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap a
m -> (Int -> a -> IntMap a -> IntMap a
forall a. Int -> a -> IntMap a -> IntMap a
I.insert Int
threadAsInt a
ctxt IntMap a
m, ())

-- | Disassociate the associated value from the current thread, returning it if it exists.
detach :: MonadIO m => ThreadStorageMap a -> m (Maybe a)
detach :: ThreadStorageMap a -> m (Maybe a)
detach ThreadStorageMap a
tsm = IO (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> m (Maybe a)) -> IO (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
  ThreadId
tid <- IO ThreadId
myThreadId
  ThreadStorageMap a -> ThreadId -> IO (Maybe a)
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 :: ThreadStorageMap a -> ThreadId -> m (Maybe a)
detachFromThread ThreadStorageMap a
tsm ThreadId
tid = IO (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> m (Maybe a)) -> IO (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
  let threadAsInt :: Int
threadAsInt = ThreadId -> Int
getThreadId ThreadId
tid
  ThreadStorageMap a
-> Int -> (IntMap a -> (IntMap a, Maybe a)) -> IO (Maybe a)
forall a b.
ThreadStorageMap a -> Int -> (IntMap a -> (IntMap a, b)) -> IO b
atomicModifyStripe ThreadStorageMap a
tsm Int
threadAsInt ((IntMap a -> (IntMap a, Maybe a)) -> IO (Maybe a))
-> (IntMap a -> (IntMap a, Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \IntMap a
m -> (Int -> IntMap a -> IntMap a
forall a. Int -> IntMap a -> IntMap a
I.delete Int
threadAsInt IntMap a
m, Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
I.lookup Int
threadAsInt IntMap a
m)

-- | Update the associated value for the current thread if it is attached.
adjust :: MonadIO m => ThreadStorageMap a -> (a -> a) -> m ()
adjust :: ThreadStorageMap a -> (a -> a) -> m ()
adjust ThreadStorageMap a
tsm a -> a
f = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  ThreadId
tid <- IO ThreadId
myThreadId
  ThreadStorageMap a -> ThreadId -> (a -> a) -> IO ()
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 :: ThreadStorageMap a -> ThreadId -> (a -> a) -> m ()
adjustOnThread ThreadStorageMap a
tsm ThreadId
tid a -> a
f = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  let threadAsInt :: Int
threadAsInt = ThreadId -> Int
getThreadId ThreadId
tid 
  ThreadStorageMap a -> Int -> (IntMap a -> (IntMap a, ())) -> IO ()
forall a b.
ThreadStorageMap a -> Int -> (IntMap a -> (IntMap a, b)) -> IO b
atomicModifyStripe ThreadStorageMap a
tsm Int
threadAsInt ((IntMap a -> (IntMap a, ())) -> IO ())
-> (IntMap a -> (IntMap a, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap a
m -> ((a -> a) -> Int -> IntMap a -> IntMap a
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
I.adjust a -> a
f Int
threadAsInt IntMap a
m, ())

-- Remove this context for thread from the map on finalization
cleanUp :: ThreadStorageMap a -> Int -> IO ()
cleanUp :: ThreadStorageMap a -> Int -> IO ()
cleanUp ThreadStorageMap a
tsm Int
tid = ThreadStorageMap a -> Int -> (IntMap a -> (IntMap a, ())) -> IO ()
forall a b.
ThreadStorageMap a -> Int -> (IntMap a -> (IntMap a, b)) -> IO b
atomicModifyStripe ThreadStorageMap a
tsm Int
tid ((IntMap a -> (IntMap a, ())) -> IO ())
-> (IntMap a -> (IntMap a, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IntMap a
m -> 
  (Int -> IntMap a -> IntMap a
forall a. Int -> IntMap a -> IntMap a
I.delete Int
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]
storedItems :: ThreadStorageMap a -> IO [Int]
storedItems ThreadStorageMap a
tsm = do
  [IntMap a]
stripes <- (Int -> IO (IntMap a)) -> [Int] -> IO [IntMap a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ThreadStorageMap a -> Int -> IO (IntMap a)
forall a. ThreadStorageMap a -> Int -> IO (IntMap a)
stripeByIndex ThreadStorageMap a
tsm) [Int
0..(Int
numStripes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
  [Int] -> IO [Int]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int] -> IO [Int]) -> [Int] -> IO [Int]
forall a b. (a -> b) -> a -> b
$ (IntMap a -> [Int]) -> [IntMap a] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap IntMap a -> [Int]
forall a. IntMap a -> [Int]
I.keys [IntMap a]
stripes

stripeByIndex :: ThreadStorageMap a -> Int -> IO (I.IntMap a)
stripeByIndex :: ThreadStorageMap a -> Int -> IO (IntMap a)
stripeByIndex (ThreadStorageMap MutableArray# RealWorld (IntMap a)
arr#) (I# Int#
i#) = (State# RealWorld -> (# State# RealWorld, IntMap a #))
-> IO (IntMap a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, IntMap a #))
 -> IO (IntMap a))
-> (State# RealWorld -> (# State# RealWorld, IntMap a #))
-> IO (IntMap a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> MutableArray# RealWorld (IntMap a)
-> Int# -> State# RealWorld -> (# State# RealWorld, IntMap a #)
forall d a.
MutableArray# d a -> Int# -> State# d -> (# State# d, a #)
readArray# MutableArray# RealWorld (IntMap a)
arr# Int#
i# State# RealWorld
s