git.iko.soy/reflex
on kassandra-bug help sign in
reflex/src/Reflex/Profiled.hs
280 lines 12 kB history raw
1{-# LANGUAGE EmptyDataDecls #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE InstanceSigs #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE PolyKinds #-}
12{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE RankNTypes #-}
14-- |
15-- Module:
16-- Reflex.Profiled
17-- Description:
18-- This module contains an instance of the 'Reflex' class that provides
19-- profiling/cost-center information.
20module Reflex.Profiled where
22import Control.Monad
23import Control.Monad.Exception
24import Control.Monad.Fix
25import Control.Monad.Primitive
26import Control.Monad.Reader
27import Control.Monad.Ref
28import Control.Monad.State.Strict (StateT, execStateT, modify)
29import Data.Bifunctor
30import Data.Coerce
31import Data.Dependent.Map (DMap, GCompare)
32import Data.FastMutableIntMap
33import Data.IORef
34import Data.List
35import Data.Map (Map)
36import qualified Data.Map.Strict as Map
37import Data.Monoid ((<>))
38import Data.Ord
39import Data.Profunctor.Unsafe ((#.))
40import qualified Data.Semigroup as S
41import Data.Type.Coercion
42import Foreign.Ptr
43import GHC.Foreign
44import GHC.IO.Encoding
45import GHC.Stack
46import Reflex.Adjustable.Class
47import Reflex.BehaviorWriter.Class
48import Reflex.Class
49import Reflex.DynamicWriter.Class
50import Reflex.EventWriter.Class
51import Reflex.Host.Class
52import Reflex.NotReady.Class
53import Reflex.PerformEvent.Class
54import Reflex.PostBuild.Class
55import Reflex.Query.Class
56import Reflex.Requester.Class
57import Reflex.TriggerEvent.Class
59import System.IO.Unsafe
61data ProfiledTimeline t
63{-# NOINLINE profilingData #-}
64profilingData :: IORef (Map (Ptr CostCentreStack) Int)
65profilingData = unsafePerformIO $ newIORef Map.empty
67data CostCentreTree = CostCentreTree
68 { _costCentreTree_ownEntries :: !Int
69 , _costCentreTree_cumulativeEntries :: !Int
70 , _costCentreTree_children :: !(Map (Ptr CostCentre) CostCentreTree)
71 }
72 deriving (Show, Eq, Ord)
74instance S.Semigroup CostCentreTree where
75 (CostCentreTree oa ea ca) <> (CostCentreTree ob eb cb) =
76 CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (S.<>) ca cb
78instance Monoid CostCentreTree where
79 mempty = CostCentreTree 0 0 mempty
80 mappend = (S.<>)
82getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]
83getCostCentreStack = go []
84 where go l ccs = if ccs == nullPtr
85 then return l
86 else do
87 cc <- ccsCC ccs
88 parent <- ccsParent ccs
89 go (cc : l) parent
91toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree
92toCostCentreTree ccs n =
93 foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty)
94 <$> getCostCentreStack ccs
96getCostCentreTree :: IO CostCentreTree
97getCostCentreTree = do
98 vals <- readIORef profilingData
99 mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
101formatCostCentreTree :: CostCentreTree -> IO String
102formatCostCentreTree cct0 = unlines . reverse <$> execStateT (go 0 cct0) []
103 where go :: Int -> CostCentreTree -> StateT [String] IO ()
104 go depth cct = do
105 let children = sortOn (Down . _costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct
106 indent = mconcat $ replicate depth " "
107 forM_ children $ \(cc, childCct) -> do
108 lbl <- liftIO $ peekCString utf8 =<< ccLabel cc
109 mdl <- liftIO $ peekCString utf8 =<< ccModule cc
110 loc <- liftIO $ peekCString utf8 =<< ccSrcSpan cc
111 let description = mdl <> "." <> lbl <> " (" <> loc <> ")"
112 modify $ (:) $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)
113 go (succ depth) childCct
115showProfilingData :: IO ()
116showProfilingData = do
117 putStr =<< formatCostCentreTree =<< getCostCentreTree
119writeProfilingData :: FilePath -> IO ()
120writeProfilingData p = do
121 writeFile p =<< formatCostCentreTree =<< getCostCentreTree
123newtype ProfiledM m a = ProfiledM { runProfiledM :: m a }
124 deriving (Functor, Applicative, Monad, MonadFix, MonadException, MonadAsyncException)
126profileEvent :: Reflex t => Event t a -> Event t a
127profileEvent e = unsafePerformIO $ do
128 stack <- getCurrentCCS e
129 let f x = unsafePerformIO $ do
130 modifyIORef' profilingData $ Map.insertWith (+) stack 1
131 return $ return $ Just x
132 return $ pushCheap f e
134--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs
136instance Reflex t => Reflex (ProfiledTimeline t) where
137 newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }
138 newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }
139 newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }
140 newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }
141 type PushM (ProfiledTimeline t) = ProfiledM (PushM t)
142 type PullM (ProfiledTimeline t) = ProfiledM (PullM t)
143 never = Event_Profiled never
144 constant = Behavior_Profiled . constant
145 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
146 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
147 pull = Behavior_Profiled . pull . coerce
148 fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)
149 mergeG :: forall (k :: z -> *) q v. GCompare k
150 => (forall a. q a -> Event (ProfiledTimeline t) (v a))
151 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
152 mergeG nt = Event_Profiled #. mergeG (coerce nt)
153 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
154 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
155 current (Dynamic_Profiled d) = coerce $ current d
156 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
157 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
158 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
159 mergeIncrementalG nt res = Event_Profiled $ mergeIncrementalG (coerce nt) (coerce res)
160 mergeIncrementalWithMoveG nt res = Event_Profiled $ mergeIncrementalWithMoveG (coerce nt) (coerce res)
161 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
162 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
163 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
164 behaviorCoercion c =
165 Coercion `trans` behaviorCoercion @t c `trans` Coercion
166 eventCoercion c =
167 Coercion `trans` eventCoercion @t c `trans` Coercion
168 dynamicCoercion c =
169 Coercion `trans` dynamicCoercion @t c `trans` Coercion
170 incrementalCoercion c d =
171 Coercion `trans` incrementalCoercion @t c d `trans` Coercion
172 mergeIntIncremental = Event_Profiled . mergeIntIncremental .
173 coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion)
174 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
176deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
177deriving instance Applicative (Dynamic t) => Applicative (Dynamic (ProfiledTimeline t))
178deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t))
180instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
181 hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v'
182 holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'
183 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
184 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
185 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
186 now = ProfiledM $ Event_Profiled <$> now
188instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
189 sample (Behavior_Profiled b) = ProfiledM $ sample b
191instance Adjustable t m => Adjustable (ProfiledTimeline t) (ProfiledM m) where
192 runWithReplace a0 a' = (fmap . fmap) coerce . lift $
193 runWithReplace (coerce a0) (coerce $ coerce <$> a')
194 traverseIntMapWithKeyWithAdjust f dm0 dm' = (fmap . fmap) coerce . lift $
195 traverseIntMapWithKeyWithAdjust (\k v -> coerce $ f k v) dm0 (coerce dm')
196 traverseDMapWithKeyWithAdjust f dm0 dm' = (fmap . fmap) coerce . lift $
197 traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) dm0 (coerce dm')
198 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = (fmap . fmap) coerce . lift $
199 traverseDMapWithKeyWithAdjustWithMove (\k v -> coerce $ f k v) dm0 (coerce dm')
201instance MonadTrans ProfiledM where
202 lift = ProfiledM
204instance MonadIO m => MonadIO (ProfiledM m) where
205 liftIO = lift . liftIO
207instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) where
208 type Performable (ProfiledM m) = Performable m
209 performEvent_ = lift . performEvent_ . coerce
210 performEvent = lift . fmap coerce . performEvent . coerce
212instance TriggerEvent t m => TriggerEvent (ProfiledTimeline t) (ProfiledM m) where
213 newTriggerEvent = first coerce <$> lift newTriggerEvent
214 newTriggerEventWithOnComplete = first coerce <$> lift newTriggerEventWithOnComplete
215 newEventWithLazyTriggerWithOnComplete f = coerce <$> lift (newEventWithLazyTriggerWithOnComplete f)
217instance PostBuild t m => PostBuild (ProfiledTimeline t) (ProfiledM m) where
218 getPostBuild = coerce <$> lift getPostBuild
220instance NotReady t m => NotReady (ProfiledTimeline t) (ProfiledM m) where
221 notReady = lift notReady
222 notReadyUntil = lift . notReadyUntil . coerce
224instance BehaviorWriter t w m => BehaviorWriter (ProfiledTimeline t) w (ProfiledM m) where
225 tellBehavior = lift . tellBehavior . coerce
227instance DynamicWriter t w m => DynamicWriter (ProfiledTimeline t) w (ProfiledM m) where
228 tellDyn = lift . tellDyn . coerce
230instance EventWriter t w m => EventWriter (ProfiledTimeline t) w (ProfiledM m) where
231 tellEvent = lift . tellEvent . coerce
233instance MonadQuery t q m => MonadQuery (ProfiledTimeline t) q (ProfiledM m) where
234 tellQueryIncremental = lift . tellQueryIncremental . coerce
235 askQueryResult = coerce <$> lift askQueryResult
236 queryIncremental = fmap coerce . lift . queryIncremental . coerce
238instance Requester t m => Requester (ProfiledTimeline t) (ProfiledM m) where
239 type Request (ProfiledM m) = Request m
240 type Response (ProfiledM m) = Response m
242 requesting = fmap coerce . lift . requesting . coerce
243 requesting_ = lift . requesting_ . coerce
245instance MonadRef m => MonadRef (ProfiledM m) where
246 type Ref (ProfiledM m) = Ref m
247 newRef = lift . newRef
248 readRef = lift . readRef
249 writeRef r = lift . writeRef r
251instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimeline t) (ProfiledM m) where
252 newEventWithTrigger = lift . fmap coerce . newEventWithTrigger
253 newFanEventWithTrigger f = do
254 es <- lift $ newFanEventWithTrigger f
255 return $ EventSelector $ \k -> coerce $ select es k
257instance MonadReader r m => MonadReader r (ProfiledM m) where
258 ask = lift ask
259 local f (ProfiledM a) = ProfiledM $ local f a
260 reader = lift . reader
262instance ReflexHost t => ReflexHost (ProfiledTimeline t) where
263 type EventTrigger (ProfiledTimeline t) = EventTrigger t
264 type EventHandle (ProfiledTimeline t) = EventHandle t
265 type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t)
267instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where
268 subscribeEvent = lift . subscribeEvent . coerce
270instance PrimMonad m => PrimMonad (ProfiledM m) where
271 type PrimState (ProfiledM m) = PrimState m
272 primitive = lift . primitive
274instance MonadReflexHost t m => MonadReflexHost (ProfiledTimeline t) (ProfiledM m) where
275 type ReadPhase (ProfiledM m) = ProfiledM (ReadPhase m)
276 fireEventsAndRead ts r = lift $ fireEventsAndRead ts $ coerce r
277 runHostFrame = lift . runHostFrame . coerce
279instance MonadReadEvent t m => MonadReadEvent (ProfiledTimeline t) (ProfiledM m) where
280 readEvent = lift . fmap coerce . readEvent