[commit: base] master: Add a way to get hold of the current call stack (c0ee7bd)

[Simon Marlow]

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 <marlowsd at gmail.com>
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  :  cvs-ghc at haskell.org
+-- 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,