Commits

Bryan O'Sullivan committed 69e7ea7

Add result I/O support; don't hold results in memory

Comments (0)

Files changed (12)

     , nfIO
     , whnfIO
     , bench
+    , bcompare
     , bgroup
     , runBenchmark
     , runAndAnalyse
     ) where
 
 import Criterion.Internal
+import Criterion.Types

Criterion/Analysis.hs

 
 import Control.Monad (when)
 import Criterion.Analysis.Types
-import Criterion.IO (note)
+import Criterion.IO.Printf (note)
 import Criterion.Measurement (secs)
 import Criterion.Monad (Criterion)
 import Data.Int (Int64)

Criterion/Analysis/Types.hs

     ) where
 
 import Control.DeepSeq (NFData(rnf))
+import Data.Binary (Binary)
 import Data.Data (Data, Typeable)
 import Data.Int (Int64)
 import Data.Monoid (Monoid(..))
     -- ^ More than 3 times the IQR above the third quartile.
     } deriving (Eq, Read, Show, Typeable, Data, Generic)
 
+instance Binary Outliers
 instance NFData Outliers
 
 -- | A description of the extent to which outliers in the sample data
                                 -- are useless).
                      deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
 
+instance Binary OutlierEffect
 instance NFData OutlierEffect
 
 instance Monoid Outliers where
     -- ^ Quantitative description of effect (a fraction between 0 and 1).
     } deriving (Eq, Read, Show, Typeable, Data, Generic)
 
+instance Binary OutlierVariance
+
 instance NFData OutlierVariance where
     rnf OutlierVariance{..} = rnf ovEffect `seq` rnf ovDesc `seq` rnf ovFraction
 
     , anOutlierVar :: OutlierVariance
     } deriving (Eq, Read, Show, Typeable, Data, Generic)
 
+instance Binary SampleAnalysis
+
 instance NFData SampleAnalysis where
     rnf SampleAnalysis{..} =
         rnf anMean `seq` rnf anStdDev `seq` rnf anOutlierVar

Criterion/Config.hs

     , cfgPerformGC    :: Last Bool   -- ^ Whether to run the GC between passes.
     , cfgPrintExit    :: PrintExit   -- ^ Whether to print information and exit.
     , cfgResamples    :: Last Int    -- ^ Number of resamples to perform.
+    , cfgResults      :: Last FilePath -- ^ File to write raw results to.
     , cfgReport       :: Last FilePath -- ^ Filename of report.
     , cfgSamples      :: Last Int    -- ^ Number of samples to collect.
     , cfgSummaryFile  :: Last FilePath -- ^ Filename of summary CSV.
                 , cfgPerformGC    = ljust True
                 , cfgPrintExit    = Nada
                 , cfgResamples    = ljust (100 * 1000)
+                , cfgResults      = mempty
                 , cfgReport       = mempty
                 , cfgSamples      = ljust 100
                 , cfgSummaryFile  = mempty
               , cfgPrintExit    = mempty
               , cfgReport       = mempty
               , cfgResamples    = mempty
+              , cfgResults      = mempty
               , cfgSamples      = mempty
               , cfgSummaryFile  = mempty
               , cfgCompareFile  = mempty
     , cfgPrintExit    = app cfgPrintExit a b
     , cfgReport       = app cfgReport a b
     , cfgResamples    = app cfgResamples a b
+    , cfgResults      = app cfgResults a b
     , cfgSamples      = app cfgSamples a b
     , cfgSummaryFile  = app cfgSummaryFile a b
     , cfgCompareFile  = app cfgCompareFile a b

Criterion/Environment.hs

 import Control.Monad (replicateM_)
 import Control.Monad.Trans (liftIO)
 import Criterion.Analysis (analyseMean)
-import Criterion.IO (note)
+import Criterion.IO.Printf (note)
 import Criterion.Measurement (getTime, runForAtLeast, time_)
 import Criterion.Monad (Criterion)
 import qualified Data.Vector.Unboxed as U
+{-# LANGUAGE OverloadedStrings #-}
 -- |
 -- Module      : Criterion.IO
 -- Copyright   : (c) 2009, 2010 Bryan O'Sullivan
 --
 -- Input and output actions.
 
-{-# LANGUAGE FlexibleInstances, Rank2Types, TypeSynonymInstances #-}
 module Criterion.IO
     (
-      CritHPrintfType
-    , note
-    , printError
-    , prolix
-    , summary
+      header
+    , hGetResults
+    , hPutResults
+    , readResults
+    , writeResults
     ) where
 
-import Control.Monad (when)
-import Control.Monad.Trans (liftIO)
-import Criterion.Config (Config, Verbosity(..), cfgSummaryFile, cfgVerbosity, fromLJ)
-import Criterion.Monad (Criterion, getConfig, getConfigItem)
-import Data.Monoid (getLast)
-import System.IO (Handle, stderr, stdout)
-import qualified Text.Printf (HPrintfType, hPrintf)
-import Text.Printf (PrintfArg)
+import Criterion.Types (ResultForest, ResultTree(..))
+import Data.Binary (Binary(..), encode)
+import Data.Binary.Get (runGetOrFail)
+import Data.Binary.Put (putByteString, putWord16be, runPut)
+import Data.Version (Version(..))
+import Paths_criterion (version)
+import System.IO (Handle, IOMode(..), withFile)
+import qualified Data.ByteString.Lazy as L
 
--- First item is the action to print now, given all the arguments
--- gathered together so far.  The second item is the function that
--- will take a further argument and give back a new PrintfCont.
-data PrintfCont = PrintfCont (IO ()) (PrintfArg a => a -> PrintfCont)
+header :: L.ByteString
+header = runPut $ do
+  putByteString "criterio"
+  mapM_ (putWord16be . fromIntegral) (versionBranch version)
 
--- | An internal class that acts like Printf/HPrintf.
---
--- The implementation is visible to the rest of the program, but the
--- details of the class are not.
-class CritHPrintfType a where
-  chPrintfImpl :: (Config -> Bool) -> PrintfCont -> a
+hGetResults :: Handle -> IO (Either String ResultForest)
+hGetResults handle = do
+  let fixup = reverse . nukem . reverse
+      nukem (Compare k _ : rs) = let (cs, rs') = splitAt k rs
+                                 in Compare k (fixup (reverse cs)) : nukem rs'
+      nukem (r : rs)           = r : nukem rs
+      nukem _                  = []
+  bs <- L.hGet handle (fromIntegral (L.length header))
+  if bs == header
+    then (Right . fixup) `fmap` readAll handle
+    else return $ Left "unexpected header"
 
+hPutResults :: Handle -> ResultForest -> IO ()
+hPutResults handle rs = do
+  L.hPut handle header
+  mapM_ (L.hPut handle . encode) rs
 
-instance CritHPrintfType (Criterion a) where
-  chPrintfImpl check (PrintfCont final _)
-    = do x <- getConfig
-         when (check x) (liftIO final)
-         return undefined
+readResults :: FilePath -> IO (Either String ResultForest)
+readResults path = withFile path ReadMode hGetResults
 
-instance CritHPrintfType (IO a) where
-  chPrintfImpl _ (PrintfCont final _)
-    = final >> return undefined
+writeResults :: FilePath -> ResultForest -> IO ()
+writeResults path rs = withFile path WriteMode (flip hPutResults rs)
 
-instance (CritHPrintfType r, PrintfArg a) => CritHPrintfType (a -> r) where
-  chPrintfImpl check (PrintfCont _ anotherArg) x
-    = chPrintfImpl check (anotherArg x)
-
-chPrintf :: CritHPrintfType r => (Config -> Bool) -> Handle -> String -> r
-chPrintf shouldPrint h s
-  = chPrintfImpl shouldPrint (make (Text.Printf.hPrintf h s)
-                                   (Text.Printf.hPrintf h s))
-  where
-    make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.HPrintfType r) =>
-                      a -> r) -> PrintfCont
-    make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x)
-                                                      (curCall' x))
-
-{- A demonstration of how to write printf in this style, in case it is
-ever needed
-  in fututre:
-
-cPrintf :: CritHPrintfType r => (Config -> Bool) -> String -> r
-cPrintf shouldPrint s
-  = chPrintfImpl shouldPrint (make (Text.Printf.printf s)
-  (Text.Printf.printf s))
-  where
-    make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.PrintfType r) => a -> r) -> PrintfCont
-    make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x) (curCall' x))
--}
-
--- | Print a \"normal\" note.
-note :: (CritHPrintfType r) => String -> r
-note = chPrintf ((> Quiet) . fromLJ cfgVerbosity) stdout
-
--- | Print verbose output.
-prolix :: (CritHPrintfType r) => String -> r
-prolix = chPrintf ((== Verbose) . fromLJ cfgVerbosity) stdout
-
--- | Print an error message.
-printError :: (CritHPrintfType r) => String -> r
-printError = chPrintf (const True) stderr
-
--- | Add to summary CSV (if applicable)
-summary :: String -> Criterion ()
-summary msg
-  = do sumOpt <- getConfigItem (getLast . cfgSummaryFile)
-       case sumOpt of
-         Just fn -> liftIO $ appendFile fn msg
-         Nothing -> return ()
-
+readAll :: Binary a => Handle -> IO [a]
+readAll handle = do
+  let go bs
+         | L.null bs = return []
+         | otherwise = case runGetOrFail get bs of
+                         Left (_, _, err) -> fail err
+                         Right (bs', _, a) -> (a:) `fmap` go bs'
+  go =<< L.hGetContents handle

Criterion/IO/Printf.hs

+-- |
+-- Module      : Criterion.IO.Printf
+-- Copyright   : (c) 2009, 2010 Bryan O'Sullivan
+--
+-- License     : BSD-style
+-- Maintainer  : bos@serpentine.com
+-- Stability   : experimental
+-- Portability : GHC
+--
+-- Input and output actions.
+
+{-# LANGUAGE FlexibleInstances, Rank2Types, TypeSynonymInstances #-}
+module Criterion.IO.Printf
+    (
+      CritHPrintfType
+    , note
+    , printError
+    , prolix
+    , summary
+    ) where
+
+import Control.Monad (when)
+import Control.Monad.Trans (liftIO)
+import Criterion.Config (Config, Verbosity(..), cfgSummaryFile, cfgVerbosity, fromLJ)
+import Criterion.Monad (Criterion, getConfig, getConfigItem)
+import Data.Monoid (getLast)
+import System.IO (Handle, stderr, stdout)
+import qualified Text.Printf (HPrintfType, hPrintf)
+import Text.Printf (PrintfArg)
+
+-- First item is the action to print now, given all the arguments
+-- gathered together so far.  The second item is the function that
+-- will take a further argument and give back a new PrintfCont.
+data PrintfCont = PrintfCont (IO ()) (PrintfArg a => a -> PrintfCont)
+
+-- | An internal class that acts like Printf/HPrintf.
+--
+-- The implementation is visible to the rest of the program, but the
+-- details of the class are not.
+class CritHPrintfType a where
+  chPrintfImpl :: (Config -> Bool) -> PrintfCont -> a
+
+
+instance CritHPrintfType (Criterion a) where
+  chPrintfImpl check (PrintfCont final _)
+    = do x <- getConfig
+         when (check x) (liftIO final)
+         return undefined
+
+instance CritHPrintfType (IO a) where
+  chPrintfImpl _ (PrintfCont final _)
+    = final >> return undefined
+
+instance (CritHPrintfType r, PrintfArg a) => CritHPrintfType (a -> r) where
+  chPrintfImpl check (PrintfCont _ anotherArg) x
+    = chPrintfImpl check (anotherArg x)
+
+chPrintf :: CritHPrintfType r => (Config -> Bool) -> Handle -> String -> r
+chPrintf shouldPrint h s
+  = chPrintfImpl shouldPrint (make (Text.Printf.hPrintf h s)
+                                   (Text.Printf.hPrintf h s))
+  where
+    make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.HPrintfType r) =>
+                      a -> r) -> PrintfCont
+    make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x)
+                                                      (curCall' x))
+
+{- A demonstration of how to write printf in this style, in case it is
+ever needed
+  in fututre:
+
+cPrintf :: CritHPrintfType r => (Config -> Bool) -> String -> r
+cPrintf shouldPrint s
+  = chPrintfImpl shouldPrint (make (Text.Printf.printf s)
+  (Text.Printf.printf s))
+  where
+    make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.PrintfType r) => a -> r) -> PrintfCont
+    make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x) (curCall' x))
+-}
+
+-- | Print a \"normal\" note.
+note :: (CritHPrintfType r) => String -> r
+note = chPrintf ((> Quiet) . fromLJ cfgVerbosity) stdout
+
+-- | Print verbose output.
+prolix :: (CritHPrintfType r) => String -> r
+prolix = chPrintf ((== Verbose) . fromLJ cfgVerbosity) stdout
+
+-- | Print an error message.
+printError :: (CritHPrintfType r) => String -> r
+printError = chPrintf (const True) stderr
+
+-- | Add to summary CSV (if applicable)
+summary :: String -> Criterion ()
+summary msg
+  = do sumOpt <- getConfigItem (getLast . cfgSummaryFile)
+       case sumOpt of
+         Just fn -> liftIO $ appendFile fn msg
+         Nothing -> return ()

Criterion/Internal.hs

-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, RecordWildCards #-}
+{-# LANGUAGE BangPatterns, RecordWildCards #-}
 -- |
 -- Module      : Criterion
 -- Copyright   : (c) 2009, 2010, 2011 Bryan O'Sullivan
 
 module Criterion.Internal
     (
-      Benchmarkable(..)
-    , Benchmark
-    , Pure
-    , nf
-    , whnf
-    , nfIO
-    , whnfIO
-    , bench
-    , bgroup
-    , runBenchmark
+      runBenchmark
     , runAndAnalyse
     , runNotAnalyse
     , prefix
     ) where
 
-import Control.Monad (replicateM_, when, mplus)
+import Control.Monad (foldM, replicateM_, when, mplus)
 import Control.Monad.Trans (liftIO)
-import Data.Data (Data, Typeable)
+import Data.Binary (encode)
+import qualified Data.ByteString.Lazy as L
 import Criterion.Analysis (Outliers(..), OutlierEffect(..), OutlierVariance(..),
                            SampleAnalysis(..), analyseSample,
                            classifyOutliers, noteOutliers)
 import Criterion.Config (Config(..), Verbosity(..), fromLJ)
 import Criterion.Environment (Environment(..))
-import Criterion.IO (note, prolix, summary)
+import Criterion.IO (header, hGetResults)
+import Criterion.IO.Printf (note, prolix, summary)
 import Criterion.Measurement (getTime, runForAtLeast, secs, time_)
 import Criterion.Monad (Criterion, getConfig, getConfigItem)
 import Criterion.Report (Report(..), report)
-import Criterion.Types (Benchmarkable(..), Benchmark(..), Pure,
-                        bench, bgroup, nf, nfIO, whnf, whnfIO)
+import Criterion.Types (Benchmark(..), Benchmarkable(..),
+                        Result(..), ResultForest, ResultTree(..))
 import qualified Data.Vector.Unboxed as U
 import Data.Monoid (getLast)
-import GHC.Generics (Generic)
 import Statistics.Resampling.Bootstrap (Estimate(..))
 import Statistics.Types (Sample)
+import System.Directory (getTemporaryDirectory, removeFile)
+import System.IO (IOMode(..), SeekMode(..), hClose, hSeek, openBinaryFile,
+                  openBinaryTempFile)
 import System.Mem (performGC)
 import Text.Printf (printf)
 
 plotAll descTimes = do
   report (zipWith (\n (Result d t a o) -> Report n d t a o) [0..] descTimes)
 
-data Result = Result { description    :: String
-                     , _sample        :: Sample
-                     , sampleAnalysis :: SampleAnalysis
-                     , _outliers      :: Outliers
-                     }
-            deriving (Eq, Read, Show, Typeable, Data, Generic)
-
-type ResultForest = [ResultTree]
-data ResultTree = Single Result | Compare ResultForest
-                deriving (Eq, Read, Show, Typeable, Data, Generic)
-
 -- | Run, and analyse, one or more benchmarks.
 runAndAnalyse :: (String -> Bool) -- ^ A predicate that chooses
                                   -- whether to run a benchmark by its
               -> Benchmark
               -> Criterion ()
 runAndAnalyse p env bs' = do
-  rts <- go "" bs'
+  mbResultFile <- getConfigItem $ getLast . cfgResults
+  (resultFile, handle) <- liftIO $
+    case mbResultFile of
+      Nothing -> do
+        tmpDir <- getTemporaryDirectory
+        openBinaryTempFile tmpDir "criterion.dat"
+      Just file -> do
+        handle <- openBinaryFile file ReadWriteMode
+        return (file, handle)
+  liftIO $ L.hPut handle header
+
+  let go !k (pfx, Benchmark desc b)
+          | p desc'   = do _ <- note "\nbenchmarking %s\n" desc'
+                           summary (show desc' ++ ",") -- String will be quoted
+                           (x,an,out) <- runAndAnalyseOne env desc' b
+                           let result = Single $ Result desc' x an out
+                           liftIO $ L.hPut handle (encode result)
+                           return $! k + 1
+          | otherwise = return (k :: Int)
+          where desc' = prefix pfx desc
+      go !k (pfx, BenchGroup desc bs) =
+          foldM go k [(prefix pfx desc, b) | b <- bs]
+      go !k (pfx, BenchCompare bs) = do
+                          l <- foldM go 0 [(pfx, b) | b <- bs]
+                          let result = Compare l []
+                          liftIO $ L.hPut handle (encode result)
+                          return $! l + k
+  _ <- go 0 ("", bs')
+
+  rts <- (either fail return =<<) . liftIO $ do
+    hSeek handle AbsoluteSeek 0
+    rs <- hGetResults handle
+    hClose handle
+    case mbResultFile of
+      Just _ -> return rs
+      _      -> removeFile resultFile >> return rs
 
   mbCompareFile <- getConfigItem $ getLast . cfgCompareFile
   case mbCompareFile of
   plotAll rs
   junit rs
 
-  where go :: String -> Benchmark -> Criterion ResultForest
-        go pfx (Benchmark desc b)
-            | p desc'   = do _ <- note "\nbenchmarking %s\n" desc'
-                             summary (show desc' ++ ",") -- String will be quoted
-                             (x,an,out) <- runAndAnalyseOne env desc' b
-                             let result = Result desc' x an out
-                             return [Single result]
-            | otherwise = return []
-            where desc' = prefix pfx desc
-        go pfx (BenchGroup desc bs) =
-            concat `fmap` mapM (go (prefix pfx desc)) bs
-        go pfx (BenchCompare bs) = ((:[]) . Compare . concat) `fmap` mapM (go pfx) bs
-
 runNotAnalyse :: (String -> Bool) -- ^ A predicate that chooses
                                   -- whether to run a benchmark by its
                                   -- name.
 flatten :: ResultForest -> [Result]
 flatten [] = []
 flatten (Single r    : rs) = r : flatten rs
-flatten (Compare crs : rs) = flatten crs ++ flatten rs
+flatten (Compare _ crs : rs) = flatten crs ++ flatten rs
 
 resultForestToCSV :: ResultForest -> String
 resultForestToCSV = unlines
           top :: ResultForest -> [(String, String, Double)]
           top [] = []
           top (Single _     : rts) = top rts
-          top (Compare rts' : rts) = cmpRT rts' ++ top rts
+          top (Compare _ rts' : rts) = cmpRT rts' ++ top rts
 
           cmpRT :: ResultForest -> [(String, String, Double)]
           cmpRT [] = []
           cmpRT (Single r     : rts) = cmpWith r rts
-          cmpRT (Compare rts' : rts) = case getReference rts' of
+          cmpRT (Compare _ rts' : rts) = case getReference rts' of
                                          Nothing -> cmpRT rts
                                          Just r  -> cmpRT rts' ++ cmpWith r rts
 
           cmpWith :: Result -> ResultForest -> [(String, String, Double)]
           cmpWith _   [] = []
           cmpWith ref (Single r     : rts) = cmp ref r : cmpWith ref rts
-          cmpWith ref (Compare rts' : rts) = cmpRT rts'       ++
+          cmpWith ref (Compare _ rts' : rts) = cmpRT rts'       ++
                                              cmpWith ref rts' ++
                                              cmpWith ref rts
 
           getReference :: ResultForest -> Maybe Result
           getReference []                   = Nothing
           getReference (Single r     : _)   = Just r
-          getReference (Compare rts' : rts) = getReference rts' `mplus`
+          getReference (Compare _ rts' : rts) = getReference rts' `mplus`
                                               getReference rts
 
 cmp :: Result -> Result -> (String, String, Double)

Criterion/Main.hs

 import Criterion.Internal (runAndAnalyse, runNotAnalyse, prefix)
 import Criterion.Config
 import Criterion.Environment (measureEnvironment)
-import Criterion.IO (note, printError)
+import Criterion.IO.Printf (note, printError)
 import Criterion.Monad (Criterion, withConfig)
 import Criterion.Types (Benchmarkable(..), Benchmark(..), Pure, bench,
                         benchNames, bgroup, bcompare, nf, nfIO, whnf, whnfIO)
  , Option [] ["resamples"]
           (ReqArg (pos "resample count"$ \n -> mempty { cfgResamples = n }) "N")
           "number of bootstrap resamples to perform"
+ , Option [] ["results"]
+          (ReqArg (\n -> return $ mempty { cfgResults = ljust n }) "FILENAME")
+          "file to write raw results to"
  , Option ['s'] ["samples"]
           (ReqArg (pos "sample count" $ \n -> mempty { cfgSamples = n }) "N")
           "number of samples to collect"

Criterion/Types.hs

-{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GADTs #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, ExistentialQuantification,
+    FlexibleInstances, GADTs #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
 
 -- |
 
 module Criterion.Types
     (
+    -- * Benchmark descriptions
       Benchmarkable(..)
     , Benchmark(..)
     , Pure
     , bgroup
     , bcompare
     , benchNames
+    -- * Result types
+    , Result(..)
+    , ResultForest
+    , ResultTree(..)
     ) where
 
 import Control.DeepSeq (NFData, rnf)
 import Control.Exception (evaluate)
+import Criterion.Analysis.Types (Outliers(..), SampleAnalysis(..))
+import Data.Binary (Binary)
+import Data.Data (Data, Typeable)
+import GHC.Generics (Generic)
+import Statistics.Types (Sample)
 
 -- | A benchmarkable function or action.
 class Benchmarkable a where
     show (Benchmark d _)  = ("Benchmark " ++ show d)
     show (BenchGroup d _) = ("BenchGroup " ++ show d)
     show (BenchCompare _) = ("BenchCompare")
+
+data Result = Result {
+      description    :: String
+    , sample         :: Sample
+    , sampleAnalysis :: SampleAnalysis
+    , outliers       :: Outliers
+    } deriving (Eq, Read, Show, Typeable, Data, Generic)
+
+instance Binary Result
+
+type ResultForest = [ResultTree]
+data ResultTree = Single Result
+                | Compare !Int ResultForest
+                  deriving (Eq, Read, Show, Typeable, Data, Generic)
+
+instance Binary ResultTree
 name:           criterion
-version:        0.7.1.0
+version:        0.8.0.0
 synopsis:       Robust, reliable performance measurement and analysis
 license:        BSD3
 license-file:   LICENSE
     Criterion.Config
     Criterion.Environment
     Criterion.IO
+    Criterion.IO.Printf
     Criterion.Main
     Criterion.Measurement
     Criterion.Monad
   build-depends:
     aeson >= 0.3.2.12,
     base < 5,
+    binary >= 0.6.3.0,
     bytestring >= 0.9 && < 1.0,
     containers,
     deepseq >= 1.1.0.0,

examples/Comparison.hs

+import Criterion.Main
+
+main = defaultMain [
+   bcompare [
+     bench "exp" $ whnf exp (2 :: Double)
+   , bench "log" $ whnf log (2 :: Double)
+   , bench "sqrt" $ whnf sqrt (2 :: Double)
+   ]
+ ]