From 13c61bc3e6048103c20a87b3b1d4172646240161 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 7 Jan 2025 12:30:24 -0700 Subject: [PATCH 1/4] Add an instance for the new `SeedGen` type class --- System/Random/MWC.hs | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/System/Random/MWC.hs b/System/Random/MWC.hs index 134bd02..a0be251 100644 --- a/System/Random/MWC.hs +++ b/System/Random/MWC.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, FlexibleContexts, +{-# LANGUAGE BangPatterns, CPP, DataKinds, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, MagicHash, Rank2Types, ScopedTypeVariables, TypeFamilies, UnboxedTuples, TypeOperators #-} @@ -164,6 +164,7 @@ import Control.Monad.ST (ST,runST) import Data.Bits ((.&.), (.|.), shiftL, shiftR, xor) import Data.Int (Int8, Int16, Int32, Int64) import Data.IORef (IORef, atomicModifyIORef, newIORef) +import Data.Semigroup (sconcat) import Data.Typeable (Typeable) import Data.Vector.Generic (Vector) import Data.Word @@ -177,6 +178,9 @@ import System.IO.Unsafe (unsafePerformIO) import qualified Control.Exception as E import System.Random.MWC.SeedSource import qualified System.Random.Stateful as Random +#if MIN_VERSION_random(1,3,0) +import Data.List.NonEmpty (NonEmpty(..), toList) +#endif -- | NOTE: Consider use of more principled type classes -- 'Random.Uniform' and 'Random.UniformRange' instead. @@ -486,6 +490,26 @@ instance PrimMonad m => Random.ThawedGen Seed m where #endif thawGen = restore +#if MIN_VERSION_random(1,3,0) +instance Random.SeedGen Seed where + type SeedSize Seed = 1032 -- == 4 * 258 + fromSeed64 seed64 = + let w64ToW32s :: Word64 -> NonEmpty Word32 + w64ToW32s w64 = fromIntegral (w64 `shiftR` 32) :| [fromIntegral w64] + in toSeed $ I.fromList $ toList $ sconcat $ fmap w64ToW32s seed64 + toSeed64 vSeed = + let w32sToW64 :: Word32 -> Word32 -> Word64 + w32sToW64 w32u w32l = + (fromIntegral w32u `shiftL` 32) .|. fromIntegral w32l + v = fromSeed vSeed + evens = I.ifilter (\i _ -> even i) v + odds = I.ifilter (\i _ -> odd i) v + in case I.toList $ I.zipWith w32sToW64 evens odds of + [] -> + error $ "Impossible: Seed had an unexpected length of: " ++ show (I.length v) + x:xs -> x :| xs +#endif + -- | Convert vector to 'Seed'. It acts similarly to 'initialize' and -- will accept any vector. If you want to pass seed immediately to -- restore you better call initialize directly since following law holds: From e623dc70466835fcd77d82feb934c8f08bf25c91 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Sat, 11 Jan 2025 14:58:18 +0300 Subject: [PATCH 2/4] Add test for SeedGen instance --- tests/props.hs | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/tests/props.hs b/tests/props.hs index 00ed03d..b6ad685 100644 --- a/tests/props.hs +++ b/tests/props.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} import Control.Monad import Data.Word @@ -16,6 +17,9 @@ import Test.QuickCheck.Monadic import System.Random.MWC import System.Random.MWC.Distributions import System.Random.Stateful (StatefulGen) +#if MIN_VERSION_random(1,3,0) +import qualified System.Random.Stateful as Random (SeedGen(..)) +#endif ---------------------------------------------------------------- -- @@ -65,6 +69,9 @@ main = do g0 <- createSystemRandom defaultMainWithIngredients ingredients $ testGroup "mwc" [ testProperty "save/restore" $ prop_SeedSaveRestore g0 +#if MIN_VERSION_random(1,3,0) + , testProperty "SeedGen" $ prop_SeedGen g0 +#endif , testCase "user save/restore" $ saveRestoreUserSeed , testCase "empty seed data" $ emptySeed , testCase "output correct" $ do @@ -76,8 +83,7 @@ main = do ] updateGenState :: GenIO -> IO () -updateGenState g = replicateM_ 256 (uniform g :: IO Word32) - +updateGenState g = replicateM_ 250 (uniform g :: IO Word32) prop_SeedSaveRestore :: GenIO -> Property prop_SeedSaveRestore g = monadicIO $ do @@ -86,6 +92,14 @@ prop_SeedSaveRestore g = monadicIO $ do seed' <- run $ save =<< restore seed return $ seed == seed' +#if MIN_VERSION_random(1,3,0) +prop_SeedGen :: GenIO -> Property +prop_SeedGen g = monadicIO $ do + run $ updateGenState g + seed <- run $ save g + return $ seed == (Random.fromSeed . Random.toSeed) seed +#endif + saveRestoreUserSeed :: IO () saveRestoreUserSeed = do let seed = toSeed $ U.replicate 258 0 From 1265c3088a63d7a7a984bd62f3af664bb7d758a5 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Sat, 11 Jan 2025 15:16:01 +0300 Subject: [PATCH 3/4] Add benchmak for new seed functions --- bench/Benchmark.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs index dd93ad8..c759ba9 100644 --- a/bench/Benchmark.hs +++ b/bench/Benchmark.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} module Main(main) where import Control.Exception @@ -48,8 +49,9 @@ main = do opts <- parseOptions ingredients (bench "Fake" (nf id ())) let iter = lookupOption opts -- Set up RNG - mwc <- create - mtg <- M.newMTGen . Just =<< uniform mwc + mwc <- create + seed <- save mwc + mtg <- M.newMTGen . Just =<< uniform mwc defaultMainWithIngredients ingredients $ bgroup "All" [ bgroup "mwc" -- One letter group names are used so they will fit on the plot. @@ -148,6 +150,13 @@ main = do bench "Double" $ whnfIO $ loop iter (M.random mtg :: IO Double) , bench "Int" $ whnfIO $ loop iter (M.random mtg :: IO Int) ] +#if MIN_VERSION_random(1,3,0) + , bgroup "seed" + [ bench "SeedGen.fromSeed" $ let rseed = R.toSeed seed :: R.Seed Seed + in whnf R.fromSeed rseed + , bench "SeedGen.toSeed" $ whnf R.toSeed seed + ] +#endif ] betaBinomial :: StatefulGen g m => Double -> Double -> Int -> g -> m Int From 4f3c8657426406fa768d86603ab849b757bdfdba Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Sat, 11 Jan 2025 15:37:45 +0300 Subject: [PATCH 4/4] Optimize fromSeed64 a bit Apparently NonEmpty doesn't interact well with build/foldr fusion --- System/Random/MWC.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/System/Random/MWC.hs b/System/Random/MWC.hs index a0be251..08201f5 100644 --- a/System/Random/MWC.hs +++ b/System/Random/MWC.hs @@ -164,7 +164,6 @@ import Control.Monad.ST (ST,runST) import Data.Bits ((.&.), (.|.), shiftL, shiftR, xor) import Data.Int (Int8, Int16, Int32, Int64) import Data.IORef (IORef, atomicModifyIORef, newIORef) -import Data.Semigroup (sconcat) import Data.Typeable (Typeable) import Data.Vector.Generic (Vector) import Data.Word @@ -493,10 +492,12 @@ instance PrimMonad m => Random.ThawedGen Seed m where #if MIN_VERSION_random(1,3,0) instance Random.SeedGen Seed where type SeedSize Seed = 1032 -- == 4 * 258 - fromSeed64 seed64 = - let w64ToW32s :: Word64 -> NonEmpty Word32 - w64ToW32s w64 = fromIntegral (w64 `shiftR` 32) :| [fromIntegral w64] - in toSeed $ I.fromList $ toList $ sconcat $ fmap w64ToW32s seed64 + fromSeed64 seed64 = toSeed $ I.fromListN 258 + [ w32 + | !w64 <- toList seed64 + , !w32 <- [ fromIntegral (w64 `shiftR` 32) + , fromIntegral w64 ] + ] toSeed64 vSeed = let w32sToW64 :: Word32 -> Word32 -> Word64 w32sToW64 w32u w32l =