From 9b9083ea307b0d0e53f3be031ffa1dd8a75bfcd1 Mon Sep 17 00:00:00 2001 From: Dominic Steinitz Date: Mon, 23 Mar 2020 15:25:06 +0000 Subject: [PATCH 01/12] UniformRange for Float and Double --- System/Random.hs | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/System/Random.hs b/System/Random.hs index b6473b928..f4c68f1f8 100644 --- a/System/Random.hs +++ b/System/Random.hs @@ -224,6 +224,9 @@ import GHC.ForeignPtr import System.IO.Unsafe (unsafePerformIO) import qualified System.Random.SplitMix as SM +import Data.Char (chr, ord) +import GHC.Float + #if !MIN_VERSION_primitive(0,7,0) import Data.Primitive.Types (Addr(..)) @@ -1002,7 +1005,11 @@ instance Random Double where random = randomDouble randomM = uniformR (0, 1) -instance UniformRange Double +instance UniformRange Double where + uniformR (l, h) g = do + w64 <- uniformWord64 g + let x = castWord64ToDouble $ (w64 `shiftR` 12) .|. 0x3ff0000000000000 + return $ (h - l) * (x - 1.0) + l randomDouble :: RandomGen b => b -> (Double, b) randomDouble rng = @@ -1021,7 +1028,11 @@ instance Random Float where random = randomFloat randomM = uniformR (0, 1) -instance UniformRange Float +instance UniformRange Float where + uniformR (l, h) g = do + w32 <- uniformWord32 g + let x = castWord32ToFloat $ (w32 `shiftR` 9) .|. 0x3f800000 + return $ (h - l) * (x - 1.0) + l randomFloat :: RandomGen b => b -> (Float, b) randomFloat rng = From 39140e658b25645701e0e43d9fd5497db44f59d3 Mon Sep 17 00:00:00 2001 From: Dominic Steinitz Date: Wed, 25 Mar 2020 15:17:30 +0000 Subject: [PATCH 02/12] Test conditional compilation --- System/Random.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/System/Random.hs b/System/Random.hs index f4c68f1f8..1e3a1ebae 100644 --- a/System/Random.hs +++ b/System/Random.hs @@ -223,8 +223,6 @@ import GHC.Exts (Ptr(..), build) import GHC.ForeignPtr import System.IO.Unsafe (unsafePerformIO) import qualified System.Random.SplitMix as SM - -import Data.Char (chr, ord) import GHC.Float #if !MIN_VERSION_primitive(0,7,0) @@ -1006,10 +1004,12 @@ instance Random Double where randomM = uniformR (0, 1) instance UniformRange Double where +#if __GLASGOW_HASKELL__ >= 844 uniformR (l, h) g = do w64 <- uniformWord64 g let x = castWord64ToDouble $ (w64 `shiftR` 12) .|. 0x3ff0000000000000 return $ (h - l) * (x - 1.0) + l +#endif randomDouble :: RandomGen b => b -> (Double, b) randomDouble rng = @@ -1029,10 +1029,12 @@ instance Random Float where randomM = uniformR (0, 1) instance UniformRange Float where +#if __GLASGOW_HASKELL__ >= 844 uniformR (l, h) g = do w32 <- uniformWord32 g let x = castWord32ToFloat $ (w32 `shiftR` 9) .|. 0x3f800000 return $ (h - l) * (x - 1.0) + l +#endif randomFloat :: RandomGen b => b -> (Float, b) randomFloat rng = From f81725c3d2f402d14eafc3764ad40f9ba71598a4 Mon Sep 17 00:00:00 2001 From: Dominic Steinitz Date: Wed, 25 Mar 2020 17:10:05 +0000 Subject: [PATCH 03/12] Support earlier versions of ghc for Double --- System/Random.hs | 12 ++++++++++-- tests/Spec.hs | 7 ++++++- tests/Spec/Bitmask.hs | 5 ++++- 3 files changed, 20 insertions(+), 4 deletions(-) diff --git a/System/Random.hs b/System/Random.hs index 1e3a1ebae..70fa3dbff 100644 --- a/System/Random.hs +++ b/System/Random.hs @@ -1004,11 +1004,15 @@ instance Random Double where randomM = uniformR (0, 1) instance UniformRange Double where -#if __GLASGOW_HASKELL__ >= 844 +#if __GLASGOW_HASKELL__ >= 804 uniformR (l, h) g = do w64 <- uniformWord64 g let x = castWord64ToDouble $ (w64 `shiftR` 12) .|. 0x3ff0000000000000 return $ (h - l) * (x - 1.0) + l +#else + uniformR (l, h) g = do + let x = fst $ randomDouble g + return $ (h - l) * x + l #endif randomDouble :: RandomGen b => b -> (Double, b) @@ -1029,11 +1033,15 @@ instance Random Float where randomM = uniformR (0, 1) instance UniformRange Float where -#if __GLASGOW_HASKELL__ >= 844 +#if __GLASGOW_HASKELL__ >= 804 uniformR (l, h) g = do w32 <- uniformWord32 g let x = castWord32ToFloat $ (w32 `shiftR` 9) .|. 0x3f800000 return $ (h - l) * (x - 1.0) + l +#else + uniformR (l, h) g = do + let x = fst $ randomFloat g + return $ (h - l) * x + l #endif randomFloat :: RandomGen b => b -> (Float, b) diff --git a/tests/Spec.hs b/tests/Spec.hs index 65d85b315..ecb368b6c 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -14,7 +14,7 @@ import qualified Spec.Bitmask as Range main :: IO () main = defaultMain $ testGroup "Spec" [ bitmaskSpecWord32, bitmaskSpecWord64 - , rangeSpecWord32, rangeSpecInt + , rangeSpecWord32, rangeSpecDouble, rangeSpecInt ] bitmaskSpecWord32 :: TestTree @@ -38,6 +38,11 @@ rangeSpecWord32 = testGroup "uniformR (Word32)" , SC.testProperty "(Word32) singleton" $ seeded $ Range.singleton @StdGen @Word32 ] +rangeSpecDouble :: TestTree +rangeSpecDouble = testGroup "uniformR (Word32)" + [ SC.testProperty "(Double) uniform bounded" $ seeded $ Range.uniformBounded @StdGen @Double + ] + rangeSpecInt :: TestTree rangeSpecInt = testGroup "uniformR (Int)" [ SC.testProperty "(Int) symmetric" $ seeded $ Range.symmetric @StdGen @Int diff --git a/tests/Spec/Bitmask.hs b/tests/Spec/Bitmask.hs index bd43505a0..835a5c1cc 100644 --- a/tests/Spec/Bitmask.hs +++ b/tests/Spec/Bitmask.hs @@ -1,4 +1,4 @@ -module Spec.Bitmask (symmetric, bounded, singleton) where +module Spec.Bitmask (symmetric, bounded, singleton, uniformBounded) where import Data.Bits import System.Random @@ -17,3 +17,6 @@ singleton :: (RandomGen g, FiniteBits a, Num a, Ord a, Random a) => g -> a -> Bo singleton g x = result == x where result = fst (bitmaskWithRejection (x, x) g) + +uniformBounded :: (RandomGen g, UniformRange a, Ord a) => g -> (a, a) -> Bool +uniformBounded g (l, r) = runGenState_ g (\g -> (uniformR (l, r) g >>= \result -> return ((min l r) <= result))) From 973d3d2163dc35cd7bc0c518b6fa18da93df7459 Mon Sep 17 00:00:00 2001 From: Dominic Steinitz Date: Thu, 26 Mar 2020 11:04:29 +0000 Subject: [PATCH 04/12] Fix(!) conditional compilation and address comments --- System/Random.hs | 30 ++++++++++++++++++++++++------ tests/Spec.hs | 9 +++++++-- tests/Spec/Bitmask.hs | 2 +- 3 files changed, 32 insertions(+), 9 deletions(-) diff --git a/System/Random.hs b/System/Random.hs index 70fa3dbff..262eedd14 100644 --- a/System/Random.hs +++ b/System/Random.hs @@ -1007,14 +1007,23 @@ instance UniformRange Double where #if __GLASGOW_HASKELL__ >= 804 uniformR (l, h) g = do w64 <- uniformWord64 g - let x = castWord64ToDouble $ (w64 `shiftR` 12) .|. 0x3ff0000000000000 + let x = castWord64ToDouble $ (w64 `unsafeShiftR` 12) .|. 0x3ff0000000000000 return $ (h - l) * (x - 1.0) + l #else uniformR (l, h) g = do - let x = fst $ randomDouble g - return $ (h - l) * x + l + x <- uniformDouble g + return $ (h - l) * x + l #endif +-- A copy of 'randomDouble' required for old versions of GHC +uniformDouble :: MonadRandom g m => g -> m Double +uniformDouble g = do + w64 <- uniformWord64 g + return $ fromIntegral (mask53 .&. w64) / fromIntegral twoto53 + where + twoto53 = (2::Word64) ^ (53::Word64) + mask53 = twoto53 - 1 + randomDouble :: RandomGen b => b -> (Double, b) randomDouble rng = case random rng of @@ -1036,14 +1045,23 @@ instance UniformRange Float where #if __GLASGOW_HASKELL__ >= 804 uniformR (l, h) g = do w32 <- uniformWord32 g - let x = castWord32ToFloat $ (w32 `shiftR` 9) .|. 0x3f800000 + let x = castWord32ToFloat $ (w32 `unsafeShiftR` 9) .|. 0x3f800000 return $ (h - l) * (x - 1.0) + l #else uniformR (l, h) g = do - let x = fst $ randomFloat g - return $ (h - l) * x + l + x <- uniformFloat g + return $ (h - l) * x + l #endif +-- A copy of 'randomFloat' required for old versions of GHC +uniformFloat :: MonadRandom g m => g -> m Float +uniformFloat g = do + w32 <- uniformWord32 g + return $ fromIntegral (mask24 .&. w32) / fromIntegral twoto24 + where + mask24 = twoto24 - 1 + twoto24 = (2::Word32) ^ (24::Word32) + randomFloat :: RandomGen b => b -> (Float, b) randomFloat rng = -- TODO: Faster to just use 'next' IF it generates enough bits of randomness. diff --git a/tests/Spec.hs b/tests/Spec.hs index ecb368b6c..bd33d58e4 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -14,7 +14,7 @@ import qualified Spec.Bitmask as Range main :: IO () main = defaultMain $ testGroup "Spec" [ bitmaskSpecWord32, bitmaskSpecWord64 - , rangeSpecWord32, rangeSpecDouble, rangeSpecInt + , rangeSpecWord32, rangeSpecDouble, rangeSpecFloat, rangeSpecInt ] bitmaskSpecWord32 :: TestTree @@ -39,10 +39,15 @@ rangeSpecWord32 = testGroup "uniformR (Word32)" ] rangeSpecDouble :: TestTree -rangeSpecDouble = testGroup "uniformR (Word32)" +rangeSpecDouble = testGroup "uniformR (Double)" [ SC.testProperty "(Double) uniform bounded" $ seeded $ Range.uniformBounded @StdGen @Double ] +rangeSpecFloat :: TestTree +rangeSpecFloat = testGroup "uniformR (Float)" + [ SC.testProperty "(Float) uniform bounded" $ seeded $ Range.uniformBounded @StdGen @Float + ] + rangeSpecInt :: TestTree rangeSpecInt = testGroup "uniformR (Int)" [ SC.testProperty "(Int) symmetric" $ seeded $ Range.symmetric @StdGen @Int diff --git a/tests/Spec/Bitmask.hs b/tests/Spec/Bitmask.hs index 835a5c1cc..1aa814dce 100644 --- a/tests/Spec/Bitmask.hs +++ b/tests/Spec/Bitmask.hs @@ -19,4 +19,4 @@ singleton g x = result == x result = fst (bitmaskWithRejection (x, x) g) uniformBounded :: (RandomGen g, UniformRange a, Ord a) => g -> (a, a) -> Bool -uniformBounded g (l, r) = runGenState_ g (\g -> (uniformR (l, r) g >>= \result -> return ((min l r) <= result))) +uniformBounded g (l, r) = runGenState_ g (\g -> (uniformR (l, r) g >>= \result -> return ((min l r) <= result && result <= (max l r)))) From 0134d0f92cf26279de680ec5b4860b9c82e3f36d Mon Sep 17 00:00:00 2001 From: Leonhard Markert Date: Thu, 26 Mar 2020 13:01:48 +0100 Subject: [PATCH 05/12] Factor version-specific code into own functions --- System/Random.hs | 54 ++++++++++++++++++++++++------------------------ 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/System/Random.hs b/System/Random.hs index 262eedd14..b675000db 100644 --- a/System/Random.hs +++ b/System/Random.hs @@ -1004,25 +1004,25 @@ instance Random Double where randomM = uniformR (0, 1) instance UniformRange Double where -#if __GLASGOW_HASKELL__ >= 804 uniformR (l, h) g = do w64 <- uniformWord64 g - let x = castWord64ToDouble $ (w64 `unsafeShiftR` 12) .|. 0x3ff0000000000000 - return $ (h - l) * (x - 1.0) + l -#else - uniformR (l, h) g = do - x <- uniformDouble g + let x = word64ToDoubleInUnitInterval w64 return $ (h - l) * x + l -#endif --- A copy of 'randomDouble' required for old versions of GHC -uniformDouble :: MonadRandom g m => g -> m Double -uniformDouble g = do - w64 <- uniformWord64 g - return $ fromIntegral (mask53 .&. w64) / fromIntegral twoto53 +-- | Turns a given uniformly distributed 'Word64' value into a uniformly +-- distributed 'Double' value. +word64ToDoubleInUnitInterval :: Word64 -> Double +#if __GLASGOW_HASKELL__ >= 804 +word64ToDoubleInUnitInterval w64 = between1and2 - 1.0 + where + between1and2 = castWord64ToDouble $ (w64 `unsafeShiftR` 12) .|. 0x3ff0000000000000 +#else +word64ToDoubleInUnitInterval w64 = fromIntegral (mask53 .&. w64) / fromIntegral twoto53 where twoto53 = (2::Word64) ^ (53::Word64) mask53 = twoto53 - 1 +#endif +{-# INLINE word64ToDoubleInUnitInterval #-} randomDouble :: RandomGen b => b -> (Double, b) randomDouble rng = @@ -1042,25 +1042,25 @@ instance Random Float where randomM = uniformR (0, 1) instance UniformRange Float where -#if __GLASGOW_HASKELL__ >= 804 uniformR (l, h) g = do w32 <- uniformWord32 g - let x = castWord32ToFloat $ (w32 `unsafeShiftR` 9) .|. 0x3f800000 - return $ (h - l) * (x - 1.0) + l -#else - uniformR (l, h) g = do - x <- uniformFloat g + let x = word32ToFloatInUnitInterval w32 return $ (h - l) * x + l -#endif --- A copy of 'randomFloat' required for old versions of GHC -uniformFloat :: MonadRandom g m => g -> m Float -uniformFloat g = do - w32 <- uniformWord32 g - return $ fromIntegral (mask24 .&. w32) / fromIntegral twoto24 - where - mask24 = twoto24 - 1 - twoto24 = (2::Word32) ^ (24::Word32) +-- | Turns a given uniformly distributed 'Word32' value into a uniformly +-- distributed 'Float' value. +word32ToFloatInUnitInterval :: Word32 -> Float +#if __GLASGOW_HASKELL__ >= 804 +word32ToFloatInUnitInterval w32 = between1and2 - 1.0 + where + between1and2 = castWord32ToFloat $ (w32 `unsafeShiftR` 9) .|. 0x3f800000 +#else +word32ToFloatInUnitInterval w32 = fromIntegral (mask24 .&. w32) / fromIntegral twoto24 + where + mask24 = twoto24 - 1 + twoto24 = (2::Word32) ^ (24::Word32) +#endif +{-# INLINE word32ToFloatInUnitInterval #-} randomFloat :: RandomGen b => b -> (Float, b) randomFloat rng = From 45d23413c6c3d51ee18613fcfeafa38334264084 Mon Sep 17 00:00:00 2001 From: Dominic Steinitz Date: Fri, 27 Mar 2020 10:19:01 +0000 Subject: [PATCH 06/12] Hand roll the technique used in GHC.Float for older GHC --- System/Random.hs | 37 ++++++++++++++++---- cbits/CastFloatWord.cmm | 76 +++++++++++++++++++++++++++++++++++++++++ random.cabal | 19 ++++++----- 3 files changed, 116 insertions(+), 16 deletions(-) create mode 100644 cbits/CastFloatWord.cmm diff --git a/System/Random.hs b/System/Random.hs index b675000db..462187675 100644 --- a/System/Random.hs +++ b/System/Random.hs @@ -7,6 +7,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE UnliftedFFITypes #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif @@ -219,12 +221,17 @@ import Foreign.C.Types import Foreign.Marshal.Alloc (alloca) import Foreign.Ptr (plusPtr) import Foreign.Storable (peekByteOff, pokeByteOff) -import GHC.Exts (Ptr(..), build) +import GHC.Exts (Ptr(..)) import GHC.ForeignPtr import System.IO.Unsafe (unsafePerformIO) import qualified System.Random.SplitMix as SM import GHC.Float +import Data.Bits +import GHC.Base +import GHC.Word + + #if !MIN_VERSION_primitive(0,7,0) import Data.Primitive.Types (Addr(..)) @@ -1017,13 +1024,30 @@ word64ToDoubleInUnitInterval w64 = between1and2 - 1.0 where between1and2 = castWord64ToDouble $ (w64 `unsafeShiftR` 12) .|. 0x3ff0000000000000 #else -word64ToDoubleInUnitInterval w64 = fromIntegral (mask53 .&. w64) / fromIntegral twoto53 +word64ToDoubleInUnitInterval w64 = between1and2 - 1.0 where - twoto53 = (2::Word64) ^ (53::Word64) - mask53 = twoto53 - 1 + between1and2 = castWord64ToDouble' $ (w64 `unsafeShiftR` 12) .|. 0x3ff0000000000000 #endif {-# INLINE word64ToDoubleInUnitInterval #-} +{-# INLINE castWord32ToFloat' #-} +castWord32ToFloat' :: Word32 -> Float +castWord32ToFloat' (W32# w#) = F# (stgWord32ToFloat' w#) + +foreign import prim "stg_word32ToFloatyg" + stgWord32ToFloat' :: Word# -> Float# + +{-# INLINE castWord64ToDouble' #-} +castWord64ToDouble' :: Word64 -> Double +castWord64ToDouble' (W64# w) = D# (stgWord64ToDouble' w) + +foreign import prim "stg_word64ToDoubleyg" +#if WORD_SIZE_IN_BITS == 64 + stgWord64ToDouble' :: Word# -> Double# +#else + stgWord64ToDouble' :: Word64# -> Double# +#endif + randomDouble :: RandomGen b => b -> (Double, b) randomDouble rng = case random rng of @@ -1055,10 +1079,9 @@ word32ToFloatInUnitInterval w32 = between1and2 - 1.0 where between1and2 = castWord32ToFloat $ (w32 `unsafeShiftR` 9) .|. 0x3f800000 #else -word32ToFloatInUnitInterval w32 = fromIntegral (mask24 .&. w32) / fromIntegral twoto24 +word32ToFloatInUnitInterval w32 = between1and2 - 1.0 where - mask24 = twoto24 - 1 - twoto24 = (2::Word32) ^ (24::Word32) + between1and2 = castWord32ToFloat' $ (w32 `unsafeShiftR` 9) .|. 0x3f800000 #endif {-# INLINE word32ToFloatInUnitInterval #-} diff --git a/cbits/CastFloatWord.cmm b/cbits/CastFloatWord.cmm new file mode 100644 index 000000000..ec85905f5 --- /dev/null +++ b/cbits/CastFloatWord.cmm @@ -0,0 +1,76 @@ +#include "Cmm.h" +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS == 64 +#define DOUBLE_SIZE_WDS 1 +#else +#define DOUBLE_SIZE_WDS 2 +#endif + +#if SIZEOF_W == 4 +#define TO_ZXW_(x) %zx32(x) +#elif SIZEOF_W == 8 +#define TO_ZXW_(x) %zx64(x) +#endif + +stg_word64ToDoubleyg(I64 w) +{ + D_ d; + P_ ptr; + + STK_CHK_GEN_N (DOUBLE_SIZE_WDS); + + reserve DOUBLE_SIZE_WDS = ptr { + I64[ptr] = w; + d = D_[ptr]; + } + + return (d); +} + +stg_doubleToWord64yg(D_ d) +{ + I64 w; + P_ ptr; + + STK_CHK_GEN_N (DOUBLE_SIZE_WDS); + + reserve DOUBLE_SIZE_WDS = ptr { + D_[ptr] = d; + w = I64[ptr]; + } + + return (w); +} + +stg_word32ToFloatyg(W_ w) +{ + F_ f; + P_ ptr; + + STK_CHK_GEN_N (1); + + reserve 1 = ptr { + I32[ptr] = %lobits32(w); + f = F_[ptr]; + } + + return (f); +} + +stg_floatToWord32yg(F_ f) +{ + W_ w; + P_ ptr; + + STK_CHK_GEN_N (1); + + reserve 1 = ptr { + F_[ptr] = f; + // Fix #16617: use zero-extending (TO_ZXW_) here + w = TO_ZXW_(I32[ptr]); + } + + return (w); +} + diff --git a/random.cabal b/random.cabal index 478152c1f..f4453b733 100644 --- a/random.cabal +++ b/random.cabal @@ -37,6 +37,7 @@ library primitive >= 0.6.4.0 && <8, mtl -any, splitmix -any + c-sources: cbits/CastFloatWord.cmm test-suite legacy type: exitcode-stdio-1.0 @@ -56,15 +57,15 @@ test-suite legacy containers -any, random -any -test-suite doctests - type: exitcode-stdio-1.0 - main-is: doctests.hs - hs-source-dirs: tests - default-language: Haskell2010 - build-depends: - base -any, - doctest >=0.15, - random -any +-- test-suite doctests +-- type: exitcode-stdio-1.0 +-- main-is: doctests.hs +-- hs-source-dirs: tests +-- default-language: Haskell2010 +-- build-depends: +-- base -any, +-- doctest >=0.15, +-- random -any test-suite spec type: exitcode-stdio-1.0 From 1d5b00454c1a61550e36c524a2318b842e6a2027 Mon Sep 17 00:00:00 2001 From: Leonhard Markert Date: Fri, 27 Mar 2020 13:07:07 +0100 Subject: [PATCH 07/12] Fix doctests --- System/Random.hs | 49 +++++++++++++++-------------------------------- random.cabal | 18 ++++++++--------- tests/doctests.hs | 4 +++- 3 files changed, 27 insertions(+), 44 deletions(-) diff --git a/System/Random.hs b/System/Random.hs index 462187675..341f8a099 100644 --- a/System/Random.hs +++ b/System/Random.hs @@ -84,27 +84,20 @@ -- (Word16, Word16)@ is a function to pull apart a 'Word32' into a -- pair of 'Word16'): -- --- >>> data PCGen' = PCGen' !Word64 !Word64 +-- >>> newtype PCGen' = PCGen' { unPCGen :: PCGen } +-- +-- >>> let stepGen' = second PCGen' . stepGen . unPCGen -- -- >>> :{ -- instance RandomGen PCGen' where --- genWord8 (PCGen' s i) = (z, PCGen' s' i') --- where --- (x, PCGen s' i') = stepGen (PCGen s i) --- y = fst $ unBuildWord32 x --- z = fst $ unBuildWord16 y --- genWord16 (PCGen' s i) = (y, PCGen' s' i') --- where --- (x, PCGen s' i') = stepGen (PCGen s i) --- y = fst $ unBuildWord32 x --- genWord32 (PCGen' s i) = (x, PCGen' s' i') --- where --- (x, PCGen s' i') = stepGen (PCGen s i) --- genWord64 (PCGen' s i) = (undefined, PCGen' s i) --- where --- (x, g) = stepGen (PCGen s i) --- (y, PCGen s' i') = stepGen g --- split _ = error "This PRNG is not splittable" +-- genWord8 = first fromIntegral . stepGen' +-- genWord16 = first fromIntegral . stepGen' +-- genWord32 = stepGen' +-- genWord64 g = (buildWord64 x y, g'') +-- where +-- (x, g') = stepGen' g +-- (y, g'') = stepGen' g' +-- buildWord64 w0 w1 = ((fromIntegral w1) `shiftL` 32) .|. (fromIntegral w0) -- :} -- -- [/Example for RNG Users:/] @@ -245,25 +238,13 @@ mutableByteArrayContentsCompat :: MutableByteArray s -> Ptr Word8 {-# INLINE mutableByteArrayContentsCompat #-} -- $setup +-- >>> import Control.Arrow (first, second) +-- >>> import Control.Monad (replicateM) +-- >>> import Data.Bits +-- >>> import Data.Word -- >>> import System.IO (IOMode(WriteMode), hPutStr, withBinaryFile) -- >>> :set -XFlexibleContexts -- >>> :set -fno-warn-missing-methods --- >>> :{ --- unBuildWord32 :: Word32 -> (Word16, Word16) --- unBuildWord32 w = (fromIntegral (shiftR w 16), --- fromIntegral (fromIntegral (maxBound :: Word16) .&. w)) --- :} --- --- >>> :{ --- unBuildWord16 :: Word16 -> (Word8, Word8) --- unBuildWord16 w = (fromIntegral (shiftR w 8), --- fromIntegral (fromIntegral (maxBound :: Word8) .&. w)) --- :} --- --- >>> :{ --- buildWord64 :: Word32 -> Word32 -> Word64 --- buildWord64 w0 w1 = ((fromIntegral w1) `shiftL` 32) .|. (fromIntegral w0) --- :} -- | The class 'RandomGen' provides a common interface to random number -- generators. diff --git a/random.cabal b/random.cabal index f4453b733..a65f6296a 100644 --- a/random.cabal +++ b/random.cabal @@ -57,15 +57,15 @@ test-suite legacy containers -any, random -any --- test-suite doctests --- type: exitcode-stdio-1.0 --- main-is: doctests.hs --- hs-source-dirs: tests --- default-language: Haskell2010 --- build-depends: --- base -any, --- doctest >=0.15, --- random -any +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: tests + default-language: Haskell2010 + build-depends: + base -any, + doctest >=0.15, + random -any test-suite spec type: exitcode-stdio-1.0 diff --git a/tests/doctests.hs b/tests/doctests.hs index bbf7787f8..5fcfbe447 100644 --- a/tests/doctests.hs +++ b/tests/doctests.hs @@ -9,4 +9,6 @@ main = do traverse_ putStrLn args doctest args where - args = flags ++ pkgs ++ module_sources + -- '-fobject-code' is required to get the doctests to build without + -- tripping over the Cmm bits. + args = ["-fobject-code"] ++ flags ++ pkgs ++ module_sources From 7e33718cceed92dce31e864b73a2bc70fb0af675 Mon Sep 17 00:00:00 2001 From: Dominic Steinitz Date: Fri, 27 Mar 2020 12:54:59 +0000 Subject: [PATCH 08/12] Consistent floating point for all versions of ghc --- System/Random.hs | 34 +++++++++++----------------------- 1 file changed, 11 insertions(+), 23 deletions(-) diff --git a/System/Random.hs b/System/Random.hs index 341f8a099..9ecdf5a4d 100644 --- a/System/Random.hs +++ b/System/Random.hs @@ -218,8 +218,6 @@ import GHC.Exts (Ptr(..)) import GHC.ForeignPtr import System.IO.Unsafe (unsafePerformIO) import qualified System.Random.SplitMix as SM -import GHC.Float - import Data.Bits import GHC.Base import GHC.Word @@ -1000,33 +998,29 @@ instance UniformRange Double where -- | Turns a given uniformly distributed 'Word64' value into a uniformly -- distributed 'Double' value. word64ToDoubleInUnitInterval :: Word64 -> Double -#if __GLASGOW_HASKELL__ >= 804 word64ToDoubleInUnitInterval w64 = between1and2 - 1.0 where between1and2 = castWord64ToDouble $ (w64 `unsafeShiftR` 12) .|. 0x3ff0000000000000 -#else -word64ToDoubleInUnitInterval w64 = between1and2 - 1.0 - where - between1and2 = castWord64ToDouble' $ (w64 `unsafeShiftR` 12) .|. 0x3ff0000000000000 -#endif {-# INLINE word64ToDoubleInUnitInterval #-} -{-# INLINE castWord32ToFloat' #-} -castWord32ToFloat' :: Word32 -> Float -castWord32ToFloat' (W32# w#) = F# (stgWord32ToFloat' w#) +-- | These are now in 'GHC.Float' but unpatched in some versions so +-- for now we roll our own. +{-# INLINE castWord32ToFloat #-} +castWord32ToFloat :: Word32 -> Float +castWord32ToFloat (W32# w#) = F# (stgWord32ToFloat w#) foreign import prim "stg_word32ToFloatyg" - stgWord32ToFloat' :: Word# -> Float# + stgWord32ToFloat :: Word# -> Float# -{-# INLINE castWord64ToDouble' #-} -castWord64ToDouble' :: Word64 -> Double -castWord64ToDouble' (W64# w) = D# (stgWord64ToDouble' w) +{-# INLINE castWord64ToDouble #-} +castWord64ToDouble :: Word64 -> Double +castWord64ToDouble (W64# w) = D# (stgWord64ToDouble w) foreign import prim "stg_word64ToDoubleyg" #if WORD_SIZE_IN_BITS == 64 - stgWord64ToDouble' :: Word# -> Double# + stgWord64ToDouble :: Word# -> Double# #else - stgWord64ToDouble' :: Word64# -> Double# + stgWord64ToDouble :: Word64# -> Double# #endif randomDouble :: RandomGen b => b -> (Double, b) @@ -1055,15 +1049,9 @@ instance UniformRange Float where -- | Turns a given uniformly distributed 'Word32' value into a uniformly -- distributed 'Float' value. word32ToFloatInUnitInterval :: Word32 -> Float -#if __GLASGOW_HASKELL__ >= 804 word32ToFloatInUnitInterval w32 = between1and2 - 1.0 where between1and2 = castWord32ToFloat $ (w32 `unsafeShiftR` 9) .|. 0x3f800000 -#else -word32ToFloatInUnitInterval w32 = between1and2 - 1.0 - where - between1and2 = castWord32ToFloat' $ (w32 `unsafeShiftR` 9) .|. 0x3f800000 -#endif {-# INLINE word32ToFloatInUnitInterval #-} randomFloat :: RandomGen b => b -> (Float, b) From b6b480eb9725fd7b176778fdadbfffa55a793141 Mon Sep 17 00:00:00 2001 From: Dominic Steinitz Date: Fri, 27 Mar 2020 13:58:21 +0000 Subject: [PATCH 09/12] Minor housekeeping --- System/Random.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/System/Random.hs b/System/Random.hs index 189453b80..f2beadc8b 100644 --- a/System/Random.hs +++ b/System/Random.hs @@ -218,7 +218,6 @@ import GHC.Exts (Ptr(..)) import GHC.ForeignPtr import System.IO.Unsafe (unsafePerformIO) import qualified System.Random.SplitMix as SM -import Data.Bits import GHC.Base import GHC.Word @@ -996,7 +995,7 @@ instance UniformRange Double where return $ (h - l) * x + l -- | Turns a given uniformly distributed 'Word64' value into a uniformly --- distributed 'Double' value. +-- distributed 'Double' value in the range [0, 1). word64ToDoubleInUnitInterval :: Word64 -> Double word64ToDoubleInUnitInterval w64 = between1and2 - 1.0 where @@ -1047,7 +1046,7 @@ instance UniformRange Float where return $ (h - l) * x + l -- | Turns a given uniformly distributed 'Word32' value into a uniformly --- distributed 'Float' value. +-- distributed 'Float' value in the range [0,1). word32ToFloatInUnitInterval :: Word32 -> Float word32ToFloatInUnitInterval w32 = between1and2 - 1.0 where From 151fcb6cdaaa589e4a9a5f5994bd036ec32adcde Mon Sep 17 00:00:00 2001 From: Dominic Steinitz Date: Fri, 27 Mar 2020 16:32:34 +0000 Subject: [PATCH 10/12] Respond to feedback --- System/Random.hs | 4 +++- cbits/CastFloatWord.cmm | 1 + 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/System/Random.hs b/System/Random.hs index f2beadc8b..0534adf32 100644 --- a/System/Random.hs +++ b/System/Random.hs @@ -1003,7 +1003,9 @@ word64ToDoubleInUnitInterval w64 = between1and2 - 1.0 {-# INLINE word64ToDoubleInUnitInterval #-} -- | These are now in 'GHC.Float' but unpatched in some versions so --- for now we roll our own. +-- for now we roll our own. See +-- https://gitlab.haskell.org/ghc/ghc/-/blob/master/libraries/base/GHC/Float.hs +-- (4bada77d58). {-# INLINE castWord32ToFloat #-} castWord32ToFloat :: Word32 -> Float castWord32ToFloat (W32# w#) = F# (stgWord32ToFloat w#) diff --git a/cbits/CastFloatWord.cmm b/cbits/CastFloatWord.cmm index ec85905f5..77c060606 100644 --- a/cbits/CastFloatWord.cmm +++ b/cbits/CastFloatWord.cmm @@ -1,3 +1,4 @@ +/* This comes as part of your Haskell installation */ #include "Cmm.h" #include "MachDeps.h" From f8f41bead70b0ea59a43be80ebf7d66c0fc366fc Mon Sep 17 00:00:00 2001 From: Dominic Steinitz Date: Fri, 27 Mar 2020 16:57:36 +0000 Subject: [PATCH 11/12] Remove unneeded code and link to source --- cbits/CastFloatWord.cmm | 33 +-------------------------------- 1 file changed, 1 insertion(+), 32 deletions(-) diff --git a/cbits/CastFloatWord.cmm b/cbits/CastFloatWord.cmm index 77c060606..2494960e1 100644 --- a/cbits/CastFloatWord.cmm +++ b/cbits/CastFloatWord.cmm @@ -1,4 +1,4 @@ -/* This comes as part of your Haskell installation */ +/* From: https://gitlab.haskell.org/ghc/ghc/-/blob/6d172e63f3dd3590b0a57371efb8f924f1fcdf05/libraries/base/cbits/CastFloatWord.cmm */ #include "Cmm.h" #include "MachDeps.h" @@ -29,21 +29,6 @@ stg_word64ToDoubleyg(I64 w) return (d); } -stg_doubleToWord64yg(D_ d) -{ - I64 w; - P_ ptr; - - STK_CHK_GEN_N (DOUBLE_SIZE_WDS); - - reserve DOUBLE_SIZE_WDS = ptr { - D_[ptr] = d; - w = I64[ptr]; - } - - return (w); -} - stg_word32ToFloatyg(W_ w) { F_ f; @@ -59,19 +44,3 @@ stg_word32ToFloatyg(W_ w) return (f); } -stg_floatToWord32yg(F_ f) -{ - W_ w; - P_ ptr; - - STK_CHK_GEN_N (1); - - reserve 1 = ptr { - F_[ptr] = f; - // Fix #16617: use zero-extending (TO_ZXW_) here - w = TO_ZXW_(I32[ptr]); - } - - return (w); -} - From 6d914b92106bf307ebf04b22501c2eabe4a1437b Mon Sep 17 00:00:00 2001 From: Dominic Steinitz Date: Fri, 27 Mar 2020 16:59:32 +0000 Subject: [PATCH 12/12] A better link --- System/Random.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/System/Random.hs b/System/Random.hs index 0534adf32..81b2bd706 100644 --- a/System/Random.hs +++ b/System/Random.hs @@ -1004,8 +1004,7 @@ word64ToDoubleInUnitInterval w64 = between1and2 - 1.0 -- | These are now in 'GHC.Float' but unpatched in some versions so -- for now we roll our own. See --- https://gitlab.haskell.org/ghc/ghc/-/blob/master/libraries/base/GHC/Float.hs --- (4bada77d58). +-- https://gitlab.haskell.org/ghc/ghc/-/blob/6d172e63f3dd3590b0a57371efb8f924f1fcdf05/libraries/base/GHC/Float.hs {-# INLINE castWord32ToFloat #-} castWord32ToFloat :: Word32 -> Float castWord32ToFloat (W32# w#) = F# (stgWord32ToFloat w#)