Make benchmark build and add benchmark for tf-random.
[packages/random.git] / Benchmark / SimpleRNGBench.hs
1 {-# LANGUAGE BangPatterns, ScopedTypeVariables, ForeignFunctionInterface #-}
2 {-# OPTIONS_GHC -fwarn-unused-imports #-}
3
4 -- | A simple script to do some very basic timing of the RNGs.
5
6 module Main where
7
8 import System.Exit (exitSuccess, exitFailure)
9 import System.Environment
10 import System.Random
11 import System.CPUTime (getCPUTime)
12 import System.CPUTime.Rdtsc
13 import System.Console.GetOpt
14
15 import GHC.Conc
16 import Control.Concurrent
17 import Control.Monad
18 import Control.Exception
19
20 import Data.IORef
21 import Data.Word
22 import Data.List hiding (last,sum)
23 import Data.Int
24 import Data.List.Split hiding (split)
25 import Text.Printf
26
27 import Foreign.Ptr
28 import Foreign.C.Types
29 import Foreign.ForeignPtr
30 import Foreign.Storable (peek,poke)
31
32 import Prelude hiding (last,sum)
33 import BinSearch
34
35 #ifdef TEST_COMPETITORS
36 import System.Random.TF
37 import System.Random.Mersenne.Pure64
38 import System.Random.MWC
39 import Control.Monad.Primitive
40 -- import System.IO.Unsafe
41 import GHC.IO
42 #endif
43
44 ----------------------------------------------------------------------------------------------------
45 -- Miscellaneous helpers:
46
47 -- Readable large integer printing:
48 commaint :: (Show a, Integral a) => a -> String
49 commaint n =
50 reverse $ concat $
51 intersperse "," $
52 chunksOf 3 $
53 reverse (show n)
54
55 padleft :: Int -> String -> String
56 padleft n str | length str >= n = str
57 padleft n str | otherwise = take (n - length str) (repeat ' ') ++ str
58
59 padright :: Int -> String -> String
60 padright n str | length str >= n = str
61 padright n str | otherwise = str ++ take (n - length str) (repeat ' ')
62
63 fmt_num :: (RealFrac a, PrintfArg a) => a -> String
64 fmt_num n = if n < 100
65 then printf "%.2f" n
66 else commaint (round n :: Integer)
67
68
69 -- Measure clock frequency, spinning rather than sleeping to try to
70 -- stay on the same core.
71 measureFreq :: IO Int64
72 measureFreq = do
73 let second = 1000 * 1000 * 1000 * 1000 -- picoseconds are annoying
74 t1 <- rdtsc
75 start <- getCPUTime
76 let loop !n !last =
77 do t2 <- rdtsc
78 when (t2 < last) $
79 putStrLn$ "COUNTERS WRAPPED "++ show (last,t2)
80 cput <- getCPUTime
81 if (cput - start < second)
82 then loop (n+1) t2
83 else return (n,t2)
84 (n,t2) <- loop 0 t1
85 putStrLn$ " Approx getCPUTime calls per second: "++ commaint (n::Int64)
86 when (t2 < t1) $
87 putStrLn$ "WARNING: rdtsc not monotonically increasing, first "++show t1++" then "++show t2++" on the same OS thread"
88
89 return$ fromIntegral (t2 - t1)
90
91 ----------------------------------------------------------------------------------------------------
92
93 -- Test overheads without actually generating any random numbers:
94 data NoopRNG = NoopRNG
95 instance RandomGen NoopRNG where
96 next g = (0,g)
97 #ifdef ENABLE_SPLITTABLEGEN
98 genRange _ = (0,0)
99 instance SplittableGen NoopRNG where
100 #endif
101 split g = (g,g)
102
103 -- An RNG generating only 0 or 1:
104 data BinRNG = BinRNG StdGen
105 instance RandomGen BinRNG where
106 next (BinRNG g) = (x `mod` 2, BinRNG g')
107 where (x,g') = next g
108 #ifdef ENABLE_SPLITTABLEGEN
109 genRange _ = (0,1)
110 instance SplittableGen BinRNG where
111 #endif
112 split (BinRNG g) = (BinRNG g1, BinRNG g2)
113 where (g1,g2) = split g
114
115
116
117 #ifdef TEST_COMPETITORS
118 data MWCRNG = MWCRNG (Gen (PrimState IO))
119 -- data MWCRNG = MWCRNG GenIO
120 instance RandomGen MWCRNG where
121 -- For testing purposes we hack this to be non-monadic:
122 -- next g@(MWCRNG gen) = unsafePerformIO $
123 next g@(MWCRNG gen) = unsafeDupablePerformIO $
124 do v <- uniform gen
125 return (v, g)
126 #endif
127
128 ----------------------------------------------------------------------------------------------------
129 -- Drivers to get random numbers repeatedly.
130
131 type Kern = Int -> Ptr Int -> IO ()
132
133 -- [2011.01.28] Changing this to take "count" and "accumulator ptr" as arguments:
134 -- foreign import ccall "cbits/c_test.c" blast_rands :: Kern
135 -- foreign import ccall "cbits/c_test.c" store_loop :: Kern
136 -- foreign import ccall unsafe "stdlib.hs" rand :: IO Int
137
138 {-# INLINE timeit #-}
139 timeit :: (Random a, RandomGen g) =>
140 Int -> Int64 -> String -> g -> (g -> (a,g)) -> IO ()
141 timeit numthreads freq msg gen nxt =
142 do
143 counters <- forM [1..numthreads] (const$ newIORef (1::Int64))
144 tids <- forM counters $ \counter ->
145 forkIO $ infloop counter (nxt gen)
146 threadDelay (1000*1000) -- One second
147 mapM_ killThread tids
148
149 finals <- mapM readIORef counters
150 let mean :: Double = fromIntegral (foldl1 (+) finals) / fromIntegral numthreads
151 cycles_per :: Double = fromIntegral freq / mean
152 printResult (round mean :: Int64) msg cycles_per
153
154 where
155 infloop !counter !(!_,!g) =
156 do incr counter
157 infloop counter (nxt g)
158
159 incr !counter =
160 do -- modifyIORef counter (+1) -- Not strict enough!
161 c <- readIORef counter
162 let c' = c+1
163 _ <- evaluate c'
164 writeIORef counter c'
165
166
167 -- This function times an IO function on one or more threads. Rather
168 -- than running a fixed number of iterations, it uses a binary search
169 -- to find out how many iterations can be completed in a second.
170 timeit_foreign :: Int -> Int64 -> String -> (Int -> Ptr Int -> IO ()) -> IO Int64
171 timeit_foreign numthreads freq msg ffn = do
172 ptr :: ForeignPtr Int <- mallocForeignPtr
173
174 let kern = if numthreads == 1
175 then ffn
176 else replicate_kernel numthreads ffn
177 wrapped n = withForeignPtr ptr (kern$ fromIntegral n)
178 (n,t) <- binSearch False 1 (1.0, 1.05) wrapped
179
180 let total_per_second = round $ fromIntegral n * (1 / t)
181 cycles_per = fromIntegral freq * t / fromIntegral n
182 printResult total_per_second msg cycles_per
183 return total_per_second
184
185 where
186 -- This lifts a C kernel to operate simultaneously on N threads.
187 replicate_kernel :: Int -> Kern -> Kern
188 replicate_kernel nthreads kern n ptr = do
189 ptrs <- forM [1..nthreads]
190 (const mallocForeignPtr)
191 tmpchan <- newChan
192 -- let childwork = ceiling$ fromIntegral n / fromIntegral nthreads
193 let childwork = n -- Keep it the same.. interested in per-thread throughput.
194 -- Fork/join pattern:
195 _ <- forM ptrs $ \pt -> forkIO $
196 withForeignPtr pt $ \p -> do
197 kern (fromIntegral childwork) p
198 result <- peek p
199 writeChan tmpchan result
200
201 results <- forM [1..nthreads] $ \_ ->
202 readChan tmpchan
203 -- Meaningless semantics here... sum the child ptrs and write to the input one:
204 poke ptr (foldl1 (+) results)
205 return ()
206
207
208 printResult :: Int64 -> String -> Double -> IO ()
209 printResult total msg cycles_per =
210 putStrLn$ " "++ padleft 11 (commaint total) ++" randoms generated "++ padright 27 ("["++msg++"]") ++" ~ "
211 ++ fmt_num cycles_per ++" cycles/int"
212
213 ----------------------------------------------------------------------------------------------------
214 -- Main Script
215
216 data Flag = NoC | Help
217 deriving (Show, Eq)
218
219 options :: [OptDescr Flag]
220 options =
221 [ Option ['h'] ["help"] (NoArg Help) "print program help"
222 , Option [] ["noC"] (NoArg NoC) "omit C benchmarks, haskell only"
223 ]
224
225 main :: IO ()
226 main = do
227 argv <- getArgs
228 let (opts,_,other) = getOpt Permute options argv
229
230 when (not$ null other) $ do
231 putStrLn$ "ERROR: Unrecognized options: "
232 mapM_ putStr other
233 exitFailure
234
235 when (Help `elem` opts) $ do
236 putStr$ usageInfo "Benchmark random number generation" options
237 exitSuccess
238
239 putStrLn$ "\nHow many random numbers can we generate in a second on one thread?"
240
241 t1 <- rdtsc
242 t2 <- rdtsc
243 putStrLn (" Cost of rdtsc (ffi call): " ++ show (t2 - t1))
244
245 freq <- measureFreq
246 putStrLn$ " Approx clock frequency: " ++ commaint freq
247
248 let
249 randInt = random :: RandomGen g => g -> (Int,g)
250 randWord16 = random :: RandomGen g => g -> (Word16,g)
251 randFloat = random :: RandomGen g => g -> (Float,g)
252 randCFloat = random :: RandomGen g => g -> (CFloat,g)
253 randDouble = random :: RandomGen g => g -> (Double,g)
254 randCDouble = random :: RandomGen g => g -> (CDouble,g)
255 randInteger = random :: RandomGen g => g -> (Integer,g)
256 randBool = random :: RandomGen g => g -> (Bool,g)
257 randChar = random :: RandomGen g => g -> (Char,g)
258
259 gen = mkStdGen 23852358661234
260 gamut th = do
261 putStrLn$ " First, timing System.Random.next:"
262 timeit th freq "constant zero gen" NoopRNG next
263 timeit th freq "System.Random stdGen/next" gen next
264
265 putStrLn$ "\n Second, timing System.Random.random at different types:"
266 timeit th freq "System.Random Ints" gen randInt
267 timeit th freq "System.Random Word16" gen randWord16
268 timeit th freq "System.Random Floats" gen randFloat
269 timeit th freq "System.Random CFloats" gen randCFloat
270 timeit th freq "System.Random Doubles" gen randDouble
271 timeit th freq "System.Random CDoubles" gen randCDouble
272 timeit th freq "System.Random Integers" gen randInteger
273 timeit th freq "System.Random Bools" gen randBool
274 timeit th freq "System.Random Chars" gen randChar
275
276 #ifdef TEST_COMPETITORS
277 putStrLn$ "\n Next test other RNG packages on Hackage:"
278 let gen_mt = pureMT 39852
279 randInt2 = random :: RandomGen g => g -> (Int,g)
280 randFloat2 = random :: RandomGen g => g -> (Float,g)
281 timeit th freq "System.Random.Mersenne.Pure64 next" gen_mt next
282 timeit th freq "System.Random.Mersenne.Pure64 Ints" gen_mt randInt2
283 timeit th freq "System.Random.Mersenne.Pure64 Floats" gen_mt randFloat2
284
285 let gen_tf = seedTFGen (0,1,2,3)
286 randInt4 = random :: RandomGen g => g -> (Int,g)
287 randFloat4 = random :: RandomGen g => g -> (Float,g)
288 timeit th freq "System.Random.TF next" gen_tf next
289 timeit th freq "System.Random.TF Ints" gen_tf randInt4
290 timeit th freq "System.Random.TF Floats" gen_tf randFloat4
291
292 withSystemRandom $ \ gen_mwc -> do
293 let randInt3 = random :: RandomGen g => g -> (Int,g)
294 randFloat3 = random :: RandomGen g => g -> (Float,g)
295
296 timeit th freq "System.Random.MWC next" (MWCRNG gen_mwc) next
297 timeit th freq "System.Random.MWC Ints" (MWCRNG gen_mwc) randInt3
298 timeit th freq "System.Random.MWC Floats" (MWCRNG gen_mwc) randFloat3
299
300 #endif
301
302 putStrLn$ "\n Next timing range-restricted System.Random.randomR:"
303 timeit th freq "System.Random Ints" gen (randomR (-100, 100::Int))
304 timeit th freq "System.Random Word16s" gen (randomR (-100, 100::Word16))
305 timeit th freq "System.Random Floats" gen (randomR (-100, 100::Float))
306 timeit th freq "System.Random CFloats" gen (randomR (-100, 100::CFloat))
307 timeit th freq "System.Random Doubles" gen (randomR (-100, 100::Double))
308 timeit th freq "System.Random CDoubles" gen (randomR (-100, 100::CDouble))
309 timeit th freq "System.Random Integers" gen (randomR (-100, 100::Integer))
310 timeit th freq "System.Random Bools" gen (randomR (False, True::Bool))
311 timeit th freq "System.Random Chars" gen (randomR ('a', 'z'))
312 timeit th freq "System.Random BIG Integers" gen (randomR (0, (2::Integer) ^ (5000::Int)))
313
314 -- when (not$ NoC `elem` opts) $ do
315 -- putStrLn$ " Comparison to C's rand():"
316 -- timeit_foreign th freq "ptr store in C loop" store_loop
317 -- timeit_foreign th freq "rand/store in C loop" blast_rands
318 -- timeit_foreign th freq "rand in Haskell loop" (\n ptr -> forM_ [1..n]$ \_ -> rand )
319 -- timeit_foreign th freq "rand/store in Haskell loop" (\n ptr -> forM_ [1..n]$ \_ -> do n <- rand; poke ptr n )
320 -- return ()
321
322 -- Test with 1 thread and numCapabilities threads:
323 gamut 1
324 when (numCapabilities > 1) $ do
325 putStrLn$ "\nNow "++ show numCapabilities ++" threads, reporting mean randoms-per-second-per-thread:"
326 gamut numCapabilities
327 return ()
328
329 putStrLn$ "Finished."