diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,13 @@ +# 0.1.0.2 + +- Drop `time` dependency in favour of handcoded initialization + - On Unix platforms we use `/dev/urandom` if it exists, + otherwise use `gettimeofday`, `clock` and `getpid`. + - On Windows we use `GetCurrentProcessID`, `GetCurrentThreadId()`, + `GetTickCount`, `GetSystemTime` and `QueryPerformanceCounter`. + - On GHCJS use `Math.random()` + - Using `time` is a fallback option (e.g. for Hugs). + # 0.1.0.1 - Add `INLINEABLE` pragmas to `bitmaskWithRejection*` functions diff --git a/cbits-unix/init.c b/cbits-unix/init.c new file mode 100644 --- /dev/null +++ b/cbits-unix/init.c @@ -0,0 +1,39 @@ +#include +#include +#include +#include +#include +#include + +uint64_t splitmix_init() { + + /* if there is /dev/urandom, read from it */ + FILE *urandom = fopen("/dev/urandom", "r"); + if (urandom) { + uint64_t result = 0; + size_t r = fread(&result, sizeof(uint64_t), 1, urandom); + fclose(urandom); + + if (r == 1) { + return result; + } else { + return 0xfeed1000; + } + + } else { + /* time of day */ + struct timeval tp = {0, 0}; + gettimeofday(&tp, NULL); + + /* cputime */ + clock_t c = clock(); + + /* process id */ + pid_t p = getpid(); + + return ((uint64_t) tp.tv_sec) + ^ ((uint64_t) tp.tv_usec) + ^ ((uint64_t) c << 16) + ^ ((uint64_t) p << 32); + } +} diff --git a/cbits-win/init.c b/cbits-win/init.c new file mode 100644 --- /dev/null +++ b/cbits-win/init.c @@ -0,0 +1,28 @@ +#include + +#include + +uint64_t splitmix_init() { + /* Handy list at https://stackoverflow.com/a/3487338/1308058 */ + + uint64_t a = GetCurrentProcessId(); /* DWORD */ + uint64_t b = GetCurrentThreadId(); /* DWORD */ + uint64_t c = GetTickCount(); /* DWORD */ + + SYSTEMTIME t = {0,0,0,0,0,0,0,0}; + GetSystemTime(&t); + + LARGE_INTEGER i; + QueryPerformanceCounter(&i); + + return a ^ (b << 32) ^ (c << 16) + ^ ((uint64_t) t.wYear << 56) + ^ ((uint64_t) t.wMonth << 48) + ^ ((uint64_t) t.wDayOfWeek << 40) + ^ ((uint64_t) t.wDay << 32) + ^ ((uint64_t) t.wHour << 24) + ^ ((uint64_t) t.wMinute << 16) + ^ ((uint64_t) t.wSecond << 8) + ^ ((uint64_t) t.wMilliseconds << 0) + ^ ((uint64_t) i.QuadPart); +} diff --git a/splitmix.cabal b/splitmix.cabal --- a/splitmix.cabal +++ b/splitmix.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: splitmix -version: 0.1.0.1 +version: 0.1.0.2 synopsis: Fast Splittable PRNG description: Pure Haskell implementation of SplitMix described in @@ -29,7 +29,7 @@ license: BSD3 license-file: LICENSE maintainer: Oleg Grenrus -bug-reports: https://github.com/phadej/splitmix/issues +bug-reports: https://github.com/haskellari/splitmix/issues category: System, Random build-type: Simple tested-with: @@ -43,8 +43,8 @@ || ==8.2.2 || ==8.4.4 || ==8.6.5 - || ==8.8.3 - || ==8.10.1 + || ==8.8.4 + || ==8.10.2 , GHCJS ==8.4 extra-source-files: @@ -62,11 +62,14 @@ default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src src-compat - other-modules: Data.Bits.Compat exposed-modules: System.Random.SplitMix System.Random.SplitMix32 + other-modules: + Data.Bits.Compat + System.Random.SplitMix.Init + -- dump-core -- build-depends: dump-core -- ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html @@ -74,14 +77,34 @@ build-depends: base >=4.3 && <4.16 , deepseq >=1.3.0.0 && <1.5 - , time >=1.2.0.3 && <1.11 if flag(optimised-mixer) cpp-options: -DOPTIMISED_MIX32=1 + -- We don't want to depend on time, nor unix or Win32 packages + -- because it's valuable that splitmix and QuickCheck doesn't + -- depend on about anything + + if impl(ghcjs) + cpp-options: -DSPLITMIX_INIT_GHCJS=1 + + else + if impl(ghc) + cpp-options: -DSPLITMIX_INIT_C=1 + + if os(windows) + c-sources: cbits-win/init.c + + else + c-sources: cbits-unix/init.c + + else + cpp-options: -DSPLITMIX_INIT_COMPAT=1 + build-depends: time >=1.2.0.3 && <1.11 + source-repository head type: git - location: https://github.com/phadej/splitmix.git + location: https://github.com/haskellari/splitmix.git benchmark comparison type: exitcode-stdio-1.0 @@ -189,3 +212,14 @@ , splitmix , tf-random >=0.5 && <0.6 , vector >=0.11.0.0 && <0.13 + +test-suite initialization + default-language: Haskell2010 + type: exitcode-stdio-1.0 + ghc-options: -Wall -threaded -rtsopts + hs-source-dirs: tests + main-is: Initialization.hs + build-depends: + base + , splitmix + , HUnit ==1.3.1.2 || >=1.6.0.0 && <1.7 diff --git a/src/System/Random/SplitMix.hs b/src/System/Random/SplitMix.hs --- a/src/System/Random/SplitMix.hs +++ b/src/System/Random/SplitMix.hs @@ -57,10 +57,11 @@ import Data.Bits (complement, shiftL, shiftR, xor, (.&.), (.|.)) import Data.Bits.Compat (countLeadingZeros, popCount, zeroBits) import Data.IORef (IORef, atomicModifyIORef, newIORef) -import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Word (Word32, Word64) import System.IO.Unsafe (unsafePerformIO) +import System.Random.SplitMix.Init + #if defined(__HUGS__) || !MIN_VERSION_base(4,8,0) import Data.Word (Word) #endif @@ -69,10 +70,6 @@ import Control.DeepSeq (NFData (..)) #endif -#if !__GHCJS__ -import System.CPUTime (cpuTimePrecision, getCPUTime) -#endif - -- $setup -- >>> import Text.Read (readMaybe) -- >>> import Data.List (unfoldr) @@ -379,9 +376,9 @@ mkSMGen :: Word64 -> SMGen mkSMGen s = SMGen (mix64 s) (mixGamma (s `plus` goldenGamma)) --- | Initialize 'SMGen' using system time. +-- | Initialize 'SMGen' using entropy available on the system (time, ...) initSMGen :: IO SMGen -initSMGen = fmap mkSMGen mkSeedTime +initSMGen = fmap mkSMGen initialSeed -- | Derive a new generator instance from the global 'SMGen' using 'splitSMGen'. newSMGen :: IO SMGen @@ -390,18 +387,6 @@ theSMGen :: IORef SMGen theSMGen = unsafePerformIO $ initSMGen >>= newIORef {-# NOINLINE theSMGen #-} - -mkSeedTime :: IO Word64 -mkSeedTime = do - now <- getPOSIXTime - let lo = truncate now :: Word32 -#if __GHCJS__ - let hi = lo -#else - cpu <- getCPUTime - let hi = fromIntegral (cpu `div` cpuTimePrecision) :: Word32 -#endif - return $ fromIntegral hi `shiftL` 32 .|. fromIntegral lo ------------------------------------------------------------------------------- -- Hugs diff --git a/src/System/Random/SplitMix/Init.hs b/src/System/Random/SplitMix/Init.hs new file mode 100644 --- /dev/null +++ b/src/System/Random/SplitMix/Init.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} +-- | Initialization of global generator. +module System.Random.SplitMix.Init ( + initialSeed, +) where + +import Data.Word (Word64) + +#if defined(SPLITMIX_INIT_GHCJS) && __GHCJS__ + +import Data.Word (Word32) + +#else +#if defined(SPLITMIX_INIT_C) + +#else + +import Data.Bits (xor) +import Data.Time.Clock.POSIX (getPOSIXTime) +#if !__GHCJS__ +import System.CPUTime (cpuTimePrecision, getCPUTime) +#endif + +#endif +#endif + +initialSeed :: IO Word64 + +#if defined(SPLITMIX_INIT_GHCJS) && __GHCJS__ + +initialSeed = fmap fromIntegral initialSeedJS + +foreign import javascript + "$r = Math.floor(Math.random()*0x100000000);" + initialSeedJS :: IO Word32 + +#else +#if defined(SPLITMIX_INIT_C) + +initialSeed = initialSeedC + +foreign import ccall "splitmix_init" initialSeedC :: IO Word64 + +#else + +initialSeed = do + now <- getPOSIXTime + let timebits = truncate now :: Word64 +#if __GHCJS__ + let cpubits = 0 +#else + cpu <- getCPUTime + let cpubits = fromIntegral (cpu `div` cpuTimePrecision) :: Word64 +#endif + return $ timebits `xor` cpubits + +#endif +#endif diff --git a/src/System/Random/SplitMix32.hs b/src/System/Random/SplitMix32.hs --- a/src/System/Random/SplitMix32.hs +++ b/src/System/Random/SplitMix32.hs @@ -41,10 +41,11 @@ import Data.Bits.Compat (countLeadingZeros, finiteBitSize, popCount, zeroBits) import Data.IORef (IORef, atomicModifyIORef, newIORef) -import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Word (Word32, Word64) import System.IO.Unsafe (unsafePerformIO) +import System.Random.SplitMix.Init + #if defined(__HUGS__) || !MIN_VERSION_base(4,8,0) import Data.Word (Word) #endif @@ -53,10 +54,6 @@ import Control.DeepSeq (NFData (..)) #endif -#if !__GHCJS__ -import System.CPUTime (cpuTimePrecision, getCPUTime) -#endif - -- $setup -- >>> import Text.Read (readMaybe) -- >>> import Data.List (unfoldr) @@ -359,9 +356,9 @@ mkSMGen :: Word32 -> SMGen mkSMGen s = SMGen (mix32 s) (mixGamma (s + goldenGamma)) --- | Initialize 'SMGen' using system time. +-- | Initialize 'SMGen' using entropy available on the system (time, ...) initSMGen :: IO SMGen -initSMGen = fmap mkSMGen mkSeedTime +initSMGen = fmap mkSMGen initialSeed' -- | Derive a new generator instance from the global 'SMGen' using 'splitSMGen'. newSMGen :: IO SMGen @@ -371,14 +368,7 @@ theSMGen = unsafePerformIO $ initSMGen >>= newIORef {-# NOINLINE theSMGen #-} -mkSeedTime :: IO Word32 -mkSeedTime = do - now <- getPOSIXTime - let lo = truncate now :: Word32 -#if __GHCJS__ - let hi = lo -#else - cpu <- getCPUTime - let hi = fromIntegral (cpu `div` cpuTimePrecision) :: Word32 -#endif - return $ fromIntegral hi `shiftL` 32 .|. fromIntegral lo +initialSeed' :: IO Word32 +initialSeed' = do + w64 <- initialSeed + return (fromIntegral (shiftL w64 32) `xor` fromIntegral w64) diff --git a/tests/Initialization.hs b/tests/Initialization.hs new file mode 100644 --- /dev/null +++ b/tests/Initialization.hs @@ -0,0 +1,28 @@ +module Main (main) where + +import Control.Monad (forM_, replicateM) +import Data.List (tails) +import Test.HUnit (assertFailure) + +import qualified System.Random.SplitMix as SM +import qualified System.Random.SplitMix32 as SM32 + +main :: IO () +main = do + g64 <- replicateM 10 (fmap show SM.initSMGen) + putStrLn $ unlines g64 + forM_ (tails g64) $ \xs' -> case xs' of + [] -> return () + (x:xs) -> + if all (x /=) xs + then return () + else assertFailure "ERROR: duplicate" + + g32 <- replicateM 10 (fmap show SM32.initSMGen) + putStrLn $ unlines g32 + forM_ (tails g32) $ \xs' -> case xs' of + [] -> return () + (x:xs) -> + if all (x /=) xs + then return () + else assertFailure "ERROR: duplicate"