@@ -0,0 +1,141 @@
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 #-}
10+module Reflex.Profiled where
11+
12+import Control.Lens hiding (children)
13+import Control.Monad
14+import Control.Monad.Fix
15+import Data.Coerce
16+import Data.Dependent.Map (DMap, GCompare)
17+import Data.List
18+import Data.FastMutableIntMap
19+import Data.IORef
20+import Data.Map (Map)
21+import qualified Data.Map.Strict as Map
22+import Data.Monoid
23+import Data.Type.Coercion
24+import Foreign.Ptr
25+import GHC.Foreign
26+import GHC.IO.Encoding
27+import GHC.Stack
28+import Reflex.Class
29+
30+import System.IO.Unsafe
31+import Unsafe.Coerce
32+
33+data ProfiledTimeline t
34+
35+{-# NOINLINE profilingData #-}
36+profilingData :: IORef (Map (Ptr CostCentreStack) Int)
37+profilingData = unsafePerformIO $ newIORef Map.empty
38+
39+data CostCentreTree = CostCentreTree
40+ { _costCentreTree_ownEntries :: !Int
41+ , _costCentreTree_cumulativeEntries :: !Int
42+ , _costCentreTree_children :: !(Map (Ptr CostCentre) CostCentreTree)
43+ }
44+ deriving (Show, Eq, Ord)
45+
46+instance Monoid CostCentreTree where
47+ mempty = CostCentreTree 0 0 mempty
48+ CostCentreTree oa ea ca `mappend` CostCentreTree ob eb cb = CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (<>) ca cb
49+
50+getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]
51+getCostCentreStack = go []
52+ where go l ccs = if ccs == nullPtr
53+ then return l
54+ else do
55+ cc <- ccsCC ccs
56+ parent <- ccsParent ccs
57+ go (cc : l) parent
58+
59+toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree
60+toCostCentreTree ccs n = do
61+ ccList <- getCostCentreStack ccs
62+ return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList
63+
64+printCostCentreTree :: CostCentreTree -> IO ()
65+printCostCentreTree = go 0
66+ where go depth cct = do
67+ let children = sortOn (_costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct
68+ indent = mconcat $ replicate depth " "
69+ forM_ children $ \(cc, childCct) -> do
70+ lbl <- peekCString utf8 =<< ccLabel cc
71+ mdl <- peekCString utf8 =<< ccModule cc
72+ loc <- peekCString utf8 =<< ccSrcSpan cc
73+ let description = mdl <> "." <> lbl <> " (" <> loc <> ")"
74+ putStrLn $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)
75+ go (succ depth) childCct
76+
77+showProfilingData :: IO ()
78+showProfilingData = do
79+ vals <- readIORef profilingData
80+ cct <- mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
81+ printCostCentreTree cct
82+
83+newtype ProfiledM m a = ProfiledM (m a) deriving (Functor, Applicative, Monad, MonadFix)
84+
85+profileEvent :: Reflex t => Event t a -> Event t a
86+profileEvent e = unsafePerformIO $ do
87+ stack <- getCurrentCCS e
88+ let f x = unsafePerformIO $ do
89+ modifyIORef' profilingData $ Map.insertWith (+) stack 1
90+ return $ return $ Just x
91+ return $ pushCheap f e
92+
93+--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs
94+
95+instance Reflex t => Reflex (ProfiledTimeline t) where
96+ newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled (Behavior t a)
97+ newtype Event (ProfiledTimeline t) a = Event_Profiled (Event t a)
98+ newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled (Dynamic t a)
99+ newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled (Incremental t p)
100+ type PushM (ProfiledTimeline t) = ProfiledM (PushM t)
101+ type PullM (ProfiledTimeline t) = ProfiledM (PullM t)
102+ never = Event_Profiled never
103+ constant = Behavior_Profiled . constant
104+ push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
105+ pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
106+ pull = Behavior_Profiled . pull . coerce
107+ merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)
108+ merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))
109+ fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
110+ switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
111+ coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
112+ current (Dynamic_Profiled d) = coerce $ current d
113+ updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
114+ unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
115+ unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
116+ mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))
117+ mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))
118+ currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
119+ updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
120+ incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
121+ behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of
122+ Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
123+ eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of
124+ Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
125+ dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of
126+ Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
127+ mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))
128+ fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
129+
130+deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
131+deriving instance Applicative (Dynamic t) => Applicative (Dynamic (ProfiledTimeline t))
132+deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t))
133+
134+instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
135+ hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v'
136+ holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'
137+ holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
138+ buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
139+
140+instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
141+ sample (Behavior_Profiled b) = ProfiledM $ sample b