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