packages feed

ghc-bench (empty) → 0.1.0

raw patch · 15 files changed

+719/−0 lines, 15 filesdep +basedep +bytestringdep +directory

Dependencies added: base, bytestring, directory, filepath, hspec, http-types, process, silently, temporary, text

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2026 Simon Hengel <sol@typeful.net>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ driver/Main.hs view
@@ -0,0 +1,9 @@+module Main (main) where++import Prelude+import System.Environment++import qualified Run++main :: IO ()+main = getArgs >>= Run.main
+ ghc-bench.cabal view
@@ -0,0 +1,101 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.39.1.+--+-- see: https://github.com/sol/hpack++name:           ghc-bench+version:        0.1.0+synopsis:       Benchmark a Haskell development system+description:    See 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+author:         Simon Hengel <sol@typeful.net>+maintainer:     Simon Hengel <sol@typeful.net>+license:        MIT+license-file:   LICENSE+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/sol/ghc-bench++executable ghc-bench+  main-is: Main.hs+  other-modules:+      Asset+      Command+      Imports+      Result+      Run+      SystemInfo+  hs-source-dirs:+      src+      driver+  default-extensions:+      NoImplicitPrelude+      OverloadedStrings+      RecordWildCards+      ViewPatterns+      BlockArguments+      LambdaCase+      NoFieldSelectors+      DuplicateRecordFields+      OverloadedRecordDot+  ghc-options: -Wall+  build-depends:+      base ==4.*+    , bytestring+    , directory+    , filepath+    , http-types+    , process+    , temporary+    , text+  default-language: GHC2024++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Asset+      Command+      Imports+      Result+      Run+      SystemInfo+      CommandSpec+      Fixtures.System+      Helper+      ResultSpec+      SystemInfoSpec+  hs-source-dirs:+      src+      test+  default-extensions:+      NoImplicitPrelude+      OverloadedStrings+      RecordWildCards+      ViewPatterns+      BlockArguments+      LambdaCase+      NoFieldSelectors+      DuplicateRecordFields+      OverloadedRecordDot+  ghc-options: -Wall+  cpp-options: -DTEST+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      base ==4.*+    , bytestring+    , directory+    , filepath+    , hspec ==2.*+    , http-types+    , process+    , silently+    , temporary+    , text+  default-language: GHC2024
+ src/Asset.hs view
@@ -0,0 +1,36 @@+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/Command.hs view
@@ -0,0 +1,90 @@+module Command (+  requireAll+, require+, resolve++, eval+, sh++, awk+, uname+, free+, lscpu+, sha256sum+, nproc++, curl+, tar+) where++import Imports hiding (strip)++import Data.Char (isSpace)+import Data.Text qualified as T++import System.Process (readProcessWithExitCode, rawSystem, callProcess)+import System.Process qualified as Process++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]++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 Int+nproc = read <$> Process.readProcess "nproc" [] ""++curl :: [String] -> IO ()+curl = callProcess "curl"++tar :: [String] -> IO ()+tar = callProcess "tar"++requireAll :: IO ()+requireAll = do+  require "bash"+  require "awk"+  require "uname"+  require "free"+  require "lscpu"+  require "sha256sum"+  require "nproc"+  require "curl"+  require "tar"++require :: String -> IO ()+require = void . resolve++resolve :: FilePath -> IO FilePath+resolve name = readProcessWithExitCode "which" [name] "" >>= \ case+  (ExitFailure _, _, _) -> error message+  (ExitSuccess, path, _) -> return $ strip path+  where+    message :: Text+    message = mconcat ["`", pack name, "` is required, but couldn't be found on the search PATH."]++    strip :: String -> String+    strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace++run :: String -> [String] -> 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)
+ src/Imports.hs view
@@ -0,0 +1,45 @@+module Imports (module Imports) where++import Prelude as Imports hiding (show, lines, unlines, words, unwords, error, putStrLn)++import Data.Maybe as Imports++import Data.Functor as Imports (void, (<&>))+import Control.Arrow as Imports ((>>>))+import Control.Monad as Imports (when, unless)++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 System.Exit (die)+import System.Directory (removePathForcibly)+import System.IO.Temp (createTempDirectory)+import Control.Exception (bracket)++withTempDirectory :: FilePath -> FilePath -> (FilePath -> IO a) -> IO a+withTempDirectory dir name = bracket (createTempDirectory dir name) removePathForcibly++error :: Text -> IO a+error message = die $ "ghc-bench: " <> unpack message++class Bind m r where+  bind :: (a -> r) -> m a -> r++instance Monad m => Bind m (m b) where+  bind :: (a -> m b) -> m a -> m b+  bind = (=<<)++instance Bind m r => Bind m (b -> r) where+  bind :: (a -> b -> r) -> m a -> b -> r+  bind f ma b = bind (flip f b) ma++infixl 1 -<++(-<) :: Bind m r => (a -> r) -> m a -> r+(-<) = bind++pass :: Applicative m => m ()+pass = pure ()
+ src/Result.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}+module Result (+  submit+, Result(..)+#ifdef TEST+, issueTitle+#endif+) where++import Imports++import Data.Text qualified as T+import Data.ByteString.Char8 (ByteString, putStrLn)+import Network.HTTP.Types.URI (renderSimpleQuery)++import SystemInfo++base :: ByteString+base = "https://github.com/sol/ghc-bench/issues/new"++data Result = Result {+  time :: Int+, concurrency :: Int+} deriving (Eq, Show)++submit :: Result -> SystemInfo -> IO ()+submit result system = do+  putStrLn "Open this URL to submit your result:"+  putStrLn $ issueUrl result system++issueUrl :: Result -> SystemInfo -> ByteString+issueUrl result system = base <> renderQuery [+    ("template", "benchmark-result.yml")+  , ("title", issueTitle result.time system)++  , ("time", show result.time)+  , ("concurrency", show result.concurrency)++  , ("os", system.os)+  , ("arch", system.arch)++  , ("system_vendor", system.vendor)++  , ("product_category", system.product.category)+  , ("product_chassis_type", system.product.chassis_type)+  , ("product_family", system.product.family)+  , ("product_name", system.product.name)+  , ("product_version", system.product.version)++  , ("board", unwords [system.board.vendor, system.board.name])++  , ("cpu_name", system.cpu.name)+  , ("cpu_cores", show system.cpu.cores)+  , ("cpu_threads", show system.cpu.threads)++  , ("cpuid", cpuid)++  , ("ram", system.ram)+  ]+  where+    cpuid :: Text+    cpuid = T.intercalate " / " [+        fromMaybe "unknown" system.cpu.vendor+      , fromMaybe "unknown" system.cpu.family+      , fromMaybe "unknown" system.cpu.model+      , fromMaybe "unknown" system.cpu.stepping+      ]++issueTitle :: Int -> SystemInfo -> Text+issueTitle seconds system = unwords ["[result]", show seconds <> "s", "-", description, "-", cpu]+  where+    description :: Text+    description = unwords case (system.vendor, system.product.name) of+      ("LENOVO", _) -> [system.vendor, system.product.version]+      (unknown -> True, _) -> [system.product.category, "computer"]+      (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++renderQuery :: [(ByteString, Text)] -> ByteString+renderQuery = renderSimpleQuery True . map (fmap encodeUtf8)
+ src/Run.hs view
@@ -0,0 +1,80 @@+module Run (main) where++import Imports+import Prelude qualified++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 qualified++import SystemInfo qualified++import Asset (Asset(..))+import Asset qualified++import Result (Result(..))+import Result qualified++version :: FilePath+version = "9.12.4"++bootGhc :: FilePath+bootGhc = "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"+  }++main :: [String] -> IO ()+main args = do+  Command.requireAll+  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}+    _ -> die "usage: ghc-bench [info]"+  putStrLn $ "Build time: " <> show result.time <> "s"+  putStrLn ""+  Result.submit result info++run :: FilePath -> Asset -> IO Result+run ghc source = withTempDirectory baseDir "run" \ sandbox -> do+  Asset.download source+  tar ["-xf", source.path, "-C", sandbox]+  build (sandbox </> "ghc-" <> version) ghc++build :: FilePath -> FilePath -> IO Result+build dir ghc = 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+    sh dir $ "hadrian/build -j" <> Prelude.show concurrency <> " --flavour=quickest"+  return Result{..}++measure :: IO () -> IO Int+measure action = do+  start <- getMonotonicTimeNSec+  action+  end <- getMonotonicTimeNSec+  let dtSeconds = fromIntegral (end - start) / 1e9 :: Double+  pure (round dtSeconds)
+ src/SystemInfo.hs view
@@ -0,0 +1,127 @@+module SystemInfo (+  collect+, SystemInfo(..)+, Product(..)+, Board(..)+, Cpu(..)+) where++import Imports hiding (product)++import Data.List (nub)+import Control.Exception++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 :: Text+} deriving (Eq, Show)++collect :: IO SystemInfo+collect = do+  os <- eval ". /etc/os-release && echo $NAME || uname" <&> strip+  arch <- uname ["--machine"]+  vendor <- fromFile "/sys/class/dmi/id/sys_vendor"+  product <- getProductInfo+  board <- getBoardInfo+  cpu <- getCpuInfo+  ram <- free ["-b"] >>= awk "/Mem:/ {print $2}" <&> strip+  return SystemInfo {..}++data Product = Product {+  category :: Text+, chassis_type :: Text+, family :: Text+, name :: Text+, version :: Text+} deriving (Eq, Show)++getProductInfo :: IO Product+getProductInfo = do+  chassis_type <- fromFile "/sys/class/dmi/id/chassis_type"+  family <- fromFile "/sys/class/dmi/id/product_family"+  name <- fromFile "/sys/class/dmi/id/product_name"+  version <- fromFile "/sys/class/dmi/id/product_version"+  return Product {+      category = interpretChassisType chassis_type+    , ..+    }++interpretChassisType :: Text -> Text+interpretChassisType = \ case+  "3" -> "desktop"+  "4" -> "desktop"+  "8" -> "laptop"+  "9" -> "laptop"+  "10" -> "laptop"+  "14" -> "laptop"+  _ -> "unknown"++data Board = Board {+  vendor :: Text+, name :: Text+} deriving (Eq, Show)++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, Show)++getCpuInfo :: IO Cpu+getCpuInfo = do+  threads <- lscpu ["-p=SOCKET,CORE,CPU,MODELNAME"] <&> parse+  let+    cpus  = nub [(socket, name) | (socket, _, _, name) <- threads]+    cores = nub [(socket, core) | (socket, core, _, _) <- threads]+  fields <- lscpu [] <&> parseFields+  return Cpu {+      name = T.intercalate " / " $ map snd cpus+    , cores = length cores+    , threads = length threads+    , vendor = lookup "Vendor ID" fields+    , family = lookup "CPU family" fields+    , model = lookup "Model" fields+    , stepping = lookup "Stepping" fields+    }+  where+    parse :: Text -> [(Text, Text, Text, Text)]+    parse = mapMaybe parseLine . removeComments . lines++    parseLine :: Text -> Maybe (Text, Text, Text, Text)+    parseLine = T.splitOn "," >>> \ case+      socket : core : thread : name -> Just (socket, core, thread, T.intercalate "," name)+      _ -> Nothing++    removeComments :: [Text] -> [Text]+    removeComments = filter (not . T.isPrefixOf "#")++    parseFields :: Text -> [(Text, Text)]+    parseFields = map parseField . lines++    parseField :: Text -> (Text, Text)+    parseField = fmap (strip . T.drop 1) . T.breakOn ": "++fromFile :: FilePath -> IO Text+fromFile p = try @IOException (Utf8.readFile p) <&> \ case+  Left _ -> "unknown"+  Right c -> strip c
+ test/CommandSpec.hs view
@@ -0,0 +1,22 @@+module CommandSpec (spec) where++import Helper++import System.IO+import System.IO.Silently+import Control.Exception++import Command++spec :: Spec+spec = do+  describe "resolve" do+    it "returns the absolute path to an executable" do+      resolve "cp" `shouldReturn` "/usr/bin/cp"++    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"+          , Left $ ExitFailure 1+          )
+ test/Fixtures/System.hs view
@@ -0,0 +1,61 @@+module Fixtures.System where++import Imports++import SystemInfo++i10900K_desktop :: SystemInfo+i10900K_desktop = SystemInfo {+    os = "Arch Linux"+  , arch = "x86_64"+  , vendor = "To Be Filled By O.E.M."+  , product = Product {+      category = "desktop"+    , chassis_type = "3"+    , family = "To Be Filled By O.E.M."+    , name = "To Be Filled By O.E.M."+    , version = "To Be Filled By O.E.M."+    }+  , board = Board {+      vendor = "ASRock"+    , name = "Z490M-ITX/ac"+    }+  , cpu = Cpu {+      name = "Intel(R) Core(TM) i9-10900K CPU @ 3.70GHz"+    , cores = 10+    , threads = 20+    , vendor = Just "GenuineIntel"+    , family = Just "6"+    , model = Just "165"+    , stepping = Just "5"+    }+  , ram = "33273524224"+  }++t60_ThinkPad :: SystemInfo+t60_ThinkPad = SystemInfo {+    os = "Arch Linux"+  , arch = "x86_64"+  , vendor = "LENOVO"+  , product = Product {+      category = "laptop"+    , chassis_type = "10"+    , family = "ThinkPad T60"+    , name = "1952W5R"+    , version = "ThinkPad T60"+    }+  , board = Board {+      vendor = "LENOVO"+    , name = "1952W5R"+    }+  , cpu = Cpu {+      name = "Intel(R) Core(TM) 2 Duo Processor T7200 @ 2.00GHz"+    , cores = 2+    , threads = 2+    , vendor = Just "GenuineIntel"+    , family = Just "6"+    , model = Just "15"+    , stepping = Just "6"+    }+  , ram = "0"+  }
+ test/Helper.hs view
@@ -0,0 +1,5 @@+module Helper (module Imports) where++import Imports+import Test.Hspec as Imports+import Run ()
+ test/ResultSpec.hs view
@@ -0,0 +1,18 @@+module ResultSpec (spec) where++import Helper++import Fixtures.System qualified as System++import Result++spec :: Spec+spec = do+  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"++    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"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/SystemInfoSpec.hs view
@@ -0,0 +1,16 @@+module SystemInfoSpec (spec) where++import Helper++import Command qualified as Command+import Fixtures.System qualified as System++import SystemInfo++spec :: Spec+spec = do+  describe "collect" do+    it "collects system information" do+      Command.eval "whoami" <&> strip >>= \ case+        "sol" -> SystemInfo.collect `shouldReturn` System.i10900K_desktop+        _ -> pendingWith "add your system info to run this test"