diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +# 0.5.1 + +* Add `benchCont` combinator. +* Set default timeout to 100 seconds. +* Use CAPI for foreign calls on Windows. +* Workaround `+cpuTimePrecision` on NetBSD. + # 0.5 * Extend `TimeMode` with `MutatorCpuTime`, `MutatorWallTime` and `CustomTime`. diff --git a/src/Test/Tasty/Bench.hs b/src/Test/Tasty/Bench.hs --- a/src/Test/Tasty/Bench.hs +++ b/src/Test/Tasty/Bench.hs @@ -650,6 +650,7 @@ -} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CApiFFI #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} @@ -670,6 +671,7 @@ , Benchmark , bench , bgroup + , benchCont , bcompare , bcompareWithin , env @@ -714,7 +716,8 @@ import Control.Arrow (first, second) import Control.DeepSeq (NFData, force, rnf) import Control.Exception (bracket, bracket_, evaluate) -import Control.Monad (void, unless, guard, (>=>), when) +import Control.Monad (void, unless, guard, join, (>=>), when) +import Control.Monad.Trans.Cont import Data.Data (Data) import Data.Foldable (foldMap, traverse_) import Data.Int (Int64) @@ -1115,10 +1118,19 @@ (estStdev (predict (hi t1) (lo t2))) } where - prec = max (fromInteger cpuTimePrecision) 1000000000 -- 1 ms + prec = max (fromInteger cpuTimePrecision') 1000000000 -- 1 ms hi meas = meas { measTime = measTime meas + prec } lo meas = meas { measTime = if measTime meas > prec then measTime meas - prec else 0 } +#ifdef netbsd_HOST_OS +-- cpuTimePrecision seems to fail on NetBSD +cpuTimePrecision' :: Prelude.Integer +cpuTimePrecision' = 0 +#else +cpuTimePrecision' :: Prelude.Integer +cpuTimePrecision' = cpuTimePrecision +#endif + hasGCStats :: Bool #if MIN_VERSION_base(4,10,0) hasGCStats = unsafePerformIO getRTSStatsEnabled @@ -1260,14 +1272,7 @@ #ifdef MIN_VERSION_tasty instance IsTest Benchmarkable where - testOptions = pure - [ Option (Proxy :: Proxy RelStDev) - -- FailIfSlower and FailIfFaster must be options of a test provider rather - -- than options of an ingredient to allow setting them on per-test level. - , Option (Proxy :: Proxy FailIfSlower) - , Option (Proxy :: Proxy FailIfFaster) - , Option (Proxy :: Proxy TimeMode) - ] + testOptions = pure benchOptions run opts b yieldProgress = case getNumThreads (lookupOption opts) of 1 -> do let timeMode = lookupOption opts @@ -1277,6 +1282,16 @@ pure $ testPassed $ show (WithLoHi est (1 - ifFaster) (1 + ifSlower)) _ -> pure $ testFailed "Benchmarks must not be run concurrently. Please pass -j1 and/or avoid +RTS -N." +benchOptions :: [OptionDescription] +benchOptions = + [ Option (Proxy :: Proxy RelStDev) + -- FailIfSlower and FailIfFaster must be options of a test provider rather + -- than options of an ingredient to allow setting them on per-test level. + , Option (Proxy :: Proxy FailIfSlower) + , Option (Proxy :: Proxy FailIfFaster) + , Option (Proxy :: Proxy TimeMode) + ] + -- | Attach a name to t'Benchmarkable'. -- -- This is actually a synonym of 'Test.Tasty.Providers.singleTest' to @@ -1297,6 +1312,63 @@ bgroup :: String -> [Benchmark] -> Benchmark bgroup = testGroup +-- | Run a t'Benchmarkable' inside some larger action. +-- +-- Prefer using 'env' or 'withResource' to avoid benchmarking setup/teardown code. +-- But this isn't always possible, like when using a library that only +-- exposes resources through `bracket`-style continuation passing. +-- Imagine an alternate reality where 'withBinaryFile' can not be +-- split into 'openFile' and 'hClose': +-- +-- > -- Broken: +-- > withResource +-- > (withBinaryFile "NO.txt" WriteMode $ pure) +-- > (pure . const ()) +-- > benchmarkWrites +-- +-- This benchmark writes to a closed file handle, which will not go well. +-- Instead, @benchCont@ allows you to embed a t'Benchmarkable' +-- in a continuation. As a trivial example, +-- +-- > main :: IO () +-- > main = defaultMain +-- > [ benchCont "write syscall" $ ContT benchmarkWrites ] +-- > +-- > benchmarkWrites :: (Benchmarkable -> IO ()) -> IO () +-- > benchmarkWrites runBenchmark = withBinaryFile "/dev/null" WriteMode $ \fh -> do +-- > hSetBuffering fh NoBuffering +-- > runBenchmark $ whnfAppIO putHello fh +-- > -- equivalently, +-- > -- runBenchmark $ whnfIO (putHello fh) +-- > +-- > putHello :: Handle -> IO () +-- > putHello h = hPutStrLn h "hi" +-- +-- Calling the runner more than once is unspecified behavior. +-- Create a separate 'Benchmark' instead. +-- +-- @since 0.5.1 +benchCont :: String -> ContT () IO Benchmarkable -> Benchmark +benchCont = singleTest + +#if !MIN_VERSION_tasty(1,5,4) +instance IsTest (ContT () IO Benchmarkable) where + testOptions = pure benchOptions + run opts (ContT bracketedBenchmark) yieldProgress = do + rr <- newIORef Nothing + let run' :: Benchmarkable -> IO () + run' b = do + r <- run opts b yieldProgress + join . atomicModifyIORef' rr $ \prev -> case prev of + Nothing -> (Just r, pure ()) + p -> (p, error "Benchmarkable called multiple times") + bracketedBenchmark run' + maybeRes <- readIORef rr + pure $ case maybeRes of + Nothing -> testFailed "Provided ContT didn't run the passed Benchmarkable" + Just r -> r +#endif + -- | Compare benchmarks, reporting relative speed up or slow down. -- -- This function is a vague reminiscence of @bcompare@, which existed in pre-1.0 @@ -1353,11 +1425,17 @@ -- -- @since 0.3.1 bcompareWithin - :: Double -- ^ Lower bound of relative speed up. - -> Double -- ^ Upper bound of relative speed up. - -> String -- ^ @tasty@ pattern to locate a baseline benchmark. - -> Benchmark -- ^ Benchmark to compare against baseline. + :: Double + -- ^ Lower bound of relative speed up. + -> Double + -- ^ Upper bound of relative speed up. + -> String + -- ^ @tasty@ pattern, which must unambiguously + -- match a unique baseline benchmark. Consider using 'locateBenchmark' to construct it. -> Benchmark + -- ^ Benchmark + -- to be compared against the baseline benchmark by dividing measured mean times. + -> Benchmark bcompareWithin lo hi s = case parseExpr s of Nothing -> error $ "Could not parse bcompare pattern " ++ s Just e -> after_ AllSucceed (And (StringLit (bcomparePrefix ++ show (lo, hi))) e) @@ -1387,6 +1465,11 @@ let act = defaultMain' bs bracketUtf8 act +withDefaultTimeout :: TestTree -> TestTree +withDefaultTimeout = adjustOption $ \opt -> case opt of + Timeout{} -> opt + NoTimeout -> mkTimeout 100000000 + bracketUtf8 :: IO a -> IO a bracketUtf8 act = do prevStdoutEnc <- hGetEncoding stdout @@ -1408,14 +1491,10 @@ defaultMain' :: [Benchmark] -> IO () defaultMain' bs = do installSignalHandlers - let b = testGroup "All" bs + let b = withDefaultTimeout $ testGroup "All" bs opts <- parseOptions benchIngredients b let opts' = setOption (NumThreads 1) opts -#if MIN_VERSION_tasty(1,5,0) opts'' = setOption (MinDurationToReport 1000000000000) opts' -#else - opts'' = opts' -#endif case tryIngredients benchIngredients opts'' b of Nothing -> exitFailure Just act -> act >>= \x -> if x then exitSuccess else exitFailure @@ -2176,21 +2255,13 @@ testNameSeqs :: OptionSet -> TestTree -> [Seq TestName] testNameSeqs = foldTestTree trivialFold { foldSingle = const $ const . (:[]) . Seq.singleton -#if MIN_VERSION_tasty(1,5,0) , foldGroup = const $ (. concat) . map . (<|) -#else - , foldGroup = const $ map . (<|) -#endif } testNamesAndDeps :: IntMap (Seq TestName) -> OptionSet -> TestTree -> [(TestName, Unique (WithLoHi IM.Key))] testNamesAndDeps im = foldTestTree trivialFold { foldSingle = const $ const . (: []) . (, mempty) -#if MIN_VERSION_tasty(1,5,0) , foldGroup = const $ (. concat) . map . first . (++) . (++ ".") -#else - , foldGroup = const $ map . first . (++) . (++ ".") -#endif , foldAfter = const foldDeps } where @@ -2236,7 +2307,6 @@ writeTVar oldTV (Done (f name depRes res)) pure (Any True, All True) -#if MIN_VERSION_tasty(1,5,0) Executing newProgr -> do let updated = case old of Executing oldProgr -> oldProgr /= newProgr @@ -2244,9 +2314,6 @@ when updated $ writeTVar oldTV (Executing newProgr) pure (Any updated, All False) -#else - Executing{} -> pure (Any False, All False) -#endif NotStarted -> pure (Any False, All False) if anyUpdated || allDone then pure allDone else retry adNauseam = doUpdate >>= (`unless` adNauseam) @@ -2272,14 +2339,8 @@ #if defined(mingw32_HOST_OS) -#if defined(i386_HOST_ARCH) -#define CCONV stdcall -#else -#define CCONV ccall -#endif - -foreign import CCONV unsafe "windows.h GetConsoleOutputCP" getConsoleOutputCP :: IO Word32 -foreign import CCONV unsafe "windows.h SetConsoleOutputCP" setConsoleOutputCP :: Word32 -> IO () +foreign import capi unsafe "windows.h GetConsoleOutputCP" getConsoleOutputCP :: IO Word32 +foreign import capi unsafe "windows.h SetConsoleOutputCP" setConsoleOutputCP :: Word32 -> IO () #endif diff --git a/tasty-bench.cabal b/tasty-bench.cabal --- a/tasty-bench.cabal +++ b/tasty-bench.cabal @@ -1,5 +1,5 @@ name: tasty-bench -version: 0.5 +version: 0.5.1 cabal-version: 1.18 build-type: Simple license: MIT @@ -46,14 +46,15 @@ build-depends: base >= 4.9 && < 5, - deepseq >= 1.1 && < 1.6 + deepseq >= 1.1 && < 1.6, + transformers >= 0.4 && < 0.7 if impl(ghc < 9.0) build-depends: ghc-prim < 0.14 if flag(tasty) build-depends: containers >= 0.5 && < 0.9, - tasty >= 1.4 && < 1.6 + tasty >= 1.5 && < 1.6 if impl(ghc < 8.4) build-depends: time >= 1.2 && < 2