Tweaks

.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 <<EOF
-          repository head.hackage.ghc.haskell.org
-             url: https://ghc.gitlab.haskell.org/head.hackage/
-             secure: True
-             root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d
-                        26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329
-                        f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89
-             key-threshold: 3
-          active-repositories: hackage.haskell.org, head.hackage.ghc.haskell.org:override
-          EOF
-          fi
           cat >> $CABAL_CONFIG <<EOF
           program-default-options
             ghc-options: $GHCJOBS +RTS -M3G -RTS

src/Test/Tasty/Bench/Equalize.hs

@@ -1,8 +1,10 @@
-{-# LANGUAGE CPP #-}
+{-# HLINT ignore "Avoid restricted function" #-}
 {-# LANGUAGE NumDecimals #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
+-- | Find a tipping point between two algorithms.
 module Test.Tasty.Bench.Equalize (
   equalize,
   mkEqualizeConfig,
@@ -11,63 +13,67 @@ module Test.Tasty.Bench.Equalize (
 
 import Control.DeepSeq (NFData)
 import System.IO.Unsafe (unsafeInterleaveIO)
-import Test.Tasty (Timeout (..))
+import Test.Tasty (Timeout (..), mkTimeout)
 import Test.Tasty.Bench (Benchmarkable, RelStDev (..), measureCpuTimeAndStDev, nf)
+import Test.Tasty.Bench.Utils (Measurement (..), measure, traceShowM')
 
-#ifdef DEBUG
-import Debug.Trace
-#endif
-
--- | Configuration for 'fit'.
+-- | Configuration for 'equalize'.
 data EqualizeConfig = EqualizeConfig
   { eqlFasterOnLow :: Word -> 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 'equalize' configuration.
 mkEqualizeConfig
   :: (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)
-  -- ^ The smallest and the largest sizes of the input.
+  -- ^ Small and large arguments.
   -> EqualizeConfig
 mkEqualizeConfig fLow fHigh (low, high) =
   EqualizeConfig
     { eqlFasterOnLow = nf fLow
     , eqlFasterOnHigh = nf fHigh
     , eqlLow = low
     , eqlHigh = high
-    , eqlTimeout = NoTimeout
+    , eqlTimeout = mkTimeout 1e8
     }
 
 equalize :: EqualizeConfig -> IO [(Word, Word)]
-equalize EqualizeConfig {..} = go (RelStDev 1.0) eqlLow eqlHigh
+equalize EqualizeConfig {..} = go (RelStDev 0.33) eqlLow eqlHigh
   where
-    go std@(RelStDev std') lo hi
-      | lo + 1 >= hi = pure [(lo, hi)]
-      | otherwise =
-          unsafeInterleaveIO $
-            ((lo, hi) :) <$> do
-              let mid = (lo + hi) `quot` 2
+    go targetStdDev@(RelStDev targetAsDbl) lo hi =
+      unsafeInterleaveIO $
+        ((lo, hi) :) <$> do
+          let mid = (lo + hi) `quot` 2
+          if mid == lo
+            then pure []
+            else do
+              traceShowM' $ "stdev = " ++ show targetStdDev
               traceShowM' $ "mid = " ++ show mid
-              (mean1, stdev1) <- measureCpuTimeAndStDev eqlTimeout std $ eqlFasterOnLow mid
+              Measurement mean1 stdev1 <-
+                measure eqlTimeout targetStdDev $ eqlFasterOnLow mid
               traceShowM' $ "(mean1, stdev1) = " ++ show (mean1, stdev1)
-              (mean2, stdev2) <- measureCpuTimeAndStDev eqlTimeout std $ eqlFasterOnHigh mid
+              Measurement mean2 stdev2 <-
+                measure eqlTimeout targetStdDev $ eqlFasterOnHigh mid
               traceShowM' $ "(mean2, stdev2) = " ++ show (mean2, stdev2)
-              if mean1 + 2 * stdev1 < mean2 - 2 * stdev2
-                then go std mid hi
-                else
-                  if mean2 + 2 * stdev2 < mean1 - 2 * stdev1
-                    then go std lo mid
-                    else go (RelStDev $ std' / 2) lo hi
 
-traceShowM' :: (Applicative m, Show a) => a -> m ()
-#ifdef DEBUG
-traceShowM' = traceShowM
-#else
-traceShowM' = const (pure ())
-#endif
+              let (targetStdDev', lo', hi')
+                    | mean1 + 2 * stdev1 < mean2 - 2 * stdev2 = (targetStdDev, mid, hi)
+                    | mean2 + 2 * stdev2 < mean1 - 2 * stdev1 = (targetStdDev, lo, mid)
+                    | otherwise = (shrinkStDev targetStdDev, lo, hi)
+              if max stdev1 stdev2 > targetAsDbl then pure [] else go targetStdDev' lo' hi'
+
+shrinkStDev :: RelStDev -> RelStDev
+shrinkStDev (RelStDev x) = RelStDev $ x * (sqrt 5 - 1) / 2

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

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).
 --

src/Test/Tasty/Bench/Utils.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module Test.Tasty.Bench.Utils (
+  Measurement (..),
+  measure,
+  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
+
+traceShowM' :: (Applicative m, Show a) => a -> m ()
+#ifdef DEBUG
+traceShowM' = traceShowM
+#else
+traceShowM' = const (pure ())
+#endif

tasty-bench-fit.cabal

@@ -36,7 +36,10 @@ library
         Test.Tasty.Bench.Equalize
 
     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: