-
Notifications
You must be signed in to change notification settings - Fork 4
/
BenchmarkRunner.hs
214 lines (195 loc) · 7.13 KB
/
BenchmarkRunner.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
module Fibon.Run.BenchmarkRunner (
RunResult(..)
, RunFailure(..)
, Fibon.Run.BenchmarkRunner.run
)
where
import Control.Concurrent
import Control.Monad
import Control.Exception
import qualified Data.ByteString as B
import Data.Maybe
import Data.Time.Clock
import qualified Data.Vector.Unboxed as Vector
import Fibon.BenchmarkInstance
import Fibon.Result
import Fibon.Run.BenchmarkBundle
import Fibon.Run.Log as Log
import qualified Fibon.Run.SysTools as SysTools
import Statistics.Sample
import System.Directory
import System.FilePath
import System.IO
import System.Process
import Text.Printf
data RunResult =
Success {runSummary :: RunSummary, runDetails :: [RunDetail]}
| Failure [RunFailure]
deriving (Read, Show)
data RunFailure =
MissingOutput FilePath
| DiffError String
| Timeout
| ExitError {exitExpected :: ExitCode, exitActual :: ExitCode}
deriving (Read, Show)
run :: BenchmarkBundle -> IO RunResult
run bb = do
let bmk = (bundleName bb)
pwd = (pathToExeBuildDir bb)
cmd = (prettyRunCommand bb)
Log.info $ "Running Benchmark "
Log.info $ " BMK: " ++ bmk
Log.info $ " PWD: " ++ pwd
Log.info $ " CMD: " ++ cmd
Log.info $ printf "\n@%s|%s|%s" bmk pwd cmd
runDirect bb
{-
-- Move this to analysis time
analyze :: Sample -> ExtraStats -> Int -> Double -> IO RunSummary
analyze times ghcStats numResamples ci = do
let ests = [mean, stdDev]
res <- withSystemRandom $ \gen ->
resample gen ests numResamples times :: IO [Resample]
let [em,es] = bootstrapBCA ci times ests res
let runData = RunSummary {
timeSummary =
TimeMeasurement {
meanTime = estPoint em
, meanTimeLB = estLowerBound em
, meanTimeUB = estUpperBound em
, meanStddev = estPoint es
, meanStddevUB = estLowerBound es
, meanStddevLB = estUpperBound es
, confidence = ci
}
, statsSummary = ghcStats
}
return runData
-}
checkResult :: BenchmarkBundle -> ExitCode -> IO (Maybe [RunFailure])
checkResult bb exitCode = do
outputs <- mapM (checkOutput bb) (output . benchDetails $ bb)
let results = checkExit bb exitCode : outputs
errs = filter isJust results
case errs of
[] -> return $ Nothing
es -> return $ Just (catMaybes es)
checkExit :: BenchmarkBundle -> ExitCode -> Maybe RunFailure
checkExit bb actual = if actual == expected then Nothing else Just ee
where expected = expectedExit . benchDetails $ bb
ee = ExitError {exitExpected = expected, exitActual = actual}
checkOutput :: BenchmarkBundle -> OutputDescription -> IO (Maybe RunFailure)
checkOutput bb (o, Exists) = do
let f = (destinationToRealFile bb o)
e <- doesFileExist f
if e then return Nothing
else return $ Just $ MissingOutput ("File "++f++" does not exist")
checkOutput bb (o, Diff diffFile) = do
e1 <- checkOutput bb (o, Exists)
e2 <- checkOutput bb (d, Exists)
e3 <- runDiff f1 f2
return $ msum [e1, e2, e3]
where
d = OutputFile diffFile
f1 = (destinationToRealFile bb o)
f2 = (destinationToRealFile bb d)
runDiff :: FilePath -> FilePath -> IO (Maybe RunFailure)
runDiff f1 f2 = do
Log.info $ "Diffing files: "++f1++" "++f2
(r, o, _) <- readProcessWithExitCode (SysTools.diff) [f1, f2] ""
if r == ExitSuccess then Log.info "No diff error" >>
return Nothing
else Log.info "Diff error" >>
(return $ Just $ DiffError o)
destinationToRealFile :: BenchmarkBundle -> OutputDestination -> FilePath
destinationToRealFile bb (OutputFile f) = (pathToExeRunDir bb) </> f
destinationToRealFile bb Stdout = (pathToStdoutFile bb)
destinationToRealFile bb Stderr = (pathToStderrFile bb)
readExtraStats :: BenchmarkBundle -> IO ExtraStats
readExtraStats bb = do
let mbStatsFile = extraStats bb
statsFile = fromJust mbStatsFile
logReadE :: IOException -> IO ExtraStats
logReadE e =
Log.warn ("Error reading stats file: "++statsFile++"\n "++show e)
>> return B.empty
case mbStatsFile of
Nothing -> return B.empty
Just f -> do
handle logReadE $
bracket (openFile ((pathToExeRunDir bb) </> f) ReadMode)
(hClose)
(\h -> B.hGetContents h >>= \s -> B.length s `seq` return s)
--stats <- hGetContents h
-- drop header line in machine readable stats
--let body = (unlines . drop 1 . lines) stats
--case reads body of
-- [(p, _)] -> return p
-- _ -> logParseE)
type RunStepResult = IO (Either [RunFailure] RunDetail)
runDirect :: BenchmarkBundle -> IO RunResult
runDirect bb = do
mbDetails <- go count []
case mbDetails of
Left e -> return $ Failure e
Right ds -> return $ Success (summarize ds) ds
where
go 0 ds = return $ Right (reverse ds)
go n ds = do
res <- runB bb
case res of
Right d -> go (n-1) (d:ds)
Left e -> return $ Left e
runB = maybe runBenchmarkWithoutTimeout runBenchmarkWithTimeout limit
limit = timeout bb
count = (iters bb)
summarize :: [RunDetail] -> RunSummary
summarize ds = RunSummary {
meanTime = mean times
, stdDevTime = stdDev times
, statsSummary = stats
}
where
times = (Vector.fromList $ map runTime ds)
stats = case ds of (x:_) -> runStats x; _ -> B.empty
type TimeoutLength = Int
runBenchmarkWithTimeout :: TimeoutLength -> BenchmarkBundle -> RunStepResult
runBenchmarkWithTimeout us bb = do
resMVar <- newEmptyMVar
pidMVar <- newEmptyMVar
tid1 <- forkIO $ (putMVar resMVar . Just) =<< timeBenchmarkExe bb (Just pidMVar)
_ <- forkIO $ threadDelay us >> putMVar resMVar Nothing
res <- takeMVar resMVar
case res of
Nothing -> do
Log.info $ "benchmark timed out after "++(show us)++" us"
-- try to kill the subprocess
pid <- tryTakeMVar pidMVar
maybe pass terminateProcess pid
-- kill the haskell thread
killThread tid1
return $ Left [Timeout]
Just (runDetail, exitCode) -> do
maybe (Right runDetail) Left `liftM` checkResult bb exitCode
runBenchmarkWithoutTimeout :: BenchmarkBundle -> RunStepResult
runBenchmarkWithoutTimeout bb = do
(runDetail, exitCode) <- timeBenchmarkExe bb Nothing
maybe (Right runDetail) Left `liftM` checkResult bb exitCode
timeBenchmarkExe :: BenchmarkBundle -- benchmark to run
-> Maybe (MVar ProcessHandle) -- in case we need to kill it
-> IO (RunDetail, ExitCode)
timeBenchmarkExe bb pidMVar = do
p <- bundleProcessSpec bb
start <- getCurrentTime
(_, _, _, pid) <- createProcess p
maybe pass (flip putMVar pid) pidMVar
exit <- waitForProcess pid
end <- getCurrentTime
mapM_ closeStdIO [std_in p, std_out p, std_err p]
stats <- readExtraStats bb
return $ (RunDetail (realToFrac (diffUTCTime end start)) stats, exit)
closeStdIO :: StdStream -> IO ()
closeStdIO (UseHandle h) = hClose h
closeStdIO _ = return ()
pass :: IO ()
pass = return()