random-1.2.0: bench-legacy/BinSearch.hs

{-
 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))
-}