packages feed

ghc-bench 0.2.0 → 0.3.0

raw patch · 18 files changed

+767/−252 lines, 18 filesdep +aesondep +containersdep +transformers

Dependencies added: aeson, containers, transformers

Files

ghc-bench.cabal view
@@ -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 <https://github.com/sol/ghc-bench#readme> 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
− process-result/Main.hs 
@@ -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
− src/Asset.hs 
@@ -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-    ]
+ src/Benchmark/BuildCabalPackage.hs view
@@ -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+      ]
+ src/Benchmark/BuildGhc.hs view
@@ -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"
+ src/Benchmark/Ghci.hs view
@@ -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"+      ]
+ src/Benchmark/Type.hs view
@@ -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
+ src/Benchmark/Util.hs view
@@ -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"
+ src/Blob.hs view
@@ -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+    ]
src/Command.hs view
@@ -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)+  ]
src/Imports.hs view
@@ -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
src/Result.hs view
@@ -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
src/Run.hs view
@@ -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
src/SystemInfo.hs view
@@ -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
test/CommandSpec.hs view
@@ -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           )
+ test/README.hs view
@@ -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
test/ResultSpec.hs view
@@ -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
+ test/RunSpec.hs view
@@ -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 ($ "<sandbox>") True [] "/path/to/ghc-9.12.4" 20+      capture_ run >>= ensureFile "test/dry-run" . encodeUtf8 . pack