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