diff --git a/src/Weigh.hs b/src/Weigh.hs --- a/src/Weigh.hs +++ b/src/Weigh.hs @@ -26,6 +26,9 @@ (-- * Main entry points mainWith ,weighResults + -- * Configuration + ,setColumns + ,Column(..) -- * Simple combinators ,func ,io @@ -49,8 +52,9 @@ where import Control.Applicative +import Control.Arrow import Control.DeepSeq -import Control.Monad.Writer +import Control.Monad.State import Data.List import Data.List.Split import Data.Maybe @@ -59,6 +63,8 @@ import Prelude import System.Environment import System.Exit +import System.IO +import System.IO.Temp import System.Mem import System.Process import Text.Printf @@ -67,16 +73,27 @@ -------------------------------------------------------------------------------- -- Types +-- | Table column. +data Column = Case | Allocated | GCs| Live | Check | Max + deriving (Show, Eq, Enum) + +-- | Weigh configuration. +data Config = Config {configColumns :: [Column]} + deriving (Show) + -- | Weigh specification monad. newtype Weigh a = - Weigh {runWeigh :: Writer [(String,Action)] a} + Weigh {runWeigh :: State (Config, [(String,Action)]) a} deriving (Monad,Functor,Applicative) -- | How much a computation weighed in at. data Weight = Weight {weightLabel :: !String ,weightAllocatedBytes :: !Int64 - ,weightGCs :: !Int64} + ,weightGCs :: !Int64 + ,weightLiveBytes :: !Int64 + ,weightMaxBytes :: !Int64 + } deriving (Read,Show) -- | An action to run. @@ -92,10 +109,10 @@ -- | Just run the measuring and print a report. Uses 'weighResults'. mainWith :: Weigh a -> IO () mainWith m = - do results <- weighResults m + do (results, config) <- weighResults m unless (null results) (do putStrLn "" - putStrLn (report results)) + putStrLn (report config results)) case mapMaybe (\(w,r) -> do msg <- r return (w,msg)) @@ -109,23 +126,39 @@ -- | Run the measuring and return all the results, each one may have -- an error. weighResults - :: Weigh a -> IO [(Weight,Maybe String)] -weighResults m = - do args <- getArgs - let cases = execWriter (runWeigh m) - result <- weighDispatch args cases - case result of - Nothing -> return [] - Just weights -> - return (map (\w -> - case lookup (weightLabel w) cases of - Nothing -> (w,Nothing) - Just a -> (w,actionCheck a w)) - weights) + :: 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) -------------------------------------------------------------------------------- -- User DSL +-- | Default columns to display. +defaultColumns :: [Column] +defaultColumns = [Case, Allocated, GCs] + +-- | Default config. +defaultConfig :: Config +defaultConfig = Config {configColumns = defaultColumns} + +-- | Set the config. Default is: 'defaultConfig'. +setColumns :: [Column] -> Weigh () +setColumns cs = Weigh (modify (first (\c -> c {configColumns = cs}))) + -- | Weigh a function applied to an argument. -- -- Implemented in terms of 'validateFunc'. @@ -182,7 +215,7 @@ -> (Weight -> Maybe String) -- ^ A validating function, returns maybe an error. -> Weigh () validateAction name !m !arg !validate = - Weigh (tell [(name,Action (Left m) arg validate)]) + tellAction [(name,Action (Left m) arg validate)] -- | Weigh a function, validating the result validateFunc :: (NFData a) @@ -192,8 +225,12 @@ -> (Weight -> Maybe String) -- ^ A validating function, returns maybe an error. -> Weigh () validateFunc name !f !x !validate = - Weigh (tell [(name,Action (Right f) x validate)]) + tellAction [(name,Action (Right f) x validate)] +-- | Write out an action. +tellAction :: [(String, Action)] -> Weigh () +tellAction x = Weigh (modify (second ( ++ x))) + -------------------------------------------------------------------------------- -- Internal measuring actions @@ -204,19 +241,27 @@ -> IO (Maybe [Weight]) weighDispatch 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}) + ("--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) @@ -227,29 +272,37 @@ fork :: String -- ^ Label for the case. -> 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 -> - case reads out of - [(!r,_)] -> return r - _ -> - error (concat ["Malformed output from subprocess. Weigh" - ," (currently) communicates with its sub-" - ,"processes via stdout. Remove any other " - ,"output from your process."]) + 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." + ])) -- | Weigh a pure function. This function is heavily documented inside. weighFunc :: (NFData a) => (b -> a) -- ^ A function whose memory use we want to measure. -> b -- ^ Argument to the function. Doesn't have to be forced. - -> IO (Int64,Int64) -- ^ Bytes allocated and garbage collections. + -> IO (Int64,Int64,Int64,Int64) -- ^ Bytes allocated and garbage collections. weighFunc run !arg = do performGC -- The above forces getGCStats data to be generated NOW. @@ -272,14 +325,17 @@ -- return zero. It's not perfect, but this library is for -- measuring large quantities anyway. actualBytes = max 0 actionBytes - return (actualBytes,actionGCs) + liveBytes = max 0 (currentBytesUsed actionStats - + currentBytesUsed bootupStats) + maxBytes = max 0 (maxBytesUsed actionStats - maxBytesUsed bootupStats) + return (actualBytes,actionGCs,liveBytes, maxBytes) -- | Weigh a pure function. This function is heavily documented inside. weighAction :: (NFData a) => (b -> IO a) -- ^ A function whose memory use we want to measure. -> b -- ^ Argument to the function. Doesn't have to be forced. - -> IO (Int64,Int64) -- ^ Bytes allocated and garbage collections. + -> IO (Int64,Int64,Int64,Int64) -- ^ Bytes allocated and garbage collections. weighAction run !arg = do performGC -- The above forces getGCStats data to be generated NOW. @@ -302,32 +358,47 @@ -- return zero. It's not perfect, but this library is for -- measuring large quantities anyway. actualBytes = max 0 actionBytes - return (actualBytes,actionGCs) + liveBytes = max 0 (currentBytesUsed actionStats - + currentBytesUsed bootupStats) + maxBytes = max 0 (maxBytesUsed actionStats - maxBytesUsed bootupStats) + return (actualBytes,actionGCs,liveBytes, maxBytes) -------------------------------------------------------------------------------- -- Formatting functions -- | Make a report of the weights. -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 +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")] + Just {} -> "INVALID")) + ] -- | Make a table out of a list of rows. 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 + where fill (x',(left',text')) = printf ("%" ++ direction ++ show width ++ "s") text' + where direction = if left' then "-" else "" width = maximum (map (length . snd . (!! x')) xs) diff --git a/weigh.cabal b/weigh.cabal --- a/weigh.cabal +++ b/weigh.cabal @@ -1,5 +1,5 @@ name: weigh -version: 0.0.3 +version: 0.0.4 synopsis: Measure allocations of a Haskell functions/values description: Please see README.md homepage: https://github.com/fpco/weigh#readme @@ -30,6 +30,7 @@ , mtl , split , template-haskell + , temporary default-language: Haskell2010 test-suite weigh-test