1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
{-
Binary search over benchmark input sizes.
There are many good ways to measure the time it takes to perform a
certain computation on a certain input. However, frequently, it's
challenging to pick the right input size for all platforms and all
compilataion modes.
Sometimes for linear-complexity benchmarks it is better to measure
/throughput/, i.e. elements processed per second. That is, fixing
the time of execution and measuring the amount of work done (rather
than the reverse). This library provides a simple way to search for
an appropriate input size that results in the desired execution time.
An alternative approach is to kill the computation after a certain
amount of time and observe how much work it has completed.
-}
module BinSearch
(
binSearch
)
where
import Control.Monad
import Data.Time.Clock -- Not in 6.10
import Data.List
import System.IO
import Prelude hiding (min,max,log)
-- | Binary search for the number of inputs to a computation that
-- results in a specified amount of execution time in seconds. For example:
--
-- > binSearch verbose N (min,max) kernel
--
-- ... will find the right input size that results in a time
-- 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]
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)
showTime :: NominalDiffTime -> String
showTime t = show ((fromRational $ toRational t) :: Double)
toDouble :: Real a => a -> Double
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)
{-
test :: IO (Integer,Double)
test =
binSearch True 3 (1.0, 1.05)
(\n ->
do v <- newIORef 0
forM_ [1..n] $ \i -> do
old <- readIORef v
writeIORef v (old+i))
-}
|
