1 files changed, 42 insertions, 0 deletions
diff --git a/libraries/base/GHC/Event/Unique.hs b/libraries/base/GHC/Event/Unique.hs
new file mode 100644
index 0000000000..f5093c9283
--- /dev/null
+++ b/libraries/base/GHC/Event/Unique.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, NoImplicitPrelude #-}
+module GHC.Event.Unique
+    (
+      UniqueSource
+    , Unique(..)
+    , newSource
+    , newUnique
+    ) where
+
+import Data.Int (Int64)
+import GHC.Base
+import GHC.Conc.Sync (TVar, atomically, newTVarIO, readTVar, writeTVar)
+import GHC.Num (Num(..))
+import GHC.Show (Show(..))
+
+-- We used to use IORefs here, but Simon switched us to STM when we
+-- found that our use of atomicModifyIORef was subject to a severe RTS
+-- performance problem when used in a tight loop from multiple
+-- threads: http://ghc.haskell.org/trac/ghc/ticket/3838
+--
+-- There seems to be no performance cost to using a TVar instead.
+
+newtype UniqueSource = US (TVar Int64)
+
+newtype Unique = Unique { asInt64 :: Int64 }
+    deriving (Eq, Ord, Num)
+
+instance Show Unique where
+    show = show . asInt64
+
+newSource :: IO UniqueSource
+newSource = US `fmap` newTVarIO 0
+
+newUnique :: UniqueSource -> IO Unique
+newUnique (US ref) = atomically $ do
+  u <- readTVar ref
+  let !u' = u+1
+  writeTVar ref u'
+  return $ Unique u'
+{-# INLINE newUnique #-}
+