Fix setStdGen not being thread safe

.github/workflows/ci.yaml

@@ -224,12 +224,12 @@ jobs:
       run: |
         set -ex
         if [ "${{ matrix.os }}.${{ matrix.resolver }}" == "ubuntu-latest.lts-19" ] && [ -n "${COVERALLS_TOKEN}" ]; then
-          stack $STACK_ARGS test :spec :legacy-test --coverage --haddock --no-haddock-deps
+          stack $STACK_ARGS test :spec :legacy-test --coverage $HADDOCK
           stack $STACK_ARGS hpc report --all
           curl -L https://github.com/rubik/stack-hpc-coveralls/releases/download/v0.0.7.0/shc-Linux-X64.tar.bz2 | tar xj shc
           ./shc --repo-token="$COVERALLS_TOKEN" --partial-coverage --fetch-coverage combined custom
         else
-          stack $STACK_ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
+          stack $STACK_ARGS test --bench --no-run-benchmarks $HADDOCK
         fi
 
   i386:

CHANGELOG.md

@@ -1,3 +1,8 @@
+# 1.3.2
+
+* Fix `setStdGen` not being threadsafe: [#190](https://github.com/haskell/random/pull/190)
+* Make `getStdRandom` lazy in the value being generated: [#190](https://github.com/haskell/random/pull/190)
+
 # 1.3.1
 
 * Add missing `SplitGen` instance for `StateGen`: [#183](https://github.com/haskell/random/pull/183)

random.cabal

@@ -1,6 +1,6 @@
 cabal-version:      >=1.10
 name:               random
-version:            1.3.1
+version:            1.3.2
 license:            BSD3
 license-file:       LICENSE
 maintainer:         [email protected]

src/System/Random.hs

@@ -102,6 +102,7 @@ import Control.Monad.State.Strict
 import Data.Array.Byte (ByteArray (..), MutableByteArray (..))
 import Data.ByteString (ByteString)
 import Data.ByteString.Short.Internal (ShortByteString (..))
+import Data.Coerce
 import Data.IORef
 import Data.Int
 import Data.Word
@@ -747,7 +748,7 @@ instance
 --
 -- @since 1.0.0
 setStdGen :: MonadIO m => StdGen -> m ()
-setStdGen = liftIO . writeIORef theStdGen
+setStdGen g = getStdRandom (const ((), g))
 
 -- | Gets the global pseudo-random number generator. Extracts the contents of
 -- 'System.Random.Stateful.globalStdGen'
@@ -785,9 +786,7 @@ newStdGen = liftIO $ atomicModifyIORef' theStdGen splitGen
 --
 -- @since 1.0.0
 getStdRandom :: MonadIO m => (StdGen -> (a, StdGen)) -> m a
-getStdRandom f = liftIO $ atomicModifyIORef' theStdGen (swap . f)
-  where
-    swap (v, g) = (g, v)
+getStdRandom f = modifyGen globalStdGen (coerce f)
 
 -- | A variant of 'System.Random.Stateful.randomRM' that uses the global
 -- pseudo-random number generator 'System.Random.Stateful.globalStdGen'

src/System/Random/Internal.hs

@@ -37,6 +37,13 @@ module System.Random.Internal (
   splitGenM,
   splitMutableGenM,
 
+  -- * Atomic and Global
+  AtomicGen (..),
+  AtomicGenM (..),
+  newAtomicGenM,
+  applyAtomicGen,
+  globalStdGen,
+
   -- ** Standard pseudo-random number generator
   StdGen (..),
   mkStdGen,
@@ -99,14 +106,15 @@ import Control.Arrow
 import Control.DeepSeq (NFData)
 import Control.Monad (replicateM, when, (>=>))
 import Control.Monad.Cont (ContT, runContT)
+import Control.Monad.IO.Class
 import Control.Monad.ST
 import Control.Monad.State.Strict (MonadState (..), State, StateT (..), execStateT, runState)
 import Control.Monad.Trans (MonadTrans, lift)
 import Control.Monad.Trans.Identity (IdentityT (runIdentityT))
 import Data.Array.Byte (ByteArray (..), MutableByteArray (..))
 import Data.Bits
 import Data.ByteString.Short.Internal (ShortByteString (SBS))
-import Data.IORef (IORef, newIORef)
+import Data.IORef
 import Data.Int
 import Data.Kind
 import Data.Word
@@ -123,6 +131,9 @@ import System.Random.Array
 import System.Random.GFinite (Cardinality (..), Finite, GFinite (..))
 import qualified System.Random.SplitMix as SM
 import qualified System.Random.SplitMix32 as SM32
+#if __GLASGOW_HASKELL__ >= 808
+import GHC.IORef (atomicModifyIORef2Lazy)
+#endif
 
 -- | This is a binary form of pseudo-random number generator's state. It is designed to be
 -- safe and easy to use for input/output operations like restoring from file, transmitting
@@ -1832,6 +1843,100 @@ instance
   ) =>
   UniformRange (a, b, c, d, e, f, g)
 
+-- | Wraps an 'IORef' that holds a pure pseudo-random number generator. All
+-- operations are performed atomically.
+--
+-- *   'AtomicGenM' is safe in the presence of exceptions and concurrency.
+-- *   'AtomicGenM' is the slowest of the monadic adapters due to the overhead
+--     of its atomic operations.
+--
+-- @since 1.2.0
+newtype AtomicGenM g = AtomicGenM {unAtomicGenM :: IORef g}
+
+-- | Frozen version of mutable `AtomicGenM` generator
+--
+-- @since 1.2.0
+newtype AtomicGen g = AtomicGen {unAtomicGen :: g}
+  deriving (Eq, Ord, Show, RandomGen, SplitGen, Storable, NFData)
+
+-- | Creates a new 'AtomicGenM'.
+--
+-- @since 1.2.0
+newAtomicGenM :: MonadIO m => g -> m (AtomicGenM g)
+newAtomicGenM = fmap AtomicGenM . liftIO . newIORef
+
+-- | Global mutable standard pseudo-random number generator. This is the same
+-- generator that was historically used by `randomIO` and `randomRIO` functions.
+--
+-- >>> import Control.Monad (replicateM)
+-- >>> replicateM 10 (uniformRM ('a', 'z') globalStdGen)
+-- "..."
+--
+-- @since 1.2.1
+globalStdGen :: AtomicGenM StdGen
+globalStdGen = AtomicGenM theStdGen
+
+instance (RandomGen g, MonadIO m) => StatefulGen (AtomicGenM g) m where
+  uniformWord32R r = applyAtomicGen (genWord32R r)
+  {-# INLINE uniformWord32R #-}
+  uniformWord64R r = applyAtomicGen (genWord64R r)
+  {-# INLINE uniformWord64R #-}
+  uniformWord8 = applyAtomicGen genWord8
+  {-# INLINE uniformWord8 #-}
+  uniformWord16 = applyAtomicGen genWord16
+  {-# INLINE uniformWord16 #-}
+  uniformWord32 = applyAtomicGen genWord32
+  {-# INLINE uniformWord32 #-}
+  uniformWord64 = applyAtomicGen genWord64
+  {-# INLINE uniformWord64 #-}
+
+instance (RandomGen g, MonadIO m) => FrozenGen (AtomicGen g) m where
+  type MutableGen (AtomicGen g) m = AtomicGenM g
+  freezeGen = fmap AtomicGen . liftIO . readIORef . unAtomicGenM
+  modifyGen (AtomicGenM ioRef) f =
+    liftIO $ atomicModifyIORefHS ioRef $ \g ->
+      case f (AtomicGen g) of
+        (a, AtomicGen g') -> (g', a)
+  {-# INLINE modifyGen #-}
+
+instance (RandomGen g, MonadIO m) => ThawedGen (AtomicGen g) m where
+  thawGen (AtomicGen g) = newAtomicGenM g
+
+-- | Atomically applies a pure operation to the wrapped pseudo-random number
+-- generator.
+--
+-- ====__Examples__
+--
+-- >>> import System.Random.Stateful
+-- >>> let pureGen = mkStdGen 137
+-- >>> g <- newAtomicGenM pureGen
+-- >>> applyAtomicGen random g :: IO Int
+-- 7879794327570578227
+--
+-- @since 1.2.0
+applyAtomicGen :: MonadIO m => (g -> (a, g)) -> AtomicGenM g -> m a
+applyAtomicGen op (AtomicGenM gVar) =
+  liftIO $ atomicModifyIORefHS gVar $ \g ->
+    case op g of
+      (a, g') -> (g', a)
+{-# INLINE applyAtomicGen #-}
+
+-- HalfStrict version of atomicModifyIORef, i.e. strict in the modifcation of the contents
+-- of the IORef, but not in the result produced.
+atomicModifyIORefHS :: IORef a -> (a -> (a, b)) -> IO b
+atomicModifyIORefHS ref f = do
+#if __GLASGOW_HASKELL__ >= 808
+  (_old, (_new, res)) <- atomicModifyIORef2Lazy ref $ \old ->
+    case f old of
+      r@(!_new, _res) -> r
+  pure res
+#else
+  atomicModifyIORef ref $ \old ->
+    case f old of
+      r@(!_new, _res) -> r
+#endif
+{-# INLINE atomicModifyIORefHS #-}
+
 -- Appendix 1.
 --
 -- @top@ and @bottom@ are signed integers of bit width @n@. @toUnsigned@

src/System/Random/Seed.hs

@@ -165,11 +165,18 @@ instance SeedGen StdGen where
   fromSeed = coerce (fromSeed :: Seed SM.SMGen -> SM.SMGen)
   toSeed = coerce (toSeed :: SM.SMGen -> Seed SM.SMGen)
 
+-- Standalone definitions due to GHC-8.0 not supporting deriving with associated type families
+
 instance SeedGen g => SeedGen (StateGen g) where
   type SeedSize (StateGen g) = SeedSize g
   fromSeed = coerce (fromSeed :: Seed g -> g)
   toSeed = coerce (toSeed :: g -> Seed g)
 
+instance SeedGen g => SeedGen (AtomicGen g) where
+  type SeedSize (AtomicGen g) = SeedSize g
+  fromSeed = coerce (fromSeed :: Seed g -> g)
+  toSeed = coerce (toSeed :: g -> Seed g)
+
 instance SeedGen SM.SMGen where
   type SeedSize SM.SMGen = 16
   fromSeed (Seed ba) =

src/System/Random/Stateful.hs

@@ -158,9 +158,6 @@ import GHC.Conc.Sync (STM, TVar, newTVar, newTVarIO, readTVar, writeTVar)
 import System.Random hiding (uniformShortByteString)
 import System.Random.Array (shortByteStringToByteString, shuffleListM)
 import System.Random.Internal
-#if __GLASGOW_HASKELL__ >= 808
-import GHC.IORef (atomicModifyIORef2Lazy)
-#endif
 
 -- $introduction
 --
@@ -424,106 +421,6 @@ uniformByteStringM n g =
     <$> uniformByteArrayM True n g
 {-# INLINE uniformByteStringM #-}
 
--- | Wraps an 'IORef' that holds a pure pseudo-random number generator. All
--- operations are performed atomically.
---
--- *   'AtomicGenM' is safe in the presence of exceptions and concurrency.
--- *   'AtomicGenM' is the slowest of the monadic adapters due to the overhead
---     of its atomic operations.
---
--- @since 1.2.0
-newtype AtomicGenM g = AtomicGenM {unAtomicGenM :: IORef g}
-
--- | Frozen version of mutable `AtomicGenM` generator
---
--- @since 1.2.0
-newtype AtomicGen g = AtomicGen {unAtomicGen :: g}
-  deriving (Eq, Ord, Show, RandomGen, SplitGen, Storable, NFData)
-
--- Standalone definition due to GHC-8.0 not supporting deriving with associated type families
-instance SeedGen g => SeedGen (AtomicGen g) where
-  type SeedSize (AtomicGen g) = SeedSize g
-  fromSeed = coerce (fromSeed :: Seed g -> g)
-  toSeed = coerce (toSeed :: g -> Seed g)
-
--- | Creates a new 'AtomicGenM'.
---
--- @since 1.2.0
-newAtomicGenM :: MonadIO m => g -> m (AtomicGenM g)
-newAtomicGenM = fmap AtomicGenM . liftIO . newIORef
-
--- | Global mutable standard pseudo-random number generator. This is the same
--- generator that was historically used by `randomIO` and `randomRIO` functions.
---
--- >>> import Control.Monad (replicateM)
--- >>> replicateM 10 (uniformRM ('a', 'z') globalStdGen)
--- "tdzxhyfvgr"
---
--- @since 1.2.1
-globalStdGen :: AtomicGenM StdGen
-globalStdGen = AtomicGenM theStdGen
-
-instance (RandomGen g, MonadIO m) => StatefulGen (AtomicGenM g) m where
-  uniformWord32R r = applyAtomicGen (genWord32R r)
-  {-# INLINE uniformWord32R #-}
-  uniformWord64R r = applyAtomicGen (genWord64R r)
-  {-# INLINE uniformWord64R #-}
-  uniformWord8 = applyAtomicGen genWord8
-  {-# INLINE uniformWord8 #-}
-  uniformWord16 = applyAtomicGen genWord16
-  {-# INLINE uniformWord16 #-}
-  uniformWord32 = applyAtomicGen genWord32
-  {-# INLINE uniformWord32 #-}
-  uniformWord64 = applyAtomicGen genWord64
-  {-# INLINE uniformWord64 #-}
-
-instance (RandomGen g, MonadIO m) => FrozenGen (AtomicGen g) m where
-  type MutableGen (AtomicGen g) m = AtomicGenM g
-  freezeGen = fmap AtomicGen . liftIO . readIORef . unAtomicGenM
-  modifyGen (AtomicGenM ioRef) f =
-    liftIO $ atomicModifyIORefHS ioRef $ \g ->
-      case f (AtomicGen g) of
-        (a, AtomicGen g') -> (g', a)
-  {-# INLINE modifyGen #-}
-
-instance (RandomGen g, MonadIO m) => ThawedGen (AtomicGen g) m where
-  thawGen (AtomicGen g) = newAtomicGenM g
-
--- | Atomically applies a pure operation to the wrapped pseudo-random number
--- generator.
---
--- ====__Examples__
---
--- >>> import System.Random.Stateful
--- >>> let pureGen = mkStdGen 137
--- >>> g <- newAtomicGenM pureGen
--- >>> applyAtomicGen random g :: IO Int
--- 7879794327570578227
---
--- @since 1.2.0
-applyAtomicGen :: MonadIO m => (g -> (a, g)) -> AtomicGenM g -> m a
-applyAtomicGen op (AtomicGenM gVar) =
-  liftIO $ atomicModifyIORefHS gVar $ \g ->
-    case op g of
-      (a, g') -> (g', a)
-{-# INLINE applyAtomicGen #-}
-
--- HalfStrict version of atomicModifyIORef, i.e. strict in the modifcation of the contents
--- of the IORef, but not in the result produced.
-atomicModifyIORefHS :: IORef a -> (a -> (a, b)) -> IO b
-atomicModifyIORefHS ref f = do
-#if __GLASGOW_HASKELL__ >= 808
-  (_old, (_new, res)) <- atomicModifyIORef2Lazy ref $ \old ->
-    case f old of
-      r@(!_new, _res) -> r
-  pure res
-#else
-  atomicModifyIORef ref $ \old ->
-    case f old of
-      r@(!_new, _res) -> r
-#endif
-{-# INLINE atomicModifyIORefHS #-}
-
 -- | Wraps an 'IORef' that holds a pure pseudo-random number generator.
 --
 -- *   'IOGenM' is safe in the presence of exceptions, but not concurrency.