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