@@ -15,6 +15,7 @@ import Control.Monad.Fix
1515import Control.Monad.Primitive
1616import Control.Monad.Reader
1717import Control.Monad.Ref
18+import Control.Monad.State.Strict (StateT, execStateT, modify)
1819import Data.Coerce
1920import Data.Dependent.Map (DMap, GCompare)
2021import Data.List
@@ -23,6 +24,7 @@ import Data.IORef
2324import Data.Map (Map)
2425import qualified Data.Map.Strict as Map
2526import Data.Monoid
27+import Data.Ord
2628import Data.Type.Coercion
2729import Foreign.Ptr
2830import GHC.Foreign
@@ -66,24 +68,32 @@ toCostCentreTree ccs n = do
6668 ccList <- getCostCentreStack ccs
6769 return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList
6870
69−printCostCentreTree :: CostCentreTree -> IO ()
70−printCostCentreTree = go 0
71− where go depth cct = do
72− let children = sortOn (_costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct
71+getCostCentreTree :: IO CostCentreTree
72+getCostCentreTree = do
73+ vals <- readIORef profilingData
74+ mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
75+
76+formatCostCentreTree :: CostCentreTree -> IO String
77+formatCostCentreTree cct0 = unlines . reverse <$> execStateT (go 0 cct0) []
78+ where go :: Int -> CostCentreTree -> StateT [String] IO ()
79+ go depth cct = do
80+ let children = sortOn (Down . _costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct
7381 indent = mconcat $ replicate depth " "
7482 forM_ children $ \(cc, childCct) -> do
75− lbl <- peekCString utf8 =<< ccLabel cc
76− mdl <- peekCString utf8 =<< ccModule cc
77− loc <- peekCString utf8 =<< ccSrcSpan cc
83+ lbl <- liftIO $ peekCString utf8 =<< ccLabel cc
84+ mdl <- liftIO $ peekCString utf8 =<< ccModule cc
85+ loc <- liftIO $ peekCString utf8 =<< ccSrcSpan cc
7886 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)
8088 go (succ depth) childCct
8189
8290showProfilingData :: IO ()
8391showProfilingData = do
84− vals <- readIORef profilingData
85− cct <- mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
86− printCostCentreTree cct
92+ putStr =<< formatCostCentreTree =<< getCostCentreTree
93+
94+writeProfilingData :: FilePath -> IO ()
95+writeProfilingData p = do
96+ writeFile p =<< formatCostCentreTree =<< getCostCentreTree
8797
8898newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } deriving (Functor, Applicative, Monad, MonadFix)
8999