[commit: base] master: Expand the stack-tracing API (8812b67)

[Simon Marlow]

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 <marlowsd at gmail.com>
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)
+    ++ " }"