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