diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for timestats + +## 0.1.0 -- 2022-07-12 + +* First version. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,48 @@ +# timestats + +This library implements time profiling by focusing on +simplicity of use. Most programs should be possible to analyze by +instrumenting the code with a few calls and then building and +running the application as usual. + +This library associates fragments of a program with labels, and +measures the execution time of these fragments using the function +[getMonotonicTimeNSec](https://hackage.haskell.org/package/base-4.16.2.0/docs/GHC-Clock.html#v:getMonotonicTimeNSec). + +Multiple measures of a same program fragment (or different fragments +using the same label) are aggregated and reported at chosen times of +the execution. + +## Usage + +```Haskell +import Control.Exception (evaluate) +import qualified Debug.TimeStats as TimeStats (printTimeStats, measureM) + +fib n = if n < 2 then 1 else fib (n - 1) + fib (n - 2) + +main = do + -- measureM collects the time taken to compute the given action + -- and stores it associated with a given label in global state. + TimeStats.measureM "fib" $ evaluate (fib 31) + -- measuring multiple times with the same label adds up + -- the time taken by all of those invocations + TimeStats.measureM "fib2" $ evaluate (fib 30) + -- adds up to the existing "fib2" stats + TimeStats.measureM "fib2" $ evaluate (fib 29) + TimeStats.printTimeStats +``` + +The output when running the program with `timestats` enabled will look as + +```bash +$ DEBUG_TIMESTATS_ENABLE=1 ./a.out + + fib: 2.055s count: 1 +fib2: 2.071s count: 2 +``` + +`timestats` is enabled by setting the environment variable +`DEBUG_TIMESTATS_ENABLE` to any value ahead of invoking any function +in [Debug.TimeStats](src/Debug/TimeStats.hs). + diff --git a/src/Debug/TimeStats.hs b/src/Debug/TimeStats.hs new file mode 100644 --- /dev/null +++ b/src/Debug/TimeStats.hs @@ -0,0 +1,247 @@ +-- | A module to collect aggregates on how much time is spent in a computation +-- +-- Aggregates can be identified with a label that determines where the time of +-- each computation is accounted for. +-- +-- Measures are collected only if the environment variable +-- @DEBUG_TIMESTATS_ENABLE@ is set to any value ahead of invoking any function +-- in this module. +-- +module Debug.TimeStats + ( -- * Measuring + measureM + , measurePure + -- * Time stats manipulation + , printTimeStats + , hPrintTimeStats + , reset + , TimeStats(..) + , collect + , asText + , scope + -- * Not intended for direct use + -- + -- | These definitions are not intended for instrumenting applications, + -- but they can be handy to implement other measuring primitives. + -- + , TimeStatsRef + , lookupTimeStatsRef + , updateTimeStatsRef + ) where + +import Control.Exception (evaluate) +import Control.Monad (forM, forM_, unless) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.IORef +import Data.Map (Map) +import Data.Maybe (isJust) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Word (Word64) +import GHC.Clock (getMonotonicTimeNSec) +import Text.Printf (printf) +import System.Environment (lookupEnv) +import System.IO (Handle, stderr) +import System.IO.Unsafe (unsafePerformIO) + + +-- | Measure the time it takes to run the action. +-- +-- Add the time to the stats of the given label and increase its count by one. +-- +-- 'measureM' keeps the stats in a globally available store in order to minimize +-- the changes necessary when instrumenting a program. Otherwise a reference to +-- the store would need to be passed to every function that might invoke +-- functions that need this reference. +-- +-- A time measure isn't collected if the given action fails with an exception. +-- This is a deliberate choice to demand less of the monad in which measures are +-- taken. +-- +-- Time measures aren't collected either if the environment variable +-- @DEBUG_TIMESTATS_ENABLE@ isn't set the first time this function is +-- evaluated. +-- +{-# INLINE measureM #-} +measureM :: MonadIO m => String -> m a -> m a +measureM label = + -- See the documentation of 'enabled' + if enabled then do + -- @ref@ is the reference to the stats associated to the label. + -- See note [Looking up stats with unsafePerformIO] + let ref = unsafePerformIO $ lookupTimeStatsRef label + in \action -> measureMWith ref action + else + id + +-- | Pure version of 'measureM'. Measures the time taken to reduce the given +-- value to head normal form. +-- +-- 'measurePure' is a bit dangerous to use in contexts where there are monadic +-- computations. If 'measurePure' is applied to a monadic computation it +-- will measure the time of constructing the computation rather than the time +-- of executing it, and the typechecker won't catch the mistake. We try to +-- fence against it with a longer name. +{-# INLINE measurePure #-} +measurePure :: String -> a -> a +measurePure label = + if enabled then + unsafePerformIO . measureM label . evaluate + else + id + +-- Note [Looking up stats with unsafePerformIO] +-- +-- When calling 'measureM' we would like to save the trouble of looking the +-- stats to update on every invocation. Hence, we use unsafePerformIO, and +-- we ask to inline 'measureM'. +-- +-- Most of the time 'measureM' should be called with a statically known label. +-- When inlining, GHC should notice this fact and move the lookup closure to +-- the top-level, thus performing it only once per invocation, and perhaps +-- only once per label for all 'measureM' calls in the same module. + + +-- | @True@ iff the environment variable @DEBUG_TIMESTATS_ENABLE@ is set to any +-- value +-- +-- We assume the value of the environment variable doesn't change during the +-- lifetime of the program. +-- +-- The purpose of making this a top-level value is to have all calls to +-- 'measureM' checking it only the first time. Thus we save the trouble of +-- looking up the environment variable repeteadly. +{-# NOINLINE enabled #-} +enabled :: Bool +enabled = unsafePerformIO $ isJust <$> lookupEnv "DEBUG_TIMESTATS_ENABLE" + +-- | A unique global reference to the map associating labels to their +-- stats. +{-# NOINLINE labelStatsMapRef #-} +labelStatsMapRef :: IORef (Map String TimeStatsRef) +labelStatsMapRef = unsafePerformIO $ newIORef Map.empty + +-- | Set all statistics to initial values. +reset :: MonadIO m => m () +reset = liftIO $ + if enabled then do + m <- readIORef labelStatsMapRef + forM_ (Map.elems m) $ \(TimeStatsRef ref) -> + writeIORef ref initialTimeStats + else + return () + +-- | Run an action by previously reseting all stats to initial values +-- and printing them afterwards. +scope :: MonadIO m => m a -> m a +scope = + if enabled then + \m -> do + reset + a <- m + hPrintTimeStats stderr + return a + else + id + +-- | Looks up the stats of a label. If no stats are found for the label, +-- a new TimeStatsRef is created with initial values. +-- +lookupTimeStatsRef :: String -> IO TimeStatsRef +lookupTimeStatsRef label = do + r0 <- newTimeStatsRef + atomicModifyIORef labelStatsMapRef $ \m -> + case Map.lookup label m of + Nothing -> (Map.insert label r0 m, r0) + Just r -> (m, r) + +-- | Yields the labels and the stats collected thus far. +collect :: MonadIO m => m [(String, TimeStats)] +collect = liftIO $ do + m <- readIORef labelStatsMapRef + forM (Map.toList m) $ \(label, TimeStatsRef ref) -> + (,) label <$> readIORef ref + +-- | Prints the time stats to the given handle. +hPrintTimeStats :: MonadIO m => Handle -> m () +hPrintTimeStats h = liftIO $ do + xs <- collect + unless (null xs) $ + Text.hPutStrLn h (asText xs) + +-- | Prints the time stats to stderr. +printTimeStats :: MonadIO m => m () +printTimeStats = hPrintTimeStats stderr + +-- | Renders the given time stats in a tabular format +asText :: [(String, TimeStats)] -> Text +asText stats = + let (lbls, timestats) = unzip stats + (times, counts) = unzip $ map formatTimeStats timestats + widthLbls = maximum $ map length lbls + widthTimes = maximum $ map length times + widthCounts = maximum $ map length counts + in Text.unlines $ + map (Text.pack . printStat widthLbls widthTimes widthCounts) $ + zip3 lbls times counts + where + formatTimeStats :: TimeStats -> (String, String) + formatTimeStats t = + ( printf "%.3f" (fromIntegral (timeStat t) / 1e9 :: Double) + , printf "%d" (countStat t) + ) + + -- At the time of this writing printf can't render to 'Text'. + printStat :: Int -> Int -> Int -> (String, String, String) -> String + printStat widthLbls widthTimes widthCounts (label, time, count) = + let fmt = concat + [ "%", show widthLbls + , "s: %", show widthTimes + , "ss count: %", show widthCounts, "s" + ] + in printf fmt (Text.pack label) time count + +--------------------- +-- TimeStats +--------------------- + +-- | A reference to a 'TimeStats' value +newtype TimeStatsRef = TimeStatsRef (IORef TimeStats) + +-- | Reports how much time (in nanoseconds) the invocations to 'measureM' took +-- for a given label and how many times it was invoked on a given label. +data TimeStats = TimeStats + { timeStat :: {-# UNPACK #-} !Word64 + , countStat :: {-# UNPACK #-} !Int + } + deriving Show + +-- | Measured time is 0 and call count is 0. +initialTimeStats :: TimeStats +initialTimeStats = TimeStats 0 0 + +-- | Creates a reference to time stats with intial values +newTimeStatsRef :: MonadIO m => m TimeStatsRef +newTimeStatsRef = liftIO $ TimeStatsRef <$> newIORef initialTimeStats + +-- | Measure the time it takes to run the given action and update with it +-- the given reference to time stats. +measureMWith :: MonadIO m => TimeStatsRef -> m a -> m a +measureMWith tref m = do + t0 <- liftIO getMonotonicTimeNSec + a <- m + liftIO $ do + tf <- getMonotonicTimeNSec + updateTimeStatsRef tref $ \st -> + st + { timeStat = (tf - t0) + timeStat st + , countStat = 1 + countStat st + } + return a + +-- | Updates the TimeStats in a TimeStatsRef +updateTimeStatsRef :: TimeStatsRef -> (TimeStats -> TimeStats) -> IO () +updateTimeStatsRef (TimeStatsRef ref) f = + atomicModifyIORef' ref $ \st -> (f st, ()) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,31 @@ +module Main where + +import Control.Exception (evaluate) +import Control.Monad (unless) +import qualified Data.Text.IO as Text +import qualified Debug.TimeStats as TimeStats +import System.Environment (setEnv) +import System.Exit (exitFailure) + +fib :: Int -> Int +fib n = if n < 2 then 1 else fib (n - 1) + fib (n - 2) + +main :: IO () +main = do + setEnv "DEBUG_TIMESTATS_ENABLE" "1" + _ <- TimeStats.measureM "fib" $ evaluate (fib 21) + _ <- TimeStats.measureM "fib2" $ evaluate (fib 20) + _ <- TimeStats.measureM "fib2" $ evaluate (fib 19) + xs <- TimeStats.collect + let expected = + [ ("fib", TimeStats.TimeStats 0 1) + , ("fib2", TimeStats.TimeStats 0 2) + ] + unless (eqStats xs expected) $ do + putStrLn "unexpected timestats:" + Text.putStrLn (TimeStats.asText xs) + exitFailure + where + eqStats xs ys = length xs == length ys && and (zipWith eqStat xs ys) + eqStat (lbl0, ts0) (lbl1, ts1) = + lbl0 == lbl1 && TimeStats.countStat ts0 == TimeStats.countStat ts1 diff --git a/timestats.cabal b/timestats.cabal new file mode 100644 --- /dev/null +++ b/timestats.cabal @@ -0,0 +1,48 @@ +cabal-version: 2.4 +name: timestats +version: 0.1.0 + +synopsis: A library for profiling time in Haskell applications +description: A simple library for profiling time that can help when more + sophisticated tools aren't available or needed. + +homepage: https://github.com/tweag/timestats +bug-reports: https://github.com/tweag/timestats/issues + +copyright: 2022 EURL Tweag +license: BSD-3-Clause +author: Facundo Domínguez +maintainer: facundo.dominguez@tweag.io + +category: Profiling +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/tweag/timestats + tag: v0.1.0 + +flag devel + default: False + manual: True + description: Enable more warnings and fail compilation when warnings occur. + Turn this flag on in CI. + +library + exposed-modules: Debug.TimeStats + build-depends: base >=4.14 && <5, containers, text + hs-source-dirs: src + default-language: Haskell2010 + if flag(devel) + ghc-options: -Wall -Werror + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: base, text, timestats + if flag(devel) + ghc-options: -Wall -Werror + hs-source-dirs: tests + default-language: Haskell2010