Commentary/Compiler/Backends/NCG/RegisterAllocator: checkSpills.hs

{-# 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, "")