{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE BangPatterns #-}
module Weigh
(
mainWith
,weighResults
,setColumns
,Column(..)
,func
,io
,value
,action
,wgroup
,validateAction
,validateFunc
,maxAllocs
,Weigh
,Weight(..)
,commas
,weighDispatch
,weighFunc
,weighAction
)
where
import Control.Applicative
import Control.Arrow
import Control.DeepSeq
import Control.Monad.State
import qualified Data.Foldable as Foldable
import qualified Data.Traversable as Traversable
import Data.Int
import qualified Data.List as List
import Data.List.Split
import Data.Maybe
import GHC.Generics
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 qualified Weigh.GHCStats as GHCStats
data Column = Case | Allocated | GCs| Live | Check | Max
deriving (Show, Eq, Enum)
data Config = Config
{ configColumns :: [Column]
, configPrefix :: String
} deriving (Show)
newtype Weigh a =
Weigh {runWeigh :: State (Config, [Grouped Action]) a}
deriving (Monad,Functor,Applicative)
data Weight =
Weight {weightLabel :: !String
,weightAllocatedBytes :: !Int64
,weightGCs :: !Int64
,weightLiveBytes :: !Int64
,weightMaxBytes :: !Int64
}
deriving (Read,Show)
data Grouped a
= Grouped String [Grouped a]
| Singleton String a
deriving (Eq, Show, Functor, Traversable.Traversable, Foldable.Foldable, Generic)
instance NFData a => NFData (Grouped a)
data Action =
forall a b. (NFData a) =>
Action {_actionRun :: !(Either (b -> IO a) (b -> a))
,_actionArg :: !b
,actionName :: !String
,actionCheck :: Weight -> Maybe String}
instance NFData Action where rnf _ = ()
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))
(concatMap Foldable.toList (Foldable.toList results)) of
[] -> return ()
errors -> do
putStrLn "\nCheck problems:"
mapM_
(\(w, r) -> putStrLn (" " ++ weightLabel w ++ "\n " ++ r))
errors
exitWith (ExitFailure (-1))
weighResults
:: Weigh a -> IO ([Grouped (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
( fmap
(fmap
(\w ->
case glookup (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, configPrefix = ""}
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 name validate)
validateFunc :: (NFData a)
=> String
-> (b -> a)
-> b
-> (Weight -> Maybe String)
-> Weigh ()
validateFunc name !f !x !validate =
tellAction name (Action (Right f) x name validate)
tellAction :: String -> Action -> Weigh ()
tellAction name act =
Weigh (do prefix <- gets (configPrefix . fst)
modify (second (\x -> x ++ [Singleton (prefix ++ "/" ++ name) act])))
wgroup :: String -> Weigh () -> Weigh ()
wgroup str wei = do
(orig, start) <- Weigh get
let startL = length $ start
Weigh (modify (first (\c -> c {configPrefix = configPrefix orig ++ "/" ++ str})))
wei
Weigh $ do
modify $ second $ \x -> take startL x ++ [Grouped str $ drop startL x]
modify (first (\c -> c {configPrefix = configPrefix orig}))
weighDispatch :: [String]
-> [Grouped Action]
-> IO (Maybe [(Grouped Weight)])
weighDispatch args cases =
case args of
("--case":label:fp:_) ->
let !_ = force fp
in case glookup label (force 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
_ -> fmap Just (Traversable.traverse (Traversable.traverse fork) cases)
glookup :: String -> [Grouped Action] -> Maybe Action
glookup label =
Foldable.find ((== label) . actionName) .
concat . map Foldable.toList . Foldable.toList
fork :: Action
-> IO Weight
fork act =
withSystemTempFile
"weigh"
(\fp h -> do
hClose h
me <- getExecutablePath
(exit, _, err) <-
readProcessWithExitCode
me
["--case", actionName act, fp, "+RTS", "-T", "-RTS"]
""
case exit of
ExitFailure {} ->
error
("Error in case (" ++ show (actionName act) ++ "):\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
ghcStatsSizeInBytes <- GHCStats.getGhcStatsSizeInBytes
performGC
!bootupStats <- GHCStats.getStats
let !_ = force (run arg)
performGC
!actionStats <- GHCStats.getStats
let reflectionGCs = 1
actionBytes =
(GHCStats.totalBytesAllocated actionStats -
GHCStats.totalBytesAllocated bootupStats) -
fromIntegral ghcStatsSizeInBytes
actionGCs =
GHCStats.gcCount actionStats - GHCStats.gcCount bootupStats -
reflectionGCs
actualBytes = max 0 actionBytes
liveBytes =
max 0 (GHCStats.liveBytes actionStats - GHCStats.liveBytes bootupStats)
maxBytes =
max
0
(GHCStats.maxBytesInUse actionStats -
GHCStats.maxBytesInUse bootupStats)
return
( fromIntegral actualBytes
, fromIntegral actionGCs
, fromIntegral liveBytes
, fromIntegral maxBytes)
weighAction
:: (NFData a)
=> (b -> IO a)
-> b
-> IO (Int64,Int64,Int64,Int64)
weighAction run !arg = do
ghcStatsSizeInBytes <- GHCStats.getGhcStatsSizeInBytes
performGC
!bootupStats <- GHCStats.getStats
!_ <- fmap force (run arg)
performGC
!actionStats <- GHCStats.getStats
let reflectionGCs = 1
actionBytes =
(GHCStats.totalBytesAllocated actionStats -
GHCStats.totalBytesAllocated bootupStats) -
fromIntegral ghcStatsSizeInBytes
actionGCs =
GHCStats.gcCount actionStats - GHCStats.gcCount bootupStats -
reflectionGCs
actualBytes = max 0 actionBytes
liveBytes =
max 0 (GHCStats.liveBytes actionStats - GHCStats.liveBytes bootupStats)
maxBytes =
max
0
(GHCStats.maxBytesInUse actionStats -
GHCStats.maxBytesInUse bootupStats)
return
( fromIntegral actualBytes
, fromIntegral actionGCs
, fromIntegral liveBytes
, fromIntegral maxBytes)
report :: Config -> [Grouped (Weight,Maybe String)] -> String
report config gs =
List.intercalate
"\n\n"
(filter
(not . null)
[ if null singletons
then []
else reportTabular config singletons
, List.intercalate "\n\n" (map (uncurry (reportGroup config)) groups)
])
where
singletons =
mapMaybe
(\case
Singleton _ v -> Just v
_ -> Nothing)
gs
groups =
mapMaybe
(\case
Grouped title vs -> Just (title, vs)
_ -> Nothing)
gs
reportGroup :: Config -> [Char] -> [Grouped (Weight, Maybe String)] -> [Char]
reportGroup config title gs = title ++ "\n\n" ++ indent (report config gs)
reportTabular :: Config -> [(Weight,Maybe String)] -> String
reportTabular config = tabled
where
tabled = tablize . (select headings :) . map (select . toRow)
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 =
List.intercalate "\n"
(map (List.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 . List.intercalate "," . chunksOf 3 . reverse . show
indent :: [Char] -> [Char]
indent = List.intercalate "\n" . map (replicate 2 ' '++) . lines