git.iko.soy/reflex
on 8eac9a2 help sign in
reflex/src/Reflex/Profiled.hs
195 lines 9.8 kB history raw
1{-# LANGUAGE EmptyDataDecls #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE InstanceSigs #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE StandaloneDeriving #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE UndecidableInstances #-}
10module Reflex.Profiled where
12import Control.Lens hiding (children)
13import Control.Monad
14import Control.Monad.Fix
15import Control.Monad.Primitive
16import Control.Monad.Reader
17import Control.Monad.Ref
18import Data.Coerce
19import Data.Dependent.Map (DMap, GCompare)
20import Data.List
21import Data.FastMutableIntMap
22import Data.IORef
23import Data.Map (Map)
24import qualified Data.Map.Strict as Map
25import Data.Monoid
26import Data.Type.Coercion
27import Foreign.Ptr
28import GHC.Foreign
29import GHC.IO.Encoding
30import GHC.Stack
31import Reflex.Class
32import Reflex.PerformEvent.Class
33import Reflex.Host.Class
35import System.IO.Unsafe
36import Unsafe.Coerce
38data ProfiledTimeline t
40{-# NOINLINE profilingData #-}
41profilingData :: IORef (Map (Ptr CostCentreStack) Int)
42profilingData = unsafePerformIO $ newIORef Map.empty
44data CostCentreTree = CostCentreTree
45 { _costCentreTree_ownEntries :: !Int
46 , _costCentreTree_cumulativeEntries :: !Int
47 , _costCentreTree_children :: !(Map (Ptr CostCentre) CostCentreTree)
48 }
49 deriving (Show, Eq, Ord)
51instance Monoid CostCentreTree where
52 mempty = CostCentreTree 0 0 mempty
53 CostCentreTree oa ea ca `mappend` CostCentreTree ob eb cb = CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (<>) ca cb
55getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]
56getCostCentreStack = go []
57 where go l ccs = if ccs == nullPtr
58 then return l
59 else do
60 cc <- ccsCC ccs
61 parent <- ccsParent ccs
62 go (cc : l) parent
64toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree
65toCostCentreTree ccs n = do
66 ccList <- getCostCentreStack ccs
67 return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList
69printCostCentreTree :: CostCentreTree -> IO ()
70printCostCentreTree = go 0
71 where go depth cct = do
72 let children = sortOn (_costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct
73 indent = mconcat $ replicate depth " "
74 forM_ children $ \(cc, childCct) -> do
75 lbl <- peekCString utf8 =<< ccLabel cc
76 mdl <- peekCString utf8 =<< ccModule cc
77 loc <- peekCString utf8 =<< ccSrcSpan cc
78 let description = mdl <> "." <> lbl <> " (" <> loc <> ")"
79 putStrLn $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)
80 go (succ depth) childCct
82showProfilingData :: IO ()
83showProfilingData = do
84 vals <- readIORef profilingData
85 cct <- mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
86 printCostCentreTree cct
88newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } deriving (Functor, Applicative, Monad, MonadFix)
90profileEvent :: Reflex t => Event t a -> Event t a
91profileEvent e = unsafePerformIO $ do
92 stack <- getCurrentCCS e
93 let f x = unsafePerformIO $ do
94 modifyIORef' profilingData $ Map.insertWith (+) stack 1
95 return $ return $ Just x
96 return $ pushCheap f e
98--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs
100instance Reflex t => Reflex (ProfiledTimeline t) where
101 newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }
102 newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }
103 newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }
104 newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }
105 type PushM (ProfiledTimeline t) = ProfiledM (PushM t)
106 type PullM (ProfiledTimeline t) = ProfiledM (PullM t)
107 never = Event_Profiled never
108 constant = Behavior_Profiled . constant
109 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
110 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
111 pull = Behavior_Profiled . pull . coerce
112 merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)
113 merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))
114 fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
115 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
116 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
117 current (Dynamic_Profiled d) = coerce $ current d
118 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
119 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
120 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
121 mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))
122 mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))
123 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
124 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
125 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
126 behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of
127 Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
128 eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of
129 Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
130 dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of
131 Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
132 mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))
133 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
135deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
136deriving instance Applicative (Dynamic t) => Applicative (Dynamic (ProfiledTimeline t))
137deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t))
139instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
140 hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v'
141 holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'
142 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
143 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
144 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
146instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
147 sample (Behavior_Profiled b) = ProfiledM $ sample b
149instance MonadTrans ProfiledM where
150 lift = ProfiledM
152instance MonadIO m => MonadIO (ProfiledM m) where
153 liftIO = lift . liftIO
155instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) where
156 type Performable (ProfiledM m) = Performable m
157 performEvent_ = lift . performEvent_ . coerce
158 performEvent = lift . fmap coerce . performEvent . coerce
160instance MonadRef m => MonadRef (ProfiledM m) where
161 type Ref (ProfiledM m) = Ref m
162 newRef = lift . newRef
163 readRef = lift . readRef
164 writeRef r = lift . writeRef r
166instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimeline t) (ProfiledM m) where
167 newEventWithTrigger = lift . fmap coerce . newEventWithTrigger
168 newFanEventWithTrigger f = do
169 es <- lift $ newFanEventWithTrigger f
170 return $ EventSelector $ \k -> coerce $ select es k
172instance MonadReader r m => MonadReader r (ProfiledM m) where
173 ask = lift ask
174 local f (ProfiledM a) = ProfiledM $ local f a
175 reader = lift . reader
177instance ReflexHost t => ReflexHost (ProfiledTimeline t) where
178 type EventTrigger (ProfiledTimeline t) = EventTrigger t
179 type EventHandle (ProfiledTimeline t) = EventHandle t
180 type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t)
182instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where
183 subscribeEvent = lift . subscribeEvent . coerce
185instance PrimMonad m => PrimMonad (ProfiledM m) where
186 type PrimState (ProfiledM m) = PrimState m
187 primitive = lift . primitive
189instance MonadReflexHost t m => MonadReflexHost (ProfiledTimeline t) (ProfiledM m) where
190 type ReadPhase (ProfiledM m) = ProfiledM (ReadPhase m)
191 fireEventsAndRead ts r = lift $ fireEventsAndRead ts $ coerce r
192 runHostFrame = lift . runHostFrame . coerce
194instance MonadReadEvent t m => MonadReadEvent (ProfiledTimeline t) (ProfiledM m) where
195 readEvent = lift . fmap coerce . readEvent