From 0058d77cdf615792e41267cabd27c4a81ed9e59a Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 5 May 2020 20:08:53 +0300 Subject: [PATCH 1/4] Minor cleanups: * Remove -fobject-code compilation, since Cmm was removed * Fix example in cabal file * Take care of some compile warnings in legacy benchmarks --- .ghci | 1 - System/Random.hs | 1 + random.cabal | 5 +++-- test/doctests.hs | 4 +--- 4 files changed, 5 insertions(+), 6 deletions(-) delete mode 100755 .ghci diff --git a/.ghci b/.ghci deleted file mode 100755 index d42a8637a..000000000 --- a/.ghci +++ /dev/null @@ -1 +0,0 @@ -:set -fobject-code diff --git a/System/Random.hs b/System/Random.hs index be16853bf..3741ce0d3 100644 --- a/System/Random.hs +++ b/System/Random.hs @@ -312,6 +312,7 @@ randomIO = liftIO $ getStdRandom random -- -- It produces a full 'Word32' of randomness per iteration. -- +-- >>> import Data.Bits -- >>> :{ -- let stepGen :: PCGen -> (Word32, PCGen) -- stepGen (PCGen state inc) = let diff --git a/random.cabal b/random.cabal index 0a6c2d101..c5f3e7670 100644 --- a/random.cabal +++ b/random.cabal @@ -19,7 +19,7 @@ description: As an example, here is how you can simulate rolls of a six-sided die using 'System.Random.uniformR': . - >>> let roll = flip uniformR (1, 6) :: RandomGen g => g -> (Word8, g) + >>> let roll = uniformR (1, 6) :: RandomGen g => g -> (Word8, g) >>> let rolls = unfoldr (Just . roll) :: RandomGen g => g -> [Word8] >>> let pureGen = mkStdGen 42 >>> take 10 (rolls pureGen) :: [Word8] @@ -50,6 +50,7 @@ description: number generators. In this example, we use the one provided in the package: . + >>> import System.Random.MWC as MWC >>> let rollM = uniformRM (1, 6) :: MonadRandom g s m => g s -> m Word8 >>> monadicGen <- MWC.create >>> (replicateM 10 . rollM) monadicGen :: m [Word8] @@ -143,7 +144,7 @@ benchmark legacy-bench hs-source-dirs: bench-legacy other-modules: BinSearch default-language: Haskell2010 - ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -Wno-deprecations build-depends: base >=4.10 && <5, random -any, diff --git a/test/doctests.hs b/test/doctests.hs index 5fcfbe447..bbf7787f8 100644 --- a/test/doctests.hs +++ b/test/doctests.hs @@ -9,6 +9,4 @@ main = do traverse_ putStrLn args doctest args where - -- '-fobject-code' is required to get the doctests to build without - -- tripping over the Cmm bits. - args = ["-fobject-code"] ++ flags ++ pkgs ++ module_sources + args = flags ++ pkgs ++ module_sources From f1cbbb7b2a407dd95f60bd19f6aa75a9eb1d228e Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 5 May 2020 21:53:40 +0300 Subject: [PATCH 2/4] Lagacy benchmarks code formatting and cleanup. Get rid of compilation warnigns --- bench-legacy/BinSearch.hs | 173 ++++++++------- bench-legacy/SimpleRNGBench.hs | 385 ++++++++++++++------------------- 2 files changed, 256 insertions(+), 302 deletions(-) diff --git a/bench-legacy/BinSearch.hs b/bench-legacy/BinSearch.hs index f61164855..81a57930e 100644 --- a/bench-legacy/BinSearch.hs +++ b/bench-legacy/BinSearch.hs @@ -1,5 +1,5 @@ -{- +{- Binary search over benchmark input sizes. There are many good ways to measure the time it takes to perform a @@ -16,7 +16,7 @@ An alternative approach is to kill the computation after a certain amount of time and observe how much work it has completed. -} -module BinSearch +module BinSearch ( binSearch ) @@ -39,81 +39,88 @@ import Prelude hiding (min,max,log) -- between min and max, then it will then run for N trials and -- return the median (input,time-in-seconds) pair. binSearch :: Bool -> Integer -> (Double,Double) -> (Integer -> IO ()) -> IO (Integer, Double) -binSearch verbose trials (min,max) kernel = - do - when(verbose)$ putStrLn$ "[binsearch] Binary search for input size resulting in time in range "++ show (min,max) - - let desired_exec_length = 1.0 - good_trial t = (toRational t <= toRational max) && (toRational t >= toRational min) - - -- At some point we must give up... - loop n | n > ((2::Integer) ^ (100::Integer)) = error "ERROR binSearch: This function doesn't seem to scale in proportion to its last argument." - - -- Not allowed to have "0" size input, bump it back to one: - loop 0 = loop 1 - - loop n = - do - when(verbose)$ putStr$ "[binsearch:"++ show n ++ "] " - time <- timeit$ kernel n - when(verbose)$ putStrLn$ "Time consumed: "++ show time - let rate = fromIntegral n / time - - -- [2010.06.09] Introducing a small fudge factor to help our guess get over the line: - let initial_fudge_factor = 1.10 - fudge_factor = 1.01 -- Even in the steady state we fudge a little - guess = desired_exec_length * rate - - -- TODO: We should keep more history here so that we don't re-explore input space we have already explored. - -- This is a balancing act because of randomness in execution time. - - if good_trial time - then do - when(verbose)$ putStrLn$ "[binsearch] Time in range. LOCKING input size and performing remaining trials." - print_trial 1 n time - lockin (trials-1) n [time] - - -- Here we're still in the doubling phase: - else if time < 0.100 - then loop (2*n) - - else do when(verbose)$ - putStrLn$ "[binsearch] Estimated rate to be " - ++show (round rate::Integer)++" per second. Trying to scale up..." - - -- Here we've exited the doubling phase, but we're making our first guess as to how big a real execution should be: - if time > 0.100 && time < 0.33 * desired_exec_length - then do when(verbose)$ putStrLn$ "[binsearch] (Fudging first guess a little bit extra)" - loop (round$ guess * initial_fudge_factor) - else loop (round$ guess * fudge_factor) - - -- Termination condition: Done with all trials. - lockin 0 n log = do when(verbose)$ putStrLn$ "[binsearch] Time-per-unit for all trials: "++ - (concat $ intersperse " " (map (show . (/ toDouble n) . toDouble) $ sort log)) - return (n, log !! ((length log) `quot` 2)) -- Take the median - - lockin trials_left n log = - do when(verbose)$ putStrLn$ "[binsearch]------------------------------------------------------------" - time <- timeit$ kernel n - -- hFlush stdout - print_trial (trials - trials_left +1 ) n time - -- when(verbose)$ hFlush stdout - lockin (trials_left - 1) n (time : log) - - print_trial :: Integer -> Integer -> NominalDiffTime -> IO () - print_trial trialnum n time = - let rate = fromIntegral n / time - timeperunit = time / fromIntegral n - in - when(verbose)$ putStrLn$ "[binsearch] TRIAL: "++show trialnum ++ - " secPerUnit: "++ showTime timeperunit ++ - " ratePerSec: "++ show (rate) ++ - " seconds: "++showTime time - - +binSearch verbose trials (min, max) kernel = do + when verbose $ + putStrLn $ + "[binsearch] Binary search for input size resulting in time in range " ++ + show (min, max) + let desired_exec_length = 1.0 + good_trial t = + (toRational t <= toRational max) && (toRational t >= toRational min) + -- At some point we must give up... + loop n + | n > ((2 :: Integer) ^ (100 :: Integer)) = + error + "ERROR binSearch: This function doesn't seem to scale in proportion to its last argument." + -- Not allowed to have "0" size input, bump it back to one: + loop 0 = loop 1 + loop n = do + when verbose $ putStr $ "[binsearch:" ++ show n ++ "] " + time <- timeit $ kernel n + when verbose $ putStrLn $ "Time consumed: " ++ show time + let rate = fromIntegral n / time + -- [2010.06.09] Introducing a small fudge factor to help our guess get over the line: + let initial_fudge_factor = 1.10 + fudge_factor = 1.01 -- Even in the steady state we fudge a little + guess = desired_exec_length * rate + -- TODO: We should keep more history here so that we don't re-explore input space we + -- have already explored. This is a balancing act because of randomness in + -- execution time. + if good_trial time + then do + when verbose $ + putStrLn + "[binsearch] Time in range. LOCKING input size and performing remaining trials." + print_trial 1 n time + lockin (trials - 1) n [time] + else if time < 0.100 + then loop (2 * n) + else do + when verbose $ + putStrLn $ + "[binsearch] Estimated rate to be " ++ + show (round rate :: Integer) ++ + " per second. Trying to scale up..." + -- Here we've exited the doubling phase, but we're making our + -- first guess as to how big a real execution should be: + if time > 0.100 && time < 0.33 * desired_exec_length + then do + when verbose $ + putStrLn + "[binsearch] (Fudging first guess a little bit extra)" + loop (round $ guess * initial_fudge_factor) + else loop (round $ guess * fudge_factor) + -- Termination condition: Done with all trials. + lockin 0 n log = do + when verbose $ + putStrLn $ + "[binsearch] Time-per-unit for all trials: " ++ + concat + (intersperse " " (map (show . (/ toDouble n) . toDouble) $ sort log)) + return (n, log !! (length log `quot` 2)) -- Take the median + lockin trials_left n log = do + when verbose $ + putStrLn + "[binsearch]------------------------------------------------------------" + time <- timeit $ kernel n + -- hFlush stdout + print_trial (trials - trials_left + 1) n time + -- whenverbose$ hFlush stdout + lockin (trials_left - 1) n (time : log) + print_trial :: Integer -> Integer -> NominalDiffTime -> IO () + print_trial trialnum n time = + let rate = fromIntegral n / time + timeperunit = time / fromIntegral n + in when verbose $ + putStrLn $ + "[binsearch] TRIAL: " ++ + show trialnum ++ + " secPerUnit: " ++ + showTime timeperunit ++ + " ratePerSec: " ++ show rate ++ " seconds: " ++ showTime time + (n, t) <- loop 1 + return (n, fromRational $ toRational t) - (n,t) <- loop 1 - return (n, fromRational$ toRational t) showTime :: NominalDiffTime -> String showTime t = show ((fromRational $ toRational t) :: Double) @@ -125,16 +132,16 @@ toDouble = fromRational . toRational -- Could use cycle counters here.... but the point of this is to time -- things on the order of a second. timeit :: IO () -> IO NominalDiffTime -timeit io = - do strt <- getCurrentTime - io - end <- getCurrentTime - return (diffUTCTime end strt) +timeit io = do + strt <- getCurrentTime + io + end <- getCurrentTime + return (diffUTCTime end strt) {- test :: IO (Integer,Double) -test = +test = binSearch True 3 (1.0, 1.05) - (\n -> + (\n -> do v <- newIORef 0 forM_ [1..n] $ \i -> do old <- readIORef v diff --git a/bench-legacy/SimpleRNGBench.hs b/bench-legacy/SimpleRNGBench.hs index a2f919d7d..297935202 100644 --- a/bench-legacy/SimpleRNGBench.hs +++ b/bench-legacy/SimpleRNGBench.hs @@ -14,7 +14,7 @@ import System.Console.GetOpt import GHC.Conc import Control.Concurrent -import Control.Monad +import Control.Monad import Control.Exception import Data.IORef @@ -32,24 +32,12 @@ import Foreign.Storable (peek,poke) import Prelude hiding (last,sum) import BinSearch -#ifdef TEST_COMPETITORS -import System.Random.Mersenne.Pure64 -import System.Random.MWC -import Control.Monad.Primitive --- import System.IO.Unsafe -import GHC.IO -#endif - ---------------------------------------------------------------------------------------------------- -- Miscellaneous helpers: -- Readable large integer printing: commaint :: Show a => a -> String -commaint n = - reverse $ concat $ - intersperse "," $ - chunk 3 $ - reverse (show n) +commaint n = reverse $ concat $ intersperse "," $ chunk 3 $ reverse (show n) padleft :: Int -> String -> String padleft n str | length str >= n = str @@ -60,70 +48,55 @@ padright n str | length str >= n = str padright n str | otherwise = str ++ take (n - length str) (repeat ' ') fmt_num :: (RealFrac a, PrintfArg a) => a -> String -fmt_num n = if n < 100 - then printf "%.2f" n - else commaint (round n :: Integer) +fmt_num n = + if n < 100 + then printf "%.2f" n + else commaint (round n :: Integer) -- Measure clock frequency, spinning rather than sleeping to try to -- stay on the same core. measureFreq :: IO Int64 -measureFreq = do +measureFreq = do let second = 1000 * 1000 * 1000 * 1000 -- picoseconds are annoying - t1 <- rdtsc + t1 <- rdtsc start <- getCPUTime - let loop !n !last = - do t2 <- rdtsc - when (t2 < last) $ - putStrLn$ "COUNTERS WRAPPED "++ show (last,t2) - cput <- getCPUTime - if (cput - start < second) - then loop (n+1) t2 - else return (n,t2) - (n,t2) <- loop 0 t1 - putStrLn$ " Approx getCPUTime calls per second: "++ commaint (n::Int64) - when (t2 < t1) $ - putStrLn$ "WARNING: rdtsc not monotonically increasing, first "++show t1++" then "++show t2++" on the same OS thread" - - return$ fromIntegral (t2 - t1) + let loop !n !last = do + t2 <- rdtsc + when (t2 < last) $ putStrLn $ "COUNTERS WRAPPED " ++ show (last, t2) + cput <- getCPUTime + if cput - start < second + then loop (n + 1) t2 + else return (n, t2) + (n, t2) <- loop 0 t1 + putStrLn $ " Approx getCPUTime calls per second: " ++ commaint (n :: Int64) + when (t2 < t1) $ + putStrLn $ + "WARNING: rdtsc not monotonically increasing, first " ++ + show t1 ++ " then " ++ show t2 ++ " on the same OS thread" + return $ fromIntegral (t2 - t1) ---------------------------------------------------------------------------------------------------- -- Test overheads without actually generating any random numbers: data NoopRNG = NoopRNG -instance RandomGen NoopRNG where - next g = (0,g) -#ifdef ENABLE_SPLITTABLEGEN - genRange _ = (0,0) -instance SplittableGen NoopRNG where -#endif - split g = (g,g) +instance RandomGen NoopRNG where + next g = (0, g) + genRange _ = (0, 0) + split g = (g, g) -- An RNG generating only 0 or 1: data BinRNG = BinRNG StdGen -instance RandomGen BinRNG where +instance RandomGen BinRNG where next (BinRNG g) = (x `mod` 2, BinRNG g') - where (x,g') = next g -#ifdef ENABLE_SPLITTABLEGEN - genRange _ = (0,1) -instance SplittableGen BinRNG where -#endif + where + (x, g') = next g + genRange _ = (0, 1) split (BinRNG g) = (BinRNG g1, BinRNG g2) - where (g1,g2) = split g - + where + (g1, g2) = split g -#ifdef TEST_COMPETITORS -data MWCRNG = MWCRNG (Gen (PrimState IO)) --- data MWCRNG = MWCRNG GenIO -instance RandomGen MWCRNG where - -- For testing purposes we hack this to be non-monadic: --- next g@(MWCRNG gen) = unsafePerformIO $ - next g@(MWCRNG gen) = unsafeDupablePerformIO $ - do v <- uniform gen - return (v, g) -#endif - ---------------------------------------------------------------------------------------------------- -- Drivers to get random numbers repeatedly. @@ -135,188 +108,162 @@ type Kern = Int -> Ptr Int -> IO () -- foreign import ccall unsafe "stdlib.hs" rand :: IO Int {-# INLINE timeit #-} -timeit :: (Random a, RandomGen g) => - Int -> Int64 -> String -> g -> (g -> (a,g)) -> IO () -timeit numthreads freq msg gen nxt = - do - counters <- forM [1..numthreads] (const$ newIORef (1::Int64)) - tids <- forM counters $ \counter -> - forkIO $ infloop counter (nxt gen) - threadDelay (1000*1000) -- One second - mapM_ killThread tids - - finals <- mapM readIORef counters - let mean :: Double = fromIntegral (foldl1 (+) finals) / fromIntegral numthreads - cycles_per :: Double = fromIntegral freq / mean - printResult (round mean :: Int64) msg cycles_per - - where - infloop !counter !(!_,!g) = - do incr counter - infloop counter (nxt g) - - incr !counter = - do -- modifyIORef counter (+1) -- Not strict enough! - c <- readIORef counter - let c' = c+1 - _ <- evaluate c' - writeIORef counter c' +timeit :: (Random a, RandomGen g) => Int -> Int64 -> String -> g -> (g -> (a,g)) -> IO () +timeit numthreads freq msg gen nxt = do + counters <- forM [1 .. numthreads] (const $ newIORef (1 :: Int64)) + tids <- forM counters $ \counter -> forkIO $ infloop counter (nxt gen) + threadDelay (1000 * 1000) -- One second + mapM_ killThread tids + finals <- mapM readIORef counters + let mean :: Double = + fromIntegral (foldl1 (+) finals) / fromIntegral numthreads + cycles_per :: Double = fromIntegral freq / mean + printResult (round mean :: Int64) msg cycles_per + where + infloop !counter (!_, !g) = do + incr counter + infloop counter (nxt g) + incr !counter + -- modifyIORef counter (+1) -- Not strict enough! + = do + c <- readIORef counter + let c' = c + 1 + _ <- evaluate c' + writeIORef counter c' -- This function times an IO function on one or more threads. Rather -- than running a fixed number of iterations, it uses a binary search -- to find out how many iterations can be completed in a second. timeit_foreign :: Int -> Int64 -> String -> (Int -> Ptr Int -> IO ()) -> IO Int64 -timeit_foreign numthreads freq msg ffn = do - ptr :: ForeignPtr Int <- mallocForeignPtr - - let kern = if numthreads == 1 - then ffn - else replicate_kernel numthreads ffn - wrapped n = withForeignPtr ptr (kern$ fromIntegral n) - (n,t) <- binSearch False 1 (1.0, 1.05) wrapped - +timeit_foreign numthreads freq msg ffn = do + ptr :: ForeignPtr Int <- mallocForeignPtr + let kern = + if numthreads == 1 + then ffn + else replicate_kernel numthreads ffn + wrapped n = withForeignPtr ptr (kern $ fromIntegral n) + (n, t) <- binSearch False 1 (1.0, 1.05) wrapped let total_per_second = round $ fromIntegral n * (1 / t) cycles_per = fromIntegral freq * t / fromIntegral n printResult total_per_second msg cycles_per return total_per_second - - where - -- This lifts a C kernel to operate simultaneously on N threads. - replicate_kernel :: Int -> Kern -> Kern - replicate_kernel nthreads kern n ptr = do - ptrs <- forM [1..nthreads] - (const mallocForeignPtr) - tmpchan <- newChan - -- let childwork = ceiling$ fromIntegral n / fromIntegral nthreads - let childwork = n -- Keep it the same.. interested in per-thread throughput. - -- Fork/join pattern: - _ <- forM ptrs $ \pt -> forkIO $ - withForeignPtr pt $ \p -> do - kern (fromIntegral childwork) p - result <- peek p - writeChan tmpchan result - - results <- forM [1..nthreads] $ \_ -> - readChan tmpchan - -- Meaningless semantics here... sum the child ptrs and write to the input one: - poke ptr (foldl1 (+) results) - return () + -- This lifts a C kernel to operate simultaneously on N threads. + where + replicate_kernel :: Int -> Kern -> Kern + replicate_kernel nthreads kern n ptr = do + ptrs <- forM [1 .. nthreads] (const mallocForeignPtr) + tmpchan <- newChan + -- let childwork = ceiling$ fromIntegral n / fromIntegral nthreads + let childwork = n -- Keep it the same.. interested in per-thread throughput. + -- Fork/join pattern: + forM_ ptrs $ \pt -> + forkIO $ + withForeignPtr pt $ \p -> do + kern (fromIntegral childwork) p + result <- peek p + writeChan tmpchan result + results <- forM [1 .. nthreads] $ \_ -> readChan tmpchan + -- Meaningless semantics here... sum the child ptrs and write to the input one: + poke ptr (foldl1 (+) results) printResult :: Int64 -> String -> Double -> IO () -printResult total msg cycles_per = - putStrLn$ " "++ padleft 11 (commaint total) ++" randoms generated "++ padright 27 ("["++msg++"]") ++" ~ " - ++ fmt_num cycles_per ++" cycles/int" +printResult total msg cycles_per = + putStrLn $ + " " ++ + padleft 11 (commaint total) ++ + " randoms generated " ++ + padright 27 ("[" ++ msg ++ "]") ++ + " ~ " ++ fmt_num cycles_per ++ " cycles/int" ---------------------------------------------------------------------------------------------------- -- Main Script -data Flag = NoC | Help +data Flag = NoC | Help deriving (Show, Eq) options :: [OptDescr Flag] -options = +options = [ Option ['h'] ["help"] (NoArg Help) "print program help" , Option [] ["noC"] (NoArg NoC) "omit C benchmarks, haskell only" ] main :: IO () -main = do - argv <- getArgs - let (opts,_,other) = getOpt Permute options argv - - when (not$ null other) $ do - putStrLn$ "ERROR: Unrecognized options: " - mapM_ putStr other - exitFailure - - when (Help `elem` opts) $ do - putStr$ usageInfo "Benchmark random number generation" options - exitSuccess - - putStrLn$ "\nHow many random numbers can we generate in a second on one thread?" - - t1 <- rdtsc - t2 <- rdtsc - putStrLn (" Cost of rdtsc (ffi call): " ++ show (t2 - t1)) - - freq <- measureFreq - putStrLn$ " Approx clock frequency: " ++ commaint freq - - let - randInt = random :: RandomGen g => g -> (Int,g) - randWord16 = random :: RandomGen g => g -> (Word16,g) - randFloat = random :: RandomGen g => g -> (Float,g) - randCFloat = random :: RandomGen g => g -> (CFloat,g) - randDouble = random :: RandomGen g => g -> (Double,g) - randCDouble = random :: RandomGen g => g -> (CDouble,g) - randInteger = random :: RandomGen g => g -> (Integer,g) - randBool = random :: RandomGen g => g -> (Bool,g) - randChar = random :: RandomGen g => g -> (Char,g) - - gen = mkStdGen 23852358661234 - gamut th = do - putStrLn$ " First, timing System.Random.next:" - timeit th freq "constant zero gen" NoopRNG next - timeit th freq "System.Random stdGen/next" gen next - - putStrLn$ "\n Second, timing System.Random.random at different types:" - timeit th freq "System.Random Ints" gen randInt - timeit th freq "System.Random Word16" gen randWord16 - timeit th freq "System.Random Floats" gen randFloat - timeit th freq "System.Random CFloats" gen randCFloat - timeit th freq "System.Random Doubles" gen randDouble - timeit th freq "System.Random CDoubles" gen randCDouble - timeit th freq "System.Random Integers" gen randInteger - timeit th freq "System.Random Bools" gen randBool - timeit th freq "System.Random Chars" gen randChar - -#ifdef TEST_COMPETITORS - putStrLn$ "\n Next test other RNG packages on Hackage:" - let gen_mt = pureMT 39852 - randInt2 = random :: RandomGen g => g -> (Int,g) - randFloat2 = random :: RandomGen g => g -> (Float,g) - timeit th freq "System.Random.Mersenne.Pure64 next" gen_mt next - timeit th freq "System.Random.Mersenne.Pure64 Ints" gen_mt randInt2 - timeit th freq "System.Random.Mersenne.Pure64 Floats" gen_mt randFloat2 - --- gen_mwc <- create - withSystemRandom $ \ gen_mwc -> do - let randInt3 = random :: RandomGen g => g -> (Int,g) - randFloat3 = random :: RandomGen g => g -> (Float,g) - - timeit th freq "System.Random.MWC next" (MWCRNG gen_mwc) next - timeit th freq "System.Random.MWC Ints" (MWCRNG gen_mwc) randInt3 - timeit th freq "System.Random.MWC Floats" (MWCRNG gen_mwc) randFloat3 - -#endif - - putStrLn$ "\n Next timing range-restricted System.Random.randomR:" - timeit th freq "System.Random Ints" gen (randomR (-100, 100::Int)) - timeit th freq "System.Random Word16s" gen (randomR (-100, 100::Word16)) - timeit th freq "System.Random Floats" gen (randomR (-100, 100::Float)) - timeit th freq "System.Random CFloats" gen (randomR (-100, 100::CFloat)) - timeit th freq "System.Random Doubles" gen (randomR (-100, 100::Double)) - timeit th freq "System.Random CDoubles" gen (randomR (-100, 100::CDouble)) - timeit th freq "System.Random Integers" gen (randomR (-100, 100::Integer)) - timeit th freq "System.Random Bools" gen (randomR (False, True::Bool)) - timeit th freq "System.Random Chars" gen (randomR ('a', 'z')) - timeit th freq "System.Random BIG Integers" gen (randomR (0, (2::Integer) ^ (5000::Int))) - - -- when (not$ NoC `elem` opts) $ do - -- putStrLn$ " Comparison to C's rand():" - -- timeit_foreign th freq "ptr store in C loop" store_loop - -- timeit_foreign th freq "rand/store in C loop" blast_rands - -- timeit_foreign th freq "rand in Haskell loop" (\n ptr -> forM_ [1..n]$ \_ -> rand ) - -- timeit_foreign th freq "rand/store in Haskell loop" (\n ptr -> forM_ [1..n]$ \_ -> do n <- rand; poke ptr n ) - -- return () - - -- Test with 1 thread and numCapabilities threads: - gamut 1 - when (numCapabilities > 1) $ do - putStrLn$ "\nNow "++ show numCapabilities ++" threads, reporting mean randoms-per-second-per-thread:" - gamut numCapabilities - return () - - putStrLn$ "Finished." +main = do + argv <- getArgs + let (opts,_,other) = getOpt Permute options argv + + unless (null other) $ do + putStrLn "ERROR: Unrecognized options: " + mapM_ putStr other + exitFailure + + when (Help `elem` opts) $ do + putStr $ usageInfo "Benchmark random number generation" options + exitSuccess + + putStrLn "\nHow many random numbers can we generate in a second on one thread?" + + t1 <- rdtsc + t2 <- rdtsc + putStrLn (" Cost of rdtsc (ffi call): " ++ show (t2 - t1)) + + freq <- measureFreq + putStrLn $ " Approx clock frequency: " ++ commaint freq + + let randInt = random :: RandomGen g => g -> (Int,g) + randWord16 = random :: RandomGen g => g -> (Word16,g) + randFloat = random :: RandomGen g => g -> (Float,g) + randCFloat = random :: RandomGen g => g -> (CFloat,g) + randDouble = random :: RandomGen g => g -> (Double,g) + randCDouble = random :: RandomGen g => g -> (CDouble,g) + randInteger = random :: RandomGen g => g -> (Integer,g) + randBool = random :: RandomGen g => g -> (Bool,g) + randChar = random :: RandomGen g => g -> (Char,g) + + gen = mkStdGen 23852358661234 + gamut th = do + putStrLn " First, timing System.Random.next:" + timeit th freq "constant zero gen" NoopRNG next + timeit th freq "System.Random stdGen/next" gen next + + putStrLn "\n Second, timing System.Random.random at different types:" + timeit th freq "System.Random Ints" gen randInt + timeit th freq "System.Random Word16" gen randWord16 + timeit th freq "System.Random Floats" gen randFloat + timeit th freq "System.Random CFloats" gen randCFloat + timeit th freq "System.Random Doubles" gen randDouble + timeit th freq "System.Random CDoubles" gen randCDouble + timeit th freq "System.Random Integers" gen randInteger + timeit th freq "System.Random Bools" gen randBool + timeit th freq "System.Random Chars" gen randChar + + putStrLn "\n Next timing range-restricted System.Random.randomR:" + timeit th freq "System.Random Ints" gen (randomR (-100, 100::Int)) + timeit th freq "System.Random Word16s" gen (randomR ( 100, 300::Word16)) + timeit th freq "System.Random Floats" gen (randomR (-100, 100::Float)) + timeit th freq "System.Random CFloats" gen (randomR (-100, 100::CFloat)) + timeit th freq "System.Random Doubles" gen (randomR (-100, 100::Double)) + timeit th freq "System.Random CDoubles" gen (randomR (-100, 100::CDouble)) + timeit th freq "System.Random Integers" gen (randomR (-100, 100::Integer)) + timeit th freq "System.Random Bools" gen (randomR (False, True::Bool)) + timeit th freq "System.Random Chars" gen (randomR ('a', 'z')) + timeit th freq "System.Random BIG Integers" gen (randomR (0, (2::Integer) ^ (5000::Int))) + + -- when (not$ NoC `elem` opts) $ do + -- putStrLn$ " Comparison to C's rand():" + -- timeit_foreign th freq "ptr store in C loop" store_loop + -- timeit_foreign th freq "rand/store in C loop" blast_rands + -- timeit_foreign th freq "rand in Haskell loop" (\n ptr -> forM_ [1..n]$ \_ -> rand ) + -- timeit_foreign th freq "rand/store in Haskell loop" (\n ptr -> forM_ [1..n]$ \_ -> do n <- rand; poke ptr n ) + -- return () + + -- Test with 1 thread and numCapabilities threads: + gamut 1 + when (numCapabilities > 1) $ do + putStrLn $ "\nNow "++ show numCapabilities ++" threads, reporting mean randoms-per-second-per-thread:" + void $ gamut numCapabilities + + putStrLn "Finished." + From 424ccdf0baef40482bd62b8ddf86d24a9bd28e18 Mon Sep 17 00:00:00 2001 From: Leonhard Markert Date: Wed, 6 May 2020 14:42:53 +0200 Subject: [PATCH 3/4] Remove unnecessary CPP uses --- bench-legacy/SimpleRNGBench.hs | 2 +- test-legacy/RangeTest.hs | 2 -- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/bench-legacy/SimpleRNGBench.hs b/bench-legacy/SimpleRNGBench.hs index 297935202..61df451f5 100644 --- a/bench-legacy/SimpleRNGBench.hs +++ b/bench-legacy/SimpleRNGBench.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, ForeignFunctionInterface #-} +{-# LANGUAGE BangPatterns, ScopedTypeVariables, ForeignFunctionInterface #-} {-# OPTIONS_GHC -fwarn-unused-imports #-} -- | A simple script to do some very basic timing of the RNGs. diff --git a/test-legacy/RangeTest.hs b/test-legacy/RangeTest.hs index 1c990385d..78cc17547 100644 --- a/test-legacy/RangeTest.hs +++ b/test-legacy/RangeTest.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - module RangeTest (main) where import Control.Monad From 85e6b5c6863ef26559af923ec08c697c0d579e8f Mon Sep 17 00:00:00 2001 From: Leonhard Markert Date: Wed, 6 May 2020 14:43:32 +0200 Subject: [PATCH 4/4] Fix "default-language" warning, run cabal format --- random.cabal | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/random.cabal b/random.cabal index c5f3e7670..c05dff267 100644 --- a/random.cabal +++ b/random.cabal @@ -144,7 +144,9 @@ benchmark legacy-bench hs-source-dirs: bench-legacy other-modules: BinSearch default-language: Haskell2010 - ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -Wno-deprecations + ghc-options: + -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -Wno-deprecations + build-depends: base >=4.10 && <5, random -any, @@ -153,10 +155,11 @@ benchmark legacy-bench time >=1.8 && <1.11 benchmark bench - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: bench - ghc-options: -Wall -O2 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench + default-language: Haskell2010 + ghc-options: -Wall -O2 build-depends: base >=4.10 && <5, gauge >=0.2.3 && <0.3,