git.iko.soy/reflex
on documentation help sign in
reflex/src/Reflex/Profiled.hs
227 lines 9.8 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.Coerce
30import Data.Dependent.Map (DMap, GCompare)
31import Data.FastMutableIntMap
32import Data.IORef
33import Data.List
34import Data.Map (Map)
35import qualified Data.Map.Strict as Map
36import Data.Monoid ((<>))
37import Data.Ord
38import Data.Profunctor.Unsafe ((#.))
39import qualified Data.Semigroup as S
40import Data.Type.Coercion
41import Foreign.Ptr
42import GHC.Foreign
43import GHC.IO.Encoding
44import GHC.Stack
45import Reflex.Class
46import Reflex.Host.Class
47import Reflex.PerformEvent.Class
49import System.IO.Unsafe
50import Unsafe.Coerce
52data ProfiledTimeline t
54{-# NOINLINE profilingData #-}
55profilingData :: IORef (Map (Ptr CostCentreStack) Int)
56profilingData = unsafePerformIO $ newIORef Map.empty
58data CostCentreTree = CostCentreTree
59 { _costCentreTree_ownEntries :: !Int
60 , _costCentreTree_cumulativeEntries :: !Int
61 , _costCentreTree_children :: !(Map (Ptr CostCentre) CostCentreTree)
62 }
63 deriving (Show, Eq, Ord)
65instance S.Semigroup CostCentreTree where
66 (CostCentreTree oa ea ca) <> (CostCentreTree ob eb cb) =
67 CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (S.<>) ca cb
69instance Monoid CostCentreTree where
70 mempty = CostCentreTree 0 0 mempty
71 mappend = (S.<>)
73getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]
74getCostCentreStack = go []
75 where go l ccs = if ccs == nullPtr
76 then return l
77 else do
78 cc <- ccsCC ccs
79 parent <- ccsParent ccs
80 go (cc : l) parent
82toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree
83toCostCentreTree ccs n =
84 foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty)
85 <$> getCostCentreStack ccs
87getCostCentreTree :: IO CostCentreTree
88getCostCentreTree = do
89 vals <- readIORef profilingData
90 mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
92formatCostCentreTree :: CostCentreTree -> IO String
93formatCostCentreTree cct0 = unlines . reverse <$> execStateT (go 0 cct0) []
94 where go :: Int -> CostCentreTree -> StateT [String] IO ()
95 go depth cct = do
96 let children = sortOn (Down . _costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct
97 indent = mconcat $ replicate depth " "
98 forM_ children $ \(cc, childCct) -> do
99 lbl <- liftIO $ peekCString utf8 =<< ccLabel cc
100 mdl <- liftIO $ peekCString utf8 =<< ccModule cc
101 loc <- liftIO $ peekCString utf8 =<< ccSrcSpan cc
102 let description = mdl <> "." <> lbl <> " (" <> loc <> ")"
103 modify $ (:) $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)
104 go (succ depth) childCct
106showProfilingData :: IO ()
107showProfilingData = do
108 putStr =<< formatCostCentreTree =<< getCostCentreTree
110writeProfilingData :: FilePath -> IO ()
111writeProfilingData p = do
112 writeFile p =<< formatCostCentreTree =<< getCostCentreTree
114newtype ProfiledM m a = ProfiledM { runProfiledM :: m a }
115 deriving (Functor, Applicative, Monad, MonadFix, MonadException, MonadAsyncException)
117profileEvent :: Reflex t => Event t a -> Event t a
118profileEvent e = unsafePerformIO $ do
119 stack <- getCurrentCCS e
120 let f x = unsafePerformIO $ do
121 modifyIORef' profilingData $ Map.insertWith (+) stack 1
122 return $ return $ Just x
123 return $ pushCheap f e
125--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs
127instance Reflex t => Reflex (ProfiledTimeline t) where
128 newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }
129 newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }
130 newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }
131 newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }
132 type PushM (ProfiledTimeline t) = ProfiledM (PushM t)
133 type PullM (ProfiledTimeline t) = ProfiledM (PullM t)
134 never = Event_Profiled never
135 constant = Behavior_Profiled . constant
136 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
137 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
138 pull = Behavior_Profiled . pull . coerce
139 fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)
140 mergeG :: forall (k :: z -> *) q v. GCompare k
141 => (forall a. q a -> Event (ProfiledTimeline t) (v a))
142 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
143 mergeG nt = Event_Profiled #. mergeG (coerce nt)
144 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
145 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
146 current (Dynamic_Profiled d) = coerce $ current d
147 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
148 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
149 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
150 mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt
151 mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt
152 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
153 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
154 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
155 behaviorCoercion c =
156 Coercion `trans` behaviorCoercion @t c `trans` Coercion
157 eventCoercion c =
158 Coercion `trans` eventCoercion @t c `trans` Coercion
159 dynamicCoercion c =
160 Coercion `trans` dynamicCoercion @t c `trans` Coercion
161 incrementalCoercion c d =
162 Coercion `trans` incrementalCoercion @t c d `trans` Coercion
163 mergeIntIncremental = Event_Profiled . mergeIntIncremental .
164 coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion)
165 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
167deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
168deriving instance Applicative (Dynamic t) => Applicative (Dynamic (ProfiledTimeline t))
169deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t))
171instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
172 hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v'
173 holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'
174 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
175 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
176 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
178instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
179 sample (Behavior_Profiled b) = ProfiledM $ sample b
181instance MonadTrans ProfiledM where
182 lift = ProfiledM
184instance MonadIO m => MonadIO (ProfiledM m) where
185 liftIO = lift . liftIO
187instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) where
188 type Performable (ProfiledM m) = Performable m
189 performEvent_ = lift . performEvent_ . coerce
190 performEvent = lift . fmap coerce . performEvent . coerce
192instance MonadRef m => MonadRef (ProfiledM m) where
193 type Ref (ProfiledM m) = Ref m
194 newRef = lift . newRef
195 readRef = lift . readRef
196 writeRef r = lift . writeRef r
198instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimeline t) (ProfiledM m) where
199 newEventWithTrigger = lift . fmap coerce . newEventWithTrigger
200 newFanEventWithTrigger f = do
201 es <- lift $ newFanEventWithTrigger f
202 return $ EventSelector $ \k -> coerce $ select es k
204instance MonadReader r m => MonadReader r (ProfiledM m) where
205 ask = lift ask
206 local f (ProfiledM a) = ProfiledM $ local f a
207 reader = lift . reader
209instance ReflexHost t => ReflexHost (ProfiledTimeline t) where
210 type EventTrigger (ProfiledTimeline t) = EventTrigger t
211 type EventHandle (ProfiledTimeline t) = EventHandle t
212 type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t)
214instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where
215 subscribeEvent = lift . subscribeEvent . coerce
217instance PrimMonad m => PrimMonad (ProfiledM m) where
218 type PrimState (ProfiledM m) = PrimState m
219 primitive = lift . primitive
221instance MonadReflexHost t m => MonadReflexHost (ProfiledTimeline t) (ProfiledM m) where
222 type ReadPhase (ProfiledM m) = ProfiledM (ReadPhase m)
223 fireEventsAndRead ts r = lift $ fireEventsAndRead ts $ coerce r
224 runHostFrame = lift . runHostFrame . coerce
226instance MonadReadEvent t m => MonadReadEvent (ProfiledTimeline t) (ProfiledM m) where
227 readEvent = lift . fmap coerce . readEvent