Add Haddock `/Since: 4.5.[01].0/` comments to symbols
[packages/base.git] / 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, EmptyDataDecls #-}
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
47 #define PROFILING
48 #include "Rts.h"
49
50 data CostCentreStack
51 data CostCentre
52
53 getCurrentCCS :: dummy -> IO (Ptr CostCentreStack)
54 getCurrentCCS dummy = IO $ \s ->
55    case getCurrentCCS## dummy s of
56      (## s', addr ##) -> (## s', Ptr addr ##)
57
58 getCCSOf :: a -> IO (Ptr CostCentreStack)
59 getCCSOf obj = IO $ \s ->
60    case getCCSOf## obj s of
61      (## s', addr ##) -> (## s', Ptr addr ##)
62
63 ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)
64 ccsCC p = (# peek CostCentreStack, cc) p
65
66 ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
67 ccsParent p = (# peek CostCentreStack, prevStack) p
68
69 ccLabel :: Ptr CostCentre -> IO CString
70 ccLabel p = (# peek CostCentre, label) p
71
72 ccModule :: Ptr CostCentre -> IO CString
73 ccModule p = (# peek CostCentre, module) p
74
75 ccSrcSpan :: Ptr CostCentre -> IO CString
76 ccSrcSpan p = (# peek CostCentre, srcloc) p
77
78 -- | returns a '[String]' representing the current call stack.  This
79 -- can be useful for debugging.
80 --
81 -- The implementation uses the call-stack simulation maintined by the
82 -- profiler, so it only works if the program was compiled with @-prof@
83 -- and contains suitable SCC annotations (e.g. by using @-fprof-auto@).
84 -- Otherwise, the list returned is likely to be empty or
85 -- uninformative.
86 --
87 -- /Since: 4.5.0.0/
88
89 currentCallStack :: IO [String]
90 currentCallStack = ccsToStrings =<< getCurrentCCS ()
91
92 ccsToStrings :: Ptr CostCentreStack -> IO [String]
93 ccsToStrings ccs0 = go ccs0 []
94   where
95     go ccs acc
96      | ccs == nullPtr = return acc
97      | otherwise = do
98         cc  <- ccsCC ccs
99         lbl <- GHC.peekCString utf8 =<< ccLabel cc
100         mdl <- GHC.peekCString utf8 =<< ccModule cc
101         loc <- GHC.peekCString utf8 =<< ccSrcSpan cc
102         parent <- ccsParent ccs
103         if (mdl == "MAIN" && lbl == "MAIN")
104            then return acc
105            else go parent ((mdl ++ '.':lbl ++ ' ':'(':loc ++ ")") : acc)
106
107 -- | Get the stack trace attached to an object.
108 --
109 -- /Since: 4.5.0.0/
110 whoCreated :: a -> IO [String]
111 whoCreated obj = do
112   ccs <- getCCSOf obj
113   ccsToStrings ccs
114
115 renderStack :: [String] -> String
116 renderStack strs = "Stack trace:" ++ concatMap ("\n  "++) (reverse strs)
117
118 -- | Like the function 'error', but appends a stack trace to the error
119 -- message if one is available.
120 --
121 -- /Since: 4.7.0.0/
122 errorWithStackTrace :: String -> a
123 errorWithStackTrace x = unsafeDupablePerformIO $ do
124    stack <- ccsToStrings =<< getCurrentCCS x
125    if null stack
126       then throwIO (ErrorCall x)
127       else throwIO (ErrorCall (x ++ '\n' : renderStack stack))