Permalink
Browse files

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

--HG--
rename : Criterion/IO.hs => Criterion/IO/Printf.hs
  • Loading branch information...
1 parent e41298e commit 03c049d4c39e141eb405686d102d60449ae7b26f @bos committed Apr 15, 2013
View
@@ -20,10 +20,12 @@ module Criterion
, nfIO
, whnfIO
, bench
+ , bcompare
, bgroup
, runBenchmark
, runAndAnalyse
, runNotAnalyse
) where
import Criterion.Internal
+import Criterion.Types
View
@@ -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)
@@ -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
View
@@ -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
View
@@ -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
View
@@ -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
View
@@ -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 ()
Oops, something went wrong.

0 comments on commit 03c049d

Please sign in to comment.