Skip to content

Commit 5a90cd0

Browse files
soulomoonsoulomoon
authored
Merge branch 'master' into fix-stuck-at-exit
2 parents 5e71390 + 863d0cd commit 5a90cd0

File tree

4 files changed

+84
-47
lines changed

4 files changed

+84
-47
lines changed

‎.github/workflows/bench.yml‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -156,6 +156,9 @@ jobs:
156156
- name: Display results
157157
run: |
158158
column -s, -t < bench-results/unprofiled/${{ matrix.example }}/results.csv | tee bench-results/unprofiled/${{ matrix.example }}/results.txt
159+
echo
160+
echo "Performance Diff(comparing to its previous Version):"
161+
column -s, -t < bench-results/unprofiled/${{ matrix.example }}/resultDiff.csv | tee bench-results/unprofiled/${{ matrix.example }}/resultDiff.txt
159162
160163
- name: tar benchmarking artifacts
161164
run: find bench-results -name "*.csv" -or -name "*.svg" -or -name "*.html" | xargs tar -czf benchmark-artifacts.tar.gz

‎bench/Main.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -163,6 +163,7 @@ createBuildSystem config = do
163163

164164
buildRules build hlsBuildRules
165165
benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchHls warmupHls "haskell-language-server" (parallelism configStatic))
166+
addGetParentOracle
166167
csvRules build
167168
svgRules build
168169
heapProfileRules build

‎bench/README.md‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -54,6 +54,9 @@ Targets:
5454
- bench-results/*/*/*/results.csv
5555
- bench-results/*/*/results.csv
5656
- bench-results/*/results.csv
57+
- bench-results/*/*/*/resultDiff.csv
58+
- bench-results/*/*/resultDiff.csv
59+
- bench-results/*/resultDiff.csv
5760
- bench-results/*/*/*/*.svg
5861
- bench-results/*/*/*/*.diff.svg
5962
- bench-results/*/*/*.svg

‎shake-bench/src/Development/Benchmark/Rules.hs‎

Lines changed: 77 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,7 @@ module Development.Benchmark.Rules
4848
(
4949
buildRules, MkBuildRules(..), OutputFolder, ProjectRoot,
5050
benchRules, MkBenchRules(..), BenchProject(..), ProfilingMode(..),
51+
addGetParentOracle,
5152
csvRules,
5253
svgRules,
5354
heapProfileRules,
@@ -77,11 +78,13 @@ import Data.Aeson (FromJSON (..),
7778
import Data.Aeson.Lens (AsJSON (_JSON),
7879
_Object, _String)
7980
import Data.ByteString.Lazy (ByteString)
80-
import Data.Char (isDigit)
81-
import Data.List (find, isInfixOf,
81+
import Data.Char (isAlpha, isDigit)
82+
import Data.List (find, intercalate,
83+
isInfixOf,
84+
isSuffixOf,
8285
stripPrefix,
8386
transpose)
84-
import Data.List.Extra (lower)
87+
import Data.List.Extra (lower, splitOn)
8588
import Data.Maybe (fromMaybe)
8689
import Data.String (fromString)
8790
import Data.Text (Text)
@@ -144,7 +147,9 @@ allTargetsForExample prof baseFolder ex = do
144147
configurations <- askOracle $ GetConfigurations ()
145148
let buildFolder = baseFolder </> profilingPath prof
146149
return $
147-
[buildFolder </> getExampleName ex </> "results.csv"]
150+
[
151+
buildFolder </> getExampleName ex </> "results.csv"
152+
, buildFolder </> getExampleName ex </> "resultDiff.csv"]
148153
++ [ buildFolder </> getExampleName ex </> escaped (escapeExperiment e) <.> "svg"
149154
| e <- experiments
150155
]
@@ -187,6 +192,8 @@ phonyRules prefix executableName prof buildFolder examples = do
187192
allTargetsForExample prof buildFolder ex
188193
need $ (buildFolder </> profilingPath prof </> "results.csv")
189194
: concat exampleTargets
195+
need $ (buildFolder </> profilingPath prof </> "resultDiff.csv")
196+
: concat exampleTargets
190197
phony (prefix <> "all-binaries") $ need =<< allBinaries buildFolder executableName
191198
--------------------------------------------------------------------------------
192199
type OutputFolder = FilePath
@@ -384,69 +391,92 @@ parseMaxResidencyAndAllocations input =
384391

385392

386393
--------------------------------------------------------------------------------
387-
394+
-- | oracles to get previous version of a given version
395+
-- used for diff the results
396+
addGetParentOracle :: Rules ()
397+
addGetParentOracle = void $ addOracle $ \(GetParent name) -> findPrev name <$> askOracle (GetVersions ())
388398
-- | Rules to aggregate the CSV output of individual experiments
389399
csvRules :: forall example . RuleResultForExample example => FilePattern -> Rules ()
390400
csvRules build = do
401+
let genConfig resultName prefixName prefixOracles out = do
402+
configurations <- prefixOracles
403+
let allResultFiles = [takeDirectory out </> c </> resultName | c <- configurations ]
404+
allResults <- traverse readFileLines allResultFiles
405+
let header = head $ head allResults
406+
results = map tail allResults
407+
header' = prefixName <> ", " <> header
408+
results' = zipWith (\v -> map (\l -> v <> ", " <> l)) configurations results
409+
writeFileChanged out $ unlines $ header' : interleave results'
391410
-- build results for every experiment*example
392-
build -/- "*/*/*/*/results.csv" %> \out -> do
411+
priority 1 $ build -/- "*/*/*/*/results.csv" %> \out -> do
393412
experiments <- askOracle $ GetExperiments ()
394-
395413
let allResultFiles = [takeDirectory out </> escaped (escapeExperiment e) <.> "csv" | e <- experiments]
396414
allResults <- traverse readFileLines allResultFiles
397-
398415
let header = head $ head allResults
399416
results = map tail allResults
400417
writeFileChanged out $ unlines $ header : concat results
401-
418+
priority 2 $ build -/- "*/*/*/*/resultDiff.csv" %> \out -> do
419+
let out2@[b, flav, example, ver, conf, exp_] = splitDirectories out
420+
prev <- fmap T.unpack $ askOracle $ GetParent $ T.pack ver
421+
allResultsCur <- readFileLines $ joinPath [b ,flav, example, ver, conf] </> "results.csv"
422+
allResultsPrev <- readFileLines $ joinPath [b ,flav, example, prev, conf] </> "results.csv"
423+
let resultsPrev = tail allResultsPrev
424+
let resultsCur = tail allResultsCur
425+
let resultDiff = zipWith convertToDiffResults resultsCur resultsPrev
426+
writeFileChanged out $ unlines $ head allResultsCur : resultDiff
402427
-- aggregate all configurations for an experiment
403-
build -/- "*/*/*/results.csv" %> \out -> do
404-
configurations <- map confName <$> askOracle (GetConfigurations ())
405-
let allResultFiles = [takeDirectory out </> c </> "results.csv" | c <- configurations ]
406-
407-
allResults <- traverse readFileLines allResultFiles
408-
409-
let header = head $ head allResults
410-
results = map tail allResults
411-
header' = "configuration, " <> header
412-
results' = zipWith (\v -> map (\l -> v <> ", " <> l)) configurations results
413-
414-
writeFileChanged out $ unlines $ header' : interleave results'
415-
428+
priority 3 $ build -/- "*/*/*/results.csv" %> genConfig "results.csv"
429+
"Configuration" (map confName <$> askOracle (GetConfigurations ()))
430+
priority 3 $ build -/- "*/*/*/resultDiff.csv" %> genConfig "resultDiff.csv"
431+
"Configuration" (map confName <$> askOracle (GetConfigurations ()))
416432
-- aggregate all experiments for an example
417-
build -/- "*/*/results.csv" %> \out -> do
418-
versions <- map (T.unpack . humanName) <$> askOracle (GetVersions ())
419-
let allResultFiles = [takeDirectory out </> v </> "results.csv" | v <- versions]
420-
421-
allResults <- traverse readFileLines allResultFiles
422-
423-
let header = head $ head allResults
424-
results = map tail allResults
425-
header' = "version, " <> header
426-
results' = zipWith (\v -> map (\l -> v <> ", " <> l)) versions results
427-
428-
writeFileChanged out $ unlines $ header' : interleave results'
429-
433+
priority 4 $ build -/- "*/*/results.csv" %> genConfig "results.csv"
434+
"Version" (map (T.unpack . humanName) <$> askOracle (GetVersions ()))
435+
priority 4 $ build -/- "*/*/resultDiff.csv" %> genConfig "resultDiff.csv"
436+
"Version" (map (T.unpack . humanName) <$> askOracle (GetVersions ()))
430437
-- aggregate all examples
431-
build -/- "*/results.csv" %> \out -> do
432-
examples <- map (getExampleName @example) <$> askOracle (GetExamples ())
433-
let allResultFiles = [takeDirectory out </> e </> "results.csv" | e <- examples]
434-
435-
allResults <- traverse readFileLines allResultFiles
436-
437-
let header = head $ head allResults
438-
results = map tail allResults
439-
header' = "example, " <> header
440-
results' = zipWith (\e -> map (\l -> e <> ", " <> l)) examples results
438+
priority 5 $ build -/- "*/results.csv" %> genConfig "results.csv"
439+
"Example" (map getExampleName <$> askOracle (GetExamples ()))
440+
priority 5 $ build -/- "*/resultDiff.csv" %> genConfig "resultDiff.csv"
441+
"Example" (map getExampleName <$> askOracle (GetExamples ()))
442+
443+
convertToDiffResults :: String -> String -> String
444+
convertToDiffResults line baseLine = intercalate "," diffResults
445+
where items = parseLine line
446+
baseItems = parseLine baseLine
447+
diffItems = zipWith diffItem items baseItems
448+
diffResults = map showItemDiffResult diffItems
449+
450+
showItemDiffResult :: (Item, Maybe Double) -> String
451+
showItemDiffResult (ItemString x, _) = x
452+
showItemDiffResult (_, Nothing) = "NA"
453+
showItemDiffResult (Mem x, Just y) = printf "%.2f" (y * 100 - 100) <> "%"
454+
showItemDiffResult (Time x, Just y) = printf "%.2f" (y * 100 - 100) <> "%"
455+
456+
diffItem :: Item -> Item -> (Item, Maybe Double)
457+
diffItem (Mem x) (Mem y) = (Mem x, Just $ fromIntegral x / fromIntegral y)
458+
diffItem (Time x) (Time y) = (Time x, if y == 0 then Nothing else Just $ x / y)
459+
diffItem (ItemString x) (ItemString y) = (ItemString x, Nothing)
460+
diffItem _ _ = (ItemString "no match", Nothing)
461+
462+
data Item = Mem Int | Time Double | ItemString String
463+
deriving (Show)
441464

442-
writeFileChanged out $ unlines $ header' : concat results'
465+
parseLine :: String -> [Item]
466+
parseLine = map f . splitOn ","
467+
where
468+
f x
469+
| "MB" `isSuffixOf` x = Mem $ read $ reverse $ drop 2 $ reverse x
470+
| otherwise =
471+
case readMaybe @Double x of
472+
Just time -> Time time
473+
Nothing -> ItemString x
443474

444475
--------------------------------------------------------------------------------
445476

446477
-- | Rules to produce charts for the GC stats
447478
svgRules :: FilePattern -> Rules ()
448479
svgRules build = do
449-
void $ addOracle $ \(GetParent name) -> findPrev name <$> askOracle (GetVersions ())
450480
-- chart GC stats for an experiment on a given revision
451481
priority 1 $
452482
build -/- "*/*/*/*/*.svg" %> \out -> do

0 commit comments

Comments
 (0)