module Weigh
(
mainWith
,weighResults
,setColumns
,Column(..)
,func
,io
,value
,action
,validateAction
,validateFunc
,maxAllocs
,Weigh
,Weight(..)
,commas
,weighDispatch
,weighFunc
,weighAction
)
where
import Control.Applicative
import Control.Arrow
import Control.DeepSeq
import Control.Monad.State
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.IO
import System.IO.Temp
import System.Mem
import System.Process
import Text.Printf
import Weigh.GHCStats
data Column = Case | Allocated | GCs| Live | Check | Max
deriving (Show, Eq, Enum)
data Config = Config {configColumns :: [Column]}
deriving (Show)
newtype Weigh a =
Weigh {runWeigh :: State (Config, [(String,Action)]) a}
deriving (Monad,Functor,Applicative)
data Weight =
Weight {weightLabel :: !String
,weightAllocatedBytes :: !Int64
,weightGCs :: !Int64
,weightLiveBytes :: !Int64
,weightMaxBytes :: !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 (results, config) <- weighResults m
unless (null results)
(do putStrLn ""
putStrLn (report config 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))
weighResults
:: Weigh a -> IO ([(Weight,Maybe String)], Config)
weighResults m = do
args <- getArgs
let (config, cases) =
execState (runWeigh m) (defaultConfig, [])
result <- weighDispatch args cases
case result of
Nothing -> return ([], config)
Just weights ->
return
( map
(\w ->
case lookup (weightLabel w) cases of
Nothing -> (w, Nothing)
Just a -> (w, actionCheck a w))
weights
, config)
defaultColumns :: [Column]
defaultColumns = [Case, Allocated, GCs]
defaultConfig :: Config
defaultConfig = Config {configColumns = defaultColumns}
setColumns :: [Column] -> Weigh ()
setColumns cs = Weigh (modify (first (\c -> c {configColumns = cs})))
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 =
tellAction [(name,Action (Left m) arg validate)]
validateFunc :: (NFData a)
=> String
-> (b -> a)
-> b
-> (Weight -> Maybe String)
-> Weigh ()
validateFunc name !f !x !validate =
tellAction [(name,Action (Right f) x validate)]
tellAction :: [(String, Action)] -> Weigh ()
tellAction x = Weigh (modify (second ( ++ x)))
weighDispatch :: [String]
-> [(String,Action)]
-> IO (Maybe [Weight])
weighDispatch args cases =
case args of
("--case":label:fp:_) ->
let !_ = force fp
in 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, liveBytes, maxByte) <-
case run of
Right f -> weighFunc f arg
Left m -> weighAction m arg
writeFile
fp
(show
(Weight
{ weightLabel = label
, weightAllocatedBytes = bytes
, weightGCs = gcs
, weightLiveBytes = liveBytes
, weightMaxBytes = maxByte
}))
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 =
withSystemTempFile
"weigh"
(\fp h -> do
hClose h
me <- getExecutablePath
(exit, _, err) <-
readProcessWithExitCode
me
["--case", label, fp, "+RTS", "-T", "-RTS"]
""
case exit of
ExitFailure {} ->
error ("Error in case (" ++ show label ++ "):\n " ++ err)
ExitSuccess ->
do out <- readFile fp
case reads out of
[(!r, _)] -> return r
_ ->
error
(concat
[ "Malformed output from subprocess. Weigh"
, " (currently) communicates with its sub-"
, "processes via a temporary file."
]))
weighFunc
:: (NFData a)
=> (b -> a)
-> b
-> IO (Int64,Int64,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
liveBytes = max 0 (currentBytesUsed actionStats
currentBytesUsed bootupStats)
maxBytes = max 0 (maxBytesUsed actionStats maxBytesUsed bootupStats)
return (actualBytes,actionGCs,liveBytes, maxBytes)
weighAction
:: (NFData a)
=> (b -> IO a)
-> b
-> IO (Int64,Int64,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
liveBytes = max 0 (currentBytesUsed actionStats
currentBytesUsed bootupStats)
maxBytes = max 0 (maxBytesUsed actionStats maxBytesUsed bootupStats)
return (actualBytes,actionGCs,liveBytes, maxBytes)
report :: Config -> [(Weight,Maybe String)] -> String
report config = tablize . (select headings :) . map (select . toRow)
where
select row = mapMaybe (\name -> lookup name row) (configColumns config)
headings =
[ (Case, (True, "Case"))
, (Allocated, (False, "Allocated"))
, (GCs, (False, "GCs"))
, (Live, (False, "Live"))
, (Check, (True, "Check"))
, (Max, (False, "Max"))
]
toRow (w, err) =
[ (Case, (True, weightLabel w))
, (Allocated, (False, commas (weightAllocatedBytes w)))
, (GCs, (False, commas (weightGCs w)))
, (Live, (False, commas (weightLiveBytes w)))
, (Max, (False, commas (weightMaxBytes w)))
, ( Check
, ( 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