From e5f78722ced2e99136e7ecbb24fdb8f58e74eeaa Mon Sep 17 00:00:00 2001 From: Bodigrim Date: Sat, 1 Jun 2024 21:58:51 +0100 Subject: [PATCH] Implement Test.Tasty.Bench.Crossover --- .github/workflows/haskell-ci.yml | 16 +-- src/Test/Tasty/Bench/Equalize.hs | 139 +++++++++++++++++++++++++ src/Test/Tasty/Bench/Fit.hs | 29 ++---- src/Test/Tasty/Bench/Fit/Complexity.hs | 14 +-- src/Test/Tasty/Bench/Utils.hs | 48 +++++++++ tasty-bench-fit.cabal | 10 +- 6 files changed, 205 insertions(+), 51 deletions(-) create mode 100644 src/Test/Tasty/Bench/Equalize.hs create mode 100644 src/Test/Tasty/Bench/Utils.hs diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index f0f0261..9802d67 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -28,9 +28,9 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.10.0.20240413 + - compiler: ghc-9.10.1 compilerKind: ghc - compilerVersion: 9.10.0.20240413 + compilerVersion: 9.10.1 setup-method: ghcup allow-failure: false - compiler: ghc-9.8.2 @@ -141,18 +141,6 @@ jobs: repository hackage.haskell.org url: http://hackage.haskell.org/ EOF - if $HEADHACKAGE; then - cat >> $CABAL_CONFIG <> $CABAL_CONFIG < Benchmarkable + -- ^ A benchmark which is faster at 'eqlLow', typically 'nf' @f@. + , eqlFasterOnHigh :: Word -> Benchmarkable + -- ^ A benchmark which is faster at 'eqlHigh', typically 'nf' @g@. + , eqlLow :: Word + -- ^ An argument at which 'eqlFasterOnLow' is faster than 'eqlFasterOnHigh'. + , eqlHigh :: Word + -- ^ An argument at which 'eqlFasterOnHigh' is faster than 'eqlFasterOnLow'. + , eqlTimeout :: Timeout + -- ^ Timeout of individual measurements. + } + +-- | Generate a default 'crossovers' configuration. +mkCrossoverConfig + :: (NFData a) + => (Word -> a) + -- ^ An algorithm which is faster for small arguments, without 'nf'. + -> (Word -> a) + -- ^ An algorithm which is faster for large arguments, without 'nf'. + -> (Word, Word) + -- ^ Small and large arguments. + -> CrossoverConfig +mkCrossoverConfig fLow fHigh (low, high) = + CrossoverConfig + { eqlFasterOnLow = nf fLow + , eqlFasterOnHigh = nf fHigh + , eqlLow = low + , eqlHigh = high + , eqlTimeout = mkTimeout 1e8 + } + +-- | Determine crossover region to switch between two algorithms. +-- Ideally the returned crossover region is just a point like @(n, n + 1)@, +-- but depending on 'eqlTimeout' it could be a larger interval. +-- +-- While suitable for automatic estimates, 'crossover' generally provides bad user +-- experience in interactive environments, because it can take a very long time +-- before it returns a result without any heartbeat in between. Consider using +-- 'crossovers' or enabling @debug@ flag. +crossover :: CrossoverConfig -> IO (NonEmpty (Word, Word)) +crossover = fmap NE.last . crossovers + +-- | Same as 'crossover', but interactively emits a list of crossover regions, +-- gradually tightening to the final result. +crossovers :: CrossoverConfig -> IO (NonEmpty (Word, Word)) +crossovers CrossoverConfig {..} = NE.fromList <$> go (RelStDev (1 / 3)) eqlLow eqlHigh + where + go targetRelStdDev lo hi = fmap ((lo, hi) :) $ + unsafeInterleaveIO $ do + let mid = (lo + hi) `quot` 2 + if mid == lo + then pure [] + else do + (cmp, targetRelStdDev') <- compareBenchmarks eqlTimeout targetRelStdDev (eqlFasterOnLow mid) (eqlFasterOnHigh mid) + case cmp of + LT -> go targetRelStdDev' mid hi + EQ -> pure [] + GT -> go targetRelStdDev' lo mid + +compareBenchmarks + :: Timeout + -> RelStDev + -> Benchmarkable + -> Benchmarkable + -> IO (Ordering, RelStDev) +compareBenchmarks tmt = go dummyMeasure + where + dummyMeasure = Measurement {measTime = 1 / 0, measStDev = 1 / 0} + + go meas1 tgtRelStdDev bench1 bench2 = do + meas2 <- measure tmt tgtRelStdDev bench2 + traceShowM' (tgtRelStdDev, meas2) + let derived = deriveRelStdDev meas1 meas2 + derivedTgtRelStdDev = if derived > 0 then derived else getRelStDev tgtRelStdDev + case compareMeasurements meas1 meas2 of + LT -> pure (LT, RelStDev derivedTgtRelStdDev) + GT -> pure (GT, RelStDev derivedTgtRelStdDev) + EQ -> + if ((>) `on` getRelStDev) (measRelStDev meas2) tgtRelStdDev + then pure (EQ, RelStDev 0.0) + else do + let tgtRelStdDev' = + RelStDev $ + max + derivedTgtRelStdDev + (getRelStDev tgtRelStdDev / 2) + first flipOrdering <$> go meas2 tgtRelStdDev' bench2 bench1 + +compareMeasurements + :: Measurement + -> Measurement + -> Ordering +compareMeasurements (Measurement mean1 stdev1) (Measurement mean2 stdev2) + | mean1 + 2 * stdev1 < mean2 - 2 * stdev2 = LT + | mean2 + 2 * stdev2 < mean1 - 2 * stdev1 = GT + | otherwise = EQ + +deriveRelStdDev + :: Measurement + -> Measurement + -> Double +deriveRelStdDev (Measurement mean1 _) (Measurement mean2 _) + | isInfinite mean1 || isInfinite mean2 = 0 + | otherwise = + abs (mean1 - mean2) / max mean1 mean2 / 4 + +flipOrdering + :: Ordering + -> Ordering +flipOrdering = \case + LT -> GT + EQ -> EQ + GT -> LT diff --git a/src/Test/Tasty/Bench/Fit.hs b/src/Test/Tasty/Bench/Fit.hs index e628a74..dbfe2f4 100644 --- a/src/Test/Tasty/Bench/Fit.hs +++ b/src/Test/Tasty/Bench/Fit.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE NumDecimals #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -35,10 +34,9 @@ import qualified Data.Map as M import Data.Ord (comparing) import System.IO.Unsafe (unsafeInterleaveIO) import Test.Tasty (Timeout, mkTimeout) -import Test.Tasty.Bench (Benchmarkable, RelStDev (..), measureCpuTimeAndStDev, nf) +import Test.Tasty.Bench (Benchmarkable, RelStDev (..), nf) import Test.Tasty.Bench.Fit.Complexity ( Complexity (..), - Measurement (..), evalComplexity, guessComplexity, isConstant, @@ -48,10 +46,7 @@ import Test.Tasty.Bench.Fit.Complexity ( isLogarithmic, isQuadratic, ) - -#ifdef DEBUG -import Debug.Trace -#endif +import Test.Tasty.Bench.Utils (Measurement (..), measure, traceShowM') -- | Configuration for 'fit'. data FitConfig = FitConfig @@ -149,17 +144,14 @@ converge xs = case zs of -- ... fits :: FitConfig -> IO (NonEmpty Complexity) fits FitConfig {..} = unsafeInterleaveIO $ do - lowTime <- measure fitLow - highTime <- measure fitHigh + lowTime <- measureIt fitLow + highTime <- measureIt fitHigh let mp = M.fromList [(fitLow, lowTime), (fitHigh, highTime)] cmpl = fitOracle mp cmpl `seq` (cmpl :|) <$> go mp where - measure :: Word -> IO Measurement - measure = - fmap (uncurry Measurement) - . measureCpuTimeAndStDev fitTimeout fitRelStDev - . fitBench + measureIt :: Word -> IO Measurement + measureIt = measure fitTimeout fitRelStDev . fitBench processGap :: forall t @@ -169,7 +161,7 @@ fits FitConfig {..} = unsafeInterleaveIO $ do -> IO (Map Word Measurement) processGap gaps mp | M.null gaps' = pure mp - | otherwise = (\m -> M.insert maxGap m mp) <$> measure maxGap + | otherwise = (\m -> M.insert maxGap m mp) <$> measureIt maxGap where gaps' = M.fromList gaps `M.difference` mp maxGap = fst $ maximumBy (comparing snd) $ M.toList gaps' @@ -200,10 +192,3 @@ fits FitConfig {..} = unsafeInterleaveIO $ do d :: Word -> Double d = fromIntegral - -traceShowM' :: (Applicative m, Show a) => a -> m () -#ifdef DEBUG -traceShowM' = traceShowM -#else -traceShowM' = const (pure ()) -#endif diff --git a/src/Test/Tasty/Bench/Fit/Complexity.hs b/src/Test/Tasty/Bench/Fit/Complexity.hs index 91be271..e24cbfd 100644 --- a/src/Test/Tasty/Bench/Fit/Complexity.hs +++ b/src/Test/Tasty/Bench/Fit/Complexity.hs @@ -8,7 +8,6 @@ -- | Guess complexity from data. module Test.Tasty.Bench.Fit.Complexity ( Complexity (..), - Measurement (..), guessComplexity, evalComplexity, @@ -36,6 +35,7 @@ import Math.Regression.Simple ( levenbergMarquardt2WithYerrors, linear, ) +import Test.Tasty.Bench.Utils (Measurement (..)) import Text.Printf (printf) import Prelude hiding (log) import qualified Prelude as P @@ -142,18 +142,6 @@ bestOf = fst . minimumBy (comparing weigh) then 100 else (if diff < 0.15 then 32 else 10) --- | Represents a time measurement for a given problem's size. -data Measurement = Measurement - { measTime :: !Double - , measStDev :: !Double - } - deriving (Eq, Ord, Generic) - -instance Show Measurement where - show (Measurement t err) = printf "%.3g ± %.3g" t err - -instance NFData Measurement - -- | Guess time complexity from a map where keys -- are problem's sizes and values are time measurements (or instruction counts). -- diff --git a/src/Test/Tasty/Bench/Utils.hs b/src/Test/Tasty/Bench/Utils.hs new file mode 100644 index 0000000..a851044 --- /dev/null +++ b/src/Test/Tasty/Bench/Utils.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} + +module Test.Tasty.Bench.Utils ( + Measurement (..), + measRelStDev, + measure, + getRelStDev, + traceShowM', +) where + +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) +import Test.Tasty (Timeout) +import Test.Tasty.Bench (Benchmarkable, RelStDev (..), measureCpuTimeAndStDev) +import Text.Printf (printf) + +#ifdef DEBUG +import Debug.Trace +#endif + +-- | Represents a time measurement for a given problem's size. +data Measurement = Measurement + { measTime :: !Double + , measStDev :: !Double + } + deriving (Eq, Ord, Generic) + +instance Show Measurement where + show (Measurement t err) = printf "%.3g ± %.3g" t err + +instance NFData Measurement + +measure :: Timeout -> RelStDev -> Benchmarkable -> IO Measurement +measure x y z = uncurry Measurement <$> measureCpuTimeAndStDev x y z + +measRelStDev :: Measurement -> RelStDev +measRelStDev (Measurement mean stDev) = RelStDev (stDev / mean) + +getRelStDev :: RelStDev -> Double +getRelStDev (RelStDev x) = x + +traceShowM' :: (Applicative m, Show a) => a -> m () +#ifdef DEBUG +traceShowM' = traceShowM +#else +traceShowM' = const (pure ()) +#endif diff --git a/tasty-bench-fit.cabal b/tasty-bench-fit.cabal index bb2983d..444fdf2 100644 --- a/tasty-bench-fit.cabal +++ b/tasty-bench-fit.cabal @@ -31,9 +31,15 @@ flag debug manual: True library - exposed-modules: Test.Tasty.Bench.Fit + exposed-modules: + Test.Tasty.Bench.Crossover + Test.Tasty.Bench.Fit + hs-source-dirs: src - other-modules: Test.Tasty.Bench.Fit.Complexity + other-modules: + Test.Tasty.Bench.Fit.Complexity + Test.Tasty.Bench.Utils + default-language: Haskell2010 ghc-options: -Wall build-depends: