diff --git a/ghc-bench.cabal b/ghc-bench.cabal --- a/ghc-bench.cabal +++ b/ghc-bench.cabal @@ -5,9 +5,9 @@ -- see: https://github.com/sol/hpack name: ghc-bench -version: 0.1.0 +version: 0.2.0 synopsis: Benchmark a Haskell development system -description: See README at +description: See the README at category: Development homepage: https://github.com/sol/ghc-bench#readme bug-reports: https://github.com/sol/ghc-bench/issues @@ -43,6 +43,7 @@ NoFieldSelectors DuplicateRecordFields OverloadedRecordDot + DerivingStrategies ghc-options: -Wall build-depends: base ==4.* @@ -55,6 +56,43 @@ , 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 + default-language: GHC2024 + test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs @@ -83,6 +121,7 @@ NoFieldSelectors DuplicateRecordFields OverloadedRecordDot + DerivingStrategies ghc-options: -Wall cpp-options: -DTEST build-tool-depends: diff --git a/process-result/Main.hs b/process-result/Main.hs new file mode 100644 --- /dev/null +++ b/process-result/Main.hs @@ -0,0 +1,71 @@ +{-# 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/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -15,6 +15,8 @@ , curl , tar + +, Concurrency(..) ) where import Imports hiding (strip) @@ -25,6 +27,9 @@ import System.Process (readProcessWithExitCode, rawSystem, callProcess) import System.Process qualified as Process +newtype Concurrency = Concurrency Int + deriving newtype (Eq, Show, Read, Num) + eval :: String -> IO Text eval command = run "bash" ["-c", command] @@ -48,8 +53,8 @@ sha256sum :: String -> IO Text sha256sum file = T.take 64 <$> run "sha256sum" [file] -nproc :: IO Int -nproc = read <$> Process.readProcess "nproc" [] "" +nproc :: IO Concurrency +nproc = read <$> readProcess "nproc" [] "" curl :: [String] -> IO () curl = callProcess "curl" diff --git a/src/Imports.hs b/src/Imports.hs --- a/src/Imports.hs +++ b/src/Imports.hs @@ -1,19 +1,27 @@ module Imports (module Imports) where -import Prelude as Imports hiding (show, lines, unlines, words, unwords, error, putStrLn) +import Prelude as Imports hiding (read, show, lines, unlines, words, unwords, error, putStrLn) import Data.Maybe as Imports +import Data.String as Imports (IsString(..)) import Data.Functor as Imports (void, (<&>)) +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 GHC.Stack as Imports (HasCallStack) +import GHC.Generics as Imports (Generic) + import Data.Text as Imports (Text, show, lines, unlines, words, unwords, pack, unpack, strip) import Data.Text.Encoding as Imports (encodeUtf8) import System.Exit as Imports (ExitCode(..)) import System.FilePath as Imports (()) +import Prelude qualified +import Text.Read (readMaybe) import System.Exit (die) import System.Directory (removePathForcibly) import System.IO.Temp (createTempDirectory) @@ -24,6 +32,11 @@ error :: Text -> IO a error message = die $ "ghc-bench: " <> unpack message + +read :: HasCallStack => Read a => Text -> a +read input = case readMaybe (unpack input) of + Just a -> a + Nothing -> Prelude.error . unpack . unwords $ ["Prelude.read: could not parse", show input] class Bind m r where bind :: (a -> r) -> m a -> r diff --git a/src/Result.hs b/src/Result.hs --- a/src/Result.hs +++ b/src/Result.hs @@ -2,17 +2,23 @@ module Result ( submit , Result(..) +, Concurrency(..) +, parseFromIssueBody +, resultPath #ifdef TEST , issueTitle #endif ) where -import Imports +import Imports hiding (product) +import Prelude qualified import Data.Text qualified as T import Data.ByteString.Char8 (ByteString, putStrLn) +import System.FilePath (joinPath) import Network.HTTP.Types.URI (renderSimpleQuery) +import Command (Concurrency(..)) import SystemInfo base :: ByteString @@ -20,16 +26,17 @@ data Result = Result { time :: Int -, concurrency :: Int -} deriving (Eq, Show) +, concurrency :: Concurrency +, system :: SystemInfo +} deriving (Eq, Show, Generic) -submit :: Result -> SystemInfo -> IO () -submit result system = do +submit :: Result -> IO () +submit result = do putStrLn "Open this URL to submit your result:" - putStrLn $ issueUrl result system + putStrLn $ issueUrl result -issueUrl :: Result -> SystemInfo -> ByteString -issueUrl result system = base <> renderQuery [ +issueUrl :: Result -> ByteString +issueUrl result = base <> renderQuery [ ("template", "benchmark-result.yml") , ("title", issueTitle result.time system) @@ -55,9 +62,12 @@ , ("cpuid", cpuid) - , ("ram", system.ram) + , ("ram", show system.ram) ] where + system :: SystemInfo + system = result.system + cpuid :: Text cpuid = T.intercalate " / " [ fromMaybe "unknown" system.cpu.vendor @@ -76,14 +86,129 @@ (vendor, unknown -> True) -> [vendor, system.product.category] (vendor, name) -> [vendor, name] - unknown :: Text -> Bool - unknown = (== "To Be Filled By O.E.M.") - 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 +unknown :: Text -> Bool +unknown = (== "To Be Filled By O.E.M.") + renderQuery :: [(ByteString, Text)] -> ByteString renderQuery = renderSimpleQuery True . map (fmap encodeUtf8) + +parseFromIssueBody :: Text -> Result +parseFromIssueBody markdown = Result { + time = int "Build time (seconds)" + , concurrency = Concurrency $ int "Used number of threads" + , system + } + where + system :: SystemInfo + system = SystemInfo { + os = get "Operating System" + , arch = get "Architecture" + , vendor = get "System Vendor" + , product + , board + , cpu + , ram = int "RAM Size (GB)" + } + + product :: Product + product = Product { + category = get "Product Category" + , chassis_type = get "Chassis Type" + , family = get "Product Family" + , name = get "Product Name" + , version = get "Product Version" + } + + board :: Board + board = case T.breakOnEnd " " $ get "Motherboard" of + (strip -> vendor, name) -> Board {..} + + cpuid :: Text + cpuid = get "CPUID (vendor / family / model / stepping)" + + cpu :: Cpu + cpu = case map unknownToNothing $ T.splitOn " / " cpuid of + [vendor, family, model, stepping] -> Cpu { + name = get "CPU Name" + , cores = int "Cores" + , threads = int "Threads" + , .. + } + _ -> Prelude.error $ "Invalid CPUID: " <> unpack cpuid + + unknownToNothing :: Text -> Maybe Text + unknownToNothing "unknown" = Nothing + unknownToNothing value = Just value + + get :: Text -> Text + get key = case lookup key sections of + Just value -> value + Nothing -> Prelude.error $ "Missing field: " <> unpack key + + int :: Text -> Int + int = read . get + + sections :: [(Text, Text)] + sections = parseSections markdown + + parseSections :: Text -> [(Text, Text)] + parseSections = map parseSection . reverse . drop 1 . T.splitOn "\n### " + where + parseSection :: Text -> (Text, Text) + parseSection = bimap strip strip . T.break (== '\n') >>> \ case + (key, "_No response_") -> (key, "") + (key, value) -> (key, value) + +newtype Timestamp = Timestamp String + deriving newtype (Eq, Show, Read, IsString) + +resultPath :: Timestamp -> SystemInfo -> FilePath +resultPath (Timestamp timestamp) system = joinPath $ sanitizePathComponents 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 + + file :: Text + file = model <> "_" <> pack timestamp <> ".yaml" + + model :: Text + model = T.intercalate "-" case (system.vendor, system.product.name) of + ("LENOVO", _) -> [tryStripPrefix "ThinkPad " system.product.version, system.product.name] + (_, unknown -> True) -> [system.board.vendor, system.board.name] + (_, name) -> [name] + +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] + +sanitizePathComponent :: Text -> FilePath +sanitizePathComponent component = case sanitize component of + "" -> "unknown" + name -> name + where + sanitize = unpack . T.filter (/= '\0') . T.replace "/" "-" . T.intercalate "-" . T.words + +sanitizePathComponents :: [Text] -> [FilePath] +sanitizePathComponents = map sanitizePathComponent + +tryStripPrefix :: Text -> Text -> Text +tryStripPrefix prefix value = fromMaybe value $ T.stripPrefix prefix value diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -18,7 +18,7 @@ import Asset (Asset(..)) import Asset qualified -import Result (Result(..)) +import Result (Concurrency, Result(..)) import Result qualified version :: FilePath @@ -43,33 +43,32 @@ Command.require "cabal" ghc <- Command.resolve bootGhc createDirectoryIfMissing False baseDir - info <- SystemInfo.collect - result <- case args of - [] -> run ghc sourceTarball - ["info"] -> return Result {time = 0, concurrency = 0} + 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 result.time <> "s" + putStrLn $ "Build time: " <> show time <> "s" putStrLn "" - Result.submit result info + Result.submit Result {..} -run :: FilePath -> Asset -> IO Result -run ghc source = withTempDirectory baseDir "run" \ sandbox -> do +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 + build (sandbox "ghc-" <> version) ghc concurrency -build :: FilePath -> FilePath -> IO Result -build dir ghc = do +build :: FilePath -> FilePath -> Concurrency -> IO Int +build dir ghc concurrency = do setEnv "GHC" ghc True sh dir "./configure" -- this makes sure that building hadrian dependencies is not measured sh dir "hadrian/build --help" - concurrency <- nproc - time <- measure do + measure do sh dir $ "hadrian/build -j" <> Prelude.show concurrency <> " --flavour=quickest" - return Result{..} measure :: IO () -> IO Int measure action = do diff --git a/src/SystemInfo.hs b/src/SystemInfo.hs --- a/src/SystemInfo.hs +++ b/src/SystemInfo.hs @@ -23,8 +23,8 @@ , product :: Product , board :: Board , cpu :: Cpu -, ram :: Text -} deriving (Eq, Show) +, ram :: Int +} deriving (Eq, Show, Generic) collect :: IO SystemInfo collect = do @@ -34,8 +34,13 @@ product <- getProductInfo board <- getBoardInfo cpu <- getCpuInfo - ram <- free ["-b"] >>= awk "/Mem:/ {print $2}" <&> strip + ram <- free ["-b"] >>= awk "/Mem:/ {print $2}" <&> toGb . read . strip return SystemInfo {..} + where + toGb :: Int -> Int + toGb bytes = case ceiling @Double $ fromIntegral bytes / 1024 / 1024 / 1024 of + 31 -> 32 -- adjust for reserved ram that is not visible to the os + n -> n data Product = Product { category :: Text @@ -43,7 +48,7 @@ , family :: Text , name :: Text , version :: Text -} deriving (Eq, Show) +} deriving (Eq, Show, Generic) getProductInfo :: IO Product getProductInfo = do @@ -69,7 +74,7 @@ data Board = Board { vendor :: Text , name :: Text -} deriving (Eq, Show) +} deriving (Eq, Show, Generic) getBoardInfo :: IO Board getBoardInfo = do @@ -85,7 +90,7 @@ , family :: Maybe Text , model :: Maybe Text , stepping :: Maybe Text -} deriving (Eq, Show) +} deriving (Eq, Show, Generic) getCpuInfo :: IO Cpu getCpuInfo = do diff --git a/test/Fixtures/System.hs b/test/Fixtures/System.hs --- a/test/Fixtures/System.hs +++ b/test/Fixtures/System.hs @@ -29,33 +29,61 @@ , model = Just "165" , stepping = Just "5" } - , ram = "33273524224" + , ram = 32 } -t60_ThinkPad :: SystemInfo -t60_ThinkPad = SystemInfo { - os = "Arch Linux" +x200 :: SystemInfo +x200 = SystemInfo { + os = "Debian GNU/Linux" , arch = "x86_64" , vendor = "LENOVO" , product = Product { category = "laptop" , chassis_type = "10" - , family = "ThinkPad T60" - , name = "1952W5R" - , version = "ThinkPad T60" + , family = "ThinkPad X200" + , name = "7455D7G" + , version = "ThinkPad X200" } , board = Board { vendor = "LENOVO" - , name = "1952W5R" + , name = "7455D7G" } , cpu = Cpu { - name = "Intel(R) Core(TM) 2 Duo Processor T7200 @ 2.00GHz" + name = "Intel(R) Core(TM)2 Duo CPU P8700 @ 2.53GHz" , cores = 2 , threads = 2 , vendor = Just "GenuineIntel" , family = Just "6" - , model = Just "15" - , stepping = Just "6" + , model = Just "23" + , stepping = Just "10" } - , ram = "0" + , ram = 4 + } + +dell_xps :: SystemInfo +dell_xps = SystemInfo { + os = "Arch Linux" + , arch = "x86_64" + , vendor = "Dell Inc." + , product = Product { + category = "laptop" + , chassis_type = "10" + , family = "XPS" + , name = "XPS 13 9310" + , version = "" + } + , board = Board { + vendor = "Dell Inc." + , name = "0GG9PT" + } + , cpu = Cpu { + name = "11th Gen Intel(R) Core(TM) i7-1165G7 @ 2.80GHz" + , cores = 4 + , threads = 8 + , vendor = Just "GenuineIntel" + , family = Just "6" + , model = Just "140" + , stepping = Just "1" + } + , ram = 16 } diff --git a/test/ResultSpec.hs b/test/ResultSpec.hs --- a/test/ResultSpec.hs +++ b/test/ResultSpec.hs @@ -1,6 +1,7 @@ module ResultSpec (spec) where import Helper +import Data.Text.IO.Utf8 qualified as Utf8 import Fixtures.System qualified as System @@ -11,8 +12,62 @@ describe "issueTitle" do context "with a desktop system" do it "creates a descriptive issue title" do - issueTitle 0 System.i10900K_desktop `shouldBe` "[result] 0s - desktop computer - Intel Core i9-10900K CPU" + issueTitle 0 System.i10900K_desktop `shouldBe` + "[result] 0s - desktop computer - Intel Core i9-10900K CPU" + context "with a laptop system" do it "creates a descriptive issue title" do - issueTitle 0 System.t60_ThinkPad `shouldBe` "[result] 0s - LENOVO ThinkPad T60 - Intel Core 2 Duo Processor T7200" + issueTitle 0 System.dell_xps `shouldBe` + + "[result] 0s - Dell Inc. XPS 13 9310 - 11th Gen 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 " + + describe "parseFromIssueBody" do + let + fixtures = [ + ("test/fixtures/i10900K_desktop", Result { + time = 526 + , concurrency = 20 + , system = System.i10900K_desktop + } + ) + , ("test/fixtures/dell_xps", Result { + time = 715 + , concurrency = 8 + , system = System.dell_xps + } + ) + , ("test/fixtures/x200", Result { + time = 3013 + , concurrency = 2 + , system = System.x200 + } + ) + ] + + for_ fixtures \ (name, expected) -> do + it name do + entry <- parseFromIssueBody <$> Utf8.readFile name + entry `shouldBe` expected + + describe "resultPath" do + context "with a desktop system" do + it "creates a descriptive path" do + resultPath "2026-04-13" System.i10900K_desktop `shouldBe` + "results/intel/10th/i9-10900K/ASRock-Z490M-ITX-ac_2026-04-13.yaml" + + context "with a laptop system" do + it "creates a descriptive path" do + resultPath "2026-04-13" System.dell_xps `shouldBe` + "results/intel/11th/i7-1165G7/XPS-13-9310_2026-04-13.yaml" + + context "with a LENOVO ThinkPad" do + it "creates a descriptive path" do + resultPath "2026-04-13" System.x200 `shouldBe` + "results/intel/core_2/P8700/X200-7455D7G_2026-04-13.yaml"