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