{-# OPTIONS -fglasgow-exts #-} -- Driver for testing out register allocator performance. -- Run this from the root of the nofib suite -- It will run the tests writing the results to a file "spill-report" in the current directory. -- Results are appended to spill-report incrementally, so you can tail it as checkSpills runs -- to see the results so far. -- -- Each benchmark run with each of the allocators, linear, graph, iterative while counting -- spills/realoads added and reg-reg moves remaining in code. -- -- Gathering spill stats can cause the compiler hold on to intermediate structures -- and thus use much more space than it would otherwise, especially when doing -- graph allocation. For this reason we compile again without stat gathering when checking -- compile times. -- import System import System.Directory import System.Posix.Process import Text.Regex import Control.Monad import Data.Maybe import Data.List ---------- debug = True ----------- -- | spills, clobbers, reloads, joins reg-reg, joins reg-mem, reg-reg-moves remaining in code type StatsLinear = (Int, Int, Int, Int, Int, Int) -- | spills, reloads, reg-reg-moves remaining in code type StatsGraph = (Int, Int, Int) -- | test results for one module type TestResult = ( String -- module name , StatsLinear , Float -- compile time with linear allocator , StatsGraph , Float -- compile time with graph coloring allocator , StatsGraph , Float) -- compile time with graph coloring allocator + iterative coalescing ----- main :: IO () main = do testsArg <- getArgs dirBase <- getCurrentDirectory let fileReport = dirBase ++ "/checkSpills.report" let fileWork = dirBase ++ "/checkSpills.tests" -- If there is a test list then read add that to the list of test to do exists <- doesFileExist fileWork testsFile <- if exists then do file <- readFile fileWork let fileLines = filter (/= "") $ lines file return fileLines else return [] -- run all the tests the tests let tests = if null testsArg then testsFile else testsArg stats <- mapM (doTest fileReport) tests -- total up al the stats appendFile fileReport ("\n\n" ++ (makeReportLine $ makeTotal stats)) return () -- Run the tests on the program in this dir -- doTest :: FilePath -- ^ file to append test results to -> FilePath -- ^ dir of nofib benchmark -> IO ( FilePath -- dir of nofib benchmark , [TestResult]) -- results for each module in the program doTest fileReport dirTest = do putStr $ "* Test " ++ dirTest ++ "\n" dirOld <- getCurrentDirectory -- change to test dir setCurrentDirectory dirTest -- run the test cmd "make boot" -- build with linear / graph / iterative allocator (statsLinear, timesLinear) <- doTestRun "" slurpSpillStatsLinear (statsGraph, timesGraph) <- doTestRun "-fregs-graph" slurpSpillStatsGraph (statsIter, timesIter) <- doTestRun "-fregs-iterative" slurpSpillStatsGraph -- builds stats let stats = map (collateResults timesLinear statsGraph timesGraph statsIter timesIter) statsLinear let out = (dirTest, stats) putStr $ makeSection out appendFile fileReport $ makeSection out -- change back to old dir setCurrentDirectory dirOld return out -- For some reason make doesn't always build the modules in the same order, so we can't -- do a simple zip here. It's all a bit tiring, really. collateResults :: [(String, Float)] -> [(String, StatsGraph)] -> [(String, Float)] -> [(String, StatsGraph)] -> [(String, Float)] -> (String, StatsLinear) -> (String, StatsLinear, Float, StatsGraph, Float, StatsGraph, Float) collateResults lTimes gStats gTimes iStats iTimes (name, lStat) | Just lTime <- lookup name lTimes , Just gStat <- lookup name gStats , Just gTime <- lookup name gTimes , Just iStat <- lookup name iStats , Just iTime <- lookup name iTimes = (name, lStat, lTime, gStat, gTime, iStat, iTime) doTestRun :: String -- ^ flag to use -> (String -> IO stats) -- ^ fn to extract stats from dropped -dump-asm-stats file -> IO ( [(String, stats)] , [(String, Float)] ) doTestRun flag slurpStats = do -- build with the requested flag cleanDumps cmd $ "make clean" cmd $ "make EXTRA_HC_OPTS=\"-Wnot -O2 -fasm -ddump-to-file -ddump-asm-stats " ++ flag ++ " \"" statFiles <- getStatFiles stats <- mapM slurpStats statFiles let moduleNames = map slurpModuleName statFiles -- build again without dumping to get the compile time. -- turning on dumping can make the compiler use much more space than it usually would. -- so we wan't to run it again without to get a true compile time. cleanDumps cmd "make clean" Just (out, err) <- cmdOE $ "make EXTRA_HC_OPTS=\"-Wnot -O2 -fasm " ++ flag ++ " \"" let compileTimes = slurpCompileTimes (lines out) return ( zip moduleNames stats , compileTimes ) -- Slurp out the compile times for each module from the nofib dump slurpCompileTimes :: [String] -> [(String, Float)] slurpCompileTimes (l0:l1:l2:l3:ls) | Just [modName] <- matchRegex (mkRegex "==nofib== .* time to compile (.*) follows") l0 , Just [min,sec,hsec] <- matchRegex (mkRegex " ([^ ]*):(.*)\\.(.*)elapsed") l3 = ( modName , read min * 60 + read sec + read hsec / 100) : slurpCompileTimes ls | otherwise = slurpCompileTimes (l1:l2:l3:ls) slurpCompileTimes _ = [] makeTotal :: [(FilePath, [TestResult])] -> TestResult makeTotal ts = let results = concat $ map snd ts total = foldr addTestResults (zeroTestResult "TOTAL") results in total makeSection :: (FilePath, [TestResult]) -> String makeSection (testName, stats) = "* " ++ testName ++ "\n" ++ (concat $ map makeReportLine stats) ++ "\n" makeReportLine :: TestResult -> String makeReportLine ( name , statsLinear @(ls, lc, lr, _, _, lm) , timeLinear , statsGraph @(gs, gr, gm) , timeGraph , statsIterative @(is, ir, im) , timeIterative) = padL 30 name ++ " " ++ padL 20 (show statsLinear) ++ " ~ " ++ padL 15 (show (ls + lc, lr, lm)) ++ " " ++ padL 5 (fmtFloat timeLinear) ++ " " ++ (score statsLinear statsGraph) ++ " " ++ padL 15 (show statsGraph) ++ " " ++ padL 5 (fmtFloat timeGraph) ++ " " ++ (score statsLinear statsIterative) ++ " " ++ padL 15 (show statsIterative) ++ " " ++ padL 5 (fmtFloat timeIterative) ++ "\n" fmtFloat :: Float -> String fmtFloat f = let str = show f first = takeWhile (/= '.') str rest = drop (length first) str in first ++ take 3 rest score :: StatsLinear -> StatsGraph -> String score (ls, lc, lr, _, _, lm) (gs, gr, gm) -- exact same score | ls + lc == gs , lr == gr , lm == gm = "-----" -- Outright success | gMem < lMem || gReg < lReg , gMem <= lMem -- allow ourselves 2 extra reg-reg moves for each mem op saved -- one to shift out and 1 to shift back in. , lessMem <- lMem - gMem , gReg <= (lReg + 2 * lessMem) = " WIN " -- same total spills/reloads/moves | gMem <= lMem , gReg <= lReg = " OK " -- no good | otherwise = "LOSE " where gMem = gs + gr gReg = gm lMem = ls + lc + lr lReg = lm padL n s = s ++ replicate (n - length s) ' ' getStatFiles :: IO [FilePath] getStatFiles = do files <- getDirectoryContents "." let statFiles = filter (match "dump-asm-stats") files return statFiles cleanDumps :: IO () cleanDumps = do files <- getDirectoryContents "." let junkFiles = filter (match "dump") files mapM_ removeFile junkFiles ---- TestResult addTestResults :: TestResult -> TestResult -> TestResult addTestResults (n1, ls1, lt1, gs1, gt1, is1, it1) (n2, ls2, lt2, gs2, gt2, is2, it2) = ( n2 , addStatsLinear ls1 ls2, lt1 + lt2 , addStatsGraph gs1 gs2, gt1 + gt2 , addStatsGraph is1 is2, it1 + it2) zeroTestResult :: String -> TestResult zeroTestResult name = ( name , (0, 0, 0, 0, 0, 0) , 0 , (0, 0, 0) , 0 , (0, 0, 0) , 0) ----- -- at the moment the spill stats are always on line 3.. -- spills, loads, moves slurpSpillStatsGraph :: FilePath -> IO StatsGraph slurpSpillStatsGraph fileName = do str <- readFile fileName return $ read $ lines str !! 2 addStatsGraph :: StatsGraph -> StatsGraph -> StatsGraph addStatsGraph (a1, a2, a3) (b1, b2, b3) = (a1 + b1, a2 + b2, a3 + b3) -- spills, clobbers, reloads, ? ?, moves slurpSpillStatsLinear :: FilePath -> IO StatsLinear slurpSpillStatsLinear fileName = do str <- readFile fileName return $ read $ lines str !! 2 addStatsLinear :: StatsLinear -> StatsLinear -> StatsLinear addStatsLinear (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6) slurpModuleName :: FilePath -> String slurpModuleName fileName = takeWhile (/= '.') fileName match :: String -> String -> Bool match regex str = isJust $ matchRegex (mkRegex regex) str --------------------------------------------------------------------------- -- Command handling -- -- scan the output for error messages -- we use this instead of just checking the return code because it -- gets clobbered by the call to tee when debugging is on. hasErrors :: String -> Bool hasErrors str | match "expected stdout not matched by reality" str = True | match "make .* Error" str = True | otherwise = False -- | Run a system command, peeling off stderr and stdout -- cmdOE :: String -- command to run -> IO (Maybe (String, String)) -- exitcode, stdout, stderr cmdOE str = do (code, out, err) <- cmdCode str case code of ExitSuccess -> return $ Just (out, err) ExitFailure n -> return Nothing -- | Run a command, expecting it to succeed cmd :: String -> IO () cmd str = do (code, out, err) <- cmdCode str if (hasErrors out || hasErrors err || code /= ExitSuccess) then error "checkSpills: command failed" else return () -- | Do a command cmdCode :: String -- command to run -> IO (ExitCode, String, String) -- exitcode, stdout, stderr cmdCode str = do when debug $ do putStr $ "DEBUG cmdCode: " ++ str ++ "\n" pid <- getProcessID let fileStdout = "/tmp/" ++ show pid ++ ".stdout" let fileStderr = "/tmp/" ++ show pid ++ ".stderr" code <- if debug then system (str ++ " | tee " ++ fileStdout ++ " 2>&1") else system (str ++ " | tee " ++ fileStdout ++ " > /dev/null") outStd <- readFile fileStdout -- outErr <- readFile fileStderr removeFile fileStdout -- removeFile fileStderr when debug $ putStr "\n" return (code, outStd, "")