edd0f4f1bc9811bfca7e448bb12b6796355fee82
[ghc.git] / libraries / base / GHC / Stack.hsc
1 -----------------------------------------------------------------------------
2 -- |
3 -- Module      :  GHC.Stack
4 -- Copyright   :  (c) The University of Glasgow 2011
5 -- License     :  see libraries/base/LICENSE
6 --
7 -- Maintainer  :  cvs-ghc@haskell.org
8 -- Stability   :  internal
9 -- Portability :  non-portable (GHC Extensions)
10 --
11 -- Access to GHC's call-stack simulation
12 --
13 -- /Since: 4.5.0.0/
14 -----------------------------------------------------------------------------
15
16 {-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}
17 module GHC.Stack (
18     -- * Call stack
19     currentCallStack,
20     whoCreated,
21     errorWithStackTrace,
22
23     -- * Internals
24     CostCentreStack,
25     CostCentre,
26     getCurrentCCS,
27     getCCSOf,
28     ccsCC,
29     ccsParent,
30     ccLabel,
31     ccModule,
32     ccSrcSpan,
33     ccsToStrings,
34     renderStack
35   ) where
36
37 import Foreign
38 import Foreign.C
39
40 import GHC.IO
41 import GHC.Base
42 import GHC.Ptr
43 import GHC.Foreign as GHC
44 import GHC.IO.Encoding
45 import GHC.Exception
46 import GHC.List ( concatMap, null, reverse )
47
48 #define PROFILING
49 #include "Rts.h"
50
51 data CostCentreStack
52 data CostCentre
53
54 getCurrentCCS :: dummy -> IO (Ptr CostCentreStack)
55 getCurrentCCS dummy = IO $ \s ->
56    case getCurrentCCS## dummy s of
57      (## s', addr ##) -> (## s', Ptr addr ##)
58
59 getCCSOf :: a -> IO (Ptr CostCentreStack)
60 getCCSOf obj = IO $ \s ->
61    case getCCSOf## obj s of
62      (## s', addr ##) -> (## s', Ptr addr ##)
63
64 ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)
65 ccsCC p = (# peek CostCentreStack, cc) p
66
67 ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
68 ccsParent p = (# peek CostCentreStack, prevStack) p
69
70 ccLabel :: Ptr CostCentre -> IO CString
71 ccLabel p = (# peek CostCentre, label) p
72
73 ccModule :: Ptr CostCentre -> IO CString
74 ccModule p = (# peek CostCentre, module) p
75
76 ccSrcSpan :: Ptr CostCentre -> IO CString
77 ccSrcSpan p = (# peek CostCentre, srcloc) p
78
79 -- | returns a '[String]' representing the current call stack.  This
80 -- can be useful for debugging.
81 --
82 -- The implementation uses the call-stack simulation maintined by the
83 -- profiler, so it only works if the program was compiled with @-prof@
84 -- and contains suitable SCC annotations (e.g. by using @-fprof-auto@).
85 -- Otherwise, the list returned is likely to be empty or
86 -- uninformative.
87 --
88 -- /Since: 4.5.0.0/
89
90 currentCallStack :: IO [String]
91 currentCallStack = ccsToStrings =<< getCurrentCCS ()
92
93 ccsToStrings :: Ptr CostCentreStack -> IO [String]
94 ccsToStrings ccs0 = go ccs0 []
95   where
96     go ccs acc
97      | ccs == nullPtr = return acc
98      | otherwise = do
99         cc  <- ccsCC ccs
100         lbl <- GHC.peekCString utf8 =<< ccLabel cc
101         mdl <- GHC.peekCString utf8 =<< ccModule cc
102         loc <- GHC.peekCString utf8 =<< ccSrcSpan cc
103         parent <- ccsParent ccs
104         if (mdl == "MAIN" && lbl == "MAIN")
105            then return acc
106            else go parent ((mdl ++ '.':lbl ++ ' ':'(':loc ++ ")") : acc)
107
108 -- | Get the stack trace attached to an object.
109 --
110 -- /Since: 4.5.0.0/
111 whoCreated :: a -> IO [String]
112 whoCreated obj = do
113   ccs <- getCCSOf obj
114   ccsToStrings ccs
115
116 renderStack :: [String] -> String
117 renderStack strs = "Stack trace:" ++ concatMap ("\n  "++) (reverse strs)
118
119 -- | Like the function 'error', but appends a stack trace to the error
120 -- message if one is available.
121 --
122 -- /Since: 4.7.0.0/
123 errorWithStackTrace :: String -> a
124 errorWithStackTrace x = unsafeDupablePerformIO $ do
125    stack <- ccsToStrings =<< getCurrentCCS x
126    if null stack
127       then throwIO (ErrorCall x)
128       else throwIO (ErrorCall (x ++ '\n' : renderStack stack))