diff --git a/ghc-bench.cabal b/ghc-bench.cabal --- a/ghc-bench.cabal +++ b/ghc-bench.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: ghc-bench -version: 0.2.0 +version: 0.3.0 synopsis: Benchmark a Haskell development system description: See the README at category: Development @@ -24,7 +24,12 @@ executable ghc-bench main-is: Main.hs other-modules: - Asset + Benchmark.BuildCabalPackage + Benchmark.BuildGhc + Benchmark.Ghci + Benchmark.Type + Benchmark.Util + Blob Command Imports Result @@ -54,50 +59,19 @@ , process , temporary , text - default-language: GHC2024 - -test-suite process-result - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Asset - Command - Imports - Result - Run - SystemInfo - hs-source-dirs: - src - process-result - default-extensions: - NoImplicitPrelude - OverloadedStrings - RecordWildCards - ViewPatterns - BlockArguments - LambdaCase - NoFieldSelectors - DuplicateRecordFields - OverloadedRecordDot - DerivingStrategies - ghc-options: -Wall - build-depends: - base ==4.* - , bytestring - , directory - , filepath - , http-types - , process - , temporary - , text - , yaml + , transformers default-language: GHC2024 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Asset + Benchmark.BuildCabalPackage + Benchmark.BuildGhc + Benchmark.Ghci + Benchmark.Type + Benchmark.Util + Blob Command Imports Result @@ -106,7 +80,9 @@ CommandSpec Fixtures.System Helper + README ResultSpec + RunSpec SystemInfoSpec hs-source-dirs: src @@ -127,8 +103,10 @@ build-tool-depends: hspec-discover:hspec-discover build-depends: - base ==4.* + aeson + , base ==4.* , bytestring + , containers , directory , filepath , hspec ==2.* @@ -137,4 +115,6 @@ , silently , temporary , text + , transformers + , yaml default-language: GHC2024 diff --git a/process-result/Main.hs b/process-result/Main.hs deleted file mode 100644 --- a/process-result/Main.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} -module Main (main) where - -import Imports - -import Data.Ord (comparing) -import Data.Yaml (ToJSON) -import Data.Yaml.Pretty qualified as Yaml -import Data.ByteString qualified as B -import System.Environment (getArgs) -import System.Directory (createDirectoryIfMissing) -import System.FilePath (takeDirectory) - -import Result -import SystemInfo - -fieldOrder :: [(Text, Int)] -fieldOrder = flip zip [1..] [ - "time" - , "concurrency" - , "os" - , "arch" - , "category" - , "chassis_type" - , "name" - , "cores" - , "threads" - , "vendor" - , "family" - , "model" - , "stepping" - , "version" - , "product" - , "board" - , "cpu" - , "ram" - ] - -instance ToJSON Result -deriving newtype instance ToJSON Concurrency -instance ToJSON SystemInfo -instance ToJSON Product -instance ToJSON Board -instance ToJSON Cpu - -main :: IO () -main = do - [body, timestamp] <- getArgs - - let - result :: Result - result = parseFromIssueBody (pack body) - - path :: FilePath - path = resultPath (fromString timestamp) result.system - - encodeFile path result - -encodeFile :: FilePath -> Result -> IO () -encodeFile file result = do - ensureDirectory file - B.writeFile file $ Yaml.encodePretty conf result - where - conf :: Yaml.Config - conf = Yaml.setConfCompare (comparing byFieldOrder) Yaml.defConfig - - byFieldOrder :: Text -> Int - byFieldOrder name = fromMaybe maxBound (lookup name fieldOrder) - -ensureDirectory :: FilePath -> IO () -ensureDirectory = createDirectoryIfMissing True . takeDirectory diff --git a/src/Asset.hs b/src/Asset.hs deleted file mode 100644 --- a/src/Asset.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Asset ( - download -, Asset(..) -) where - -import Imports - -import System.Directory (doesFileExist, renameFile) - -import Command (curl, sha256sum) - -data Asset = Asset { - url :: FilePath -, path :: FilePath -, hash :: Text -} deriving (Eq, Show) - -download :: Asset -> IO () -download asset = do - ensure asset.url asset.path - verify asset.path asset.hash - -ensure :: FilePath -> FilePath -> IO () -ensure url path = unless -< doesFileExist path $ do - let tmp = path <> ".tmp" - curl ["-L", url, "-o", tmp] - renameFile tmp path - -verify :: FilePath -> Text -> IO () -verify path expected = do - actual <- sha256sum path - when (actual /= expected) . error $ unlines [ - "SHA256 mismatch!" - , "Expected: " <> expected - , "Actual: " <> actual - ] diff --git a/src/Benchmark/BuildCabalPackage.hs b/src/Benchmark/BuildCabalPackage.hs new file mode 100644 --- /dev/null +++ b/src/Benchmark/BuildCabalPackage.hs @@ -0,0 +1,34 @@ +module Benchmark.BuildCabalPackage (run, withPackage) where + +import Benchmark.Util + +indexState :: FilePath +indexState = "--index-state=2026-04-15T08:18:05Z" + +withPackage :: String -> Benchmark () -> Benchmark () +withPackage package action = do + call "cabal" ["unpack", package, indexState] + cd package action + +run :: String -> FilePath -> Concurrency -> Benchmark () +run package ghc concurrency = withPackage package do + cabal "user-config" ["init"] + cabal "configure" [ + "--with-compiler=" <> ghc + , "--jobs=" <> show concurrency + , "--enable-tests" + , "--enable-benchmarks" + , indexState + ] + cabal "build" ["--only-dependencies", "--only-download"] + measure "dependencies" do + cabal "build" ["--only-dependencies"] + measure "build" do + cabal "build" [] + where + cabal :: FilePath -> [FilePath] -> Benchmark () + cabal command = call "cabal" . mappend [ + "--config-file=ghc-bench-cabal-config" + , "--store-dir=store" + , command + ] diff --git a/src/Benchmark/BuildGhc.hs b/src/Benchmark/BuildGhc.hs new file mode 100644 --- /dev/null +++ b/src/Benchmark/BuildGhc.hs @@ -0,0 +1,23 @@ +module Benchmark.BuildGhc (Tarball(..), run) where + +import Benchmark.Util + +import Blob (Blob) +import Blob qualified + +data Tarball = Tarball { + blob :: Blob +, root :: FilePath +} deriving (Eq, Show) + +run :: Tarball -> FilePath -> Concurrency -> Benchmark () +run tarball stage0 concurrency = setEnv "GHC" stage0 do + download tarball.blob + tar ["-xf", tarball.blob.path] + cd tarball.root do + call "./configure" [] + hadrian ["--help"] -- this makes sure that building hadrian dependencies is not measured + measure "build" do + hadrian ["-j" <> show concurrency, "--flavour=quickest"] + where + hadrian = call "hadrian/build" diff --git a/src/Benchmark/Ghci.hs b/src/Benchmark/Ghci.hs new file mode 100644 --- /dev/null +++ b/src/Benchmark/Ghci.hs @@ -0,0 +1,22 @@ +module Benchmark.Ghci (run) where + +import Benchmark.Util +import Benchmark.BuildCabalPackage (withPackage) + +run :: String -> FilePath -> Concurrency -> Benchmark () +run package ghc _concurrency = withPackage package do + measure "ghci" do + call "bash" ["-c", command] + where + command :: String + command = unwords [ + "echo" + , "|" + , ghc + , "--interactive" + , "-ignore-dot-ghci" + , "-isrc" + , "`find src -name '*.hs'`" + , "-Iinclude" + , "-XHaskell2010" + ] diff --git a/src/Benchmark/Type.hs b/src/Benchmark/Type.hs new file mode 100644 --- /dev/null +++ b/src/Benchmark/Type.hs @@ -0,0 +1,182 @@ +module Benchmark.Type ( + Label(..) +, Seconds(..) +, Benchmark +, dependencies +, dryRun +, run + +, withLabel +, setEnv +, cd +, download +, call +, measure +) where + +import Imports + +import GHC.Clock (getMonotonicTimeNSec) +import Data.Char (isSpace) +import Data.Text qualified as T +import Data.Text.IO.Utf8 qualified as Utf8 +import System.FilePath (splitPath) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer.CPS hiding (tell) +import Control.Monad.Trans.Writer.CPS qualified as Writer + +import Blob (Blob) +import Blob qualified +import Command hiding (callWith) +import Command qualified + +newtype Label = Label Text + deriving newtype (Eq, Show, Ord, IsString) + +newtype Seconds = Seconds Int + deriving newtype (Eq, Show, Num, Ord, Bounded) + +data Command = + SetEnv String String [Command] + | ChangeDirectory FilePath [Command] + | Download Blob + | Call FilePath [FilePath] + | Measure Label [Command] + deriving (Show) + +type Benchmark = ReaderT [String] (Writer [Command]) + +dependencies :: Benchmark () -> [FilePath] +dependencies = collectDependencies . toForest + +dryRun :: Benchmark () -> IO [(Label, Seconds)] +dryRun action = do + let (times, output) = dryRunForest $ toForest action + Utf8.putStrLn output + return times + +run :: Benchmark () -> IO [(Label, Seconds)] +run = execForest . toForest + +toForest :: Benchmark () -> [Command] +toForest = toForestWith [] + +toForestWith :: [String] -> Benchmark () -> [Command] +toForestWith labels action = execWriter $ runReaderT action labels + +tell :: Command -> Benchmark () +tell = lift . Writer.tell . return + +withLabel :: String -> Benchmark () -> Benchmark () +withLabel = local . (:) + +setEnv :: String -> String -> Benchmark () -> Benchmark () +setEnv key value action = do + labels <- ask + let commands = toForestWith labels action + tell $ SetEnv key value commands + +cd :: FilePath -> Benchmark () -> Benchmark () +cd dir action = do + labels <- ask + let commands = toForestWith labels action + tell $ ChangeDirectory dir commands + +download :: Blob -> Benchmark () +download = tell . Download + +call :: FilePath -> [FilePath] -> Benchmark () +call command = tell . Call command + +measure :: String -> Benchmark () -> Benchmark () +measure label action = withLabel label do + labels <- ask + let commands = toForestWith labels action + tell $ Measure (toLabel labels) commands + +collectDependencies :: [Command] -> [FilePath] +collectDependencies = concatMap \ case + Download _ -> [] + Call path _ -> case splitPath path of + [name] -> [name] + _ -> [] + SetEnv _ _ commands -> collectDependencies commands + ChangeDirectory _ commands -> collectDependencies commands + Measure _ commands -> collectDependencies commands + +dryRunForest :: [Command] -> ([(Label, Seconds)], Text) +dryRunForest = fmap unlines . runWriter . \ commands -> do + writeLine "" + writeLine "############################################" + writeLine "# With a fresh temporary working directory #" + writeLine "############################################" + writeLine "" + go commands + where + writeLine :: Text -> Writer [Text] () + writeLine = Writer.tell . (: []) + + go :: [Command] -> Writer [Text] [(Label, Seconds)] + go = fmap concat . traverse \ case + ChangeDirectory dir commands -> do + writeLine $ "cd " <> pack dir + go commands + + SetEnv name value commands -> do + writeLine $ "export " <> pack name <> "=" <> pack value + go commands + + Download blob -> do + writeLine "" + writeLine $ "# Ensure that " <> pack blob.path <> " exists; download if necessary." + writeLine $ "# url: " <> pack blob.url + writeLine $ "# sha256: " <> blob.hash + writeLine "" + return [] + + Call command args -> do + writeLine $ showCommand command args + return [] + + Measure (Label label) commands -> do + writeLine "" + writeLine $ "# MEASURE " <> label + times <- go commands + return $ (Label label, 0) : times + +showCommand :: String -> [String] -> Text +showCommand command = unwords . map showArg . (:) command + +showArg :: String -> Text +showArg arg + | any isSpace arg = show arg + | otherwise = pack arg + +execForest :: [Command] -> IO [(Label, Seconds)] +execForest = go mempty + where + go env = fmap concat . traverse \ case + SetEnv name value commands -> do + go env { extend = (name, value) : env.extend } commands + + ChangeDirectory dir commands -> do + go env { dir = env.dir dir } commands + + Download blob -> do + Blob.download blob $> [] + + Call command args -> do + Command.callWith env command args $> [] + + Measure label cs -> do + start <- getMonotonicTimeNSec + times <- go env cs + end <- getMonotonicTimeNSec + let + time :: Double + time = fromIntegral (end - start) / 1e9 + return $ (label, Seconds (round time)) : times + +toLabel :: [String] -> Label +toLabel = Label . T.intercalate "-" . map pack . reverse diff --git a/src/Benchmark/Util.hs b/src/Benchmark/Util.hs new file mode 100644 --- /dev/null +++ b/src/Benchmark/Util.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE NoFieldSelectors #-} +module Benchmark.Util ( + module Imports +, Benchmark +, Concurrency + +, withLabel +, setEnv +, cd +, download +, call +, measure + +, tar +) where + +import Prelude as Imports + +import Benchmark.Type +import Command (Concurrency) + +tar :: [String] -> Benchmark () +tar = call "tar" diff --git a/src/Blob.hs b/src/Blob.hs new file mode 100644 --- /dev/null +++ b/src/Blob.hs @@ -0,0 +1,39 @@ +module Blob ( + download +, Blob(..) +) where + +import Imports + +import System.Directory (doesFileExist, renameFile) + +import Command (curl, sha256sum) + +data Blob = Blob { + url :: FilePath +, path :: FilePath +, hash :: Text +} deriving (Eq, Show) + +download :: Blob -> IO () +download blob = do + ensure blob.url blob.path + verify blob + +ensure :: FilePath -> FilePath -> IO () +ensure url path = unless -< doesFileExist path $ do + let tmp = path <> ".tmp" + curl ["-L", url, "-o", tmp] + renameFile tmp path + +verify :: Blob -> IO () +verify Blob {..} = do + actual <- sha256sum path + when (actual /= hash) . error $ unlines [ + "sha256sum mismatch!" + , "" + , " url: " <> pack url + , " file: " <> pack path + , " expected: " <> hash + , " actual: " <> actual + ] diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -4,7 +4,6 @@ , resolve , eval -, sh , awk , uname @@ -14,9 +13,12 @@ , nproc , curl -, tar , Concurrency(..) + +, callWith +, Env(..) +, chdir ) where import Imports hiding (strip) @@ -24,20 +26,16 @@ import Data.Char (isSpace) import Data.Text qualified as T -import System.Process (readProcessWithExitCode, rawSystem, callProcess) +import System.Environment (getEnvironment) +import System.Process hiding (readProcess, callProcess) import System.Process qualified as Process newtype Concurrency = Concurrency Int - deriving newtype (Eq, Show, Read, Num) + deriving newtype (Eq, Ord, Show, Read, Num) eval :: String -> IO Text eval command = run "bash" ["-c", command] -sh :: FilePath -> String -> IO () -sh dir command = rawSystem "bash" ["-c", "cd " <> dir <> " && " <> command] >>= \ case - ExitSuccess -> pass - ExitFailure _ -> error $ "Running `" <> pack command <> "` failed!" - awk :: Text -> Text -> IO Text awk command = readProcess "awk" [unpack command] @@ -57,10 +55,7 @@ nproc = read <$> readProcess "nproc" [] "" curl :: [String] -> IO () -curl = callProcess "curl" - -tar :: [String] -> IO () -tar = callProcess "tar" +curl = call "curl" requireAll :: IO () requireAll = do @@ -72,9 +67,8 @@ require "sha256sum" require "nproc" require "curl" - require "tar" -require :: String -> IO () +require :: FilePath -> IO () require = void . resolve resolve :: FilePath -> IO FilePath @@ -88,8 +82,53 @@ strip :: String -> String strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace -run :: String -> [String] -> IO Text +run :: FilePath -> [FilePath] -> IO Text run command args = readProcess command args "" readProcess :: FilePath -> [FilePath] -> Text -> IO Text readProcess name args input = pack <$> Process.readProcess name args (unpack input) + +call :: FilePath -> [FilePath] -> IO () +call = callWith mempty + +callWith :: Env -> FilePath -> [FilePath] -> IO () +callWith Env{..} command args = do + env <- case extend of + [] -> return Nothing + values -> Just . (values ++) <$> getEnvironment + callProcess (proc command args) { + cwd = case dir of + "" -> Nothing + d -> Just d + , env + } + +data Env = Env { + dir :: FilePath +, extend :: [(FilePath, FilePath)] +} deriving (Eq, Show) + +instance Semigroup Env where + Env _ envl <> Env dir envr = Env dir (envl ++ envr) + +instance Monoid Env where + mempty = Env "" [] + +chdir :: FilePath -> Env +chdir dir = mempty { dir } + +callProcess :: CreateProcess -> IO () +callProcess command = withCreateProcess command wait + where + wait _ _ _ = waitForProcess >=> \ case + ExitSuccess -> pass + ExitFailure status -> externalCommandFailed status case cmdspec command of + ShellCommand cmd -> [cmd] + RawCommand cmd args -> cmd : args + +externalCommandFailed :: Int -> [String] -> IO a +externalCommandFailed status command = Imports.error $ T.intercalate "\n" [ + "external command failed with exit status " <> show status + , "" + , " " <> unwords (map pack command) + ] diff --git a/src/Imports.hs b/src/Imports.hs --- a/src/Imports.hs +++ b/src/Imports.hs @@ -5,11 +5,11 @@ import Data.Maybe as Imports import Data.String as Imports (IsString(..)) -import Data.Functor as Imports (void, (<&>)) +import Data.Functor as Imports hiding (unzip) import Data.Bifunctor as Imports (Bifunctor(..)) import Control.Arrow as Imports ((>>>)) -import Control.Monad as Imports (when, unless) -import Data.Foldable as Imports (for_) +import Control.Monad as Imports (when, unless, (>=>)) +import Data.Foldable as Imports (for_, traverse_) import GHC.Stack as Imports (HasCallStack) import GHC.Generics as Imports (Generic) @@ -31,7 +31,7 @@ withTempDirectory dir name = bracket (createTempDirectory dir name) removePathForcibly error :: Text -> IO a -error message = die $ "ghc-bench: " <> unpack message +error message = die $ "\nghc-bench: " <> unpack message read :: HasCallStack => Read a => Text -> a read input = case readMaybe (unpack input) of diff --git a/src/Result.hs b/src/Result.hs --- a/src/Result.hs +++ b/src/Result.hs @@ -2,9 +2,15 @@ module Result ( submit , Result(..) +, Label(..) +, Seconds(..) , Concurrency(..) , parseFromIssueBody , resultPath +, formatTime +, cpuName +, basePath + #ifdef TEST , issueTitle #endif @@ -18,6 +24,7 @@ import System.FilePath (joinPath) import Network.HTTP.Types.URI (renderSimpleQuery) +import Benchmark.Type (Label(..), Seconds(..)) import Command (Concurrency(..)) import SystemInfo @@ -25,7 +32,7 @@ base = "https://github.com/sol/ghc-bench/issues/new" data Result = Result { - time :: Int + times :: [(Label, Seconds)] , concurrency :: Concurrency , system :: SystemInfo } deriving (Eq, Show, Generic) @@ -33,14 +40,14 @@ submit :: Result -> IO () submit result = do putStrLn "Open this URL to submit your result:" - putStrLn $ issueUrl result + putStrLn $ "\n " <> issueUrl result issueUrl :: Result -> ByteString issueUrl result = base <> renderQuery [ ("template", "benchmark-result.yml") - , ("title", issueTitle result.time system) + , ("title", issueTitle (sum $ map snd result.times) system) - , ("time", show result.time) + , ("times", formatTimes result.times) , ("concurrency", show result.concurrency) , ("os", system.os) @@ -76,8 +83,8 @@ , fromMaybe "unknown" system.cpu.stepping ] -issueTitle :: Int -> SystemInfo -> Text -issueTitle seconds system = unwords ["[result]", show seconds <> "s", "-", description, "-", cpu] +issueTitle :: Seconds -> SystemInfo -> Text +issueTitle seconds system = unwords ["[result]", formatTime seconds, "-", description, "-", cpuName system.cpu] where description :: Text description = unwords case (system.vendor, system.product.name) of @@ -86,12 +93,24 @@ (vendor, unknown -> True) -> [vendor, system.product.category] (vendor, name) -> [vendor, name] - cpu :: Text - cpu = case system.cpu.vendor of - Just "GenuineIntel" -> case T.breakOn " @ " system.cpu.name of - (name, _) -> T.replace "(TM)" "" $ T.replace "(R)" "" name - _ -> system.cpu.name +cpuName :: Cpu -> Text +cpuName cpu = case cpu.vendor of + Just "GenuineIntel" -> case T.breakOn " @ " cpu.name of + (name, _) -> + unwords + . filter (/= "CPU") + . words + . tryStripPrefix "11th Gen " + . T.replace "(R)" "" + . T.replace "(TM)" " " + $ name + _ -> cpu.name +formatTime :: Seconds -> Text +formatTime (Seconds seconds) = case seconds `divMod` 60 of + (0, s) -> show s <> "s" + (m, s) -> mconcat [show seconds, "s (", show m, "m ", show s, "s)"] + unknown :: Text -> Bool unknown = (== "To Be Filled By O.E.M.") @@ -100,7 +119,7 @@ parseFromIssueBody :: Text -> Result parseFromIssueBody markdown = Result { - time = int "Build time (seconds)" + times = parseTimes $ get "Build times (seconds)" , concurrency = Concurrency $ int "Used number of threads" , system } @@ -165,24 +184,24 @@ (key, "_No response_") -> (key, "") (key, value) -> (key, value) +formatTimes :: [(Label, Seconds)] -> Text +formatTimes = unwords . map \ case + (Label name, time) -> mconcat [name, ":", show time] + +parseTimes :: Text -> [(Label, Seconds)] +parseTimes = words >>> map parseTime + where + parseTime :: Text -> (Label, Seconds) + parseTime = T.breakOn ":" >>> bimap Label (Seconds . read . T.drop 1) + newtype Timestamp = Timestamp String deriving newtype (Eq, Show, Read, IsString) resultPath :: Timestamp -> SystemInfo -> FilePath -resultPath (Timestamp timestamp) system = joinPath $ sanitizePathComponents path +resultPath (Timestamp timestamp) system = joinPathComponents path where path :: [Text] - path = "results" : vendor : cpu ++ [file] - - vendor :: Text - vendor = case system.cpu.vendor of - Just "GenuineIntel" -> "intel" - Just "AuthenticAMD" -> "amd" - Just name -> name - Nothing -> "unknown" - - cpu :: [Text] - cpu = cpuToPathComponents system.cpu + path = basePathComponents system.cpu ++ [file] file :: Text file = model <> "_" <> pack timestamp <> ".yaml" @@ -193,12 +212,28 @@ (_, unknown -> True) -> [system.board.vendor, system.board.name] (_, name) -> [name] +basePath :: Cpu -> String +basePath = joinPathComponents . basePathComponents + +basePathComponents :: Cpu -> [Text] +basePathComponents cpu = "results" : vendor : cpuToPathComponents cpu + where + vendor :: Text + vendor = case cpu.vendor of + Just "GenuineIntel" -> "intel" + Just "AuthenticAMD" -> "amd" + Just name -> name + Nothing -> "unknown" + cpuToPathComponents :: Cpu -> [Text] cpuToPathComponents cpu = case (cpu.vendor, cpu.family, cpu.model, cpu.stepping) of (Just "GenuineIntel", Just "6", Just "165", Just "5") -> ["10th", T.take 9 $ T.drop 18 cpu.name] (Just "GenuineIntel", Just "6", Just "140", Just "1") -> ["11th", T.take 9 $ T.drop 27 cpu.name] (Just "GenuineIntel", Just "6", Just "23", Just "10") -> ["core_2", T.take 5 $ T.drop 31 cpu.name] _ -> ["unknown", T.replace " " "_" cpu.name] + +joinPathComponents :: [Text] -> String +joinPathComponents = joinPath . sanitizePathComponents sanitizePathComponent :: Text -> FilePath sanitizePathComponent component = case sanitize component of diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -1,79 +1,106 @@ -module Run (main) where +module Run (main, run) where import Imports -import Prelude qualified +import Data.List qualified as List import Data.Text.IO (putStrLn) - -import GHC.Clock (getMonotonicTimeNSec) import System.Directory (createDirectoryIfMissing) -import System.Environment.Blank (setEnv) import System.Exit (die) -import Command (tar, nproc, sh) +import Command (Concurrency, nproc) import Command qualified - import SystemInfo qualified - -import Asset (Asset(..)) -import Asset qualified - -import Result (Concurrency, Result(..)) +import Blob (Blob(..)) +import Result (Result(..), Label(..), Seconds) import Result qualified +import Benchmark.Type (Benchmark, withLabel) +import Benchmark.Type qualified as Benchmark +import Benchmark.BuildGhc (Tarball(..)) +import Benchmark.BuildGhc qualified as BuildGhc +import Benchmark.BuildCabalPackage qualified as BuildCabalPackage +import Benchmark.Ghci qualified as Ghci version :: FilePath version = "9.12.4" -bootGhc :: FilePath -bootGhc = "ghc-" <> version +ghc :: FilePath +ghc = "ghc-" <> version baseDir :: FilePath baseDir = "/tmp/ghc-bench" -sourceTarball :: Asset -sourceTarball = Asset { - url = "https://downloads.haskell.org/~ghc/" <> version <> "/ghc-" <> version <> "-src.tar.gz" - , path = baseDir "ghc-" <> version <> "-src.tar.gz" - , hash = "df71d96169056d3a6d7ec17498864cbdd5511bda196440dc38a692133833dfa4" +sourceTarball :: Tarball +sourceTarball = Tarball { + blob = Blob { + url = "https://downloads.haskell.org/~ghc/" <> version <> "/ghc-" <> version <> "-src.tar.gz" + , path = baseDir "ghc-" <> version <> "-src.tar.gz" + , hash = "df71d96169056d3a6d7ec17498864cbdd5511bda196440dc38a692133833dfa4" + } + , root = "ghc-" <> version } +cabalPackage :: FilePath +cabalPackage = "hedgehog-1.7" + +ghciPackage :: FilePath +ghciPackage = "containers-0.8" + +parseOptions :: [FilePath] -> (Bool, [FilePath]) +parseOptions = first (not . null) . List.partition (== "--dry-run") + main :: [String] -> IO () -main args = do +main (parseOptions -> (dryRun, args)) = do Command.requireAll - Command.require "cabal" - ghc <- Command.resolve bootGhc + stage0 <- Command.resolve ghc createDirectoryIfMissing False baseDir system <- SystemInfo.collect concurrency <- nproc - time <- case args of - [] -> run ghc sourceTarball concurrency - ["info"] -> return 0 - _ -> die "usage: ghc-bench [info]" - putStrLn $ "Build time: " <> show time <> "s" - putStrLn "" - Result.submit Result {..} + times <- run (withTempDirectory baseDir "build") dryRun args stage0 concurrency + unless (null times) do + putStrLn "\ntimes:" + for_ times \ (Label name, time) -> do + putStrLn $ " " <> name <> ": " <> (Result.formatTime time) -run :: FilePath -> Asset -> Concurrency -> IO Int -run ghc source concurrency = withTempDirectory baseDir "run" \ sandbox -> do - Asset.download source - tar ["-xf", source.path, "-C", sandbox] - build (sandbox "ghc-" <> version) ghc concurrency + putStrLn "" + Result.submit Result {..} -build :: FilePath -> FilePath -> Concurrency -> IO Int -build dir ghc concurrency = do - setEnv "GHC" ghc True - sh dir "./configure" +type WithTempDirectory = forall a. (FilePath -> IO a) -> IO a - -- this makes sure that building hadrian dependencies is not measured - sh dir "hadrian/build --help" +run :: WithTempDirectory -> Bool -> [String] -> FilePath -> Concurrency -> IO [(Label, Seconds)] +run withTemp dryRun args stage0 concurrency = requireDependencies >> case args of + [] -> runAll + [name] | Just action <- lookup name subcommands -> action + _ -> die usage + where + requireDependencies :: IO () + requireDependencies = for_ dependencies Command.require - measure do - sh dir $ "hadrian/build -j" <> Prelude.show concurrency <> " --flavour=quickest" + dependencies :: [FilePath] + dependencies = List.nub $ concatMap (Benchmark.dependencies . snd) benchmarkActions -measure :: IO () -> IO Int -measure action = do - start <- getMonotonicTimeNSec - action - end <- getMonotonicTimeNSec - let dtSeconds = fromIntegral (end - start) / 1e9 :: Double - pure (round dtSeconds) + benchmarkActions :: [(String, Benchmark ())] + benchmarkActions = [ + ("ghc", withLabel ghc $ BuildGhc.run sourceTarball stage0 concurrency) + , ("cabal", withLabel cabalPackage $ BuildCabalPackage.run cabalPackage ghc concurrency) + , ("ghci", withLabel ghciPackage $ Ghci.run ghciPackage ghc concurrency) + ] + + runAll :: IO [(Label, Seconds)] + runAll = concat <$> sequence (map snd actions) + + actions :: [(String, IO [(Label, Seconds)])] + actions = map (fmap $ withTemp . runBenchmark dryRun) benchmarkActions + + subcommands :: [(FilePath, IO [(Label, Seconds)])] + subcommands = actions ++ [ + ("all", runAll) + , ("info", return [("info", 0)]) + ] + + usage :: FilePath + usage = "usage: ghc-bench [ " <> List.intercalate " | " (map fst subcommands) <> " ] [ --dry-run ]" + +runBenchmark :: Bool -> Benchmark () -> FilePath -> IO [(Label, Seconds)] +runBenchmark dryRun action dir + | dryRun = Benchmark.dryRun $ Benchmark.cd dir action + | otherwise = Benchmark.run $ Benchmark.cd dir action diff --git a/src/SystemInfo.hs b/src/SystemInfo.hs --- a/src/SystemInfo.hs +++ b/src/SystemInfo.hs @@ -90,7 +90,7 @@ , family :: Maybe Text , model :: Maybe Text , stepping :: Maybe Text -} deriving (Eq, Show, Generic) +} deriving (Eq, Ord, Show, Generic) getCpuInfo :: IO Cpu getCpuInfo = do diff --git a/test/CommandSpec.hs b/test/CommandSpec.hs --- a/test/CommandSpec.hs +++ b/test/CommandSpec.hs @@ -17,6 +17,6 @@ context "when executable does not exist" do it "terminates" do hCapture [stderr] (try $ resolve "d3b07384") `shouldReturn` ( - "ghc-bench: `d3b07384` is required, but couldn't be found on the search PATH.\n" + "\nghc-bench: `d3b07384` is required, but couldn't be found on the search PATH.\n" , Left $ ExitFailure 1 ) diff --git a/test/README.hs b/test/README.hs new file mode 100644 --- /dev/null +++ b/test/README.hs @@ -0,0 +1,129 @@ +module README ( + update +, ensureFile +) where + +import Helper + +import Data.List qualified as List +import Data.Tuple (swap) +import Control.Exception +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory) +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.Text qualified as T +import Data.Text.IO.Utf8 qualified as Utf8 +import Data.Set qualified as Set +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map + +import Result +import SystemInfo + +update :: [Result] -> IO () +update results = do + Utf8.readFile "README.md" + >>= (updateResults results >>> encodeUtf8 >>> ensureFile "README.md") + +updateResults :: [Result] -> Text -> Text +updateResults (resultTable -> results) = splitOutResultTable >>> \ case + (prefix, (_results, suffix)) -> mconcat [prefix, "\n", results, "\n", suffix] + where + splitOutResultTable = T.breakOnEnd "## Benchmark results\n" >>> (<&> T.breakOn "## ") + +type Configuration = (Cpu, Concurrency) + +aggregateResults :: [Result] -> Map Configuration (Map Label [Seconds]) +aggregateResults = map resultTimes >>> Map.fromListWith (Map.unionWith (++)) + where + resultTimes :: Result -> (Configuration, Map Label [Seconds]) + resultTimes result = (configuration, return <$> Map.fromList result.times) + where + configuration :: Configuration + configuration = (result.system.cpu, result.concurrency) + +resultTable :: [Result] -> Text +resultTable results = unlines $ map joinColumns table + where + table :: [[Text]] + table = header : replicate (length header) "---" : map formatRow rows + + joinColumns :: [Text] -> Text + joinColumns columns = mconcat ["| ", T.intercalate " | " columns, " |"] + + header :: [Text] + header = "CPU" : map formatLabel labels + + rows :: [(Configuration, [Maybe Seconds])] + rows = sortByTimes . map toRow $ Map.toList aggregated + where + sortByTimes :: [(c, [Maybe Seconds])] -> [(c, [Maybe Seconds])] + sortByTimes = List.sortOn sortKey + where + sortKey :: (c, [Maybe Seconds]) -> [Seconds] + sortKey = map (fromMaybe maxBound) . snd + + toRow :: (Configuration, Map Label [Seconds]) -> (Configuration, [Maybe Seconds]) + toRow (configuration, times) = (configuration, columns) + where + medians :: Map Label Seconds + medians = Map.mapMaybe median times + + columns :: [Maybe Seconds] + columns = map (`Map.lookup` medians) labels + + formatRow :: (Configuration, [Maybe Seconds]) -> [Text] + formatRow ((cpu, _), times) = formatCpu cpu : map formatColumn times + where + formatColumn :: Maybe Seconds -> Text + formatColumn = \ case + Nothing -> "-" + Just t -> formatTime t + + aggregated :: Map Configuration (Map Label [Seconds]) + aggregated = aggregateResults results + + labels :: [Label] + labels = sortLabels . Set.toList . mconcat . map Map.keysSet $ Map.elems aggregated + where + sortLabels :: [Label] -> [Label] + sortLabels = List.sortOn sortKey + + sortKey :: Label -> (Text, Int) + sortKey (Label label) = fromMaybe (label, maxBound) key + where + key :: Maybe (Text, Int) + key = swap <$> (listToMaybe (mapMaybe toKey labelOrder)) + + toKey :: (Int, Text) -> Maybe (Int, Text) + toKey = traverse (`T.stripSuffix` label) + + labelOrder :: [(Int, Text)] + labelOrder = zip [0..] [ + "ghc" + , "-dependencies" + , "-build" + ] + +formatLabel :: Label -> Text +formatLabel = \ case + "ghc-9.12.4-build" -> "[GHC 9.12.4 build](src/Benchmark/BuildGhc.hs)" + "hedgehog-1.7-dependencies" -> "[hedgehog-1.7-dependencies](src/Benchmark/BuildCabalPackage.hs)" + "hedgehog-1.7-build" -> "[hedgehog-1.7-build](src/Benchmark/BuildCabalPackage.hs)" + Label label -> label + +formatCpu :: Cpu -> Text +formatCpu cpu = mconcat ["[", cpuName cpu, "](", pack $ basePath cpu, ")"] + +median :: [Seconds] -> Maybe Seconds +median = List.sort >>> \ case + [] -> Nothing + values -> Just $ values !! (length values `div` 2) + +ensureFile :: FilePath -> ByteString -> IO () +ensureFile file new = do + old <- try @IOException $ B.readFile file + unless (old == Right new) do + createDirectoryIfMissing True (takeDirectory file) + B.writeFile file new diff --git a/test/ResultSpec.hs b/test/ResultSpec.hs --- a/test/ResultSpec.hs +++ b/test/ResultSpec.hs @@ -1,10 +1,21 @@ +{-# OPTIONS_GHC -Wno-orphans #-} module ResultSpec (spec) where import Helper + +import Data.Ord (comparing) +import Data.Aeson (ToJSONKey) +import Data.Yaml (ToJSON(..), object, (.=)) +import Data.Yaml.Pretty qualified as Yaml +import System.Directory (listDirectory) import Data.Text.IO.Utf8 qualified as Utf8 +import Data.Map.Strict qualified as Map import Fixtures.System qualified as System +import README (ensureFile) +import README qualified (update) +import SystemInfo import Result spec :: Spec @@ -14,37 +25,37 @@ it "creates a descriptive issue title" do issueTitle 0 System.i10900K_desktop `shouldBe` - "[result] 0s - desktop computer - Intel Core i9-10900K CPU" + "[result] 0s - desktop computer - Intel Core i9-10900K" context "with a laptop system" do it "creates a descriptive issue title" do issueTitle 0 System.dell_xps `shouldBe` - "[result] 0s - Dell Inc. XPS 13 9310 - 11th Gen Intel Core i7-1165G7" + "[result] 0s - Dell Inc. XPS 13 9310 - Intel Core i7-1165G7" context "with a LENOVO ThinkPad" do it "creates a descriptive issue title" do issueTitle 0 System.x200 `shouldBe` - "[result] 0s - LENOVO ThinkPad X200 - Intel Core2 Duo CPU P8700 " + "[result] 0s - LENOVO ThinkPad X200 - Intel Core 2 Duo P8700" describe "parseFromIssueBody" do let fixtures = [ - ("test/fixtures/i10900K_desktop", Result { - time = 526 + ("raw/2026-04-12T16:01:13Z", Result { + times = [("ghc-9.12.4-build", 526)] , concurrency = 20 , system = System.i10900K_desktop } ) - , ("test/fixtures/dell_xps", Result { - time = 715 + , ("raw/2026-04-12T13:37:10Z", Result { + times = [("ghc-9.12.4-build", 715)] , concurrency = 8 , system = System.dell_xps } ) - , ("test/fixtures/x200", Result { - time = 3013 + , ("raw/2026-04-12T17:38:23Z", Result { + times = [("ghc-9.12.4-build", 3013)] , concurrency = 2 , system = System.x200 } @@ -71,3 +82,67 @@ it "creates a descriptive path" do resultPath "2026-04-13" System.x200 `shouldBe` "results/intel/core_2/P8700/X200-7455D7G_2026-04-13.yaml" + + it "process results" do + results <- processResults "raw" + README.update results + +processResults :: FilePath -> IO [Result] +processResults dir = do + listDirectory dir >>= traverse \ timestamp -> do + body <- Utf8.readFile (dir timestamp) + let + result :: Result + result = parseFromIssueBody body + + path :: FilePath + path = resultPath (fromString timestamp) result.system + encodeFile path result + return result + +encodeFile :: FilePath -> Result -> IO () +encodeFile file result = do + ensureFile file $ Yaml.encodePretty conf result + where + conf :: Yaml.Config + conf = Yaml.setConfCompare (comparing byFieldOrder) Yaml.defConfig + + byFieldOrder :: Text -> Int + byFieldOrder name = fromMaybe maxBound (lookup name fieldOrder) + +fieldOrder :: [(Text, Int)] +fieldOrder = flip zip [1..] [ + "times" + , "concurrency" + , "os" + , "arch" + , "category" + , "chassis_type" + , "name" + , "cores" + , "threads" + , "vendor" + , "family" + , "model" + , "stepping" + , "version" + , "product" + , "board" + , "cpu" + , "ram" + ] + +instance ToJSON Result where + toJSON Result{..} = object [ + "times" .= Map.fromList times + , "concurrency" .= concurrency + , "system" .= system + ] + +deriving newtype instance ToJSONKey Label +deriving newtype instance ToJSON Seconds +deriving newtype instance ToJSON Concurrency +instance ToJSON SystemInfo +instance ToJSON Product +instance ToJSON Board +instance ToJSON Cpu diff --git a/test/RunSpec.hs b/test/RunSpec.hs new file mode 100644 --- /dev/null +++ b/test/RunSpec.hs @@ -0,0 +1,14 @@ +module RunSpec (spec) where + +import Helper +import System.IO.Silently +import README (ensureFile) + +import Run qualified + +spec :: Spec +spec = do + describe "--dry-run" do + it "prints commands" do + let run = Run.run ($ "") True [] "/path/to/ghc-9.12.4" 20 + capture_ run >>= ensureFile "test/dry-run" . encodeUtf8 . pack