git.iko.soy/reflex
on develop help sign in
reflex/src/Reflex/Profiled.hs
281 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)
32import Data.GADT.Compare (GCompare)
33import Data.FastMutableIntMap
34import Data.IORef
35import Data.List
36import Data.Map (Map)
37import qualified Data.Map.Strict as Map
38import Data.Monoid ((<>))
39import Data.Ord
40import Data.Profunctor.Unsafe ((#.))
41import qualified Data.Semigroup as S
42import Data.Type.Coercion
43import Foreign.Ptr
44import GHC.Foreign
45import GHC.IO.Encoding
46import GHC.Stack
47import Reflex.Adjustable.Class
48import Reflex.BehaviorWriter.Class
49import Reflex.Class
50import Reflex.DynamicWriter.Class
51import Reflex.EventWriter.Class
52import Reflex.Host.Class
53import Reflex.NotReady.Class
54import Reflex.PerformEvent.Class
55import Reflex.PostBuild.Class
56import Reflex.Query.Class
57import Reflex.Requester.Class
58import Reflex.TriggerEvent.Class
60import System.IO.Unsafe
62data ProfiledTimeline t
64{-# NOINLINE profilingData #-}
65profilingData :: IORef (Map (Ptr CostCentreStack) Int)
66profilingData = unsafePerformIO $ newIORef Map.empty
68data CostCentreTree = CostCentreTree
69 { _costCentreTree_ownEntries :: !Int
70 , _costCentreTree_cumulativeEntries :: !Int
71 , _costCentreTree_children :: !(Map (Ptr CostCentre) CostCentreTree)
72 }
73 deriving (Show, Eq, Ord)
75instance S.Semigroup CostCentreTree where
76 (CostCentreTree oa ea ca) <> (CostCentreTree ob eb cb) =
77 CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (S.<>) ca cb
79instance Monoid CostCentreTree where
80 mempty = CostCentreTree 0 0 mempty
81 mappend = (S.<>)
83getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]
84getCostCentreStack = go []
85 where go l ccs = if ccs == nullPtr
86 then return l
87 else do
88 cc <- ccsCC ccs
89 parent <- ccsParent ccs
90 go (cc : l) parent
92toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree
93toCostCentreTree ccs n =
94 foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty)
95 <$> getCostCentreStack ccs
97getCostCentreTree :: IO CostCentreTree
98getCostCentreTree = do
99 vals <- readIORef profilingData
100 mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
102formatCostCentreTree :: CostCentreTree -> IO String
103formatCostCentreTree cct0 = unlines . reverse <$> execStateT (go 0 cct0) []
104 where go :: Int -> CostCentreTree -> StateT [String] IO ()
105 go depth cct = do
106 let children = sortOn (Down . _costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct
107 indent = mconcat $ replicate depth " "
108 forM_ children $ \(cc, childCct) -> do
109 lbl <- liftIO $ peekCString utf8 =<< ccLabel cc
110 mdl <- liftIO $ peekCString utf8 =<< ccModule cc
111 loc <- liftIO $ peekCString utf8 =<< ccSrcSpan cc
112 let description = mdl <> "." <> lbl <> " (" <> loc <> ")"
113 modify $ (:) $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)
114 go (succ depth) childCct
116showProfilingData :: IO ()
117showProfilingData = do
118 putStr =<< formatCostCentreTree =<< getCostCentreTree
120writeProfilingData :: FilePath -> IO ()
121writeProfilingData p = do
122 writeFile p =<< formatCostCentreTree =<< getCostCentreTree
124newtype ProfiledM m a = ProfiledM { runProfiledM :: m a }
125 deriving (Functor, Applicative, Monad, MonadFix, MonadException, MonadAsyncException)
127profileEvent :: Reflex t => Event t a -> Event t a
128profileEvent e = unsafePerformIO $ do
129 stack <- getCurrentCCS e
130 let f x = unsafePerformIO $ do
131 modifyIORef' profilingData $ Map.insertWith (+) stack 1
132 return $ return $ Just x
133 return $ pushCheap f e
135--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs
137instance Reflex t => Reflex (ProfiledTimeline t) where
138 newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }
139 newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }
140 newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }
141 newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }
142 type PushM (ProfiledTimeline t) = ProfiledM (PushM t)
143 type PullM (ProfiledTimeline t) = ProfiledM (PullM t)
144 never = Event_Profiled never
145 constant = Behavior_Profiled . constant
146 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
147 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
148 pull = Behavior_Profiled . pull . coerce
149 fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)
150 mergeG :: forall z (k :: z -> *) q v. GCompare k
151 => (forall a. q a -> Event (ProfiledTimeline t) (v a))
152 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
153 mergeG nt = Event_Profiled #. mergeG (coerce nt)
154 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
155 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
156 current (Dynamic_Profiled d) = coerce $ current d
157 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
158 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
159 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
160 mergeIncrementalG nt res = Event_Profiled $ mergeIncrementalG (coerce nt) (coerce res)
161 mergeIncrementalWithMoveG nt res = Event_Profiled $ mergeIncrementalWithMoveG (coerce nt) (coerce res)
162 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
163 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
164 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
165 behaviorCoercion c =
166 Coercion `trans` behaviorCoercion @t c `trans` Coercion
167 eventCoercion c =
168 Coercion `trans` eventCoercion @t c `trans` Coercion
169 dynamicCoercion c =
170 Coercion `trans` dynamicCoercion @t c `trans` Coercion
171 incrementalCoercion c d =
172 Coercion `trans` incrementalCoercion @t c d `trans` Coercion
173 mergeIntIncremental = Event_Profiled . mergeIntIncremental .
174 coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion)
175 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
177deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
178deriving instance Applicative (Dynamic t) => Applicative (Dynamic (ProfiledTimeline t))
179deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t))
181instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
182 hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v'
183 holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'
184 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
185 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
186 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
187 now = ProfiledM $ Event_Profiled <$> now
189instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
190 sample (Behavior_Profiled b) = ProfiledM $ sample b
192instance Adjustable t m => Adjustable (ProfiledTimeline t) (ProfiledM m) where
193 runWithReplace a0 a' = (fmap . fmap) coerce . lift $
194 runWithReplace (coerce a0) (coerce $ coerce <$> a')
195 traverseIntMapWithKeyWithAdjust f dm0 dm' = (fmap . fmap) coerce . lift $
196 traverseIntMapWithKeyWithAdjust (\k v -> coerce $ f k v) dm0 (coerce dm')
197 traverseDMapWithKeyWithAdjust f dm0 dm' = (fmap . fmap) coerce . lift $
198 traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) dm0 (coerce dm')
199 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = (fmap . fmap) coerce . lift $
200 traverseDMapWithKeyWithAdjustWithMove (\k v -> coerce $ f k v) dm0 (coerce dm')
202instance MonadTrans ProfiledM where
203 lift = ProfiledM
205instance MonadIO m => MonadIO (ProfiledM m) where
206 liftIO = lift . liftIO
208instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) where
209 type Performable (ProfiledM m) = Performable m
210 performEvent_ = lift . performEvent_ . coerce
211 performEvent = lift . fmap coerce . performEvent . coerce
213instance TriggerEvent t m => TriggerEvent (ProfiledTimeline t) (ProfiledM m) where
214 newTriggerEvent = first coerce <$> lift newTriggerEvent
215 newTriggerEventWithOnComplete = first coerce <$> lift newTriggerEventWithOnComplete
216 newEventWithLazyTriggerWithOnComplete f = coerce <$> lift (newEventWithLazyTriggerWithOnComplete f)
218instance PostBuild t m => PostBuild (ProfiledTimeline t) (ProfiledM m) where
219 getPostBuild = coerce <$> lift getPostBuild
221instance NotReady t m => NotReady (ProfiledTimeline t) (ProfiledM m) where
222 notReady = lift notReady
223 notReadyUntil = lift . notReadyUntil . coerce
225instance BehaviorWriter t w m => BehaviorWriter (ProfiledTimeline t) w (ProfiledM m) where
226 tellBehavior = lift . tellBehavior . coerce
228instance DynamicWriter t w m => DynamicWriter (ProfiledTimeline t) w (ProfiledM m) where
229 tellDyn = lift . tellDyn . coerce
231instance EventWriter t w m => EventWriter (ProfiledTimeline t) w (ProfiledM m) where
232 tellEvent = lift . tellEvent . coerce
234instance MonadQuery t q m => MonadQuery (ProfiledTimeline t) q (ProfiledM m) where
235 tellQueryIncremental = lift . tellQueryIncremental . coerce
236 askQueryResult = coerce <$> lift askQueryResult
237 queryIncremental = fmap coerce . lift . queryIncremental . coerce
239instance Requester t m => Requester (ProfiledTimeline t) (ProfiledM m) where
240 type Request (ProfiledM m) = Request m
241 type Response (ProfiledM m) = Response m
243 requesting = fmap coerce . lift . requesting . coerce
244 requesting_ = lift . requesting_ . coerce
246instance MonadRef m => MonadRef (ProfiledM m) where
247 type Ref (ProfiledM m) = Ref m
248 newRef = lift . newRef
249 readRef = lift . readRef
250 writeRef r = lift . writeRef r
252instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimeline t) (ProfiledM m) where
253 newEventWithTrigger = lift . fmap coerce . newEventWithTrigger
254 newFanEventWithTrigger f = do
255 es <- lift $ newFanEventWithTrigger f
256 return $ EventSelector $ \k -> coerce $ select es k
258instance MonadReader r m => MonadReader r (ProfiledM m) where
259 ask = lift ask
260 local f (ProfiledM a) = ProfiledM $ local f a
261 reader = lift . reader
263instance ReflexHost t => ReflexHost (ProfiledTimeline t) where
264 type EventTrigger (ProfiledTimeline t) = EventTrigger t
265 type EventHandle (ProfiledTimeline t) = EventHandle t
266 type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t)
268instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where
269 subscribeEvent = lift . subscribeEvent . coerce
271instance PrimMonad m => PrimMonad (ProfiledM m) where
272 type PrimState (ProfiledM m) = PrimState m
273 primitive = lift . primitive
275instance MonadReflexHost t m => MonadReflexHost (ProfiledTimeline t) (ProfiledM m) where
276 type ReadPhase (ProfiledM m) = ProfiledM (ReadPhase m)
277 fireEventsAndRead ts r = lift $ fireEventsAndRead ts $ coerce r
278 runHostFrame = lift . runHostFrame . coerce
280instance MonadReadEvent t m => MonadReadEvent (ProfiledTimeline t) (ProfiledM m) where
281 readEvent = lift . fmap coerce . readEvent