diff --git a/.gitignore b/.gitignore index f4181ce334..8a74793ae4 100644 --- a/.gitignore +++ b/.gitignore @@ -59,6 +59,9 @@ tests/**/*.dyn_o tests/**/*.hi-boot tests/**/*.o-boot +tmp/ +*.svg + .idea *.iml diff --git a/README.md b/README.md index 1a3c11fddd..f901bd0a1f 100644 --- a/README.md +++ b/README.md @@ -25,7 +25,7 @@ to let us know. If possible, try to: ## Your first Pull Request -We are thrilled to get PRs! Please follow these guidelines, as doing so will increase the chances of +We are thrilled to get PRs! Please follow these guidelines, as doing so will increase the chances of having your PR accepted: * The main LH repo [lives here](https://github.com/ucsd-progsys/liquidhaskell) @@ -98,7 +98,7 @@ It's also possible (but not recommended) to add `LIQUID_DEV_MODE` to .bashrc or permanently disable building the `liquid-*` packages, and this might silently mask breaking changes to the `liquidhaskell` library that would manifest only when compiling these other packages. -If you wish to force building all the libraries again, it's sufficient to issue the same builds commands +If you wish to force building all the libraries again, it's sufficient to issue the same builds commands without the `LIQUID_DEV_MODE`. ## How To Run Regression Tests @@ -115,7 +115,7 @@ You can run a bunch of particular test-groups instead by $ LIQUID_DEV_MODE=true ./scripts/test/test_plugin.sh ... -and you can list all the possible test options with +and you can list all the possible test options with $ LIQUID_DEV_MODE=true ./scripts/test/test_plugin.sh --help @@ -147,8 +147,8 @@ When `liquidhaskell` tests run, we can collect timing information with $ ./scripts/test/test_plugin.sh --measure-timings -Measures will be collected in `.dump-timings` files. These can be converted to json -data with +Measures will be collected in `.dump-timings` files under `dist-newstyle` directory. These can be +converted to json data with ```bash cabal v2-build ghc-timings @@ -163,16 +163,26 @@ cabal v2-run benchmark-timings -- tmp/*.json --phase LiquidHaskell -o summary.cs ``` On each line, the report will contain the time taken by each test. -There is a script `scripts/plot-performance/chart_perf.sh` that can be -used to generate comparison charts in `svg` and `png` formats. It -requires [gnuplot](http://www.gnuplot.info/) to run. The following -command will produce two files `perf.svg` and `perf.png` in the -current directory. +Comparison charts in `svg` format can be generated by invoking + +``` +cabal v2-run plot-performance -- -b path_to_before_summary.csv -a path_to_after_summary.csv -s 50 -f "benchmark" -o outdir +``` + +This will generate three files `filtered.svg` (a subset of tests with a `benchmark` prefix, enabled by the `-f` option), +`top.svg` and `bot.svg` (top 50 speedups and slowdowns over the entire test set, both enabled by the `-s` option) under +the `outdir` directory. The `-f` and `-s` options can be used/omitted independently. If both are omitted, a single +`perf.svg` will be produced covering the full input test set. Additionally, their effects can be combined by providing +a third `-c` option (this will produce 2 files `filtered-top.svg` and `filtered-bot.svg` instead of 3). + +There is also a legacy script `scripts/plot-performance/chart_perf.sh` that can be used to generate comparison charts +in both `svg` and `png` formats. It requires [gnuplot](http://www.gnuplot.info/) to run and assumes both files contain +the same test set. The following command will produce two files `perf.svg` and `perf.png` in the current directory. $ scripts/plot-performance/chart_perf.sh path_to_before_summary.csv path_to_after_summary.csv -The current formatting is optimized for comparing the outputs of running -the benchmarks alone. +The current formatting is optimized for comparing some subsets of the full test run, typically just the benchmarks alone. +If one wishes to save time or is not interested in top speedups/slowdowns, the benchmark subset can be obtained by running $ scripts/test/test_plugin.sh \ benchmark-stitch-lh \ @@ -185,7 +195,7 @@ the benchmarks alone. ## Miscelaneous tasks -* **Profiling** See the instructions in [scripts/ProfilingDriver.hs][]. +* **Profiling** See the instructions in [scripts/ProfilingDriver.hs](scripts/ProfilingDriver.hs). * **Getting stack traces on exceptions** See `-xc` flag in the [GHC user's guide][ghc-users-guide]. * **Working with submodules** See `man gitsubmodules` or the [git documentation site][git-documentation]. @@ -338,7 +348,7 @@ any `LiftedSpec` from the interface file's annotations. Typically the first thing you might want to do is to run a "clean" `cabal v2-build` or `stack build` using the latest compiler and "check the damage". If you are lucky, everything works out of the box, otherwise compilation might fail with an error, typically because some `ghc` API function has been removed/moved/renamed. -The way to fix it is to modify the [GHC.API][] shim module and perform any required change, likely by +The way to fix it is to modify the [GHC.API][] shim module and perform any required change, likely by conditionally compiling some code in a `CPP` block. For minor changes, it's usually enough to perform small changes, but for more tricky migrations it might be necessary to backport some GHC code, or create some patter synonym to deal with changes in type constructors. @@ -348,8 +358,6 @@ patter synonym to deal with changes in type constructors. Currently, no. Only one version of GHC is supported and that is the one that can be tested with `./scripts/test/test_plugin.sh`. -[GHC.API]: src-ghc/Liquid/GHC/API.hs - # GHC Plugin Development FAQs ## Why is the GHC.Interface using slightly different types than the GHC.Plugin module? @@ -361,24 +369,24 @@ to map back and forth (sometimes in a partial way) between old and new data stru **consider the GHC.Plugin as the single source of truth, and prefer whichever data structure the latter is using**. - -[Plugin]: src/Language/Haskell/Liquid/GHC/Plugin.hs -[GHC.Plugin]: src/Language/Haskell/Liquid/GHC/Plugin.hs -[GHC.Interface]: src-ghc/Liquid/GHC/Interface.hs -[SpecFinder]: src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs -[BareSpec]: src/Language/Haskell/Liquid/Types/Specs.hs#L361 -[LiftedSpec]: src/Language/Haskell/Liquid/Types/Specs.hs#L554 -[TargetSrc]: src/Language/Haskell/Liquid/Types/Specs.hs#L157 -[Ghc monad]: https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#t:Ghc -[HscEnv]: https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#t:HscEnv -[DynFlags]: https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#t:DynFlags -[GhcMonad]: https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#t:GhcMonad -[GhcMonadLike]: src-ghc/Liquid/GHC/GhcMonadLike.hs -[typechecking phase]: src/Language/Haskell/Liquid/GHC/Plugin.hs#L206-L222 +[GHC.API]: liquidhaskell-boot/src-ghc/Liquid/GHC/API.hs +[Plugin]: liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Plugin.hs +[GHC.Plugin]: liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Plugin.hs +[GHC.Interface]: liquidhaskell-boot/src-ghc/Liquid/GHC/Interface.hs +[SpecFinder]: liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs +[BareSpec]: liquidhaskell-boot/src/Language/Haskell/Liquid/Types/Specs.hs#L362 +[LiftedSpec]: liquidhaskell-boot/src/Language/Haskell/Liquid/Types/Specs.hs#L559 +[TargetSrc]: liquidhaskell-boot/src/Language/Haskell/Liquid/Types/Specs.hs#L158 +[Ghc monad]: https://hackage.haskell.org/package/ghc-9.2.5/docs/GHC.html#t:Ghc +[HscEnv]: https://hackage.haskell.org/package/ghc-9.2.5/docs/GHC.html#t:HscEnv +[DynFlags]: https://hackage.haskell.org/package/ghc-9.2.5/docs/GHC.html#t:DynFlags +[GhcMonad]: https://hackage.haskell.org/package/ghc-9.2.5/docs/GHC.html#t:GhcMonad +[GhcMonadLike]: liquidhaskell-boot/src-ghc/Liquid/GHC/GhcMonadLike.hs +[typechecking phase]: liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Plugin.hs#L211-L226 [ghcide]: https://github.com/haskell/ghcide -[findRelevantSpecs]: src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs#L61 -[core binds]: https://hackage.haskell.org/package/ghc-8.10.1/docs/CoreSyn.html#t:CoreBind -[configureGhcTargets]: src-ghc/Liquid/GHC/Interface.hs#L252 -[processTargetModule]: src-ghc/Liquid/GHC/Interface.hs#L481 -[processModule]: src/Language/Haskell/Liquid/GHC/Plugin.hs#L393 +[findRelevantSpecs]: liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Plugin/SpecFinder.hs#L65 +[core binds]: https://hackage.haskell.org/package/ghc-9.2.5/docs/CoreSyn.html#t:CoreBind +[configureGhcTargets]: liquidhaskell-boot/src-ghc/Liquid/GHC/Interface.hs#L254 +[processTargetModule]: liquidhaskell-boot/src-ghc/Liquid/GHC/Interface.hs#L483 +[processModule]: liquidhaskell-boot/src/Language/Haskell/Liquid/GHC/Plugin.hs#L509 diff --git a/benchmark-timings/app/Main.hs b/benchmark-timings/app/Main.hs index 1000b9428e..fb309f83ae 100644 --- a/benchmark-timings/app/Main.hs +++ b/benchmark-timings/app/Main.hs @@ -49,18 +49,18 @@ data Options = Options options :: Parser Options options = Options <$> - (many (argument + many (argument str (metavar "FILEPATH..." - <> help "The files you wish to process."))) - <*> (many (strOption (long "phase" + <> help "The files you wish to process.")) + <*> many (strOption (long "phase" <> short 'p' <> metavar "PHASE" - <> help "Phase to include in summary. Can be specified more thance once."))) - <*> (strOption (long "output" + <> help "Phase to include in summary. Can be specified more thance once.")) + <*> strOption (long "output" <> short 'o' <> metavar "OUTPUTFILEPATH" - <> help "File to which to output CSV contents.")) + <> help "File to which to output CSV contents.") opts :: ParserInfo Options opts = info (options <**> helper) diff --git a/cabal.project b/cabal.project index 0efa1218ef..8eb99f0422 100644 --- a/cabal.project +++ b/cabal.project @@ -10,12 +10,19 @@ packages: . ./tests ./tests/benchmarks/popl18/lib ./benchmark-timings + ./scripts/plot-performance source-repository-package type: git location: https://github.com/qnikst/ghc-timings-report tag: 45ef3498e35897712bde8e002ce18df6d55f8b15 +source-repository-package + type: git + location: https://github.com/timbod7/haskell-chart/ + tag: ba85444d3c81774a43b8c2b046084e92869914f4 + subdir: chart + allow-newer: ghc-timings:base, rest-rewrite:time package liquid-fixpoint diff --git a/scripts/plot-benchmarks/src/Benchmark.hs b/scripts/plot-benchmarks/src/Benchmark.hs index 083db182ef..a23240f620 100644 --- a/scripts/plot-benchmarks/src/Benchmark.hs +++ b/scripts/plot-benchmarks/src/Benchmark.hs @@ -21,11 +21,11 @@ instance Ord Benchmark where compare lhs rhs = compare (benchTimestamp lhs) (benchTimestamp rhs) unionAppend :: Map.Map String [Benchmark] - -> Map.Map String Benchmark - -> Map.Map String [Benchmark] + -> Map.Map String Benchmark + -> Map.Map String [Benchmark] unionAppend l r = Map.unionWith (++) l r' where - r' = fmap (\a -> [a]) r + r' = (\a -> [a]) <$> r toBenchMap :: (Foldable f) => f Benchmark @@ -40,8 +40,7 @@ instance FromRecord Benchmark where <*> pure (error ("Shouldn't be evaluated until after" ++ " reassignment!")) <*> r .! 1 - <*> do asStr <- r .! 2 - return $ read asStr {- Since the test suite + <*> (read <$> r .! 2) {- Since the test suite generates this field by calling show, this read Should Be Safe (TM) -} csvOutName = "Name" @@ -51,6 +50,6 @@ csvOutPass = "Success" instance ToNamedRecord (LocalTime, Benchmark) where toNamedRecord (_, bm) = namedRecord [csvOutName .= benchName bm, - csvOutDate .= (show $ benchTimestamp bm), - csvOutTime .= (benchTime bm), - csvOutPass .= (show $ benchPass bm)] + csvOutDate .= (show $ benchTimestamp bm), + csvOutTime .= (benchTime bm), + csvOutPass .= (show $ benchPass bm)] diff --git a/scripts/plot-benchmarks/src/Config.hs b/scripts/plot-benchmarks/src/Config.hs index 489f4fe4e4..f17176d8cc 100644 --- a/scripts/plot-benchmarks/src/Config.hs +++ b/scripts/plot-benchmarks/src/Config.hs @@ -5,9 +5,7 @@ module Config where import System.Console.CmdArgs import System.Directory -data OutputType = - Svg - | Csv +data OutputType = Svg | Csv deriving (Eq, Data, Typeable, Show) data Config = @@ -32,7 +30,7 @@ instance Default Config where config :: Config config = Config { logDir = pwd &= help "The directory that contains the logs", - outputDir = pwd &= help "The diretory to output graphs to", + outputDir = pwd &= help "The directory to output graphs to", outputType = Csv &= help "The type of output to produce", plotCompare = def &= help "Pairs of benchmarks to compare", plot = def &= help "Benchmarks to plot" diff --git a/scripts/plot-benchmarks/src/Main.hs b/scripts/plot-benchmarks/src/Main.hs index 5421469497..cc39ae40d9 100644 --- a/scripts/plot-benchmarks/src/Main.hs +++ b/scripts/plot-benchmarks/src/Main.hs @@ -5,26 +5,13 @@ import Config import Parse main :: IO () -main = do - conf <- getConfig - case (outputType conf) of - Csv -> do - csvData <- getAllData - (logDir conf) - (plot conf) - dumpLogs - (outputDir conf) - csvData - Svg -> do - timeData <- getTimeData - (logDir conf) - (plot conf) - plotTimeData - (outputDir conf) - timeData - compareTimeData <- getCompareTimeData - (logDir conf) - (plotCompare conf) - plotCompareTimeData - (outputDir conf) - compareTimeData +main = + do conf <- getConfig + case outputType conf of + Csv -> do csvData <- getAllData (logDir conf) (plot conf) + dumpLogs (outputDir conf) csvData + Svg -> do timeData <- getTimeData (logDir conf) (plot conf) + plotTimeData (outputDir conf) timeData + compareTimeData <- getCompareTimeData (logDir conf) + (plotCompare conf) + plotCompareTimeData (outputDir conf) compareTimeData diff --git a/scripts/plot-performance/app/Benchmark.hs b/scripts/plot-performance/app/Benchmark.hs new file mode 100644 index 0000000000..e7fe8ab4f6 --- /dev/null +++ b/scripts/plot-performance/app/Benchmark.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Benchmark where + +import Prelude hiding (readFile, writeFile, filter, zip, lookup) +import Data.Ord (Down(..)) +import Data.String (fromString) +import Data.List as L +import Data.Vector as V hiding (length, concat, null, (++), last, find) +import Data.Map as M hiding (null) +import Data.ByteString.Char8 (unpack) +import Data.ByteString.Lazy.Char8 (readFile, writeFile) +import GHC.Generics (Generic) +import Data.Csv hiding (Options, Parser, lookup) + +-- Individual entries + +data Benchmark = Benchmark + { test :: String + , time :: Double + , result :: Bool + } deriving stock (Eq, Ord, Show, Generic) + +instance FromField Bool where + parseField = pure . read . unpack + +instance ToField Bool where + toField b = fromString $ show b + +instance FromNamedRecord Benchmark where + parseNamedRecord m = Benchmark + <$> m .: "test" + <*> m .: "time" + <*> m .: "result" + +instance ToNamedRecord Benchmark +instance DefaultOrdered Benchmark + +readCSV :: FilePath -> IO (Vector Benchmark) +readCSV f = do bytes <- readFile f + case decodeByName bytes of + Left err -> error err + Right (_, bs) -> pure bs + +writeCSV :: FilePath -> [Benchmark] -> IO () +writeCSV f dat = do + let csvData = encodeDefaultOrderedByNameWith (defaultEncodeOptions { encUseCrLf = False }) dat + writeFile f csvData + +-- Data sets + +type BData = (Double, Bool) + +data BenchmarkDataSet = BenchmarkDS + { removed :: [(String, BData)] + , combined :: [(String, BData, BData)] + , added :: [(String, BData)] + } deriving stock (Eq, Ord, Show, Generic) + +bdsLen :: BenchmarkDataSet -> Int +bdsLen (BenchmarkDS rs xs as) = length rs + length xs + length as + +splitBenchmarks :: Vector Benchmark + -> Vector Benchmark + -> BenchmarkDataSet +splitBenchmarks v1 v2 = go v1 (M.fromList $ V.toList $ V.map kvfun v2) + where + kvfun b = (test b, (time b, result b)) + go :: Vector Benchmark -> Map String BData -> BenchmarkDataSet + go vb ma = case V.uncons vb of + Just (Benchmark n f r, tl) -> + case M.lookup n ma of + Just a -> let (BenchmarkDS rs xs as) = go tl (M.delete n ma) in + BenchmarkDS rs ((n, (f, r), a) : xs) as + Nothing -> let (BenchmarkDS rs xs as) = go tl ma in + BenchmarkDS ((n, (f, r)) : rs) xs as + Nothing -> BenchmarkDS [] [] (M.toList ma) + +hiBenchmarks :: Int -> BenchmarkDataSet -> BenchmarkDataSet +hiBenchmarks n (BenchmarkDS rs xs as) = + let rs' = L.take n $ sortOn (Down . fst . snd) rs + ys = sortOn (\(_, bt, at) -> fst at - fst bt) xs + ys' = L.take (n - length rs') ys + as' = L.take (n - (length rs' + length ys')) $ sortOn (Down . fst . snd) as + in BenchmarkDS rs' ys' as' + +loBenchmarks :: Int -> BenchmarkDataSet -> BenchmarkDataSet +loBenchmarks n (BenchmarkDS rs xs as) = + let as' = L.take n $ sortOn (fst . snd) as + ys = sortOn (\(_, bt, at) -> fst bt - fst at) xs + ys' = L.take (n - length as') ys + rs' = L.take (n - (length as' + length ys')) $ sortOn (fst . snd) rs + in BenchmarkDS rs' ys' as' + +decouple :: BenchmarkDataSet -> Bool -> ([Benchmark], [Benchmark]) +decouple (BenchmarkDS rs xs as) rev = + let + rb = L.map toBench1 rs + (xs1,xs2) = L.unzip $ L.map toBench2 xs + ab = L.map toBench1 as + in + if rev + then (L.map nullBench ab ++ xs1 ++ rb, ab ++ xs2 ++ L.map nullBench rb) + else (rb ++ xs1 ++ L.map nullBench ab, L.map nullBench rb ++ xs2 ++ ab) + where + toBench1 (n, (t,f)) = Benchmark n t f + toBench2 (n, (t1,f1), (t2,f2)) = (Benchmark n t1 f1, Benchmark n t2 f2) + nullBench (Benchmark n _ _) = Benchmark n 0.0 False diff --git a/scripts/plot-performance/app/Main.hs b/scripts/plot-performance/app/Main.hs new file mode 100644 index 0000000000..0c30c64e85 --- /dev/null +++ b/scripts/plot-performance/app/Main.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Main where + +import Prelude hiding (readFile, filter, zip, lookup) +import Data.Maybe (isJust) +import Data.List (find, isPrefixOf) +import Data.Vector as V hiding (concat, null, (++), last, find) +import Options.Applicative +import System.Directory (createDirectoryIfMissing) + +import Benchmark +import Plot (chartToFile) + +data Options = Options + { optsBeforeFile :: FilePath + , optsAfterFile :: FilePath + , optsCombine :: Bool + , optsSort :: Maybe Int + , optsFilter :: [String] + , optsOutputDir :: Maybe FilePath + } deriving stock (Eq, Ord, Show) + +options :: Parser Options +options = Options <$> + strOption (long "before" + <> short 'b' + <> metavar "BEFOREPATH" + <> help "Input CSV file with original benchmark data.") + <*> strOption (long "after" + <> short 'a' + <> metavar "AFTERPATH" + <> help "Input CSV file with modified benchmark data.") + <*> switch (long "combine" + <> short 'c' + <> help "If both sort and filter are used, combine their actions instead of doing both in parallel (default)" ) + <*> optional (option auto (long "sort" + <> short 's' + <> metavar "N" + <> help "Generate two graphs for top and bottom N differences.")) + <*> (concat <$> many (option (words <$> str) (long "filter" + <> short 'f' + <> metavar "FILTER" + <> help "Whitespace-separated list of test names to include, in quotes."))) + <*> optional (strOption (long "outdir" + <> short 'o' + <> metavar "OUTDIR" + <> help "The folder which will receive output graphs.")) + +opts :: ParserInfo Options +opts = info (options <**> helper) + (fullDesc + <> progDesc "Plot test performance difference.") + +main :: IO () +main = do op <- execParser opts + + outdir <- maybe (pure "") + (\od -> do let nm = if null od || (not (null od) && (last od == '/')) then od else od ++ "/" + createDirectoryIfMissing True nm + pure nm) + (optsOutputDir op) + + -- TODO: use a regexp? + let f = V.filter (\b -> isJust $ find (\fi -> fi `isPrefixOf` test b) (optsFilter op)) + + vb <- f0 <$> readCSV (optsBeforeFile op) + va <- f0 <$> readCSV (optsAfterFile op) + + case (optsSort op, null $ optsFilter op, optsCombine op) of + (Just n , False, True ) -> + let bdsf = splitBenchmarks (f vb) (f va) + hif = hiBenchmarks n bdsf + lof = loBenchmarks n bdsf + in do chartToFile False "Top filtered speedups (seconds)" hif (outdir ++ "filtered-top.svg") + chartToFile True "Top filtered slowdowns (seconds)" lof (outdir ++ "filtered-bot.svg") + (Just n , False, False) -> + let bds = splitBenchmarks vb va + bdsf = splitBenchmarks (f vb) (f va) + hi = hiBenchmarks n bds + lo = loBenchmarks n bds + in do chartToFile False ("Perf diff: " ++ show (optsFilter op) ++ " (seconds)") bdsf (outdir ++ "filtered.svg") + chartToFile False "Top speedups (seconds)" hi (outdir ++ "top.svg") + chartToFile True "Top slowdowns (seconds)" lo (outdir ++ "bot.svg") + (Just n , True , _ ) -> + let bds = splitBenchmarks vb va + hi = hiBenchmarks n bds + lo = loBenchmarks n bds + in do chartToFile False "Top speedups (seconds)" hi (outdir ++ "top.svg") + chartToFile True "Top slowdowns (seconds)" lo (outdir ++ "bot.svg") + (Nothing, False, _ ) -> + let bdsf = splitBenchmarks (f vb) (f va) + in chartToFile False "Perf diff (seconds)" bdsf (outdir ++ "filtered.svg") + (Nothing, True , _ ) -> + let bds = splitBenchmarks vb va + in do chartToFile False "Perf" bds (outdir ++ "perf.svg") + where + f0 = V.filter (\b -> test b /= "app/Main") diff --git a/scripts/plot-performance/app/Plot.hs b/scripts/plot-performance/app/Plot.hs new file mode 100644 index 0000000000..8e94ac3b2c --- /dev/null +++ b/scripts/plot-performance/app/Plot.hs @@ -0,0 +1,111 @@ +module Plot where + +import Text.Printf ( printf ) +import Control.Lens ( _Just, (.~) ) +import Graphics.Rendering.Chart +import Graphics.Rendering.Chart.Backend.Diagrams +import Data.Default.Class (Default(..)) +import Data.Colour ( opaque, withOpacity ) +import Data.Colour.Names ( green, grey, red ) + +import Benchmark + +chart :: Bool -> String -> BenchmarkDataSet -> Renderable (LayoutPick LogValue PlotIndex PlotIndex) +chart rev title bds = layoutToRenderable layout + where + layout = + -- title + legend + layout_title .~ title + $ layout_title_style . font_size .~ 30 + $ layout_legend . _Just . legend_position .~ LegendAbove + $ layout_legend . _Just . legend_margin .~ 10 + $ layout_legend . _Just . legend_label_style . font_size .~ 18 + + -- X + $ layout_x_axis . laxis_style . axis_grid_style .~ solidLine 0.4 (opaque grey) + $ layout_x_axis . laxis_style . axis_label_gap .~ 3 + $ layout_x_axis . laxis_style . axis_label_style . font_size .~ 18 + $ layout_x_axis . laxis_override .~ axisGridAtBigTicks + $ layout_top_axis_visibility . axis_show_line .~ True + $ layout_top_axis_visibility . axis_show_ticks .~ True + $ layout_top_axis_visibility . axis_show_labels .~ True + $ layout_bottom_axis_visibility . axis_show_ticks .~ True + + -- Y + $ layout_y_axis . laxis_generate .~ autoIndexAxis' True lab + $ layout_y_axis . laxis_override .~ axisGridAtTicks + $ layout_y_axis . laxis_reverse .~ True + $ layout_y_axis . laxis_style . axis_grid_style .~ solidLine 0.5 (opaque grey) + $ layout_y_axis . laxis_style . axis_label_style . font_size .~ 14 + $ layout_left_axis_visibility . axis_show_ticks .~ False + + -- data + $ layout_plots .~ [ plotHBars bars ] + + $ def :: Layout LogValue PlotIndex + + bars = plot_bars_values_with_labels .~ addIndexes dat + $ plot_bars_titles .~ ["","after","before"] + $ plot_bars_style .~ BarsStacked + $ plot_bars_spacing .~ BarsFixGap 10 10 + $ plot_bars_item_styles .~ colors + $ plot_bars_label_bar_hanchor .~ BHA_Right + $ plot_bars_label_bar_vanchor .~ BVA_Centre + $ plot_bars_label_text_hanchor .~ HTA_Left + $ plot_bars_label_text_vanchor .~ VTA_Centre + $ plot_bars_label_offset .~ Vector 3 0 + $ plot_bars_label_style . font_slant .~ FontSlantItalic + $ plot_bars_label_style . font_size .~ 15 + $ def + + (lab, dat) = diffData rev bds + + colors = map (\c -> (solidFillStyle $ withOpacity c 0.7, Nothing)) [grey, red, green] + +-- TODO we currently ignore the test state flag +diffData :: Bool -> BenchmarkDataSet -> ([String], [[(LogValue, String)]]) +diffData rev (BenchmarkDS rs xs as) = + if rev + then (alab ++ xlab ++ rlab, adat ++ xdat ++ rdat) + else (rlab ++ xlab ++ alab, rdat ++ xdat ++ adat) + where + (rlab, rdat) = unzip $ map + (\(l,(v, _)) -> (l, [ (LogValue 0, "") + , (LogValue 0, "") + , (LogValue v, printf "%0.2f" (-v)) ] )) rs + (xlab, xdat) = unzip $ map + (\(l,(a,_),(b,_)) -> (l, [ (LogValue (min a b), if a == b then "0.0" else "") + , if a < b then + let v = b - a in + (LogValue v, printf "%0.2f" v) + else (LogValue 0, "") + , if b < a then + let v = a - b in + (LogValue v, printf "%0.2f" (-v)) + else (LogValue 0, "") + ] )) xs + (alab, adat) = unzip $ map + (\(l,(v,_)) -> (l, [ (LogValue 0, "") + , (LogValue v, printf "%0.2f" v) + , (LogValue 0, "") ] )) as + +-- This is fitted to specific values above (font size etc) +heightHeuristic :: Int -> Double +heightHeuristic n | n < 10 = 8.0 + | n < 28 = 9.0 + | n < 65 = 10.0 + | n < 138 = 11.0 + | n < 283 = 12.0 + | n < 577 = 13.0 + | otherwise = 14.0 + +chartToFile :: Bool -> String -> BenchmarkDataSet -> FilePath -> IO () +chartToFile rev title bds path = + do let len = bdsLen bds + let wh = (2048.0, 2.0 ** heightHeuristic len) + let fo = FileOptions wh SVG loadSansSerifFonts + let plot = chart rev title bds + let cb = render plot wh + putStrLn $ printf "Writing %s (%d entries, %.0fx%.0f)" path len (fst wh) (snd wh) + _ <- cBackendToFile fo cb path + pure () diff --git a/scripts/plot-performance/plot-performance.cabal b/scripts/plot-performance/plot-performance.cabal new file mode 100644 index 0000000000..35cc315006 --- /dev/null +++ b/scripts/plot-performance/plot-performance.cabal @@ -0,0 +1,53 @@ +cabal-version: 2.4 +name: plot-performance +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +-- license: +author: The Liquid Haskell Developers + +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: CHANGELOG.md + +flag devel + default: False + description: Enable more warnings and fail compilation when warnings occur. + Turn this flag on in CI. + +executable plot-performance + main-is: Main.hs + -- Modules included in this executable, other than Main. + other-modules: + Benchmark + Plot + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base + , bytestring >=0.10.12 && <0.12 + , cassava ^>=0.5.2 + , Chart >= 1.9.4 + , Chart-diagrams + , colour + , containers + , data-default-class + , directory + , lens + , optparse-applicative >=0.16.1 && <0.18 + , vector + ghc-options: -Wall + hs-source-dirs: app + default-language: Haskell2010 + if flag(devel) + ghc-options: -Werror