@@ -15,6 +15,7 @@ import Control.Monad.Fix
15import Control.Monad.Primitive
15import Control.Monad.Primitive
16import Control.Monad.Reader
16import Control.Monad.Reader
17import Control.Monad.Ref
17import Control.Monad.Ref
18+import Control.Monad.State.Strict (StateT, execStateT, modify)
18import Data.Coerce
19import Data.Coerce
19import Data.Dependent.Map (DMap, GCompare)
20import Data.Dependent.Map (DMap, GCompare)
20import Data.List
21import Data.List
@@ -23,6 +24,7 @@ import Data.IORef
23import Data.Map (Map)
24import Data.Map (Map)
24import qualified Data.Map.Strict as Map
25import qualified Data.Map.Strict as Map
25import Data.Monoid
26import Data.Monoid
26import Data.Type.Coercion
28import Data.Type.Coercion
27import Foreign.Ptr
29import Foreign.Ptr
28import GHC.Foreign
30import GHC.Foreign
@@ -66,24 +68,32 @@ toCostCentreTree ccs n = do
66 ccList <- getCostCentreStack ccs
68 ccList <- getCostCentreStack ccs
67 return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList
69 return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList
69−printCostCentreTree :: CostCentreTree -> IO ()
71+getCostCentreTree :: IO CostCentreTree
70−printCostCentreTree = go 0
72+getCostCentreTree = do
73+ vals <- readIORef profilingData
74+ mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
76+formatCostCentreTree :: CostCentreTree -> IO String
77+formatCostCentreTree cct0 = unlines . reverse <$> execStateT (go 0 cct0) []
78+ where go :: Int -> CostCentreTree -> StateT [String] IO ()
71− where go depth cct = do
79+ go depth cct = do
72− let children = sortOn (_costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct
80+ let children = sortOn (Down . _costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct
73 indent = mconcat $ replicate depth " "
81 indent = mconcat $ replicate depth " "
74 forM_ children $ \(cc, childCct) -> do
82 forM_ children $ \(cc, childCct) -> do
75− lbl <- peekCString utf8 =<< ccLabel cc
83+ lbl <- liftIO $ peekCString utf8 =<< ccLabel cc
76− mdl <- peekCString utf8 =<< ccModule cc
84+ mdl <- liftIO $ peekCString utf8 =<< ccModule cc
77− loc <- peekCString utf8 =<< ccSrcSpan cc
85+ loc <- liftIO $ peekCString utf8 =<< ccSrcSpan cc
78 let description = mdl <> "." <> lbl <> " (" <> loc <> ")"
86 let description = mdl <> "." <> lbl <> " (" <> loc <> ")"
79− putStrLn $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)
87+ modify $ (:) $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)
80 go (succ depth) childCct
88 go (succ depth) childCct
82showProfilingData :: IO ()
90showProfilingData :: IO ()
83showProfilingData = do
91showProfilingData = do
84− vals <- readIORef profilingData
92+ putStr =<< formatCostCentreTree =<< getCostCentreTree
85− cct <- mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
93+
86− printCostCentreTree cct
94+writeProfilingData :: FilePath -> IO ()
95+writeProfilingData p = do
96+ writeFile p =<< formatCostCentreTree =<< getCostCentreTree
88newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } deriving (Functor, Applicative, Monad, MonadFix)
98newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } deriving (Functor, Applicative, Monad, MonadFix)