{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} -------------------------------------------------------------------- -- | -- Module : ghc-gc-tune -- Copyright : (c) Don Stewart, 2010 -- License : BSD3 -- -- Maintainer: Don Stewart -- Stability : provisional -- Portability: Needs a few libraries from hackage. -- -------------------------------------------------------------------- -- -- Graph the performance of a Haskell program as GC settings change. -- -- Examples: -- -- > ghc-gc-tune a.out -- ------------------------------------------------------------------------ import System.IO import System.Exit import System.Environment import System.Directory import System.Console.GetOpt import Data.List import Data.Char import Data.Int import Data.Function import Data.Ord import Control.Monad import Control.Concurrent import Text.Printf import System.Process hiding (readProcess) import qualified Control.OldException as C import System.FilePath {- -- import Graphics.Gnuplot.Simple import Control.OldException import Data.List import Data.Maybe import System.Directory -} ------------------------------------------------------------------------ {- Goals: * Use criterion to time the computation * ADT for flags. * Collect 3D values. -H -A time * Render to gnuplot -} ------------------------------------------------------------------------ -- -- Command line parsing -- data Options = Options { optHelp :: Bool , optType :: Maybe String , optMin :: !Int64 , optMax :: !Int64 } deriving (Eq, Show) defaultOptions :: Options defaultOptions = Options { optHelp = False , optType = Nothing , optMin = k 8 -- TODO stub support for range , optMax = g 2 } options :: [OptDescr (Options -> Options)] options = [ Option ['h'] ["help"] (NoArg (\opts -> opts { optHelp = True })) "Print this help message." , Option ['t'] ["type"] (ReqArg (\x opts -> opts { optType = Just x }) "TYPE") "Output type: pdf, png, svg." ] parseOptions :: [String] -> IO (Options, [String]) parseOptions argv = case getOpt RequireOrder options argv of (o, n, []) -> let o' = foldl (flip ($)) defaultOptions o in if optHelp o' then do hPutStr stderr (usageInfo header options) exitWith ExitSuccess else return (o', n) (_, _, es) -> ioError (userError (concat es ++ usageInfo header options)) header :: String header = "Usage: ghc-gc-tune [OPTS...] executable [PROG_ARGS...] [GHC_RTS_OPTION...]" ------------------------------------------------------------------------ -- -- | A data type to represent the output of +RTS -t --machine-readable -- -- -- -- * The peak memory the RTS has allocated from the OS. -- * The amount of CPU time and elapsed wall clock time -- data GCStats = GCStats { numberOfGCs :: !Int64 -- ^ total number of GCs ,peakMemory :: !Int64 -- ^ peak memory allocated ,mutatorTime :: !Double -- ^ wall clock mutator time ,gcTime :: !Double -- ^ wall clock GC time ,totalTime :: !Double -- ^ sum of init, exit, gc, mutator } deriving Show parse :: String -> GCStats parse s = case maybeRead s of Nothing -> error $ "Can't parse GC stats: " ++ show s Just (assocs :: [(String,String)]) -> let mgc = do numberOfGCs <- fmap read $ lookup "num_GCs" assocs peakMemory <- fmap read $ lookup "peak_megabytes_allocated" assocs mutatorTime <- fmap read $ lookup "mutator_wall_seconds" assocs gcTime <- fmap read $ lookup "GC_wall_seconds" assocs return GCStats { totalTime = mutatorTime + gcTime , .. } -- ^ record pun. in case mgc of Nothing -> error $ "Missing fields in GC stats: " ++ show s Just gc -> gc where maybeRead z = case reads z of [(x, s')] | all isSpace s' -> Just x _ -> Nothing ------------------------------------------------------------------------ -- Data type for controlling the GC. data GCHooks = GCHooks { -- | Set the allocation area size used by the garbage collector. The -- allocation area (actually generation 0 step 0) is fixed and is -- never resized (unless you use -H, below). sizeA :: !Int64 -- | This option provides a “suggested heap size” for the garbage -- collector. The garbage collector will use about this much memory -- until the program residency grows and the heap size needs to be -- expanded to retain reasonable performance. , sizeH :: !Int64 } deriving Show k,m,g :: Int64 -> Int64 k x = x * 1024 m x = k x * 1024 g x = m x * 1024 -- -- static defaults for various A and H sizes. Need an algorithm to determine these -- based on available memory, L2 cache size, and application's default maximum heap -- series :: [Int64] series = [ k 8 , k 16 , k 32 , k 64 , k 128 , k 256 , k 512 , m 1 , m 2 , m 4 , m 8 , m 16 , m 32 , m 64 , m 128 , m 256 , m 512 , g 1 , g 2 ] tuningSpace :: [GCHooks] tuningSpace = [ GCHooks a h | a <- series , h <- series ] ------------------------------------------------------------------------ main :: IO () main = do -- Parse command line (opts, args') <- getArgs >>= parseOptions (exe,args) <- case args' of [] -> ioError (userError (usageInfo header options)) (x:xs) -> return (x,xs) -- Now traverse the space stats <- forM tuningSpace $ \hooks -> do s <- runGHCProgram exe args hooks case s of Just y -> printf "\t<>\n" (numberOfGCs y) (peakMemory y) (mutatorTime y) (gcTime y) Nothing -> return () return (hooks, s) -- Best settings observed let (bestA, bestH, bestT) = minimumBy (comparing thd3) [ (sizeA gs, sizeH gs, totalTime r) | (gs,Just r) <- stats ] printf "Best settings (%.2fs): +RTS -A%d -H%d\n" bestT bestA bestH -- TODO graph Z as time or space. -- x is A, y is H, z is total time let space = groupBy ((==) `on` fst3) [ (sizeA gs, sizeH gs, totalTime r) | (gs,Just r) <- stats ] C.bracket (openTempFile "/tmp" "ghc-gc-tune-XXXX.dat") (\(f,_) -> removeFile f) $ \(f,h) -> do -- generate the data file hPutStr h $ concatMap (\s -> case s of [] -> "\n" -- blank line between Y lines xs -> unlines $ map (\(x,y,z) -> intercalate " " [show x, show y, show z]) xs ) (intersperse [] space) hFlush h >> hClose h -- construct the gp script let script = plot3d f exe (optType opts) writeFile "/tmp/script" script -- get a handle to the gnuplot process (ih,_,eh,pid) <- C.handle (\e -> error $ "Couldn't fork gnuplot: " ++ show e) (do mgnu <- findExecutable "gnuplot" case mgnu of Nothing -> error "Cannot find gnuplot" Just gnuplot -> runInteractiveCommand gnuplot) -- print script into gnuplot hPutStrLn ih script -- >> hClose ih -- write into gnuplot hFlush ih -- If interactive, tell them to use ^C^C to kill case optType opts of Nothing -> do putStrLn "Rendering ... type q and ^C^C to exit interactive mode" -- interactive keep it open. hGetContents eh >>= putStr -- dump any error output it produces waitForProcess pid return () Just t -> do putStrLn $ "Output written to : " ++ outputFile exe t hClose ih hGetContents eh >>= putStr -- dump any error output it produces waitForProcess pid return () -- Work out the output file from the source name and the file type outputFile :: FilePath -> String -> FilePath outputFile f ty = "/tmp/" ++ takeFileName f ++"-gc-space." ++ ty ------------------------------------------------------------------------ -- 3d plot plot3d :: FilePath -> FilePath -> Maybe String -> String plot3d datFile srcFile mty = script where script = unlines [ "set logscale xy" , "set title \"Running time of " ++ takeFileName srcFile ++ " as a function of GC -A and -H values\"" , "set pm3d at b" , "set xlabel \"-A (default allocation area)\"" , "set ylabel \"-H (suggested heap)\"" , "set zlabel \"Running time (seconds)\" rotate by 90" , "unset key" , "set xtics (\"16k\" 16384 ,\"64k\" 65536 ,\"256k\" 262144 ,\"1M\" 1048576 ,\"4M\" 4194304 ,\"16M\" 16777216 , \"64M\" 67108864, \"256M\" 268435456 ,\"1G\" 1073741824)" , "set ytics (\"16k\" 16384 ,\"64k\" 65536 ,\"256k\" 262144 ,\"1M\" 1048576 ,\"4M\" 4194304 ,\"16M\" 16777216 , \"64M\" 67108864, \"256M\" 268435456 ,\"1G\" 1073741824)" , case mty of Nothing -> "#" -- interactive Just "png" -> unlines ["set terminal pngcairo enhanced font \"Arial,8\"" ,"set output \"" ++ outputFile srcFile "png" ++ "\""] Just "pdf" -> unlines ["set terminal pdfcairo enhanced font \"Arial,8\"" ,"set output \"" ++ outputFile srcFile "pdf" ++ "\""] Just "svg" -> unlines ["set terminal svg dynamic enhanced" ,"set output \"" ++ outputFile srcFile "svg" ++ "\""] Just _ -> "#" , "splot \"" ++ datFile ++ "\" with lines" ] ------------------------------------------------------------------------ -- -- Run a GHC-compiled program with -t --machine-readable, passing -- any user supplied args and RTS flags through as well. -- -- The program needs to run to completion with a successful exit code. -- If the user passes +RTS flags they'll need to add -RTS so we don't -- clobber them. Perhaps filter for this. -- runGHCProgram :: FilePath -> [String] -> GCHooks -> IO (Maybe GCStats) runGHCProgram exe opts gcflags = do printf "%s %s\n" exe (intercalate " " $ opts ++ tuningargs) x <- readProcessStderr exe (opts ++ rtsargs ++ tuningargs) [] case x of Left (err,str,std) -> do mapM_ putStrLn (lines str) mapM_ putStrLn (lines std) printf "Executable failed with error %s\n" (show err) return Nothing -- drop "test/binary-trees 16 +RTS -t --machine-readable \n " Right str -> return $! Just $! parse (unlines . drop 1 . lines $ str) where rtsargs = words "+RTS -t --machine-readable -RTS" tuningargs = ["+RTS" ,"-A" ++ show (sizeA gcflags) ,"-H" ++ show (sizeH gcflags) ,"-RTS" ] -- -- Strict process reading (we only care about stderr) -- readProcessStderr :: FilePath -- ^ command to run -> [String] -- ^ any arguments -> String -- ^ standard input -> IO (Either (ExitCode,String,String) String) -- ^ either the stderr, or an exitcode and any output readProcessStderr cmd args input = C.handle (return . handler) $ do (inh,outh,errh,pid) <- runInteractiveProcess cmd args Nothing Nothing output <- hGetContents outh outMVar <- newEmptyMVar _ <- forkIO $ (C.evaluate (length output) >> putMVar outMVar ()) errput <- hGetContents errh errMVar <- newEmptyMVar _ <- forkIO $ (C.evaluate (length errput) >> putMVar errMVar ()) when (not (null input)) $ hPutStr inh input takeMVar outMVar takeMVar errMVar ex <- C.catch (waitForProcess pid) (\_e -> return ExitSuccess) hClose outh hClose inh hClose errh return $ case ex of ExitSuccess -> Right errput ExitFailure _ -> Left (ex, errput, output) where handler (C.ExitException e) = Left (e,"","") handler e = Left (ExitFailure 1, show e, "") {- -- Safe wrapper for getEnv getEnvMaybe :: String -> IO (Maybe String) getEnvMaybe name = handle (const $ return Nothing) (Just `fmap` getEnv name) -} fst3 :: (a,b,c) -> a fst3 (x,_,_) = x thd3 :: (a,b,c) -> c thd3 (_,_,z) = z