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

--HG--
rename : Criterion/IO.hs => Criterion/IO/Printf.hs

Criterion.hs

@@ -20,10 +20,12 @@ module Criterion
     , nfIO
     , whnfIO
     , bench
+    , bcompare
     , bgroup
     , runBenchmark
     , runAndAnalyse
     , runNotAnalyse
     ) where
 
 import Criterion.Internal
+import Criterion.Types

Criterion/Analysis.hs

@@ -27,7 +27,7 @@ module Criterion.Analysis
 
 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

@@ -20,6 +20,7 @@ module Criterion.Analysis.Types
     ) where
 
 import Control.DeepSeq (NFData(rnf))
+import Data.Binary (Binary)
 import Data.Data (Data, Typeable)
 import Data.Int (Int64)
 import Data.Monoid (Monoid(..))
@@ -41,6 +42,7 @@ data Outliers = Outliers {
     -- ^ 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
@@ -52,6 +54,7 @@ data OutlierEffect = Unaffected -- ^ Less than 1% effect.
                                 -- are useless).
                      deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
 
+instance Binary OutlierEffect
 instance NFData OutlierEffect
 
 instance Monoid Outliers where
@@ -74,6 +77,8 @@ data OutlierVariance = OutlierVariance {
     -- ^ 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
 
@@ -84,6 +89,8 @@ data SampleAnalysis = SampleAnalysis {
     , 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

@@ -58,6 +58,7 @@ data Config = Config {
     , 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.
@@ -81,6 +82,7 @@ defaultConfig = Config {
                 , cfgPerformGC    = ljust True
                 , cfgPrintExit    = Nada
                 , cfgResamples    = ljust (100 * 1000)
+                , cfgResults      = mempty
                 , cfgReport       = mempty
                 , cfgSamples      = ljust 100
                 , cfgSummaryFile  = mempty
@@ -112,6 +114,7 @@ emptyConfig = Config {
               , cfgPrintExit    = mempty
               , cfgReport       = mempty
               , cfgResamples    = mempty
+              , cfgResults      = mempty
               , cfgSamples      = mempty
               , cfgSummaryFile  = mempty
               , cfgCompareFile  = mempty
@@ -131,6 +134,7 @@ appendConfig a b =
     , 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

@@ -20,7 +20,7 @@ module Criterion.Environment
 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

Criterion/IO.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 -- |
 -- Module      : Criterion.IO
 -- Copyright   : (c) 2009, 2010 Bryan O'Sullivan
@@ -9,92 +10,57 @@
 --
 -- 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)
-
--- 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 ()
-
+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
+
+header :: L.ByteString
+header = runPut $ do
+  putByteString "criterio"
+  mapM_ (putWord16be . fromIntegral) (versionBranch version)
+
+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
+
+readResults :: FilePath -> IO (Either String ResultForest)
+readResults path = withFile path ReadMode hGetResults
+
+writeResults :: FilePath -> ResultForest -> IO ()
+writeResults path rs = withFile path WriteMode (flip hPutResults rs)
+
+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

@@ -0,0 +1,99 @@
+-- |
+-- 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 ()