More efficient hashThreadId.

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 @@
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MagicHash        #-}
+{-# LANGUAGE RankNTypes       #-}
+{-# LANGUAGE UnliftedFFITypes #-}
 module Control.Concurrent.Lifted.Instrument
     ( module Control.Concurrent.Lifted
     , forkLabeled
@@ -17,6 +19,9 @@ import qualified Control.Concurrent.Lifted as Raw
 import Control.Concurrent.Lifted hiding (fork,forkOS)
 import Control.Exception (fromException)
 import Control.Monad.Trans.Control
+import Foreign.C.Types
+import GHC.Exts (ThreadId#)
+import GHC.Conc (ThreadId(..))
 import GHC.Stack
 import System.IO.Unsafe
 import qualified Data.Map.Strict  as Map
@@ -45,13 +50,11 @@ data GlobalState = GlobalState
  { reportException :: String -> IO ()
  }
 
+foreign import ccall unsafe "rts_getThreadId" rts_getThreadId :: ThreadId# -> CInt
+
 hashThreadId :: ThreadId -> Int
-hashThreadId tid = hash 0 (dropThreadIdAndSPace (show tid))
-    where
-        dropThreadIdAndSPace ('T':'h':'r':'e':'a':'d':'I':'d':' ':xs) = xs
-        dropThreadIdAndSPace xs = xs
-        hash n xs = read xs `mod` 256
-        
+hashThreadId (ThreadId t) = fromIntegral (rts_getThreadId t) `mod` V.length globalMVarArray
+
 
 globals :: MVar GlobalState
 globals = unsafePerformIO $ newMVar $ GlobalState