work on performance comparison tool

2 files changed, 43 insertions, 5 deletions

diff --git a/test/PerfReport.hs b/test/PerfReport.hs
new file mode 100644
index 00000000..7ad0b9b8
--- /dev/null
+++ b/test/PerfReport.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE ViewPatterns, TupleSections #-}
+import Data.Char
+import System.Directory
+import System.FilePath
+import Text.Printf
+import Control.Monad
+import Data.Map (Map,(!))
+import qualified Data.Map as Map
+
+-- HINT: lambdacube-compiler-test-suite --overall-time performance +RTS -tcurrent.log --machine-readable
+-- output: current.log overall-time.txt
+
+resultPath = "performance"
+
+main = do
+  -- read current result
+  overallTime <- read <$> readFile "overall-time.txt" :: IO Double
+  let toDouble = read :: String -> Double
+      toInteger = read :: String -> Integer
+  new <- Map.fromList . (:) ("overall_time",show overallTime) . read . unlines . tail . lines <$> readFile "current.log" :: IO (Map String String)
+  let totalAlloc a = toInteger $ a ! "bytes allocated"
+      peakAlloc a = toInteger $ a ! "peak_megabytes_allocated"
+      totalAllocF a = toDouble $ a ! "bytes allocated"
+      peakAllocF a = toDouble $ a ! "peak_megabytes_allocated"
+      overallTime a = toDouble $ a ! "overall_time"
+
+  putStrLn $ printf "%-20s time: % 6.3fs \tpeak mem: % 6d MBytes total alloc: %d bytes" "current" (overallTime new) (peakAlloc new) (totalAlloc new)
+  -- read previous results
+  perfs <- filter ((".perf" ==) . takeExtension) <$> getDirectoryContents "performance" >>= mapM (\n -> (n,) . read <$> readFile (resultPath </> n)) :: IO [(String,Map String String)]
+  forM_ perfs $ \(name,old) -> do
+    putStrLn $ printf "%-20s time: %+6.3f%% \tpeak mem: %+6.3f%% \ttotal alloc: %+6.3f%%"
+      name (100*(overallTime new / overallTime old - 1)) (100*(peakAllocF new / peakAllocF old - 1)) (100*(totalAllocF new / totalAllocF old - 1))
+  --TODO
+  --writeFile "performance/release-0.5.perf" $ show new
\ No newline at end of file
diff --git a/test/runTests.hs b/test/runTests.hs
index c36e6c59..a175bc7e 100644
--- a/test/runTests.hs
+++ b/test/runTests.hs
@@ -84,10 +84,11 @@ testDataPath = "./testdata"
 
 data Config
   = Config
-  { cfgVerbose :: Bool
-  , cfgReject  :: Bool
-  , cfgTimeout :: NominalDiffTime
-  , cfgIgnore  :: [String]
+  { cfgVerbose      :: Bool
+  , cfgReject       :: Bool
+  , cfgTimeout      :: NominalDiffTime
+  , cfgIgnore       :: [String]
+  , cfgOverallTime  :: Bool
   } deriving Show
 
 arguments :: Parser (Config, [String])
@@ -96,6 +97,7 @@ arguments =
                   <*> switch (short 'r' <> long "reject" <> help "Reject test cases with missing, new or different .out files")
                   <*> option (realToFrac <$> (auto :: ReadM Double)) (value 60 <> short 't' <> long "timeout" <> help "Timeout for tests in seconds")
                   <*> many (option (eitherReader Right) (short 'i' <> long "ignore" <> help "Ignore test"))
+                  <*> switch (long "overall-time" <> help "Writes overall time to overall-time.txt")
           )
       <*> many (strArgument idm)
 
@@ -167,7 +169,9 @@ main = do
              ]
       ++ sh (\s ty -> ty == Passed && isWip s) "wip passed test"
 
-  putStrLn $ "Overall time: " ++ showTime (sum $ map fst resultDiffs)
+  let overallTime = sum $ map fst resultDiffs
+  putStrLn $ "Overall time: " ++ showTime overallTime
+  when cfgOverallTime $ writeFile "overall-time.txt" $ show (realToFrac overallTime :: Double)
 
   when (or [erroneous r | ((_, r), f) <- zip resultDiffs testSet, not $ isWip f]) exitFailure
   putStrLn "All OK"