Repository : ssh://darcs.haskell.org//srv/darcs/packages/base On branch : master
http://hackage.haskell.org/trac/ghc/changeset/8812b6716e6a7c7ef2b8b1d074ce1015206ba3c1 >--------------------------------------------------------------- commit 8812b6716e6a7c7ef2b8b1d074ce1015206ba3c1 Author: Simon Marlow <[email protected]> Date: Wed Nov 30 10:36:11 2011 +0000 Expand the stack-tracing API - add whoCreated :: a -> IO [String] Get the stack trace attached to an object - rename getCCCS to getCurrentCCS - add getCCSOf (used to implement whoCreated) - add renderStack :: [String] -> String A handy function for prettifying a stack >--------------------------------------------------------------- GHC/Stack.hsc | 43 ++++++++++++++++++++++++++++++++++--------- 1 files changed, 34 insertions(+), 9 deletions(-) diff --git a/GHC/Stack.hsc b/GHC/Stack.hsc index 657a3d1..7dc8b5b 100644 --- a/GHC/Stack.hsc +++ b/GHC/Stack.hsc @@ -16,15 +16,19 @@ module GHC.Stack ( -- * Call stack currentCallStack, + whoCreated, -- * Internals CostCentreStack, CostCentre, - getCCCS, + getCurrentCCS, + getCCSOf, ccsCC, ccsParent, ccLabel, ccModule, + ccsToStrings, + renderStack ) where import Foreign @@ -35,6 +39,7 @@ import GHC.Base import GHC.Ptr import GHC.Foreign as GHC import GHC.IO.Encoding +import Data.List #define PROFILING #include "Rts.h" @@ -42,8 +47,15 @@ import GHC.IO.Encoding data CostCentreStack data CostCentre -getCCCS :: IO (Ptr CostCentreStack) -getCCCS = IO $ \s -> case getCCCS## s of (## s', addr ##) -> (## s', Ptr addr ##) +getCurrentCCS :: dummy -> IO (Ptr CostCentreStack) +getCurrentCCS dummy = IO $ \s -> + case getCurrentCCS## dummy s of + (## s', addr ##) -> (## s', Ptr addr ##) + +getCCSOf :: a -> IO (Ptr CostCentreStack) +getCCSOf obj = IO $ \s -> + case getCCSOf## obj s of + (## s', addr ##) -> (## s', Ptr addr ##) ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre) ccsCC p = (# peek CostCentreStack, cc) p @@ -67,8 +79,11 @@ ccModule p = (# peek CostCentre, module) p -- uninformative. currentCallStack :: IO [String] -currentCallStack = do - let +currentCallStack = ccsToStrings =<< getCurrentCCS () + +ccsToStrings :: Ptr CostCentreStack -> IO [String] +ccsToStrings ccs0 = go ccs0 [] + where go ccs acc | ccs == nullPtr = return acc | otherwise = do @@ -76,7 +91,17 @@ currentCallStack = do lbl <- GHC.peekCString utf8 =<< ccLabel cc mdl <- GHC.peekCString utf8 =<< ccModule cc parent <- ccsParent ccs - go parent ((mdl ++ '.':lbl) : acc) - -- - ccs <- getCCCS - go ccs [] + if (mdl == "MAIN" && lbl == "MAIN") + then return acc + else go parent ((mdl ++ '.':lbl) : acc) + +whoCreated :: a -> IO [String] +whoCreated obj = do + ccs <- getCCSOf obj + ccsToStrings ccs + +renderStack :: [String] -> String +renderStack strs = + "{ " ++ + intercalate "\n " (zipWith (++) (iterate (' ':) []) strs) + ++ " }" _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
