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