Stack.hsc 5.61 KB
Newer Older
1 2
{-# LANGUAGE Trustworthy #-}

3 4 5 6 7
-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Stack
-- Copyright   :  (c) The University of Glasgow 2011
-- License     :  see libraries/base/LICENSE
8
--
9 10 11 12 13 14
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- Access to GHC's call-stack simulation
--
15
-- @since 4.5.0.0
16 17
-----------------------------------------------------------------------------

18
{-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}
19
module GHC.Stack (
20 21
    -- * Call stacks
    -- ** Simulated by the RTS
22
    currentCallStack,
Simon Marlow's avatar
Simon Marlow committed
23
    whoCreated,
Simon Marlow's avatar
Simon Marlow committed
24
    errorWithStackTrace,
25

26
    -- ** Explicitly created via implicit-parameters
27 28
    --
    -- @since 4.8.2.0
29 30 31 32
    CallStack,
    getCallStack,
    showCallStack,

33 34 35
    -- * Internals
    CostCentreStack,
    CostCentre,
Simon Marlow's avatar
Simon Marlow committed
36 37
    getCurrentCCS,
    getCCSOf,
38 39 40 41
    ccsCC,
    ccsParent,
    ccLabel,
    ccModule,
42
    ccSrcSpan,
Simon Marlow's avatar
Simon Marlow committed
43 44
    ccsToStrings,
    renderStack
45 46
  ) where

47 48
import Data.List ( unlines )

49 50 51 52 53 54
import Foreign
import Foreign.C

import GHC.IO
import GHC.Base
import GHC.Ptr
55 56
import GHC.Foreign as GHC
import GHC.IO.Encoding
Simon Marlow's avatar
Simon Marlow committed
57
import GHC.Exception
58
import GHC.List ( concatMap, null, reverse )
59 60
import GHC.Show
import GHC.SrcLoc
61 62 63 64 65 66 67

#define PROFILING
#include "Rts.h"

data CostCentreStack
data CostCentre

Simon Marlow's avatar
Simon Marlow committed
68 69 70 71 72 73 74 75 76
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 ##)
77 78 79 80 81 82 83 84 85 86 87 88 89

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

90 91 92
ccSrcSpan :: Ptr CostCentre -> IO CString
ccSrcSpan p = (# peek CostCentre, srcloc) p

93 94 95 96 97 98 99 100
-- | 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.
101
--
102
-- @since 4.5.0.0
103 104

currentCallStack :: IO [String]
Simon Marlow's avatar
Simon Marlow committed
105 106 107 108 109
currentCallStack = ccsToStrings =<< getCurrentCCS ()

ccsToStrings :: Ptr CostCentreStack -> IO [String]
ccsToStrings ccs0 = go ccs0 []
  where
110 111 112 113
    go ccs acc
     | ccs == nullPtr = return acc
     | otherwise = do
        cc  <- ccsCC ccs
114 115
        lbl <- GHC.peekCString utf8 =<< ccLabel cc
        mdl <- GHC.peekCString utf8 =<< ccModule cc
116
        loc <- GHC.peekCString utf8 =<< ccSrcSpan cc
117
        parent <- ccsParent ccs
Simon Marlow's avatar
Simon Marlow committed
118 119
        if (mdl == "MAIN" && lbl == "MAIN")
           then return acc
120
           else go parent ((mdl ++ '.':lbl ++ ' ':'(':loc ++ ")") : acc)
Simon Marlow's avatar
Simon Marlow committed
121

122 123
-- | Get the stack trace attached to an object.
--
124
-- @since 4.5.0.0
Simon Marlow's avatar
Simon Marlow committed
125 126 127 128 129 130
whoCreated :: a -> IO [String]
whoCreated obj = do
  ccs <- getCCSOf obj
  ccsToStrings ccs

renderStack :: [String] -> String
131
renderStack strs = "Stack trace:" ++ concatMap ("\n  "++) (reverse strs)
Simon Marlow's avatar
Simon Marlow committed
132 133 134

-- | Like the function 'error', but appends a stack trace to the error
-- message if one is available.
135
--
136
-- @since 4.7.0.0
Simon Marlow's avatar
Simon Marlow committed
137 138 139 140 141 142
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))
143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175


----------------------------------------------------------------------
-- Explicit call-stacks built via ImplicitParams
----------------------------------------------------------------------

-- | @CallStack@s are an alternate method of obtaining the call stack at a given
-- point in the program.
--
-- When an implicit-parameter of type @CallStack@ occurs in a program, GHC will
-- solve it with the current location. If another @CallStack@ implicit-parameter
-- is in-scope (e.g. as a function argument), the new location will be appended
-- to the one in-scope, creating an explicit call-stack. For example,
--
-- @
-- myerror :: (?loc :: CallStack) => String -> a
-- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc)
-- @
-- ghci> myerror "die"
-- *** Exception: die
-- ?loc, called at MyError.hs:7:51 in main:MyError
--   myerror, called at <interactive>:2:1 in interactive:Ghci1
--
-- @CallStack@s do not interact with the RTS and do not require compilation with
-- @-prof@. On the other hand, as they are built up explicitly using
-- implicit-parameters, they will generally not contain as much information as
-- the simulated call-stacks maintained by the RTS.
--
-- The @CallStack@ type is abstract, but it can be converted into a
-- @[(String, SrcLoc)]@ via 'getCallStack'. The @String@ is the name of function
-- that was called, the 'SrcLoc' is the call-site. The list is ordered with the
-- most recently called function at the head.
--
176
-- @since 4.8.2.0
177 178 179 180
data CallStack = CallStack { getCallStack :: [(String, SrcLoc)] }
  -- See Note [Overview of implicit CallStacks]
  deriving (Show, Eq)

181 182 183
-- | Pretty print 'CallStack'
--
-- @since 4.8.2.0
184 185 186 187 188 189 190
showCallStack :: CallStack -> String
showCallStack (CallStack (root:rest))
  = unlines (showCallSite root : map (indent . showCallSite) rest)
  where
  indent l = "  " ++ l
  showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc
showCallStack _ = error "CallStack cannot be empty!"