packages feed

ghc-bench 0.3.0 → 0.3.1

raw patch · 14 files changed

+215/−152 lines, 14 files

Files

ghc-bench.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           ghc-bench-version:        0.3.0+version:        0.3.1 synopsis:       Benchmark a Haskell development system description:    See the README at <https://github.com/sol/ghc-bench#readme> category:       Development@@ -35,6 +35,7 @@       Result       Run       SystemInfo+      SystemInfo.Type   hs-source-dirs:       src       driver@@ -77,6 +78,7 @@       Result       Run       SystemInfo+      SystemInfo.Type       CommandSpec       Fixtures.System       Helper
src/Benchmark/Type.hs view
@@ -28,8 +28,7 @@  import Blob (Blob) import Blob qualified-import Command hiding (callWith)-import Command qualified+import Command (Env(..), callWith)  newtype Label = Label Text   deriving newtype (Eq, Show, Ord, IsString)@@ -131,7 +130,7 @@         writeLine ""         writeLine $ "# Ensure that " <> pack blob.path <> " exists; download if necessary."         writeLine $ "# url: " <> pack blob.url-        writeLine $ "# sha256: " <> blob.hash+        writeLine $ "# hash: " <> blob.hash         writeLine ""         return []
src/Benchmark/Util.hs view
@@ -16,8 +16,8 @@  import Prelude as Imports +import SystemInfo (Concurrency) import Benchmark.Type-import Command (Concurrency)  tar :: [String] -> Benchmark () tar = call "tar"
src/Blob.hs view
@@ -1,13 +1,15 @@ module Blob (-  download+  requireAll+, download , Blob(..) ) where  import Imports +import GHC.Fingerprint (getFileHash) import System.Directory (doesFileExist, renameFile) -import Command (curl, sha256sum)+import Command qualified  data Blob = Blob {   url :: FilePath@@ -28,12 +30,19 @@  verify :: Blob -> IO () verify Blob {..} = do-  actual <- sha256sum path+  actual <- show <$> getFileHash path   when (actual /= hash) . error $ unlines [-      "sha256sum mismatch!"+      "hash mismatch!"     , ""     , "  url:      " <> pack url     , "  file:     " <> pack path     , "  expected: " <> hash     , "  actual:   " <> actual     ]++requireAll :: IO ()+requireAll = do+  Command.require "curl"++curl :: [String] -> IO ()+curl = Command.call "curl"
src/Command.hs view
@@ -1,21 +1,11 @@ module Command (-  requireAll-, require+  require , resolve -, eval--, awk-, uname-, free-, lscpu-, sha256sum-, nproc--, curl--, Concurrency(..)+, run+, readProcess +, call , callWith , Env(..) , chdir@@ -29,44 +19,6 @@ import System.Environment (getEnvironment) import System.Process hiding (readProcess, callProcess) import System.Process qualified as Process--newtype Concurrency = Concurrency Int-  deriving newtype (Eq, Ord, Show, Read, Num)--eval :: String -> IO Text-eval command = run "bash" ["-c", command]--awk :: Text -> Text -> IO Text-awk command = readProcess "awk" [unpack command]--uname :: [String] -> IO Text-uname args = run "uname" args <&> T.strip--free :: [String] -> IO Text-free = run "free"--lscpu :: [String] -> IO Text-lscpu = run "lscpu"--sha256sum :: String -> IO Text-sha256sum file = T.take 64 <$> run "sha256sum" [file]--nproc :: IO Concurrency-nproc = read <$> readProcess "nproc" [] ""--curl :: [String] -> IO ()-curl = call "curl"--requireAll :: IO ()-requireAll = do-  require "bash"-  require "awk"-  require "uname"-  require "free"-  require "lscpu"-  require "sha256sum"-  require "nproc"-  require "curl"  require :: FilePath -> IO () require = void . resolve
src/Imports.hs view
@@ -1,10 +1,10 @@ module Imports (module Imports) where -import Prelude as Imports hiding (read, show, lines, unlines, words, unwords, error, putStrLn)+import Prelude as Imports hiding (read, show, lines, unlines, words, unwords, error, putStr, putStrLn)  import Data.Maybe as Imports- import Data.String as Imports (IsString(..))+import Data.Function as Imports ((&)) import Data.Functor as Imports hiding (unzip) import Data.Bifunctor as Imports (Bifunctor(..)) import Control.Arrow as Imports ((>>>))
src/Result.hs view
@@ -25,7 +25,6 @@ import Network.HTTP.Types.URI (renderSimpleQuery)  import Benchmark.Type (Label(..), Seconds(..))-import Command (Concurrency(..)) import SystemInfo  base :: ByteString@@ -227,6 +226,7 @@  cpuToPathComponents :: Cpu -> [Text] cpuToPathComponents cpu = case (cpu.vendor, cpu.family, cpu.model, cpu.stepping) of+  (Just "GenuineIntel", Just "6", Just "198", Just "2") -> ["core_ultra_series_2", T.drop 26 cpu.name]   (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]
src/Run.hs view
@@ -3,14 +3,15 @@ import Imports  import Data.List qualified as List-import Data.Text.IO (putStrLn)-import System.Directory (createDirectoryIfMissing)+import Data.Text.IO (putStr, putStrLn)+import System.Directory (getXdgDirectory, XdgDirectory(..), getTemporaryDirectory, createDirectoryIfMissing) import System.Exit (die) -import Command (Concurrency, nproc) import Command qualified+import SystemInfo (Concurrency) import SystemInfo qualified import Blob (Blob(..))+import Blob qualified import Result (Result(..), Label(..), Seconds) import Result qualified import Benchmark.Type (Benchmark, withLabel)@@ -26,15 +27,12 @@ ghc :: FilePath ghc = "ghc-" <> version -baseDir :: FilePath-baseDir = "/tmp/ghc-bench"--sourceTarball :: Tarball-sourceTarball = Tarball {+sourceTarball :: FilePath -> Tarball+sourceTarball dir = Tarball {     blob = Blob {       url = "https://downloads.haskell.org/~ghc/" <> version <> "/ghc-" <> version <> "-src.tar.gz"-    , path = baseDir </> "ghc-" <> version <> "-src.tar.gz"-    , hash = "df71d96169056d3a6d7ec17498864cbdd5511bda196440dc38a692133833dfa4"+    , path = dir </> "ghc-" <> version <> "-src.tar.gz"+    , hash = "078e0272f52407601e24f054a1efc2c5"     }   , root = "ghc-" <> version   }@@ -50,12 +48,21 @@  main :: [String] -> IO () main (parseOptions -> (dryRun, args)) = do-  Command.requireAll-  stage0 <- Command.resolve ghc++  cacheDir <- getXdgDirectory XdgCache "ghc-bench"+  createDirectoryIfMissing True cacheDir+  baseDir <- getTemporaryDirectory <&> (</> "ghc-bench")   createDirectoryIfMissing False baseDir++  Blob.requireAll+  SystemInfo.requireAll+  stage0 <- Command.resolve ghc   system <- SystemInfo.collect-  concurrency <- nproc-  times <- run (withTempDirectory baseDir "build") dryRun args stage0 concurrency+  concurrency <- SystemInfo.nproc++  putStr . unlines $ "" : SystemInfo.pretty system++  times <- run cacheDir (withTempDirectory baseDir "build") dryRun args stage0 concurrency   unless (null times) do     putStrLn "\ntimes:"     for_ times \ (Label name, time) -> do@@ -66,12 +73,15 @@  type WithTempDirectory = forall a. (FilePath -> IO a) -> IO a -run :: WithTempDirectory -> Bool -> [String] -> FilePath -> Concurrency -> IO [(Label, Seconds)]-run withTemp dryRun args stage0 concurrency = requireDependencies >> case args of+run :: FilePath -> WithTempDirectory -> Bool -> [String] -> FilePath -> Concurrency -> IO [(Label, Seconds)]+run cacheDir withTemp dryRun args stage0 concurrency = requireDependencies >> case args of   [] -> runAll-  [name] | Just action <- lookup name subcommands -> action+  [name] | Just action <- lookup name actions -> action   _ -> die usage   where+    source :: Tarball+    source = sourceTarball cacheDir+     requireDependencies :: IO ()     requireDependencies = for_ dependencies Command.require @@ -80,7 +90,7 @@      benchmarkActions :: [(String, Benchmark ())]     benchmarkActions = [-        ("ghc", withLabel ghc $ BuildGhc.run sourceTarball stage0 concurrency)+        ("ghc", withLabel ghc $ BuildGhc.run source stage0 concurrency)       , ("cabal", withLabel cabalPackage $ BuildCabalPackage.run cabalPackage ghc concurrency)       , ("ghci", withLabel ghciPackage $ Ghci.run ghciPackage ghc concurrency)       ]@@ -91,14 +101,8 @@     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 ]"+    usage = "\nusage: ghc-bench [ " <> List.intercalate " | " (map fst actions) <> " ] [ --dry-run ]"  runBenchmark :: Bool -> Benchmark () -> FilePath -> IO [(Label, Seconds)] runBenchmark dryRun action dir
src/SystemInfo.hs view
@@ -1,9 +1,14 @@ module SystemInfo (   collect+, pretty+, requireAll , SystemInfo(..) , Product(..) , Board(..) , Cpu(..)++, Concurrency(..)+, nproc ) where  import Imports hiding (product)@@ -14,22 +19,13 @@ import Data.Text qualified as T import Data.Text.IO.Utf8 qualified as Utf8 -import Command (eval, uname, lscpu, free, awk)--data SystemInfo = SystemInfo {-  os :: Text-, arch :: Text-, vendor :: Text-, product :: Product-, board :: Board-, cpu :: Cpu-, ram :: Int-} deriving (Eq, Show, Generic)+import SystemInfo.Type+import Command qualified  collect :: IO SystemInfo collect = do-  os <- eval ". /etc/os-release && echo $NAME || uname" <&> strip-  arch <- uname ["--machine"]+  os <- getOsName+  arch <- uname ["-m"]   vendor <- fromFile "/sys/class/dmi/id/sys_vendor"   product <- getProductInfo   board <- getBoardInfo@@ -42,14 +38,6 @@       31 -> 32 -- adjust for reserved ram that is not visible to the os       n -> n -data Product = Product {-  category :: Text-, chassis_type :: Text-, family :: Text-, name :: Text-, version :: Text-} deriving (Eq, Show, Generic)- getProductInfo :: IO Product getProductInfo = do   chassis_type <- fromFile "/sys/class/dmi/id/chassis_type"@@ -71,27 +59,12 @@   "14" -> "laptop"   _ -> "unknown" -data Board = Board {-  vendor :: Text-, name :: Text-} deriving (Eq, Show, Generic)- getBoardInfo :: IO Board getBoardInfo = do   vendor <- fromFile "/sys/class/dmi/id/board_vendor"   name <- fromFile "/sys/class/dmi/id/board_name"   return Board {..} -data Cpu = Cpu {-  name :: Text-, cores :: Int-, threads :: Int-, vendor :: Maybe Text-, family :: Maybe Text-, model :: Maybe Text-, stepping :: Maybe Text-} deriving (Eq, Ord, Show, Generic)- getCpuInfo :: IO Cpu getCpuInfo = do   threads <- lscpu ["-p=SOCKET,CORE,CPU,MODELNAME"] <&> parse@@ -130,3 +103,33 @@ fromFile p = try @IOException (Utf8.readFile p) <&> \ case   Left _ -> "unknown"   Right c -> strip c++requireAll :: IO ()+requireAll = do+  Command.require "bash"+  Command.require "awk"+  Command.require "uname"+  Command.require "free"+  Command.require "lscpu"+  Command.require "nproc"++getOsName :: IO Text+getOsName = Command.run "bash" ["-c", ". /etc/os-release && echo $NAME || uname"] <&> strip++awk :: Text -> Text -> IO Text+awk command = Command.readProcess "awk" [unpack command]++uname :: [String] -> IO Text+uname args = Command.run "uname" args <&> T.strip++free :: [String] -> IO Text+free = Command.run "free"++lscpu :: [String] -> IO Text+lscpu = Command.run "lscpu"++newtype Concurrency = Concurrency Int+  deriving newtype (Eq, Ord, Show, Read, Num)++nproc :: IO Concurrency+nproc = read <$> Command.readProcess "nproc" [] ""
+ src/SystemInfo/Type.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DefaultSignatures #-}+module SystemInfo.Type (+  SystemInfo(..)+, Product(..)+, Board(..)+, Cpu(..)++, pretty+) where++import Imports+import GHC.Generics+import Data.Text qualified as T++data SystemInfo = SystemInfo {+  os :: Text+, arch :: Text+, vendor :: Text+, product :: Product+, board :: Board+, cpu :: Cpu+, ram :: Int+} deriving (Eq, Show, Generic, ToFields)++data Product = Product {+  category :: Text+, chassis_type :: Text+, family :: Text+, name :: Text+, version :: Text+} deriving (Eq, Show, Generic, ToFields)++data Board = Board {+  vendor :: Text+, name :: Text+} deriving (Eq, Show, Generic, ToFields)++data Cpu = Cpu {+  name :: Text+, cores :: Int+, threads :: Int+, vendor :: Maybe Text+, family :: Maybe Text+, model :: Maybe Text+, stepping :: Maybe Text+} deriving (Eq, Ord, Show, Generic, ToFields)++pretty :: SystemInfo -> [Text]+pretty = toFields >>> labelWith "system" >>> formatFields++type Fields = [([Text], Text)]++leaf :: Text -> Fields+leaf value = [([], value)]++class ToFields a where+  toFields :: a -> Fields+  default toFields :: (Generic a, GenericToFields (Rep a)) => a -> Fields+  toFields = genericToFields . from++instance ToFields Int where+  toFields = leaf . show++instance ToFields Text where+  toFields = leaf++instance ToFields a => ToFields (Maybe a) where+  toFields = \ case+    Nothing -> leaf "unknown"+    Just value -> toFields value++formatFields :: Fields -> [Text]+formatFields = map \ case+  (name, value) -> T.intercalate "." name <> ": " <> value++labelWith :: String -> Fields -> Fields+labelWith = map . first . (:) . pack++class GenericToFields f where+  genericToFields :: f a -> Fields++instance (GenericToFields f) => GenericToFields (M1 D d f) where+  genericToFields = genericToFields . unM1++instance (GenericToFields f) => GenericToFields (M1 C c f) where+  genericToFields = genericToFields . unM1++instance (GenericToFields a, GenericToFields b) => GenericToFields (a :*: b) where+  genericToFields (a :*: b) = genericToFields a <> genericToFields b++instance (Selector s, GenericToFields f) => GenericToFields (M1 S s f) where+  genericToFields metadata@(M1 selector) = labelWith (selName metadata) $ genericToFields selector++instance ToFields a => GenericToFields (K1 i a) where+  genericToFields (K1 value) = toFields value
test/README.hs view
@@ -6,7 +6,6 @@ import Helper  import Data.List qualified as List-import Data.Tuple (swap) import Control.Exception import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory)@@ -90,28 +89,27 @@         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)+        sortKey :: Label -> Int+        sortKey (Label label) = fromMaybe maxBound $ lookup label labelOrder -        labelOrder :: [(Int, Text)]-        labelOrder = zip [0..] [-            "ghc"-          , "-dependencies"-          , "-build"-          ]+        labelOrder :: [(Text, Int)]+        labelOrder = zip [+            "ghc-9.12.4-build"+          , "hedgehog-1.7-dependencies"+          , "hedgehog-1.7-build"+          , "containers-0.8-ghci"+          ] [0..]  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+formatLabel (Label label) = case label of+  "ghc-9.12.4-build" -> markdownLink "GHC 9.12.4 build" "src/Benchmark/BuildGhc.hs"+  "hedgehog-1.7-dependencies" -> markdownLink label "src/Benchmark/BuildCabalPackage.hs"+  "hedgehog-1.7-build" -> markdownLink label "src/Benchmark/BuildCabalPackage.hs"+  "containers-0.8-ghci" -> markdownLink label "src/Benchmark/Ghci.hs"+  _ -> label++markdownLink :: Text -> Text -> Text+markdownLink name url = "[" <> name <> "](" <> url <> ")"  formatCpu :: Cpu -> Text formatCpu cpu = mconcat ["[", cpuName cpu, "](", pack $ basePath cpu,  ")"]
test/ResultSpec.hs view
@@ -42,19 +42,19 @@   describe "parseFromIssueBody" do     let       fixtures = [-          ("raw/2026-04-12T16:01:13Z", Result {+          ("raw/2026-04-12_16-01-13", Result {               times = [("ghc-9.12.4-build", 526)]             , concurrency = 20             , system = System.i10900K_desktop             }           )-        , ("raw/2026-04-12T13:37:10Z", Result {+        , ("raw/2026-04-12_13-37-10", Result {               times = [("ghc-9.12.4-build", 715)]             , concurrency = 8             , system = System.dell_xps             }           )-        , ("raw/2026-04-12T17:38:23Z", Result {+        , ("raw/2026-04-12_17-38-23", Result {               times = [("ghc-9.12.4-build", 3013)]             , concurrency = 2             , system = System.x200
test/RunSpec.hs view
@@ -10,5 +10,5 @@ spec = do   describe "--dry-run" do     it "prints commands" do-      let run = Run.run ($ "<sandbox>") True [] "/path/to/ghc-9.12.4" 20+      let run = Run.run "~/.cache/ghc-bench" ($ "<sandbox>") True [] "/path/to/ghc-9.12.4" 20       capture_ run >>= ensureFile "test/dry-run" . encodeUtf8 . pack
test/SystemInfoSpec.hs view
@@ -1,8 +1,8 @@ module SystemInfoSpec (spec) where  import Helper+import System.Environment (lookupEnv) -import Command qualified as Command import Fixtures.System qualified as System  import SystemInfo@@ -11,6 +11,6 @@ spec = do   describe "collect" do     it "collects system information" do-      Command.eval "whoami" <&> strip >>= \ case-        "sol" -> SystemInfo.collect `shouldReturn` System.i10900K_desktop+      lookupEnv "USER" >>= \ case+        Just "sol" -> SystemInfo.collect `shouldReturn` System.i10900K_desktop         _ -> pendingWith "add your system info to run this test"