packages feed

ekg-core (empty) → 0.1.0.0

raw patch · 19 files changed

+1258/−0 lines, 19 filesdep +basedep +containersdep +ekg-coresetup-changed

Dependencies added: base, containers, ekg-core, ghc-prim, text, unordered-containers

Files

+ CHANGES.md view
@@ -0,0 +1,3 @@+## 0.1.0.0 (2013-05-01)++ * Initial release.
+ Data/Array.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE BangPatterns, MagicHash, Rank2Types, UnboxedTuples #-}++-- | Zero based arrays.+--+-- Note that no bounds checking are performed.+module Data.Array+    ( Array+    , length+    , index+    , fromList+    , toList+    ) where++import Control.Monad.ST+import GHC.Exts (Array#, Int(..), MutableArray#, indexArray#, newArray#,+                 sizeofArray#, sizeofMutableArray#, unsafeFreezeArray#,+                 writeArray#)+import GHC.ST (ST(..))+import Prelude hiding (foldr, length)++data Array a = Array { unArray :: !(Array# a) }++length :: Array a -> Int+length ary = I# (sizeofArray# (unArray ary))+{-# INLINE length #-}++-- | Smart constructor+array :: Array# a -> Int -> Array a+array ary _n = Array ary+{-# INLINE array #-}++data MArray s a = MArray {+      unMArray :: !(MutableArray# s a)+    }++lengthM :: MArray s a -> Int+lengthM mary = I# (sizeofMutableArray# (unMArray mary))+{-# INLINE lengthM #-}++-- | Smart constructor+marray :: MutableArray# s a -> Int -> MArray s a+marray mary _n = MArray mary+{-# INLINE marray #-}++new :: Int -> a -> ST s (MArray s a)+new n@(I# n#) b =+    ST $ \s ->+        case newArray# n# b s of+            (# s', ary #) -> (# s', marray ary n #)+{-# INLINE new #-}++new_ :: Int -> ST s (MArray s a)+new_ n = new n undefinedElem++write :: MArray s a -> Int -> a -> ST s ()+write ary _i@(I# i#) b = ST $ \ s ->+    case writeArray# (unMArray ary) i# b s of+        s' -> (# s' , () #)+{-# INLINE write #-}++index :: Array a -> Int -> a+index ary _i@(I# i#) =+    case indexArray# (unArray ary) i# of (# b #) -> b+{-# INLINE index #-}++unsafeFreeze :: MArray s a -> ST s (Array a)+unsafeFreeze mary+    = ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of+        (# s', ary #) -> (# s', array ary (lengthM mary) #)+{-# INLINE unsafeFreeze #-}++run :: (forall s . ST s (MArray s e)) -> Array e+run act = runST $ act >>= unsafeFreeze+{-# INLINE run #-}++undefinedElem :: a+undefinedElem = error "Data.HashMap.Array: Undefined element"+{-# NOINLINE undefinedElem #-}++fromList :: Int -> [a] -> Array a+fromList n xs0 = run $ do+    mary <- new_ n+    go xs0 mary 0+  where+    go [] !mary !_   = return mary+    go (x:xs) mary i = do write mary i x+                          go xs mary (i+1)++toList :: Array a -> [a]+toList = foldr (:) []++foldr :: (a -> b -> b) -> b -> Array a -> b+foldr f = \ z0 ary0 -> go ary0 (length ary0) 0 z0+  where+    go ary n i z+        | i >= n    = z+        | otherwise = f (index ary i) (go ary n (i+1) z)+{-# INLINE foldr #-}
+ Data/Atomic.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE BangPatterns, ForeignFunctionInterface #-}+-- | An atomic integer value. All operations are thread safe.+module Data.Atomic+    (+      Atomic+    , new+    , read+    , write+    , inc+    , dec+    , add+    , subtract+    ) where++import Data.Int (Int64)+import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr, withForeignPtr)+import Foreign.Ptr (Ptr)+import Foreign.Storable (poke)+import Prelude hiding (read, subtract)++-- | A mutable, atomic integer.+newtype Atomic = C (ForeignPtr Int64)++-- | Create a new, zero initialized, atomic.+new :: Int64 -> IO Atomic+new n = do+    fp <- mallocForeignPtr+    withForeignPtr fp $ \ p -> poke p n+    return $ C fp++read :: Atomic -> IO Int64+read (C fp) = withForeignPtr fp cRead++foreign import ccall unsafe "hs_atomic_read" cRead :: Ptr Int64 -> IO Int64++-- | Set the atomic to the given value.+write :: Atomic -> Int64 -> IO ()+write (C fp) n = withForeignPtr fp $ \ p -> cWrite p n++foreign import ccall unsafe "hs_atomic_write" cWrite+    :: Ptr Int64 -> Int64 -> IO ()++-- | Increase the atomic by one.+inc :: Atomic -> IO ()+inc atomic = add atomic 1++-- | Decrease the atomic by one.+dec :: Atomic -> IO ()+dec atomic = subtract atomic 1++-- | Increase the atomic by the given amount.+add :: Atomic -> Int64 -> IO ()+add (C fp) n = withForeignPtr fp $ \ p -> cAdd p n++-- | Decrease the atomic by the given amount.+subtract :: Atomic -> Int64 -> IO ()+subtract (C fp) n = withForeignPtr fp $ \ p -> cSubtract p n++-- | Increase the atomic by the given amount.+foreign import ccall unsafe "hs_atomic_add" cAdd :: Ptr Int64 -> Int64 -> IO ()++-- | Increase the atomic by the given amount.+foreign import ccall unsafe "hs_atomic_subtract" cSubtract+    :: Ptr Int64 -> Int64 -> IO ()
+ Data/Mutex.hs view
@@ -0,0 +1,29 @@+module Data.Mutex+    ( Mutex+    , new+    , lock+    , unlock+    ) where++import Data.Int (Int64)+import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr, withForeignPtr)+import Foreign.Ptr (Ptr)+import Foreign.Storable (poke)++newtype Mutex = M { unM :: ForeignPtr Int64 }++new :: IO Mutex+new = do+    fp <- mallocForeignPtr+    withForeignPtr fp $ \ p -> poke p 0+    return $ M fp++lock :: Mutex -> IO ()+lock m = withForeignPtr (unM m) cLock++foreign import ccall unsafe "hs_lock" cLock :: Ptr Int64 -> IO ()++unlock :: Mutex -> IO ()+unlock m = withForeignPtr (unM m) cUnlock++foreign import ccall unsafe "hs_unlock" cUnlock :: Ptr Int64 -> IO ()
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Johan Tibell++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 Johan Tibell 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/Metrics.hs view
@@ -0,0 +1,535 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+-- | A module for defining metrics that can be monitored.+--+-- Metrics are used to monitor program behavior and performance. All+-- metrics have+--+--  * a name, and+--+--  * a way to get the metric's current value.+--+-- This module provides a way to register metrics in a global \"metric+-- store\". The store can then be used to get a snapshot of all+-- metrics. The store also serves as a central place to keep track of+-- all the program's metrics, both user and library defined.+--+-- Here's an example of creating a single counter, used to count the+-- number of request served by a web server:+--+-- > import System.Metrics+-- > import qualified System.Metrics.Counter as Counter+-- >+-- > main = do+-- >     store <- newStore+-- >     requests <- createCounter "myapp.request_count" store+-- >     -- Every time we receive a request:+-- >     Counter.inc requests+--+-- This module also provides a way to register a number of predefined+-- metrics that are useful in most applications. See e.g.+-- 'registerGcMetrics'.+module System.Metrics+    (+      -- * Naming metrics+      -- $naming++      -- * The metric store+      -- $metric-store+      Store+    , newStore++      -- * Registering metrics+      -- $registering+    , registerCounter+    , registerGauge+    , registerLabel+    , registerDistribution+    , registerGroup++      -- ** Convenience functions+      -- $convenience+    , createCounter+    , createGauge+    , createLabel+    , createDistribution++      -- ** Predefined metrics+      -- $predefined+    , registerGcMetrics++      -- * Sampling metrics+      -- $sampling+    , Sample+    , sampleAll+    , Value(..)+    ) where++import Control.Applicative ((<$>))+import Control.Monad (forM)+import Data.Int (Int64)+import qualified Data.IntMap.Strict as IM+import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef)+import qualified Data.HashMap.Strict as M+import qualified Data.Text as T+import qualified GHC.Stats as Stats+import Prelude hiding (read)++import System.Metrics.Counter (Counter)+import qualified System.Metrics.Counter as Counter+import System.Metrics.Distribution (Distribution)+import qualified System.Metrics.Distribution as Distribution+import System.Metrics.Gauge (Gauge)+import qualified System.Metrics.Gauge as Gauge+import System.Metrics.Label (Label)+import qualified System.Metrics.Label as Label++-- $naming+-- Compound metric names should be separated using underscores.+-- Example: @request_count@. Periods in the name imply namespacing.+-- Example: @\"myapp.users\"@. Some consumers of metrics will use+-- these namespaces to group metrics in e.g. UIs.+--+-- Libraries and frameworks that want to register their own metrics+-- should prefix them with a namespace, to avoid collision with+-- user-defined metrics and metrics defined by other libraries. For+-- example, the Snap web framework could prefix all its metrics with+-- @\"snap.\"@.+--+-- It's customary to suffix the metric name with a short string+-- explaining the metric's type e.g. using @\"_ms\"@ to denote+-- milliseconds.++------------------------------------------------------------------------+-- * The metric store++-- $metric-store+-- The metric store is a shared store of metrics. It allows several+-- disjoint components (e.g. libraries) to contribute to the set of+-- metrics exposed by an application. Libraries that want to provide a+-- set of metrics should defined a register method, in the style of+-- 'registerGcMetrics', that registers the metrics in the 'Store'. The+-- register function should document which metrics are registered and+-- their types (i.e. counter, gauge, label, or distribution).++-- | A mutable metric store.+newtype Store = Store { storeState :: IORef State }++type GroupId = Int++-- | The 'Store' state.+data State = State+     { stateMetrics :: !(M.HashMap T.Text (Either MetricSampler GroupId))+     , stateGroups  :: !(IM.IntMap GroupSampler)+     , stateNextId  :: {-# UNPACK #-} !Int+     }++data GroupSampler = forall a. GroupSampler+     { groupSampleAction   :: !(IO a)+     , groupSamplerMetrics :: !(M.HashMap T.Text (a -> Value))+     }++-- TODO: Rename this to Metric and Metric to SampledMetric.+data MetricSampler = CounterS !(IO Int64)+                   | GaugeS !(IO Int64)+                   | LabelS !(IO T.Text)+                   | DistributionS !(IO Distribution.Stats)++-- | Create a new, empty metric store.+newStore :: IO Store+newStore = do+    state <- newIORef $ State M.empty IM.empty 0+    return $ Store state++------------------------------------------------------------------------+-- * Registering metrics++-- $registering+-- Before metrics can be sampled they need to be registered with the+-- metric store. The same metric name can only be used once. Passing a+-- metric name that has already been used to one of the register+-- function is an 'error'.++-- | Register a non-negative, monotonically increasing, integer-valued+-- metric. The provided action to read the value must be thread-safe.+-- Also see 'createCounter'.+registerCounter :: T.Text    -- ^ Counter name+                -> IO Int64  -- ^ Action to read the current metric value+                -> Store     -- ^ Metric store+                -> IO ()+registerCounter name sample store =+    register name (CounterS sample) store++-- | Register an integer-valued metric. The provided action to read+-- the value must be thread-safe. Also see 'createGauge'.+registerGauge :: T.Text    -- ^ Gauge name+              -> IO Int64  -- ^ Action to read the current metric value+              -> Store     -- ^ Metric store+              -> IO ()+registerGauge name sample store =+    register name (GaugeS sample) store++-- | Register a text metric. The provided action to read the value+-- must be thread-safe. Also see 'createLabel'.+registerLabel :: T.Text     -- ^ Label name+              -> IO T.Text  -- ^ Action to read the current metric value+              -> Store      -- ^ Metric store+              -> IO ()+registerLabel name sample store =+    register name (LabelS sample) store++-- | Register a distribution metric. The provided action to read the+-- value must be thread-safe. Also see 'createDistribution'.+registerDistribution+    :: T.Text                 -- ^ Distribution name+    -> IO Distribution.Stats  -- ^ Action to read the current metric+                              -- value+    -> Store                  -- ^ Metric store+    -> IO ()+registerDistribution name sample store =+    register name (DistributionS sample) store++register :: T.Text+         -> MetricSampler+         -> Store+         -> IO ()+register name sample store = do+    atomicModifyIORef (storeState store) $ \ state@State{..} ->+        case M.member name stateMetrics of+            False -> let !state' = state {+                               stateMetrics = M.insert name+                                              (Left sample)+                                              stateMetrics+                             }+                     in (state', ())+            True  -> alreadyInUseError name++-- | Raise an exception indicating that the metric name is already in+-- use.+alreadyInUseError :: T.Text -> a+alreadyInUseError name =+    error $ "The name \"" ++ show name ++ "\" is already taken " +++    "by a metric."++-- | Register an action that will be executed any time one of the+-- metrics computed from the value it returns needs to be sampled.+--+-- When one or more of the metrics listed in the first argument needs+-- to be sampled, the action is executed and the provided getter+-- functions will be used to extract the metric(s) from the action's+-- return value.+--+-- The registered action might be called from a different thread and+-- therefore needs to be thread-safe.+--+-- This function allows you to sample groups of metrics together. This+-- is useful if+--+-- * you need a consistent view of several metric or+--+-- * sampling the metrics together is more efficient.+--+-- For example, sampling GC statistics needs to be done atomically or+-- a GC might strike in the middle of sampling, rendering the values+-- incoherent. Sampling GC statistics is also more efficient if done+-- in \"bulk\", as the run-time system provides a function to sample all+-- GC statistics at once.+--+-- Note that sampling of the metrics is only atomic if the provided+-- action computes @a@ atomically (e.g. if @a@ is a record, the action+-- needs to compute its fields atomically if the sampling is to be+-- atomic.)+--+-- Example usage:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import qualified Data.HashMap.Strict as M+-- > import GHC.Stats+-- > import System.Metrics+-- >+-- > main = do+-- >     store <- newStore+-- >     let metrics =+-- >             [ ("num_gcs", Counter . numGcs)+-- >             , ("max_bytes_used", Gauge . maxBytesUsed)+-- >             ]+-- >     registerGroup (M.fromList metrics) getGCStats store+registerGroup+    :: M.HashMap T.Text+       (a -> Value)  -- ^ Metric names and getter functions.+    -> IO a          -- ^ Action to sample the metric group+    -> Store         -- ^ Metric store+    -> IO ()+registerGroup getters cb store = do+    atomicModifyIORef (storeState store) $ \ State{..} ->+        let !state' = State+                { stateMetrics = M.foldlWithKey' (register_ stateNextId)+                                 stateMetrics getters+                , stateGroups  = IM.insert stateNextId+                                 (GroupSampler cb getters)+                                 stateGroups+                , stateNextId  = stateNextId + 1+                }+       in (state', ())+  where+    register_ groupId metrics name _ = case M.lookup name metrics of+        Nothing -> M.insert name (Right groupId) metrics+        Just _  -> alreadyInUseError name++------------------------------------------------------------------------+-- ** Convenience functions++-- $convenience+-- These functions combined the creation of a mutable reference (e.g.+-- a 'Counter') with registering that reference in the store in one+-- convenient function.++-- | Create and register a zero-initialized counter.+createCounter :: T.Text  -- ^ Counter name+              -> Store   -- ^ Metric store+              -> IO Counter+createCounter name store = do+    counter <- Counter.new+    registerCounter name (Counter.read counter) store+    return counter++-- | Create and register a zero-initialized gauge.+createGauge :: T.Text  -- ^ Gauge name+            -> Store   -- ^ Metric store+            -> IO Gauge+createGauge name store = do+    gauge <- Gauge.new+    registerGauge name (Gauge.read gauge) store+    return gauge++-- | Create and register an empty label.+createLabel :: T.Text  -- ^ Label name+            -> Store   -- ^ Metric store+            -> IO Label+createLabel name store = do+    label <- Label.new+    registerLabel name (Label.read label) store+    return label++-- | Create and register an event tracker.+createDistribution :: T.Text  -- ^ Distribution name+                   -> Store   -- ^ Metric store+                   -> IO Distribution+createDistribution name store = do+    event <- Distribution.new+    registerDistribution name (Distribution.read event) store+    return event++------------------------------------------------------------------------+-- * Predefined metrics++-- $predefined+-- This library provides a number of pre-defined metrics that can+-- easily be added to a metrics store by calling their register+-- function.++-- | Convert seconds to milliseconds.+toMs :: Double -> Int64+toMs s = round (s * 1000.0)++-- | Register a number of metrics related to garbage collector+-- behavior.+--+-- To enable GC statistics collection, either run your program with+--+-- > +RTS -T+--+-- or compile it with+--+-- > -with-rtsopts=-T+--+-- The runtime overhead of @-T@ is very small so it's safe to always+-- leave it enabled.+--+-- Registered counters:+--+-- [@rts.gc.bytes_allocated@] Total number of bytes allocated+--+-- [@rts.gc.num_gcs@] Number of garbage collections performed+--+-- [@rts.gc.num_bytes_usage_samples@] Number of byte usage samples taken+--+-- [@rts.gc.cumulative_bytes_used@] Sum of all byte usage samples, can be+-- used with @numByteUsageSamples@ to calculate averages with+-- arbitrary weighting (if you are sampling this record multiple+-- times).+--+-- [@rts.gc.bytes_copied@] Number of bytes copied during GC+--+-- [@rts.gc.mutator_cpu_ms@] CPU time spent running mutator threads,+-- in milliseconds. This does not include any profiling overhead or+-- initialization.+--+-- [@rts.gc.mutator_wall_ms@] Wall clock time spent running mutator+-- threads, in milliseconds. This does not include initialization.+--+-- [@rts.gc.gc_cpu_ms@] CPU time spent running GC, in milliseconds.+--+-- [@rts.gc.gc_wall_ms@] Wall clock time spent running GC, in+-- milliseconds.+--+-- [@rts.gc.cpu_ms@] Total CPU time elapsed since program start, in+-- milliseconds.+--+-- [@rts.gc.wall_ms@] Total wall clock time elapsed since start, in+-- milliseconds.+--+-- Registered gauges:+--+-- [@rts.gc.max_bytes_used@] Maximum number of live bytes seen so far+--+-- [@rts.gc.current_bytes_used@] Current number of live bytes+--+-- [@rts.gc.current_bytes_slop@] Current number of bytes lost to slop+--+-- [@rts.gc.max_bytes_slop@] Maximum number of bytes lost to slop at any one time so far+--+-- [@rts.gc.peak_megabytes_allocated@] Maximum number of megabytes allocated+--+-- [@rts.gc.par_tot_bytes_copied@] Number of bytes copied during GC, minus+-- space held by mutable lists held by the capabilities.  Can be used+-- with 'parMaxBytesCopied' to determine how well parallel GC utilized+-- all cores.+--+-- [@rts.gc.par_avg_bytes_copied@] Deprecated alias for+-- @par_tot_bytes_copied@.+--+-- [@rts.gc.par_max_bytes_copied@] Sum of number of bytes copied each GC by+-- the most active GC thread each GC. The ratio of+-- @par_tot_bytes_copied@ divided by @par_max_bytes_copied@ approaches+-- 1 for a maximally sequential run and approaches the number of+-- threads (set by the RTS flag @-N@) for a maximally parallel run.+registerGcMetrics :: Store -> IO ()+registerGcMetrics store =+    registerGroup+    (M.fromList+     [ ("rts.gc.bytes_allocated"          , Counter . Stats.bytesAllocated)+     , ("rts.gc.num_gcs"                  , Counter . Stats.numGcs)+     , ("rts.gc.num_bytes_usage_samples"  , Counter . Stats.numByteUsageSamples)+     , ("rts.gc.cumulative_bytes_used"    , Counter . Stats.cumulativeBytesUsed)+     , ("rts.gc.bytes_copied"             , Counter . Stats.bytesCopied)+     , ("rts.gc.mutator_cpu_ms"           , Counter . toMs . Stats.mutatorCpuSeconds)+     , ("rts.gc.mutator_wall_ms"          , Counter . toMs . Stats.mutatorWallSeconds)+     , ("rts.gc.gc_cpu_ms"                , Counter . toMs . Stats.gcCpuSeconds)+     , ("rts.gc.gc_wall_ms"               , Counter . toMs . Stats.gcWallSeconds)+     , ("rts.gc.cpu_ms"                   , Counter . toMs . Stats.cpuSeconds)+     , ("rts.gc.wall_ms"                  , Counter . toMs . Stats.wallSeconds)+     , ("rts.gc.max_bytes_used"           , Gauge . Stats.maxBytesUsed)+     , ("rts.gc.current_bytes_used"       , Gauge . Stats.currentBytesUsed)+     , ("rts.gc.current_bytes_slop"       , Gauge . Stats.currentBytesSlop)+     , ("rts.gc.max_bytes_slop"           , Gauge . Stats.maxBytesSlop)+     , ("rts.gc.peak_megabytes_allocated" , Gauge . Stats.peakMegabytesAllocated)+     , ("rts.gc.par_tot_bytes_copied"     , Gauge . gcParTotBytesCopied)+     , ("rts.gc.par_avg_bytes_copied"     , Gauge . gcParTotBytesCopied)+     , ("rts.gc.par_max_bytes_copied"     , Gauge . Stats.parMaxBytesCopied)+     ])+    getGcStats+    store++-- | Get GC statistics.+getGcStats :: IO Stats.GCStats+#if MIN_VERSION_base(4,6,0)+getGcStats = do+    enabled <- Stats.getGCStatsEnabled+    if enabled+        then Stats.getGCStats+        else return emptyGCStats++-- | Empty GC statistics, as if the application hasn't started yet.+emptyGCStats :: Stats.GCStats+emptyGCStats = Stats.GCStats+    { bytesAllocated         = 0+    , numGcs                 = 0+    , maxBytesUsed           = 0+    , numByteUsageSamples    = 0+    , cumulativeBytesUsed    = 0+    , bytesCopied            = 0+    , currentBytesUsed       = 0+    , currentBytesSlop       = 0+    , maxBytesSlop           = 0+    , peakMegabytesAllocated = 0+    , mutatorCpuSeconds      = 0+    , mutatorWallSeconds     = 0+    , gcCpuSeconds           = 0+    , gcWallSeconds          = 0+    , cpuSeconds             = 0+    , wallSeconds            = 0+    , parTotBytesCopied      = 0+    , parMaxBytesCopied      = 0+    }+#else+getGcStats = Stats.getGCStats+#endif++-- | Helper to work around rename in GHC.Stats in base-4.6.+gcParTotBytesCopied :: Stats.GCStats -> Int64+#if MIN_VERSION_base(4,6,0)+gcParTotBytesCopied = Stats.parTotBytesCopied+#else+gcParTotBytesCopied = Stats.parAvgBytesCopied+#endif++------------------------------------------------------------------------+-- * Sampling metrics++-- $sampling+-- The metrics register in the store can be sampled together. Sampling+-- is /not/ atomic. While each metric will be retrieved atomically,+-- the sample is not an atomic snapshot of the system as a whole. See+-- 'registerGroup' for an explanation of how to sample a subset of all+-- metrics atomically.++-- | A sample of some metrics.+type Sample = M.HashMap T.Text Value++-- | Sample all metrics. Sampling is /not/ atomic in the sense that+-- some metrics might have been mutated before they're sampled but+-- after some other metrics have already been sampled.+sampleAll :: Store -> IO Sample+sampleAll store = do+    state <- readIORef (storeState store)+    let metrics = stateMetrics state+        groups = stateGroups state+    cbSample <- sampleGroups $ IM.elems groups+    sample <- readAllRefs metrics+    let allSamples = sample ++ cbSample+    return $! M.fromList allSamples++-- | Sample all metric groups.+sampleGroups :: [GroupSampler] -> IO [(T.Text, Value)]+sampleGroups cbSamplers = concat `fmap` sequence (map runOne cbSamplers)+  where+    runOne :: GroupSampler -> IO [(T.Text, Value)]+    runOne GroupSampler{..} = do+        a <- groupSampleAction+        return $! map (\ (n, f) -> (n, f a)) (M.toList groupSamplerMetrics)++-- | The value of a sampled metric.+data Value = Counter {-# UNPACK #-} !Int64+           | Gauge {-# UNPACK #-} !Int64+           | Label {-# UNPACK #-} !T.Text+           | Distribution !Distribution.Stats+           deriving Show++sampleOne :: MetricSampler -> IO Value+sampleOne (CounterS m)      = Counter <$> m+sampleOne (GaugeS m)        = Gauge <$> m+sampleOne (LabelS m)        = Label <$> m+sampleOne (DistributionS m) = Distribution <$> m++-- | Get a snapshot of all values.  Note that we're not guaranteed to+-- see a consistent snapshot of the whole map.+readAllRefs :: M.HashMap T.Text (Either MetricSampler GroupId)+            -> IO [(T.Text, Value)]+readAllRefs m = do+    forM ([(name, ref) | (name, Left ref) <- M.toList m]) $ \ (name, ref) -> do+        val <- sampleOne ref+        return (name, val)
+ System/Metrics/Counter.hs view
@@ -0,0 +1,35 @@+-- | This module defines a type for mutable, integer-valued counters.+-- Counters are non-negative, monotonically increasing values and can+-- be used to track e.g. the number of requests served since program+-- start.  All operations on counters are thread-safe.+module System.Metrics.Counter+    (+      Counter+    , new+    , read+    , inc+    , add+    ) where++import qualified Data.Atomic as Atomic+import Data.Int (Int64)+import Prelude hiding (read)++-- | A mutable, integer-valued counter.+newtype Counter = C { unC :: Atomic.Atomic }++-- | Create a new, zero initialized, counter.+new :: IO Counter+new = C `fmap` Atomic.new 0++-- | Get the current value of the counter.+read :: Counter -> IO Int64+read = Atomic.read . unC++-- | Increase the counter by one.+inc :: Counter -> IO ()+inc counter = add counter 1++-- | Add the argument to the counter.+add :: Counter -> Int64 -> IO ()+add counter = Atomic.add (unC counter)
+ System/Metrics/Distribution.hsc view
@@ -0,0 +1,175 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++#include "distrib.h"++-- | This module defines a type for tracking statistics about a series+-- of events. An event could be handling of a request and the value+-- associated with the event -- the value you'd pass to 'add' -- could+-- be the amount of time spent serving that request (e.g. in+-- milliseconds). All operations are thread safe.+module System.Metrics.Distribution+    ( Distribution+    , new+    , add+    , addN+    , read++      -- * Gathered statistics+    , Stats+    , mean+    , variance+    , count+    , sum+    , min+    , max+    ) where++import Control.Monad (forM_, replicateM)+import Data.Int (Int64)+import Foreign.C.Types (CInt)+import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtr, withForeignPtr)+import Foreign.Ptr (Ptr)+import Foreign.Storable (Storable(alignment, peek, poke, sizeOf), peekByteOff,+                         pokeByteOff)+import Prelude hiding (max, min, read, sum)++import Data.Array+import qualified Data.Mutex as Mutex+import System.Metrics.ThreadId++-- | An metric for tracking events.+newtype Distribution = Distribution { unD :: Array Stripe }++data Stripe = Stripe+    { stripeFp    :: !(ForeignPtr CDistrib)+    , stripeMutex :: !Mutex.Mutex+    }++-- | Perform action with lock held. Not exception safe.+withMutex :: Mutex.Mutex -> IO a -> IO a+withMutex lock m = do+    Mutex.lock lock+    a <- m+    Mutex.unlock lock+    return a++data CDistrib = CDistrib+    { cCount      :: !Int64+    , cMean       :: !Double+    , cSumSqDelta :: !Double+    , cSum        :: !Double+    , cMin        :: !Double+    , cMax        :: !Double+    }++instance Storable CDistrib where+    sizeOf _ = (#size struct distrib)+    alignment _ = alignment (undefined :: CInt)++    peek p = do+        cCount <- (#peek struct distrib, count) p+        cMean <- (#peek struct distrib, mean) p+        cSumSqDelta <- (#peek struct distrib, sum_sq_delta) p+        cSum <- (#peek struct distrib, sum) p+        cMin <- (#peek struct distrib, min) p+        cMax <- (#peek struct distrib, max) p+        return $! CDistrib+            { cCount      = cCount+            , cMean       = cMean+            , cSumSqDelta = cSumSqDelta+            , cSum        = cSum+            , cMin        = cMin+            , cMax        = cMax+            }++    poke p CDistrib{..} = do+        (#poke struct distrib, count) p cCount+        (#poke struct distrib, mean) p cMean+        (#poke struct distrib, sum_sq_delta) p cSumSqDelta+        (#poke struct distrib, sum) p cSum+        (#poke struct distrib, min) p cMin+        (#poke struct distrib, max) p cMax++newCDistrib :: IO (ForeignPtr CDistrib)+newCDistrib = do+    fp <- mallocForeignPtr+    withForeignPtr fp $ \ p -> poke p $ CDistrib 0 0.0 0.0 0.0 0.0 0.0+    return fp++newStripe :: IO Stripe+newStripe = do+    fp <- newCDistrib+    mutex <- Mutex.new+    return $! Stripe+        { stripeFp    = fp+        , stripeMutex = mutex+        }++-- | Number of lock stripes. Should be greater or equal to the number+-- of HECs.+numStripes :: Int+numStripes = 8++-- | Get the stripe to use for this thread.+myStripe :: Distribution -> IO Stripe+myStripe distrib = do+    tid <- myCapability+    return $! unD distrib `index` (tid `mod` numStripes)++------------------------------------------------------------------------+-- Exposed API++-- | Create a new distribution.+new :: IO Distribution+new = (Distribution . fromList numStripes) `fmap`+      replicateM numStripes newStripe++-- | Add a value to the distribution.+add :: Distribution -> Double -> IO ()+add distrib val = addN distrib val 1++foreign import ccall unsafe "hs_distrib_add_n" cDistribAddN+    :: Ptr CDistrib -> Double -> Int64 -> IO ()++-- | Add the same value to the distribution N times.+addN :: Distribution -> Double -> Int64 -> IO ()+addN distrib val n = do+    stripe <- myStripe distrib+    withForeignPtr (stripeFp stripe) $ \ p ->+        withMutex (stripeMutex stripe) $ cDistribAddN p val n++foreign import ccall unsafe "hs_distrib_combine" combine+    :: Ptr CDistrib -> Ptr CDistrib -> IO ()++-- | Get the current statistical summary for the event being tracked.+read :: Distribution -> IO Stats+read distrib = do+    result <- newCDistrib+    CDistrib{..} <- withForeignPtr result $ \ resultp -> do+        forM_ (toList $ unD distrib) $ \ stripe ->+            withForeignPtr (stripeFp stripe) $ \ p ->+            withMutex (stripeMutex stripe) $+            combine p resultp+        peek resultp+    return $! Stats+        { mean  = cMean+        , variance = if cCount == 0 then 0.0+                     else cSumSqDelta / fromIntegral cCount+        , count = cCount+        , sum   = cSum+        , min   = cMin+        , max   = cMax+        }++-- | Distribution statistics+data Stats = Stats+    { mean     :: !Double  -- ^ Sample mean+    , variance :: !Double  -- ^ Biased sample variance+    , count    :: !Int64   -- ^ Event count+    , sum      :: !Double  -- ^ Sum of values+    , min      :: !Double  -- ^ Min value seen+    , max      :: !Double  -- ^ Max value seen+    } deriving Show
+ System/Metrics/Gauge.hs view
@@ -0,0 +1,50 @@+-- | This module defines a type for mutable, integer-valued gauges.+-- Gauges are variable values and can be used to track e.g. the+-- current number of concurrent connections. All operations on gauges+-- are thread-safe.+module System.Metrics.Gauge+    (+      Gauge+    , new+    , read+    , inc+    , dec+    , add+    , subtract+    , set+    ) where++import qualified Data.Atomic as Atomic+import Data.Int (Int64)+import Prelude hiding (subtract, read)++-- | A mutable, integer-valued gauge.+newtype Gauge = C { unC :: Atomic.Atomic }++-- | Create a new, zero initialized, gauge.+new :: IO Gauge+new = C `fmap` Atomic.new 0++-- | Get the current value of the gauge.+read :: Gauge -> IO Int64+read = Atomic.read . unC++-- | Increase the gauge by one.+inc :: Gauge -> IO ()+inc gauge = add gauge 1++-- | Decrease the gauge by one.+dec :: Gauge -> IO ()+dec gauge = subtract gauge 1++-- | Increase the gauge by the given amount.+add :: Gauge -> Int64 -> IO ()+add gauge = Atomic.add (unC gauge)++-- | Decrease the gauge by the given amount.+subtract :: Gauge -> Int64 -> IO ()+subtract gauge = Atomic.subtract (unC gauge)++-- | Set the gauge to the given value.+set :: Gauge -> Int64 -> IO ()+set gauge = Atomic.write (unC gauge)
+ System/Metrics/Label.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE BangPatterns #-}+-- | This module defines a type for mutable, string-valued labels.+-- Labels are variable values and can be used to track e.g. the+-- command line arguments or other free-form values. All operations on+-- labels are thread-safe.+module System.Metrics.Label+    (+      Label+    , new+    , read+    , set+    , modify+    ) where++import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef)+import qualified Data.Text as T+import Prelude hiding (read)++-- | A mutable, text-valued label.+newtype Label = C { unC :: IORef T.Text }++-- | Create a new empty label.+new :: IO Label+new = C `fmap` newIORef T.empty++-- | Get the current value of the label.+read :: Label -> IO T.Text+read = readIORef . unC++-- | Set the label to the given value.+set :: Label -> T.Text -> IO ()+set (C ref) !i = atomicModifyIORef ref $ \ _ -> (i, ())++-- | Set the label to the result of applying the given function to the+-- value.+modify :: (T.Text -> T.Text) -> Label -> IO ()+modify f (C ref) = do+    !_ <- atomicModifyIORef ref $ \ i -> let i' = f i in (i', i')+    return ()
+ System/Metrics/ThreadId.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash #-}+module System.Metrics.ThreadId+    ( myCapability+    ) where++import qualified Control.Concurrent as Concurrent++myCapability :: IO Int+myCapability = (return . fst) =<< Concurrent.threadCapability =<<+               Concurrent.myThreadId+
+ benchmarks/Counter.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}++-- | Perform 100,000 atomic increments using 100 concurrent writers.+module Main where++import Control.Concurrent+import Control.Monad+import System.Metrics.Counter++main :: IO ()+main = do+    counter <- new+    locks <- replicateM n newEmptyMVar+    mapM_ (forkIO . work counter iters) locks+    mapM_ takeMVar locks+  where+    n = 100+    iters = 100000++    work :: Counter -> Int -> MVar () -> IO ()+    work !_ 0 !lock     = putMVar lock ()+    work counter i lock = inc counter >> work counter (i - 1) lock
+ benchmarks/Distribution.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}++-- | Perform 100,000 atomic sample additions using 100 concurrent+-- writers.+module Main where++import Control.Concurrent+import Control.Monad+import System.Metrics.Distribution++main :: IO ()+main = do+    distrib <- new+    locks <- replicateM n newEmptyMVar+    mapM_ (forkIO . work distrib iters) locks+    mapM_ takeMVar locks+  where+    n = 100+    iters = 100000++    work :: Distribution -> Int -> MVar () -> IO ()+    work !_ 0 !lock     = putMVar lock ()+    work distrib i lock = add distrib 1.0 >> work distrib (i - 1) lock
+ cbits/atomic.c view
@@ -0,0 +1,17 @@+#include "HsFFI.h"++void hs_atomic_add(volatile StgInt64* atomic, StgInt64 n) {+  __sync_fetch_and_add(atomic, n);+}++void hs_atomic_subtract(volatile StgInt64* atomic, StgInt64 n) {+  __sync_fetch_and_sub(atomic, n);+}++StgInt64 hs_atomic_read(volatile const StgInt64* atomic) {+  return *atomic;+}++void hs_atomic_write(volatile StgInt64* atomic, StgInt64 n) {+  *atomic = n;+}
+ cbits/distrib.c view
@@ -0,0 +1,32 @@+#include "HsFFI.h"+#include "distrib.h"++// Mean and variance are computed according to+// http://en.wikipedia.org/wiki/Algorithms_for_calculating_variance#Online_algorithm+void hs_distrib_add_n(struct distrib* distrib, StgDouble val, StgInt64 n) {+  const StgInt64 count = distrib->count + n;+  const StgDouble delta = val - distrib->mean;+  const StgDouble mean = distrib->mean + n * delta / count;+  const StgDouble sum_sq_delta = distrib->sum_sq_delta + delta * (val - mean) * n;+  distrib->count = count;+  distrib->mean = mean;+  distrib->sum_sq_delta = sum_sq_delta;+  distrib->sum += val;+  distrib->min = val < distrib->min ? val : distrib->min;+  distrib->max = val > distrib->max ? val : distrib->max;+}++// http://en.wikipedia.org/wiki/Algorithms_for_calculating_variance#Parallel_algorithm+void hs_distrib_combine(const struct distrib* b, struct distrib* a) {+  const StgInt64 count = a->count + b->count;+  const StgDouble delta = b->mean - a->mean;+  const StgDouble mean = (a->count * a->mean + b->count * b->mean) / count;+  const StgDouble sum_sq_delta = (a->sum_sq_delta + b->sum_sq_delta ++                                  delta * delta * (a->count * b->count) / count);+  a->count = count;+  a->mean = mean;+  a->sum_sq_delta = sum_sq_delta;+  a->sum = a->sum + b->sum;+  a->min = b->min < a->min ? b->min : a->min;+  a->max = b->max > a->max ? b->max : a->max;+}
+ cbits/distrib.h view
@@ -0,0 +1,14 @@+#include "HsFFI.h"++struct distrib {+  StgInt64 count;+  StgDouble mean;+  StgDouble sum_sq_delta;+  StgDouble sum;+  StgDouble min;+  StgDouble max;+};++void hs_distrib_add_n(struct distrib* distrib, StgDouble val, StgInt64 n);++void hs_distrib_combine(const struct distrib* b, struct distrib* a);
+ cbits/mutex.c view
@@ -0,0 +1,9 @@+#include "HsFFI.h"++void hs_lock(volatile StgInt64* lock) {+  while(!__sync_bool_compare_and_swap(lock, 0, 1));+}++void hs_unlock(volatile StgInt64* lock) {+  *lock = 0;+}
+ ekg-core.cabal view
@@ -0,0 +1,68 @@+name:                ekg-core+version:             0.1.0.0+synopsis:            Tracking of system metrics+description:+  This library lets you defined and track system metrics.+homepage:            https://github.com/tibbe/ekg-core+bug-reports:         https://github.com/tibbe/ekg-core/issues+license:             BSD3+license-file:        LICENSE+author:              Johan Tibell+maintainer:          johan.tibell@gmail.com+category:            System+build-type:          Simple+extra-source-files:  CHANGES.md+cabal-version:       >=1.10++library+  exposed-modules:+    System.Metrics+    System.Metrics.Counter+    System.Metrics.Distribution+    System.Metrics.Gauge+    System.Metrics.Label++  other-modules:+    Data.Array+    Data.Atomic+    Data.Mutex+    System.Metrics.ThreadId++  build-depends:+    ghc-prim < 0.4,+    base >= 4.5 && < 4.8,+    containers >= 0.5 && < 0.6,+    text < 1.2,+    unordered-containers < 0.3++  default-language:    Haskell2010++  ghc-options: -Wall+  includes: distrib.h+  install-includes: distrib.h+  include-dirs: cbits+  c-sources: cbits/atomic.c cbits/distrib.c cbits/mutex.c++benchmark counter+  main-is: Counter.hs+  type: exitcode-stdio-1.0+  build-depends:+    base,+    ekg-core+  default-language: Haskell2010+  hs-source-dirs: benchmarks+  ghc-options: -O2 -threaded -Wall++benchmark distribution+  main-is: Distribution.hs+  type: exitcode-stdio-1.0+  build-depends:+    base,+    ekg-core+  default-language: Haskell2010+  hs-source-dirs: benchmarks+  ghc-options: -O2 -threaded -Wall++source-repository head+  type:     git+  location: https://github.com/tibbe/ekg-core.git