diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,60 @@ +# weigh [![Build Status](https://travis-ci.org/fpco/weigh.png)](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` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Weigh.hs b/src/Weigh.hs new file mode 100644 --- /dev/null +++ b/src/Weigh.hs @@ -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 diff --git a/src/Weigh/GHCStats.hs b/src/Weigh/GHCStats.hs new file mode 100644 --- /dev/null +++ b/src/Weigh/GHCStats.hs @@ -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.") diff --git a/src/test/Main.hs b/src/test/Main.hs new file mode 100644 --- /dev/null +++ b/src/test/Main.hs @@ -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 diff --git a/src/test/Maps.hs b/src/test/Maps.hs new file mode 100644 --- /dev/null +++ b/src/test/Maps.hs @@ -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 diff --git a/weigh.cabal b/weigh.cabal new file mode 100644 --- /dev/null +++ b/weigh.cabal @@ -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