Merge pull request #33 from thomie/master
[packages/random.git] / Benchmark / BinSearch.hs
1
2 {-
3 Binary search over benchmark input sizes.
4
5 There are many good ways to measure the time it takes to perform a
6 certain computation on a certain input. However, frequently, it's
7 challenging to pick the right input size for all platforms and all
8 compilataion modes.
9
10 Sometimes for linear-complexity benchmarks it is better to measure
11 /throughput/, i.e. elements processed per second. That is, fixing
12 the time of execution and measuring the amount of work done (rather
13 than the reverse). This library provides a simple way to search for
14 an appropriate input size that results in the desired execution time.
15
16 An alternative approach is to kill the computation after a certain
17 amount of time and observe how much work it has completed.
18 -}
19 module BinSearch
20 (
21 binSearch
22 )
23 where
24
25 import Control.Monad
26 import Data.Time.Clock -- Not in 6.10
27 import Data.List
28 import System.IO
29 import Prelude hiding (min,max,log)
30
31
32
33 -- | Binary search for the number of inputs to a computation that
34 -- results in a specified amount of execution time in seconds. For example:
35 --
36 -- > binSearch verbose N (min,max) kernel
37 --
38 -- ... will find the right input size that results in a time
39 -- between min and max, then it will then run for N trials and
40 -- return the median (input,time-in-seconds) pair.
41 binSearch :: Bool -> Integer -> (Double,Double) -> (Integer -> IO ()) -> IO (Integer, Double)
42 binSearch verbose trials (min,max) kernel =
43 do
44 when(verbose)$ putStrLn$ "[binsearch] Binary search for input size resulting in time in range "++ show (min,max)
45
46 let desired_exec_length = 1.0
47 good_trial t = (toRational t <= toRational max) && (toRational t >= toRational min)
48
49 -- At some point we must give up...
50 loop n | n > ((2::Integer) ^ (100::Integer)) = error "ERROR binSearch: This function doesn't seem to scale in proportion to its last argument."
51
52 -- Not allowed to have "0" size input, bump it back to one:
53 loop 0 = loop 1
54
55 loop n =
56 do
57 when(verbose)$ putStr$ "[binsearch:"++ show n ++ "] "
58 time <- timeit$ kernel n
59 when(verbose)$ putStrLn$ "Time consumed: "++ show time
60 let rate = fromIntegral n / time
61
62 -- [2010.06.09] Introducing a small fudge factor to help our guess get over the line:
63 let initial_fudge_factor = 1.10
64 fudge_factor = 1.01 -- Even in the steady state we fudge a little
65 guess = desired_exec_length * rate
66
67 -- TODO: We should keep more history here so that we don't re-explore input space we have already explored.
68 -- This is a balancing act because of randomness in execution time.
69
70 if good_trial time
71 then do
72 when(verbose)$ putStrLn$ "[binsearch] Time in range. LOCKING input size and performing remaining trials."
73 print_trial 1 n time
74 lockin (trials-1) n [time]
75
76 -- Here we're still in the doubling phase:
77 else if time < 0.100
78 then loop (2*n)
79
80 else do when(verbose)$
81 putStrLn$ "[binsearch] Estimated rate to be "
82 ++show (round rate::Integer)++" per second. Trying to scale up..."
83
84 -- Here we've exited the doubling phase, but we're making our first guess as to how big a real execution should be:
85 if time > 0.100 && time < 0.33 * desired_exec_length
86 then do when(verbose)$ putStrLn$ "[binsearch] (Fudging first guess a little bit extra)"
87 loop (round$ guess * initial_fudge_factor)
88 else loop (round$ guess * fudge_factor)
89
90 -- Termination condition: Done with all trials.
91 lockin 0 n log = do when(verbose)$ putStrLn$ "[binsearch] Time-per-unit for all trials: "++
92 (concat $ intersperse " " (map (show . (/ toDouble n) . toDouble) $ sort log))
93 return (n, log !! ((length log) `quot` 2)) -- Take the median
94
95 lockin trials_left n log =
96 do when(verbose)$ putStrLn$ "[binsearch]------------------------------------------------------------"
97 time <- timeit$ kernel n
98 -- hFlush stdout
99 print_trial (trials - trials_left +1 ) n time
100 -- when(verbose)$ hFlush stdout
101 lockin (trials_left - 1) n (time : log)
102
103 print_trial :: Integer -> Integer -> NominalDiffTime -> IO ()
104 print_trial trialnum n time =
105 let rate = fromIntegral n / time
106 timeperunit = time / fromIntegral n
107 in
108 when(verbose)$ putStrLn$ "[binsearch] TRIAL: "++show trialnum ++
109 " secPerUnit: "++ showTime timeperunit ++
110 " ratePerSec: "++ show (rate) ++
111 " seconds: "++showTime time
112
113
114
115 (n,t) <- loop 1
116 return (n, fromRational$ toRational t)
117
118 showTime :: NominalDiffTime -> String
119 showTime t = show ((fromRational $ toRational t) :: Double)
120
121 toDouble :: Real a => a -> Double
122 toDouble = fromRational . toRational
123
124
125 -- Could use cycle counters here.... but the point of this is to time
126 -- things on the order of a second.
127 timeit :: IO () -> IO NominalDiffTime
128 timeit io =
129 do strt <- getCurrentTime
130 io
131 end <- getCurrentTime
132 return (diffUTCTime end strt)
133 {-
134 test :: IO (Integer,Double)
135 test =
136 binSearch True 3 (1.0, 1.05)
137 (\n ->
138 do v <- newIORef 0
139 forM_ [1..n] $ \i -> do
140 old <- readIORef v
141 writeIORef v (old+i))
142 -}