module Weigh
(
mainWith
,Weigh
,Weight(..)
,action
,func
,value
,validateAction
,validateFunc
,maxAllocs
,commas)
where
import Control.Applicative
import Control.DeepSeq
import Control.Monad.Writer
import Data.List
import Data.List.Split
import Data.Maybe
import GHC.Int
import GHC.Stats
import Prelude
import System.Environment
import System.Exit
import System.Mem
import System.Process
import Text.Printf
import Weigh.GHCStats
newtype Weigh a =
Weigh {runWeigh :: Writer [(String,Action)] a}
deriving (Monad,Functor,Applicative)
data Weight =
Weight {weightLabel :: !String
,weightAllocatedBytes :: !Int64
,weightGCs :: !Int64}
deriving (Read,Show)
data Action =
forall a b. (NFData a) =>
Action {_actionRun :: !(b -> IO a)
,_actionArg :: !b
,actionCheck :: Weight -> Maybe String}
mainWith :: Weigh a -> IO ()
mainWith m =
do args <- getArgs
let cases = execWriter (runWeigh m)
result <- weigh args cases
case result of
Nothing -> return ()
Just weights ->
do let results =
map (\w ->
case lookup (weightLabel w) cases of
Nothing -> (w,Nothing)
Just a -> (w,actionCheck a w))
weights
putStrLn ""
putStrLn (report results)
case mapMaybe (\(w,r) ->
do msg <- r
return (w,msg))
results of
[] -> return ()
errors ->
do putStrLn "\nCheck problems:"
mapM_ (\(w,r) ->
putStrLn (" " ++ weightLabel w ++ "\n " ++ r))
errors
exitWith (ExitFailure (1))
func :: (NFData a) => String -> (b -> a) -> b -> Weigh ()
func name !f !x = validateFunc name f x (const Nothing)
value :: NFData a => String -> a -> Weigh ()
value name !v = action name (return v)
action :: NFData a
=> String -> IO a -> Weigh ()
action name !m =
validateAction name
(const m)
()
(const Nothing)
maxAllocs :: Int64 -> (Weight -> Maybe String)
maxAllocs n =
\w ->
if weightAllocatedBytes w > n
then Just ("Allocated bytes exceeds " ++
commas n ++ ": " ++ commas (weightAllocatedBytes w))
else Nothing
validateAction
:: (NFData a)
=> String -> (b -> IO a) -> b -> (Weight -> Maybe String) -> Weigh ()
validateAction name !m !arg !validate =
Weigh (tell [(name,Action m arg validate)])
validateFunc
:: (NFData a)
=> String -> (b -> a) -> b -> (Weight -> Maybe String) -> Weigh ()
validateFunc name !f !x !validate =
Weigh (tell [(name,Action (return . f) x validate)])
weigh :: [String] -> [(String,Action)] -> IO (Maybe [Weight])
weigh args cases =
case args of
("--case":label:_) ->
case lookup label (deepseq (map fst cases) cases) of
Nothing -> error "No such case!"
Just act ->
do case act of
Action !run arg _ ->
do (bytes,gcs) <- weighAction run arg
print (Weight {weightLabel = label
,weightAllocatedBytes = bytes
,weightGCs = gcs})
return Nothing
_
| names == nub names -> fmap Just (mapM (fork . fst) cases)
| otherwise -> error "Non-unique names specified for things to measure."
where names = map fst cases
fork :: String
-> IO Weight
fork label =
do me <- getExecutablePath
(exit,out,err) <-
readProcessWithExitCode me
["--case",label,"+RTS","-T","-RTS"]
""
case exit of
ExitFailure{} -> error ("Error in case (" ++ show label ++ "):\n " ++ err)
ExitSuccess ->
let !r = read out
in return r
weighAction
:: (NFData a)
=> (b -> IO a)
-> b
-> IO (Int64,Int64)
weighAction !run !arg =
do performGC
!bootupStats <- getGCStats
!_ <- fmap force (run arg)
performGC
!actionStats <- getGCStats
let reflectionGCs = 1
actionBytes =
(bytesAllocated actionStats bytesAllocated bootupStats)
ghcStatsSizeInBytes
actionGCs = numGcs actionStats numGcs bootupStats reflectionGCs
overheadBytes = 24
actualBytes = max 0 (actionBytes overheadBytes)
return (actualBytes,actionGCs)
report :: [(Weight,Maybe String)] -> String
report =
tablize .
([(True,"Case"),(False,"Bytes"),(False,"GCs"),(True,"Check")] :) . map toRow
where toRow (w,err) =
[(True,weightLabel w)
,(False,commas (weightAllocatedBytes w))
,(False,commas (weightGCs w))
,(True
,case err of
Nothing -> "OK"
Just{} -> "INVALID")]
tablize :: [[(Bool,String)]] -> String
tablize xs =
intercalate "\n"
(map (intercalate " " . map fill . zip [0 ..]) xs)
where fill (x',(left,text')) = printf ("%" ++ direction ++ show width ++ "s") text'
where direction = if left
then "-"
else ""
width = maximum (map (length . snd . (!! x')) xs)
commas :: (Num a,Integral a,Show a) => a -> String
commas = reverse . intercalate "," . chunksOf 3 . reverse . show