module Weigh
(
mainWith
,Weigh
,Weight(..)
,func
,io
,value
,action
,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 :: !(Either (b -> IO a) (b -> 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)
io :: (NFData a) => String -> (b -> IO a) -> b -> Weigh ()
io name !f !x = validateAction name f x (const Nothing)
value :: NFData a => String -> a -> Weigh ()
value name !v = func name id v
action :: NFData a
=> String -> IO a -> Weigh ()
action name !m = io name (const m) ()
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 (Left m) arg validate)])
validateFunc
:: (NFData a)
=> String -> (b -> a) -> b -> (Weight -> Maybe String) -> Weigh ()
validateFunc name !f !x !validate =
Weigh (tell [(name,Action (Right 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) <-
case run of
Right f -> weighFunc f arg
Left m -> weighAction m 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
weighFunc
:: (NFData a)
=> (b -> a)
-> b
-> IO (Int64,Int64)
weighFunc run !arg =
do performGC
!bootupStats <- getGCStats
let !_ = force (run arg)
performGC
!actionStats <- getGCStats
let reflectionGCs = 1
actionBytes =
(bytesAllocated actionStats bytesAllocated bootupStats)
ghcStatsSizeInBytes
actionGCs = numGcs actionStats numGcs bootupStats reflectionGCs
actualBytes = max 0 actionBytes
return (actualBytes,actionGCs)
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
actualBytes = max 0 actionBytes
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