diff options
Diffstat (limited to 'lifted-concurrent/src')
-rw-r--r-- | lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs | 17 |
1 files changed, 10 insertions, 7 deletions
diff --git a/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs b/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs index b4a67583..d886f939 100644 --- a/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs +++ b/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs | |||
@@ -1,5 +1,7 @@ | |||
1 | {-# LANGUAGE FlexibleContexts #-} | 1 | {-# LANGUAGE FlexibleContexts #-} |
2 | {-# LANGUAGE RankNTypes #-} | 2 | {-# LANGUAGE MagicHash #-} |
3 | {-# LANGUAGE RankNTypes #-} | ||
4 | {-# LANGUAGE UnliftedFFITypes #-} | ||
3 | module Control.Concurrent.Lifted.Instrument | 5 | module Control.Concurrent.Lifted.Instrument |
4 | ( module Control.Concurrent.Lifted | 6 | ( module Control.Concurrent.Lifted |
5 | , forkLabeled | 7 | , forkLabeled |
@@ -17,6 +19,9 @@ import qualified Control.Concurrent.Lifted as Raw | |||
17 | import Control.Concurrent.Lifted hiding (fork,forkOS) | 19 | import Control.Concurrent.Lifted hiding (fork,forkOS) |
18 | import Control.Exception (fromException) | 20 | import Control.Exception (fromException) |
19 | import Control.Monad.Trans.Control | 21 | import Control.Monad.Trans.Control |
22 | import Foreign.C.Types | ||
23 | import GHC.Exts (ThreadId#) | ||
24 | import GHC.Conc (ThreadId(..)) | ||
20 | import GHC.Stack | 25 | import GHC.Stack |
21 | import System.IO.Unsafe | 26 | import System.IO.Unsafe |
22 | import qualified Data.Map.Strict as Map | 27 | import qualified Data.Map.Strict as Map |
@@ -45,13 +50,11 @@ data GlobalState = GlobalState | |||
45 | { reportException :: String -> IO () | 50 | { reportException :: String -> IO () |
46 | } | 51 | } |
47 | 52 | ||
53 | foreign import ccall unsafe "rts_getThreadId" rts_getThreadId :: ThreadId# -> CInt | ||
54 | |||
48 | hashThreadId :: ThreadId -> Int | 55 | hashThreadId :: ThreadId -> Int |
49 | hashThreadId tid = hash 0 (dropThreadIdAndSPace (show tid)) | 56 | hashThreadId (ThreadId t) = fromIntegral (rts_getThreadId t) `mod` V.length globalMVarArray |
50 | where | 57 | |
51 | dropThreadIdAndSPace ('T':'h':'r':'e':'a':'d':'I':'d':' ':xs) = xs | ||
52 | dropThreadIdAndSPace xs = xs | ||
53 | hash n xs = read xs `mod` 256 | ||
54 | |||
55 | 58 | ||
56 | globals :: MVar GlobalState | 59 | globals :: MVar GlobalState |
57 | globals = unsafePerformIO $ newMVar $ GlobalState | 60 | globals = unsafePerformIO $ newMVar $ GlobalState |