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