timestats (empty) → 0.1.0

raw patch · 5 files changed

+379/−0 lines, 5 filesdep +basedep +containersdep +text

Dependencies added: base, containers, text, timestats

Files

• CHANGELOG.md +5/−0
• README.md +48/−0
• src/Debug/TimeStats.hs +247/−0
• tests/Main.hs +31/−0
• timestats.cabal +48/−0

@@ -0,0 +1,5 @@+# Revision history for timestats++## 0.1.0 -- 2022-07-12++* First version.

@@ -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).+

@@ -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, ())

@@ -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

@@ -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