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.3.0 +version: 0.3.1 synopsis: Benchmark a Haskell development system description: See the README at 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 diff --git a/src/Benchmark/Type.hs b/src/Benchmark/Type.hs --- a/src/Benchmark/Type.hs +++ b/src/Benchmark/Type.hs @@ -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 [] diff --git a/src/Benchmark/Util.hs b/src/Benchmark/Util.hs --- a/src/Benchmark/Util.hs +++ b/src/Benchmark/Util.hs @@ -16,8 +16,8 @@ import Prelude as Imports +import SystemInfo (Concurrency) import Benchmark.Type -import Command (Concurrency) tar :: [String] -> Benchmark () tar = call "tar" diff --git a/src/Blob.hs b/src/Blob.hs --- a/src/Blob.hs +++ b/src/Blob.hs @@ -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" diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -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 diff --git a/src/Imports.hs b/src/Imports.hs --- a/src/Imports.hs +++ b/src/Imports.hs @@ -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 ((>>>)) diff --git a/src/Result.hs b/src/Result.hs --- a/src/Result.hs +++ b/src/Result.hs @@ -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] diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -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 diff --git a/src/SystemInfo.hs b/src/SystemInfo.hs --- a/src/SystemInfo.hs +++ b/src/SystemInfo.hs @@ -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" [] "" diff --git a/src/SystemInfo/Type.hs b/src/SystemInfo/Type.hs new file mode 100644 --- /dev/null +++ b/src/SystemInfo/Type.hs @@ -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 diff --git a/test/README.hs b/test/README.hs --- a/test/README.hs +++ b/test/README.hs @@ -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, ")"] diff --git a/test/ResultSpec.hs b/test/ResultSpec.hs --- a/test/ResultSpec.hs +++ b/test/ResultSpec.hs @@ -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 diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -10,5 +10,5 @@ spec = do describe "--dry-run" do it "prints commands" do - let run = Run.run ($ "") True [] "/path/to/ghc-9.12.4" 20 + let run = Run.run "~/.cache/ghc-bench" ($ "") True [] "/path/to/ghc-9.12.4" 20 capture_ run >>= ensureFile "test/dry-run" . encodeUtf8 . pack diff --git a/test/SystemInfoSpec.hs b/test/SystemInfoSpec.hs --- a/test/SystemInfoSpec.hs +++ b/test/SystemInfoSpec.hs @@ -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"