diff --git a/Data/Size/Base.hs b/Data/Size/Base.hs --- a/Data/Size/Base.hs +++ b/Data/Size/Base.hs @@ -1,24 +1,35 @@ {-# LANGUAGE BangPatterns #-} module Data.Size.Base - ( Size + ( Bytes + , Size , SizeTable , SizeStatistics , Sizeable(..) , bitsPerWord , bytesPerWord + , bytesPerChar , bytesToWords - , mksize + , wordAlign + , mkBytes + , mkSize , dataSize , singletonSize + , dataOfObj + , dataOfConstr + , dataOfPtr + , dataOfSingleton , (.*.) + , typeName , setName , addSize , addPart - , mkstats - , showstats + , mkObject + , mkStats + , constrStats + , showStats , mempty -- re-export of Monoid , mappend @@ -27,10 +38,11 @@ ) where -import qualified Data.List as L -import qualified Data.Map.Strict as M +import qualified Data.List as L +import qualified Data.Map.Strict as M import Data.Monoid import Data.Typeable +import qualified Foreign.Storable as FS -- ---------------------------------------- @@ -41,6 +53,9 @@ bytesPerWord :: Int bytesPerWord = bitsPerWord `div` 8 +bytesPerChar :: Int +bytesPerChar = FS.sizeOf ' ' + bitsPerWord :: Int bitsPerWord = cnt 1 $ iterate (*2) (1::Int) where @@ -55,12 +70,63 @@ -- -------------------- +data Bytes + = Bytes + { _bytes :: ! Int + , _align :: ! Int + } + deriving (Eq, Show) + +instance Monoid Bytes where + mempty + = Bytes 0 1 + (Bytes bs1 al1) `mappend` (Bytes bs2 al2) + = Bytes (align bs1 al2 + bs2) (al1 `max` al2) + +instance Scale Bytes where + i .*. (Bytes bs al) + = Bytes (i * bs) al + +align :: Int -> Int -> Int +align x a + = (x + (a - 1)) `div` a * a + +mkBytes :: Int -> Int -> Bytes +mkBytes bs' al' + = Bytes (align bs al) al + where + bs = bs' `max` 0 + al = al' `max` 1 + +wordAlign :: Bytes -> Bytes +wordAlign x + = x <> Bytes 0 bytesPerWord + +dataOfSingleton :: Bytes +dataOfSingleton + = Bytes 0 bytesPerWord + +dataOfConstr :: Bytes +dataOfConstr + = Bytes bytesPerWord bytesPerWord + +dataOfPtr :: Bytes +dataOfPtr + = Bytes bytesPerWord bytesPerWord + +dataOfObj :: Bytes -> Bytes +dataOfObj w@(Bytes bs _al) + | bs == 0 = w -- singleton + | otherwise = wordAlign $ dataOfConstr <> w + +-- -------------------- + -- | Counter for # of objects and # of words data Size = Size { _objCnt :: ! Int - , _wordCnt :: ! Int + , _byteCnt :: ! Int } deriving (Eq, Show) @@ -70,14 +136,15 @@ -- If # words for the data is 0, it's a singleton, -- so the # of objects are not accumulated -mksize :: Int -> Size -mksize 0 = singletonSize -mksize n = Size 1 (n + 1) -- one word for constructor +mkSize :: Bytes -> Size +mkSize (Bytes n _) + | n == 0 = singletonSize + | otherwise = Size 1 n --- get the # of words for the data fields of a value +-- get the # of bytes for the data fields of a value, without counting the constructor field dataSize :: Size -> Int -dataSize (Size _o w) = (w - 1) `max` 0 -- decrement constructor size +dataSize (Size _o w) = (w - bytesPerWord) `max` 0 -- decrement constructor size -- | The size value of a singleton -- @@ -104,7 +171,7 @@ -- -------------------- newtype SizeTable - = ST (M.Map String Size) + = ST (M.Map (String, String) Size) deriving (Show) instance Monoid SizeTable where @@ -123,13 +190,13 @@ data SizeStatistics = SST - { _nameof :: ! String - , _accu :: ! Size - , _parts :: ! SizeTable + { _nameof :: String + , _accu :: Size + , _parts :: SizeTable } +-- deriving Show -instance Show SizeStatistics where - show = showstats +instance Show SizeStatistics where show = showStats instance Monoid SizeStatistics where mempty = SST "" mempty mempty @@ -153,26 +220,27 @@ -- -------------------- -class Typeable a => Sizeable a where - nameof :: a -> String - sizeof :: a -> Size - statsof :: a -> SizeStatistics +class (Typeable a) => Sizeable a where + nameOf :: a -> String + dataOf :: a -> Bytes + bytesOf :: a -> Bytes + objectsOf :: a -> Size + statsOf :: a -> SizeStatistics - nameof x - | m == "GHC.Types" = n - | otherwise = m ++ "." ++ n - where - t = fst . splitTyConApp . typeOf $ x - m = tyConModule t - n = tyConName t + nameOf = typeName + bytesOf = dataOfObj . dataOf + objectsOf = _accu . statsOf + statsOf = mkStats - sizeof _ = mksize 1 -- defaults for primitive types - statsof x = mkstats x "" 1 -- " " " " +typeName :: Typeable a => a -> String +typeName + = show . typeOf + -- ------------------------------------------------------------ -insertSizeTable :: String -> Size -> SizeTable -> SizeTable -insertSizeTable k v (ST t) = ST $ M.insertWith (<>) k v t +insertSizeTable :: (String, String) -> Size -> SizeTable -> SizeTable +insertSizeTable tn v (ST t) = ST $ M.insertWith (<>) tn v t -- ------------------------------------------------------------ @@ -184,69 +252,127 @@ addSize c st = st { _accu = c <> _accu st } -addPart :: String -> Size -> SizeStatistics -> SizeStatistics -addPart n c st - = st { _parts = insertSizeTable n c $ _parts st } +addPart :: String -> String -> Size -> SizeStatistics -> SizeStatistics +addPart tn cn c st + = st { _parts = insertSizeTable (tn, cn) c $ _parts st } -mkstats :: Sizeable a => a -> String -> Int -> SizeStatistics -mkstats x cn w +mkObject :: Sizeable a => a -> Size +mkObject x + | n == 0 = singletonSize + | otherwise = Size 1 n + where + (Bytes n _) = bytesOf x + +mkStats :: (Sizeable a) => a -> SizeStatistics +mkStats = constrStats "" + +constrStats :: (Sizeable a) => String -> a -> SizeStatistics +constrStats cn x = st3 where - n = nameof x - cnt = Size 1 (if w == 0 then 0 else w + 1) -- overhead for tagfield - st1 = addSize cnt $ setName n $ mempty - st2 = addPart n cnt st1 - st3 | null cn = st2 - | otherwise = addPart (n ++ " " ++ cn) cnt st2 + nm = nameOf x + cnt = mkObject x + st1 = addSize cnt $ setName nm $ mempty -- add the stats for the datatype + st2 = addPart nm "" cnt st1 + st3 | null cn = st2 + | otherwise = addPart nm cn cnt st2 -- add the stats for the constructor -showstats :: SizeStatistics -> String -showstats (SST name cnt (ST parts)) +showStats :: SizeStatistics -> String +showStats (SST name (Size oc bc) (ST parts)) = unlines $ header ++ "total value:" - : toLine name cnt + : toLine' ( (charToString name, "") + , (showNum oc, showNum . bytesToWords $ bc) + ) : "" : "components:" - : (L.map (uncurry toLine) . M.toList $ parts) + : toTable where - ! widthName = L.maximum . L.map length . ([col1, name] ++) . M.keys - $ parts - ! widthObj = 16 `max` length col2 - ! widthWord = 16 `max` length col3 + statsTable = L.map toString . M.toList $ parts + + toString :: ((String, String), Size) -> ((String, String), (String, String)) + toString ((tn, cn), Size os bs) + = ( ( if null cn + then charToString tn + else blankName + , cn + ) + , ( showNum os + , showNum . bytesToWords $ bs + ) + ) + toTable + = L.map toLine' $ statsTable + + toLine' :: ((String, String), (String, String)) -> String + toLine' ((tn, cn), (os, bs)) + = unwords [ if null cn + then expR widthCol1 tn + else blankName ++ expR widthCol1 cn + , expL widthCol2 os + , expL widthCol3 bs + ] + + blankName = replicate 8 ' ' + + widthCol1 + = 16 `max` length col1 `max` (L.maximum . L.map (uncurry width . fst) $ statsTable) + where + width tn cn + = length tn + length cn + widthCol2 + = 16 `max` length col2 `max` (L.maximum . L.map (length . fst . snd) $ statsTable) + + widthCol3 + = 16 `max`length col3 `max` (L.maximum . L.map (length . snd . snd) $ statsTable) + + charToString + = subst "[Char]" "String" + col1 = "type/constructor" col2 = "# object" col3 = "# word" ++ show bitsPerWord header = [l1, l2, l3] where - l1 = unwords [ expR widthName col1 - , expL widthObj col2 - , expL widthWord col3 + l1 = unwords [ expR widthCol1 col1 + , expL widthCol2 col2 + , expL widthCol3 col3 ] l2 = map (const '=') l1 l3 = "" - toLine n (Size o w) - = unwords [ indentConstr widthName n - , expL widthObj $ show o - , expL widthWord $ show w - ] - indentConstr i n - | length ws == 2 = replicate 8 ' ' ++ expR i (concat . drop 1 $ ws) - | otherwise = expR i n - where - ws = words n +expL :: Int -> String -> String +expL n s + | n < n' = s + | otherwise = reverse . take n . reverse . (replicate n ' ' ++) $ s + where + n' = length s - expL n s - | n < n' = s - | otherwise = reverse . take n . reverse . (replicate n ' ' ++) $ s - where - n' = length s +expR :: Int -> String -> String +expR n s + | n < n' = s + | otherwise = take n $ s ++ replicate n ' ' + where + n' = length s - expR n s - | n < n' = s - | otherwise = take n $ s ++ replicate n ' ' - where - n' = length s +showNum :: Int -> String +showNum + = reverse . insComma . reverse . show + where + insComma (x1 : x2 : x3 : xs4@(_ : _)) + = x1 : x2 : x3 : ',' : insComma xs4 + insComma xs + = xs + +subst :: String -> String -> String -> String +subst _ _ [] + = [] +subst xs ys inp + | L.isPrefixOf xs inp + = ys ++ subst xs ys (L.drop (length xs) inp) + | otherwise + = head inp : subst xs ys (tail inp) -- ------------------------------------------------------------ diff --git a/Data/Size/Instances.hs b/Data/Size/Instances.hs --- a/Data/Size/Instances.hs +++ b/Data/Size/Instances.hs @@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns #-} -{-# OPTIONS -fno-warn-orphans #-} +{-# OPTIONS -fno-warn-orphans #-} module Data.Size.Instances where @@ -13,211 +13,226 @@ import qualified Data.IntSet as IS import qualified Data.Map as M +import qualified Foreign.Storable as FS + -- ---------------------------------------- -instance Sizeable Bool where -instance Sizeable Int where -instance Sizeable Char where -instance Sizeable Double where - sizeof _ = mksize (64 `div` bitsPerWord) - statsof x = mkstats x "" (64 `div` bitsPerWord) +instance Sizeable Bool where dataOf = dataOfStorable +instance Sizeable Int where dataOf = dataOfStorable +instance Sizeable Char where dataOf = dataOfStorable +instance Sizeable Float where dataOf = dataOfStorable +instance Sizeable Double where dataOf = dataOfStorable +dataOfStorable :: FS.Storable a => a -> Bytes +dataOfStorable x + = mkBytes (FS.sizeOf x) (FS.alignment x) + +dataOfBool :: Bytes +dataOfBool + = dataOfStorable (undefined :: Bool) + +dataOfInt :: Bytes +dataOfInt + = dataOfStorable (undefined :: Int) + +dataOfChar :: Bytes +dataOfChar + = dataOfStorable (undefined :: Char) + +dataOfFloat :: Bytes +dataOfFloat + = dataOfStorable (undefined :: Float) + +dataOfDouble :: Bytes +dataOfDouble + = dataOfStorable (undefined :: Double) + -- -------------------- instance (Sizeable t1, Sizeable t2) => Sizeable (t1, t2) where - nameof (x1, x2) - = concat ["(" - , nameof x1 - , "," - , nameof x2 - , ")" - ] - sizeof (x1, x2) - = mksize 2 - <> - sizeof x1 <> sizeof x2 - statsof xs@(x1, x2) - = mkstats xs "" 2 + dataOf (_x1, _x2) + = 2 .*. dataOfPtr + + statsOf xs@(x1, x2) + = mkStats xs <> - statsof x1 <> statsof x2 + statsOf x1 <> statsOf x2 -- -------------------- instance (Sizeable t1, Sizeable t2, Sizeable t3) => Sizeable (t1, t2, t3) where - nameof (x1, x2, x3) - = concat ["(" - , nameof x1 - , "," - , nameof x2 - , "," - , nameof x3 - , ")" - ] - sizeof (x1, x2, x3) - = mksize 3 - <> - sizeof x1 <> sizeof x2 <> sizeof x3 - statsof xs@(x1, x2, x3) - = mkstats xs "" 3 + dataOf (_x1, _x2, _x3) + = 3 .*. dataOfPtr + + statsOf xs@(x1, x2, x3) + = mkStats xs <> - statsof x1 <> statsof x2 <> statsof x3 + statsOf x1 <> statsOf x2 <> statsOf x3 -- -------------------- instance (Sizeable t1, Sizeable t2, Sizeable t3, Sizeable t4) => Sizeable (t1, t2, t3, t4) where - nameof (x1, x2, x3, x4) - = concat ["(" - , nameof x1 - , "," - , nameof x2 - , "," - , nameof x3 - , "," - , nameof x4 - , ")" - ] - sizeof (x1, x2, x3, x4) - = mksize 4 - <> - sizeof x1 <> sizeof x2 <> sizeof x3 <> sizeof x4 - statsof xs@(x1, x2, x3, x4) - = mkstats xs "" 4 + dataOf (_x1, _x2, _x3, _x4) + = 4 .*. dataOfPtr + + statsOf xs@(x1, x2, x3, x4) + = mkStats xs <> - statsof x1 <> statsof x2 <> statsof x3 <> statsof x4 + statsOf x1 <> statsOf x2 <> statsOf x3 <> statsOf x4 -- -------------------- +instance (Sizeable t) => Sizeable (Maybe t) where + dataOf x + = case x of + Just _ -> dataOfPtr + Nothing -> dataOfSingleton + + statsOf x + = case x of + Just x1 -> constrStats "Just" x <> statsOf x1 + Nothing -> constrStats "Nothing" x + +-- -------------------- + +instance (Sizeable t1, Sizeable t2) => Sizeable (Either t1 t2) where + dataOf x + = case x of + Left _ -> dataOfPtr + Right _ -> dataOfPtr + + statsOf x + = case x of + Left x1 -> constrStats "Left" x <> statsOf x1 + Right x1 -> constrStats "Right" x <> statsOf x1 + +-- -------------------- +-- +-- in list statistics the constructors ([] and (:) are not counted +-- just the # of lists and the total # of cells used for all the (:) nodes + instance Sizeable a => Sizeable [a] where - nameof xs - = listTypeName (nameof (head xs)) - sizeof - = mconcat . L.map sizeof - statsof xs + dataOf xs + = length xs .*. (dataOfConstr <> (2 .*. dataOfPtr)) + + bytesOf -- Lists are handled as a single object, + = dataOf -- all space is already accumulated in dataOf + + statsOf xs | null xs - = mkstats xs "[]" 0 + = mkStats xs - | nameof hd `elem` ["Char", "Int", "Double", "Float", "Bool"] - = mkstats xs "[]" 0 - <> - len .*. mkstats xs "(:)" 2 + | nameOf hd `elem` ["Char", "Int", "Double", "Float", "Bool"] + = mkStats xs <> - len .*. statsof hd + len .*. statsOf hd | otherwise - = mkstats xs "[]" 0 - <> - len .*. mkstats xs "(:)" 2 + = mkStats xs <> - (mconcat . L.map statsof $ xs) + (mconcat . L.map statsOf $ xs) where hd = head xs len = length xs -listTypeName :: String -> String -listTypeName n - | n == "Char" = "String" - | otherwise = "[" ++ n ++ "]" - -- -------------------- instance Sizeable IS.IntSet where - sizeof s + dataOf s | IS.null s - = mksize 0 + = dataOfSingleton | otherwise - = len .*. mksize 2 + = len .*. (dataOfObj $ dataOfInt <> dataOfInt) <> - (len - 1) .*. mksize 4 + (len - 1) .*. (dataOfObj $ dataOfInt <> dataOfInt <> dataOfPtr <> dataOfPtr) where len = countTips s - statsof s - | IS.null s - = mkstats s "Nil" 0 - | otherwise - = len .*. mkstats s "Tip" 2 - <> - (len - 1) .*. mkstats s "Bin" 4 - where - len = countTips s + countTips :: IS.IntSet -> Int + countTips = cnt 0 . IS.elems + where + cnt !i [] + = i + cnt !i xs@(x : _) + = cnt (i + 1) $ + dropWhile (\ y -> y `div` bitsPerWord == x `div` bitsPerWord) xs --- hack: Data.IntSet.Base is hidden, so we have to look into the source --- and compute the size by hand + bytesOf -- IntSet is handled as a single object, + = dataOf -- all space is already accumulated in dataOf -countTips :: IS.IntSet -> Int -countTips = cnt 0 . IS.elems - where - cnt !i [] - = i - cnt !i xs@(x : _) - = cnt (i + 1) $ dropWhile (\ y -> y `div` bitsPerWord == x `div` bitsPerWord) xs + statsOf + = mkStats -- -------------------- instance Sizeable v => Sizeable (IM.IntMap v) where - sizeof m + dataOf m | IM.null m - = mksize 0 + = dataOfSingleton | otherwise - = len .*. mksize 2 + = len .*. (dataOfObj $ dataOfInt <> dataOfPtr) <> - (len - 1) .*. mksize 4 + (len - 1) .*. (dataOfObj $ dataOfInt <> dataOfInt <> dataOfPtr <> dataOfPtr) where len = IM.size m - statsof m - | IM.null m - = mkstats m "Nil" 0 - | otherwise - = len .*. mkstats m "Tip" 2 - <> - (len - 1) .*. mkstats m "Bin" 4 - <> - IM.foldr' ((<>) . statsof) mempty m - where - len = IM.size m + bytesOf -- IntMap is handled as a single object, + = dataOf -- all space is already accumulated in dataOf + statsOf m + = mkStats m + <> + IM.foldr' ((<>) . statsOf) mempty m + -- -------------------- instance (Sizeable k, Sizeable v) => Sizeable (M.Map k v) where - sizeof m + dataOf m | M.null m - = mksize 0 + = dataOfSingleton | otherwise - = len .*. mksize 5 - <> - M.foldWithKey (\ k v st -> sizeof k <> sizeof v <> st) mempty m + = len .*. (dataOfObj $ dataOfInt <> 4 .*. dataOfPtr) where len = M.size m - statsof m - | M.null m - = mkstats m "Tip" 0 - | otherwise - = (len + 1) .*. mkstats m "Tip" 0 - <> - len .*. mkstats m "Bin" 5 - <> - M.foldWithKey (\ k v st -> statsof k <> statsof v <> st) mempty m + bytesOf -- Map is handled as a single object, + = dataOf -- all space is already accumulated in dataOf + + statsOf m + = mkStats m + <> + (mconcat . L.map (uncurry statsOfPair) $ M.toList m) where - len = M.size m + statsOfPair k v + = statsOf k <> statsOf v + -- -------------------- {- data BS.ByteString = PS {-# UNPACK #-} !(ForeignPtr Word8) -- payload {-# UNPACK #-} !Int -- offset {-# UNPACK #-} !Int -- length +data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents + +data ForeignPtrContents + = PlainForeignPtr !(IORef (Finalizers, [IO ()])) + | MallocPtr (MutableByteArray# RealWorld) !(IORef (Finalizers, [IO ()])) + | PlainPtr (MutableByteArray# RealWorld) -} instance Sizeable BS.ByteString where - sizeof - = mksize . (3 +) . bytesToWords . BS.length + dataOf bs + = (dataOfPtr <> 2 .*. dataOfInt) -- size of ByteString data + <> (dataOfObj $ dataOfPtr <> dataOfPtr) -- size of ForeignPtr object + <> (wordAlign $ -- size of byte sequence + BS.length bs .*. dataOfChar + ) - statsof s - = mkstats s "" (dataSize . sizeof $ s) + statsOf s + = mkStats s -- -------------------- @@ -227,12 +242,20 @@ -} instance Sizeable BL.ByteString where - sizeof - = mconcat . L.map sizeof' . BL.toChunks - where - sizeof' c = mksize (3 + 1 + bytesToWords (BS.length c)) + nameOf + = (++ " (lazy)") . typeName - statsof s - = mkstats s "" (dataSize . sizeof $ s) + dataOf bs + = length cs .*. (dataOfObj $ dataOfPtr <> dataOfPtr) + <> + (mconcat . L.map bytesOf $ cs) + where + cs = BL.toChunks bs + + bytesOf -- ByteString is handled as a single object, + = dataOf -- all space is already accumulated in dataOf + + statsOf + = mkStats -- ------------------------------------------------------------ diff --git a/data-size.cabal b/data-size.cabal --- a/data-size.cabal +++ b/data-size.cabal @@ -1,8 +1,5 @@ --- Initial data-size.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: data-size -version: 0.1.0.4 +version: 0.1.1.1 synopsis: Profiling of data structures description: Profiling of data structures for counting the # of object allocated for a value