Repository : ssh://darcs.haskell.org//srv/darcs/packages/base On branch : master
http://hackage.haskell.org/trac/ghc/changeset/c0ee7bd3c9558f9e19218066b9e002380b878b0c >--------------------------------------------------------------- commit c0ee7bd3c9558f9e19218066b9e002380b878b0c Author: Simon Marlow <[email protected]> Date: Tue Nov 29 14:10:59 2011 +0000 Add a way to get hold of the current call stack GHC.Stack.currentCallStack :: IO [String] At the moment this uses the profiler's cost-centre stack; maybe in the future it might use some other mechanism. Right now it only gives useful results when profiling and using -fprof-auto or similar, but it could be quite handy. e.g. f :: Int -> IO Int f x = do currentCallStack >>= print; return (x+1) mapM :: Monad m => (a -> m b) -> [a] -> m [b] mapM f xs = go xs where go [] = return [] go (x:xs) = do x' <- f x xs' <- mapM f xs return (x':xs') main = mapM f [42,42] $ ./stack ["MAIN.MAIN","Main.main","Main.mapM","Main.mapM.go","Main.f"] ["MAIN.MAIN","Main.main","Main.mapM","Main.mapM.go","Main.f"] >--------------------------------------------------------------- GHC/Exts.hs | 6 +++- GHC/Stack.hsc | 80 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ base.cabal | 1 + 3 files changed, 86 insertions(+), 1 deletions(-) diff --git a/GHC/Exts.hs b/GHC/Exts.hs index 72d4f78..85e17b7 100644 --- a/GHC/Exts.hs +++ b/GHC/Exts.hs @@ -51,7 +51,10 @@ module GHC.Exts traceEvent, -- * SpecConstr annotations - SpecConstrAnnotation(..) + SpecConstrAnnotation(..), + + -- * The call stack + currentCallStack ) where @@ -65,6 +68,7 @@ import GHC.Int import GHC.Ptr import GHC.Foreign import GHC.IO.Encoding +import GHC.Stack import Data.String import Data.List import Data.Data diff --git a/GHC/Stack.hsc b/GHC/Stack.hsc new file mode 100644 index 0000000..38bd6f5 --- /dev/null +++ b/GHC/Stack.hsc @@ -0,0 +1,80 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Stack +-- Copyright : (c) The University of Glasgow 2011 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : [email protected] +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Access to GHC's call-stack simulation +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE UnboxedTuples, MagicHash, EmptyDataDecls #-} +module GHC.Stack ( + -- * Call stack + currentCallStack, + + -- * Internals + CostCentreStack, + CostCentre, + getCCCS, + ccsCC, + ccsParent, + ccLabel, + ccModule, + ) where + +import Foreign +import Foreign.C + +import GHC.IO +import GHC.Base +import GHC.Ptr + +#define PROFILING +#include "Rts.h" + +data CostCentreStack +data CostCentre + +getCCCS :: IO (Ptr CostCentreStack) +getCCCS = IO $ \s -> case getCCCS## s of (## s', addr ##) -> (## s', Ptr addr ##) + +ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre) +ccsCC p = (# peek CostCentreStack, cc) p + +ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack) +ccsParent p = (# peek CostCentreStack, prevStack) p + +ccLabel :: Ptr CostCentre -> IO CString +ccLabel p = (# peek CostCentre, label) p + +ccModule :: Ptr CostCentre -> IO CString +ccModule p = (# peek CostCentre, module) p + +-- | returns a '[String]' representing the current call stack. This +-- can be useful for debugging. +-- +-- The implementation uses the call-stack simulation maintined by the +-- profiler, so it only works if the program was compiled with @-prof@ +-- and contains suitable SCC annotations (e.g. by using @-fprof-auto@). +-- Otherwise, the list returned is likely to be empty or +-- uninformative. + +currentCallStack :: IO [String] +currentCallStack = do + let + go ccs acc + | ccs == nullPtr = return acc + | otherwise = do + cc <- ccsCC ccs + lbl <- peekCAString =<< ccLabel cc + mdl <- peekCString =<< ccModule cc + parent <- ccsParent ccs + go parent ((mdl ++ '.':lbl) : acc) + -- + ccs <- getCCCS + go ccs [] diff --git a/base.cabal b/base.cabal index a0211ad..f593352 100644 --- a/base.cabal +++ b/base.cabal @@ -92,6 +92,7 @@ Library { GHC.Read, GHC.Real, GHC.ST, + GHC.Stack, GHC.Stats, GHC.Show, GHC.Stable, _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
