cabal.project

+packages: shake
+
+source-repository-package
+    type: git
+    location: https://github.com/bgamari/tabular
+    tag: 204b01f63dec6bf0e0aba2862c71e77b2ec3909b

parallel/gray/Eval.hs

@@ -35,6 +35,8 @@ instance Applicative Pure where
 instance Monad Pure where
     Pure x >>= k = k x
     return       = Pure
+
+instance MonadFail Pure where
     fail s       = error s
 
 instance MonadEval Pure where
@@ -313,6 +315,8 @@ instance Monad Abs where
                                    AbsState r s' -> runAbs (k r) s'
                                    AbsFail m     -> AbsFail m)
     return       = pure
+
+instance MonadFail Abs where
     fail s       = Abs (\ n -> AbsFail s)
 
 instance MonadEval Abs where

shake/CachegrindParse.hs

+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module CachegrindParse where
+
+import Data.Maybe
+import qualified Data.Map as M
+
+newtype EventName = EventName { getEventName :: String }
+                  deriving (Show, Eq, Ord)
+
+parse :: FilePath -> IO (M.Map EventName Integer)
+parse fname = parse' <$> readFile fname
+
+parse' :: String -> M.Map EventName Integer
+parse' content =
+    M.fromList $ zip summary events
+  where
+    events = case mapMaybe isEventList $ lines content of
+               [] -> error "No event list found"
+               [x] -> x
+               _ -> error "More than one event list found"
+    summary = case mapMaybe isSummaryList $ lines content of
+               [] -> error "No event summary found"
+               [x] -> x
+               _ -> error "More than one event summary found"
+
+    isEventList :: String -> Maybe [Integer]
+    isEventList line
+      | "summary:" : rest <- words line = Just $ map read rest
+      | otherwise = Nothing
+
+    isSummaryList :: String -> Maybe [EventName]
+    isSummaryList line
+      | "events:" : rest <- words line = Just $ map EventName rest
+      | otherwise = Nothing
+

shake/LICENSE

+Copyright (c) 2019, Ben Gamari
+
+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 Ben Gamari 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.

shake/LabelMatch.hs

+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GADTs #-}
+
+module LabelMatch where
+
+import Control.Applicative
+import Control.Monad
+import Data.String
+import qualified Data.Text as T
+
+import MeasurementTree (Label(..))
+import qualified MeasurementTree as MTree
+
+newtype LabelMatcher a = LabelMatcher (Label -> Maybe (Label, a))
+    deriving (Functor)
+
+match :: LabelMatcher a -> Label -> Maybe a
+match (LabelMatcher f) l = snd <$> f l
+
+instance (a ~ ()) => IsString (LabelMatcher a) where
+    fromString = matchPart . fromString
+
+instance Applicative LabelMatcher where
+    pure x = LabelMatcher $ \lbl -> Just (lbl, x)
+    (<*>) = ap
+
+instance Alternative LabelMatcher where
+    LabelMatcher f <|> LabelMatcher g =
+      LabelMatcher $ \lbl -> f lbl <|> g lbl
+    empty = LabelMatcher $ const Nothing
+
+instance Monad LabelMatcher where
+    LabelMatcher f >>= g = LabelMatcher $ \lbl ->
+        case f lbl of
+          Nothing -> Nothing
+          Just (lbl', x) -> let LabelMatcher h = g x
+                             in h lbl'
+
+matchPart :: T.Text -> LabelMatcher ()
+matchPart s = LabelMatcher f
+  where
+    f (Label (x:xs))
+      | x == s = Just (Label xs, ())
+    f _ = Nothing
+
+wildcard :: LabelMatcher String
+wildcard = LabelMatcher f
+  where
+    f (Label (x:xs)) = Just (Label xs, T.unpack x)
+    f (Label []) = Nothing
+
+end :: LabelMatcher ()
+end = LabelMatcher f
+  where
+    f (Label []) = Just (Label [], ())
+    f (Label _) = Nothing
+

shake/Merge.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+import Data.Foldable
+import Options.Applicative
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.Csv as Csv
+
+import qualified MeasurementTree as MTree
+import MeasurementTree (Measurements, Label)
+
+args :: Parser (FilePath, [FilePath], Bool)
+args =
+  (,,)
+  <$> option str (long "output" <> short 'o' <> help "output file")
+  <*> some (argument str (metavar "FILE" <> help "results.json files"))
+  <*> switch (long "csv" <> short 'c' <> help "produce CSV output")
+
+main :: IO ()
+main = do
+    (output, files, csv) <- execParser $ info (helper <*> args) mempty
+    trees <- mapM MTree.readFile files
+    let result = fold trees
+    if csv
+       then MTree.writeFileCsv output result
+       else MTree.writeFile output result
+

shake/ParseResults.hs

+module ParseResults 
+  ( parseCodeSize
+  , parseRtsStats
+  ) where
+
+import qualified Data.Map.Strict as M
+import Data.Maybe
+
+-- | Parse text section size out of Berkley-format @size@ output
+parseCodeSize :: String -> Integer
+parseCodeSize content
+  | header : sizes : _ <- lines content
+  , "text" : _ <- words header =
+      read $ head $ words sizes
+  | otherwise = error "unrecognized size output"
+
+parseRtsStats :: String -> M.Map String Double
+parseRtsStats = foldMap parseValue . readPairs . dropFirstLine
+  where
+    parseValue (name, value)
+      | (x, ""):_ <- reads value = M.singleton name x
+      | otherwise = M.empty
+
+    dropFirstLine = unlines . drop 1 . lines
+
+    readPairs :: String -> [(String, String)]
+    readPairs s
+      | (x, _):_ <- reads s = x
+      | otherwise = error $ "Failed to parse RTS statistics: " ++ s

shake/PerfStatParse.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module PerfStatParse (readPerfStat, EventName(..)) where
+
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import qualified Data.Map as M
+
+newtype EventName = EventName { getEventName :: String }
+                  deriving (Show, Eq, Ord)
+
+-- | Read metrics from @perf stat -x,@ invocation.
+readPerfStat :: FilePath -> IO (M.Map EventName [Double])
+readPerfStat path = do
+    parsePerfStat <$> TIO.readFile path
+
+parsePerfStat :: T.Text -> M.Map EventName [Double]
+parsePerfStat = M.unionsWith (++) . map parseLine . T.lines
+  where
+    parseLine line
+      | "#" `T.isPrefixOf` line = mempty
+      | value:_:metric:_ <- T.splitOn "," line
+      , (val, "") : _ <- reads $ T.unpack value
+      = M.singleton (EventName $ T.unpack metric) [val]
+      | otherwise = mempty

shake/Setup.hs

+import Distribution.Simple
+main = defaultMain

shake/nofib-run.cabal

+cabal-version:       >=1.10
+name:                nofib
+version:             0.1.0.0
+-- synopsis:
+-- description:
+-- bug-reports:
+license:             BSD3
+license-file:        LICENSE
+author:              Ben Gamari
+maintainer:          ben@smart-cactus.org
+-- copyright:
+-- category:
+build-type:          Simple
+
+library
+  exposed-modules:     MeasurementTree
+  hs-source-dirs:      src
+  build-depends:       base >=4.10 && <4.13,
+                       aeson,
+                       these >= 0.8,
+                       containers,
+                       cassava,
+                       text,
+                       vector,
+                       bytestring
+  default-language:    Haskell2010
+
+executable nofib-run
+  main-is:             Main.hs
+  other-modules:       CachegrindParse, PerfStatParse, ParseResults
+  other-extensions:    RecordWildCards, DeriveDataTypeable
+  build-depends:       base >=4.10 && <4.13,
+                       time >=1.8 && <1.9,
+                       containers,
+                       bytestring,
+                       directory >=1.3 && <1.4,
+                       process >=1.6 && <1.7,
+                       text,
+                       cmdargs,
+                       shake,
+                       nofib
+  default-language:    Haskell2010
+
+executable nofib-compare
+  main-is:             Compare.hs
+  other-modules:       LabelMatch
+  other-extensions:    RecordWildCards, DeriveDataTypeable
+  build-depends:       base >=4.10 && <4.13,
+                       these,
+                       containers,
+                       directory,
+                       filepath,
+                       text,
+                       aeson,
+                       ansi-wl-pprint,
+                       tabular,
+                       these,
+                       semialign,
+                       optparse-applicative,
+                       ansi-terminal,
+                       nofib
+  default-language:    Haskell2010
+
+executable nofib-merge
+  main-is:             Merge.hs
+  build-depends:       base >=4.10 && <4.13,
+                       optparse-applicative,
+                       cassava,
+                       bytestring,
+                       nofib
+  default-language:    Haskell2010

shake/src/MeasurementTree.hs

+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module MeasurementTree
+    ( -- * Labels
+      -- | A label hierarchically identifies a type of measurement (e.g.
+      -- @T1234//bytes allocated@)
+      Label(..)
+    , mkLabel
+    , encodeLabel
+
+      -- * Measurements
+    , Measurements(..)
+    , toMap
+    , fromMap
+    , prefix
+    , singleton
+    , fromList
+      -- ** I/O with JSON representation
+    , writeFile'
+    , writeFile
+    , readFile'
+    , readFile
+      -- ** I/O with CSV representation
+    , writeFileCsv
+
+      -- * Miscellaneous utilities
+    , mean, geomMean, stdDev
+    ) where
+
+import Data.String (IsString(..))
+import Data.Bifunctor
+import Data.Maybe
+import Data.List (intercalate)
+import Control.Applicative
+import Control.Monad
+import Data.Aeson
+import qualified Data.Csv as Csv
+import qualified Data.Vector as V
+import qualified Data.Map.Strict as M
+import GHC.Generics
+import qualified Data.ByteString.Lazy.Char8 as BSL
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.Text as T
+import Prelude hiding (readFile, writeFile)
+
+newtype Label = Label { getLabel :: [T.Text] }
+              deriving (Eq, Ord, Show, Monoid, Semigroup,
+                        ToJSON, FromJSON, ToJSONKey, FromJSONKey)
+
+instance IsString Label where
+    fromString s = Label [fromString s]
+
+instance Csv.ToField Label where
+    toField = Csv.toField . encodeLabel
+
+instance Csv.FromField Label where
+    parseField = pure . Label . T.splitOn "//" <=< Csv.parseField
+
+mkLabel :: String -> Label
+mkLabel = fromString
+
+encodeLabel :: Label -> T.Text
+encodeLabel (Label parts) = T.intercalate "//" parts
+
+newtype Measurements a = Measurements { toList :: [(Label, a)] }
+    deriving (Show, Functor, Monoid, Semigroup, ToJSON, FromJSON)
+
+toMap :: ([a] -> b) -> Measurements a -> M.Map Label b
+toMap f (Measurements xs) = 
+    fmap f $ M.fromListWith (<>) [ (x, [y]) | (x,y) <- xs ]
+
+fromMap :: M.Map Label a -> Measurements a
+fromMap = Measurements . M.toList
+
+prefix :: Label -> Measurements a -> Measurements a
+prefix lbl (Measurements xs) = Measurements $ map (first (lbl<>)) xs
+
+singleton :: Label -> a -> Measurements a
+singleton lbl x = Measurements [(lbl, x)]
+
+fromList :: [(Label, a)] -> Measurements a
+fromList = Measurements
+
+filterByLabel :: (Label -> Bool) -> Measurements a -> Measurements a
+filterByLabel f (Measurements xs) = Measurements $ filter (f . fst) xs
+
+mapLabels :: (Label -> Maybe Label) -> Measurements a -> Measurements a
+mapLabels f (Measurements xs) =
+    Measurements $ mapMaybe (\(k,v) -> (\k' -> (k', v)) <$> f k) xs
+
+writeFile' :: ToJSON a => FilePath -> Measurements a -> IO ()
+writeFile' fname = BSL.writeFile fname . encode
+
+writeFile :: FilePath -> Measurements Double -> IO ()
+writeFile = writeFile'
+
+readFile' :: FromJSON a => FilePath -> IO (Measurements a)
+readFile' fname = eitherDecodeFileStrict fname >>= either fail pure
+
+readFile :: FilePath -> IO (Measurements Double)
+readFile = readFile'
+
+writeFileCsv :: FilePath -> Measurements Double -> IO ()
+writeFileCsv fname = BSL.writeFile fname . Csv.encodeByName header . map f . toList
+  where
+    f (label, value) = Csv.namedRecord [ "label" Csv..= label, "value" Csv..= value ]
+    header = V.fromList ["label", "value"]
+
+mean :: RealFrac a => [a] -> a
+mean xs = sum xs / realToFrac (length xs)
+
+geomMean :: RealFloat a => [a] -> a
+geomMean = exp . mean . map log
+
+stdDev :: RealFloat a => [a] -> a
+stdDev xs = sqrt $ mean $ map (\x -> (x-m)^(2::Int)) xs
+  where m = mean xs
+