weigh (empty) → 0.0.0
raw patch · 8 files changed
+574/−0 lines, 8 filesdep +basedep +bytestring-triedep +containerssetup-changed
Dependencies added: base, bytestring-trie, containers, deepseq, mtl, process, random, split, template-haskell, unordered-containers, weigh
Files
- LICENSE +30/−0
- README.md +60/−0
- Setup.hs +2/−0
- src/Weigh.hs +249/−0
- src/Weigh/GHCStats.hs +48/−0
- src/test/Main.hs +79/−0
- src/test/Maps.hs +48/−0
- weigh.cabal +58/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Chris Done (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Chris Done nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,60 @@+# weigh [](https://travis-ci.org/fpco/weigh)++Measures the memory usage of a Haskell value or function++## Example use++``` haskell+import Weigh++-- | Weigh integers.+main :: IO ()+main =+ mainWith (do integers+ ints)++-- | Just counting integers.+integers :: Weigh ()+integers =+ do func "integers count 0" count 0+ func "integers count 1" count 1+ func "integers count 2" count 2+ func "integers count 3" count 3+ func "integers count 10" count 10+ func "integers count 100" count 100+ where count :: Integer -> ()+ count 0 = ()+ count a = count (a - 1)++-- | We count ints and ensure that the allocations are optimized away+-- to only two 64-bit Ints (16 bytes).+ints :: Weigh ()+ints =+ do validateFunc "ints count 1" count 1 (maxAllocs 24)+ validateFunc "ints count 10" count 10 (maxAllocs 24)+ validateFunc "ints count 1000000" count 1000000 (maxAllocs 24)+ where count :: Int -> ()+ count 0 = ()+ count a = count (a - 1)+```++Output results:++```+Case Bytes GCs Check+integers count 0 0 0 OK+integers count 1 32 0 OK+integers count 2 64 0 OK+integers count 3 96 0 OK+integers count 10 320 0 OK+integers count 100 3,200 0 OK+ints count 1 0 0 OK+ints count 10 0 0 OK+ints count 1000000 0 0 OK+```++You can try this out with `stack test` in the `weight` directory.++To try out other examples, try:++* `stack test :weigh-maps --flag weigh:weigh-maps`
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Weigh.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE BangPatterns #-}++-- | Framework for seeing how much a function allocates.++module Weigh+ (-- * Main entry point.+ mainWith+ -- * Types+ ,Weigh+ ,Weight(..)+ -- * Simple combinators+ ,action+ ,func+ ,value+ -- * Validating combinators+ ,validateAction+ ,validateFunc+ -- * Validators+ ,maxAllocs+ -- * Handy utilities+ ,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++--------------------------------------------------------------------------------+-- Types++-- | Weigh specification monad.+newtype Weigh a =+ Weigh {runWeigh :: Writer [(String,Action)] a}+ deriving (Monad,Functor,Applicative)++-- | How much a computation weighed in at.+data Weight =+ Weight {weightLabel :: !String+ ,weightAllocatedBytes :: !Int64+ ,weightGCs :: !Int64}+ deriving (Read,Show)++-- | An action to run.+data Action =+ forall a b. (NFData a) =>+ Action {_actionRun :: !(b -> IO a)+ ,_actionArg :: !b+ ,actionCheck :: Weight -> Maybe String}++--------------------------------------------------------------------------------+-- Main-runners++-- | Just run the measuring and print a report.+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))++--------------------------------------------------------------------------------+-- User DSL++-- | Weigh a function applied to an argument.+--+-- Implemented in terms of 'validateFunc'.+func :: (NFData a) => String -> (b -> a) -> b -> Weigh ()+func name !f !x = validateFunc name f x (const Nothing)++-- | Weigh a value.+--+-- Implemented in terms of 'action'.+value :: NFData a => String -> a -> Weigh ()+value name !v = action name (return v)++-- | Weigh an IO action.+--+-- Implemented in terms of 'validateAction'.+action :: NFData a+ => String -> IO a -> Weigh ()+action name !m =+ validateAction name+ (const m)+ ()+ (const Nothing)++-- | Make a validator that set sthe maximum allocations.+maxAllocs :: Int64 -> (Weight -> Maybe String)+maxAllocs n =+ \w ->+ if weightAllocatedBytes w > n+ then Just ("Allocated bytes exceeds " +++ commas n ++ ": " ++ commas (weightAllocatedBytes w))+ else Nothing++-- | Weigh an IO action, validating the result.+validateAction+ :: (NFData a)+ => String -> (b -> IO a) -> b -> (Weight -> Maybe String) -> Weigh ()+validateAction name !m !arg !validate =+ Weigh (tell [(name,Action m arg validate)])++-- | Weigh a function, validating the result+validateFunc+ :: (NFData a)+ => String -> (b -> a) -> b -> (Weight -> Maybe String) -> Weigh ()+validateFunc name !f !x !validate =+ Weigh (tell [(name,Action (return . f) x validate)])++--------------------------------------------------------------------------------+-- Internal measuring actions++-- | Weigh a set of actions. The value of the actions are forced+-- completely to ensure they are fully allocated.+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 a case and run it.+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 ->+ let !r = read out+ in return r++-- | Weigh an action. 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.+weighAction !run !arg =+ do performGC+ -- The above forces getGCStats data to be generated NOW.+ !bootupStats <- getGCStats+ -- We need the above to subtract "program startup" overhead. This+ -- operation itself adds n bytes for the size of GCStats, but we+ -- subtract again that later.+ !_ <- fmap force (run arg)+ performGC+ -- The above forces getGCStats data to be generated NOW.+ !actionStats <- getGCStats+ let reflectionGCs = 1 -- We performed an additional GC.+ actionBytes =+ (bytesAllocated actionStats - bytesAllocated bootupStats) -+ -- We subtract the size of "bootupStats", which will be+ -- included after we did the performGC.+ ghcStatsSizeInBytes+ actionGCs = numGcs actionStats - numGcs bootupStats - reflectionGCs+ -- I believe that 24 is the cost to allocate and force the+ -- thunk. This may change with GHC version in the future.+ overheadBytes = 24+ -- If overheadBytes is too large, we conservatively just+ -- return zero. It's not perfect, but this library is for+ -- measuring large quantities anyway.+ actualBytes = max 0 (actionBytes - overheadBytes)+ return (actualBytes,actionGCs)++--------------------------------------------------------------------------------+-- 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+ Nothing -> "OK"+ 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+ then "-"+ else ""+ width = maximum (map (length . snd . (!! x')) xs)++-- | Formatting an integral number to 1,000,000, etc.+commas :: (Num a,Integral a,Show a) => a -> String+commas = reverse . intercalate "," . chunksOf 3 . reverse . show
+ src/Weigh/GHCStats.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Calculate the size of GHC.Stats statically.++module Weigh.GHCStats+ (ghcStatsSizeInBytes)+ where++import GHC.Stats+import GHC.Int+import Language.Haskell.TH+import Data.List++-- | Get the size of a 'GHCStats' object in bytes.+ghcStatsSizeInBytes :: Int64+ghcStatsSizeInBytes =+ $(do info <- reify ''GHC.Stats.GCStats+ case info of+ TyConI (DataD _ _ _ [RecC _ fields] _) ->+ do total <-+ fmap (foldl' (+) headerSize)+ (mapM fieldSize fields)+ litE (IntegerL (fromIntegral total))+ where headerSize = 8+ fieldSize+ :: (name,strict,Type) -> Q Int64+ fieldSize (_,_,typ) =+ case typ of+ ConT typeName ->+ case lookup typeName knownTypes of+ Nothing ->+ fail ("Unknown size for type " +++ show typeName +++ ". Please report this as a bug, the codebase needs updating.")+ Just size -> return size+ _ ->+ fail ("Unexpected type shape: " +++ show typ +++ ". Please report this as a bug, the codebase needs updating.")+ knownTypes :: [(Name,Int64)]+ knownTypes =+ map (,8)+ [''Int64,''Int32,''Int8,''Int16,''Double]+ _ ->+ fail "Unexpected shape of GCStats data type. \+ \Please report this as a bug, this function \+ \needs to be updated to the newer GCStats type.")
+ src/test/Main.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++-- | Example uses of Weigh which should work.++module Main where++import Control.DeepSeq+import Weigh+import GHC.Generics++-- | Weigh integers.+main :: IO ()+main =+ mainWith (do integers+ ints+ struct+ packing)++-- | Just counting integers.+integers :: Weigh ()+integers =+ do func "integers count 0" count 0+ func "integers count 1" count 1+ func "integers count 2" count 2+ func "integers count 3" count 3+ func "integers count 10" count 10+ func "integers count 100" count 100+ where count :: Integer -> ()+ count 0 = ()+ count a = count (a - 1)++-- | We count ints and ensure that the allocations are optimized away+-- to only two 64-bit Ints (16 bytes).+ints :: Weigh ()+ints =+ do validateFunc "ints count 1" count 1 (maxAllocs 0)+ validateFunc "ints count 10" count 10 (maxAllocs 0)+ validateFunc "ints count 1000000" count 1000000 (maxAllocs 0)+ where count :: Int -> ()+ count 0 = ()+ count a = count (a - 1)++-- | Some simple data structure of two ints.+data IntegerStruct = IntegerStruct !Integer !Integer+ deriving (Generic)+instance NFData IntegerStruct++-- | Weigh allocating a user-defined structure.+struct :: Weigh ()+struct =+ do func "\\_ -> IntegerStruct 0 0" (\_ -> IntegerStruct 0 0) (5 :: Integer)+ func "\\x -> IntegerStruct x 0" (\x -> IntegerStruct x 0) 5+ func "\\x -> IntegerStruct x x" (\x -> IntegerStruct x x) 5+ func "\\x -> IntegerStruct (x+1) x" (\x -> IntegerStruct (x+1) x) 5+ func "\\x -> IntegerStruct (x+1) (x+1)" (\x -> IntegerStruct (x+1) (x+1)) 5+ func "\\x -> IntegerStruct (x+1) (x+2)" (\x -> IntegerStruct (x+1) (x+2)) 5++-- | A simple structure with an Int in it.+data HasInt = HasInt !Int+ deriving (Generic)+instance NFData HasInt++-- | A simple structure with an Int in it.+data HasPacked = HasPacked HasInt+ deriving (Generic)+instance NFData HasPacked++-- | A simple structure with an Int in it.+data HasUnpacked = HasUnpacked {-# UNPACK #-} !HasInt+ deriving (Generic)+instance NFData HasUnpacked++-- | Weigh: packing vs no packing.+packing :: Weigh ()+packing =+ do func "\\x -> HasInt x" (\x -> HasInt x) 5+ func "\\x -> HasUnpacked (HasInt x)" (\x -> HasUnpacked (HasInt x)) 5+ func "\\x -> HasPacked (HasInt x)" (\x -> HasPacked (HasInt x)) 5
+ src/test/Maps.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++-- | Example uses of comparing map-like data structures.++module Main where++import Control.DeepSeq+import qualified Data.HashMap.Lazy+import qualified Data.HashMap.Strict+import qualified Data.IntMap.Lazy+import qualified Data.IntMap.Strict+import qualified Data.Map.Lazy+import qualified Data.Map.Strict+import System.Random+import Weigh++-- | Weigh maps.+main :: IO ()+main =+ mainWith (do inserts+ fromlists)++inserts :: Weigh ()+inserts = do func "Data.Map.Strict.insert mempty"+ (\(k,v) -> Data.Map.Strict.insert k v mempty)+ (1 :: Int,1 :: Int)+ func "Data.Map.Lazy.insert mempty"+ (\(k,v) -> Data.Map.Lazy.insert k v mempty)+ (1 :: Int,1 :: Int)+ func "Data.HashMap.Strict.insert mempty"+ (\(k,v) -> Data.HashMap.Strict.insert k v mempty)+ (1 :: Int,1 :: Int)+ func "Data.HashMap.Lazy.insert mempty"+ (\(k,v) -> Data.HashMap.Lazy.insert k v mempty)+ (1 :: Int,1 :: Int)++fromlists :: Weigh ()+fromlists =+ do let !elems =+ force (zip (randoms (mkStdGen 0) :: [Int])+ [1 :: Int .. 1000000])+ func "Data.Map.Strict.fromList (1 million)" Data.Map.Strict.fromList elems+ func "Data.Map.Lazy.fromList (1 million)" Data.Map.Lazy.fromList elems+ func "Data.IntMap.Strict.fromList (1 million)" Data.IntMap.Strict.fromList elems+ func "Data.IntMap.Lazy.fromList (1 million)" Data.IntMap.Lazy.fromList elems+ func "Data.HashMap.Strict.fromList (1 million)" Data.HashMap.Strict.fromList elems+ func "Data.HashMap.Lazy.fromList (1 million)" Data.HashMap.Lazy.fromList elems
+ weigh.cabal view
@@ -0,0 +1,58 @@+name: weigh+version: 0.0.0+synopsis: Measure allocations of a Haskell functions/values+description: Please see README.md+homepage: https://github.com/fpco/weigh#readme+license: BSD3+license-file: LICENSE+author: Chris Done+maintainer: chrisdone@fpcomplete.com+copyright: FP Complete+category: Web+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++flag weigh-maps+ manual: True+ default: False+ description: Weigh maps.++library+ hs-source-dirs: src+ ghc-options: -Wall -O2+ exposed-modules: Weigh+ other-modules: Weigh.GHCStats+ build-depends: base >= 4.7 && < 5+ , process+ , deepseq+ , mtl+ , split+ , template-haskell+ default-language: Haskell2010++test-suite weigh-test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: src/test+ ghc-options: -O2+ main-is: Main.hs+ build-depends: base+ , weigh+ , deepseq++test-suite weigh-maps+ if !flag(weigh-maps)+ buildable: False+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: src/test+ ghc-options: -O2+ main-is: Maps.hs+ build-depends: base+ , weigh+ , deepseq+ , containers+ , unordered-containers+ , bytestring-trie+ , random