[Git][ghc/ghc][wip/foundation-tests] Use better random gen
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Wed Oct 12 20:02:38 UTC 2022
Matthew Pickering pushed to branch wip/foundation-tests at Glasgow Haskell Compiler / GHC
Commits:
b291f60f by Matthew Pickering at 2022-10-12T21:02:30+01:00
Use better random gen
- - - - -
1 changed file:
- testsuite/tests/numeric/should_run/foundation.hs
Changes:
=====================================
testsuite/tests/numeric/should_run/foundation.hs
=====================================
@@ -5,6 +5,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RecordWildCards #-}
module Main
( main
) where
@@ -24,13 +25,14 @@ import Foreign.Marshal.Alloc
import Foreign.Storable
import Foreign.Ptr
import Data.List (intercalate)
+import Data.IORef
+import Unsafe.Coerce
#include "MachDeps.h"
-newtype Gen a = Gen { runGen :: (ReaderT Handle IO a) }
+newtype Gen a = Gen { runGen :: (ReaderT LCGGen IO a) }
deriving newtype (Functor, Applicative, Monad)
--- | A version of "Arbitrary" but which just runs on numbers up to a certain bound.
class Arbitrary a where
arbitrary :: Gen a
@@ -82,6 +84,129 @@ data Test where
Property :: IsProperty prop => String -> prop -> Test
+arbitraryInt64 :: Gen Int64
+arbitraryInt64 = Gen $ do
+ h <- ask
+ W64# w <- liftIO (randomWord64 h)
+ return (I64# (unsafeCoerce# w))
+
+integralDownsize :: (Integral a) => Int64 -> a
+integralDownsize = fromIntegral
+
+wordDownsize :: (Integral a) => Word64 -> a
+wordDownsize = fromIntegral
+
+arbitraryWord64 :: Gen Word64
+arbitraryWord64 = Gen $ do
+ h <- ask
+ liftIO (randomWord64 h)
+
+instance Arbitrary Natural where
+ arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64
+
+-- Bounded by Int64
+instance Arbitrary Integer where
+ arbitrary = fromIntegral <$> arbitraryInt64
+
+instance Arbitrary Int where
+ arbitrary = int64ToInt <$> arbitraryInt64
+instance Arbitrary Word where
+ arbitrary = word64ToWord <$> arbitraryWord64
+instance Arbitrary Word64 where
+ arbitrary = arbitraryWord64
+instance Arbitrary Word32 where
+ arbitrary = wordDownsize <$> arbitraryWord64
+instance Arbitrary Word16 where
+ arbitrary = wordDownsize <$> arbitraryWord64
+instance Arbitrary Word8 where
+ arbitrary = wordDownsize <$> arbitraryWord64
+instance Arbitrary Int64 where
+ arbitrary = arbitraryInt64
+instance Arbitrary Int32 where
+ arbitrary = integralDownsize <$> arbitraryInt64
+instance Arbitrary Int16 where
+ arbitrary = integralDownsize <$> arbitraryInt64
+instance Arbitrary Int8 where
+ arbitrary = integralDownsize <$> arbitraryInt64
+
+int64ToInt :: Int64 -> Int
+#if WORD_SIZE_IN_BITS == 64
+#if __GLASGOW_HASKELL__ >= 904
+int64ToInt (I64# i) = I# (int64ToInt# i)
+#else
+int64ToInt (I64# i) = I# i
+#endif
+#else
+int64ToInt (I64# i) = I# (int64ToInt# i)
+#endif
+
+
+word64ToWord :: Word64 -> Word
+#if WORD_SIZE_IN_BITS == 64
+#if __GLASGOW_HASKELL__ >= 904
+word64ToWord (W64# i) = W# (GHC.Prim.word64ToWord# i)
+#else
+word64ToWord (W64# i) = W# i
+#endif
+#else
+word64ToWord (W64# i) = W# (word64ToWord# i)
+#endif
+
+
+data RunS = RunS { depth :: Int, rg :: LCGGen }
+
+newtype LCGGen = LCGGen { randomWord64 :: IO Word64 }
+
+data LCGParams = LCGParams { seed :: Word64, a :: Word64, c :: Word64, m :: Word64 }
+
+newLCGGen :: LCGParams -> IO LCGGen
+newLCGGen LCGParams{..} = do
+ var <- newIORef (fromIntegral seed)
+ return $ LCGGen $ do
+ atomicModifyIORef' var (\old_v -> let new_val = (old_v * a + c) `mod` m in (new_val, new_val))
+
+
+runPropertyCheck (PropertyBinaryOp res desc s1 s2) =
+ if res then return True else (putMsg ("Failure: " ++ s1 ++ desc ++ s2) >> return False)
+runPropertyCheck (PropertyAnd a1 a2) = (&&) <$> runPropertyCheck a1 <*> runPropertyCheck a2
+
+runProperty :: Property -> ReaderT RunS IO ()
+runProperty (Prop p) = do
+ let iterations = 100
+ loop iterations iterations
+ where
+ loop iterations 0 = putMsg ("Passed " ++ show iterations ++ " iterations")
+ loop iterations n = do
+ h <- rg <$> ask
+ p <- liftIO (runReaderT (runGen p) h)
+ let (ss, pc) = getCheck p
+ res <- runPropertyCheck pc
+ if res then loop iterations (n-1)
+ else putMsg ("With arguments " ++ intercalate ", " ss)
+
+putMsg s = do
+ n <- depth <$> ask
+ liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
+
+nest = local (\s -> s { depth = depth s + 1 })
+
+runTestInternal :: Test -> ReaderT RunS IO ()
+runTestInternal (Group name tests) = do
+ putMsg ("Group " ++ name)
+ nest (mapM_ runTestInternal tests)
+runTestInternal (Property name p) = do
+ putMsg ("Running " ++ name)
+ nest $ runProperty (property p)
+
+
+runTests :: Test -> IO ()
+runTests t = do
+ -- These params are the same ones as glibc uses.
+ h <- newLCGGen (LCGParams { seed = 1238123213, m = 2^31, a = 1103515245, c = 12345 })
+ runReaderT (runTestInternal t) (RunS 0 h)
+
+-------------------------------------------------------------------------------
+
testIntegral :: forall a . (Arbitrary a, Show a, Integral a, Typeable a)
=> Proxy a -> Test
testIntegral _ = Group "Integral"
@@ -168,119 +293,5 @@ testNumberRefs = Group "ALL"
]
-
-arbitraryInt64 :: Gen Int64
-arbitraryInt64 = Gen $ do
- h <- ask
- liftIO $
- allocaBytes 8 $ \buf -> do
- 8 <- hGetBuf h buf 8
- peek (castPtr buf)
-
-integralDownsize :: (Integral a) => Int64 -> a
-integralDownsize = fromIntegral
-
-wordDownsize :: (Integral a) => Word64 -> a
-wordDownsize = fromIntegral
-
-arbitraryWord64 :: Gen Word64
-arbitraryWord64 = Gen $ do
- h <- ask
- liftIO $
- allocaBytes 8 $ \buf -> do
- 8 <- hGetBuf h buf 8
- peek (castPtr buf)
-
-instance Arbitrary Natural where
- arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64
-
--- Bounded by Int64
-instance Arbitrary Integer where
- arbitrary = fromIntegral <$> arbitraryInt64
-
-instance Arbitrary Int where
- arbitrary = int64ToInt <$> arbitraryInt64
-instance Arbitrary Word where
- arbitrary = word64ToWord <$> arbitraryWord64
-instance Arbitrary Word64 where
- arbitrary = arbitraryWord64
-instance Arbitrary Word32 where
- arbitrary = wordDownsize <$> arbitraryWord64
-instance Arbitrary Word16 where
- arbitrary = wordDownsize <$> arbitraryWord64
-instance Arbitrary Word8 where
- arbitrary = wordDownsize <$> arbitraryWord64
-instance Arbitrary Int64 where
- arbitrary = arbitraryInt64
-instance Arbitrary Int32 where
- arbitrary = integralDownsize <$> arbitraryInt64
-instance Arbitrary Int16 where
- arbitrary = integralDownsize <$> arbitraryInt64
-instance Arbitrary Int8 where
- arbitrary = integralDownsize <$> arbitraryInt64
-
-data RunS = RunS { depth :: Int, rg :: Handle }
-
-
-runPropertyCheck (PropertyBinaryOp res desc s1 s2) =
- if res then return True else (putMsg ("Failure: " ++ s1 ++ desc ++ s2) >> return False)
-runPropertyCheck (PropertyAnd a1 a2) = (&&) <$> runPropertyCheck a1 <*> runPropertyCheck a2
-
-runProperty :: Property -> ReaderT RunS IO ()
-runProperty (Prop p) = do
- let iterations = 100
- loop iterations iterations
- where
- loop iterations 0 = putMsg ("Passed " ++ show iterations ++ " iterations")
- loop iterations n = do
- h <- rg <$> ask
- p <- liftIO (runReaderT (runGen p) h)
- let (ss, pc) = getCheck p
- res <- runPropertyCheck pc
- if res then loop iterations (n-1)
- else putMsg ("With arguments " ++ intercalate ", " ss)
-
-putMsg s = do
- n <- depth <$> ask
- liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
-
-
-nest = local (\s -> s { depth = depth s + 1 })
-
-runTestInternal :: Test -> ReaderT RunS IO ()
-runTestInternal (Group name tests) = do
- putMsg ("Group " ++ name)
- nest (mapM_ runTestInternal tests)
-runTestInternal (Property name p) = do
- putMsg ("Running " ++ name)
- nest $ runProperty (property p)
-
-runTests :: Test -> IO ()
-runTests t = do
- h <- openFile ("/dev/urandom") ReadMode
- runReaderT (runTestInternal t) (RunS 0 h)
-
main = runTests testNumberRefs
-int64ToInt :: Int64 -> Int
-#if WORD_SIZE_IN_BITS == 64
-#if __GLASGOW_HASKELL__ >= 904
-int64ToInt (I64# i) = I# (int64ToInt# i)
-#else
-int64ToInt (I64# i) = I# i
-#endif
-#else
-int64ToInt (I64# i) = I# (int64ToInt# i)
-#endif
-
-
-word64ToWord :: Word64 -> Word
-#if WORD_SIZE_IN_BITS == 64
-#if __GLASGOW_HASKELL__ >= 904
-word64ToWord (W64# i) = W# (GHC.Prim.word64ToWord# i)
-#else
-word64ToWord (W64# i) = W# i
-#endif
-#else
-word64ToWord (W64# i) = W# (word64ToWord# i)
-#endif
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b291f60fd9c22e23b560202ab20546b50330d148
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b291f60fd9c22e23b560202ab20546b50330d148
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221012/4331912b/attachment-0001.html>
More information about the ghc-commits
mailing list