git.iko.soy/patch
on bc216da help sign in
patch/src/Reflex/Profiled.hs
213 lines 10 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 #-}
11module Reflex.Profiled where
13import Control.Lens hiding (children)
14import Control.Monad
15import Control.Monad.Exception
16import Control.Monad.Fix
17import Control.Monad.Primitive
18import Control.Monad.Reader
19import Control.Monad.Ref
20import Control.Monad.State.Strict (StateT, execStateT, modify)
21import Data.Coerce
22import Data.Dependent.Map (DMap, GCompare)
23import Data.FastMutableIntMap
24import Data.IORef
25import Data.List
26import Data.Map (Map)
27import qualified Data.Map.Strict as Map
28import Data.Monoid ((<>))
29import Data.Ord
30import qualified Data.Semigroup as S
31import Data.Type.Coercion
32import Foreign.Ptr
33import GHC.Foreign
34import GHC.IO.Encoding
35import GHC.Stack
36import Reflex.Class
37import Reflex.Host.Class
38import Reflex.PerformEvent.Class
40import System.IO.Unsafe
41import Unsafe.Coerce
43data ProfiledTimeline t
45{-# NOINLINE profilingData #-}
46profilingData :: IORef (Map (Ptr CostCentreStack) Int)
47profilingData = unsafePerformIO $ newIORef Map.empty
49data CostCentreTree = CostCentreTree
50 { _costCentreTree_ownEntries :: !Int
51 , _costCentreTree_cumulativeEntries :: !Int
52 , _costCentreTree_children :: !(Map (Ptr CostCentre) CostCentreTree)
53 }
54 deriving (Show, Eq, Ord)
56instance S.Semigroup CostCentreTree where
57 (CostCentreTree oa ea ca) <> (CostCentreTree ob eb cb) =
58 CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (S.<>) ca cb
60instance Monoid CostCentreTree where
61 mempty = CostCentreTree 0 0 mempty
62 mappend = (S.<>)
64getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]
65getCostCentreStack = go []
66 where go l ccs = if ccs == nullPtr
67 then return l
68 else do
69 cc <- ccsCC ccs
70 parent <- ccsParent ccs
71 go (cc : l) parent
73toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree
74toCostCentreTree ccs n = do
75 ccList <- getCostCentreStack ccs
76 return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList
78getCostCentreTree :: IO CostCentreTree
79getCostCentreTree = do
80 vals <- readIORef profilingData
81 mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
83formatCostCentreTree :: CostCentreTree -> IO String
84formatCostCentreTree cct0 = unlines . reverse <$> execStateT (go 0 cct0) []
85 where go :: Int -> CostCentreTree -> StateT [String] IO ()
86 go depth cct = do
87 let children = sortOn (Down . _costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct
88 indent = mconcat $ replicate depth " "
89 forM_ children $ \(cc, childCct) -> do
90 lbl <- liftIO $ peekCString utf8 =<< ccLabel cc
91 mdl <- liftIO $ peekCString utf8 =<< ccModule cc
92 loc <- liftIO $ peekCString utf8 =<< ccSrcSpan cc
93 let description = mdl <> "." <> lbl <> " (" <> loc <> ")"
94 modify $ (:) $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)
95 go (succ depth) childCct
97showProfilingData :: IO ()
98showProfilingData = do
99 putStr =<< formatCostCentreTree =<< getCostCentreTree
101writeProfilingData :: FilePath -> IO ()
102writeProfilingData p = do
103 writeFile p =<< formatCostCentreTree =<< getCostCentreTree
105newtype ProfiledM m a = ProfiledM { runProfiledM :: m a }
106 deriving (Functor, Applicative, Monad, MonadFix, MonadException, MonadAsyncException)
108profileEvent :: Reflex t => Event t a -> Event t a
109profileEvent e = unsafePerformIO $ do
110 stack <- getCurrentCCS e
111 let f x = unsafePerformIO $ do
112 modifyIORef' profilingData $ Map.insertWith (+) stack 1
113 return $ return $ Just x
114 return $ pushCheap f e
116--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs
118instance Reflex t => Reflex (ProfiledTimeline t) where
119 newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }
120 newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }
121 newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }
122 newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }
123 type PushM (ProfiledTimeline t) = ProfiledM (PushM t)
124 type PullM (ProfiledTimeline t) = ProfiledM (PullM t)
125 never = Event_Profiled never
126 constant = Behavior_Profiled . constant
127 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
128 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
129 pull = Behavior_Profiled . pull . coerce
130 merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)
131 merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))
132 fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
133 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
134 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
135 current (Dynamic_Profiled d) = coerce $ current d
136 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
137 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
138 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
139 mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))
140 mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))
141 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
142 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
143 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
144 behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of
145 Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
146 eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of
147 Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
148 dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of
149 Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
150 mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))
151 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
153deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
154deriving instance Applicative (Dynamic t) => Applicative (Dynamic (ProfiledTimeline t))
155deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t))
157instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
158 hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v'
159 holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'
160 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
161 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
162 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
164instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
165 sample (Behavior_Profiled b) = ProfiledM $ sample b
167instance MonadTrans ProfiledM where
168 lift = ProfiledM
170instance MonadIO m => MonadIO (ProfiledM m) where
171 liftIO = lift . liftIO
173instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) where
174 type Performable (ProfiledM m) = Performable m
175 performEvent_ = lift . performEvent_ . coerce
176 performEvent = lift . fmap coerce . performEvent . coerce
178instance MonadRef m => MonadRef (ProfiledM m) where
179 type Ref (ProfiledM m) = Ref m
180 newRef = lift . newRef
181 readRef = lift . readRef
182 writeRef r = lift . writeRef r
184instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimeline t) (ProfiledM m) where
185 newEventWithTrigger = lift . fmap coerce . newEventWithTrigger
186 newFanEventWithTrigger f = do
187 es <- lift $ newFanEventWithTrigger f
188 return $ EventSelector $ \k -> coerce $ select es k
190instance MonadReader r m => MonadReader r (ProfiledM m) where
191 ask = lift ask
192 local f (ProfiledM a) = ProfiledM $ local f a
193 reader = lift . reader
195instance ReflexHost t => ReflexHost (ProfiledTimeline t) where
196 type EventTrigger (ProfiledTimeline t) = EventTrigger t
197 type EventHandle (ProfiledTimeline t) = EventHandle t
198 type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t)
200instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where
201 subscribeEvent = lift . subscribeEvent . coerce
203instance PrimMonad m => PrimMonad (ProfiledM m) where
204 type PrimState (ProfiledM m) = PrimState m
205 primitive = lift . primitive
207instance MonadReflexHost t m => MonadReflexHost (ProfiledTimeline t) (ProfiledM m) where
208 type ReadPhase (ProfiledM m) = ProfiledM (ReadPhase m)
209 fireEventsAndRead ts r = lift $ fireEventsAndRead ts $ coerce r
210 runHostFrame = lift . runHostFrame . coerce
212instance MonadReadEvent t m => MonadReadEvent (ProfiledTimeline t) (ProfiledM m) where
213 readEvent = lift . fmap coerce . readEvent