Metrics.hs 10.1 KB
Newer Older
1
{-# LANGUAGE Arrows #-}
2
{-# LANGUAGE DataKinds #-}
3
4
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
5
{-# LANGUAGE GADTs #-}
6
7
8
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
Sven Keidel's avatar
Sven Keidel committed
9
10
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
11
{-# LANGUAGE UnboxedTuples #-}
Sven Keidel's avatar
Sven Keidel committed
12
13
14
15
16
17
18
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Metrics where

import           Prelude hiding (pred,lookup,map,head,iterate,(.),id,truncate,elem,product,(**))

import           Control.Category
import           Control.Arrow
19
import           Control.Arrow.Primitive
Sven Keidel's avatar
Sven Keidel committed
20
21
22
import           Control.Arrow.Order
import           Control.Arrow.State
import           Control.Arrow.Trans
Sven Keidel's avatar
Sven Keidel committed
23
import           Control.Arrow.Fix.Metrics (ArrowMetrics)
24
import qualified Control.Arrow.Fix.Metrics as F
25
import           Control.Arrow.Fix.ControlFlow as CF
Sven Keidel's avatar
Sven Keidel committed
26
27
28
import           Control.Arrow.Fix.Chaotic as Chaotic
import           Control.Arrow.Fix.Cache as Cache
import           Control.Arrow.Fix.Stack as Stack
29
import           Control.Arrow.Fix.Context(ArrowContext)
Sven Keidel's avatar
Sven Keidel committed
30
31
32
33
34
35
36
37
38
39
40
41
42

import           Control.Arrow.Transformer.State

import           Data.Empty
import           Data.Foldable (fold)
import           Data.Identifiable
import           Data.Profunctor.Unsafe
import           Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import           Data.Coerce

import           Text.Printf

Tomislav Pree's avatar
Tomislav Pree committed
43
44
45
import           Control.Arrow.Transformer.Abstract.FiniteEnvStore 
import           Data.Abstract.MonotoneStore(Store)

46
newtype MetricsT metric a c x y = MetricsT (StateT (metric a) c x y)
47
48
  deriving (Profunctor,Category,Arrow,ArrowChoice,ArrowLowerBounded z,
            ArrowComponent a,ArrowInComponent a,ArrowControlFlow stmt,
Sven Keidel's avatar
Sven Keidel committed
49
            ArrowStackDepth,ArrowStackElements a,ArrowContext ctx,ArrowTopLevel,
Tomislav Pree's avatar
Tomislav Pree committed
50
            ArrowGetCache cache, ArrowPrimitive, ArrowCFG graph)
Sven Keidel's avatar
Sven Keidel committed
51

52
53
54
55
instance (IsEmpty (metrics a), ArrowRun c) => ArrowRun (MetricsT metrics a c) where
  type Run (MetricsT metrics a c) x y = Run c x (metrics a,y)
  run f = run (lmap (empty,) (unlift f))

56
instance ArrowLift (MetricsT metrics a c) where
57
58
  type Underlying (MetricsT metrics a c) x y = c (metrics a,x) (metrics a,y)

59
instance ArrowTrans (MetricsT metrics a) where
60
61
62
63
64
65
66
  lift' = MetricsT . lift'
  {-# INLINE lift' #-}

instance (Profunctor c,ArrowApply c) => ArrowApply (MetricsT metrics a c) where
  app = MetricsT (app .# first coerce)
  {-# INLINE app #-}

Tomislav Pree's avatar
Tomislav Pree committed
67
68
69
70
71
72
73
74
75
76
77
--instance ArrowState s c => ArrowState s (MetricsT metrics a c) where
--  get = lift' get
--  put = lift' put
--  {-# INLINE get #-}
--  {-# INLINE put #-}

--instance (Arrow c, Profunctor c) => ArrowState (Store addr val) (EnvStoreT var addr val c) where
--  get = EnvStoreT get
--  put = EnvStoreT put
--  {-# INLINE get #-}
--  {-# INLINE put #-}
78
79

-- Basic Metric ----------------------------------------------------------------
80
newtype Metrics a = Metrics (HashMap a Metric)
Sven Keidel's avatar
Sven Keidel committed
81

Sven Keidel's avatar
Sven Keidel committed
82
83
84
data Metric = Metric
            { filtered :: !Int
            , evaluated :: !Int
85
            , iteration :: !Int
Sven Keidel's avatar
Sven Keidel committed
86
87
88
            , stackLookups :: !Int
            , cacheEntries :: !Int
            , cacheLookups :: !Int
89
            , cacheUpdates :: !Int
Sven Keidel's avatar
Sven Keidel committed
90
91
92
            }
  deriving (Show)

Sven Keidel's avatar
Sven Keidel committed
93
instance Semigroup Metric where
94
95
96
  m1 <> m2 = Metric
    { filtered = filtered m1 + filtered m2
    , evaluated = evaluated m1 + evaluated m2
97
    , iteration = iteration m1 + iteration m2
98
99
100
101
102
    , stackLookups = stackLookups m1 + stackLookups m2
    , cacheEntries = cacheEntries m1 + cacheEntries m2
    , cacheLookups = cacheLookups m1 + cacheLookups m2
    , cacheUpdates = cacheUpdates m1 + cacheUpdates m2
    }
Sven Keidel's avatar
Sven Keidel committed
103

Sven Keidel's avatar
Sven Keidel committed
104
105
instance Monoid Metric where
  mappend = (<>)
106
  mempty = Metric
107
    { filtered = 0, evaluated = 0, iteration = 0, stackLookups = 0
108
    , cacheEntries = 0, cacheLookups = 0, cacheUpdates = 0 }
Sven Keidel's avatar
Sven Keidel committed
109
110
  {-# INLINE mappend #-}

111
csvHeader :: String
112
csvHeader = "Filtered,Evaluated,Iteration,Stack Lookups,Cache Entries,Cache Lookups,Cache Updates"
113

Sven Keidel's avatar
Sven Keidel committed
114
toCSV :: Metrics a -> String
115
116
117
toCSV (Metrics metrics) =
  let Metric {..} = fold metrics
  in printf "%d,%d,%d,%d,%d,%d,%d"
118
            filtered evaluated iteration stackLookups cacheEntries cacheLookups cacheUpdates
Sven Keidel's avatar
Sven Keidel committed
119
120

instance IsEmpty (Metrics a) where
121
  empty = Metrics empty
Sven Keidel's avatar
Sven Keidel committed
122

Sven Keidel's avatar
Sven Keidel committed
123
instance (Identifiable a, Arrow c,Profunctor c) => ArrowMetrics a (MetricsT Metrics a c) where
124
125
  filtered = MetricsT $ proc a ->
    modifyMetric setFiltered -< a
Sven Keidel's avatar
Sven Keidel committed
126
127
  evaluated = MetricsT $ proc a ->
    modifyMetric incrementEvaluated -< a
128
129
  iterated = MetricsT $ proc a ->
    modifyMetric incrementIterated -< a
Sven Keidel's avatar
Sven Keidel committed
130

131
instance (Identifiable a, ArrowStack a c) => ArrowStack a (MetricsT Metrics a c) where
132
133
134
  elem = MetricsT $ proc a -> do
    modifyMetric incrementStackLookups -< a
    lift' elem -< a
135
  push f = lift $ lmap (\(m, (a, x)) -> (a, (m, x))) (push (unlift f))
136
137
  {-# INLINE elem #-}
  {-# INLINE push #-}
Sven Keidel's avatar
Sven Keidel committed
138

139
140
instance (Identifiable a, ArrowChoice c, Profunctor c, ArrowCache a b c) => ArrowCache a b (MetricsT Metrics a c) where
  type Widening (MetricsT Metrics a c) = Cache.Widening c
Sven Keidel's avatar
Sven Keidel committed
141
142
143
144
  initialize = MetricsT $ proc a -> do
    modifyMetric incrementInitializes -< a
    initialize -< a
  lookup = MetricsT $ proc a -> do
145
    modifyMetric incrementCacheLookups -< a
Sven Keidel's avatar
Sven Keidel committed
146
    Cache.lookup -< a
147
  update = MetricsT $ proc (st,a,b) -> do
Sven Keidel's avatar
Sven Keidel committed
148
    modifyMetric incrementUpdates -< a
149
    update -< (st,a,b)
Sven Keidel's avatar
Sven Keidel committed
150
151
152
153
154
155
156
157
  write = MetricsT $ proc (a,b,s) -> do
    modifyMetric incrementUpdates -< a
    write -< (a,b,s)
  {-# INLINE initialize #-}
  {-# INLINE lookup #-}
  {-# INLINE update #-}
  {-# INLINE write #-}

158
159
160
161
instance (Identifiable a, ArrowIterateCache a b c) => ArrowIterateCache a b (MetricsT Metrics a c) where
  nextIteration = MetricsT $ proc (a,b) -> do
    modifyMetric incrementIterated -< a
    lift' nextIteration -< (a,b)
Sven Keidel's avatar
Sven Keidel committed
162
163
  {-# INLINE nextIteration #-}

164
instance (Identifiable a, ArrowParallelCache a b c) => ArrowParallelCache a b (MetricsT Metrics a c) where
165
166
167
168
169
170
171
172
173
  lookupOldCache = MetricsT $ proc a -> do
    modifyMetric incrementCacheLookups -< a
    Cache.lookupOldCache -< a
  lookupNewCache = MetricsT $ proc a -> do
    modifyMetric incrementCacheLookups -< a
    Cache.lookupNewCache -< a
  updateNewCache = MetricsT $ proc (a,b) -> do
    modifyMetric incrementUpdates -< a
    Cache.updateNewCache -< (a,b)
174
175
176
  {-# INLINE lookupOldCache #-}
  {-# INLINE lookupNewCache #-}
  {-# INLINE updateNewCache #-}
177

Sven Keidel's avatar
Sven Keidel committed
178
modifyMetric :: (Identifiable a, ArrowState (Metrics a) c) => (Metric -> Metric) -> c a ()
179
modifyMetric f = modify' (\(a,Metrics m) -> ((),Metrics (upsert f a m)))
180
{-# INLINE modifyMetric #-}
Sven Keidel's avatar
Sven Keidel committed
181

182
183
setFiltered :: Metric -> Metric
setFiltered m = m { filtered = 1 }
Sven Keidel's avatar
Sven Keidel committed
184

Sven Keidel's avatar
Sven Keidel committed
185
186
187
incrementEvaluated :: Metric -> Metric
incrementEvaluated m@Metric{..} = m { evaluated = evaluated + 1 }

188
incrementIterated :: Metric -> Metric
189
incrementIterated m@Metric{..} = m { iteration = iteration + 1 }
190

Sven Keidel's avatar
Sven Keidel committed
191
incrementInitializes :: Metric -> Metric
192
incrementInitializes m@Metric{..} = m { cacheEntries = 1 }
Sven Keidel's avatar
Sven Keidel committed
193

194
incrementCacheLookups :: Metric -> Metric
195
incrementCacheLookups m@Metric{..} = m { cacheLookups = cacheLookups + 1 }
Sven Keidel's avatar
Sven Keidel committed
196

197
incrementStackLookups :: Metric -> Metric
198
incrementStackLookups m@Metric{..} = m { stackLookups = stackLookups + 1 }
Sven Keidel's avatar
Sven Keidel committed
199
200

incrementUpdates :: Metric -> Metric
201
incrementUpdates m@Metric{..} = m { cacheEntries = 1, cacheUpdates = cacheUpdates + 1 }
Sven Keidel's avatar
Sven Keidel committed
202
203
204
205
206

upsert :: Identifiable a => Monoid b => (b -> b) -> a -> HashMap a b -> HashMap a b
upsert f a = M.insertWith (\_ _old -> f _old) a mempty
{-# INLINE upsert #-}

207
208
209
-- Metric for monotone Inputs ----------------------------------------------------------------
data Monotone a where
  Monotone :: Metrics b -> Monotone (a,b)
Sven Keidel's avatar
Sven Keidel committed
210

211
212
instance IsEmpty (Monotone (a,b)) where
  empty = Monotone empty
Sven Keidel's avatar
Sven Keidel committed
213

214
215
216
217
218
219
220
instance (Identifiable a', Arrow c,Profunctor c) => ArrowMetrics (a,a') (MetricsT Monotone (a,a') c) where
  filtered = MetricsT $ proc (_,a') ->
    modifyMetric' setFiltered -< a'
  evaluated = MetricsT $ proc (_,a') ->
    modifyMetric' incrementEvaluated -< a'
  iterated = MetricsT $ proc (_,a') ->
    modifyMetric' incrementIterated -< a'
Sven Keidel's avatar
Sven Keidel committed
221
222
  {-# INLINE filtered #-}
  {-# INLINE evaluated #-}
223
  {-# INLINE iterated #-}
Sven Keidel's avatar
Sven Keidel committed
224

225
226
227
228
229
230
231
instance (Identifiable b, ArrowStack (a,b) c) => ArrowStack (a,b) (MetricsT Monotone (a,b) c) where
  elem = MetricsT $ proc x@(_,b) -> do
    modifyMetric' incrementStackLookups -< b
    lift' elem -< x
  push f = lift $ lmap (\(m, (a, x)) -> (a, (m, x))) (push (unlift f))
  {-# INLINE elem #-}
  {-# INLINE push #-}
232

233
234
235
236
237
238
239
240
instance (Identifiable a', ArrowChoice c, Profunctor c, ArrowCache (a,a') b c) => ArrowCache (a,a') b (MetricsT Monotone (a,a') c) where
  type Widening (MetricsT Monotone (a,a') c) = Cache.Widening c
  initialize = MetricsT $ proc x@(_,a') -> do
    modifyMetric' incrementInitializes -< a'
    initialize -< x
  lookup = MetricsT $ proc x@(_,a') -> do
    modifyMetric' incrementCacheLookups -< a'
    Cache.lookup -< x
241
  update = MetricsT $ proc (st,x@(_,a'),b) -> do
242
    modifyMetric' incrementUpdates -< a'
243
    update -< (st,x,b)
244
245
246
247
248
249
250
251
  write = MetricsT $ proc (x@(_,a'),b,s) -> do
    modifyMetric' incrementUpdates -< a'
    write -< (x,b,s)
  {-# INLINE initialize #-}
  {-# INLINE lookup #-}
  {-# INLINE update #-}
  {-# INLINE write #-}

252
253
254
255
instance (Identifiable a', ArrowIterateCache (a,a') b c) => ArrowIterateCache (a,a') b (MetricsT Monotone (a,a') c) where
  nextIteration = MetricsT $ proc x@((_,a'),_) -> do
    modifyMetric' incrementIterated -< a'
    lift' nextIteration -< x
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
  {-# INLINE nextIteration #-}

instance (Identifiable a', ArrowParallelCache (a,a') b c) => ArrowParallelCache (a,a') b (MetricsT Monotone (a,a') c) where
  lookupOldCache = MetricsT $ proc x@(_,a') -> do
    modifyMetric' incrementCacheLookups -< a'
    Cache.lookupOldCache -< x
  lookupNewCache = MetricsT $ proc x@(_,a') -> do
    modifyMetric' incrementCacheLookups -< a'
    Cache.lookupNewCache -< x
  updateNewCache = MetricsT $ proc (x@(_,a'),b) -> do
    modifyMetric' incrementUpdates -< a'
    Cache.updateNewCache -< (x,b)
  {-# INLINE lookupOldCache #-}
  {-# INLINE lookupNewCache #-}
  {-# INLINE updateNewCache #-}

modifyMetric' :: (Identifiable b, ArrowState (Monotone (a,b)) c) => (Metric -> Metric) -> c b ()
273
modifyMetric' f = modify' (\(b, Monotone (Metrics m)) -> ((), Monotone (Metrics (upsert f b m))))
274
{-# INLINE modifyMetric' #-}