packages feed

ghc-bench 0.1.0 → 0.2.0

raw patch · 9 files changed

+392/−52 lines, 9 filesdep +yaml

Dependencies added: yaml

Files

ghc-bench.cabal view
@@ -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 <https://github.com/sol/ghc-bench#readme>+description:    See the README at <https://github.com/sol/ghc-bench#readme> 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:
+ process-result/Main.hs view
@@ -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
src/Command.hs view
@@ -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"
src/Imports.hs view
@@ -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
src/Result.hs view
@@ -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
src/Run.hs view
@@ -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
src/SystemInfo.hs view
@@ -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
test/Fixtures/System.hs view
@@ -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   }
test/ResultSpec.hs view
@@ -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"