Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

134 lines (103 sloc) 4.532 kB
-- This is a script used for timing the throughput of benchmarks that
-- take one argument and have linear complexity.
module Benchmark.BinSearch
(
binSearch
)
where
import Control.Monad
import Data.Time.Clock -- Not in 6.10
import Data.List
import Data.IORef
import System
import System.IO
import System.Cmd
import System.Exit
import Debug.Trace
-- In seconds:
--desired_exec_length = 3
-- | Binary search for the number of inputs to a computation that
-- | makes it take a specified time in seconds.
--
-- > binSearch verbose N (min,max) kernel
--
-- | binSearch 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)
--loop :: Bool -> [String] -> Int -> Integer -> IO ()
-- At some point we must give up...
loop n | n > (2 ^ 100) = 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 ++ "] "
-- hFlush stdout
time <- timeit$ kernel n
when(verbose)$ putStrLn$ "Time consumed: "++ show time
-- hFlush stdout
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)++" 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 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 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 =
do strt <- getCurrentTime
io
end <- getCurrentTime
return (diffUTCTime end strt)
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))
Jump to Line
Something went wrong with that request. Please try again.