{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}

module GHC.Internal.Exception.Backtrace
    ( -- * Backtrace mechanisms
      BacktraceMechanism(..)
    , getBacktraceMechanismState
    , setBacktraceMechanismState
      -- * Collecting backtraces
    , Backtraces
    , displayBacktraces
    , collectBacktraces
    ) where

import GHC.Internal.Base
import GHC.Internal.Data.OldList
import GHC.Internal.IORef
import GHC.Internal.IO.Unsafe (unsafePerformIO)
import GHC.Internal.Exception.Context
import GHC.Internal.Ptr
import GHC.Internal.Stack.Types as GHC.Stack (CallStack)
import qualified GHC.Internal.Stack as HCS
import qualified GHC.Internal.ExecutionStack as ExecStack
import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
import qualified GHC.Internal.Stack.CloneStack as CloneStack
import qualified GHC.Internal.Stack.CCS as CCS

-- | How to collect a backtrace when an exception is thrown.
data BacktraceMechanism
  -- | collect cost-centre stack backtraces (only available when built with profiling)
  = CostCentreBacktrace
  -- | collect 'HasCallStack' backtraces
  | HasCallStackBacktrace
  -- | collect backtraces from native execution stack unwinding
  | ExecutionBacktrace
  -- | collect backtraces from Info Table Provenance Entries
  | IPEBacktrace

data EnabledBacktraceMechanisms =
    EnabledBacktraceMechanisms
      { EnabledBacktraceMechanisms -> Bool
costCentreBacktraceEnabled   :: !Bool
      , EnabledBacktraceMechanisms -> Bool
hasCallStackBacktraceEnabled :: !Bool
      , EnabledBacktraceMechanisms -> Bool
executionBacktraceEnabled    :: !Bool
      , EnabledBacktraceMechanisms -> Bool
ipeBacktraceEnabled          :: !Bool
      }

defaultEnabledBacktraceMechanisms :: EnabledBacktraceMechanisms
defaultEnabledBacktraceMechanisms :: EnabledBacktraceMechanisms
defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms
  { costCentreBacktraceEnabled :: Bool
costCentreBacktraceEnabled   = Bool
False
  , hasCallStackBacktraceEnabled :: Bool
hasCallStackBacktraceEnabled = Bool
True
  , executionBacktraceEnabled :: Bool
executionBacktraceEnabled    = Bool
False
  , ipeBacktraceEnabled :: Bool
ipeBacktraceEnabled          = Bool
False
  }

backtraceMechanismEnabled :: BacktraceMechanism -> EnabledBacktraceMechanisms -> Bool
backtraceMechanismEnabled :: BacktraceMechanism -> EnabledBacktraceMechanisms -> Bool
backtraceMechanismEnabled BacktraceMechanism
bm =
  case BacktraceMechanism
bm of
    BacktraceMechanism
CostCentreBacktrace   -> EnabledBacktraceMechanisms -> Bool
costCentreBacktraceEnabled
    BacktraceMechanism
HasCallStackBacktrace -> EnabledBacktraceMechanisms -> Bool
hasCallStackBacktraceEnabled
    BacktraceMechanism
ExecutionBacktrace    -> EnabledBacktraceMechanisms -> Bool
executionBacktraceEnabled
    BacktraceMechanism
IPEBacktrace          -> EnabledBacktraceMechanisms -> Bool
ipeBacktraceEnabled

setBacktraceMechanismEnabled
    :: BacktraceMechanism -> Bool
    -> EnabledBacktraceMechanisms
    -> EnabledBacktraceMechanisms
setBacktraceMechanismEnabled :: BacktraceMechanism
-> Bool -> EnabledBacktraceMechanisms -> EnabledBacktraceMechanisms
setBacktraceMechanismEnabled BacktraceMechanism
bm Bool
enabled EnabledBacktraceMechanisms
en =
    case BacktraceMechanism
bm of
      BacktraceMechanism
CostCentreBacktrace   -> EnabledBacktraceMechanisms
en { costCentreBacktraceEnabled = enabled }
      BacktraceMechanism
HasCallStackBacktrace -> EnabledBacktraceMechanisms
en { hasCallStackBacktraceEnabled = enabled }
      BacktraceMechanism
ExecutionBacktrace    -> EnabledBacktraceMechanisms
en { executionBacktraceEnabled = enabled }
      BacktraceMechanism
IPEBacktrace          -> EnabledBacktraceMechanisms
en { ipeBacktraceEnabled = enabled }

enabledBacktraceMechanismsRef :: IORef EnabledBacktraceMechanisms
enabledBacktraceMechanismsRef :: IORef EnabledBacktraceMechanisms
enabledBacktraceMechanismsRef =
    IO (IORef EnabledBacktraceMechanisms)
-> IORef EnabledBacktraceMechanisms
forall a. IO a -> a
unsafePerformIO (IO (IORef EnabledBacktraceMechanisms)
 -> IORef EnabledBacktraceMechanisms)
-> IO (IORef EnabledBacktraceMechanisms)
-> IORef EnabledBacktraceMechanisms
forall a b. (a -> b) -> a -> b
$ EnabledBacktraceMechanisms -> IO (IORef EnabledBacktraceMechanisms)
forall a. a -> IO (IORef a)
newIORef EnabledBacktraceMechanisms
defaultEnabledBacktraceMechanisms
{-# NOINLINE enabledBacktraceMechanismsRef #-}

-- | Returns the currently enabled 'BacktraceMechanism's.
getEnabledBacktraceMechanisms :: IO EnabledBacktraceMechanisms
getEnabledBacktraceMechanisms :: IO EnabledBacktraceMechanisms
getEnabledBacktraceMechanisms = IORef EnabledBacktraceMechanisms -> IO EnabledBacktraceMechanisms
forall a. IORef a -> IO a
readIORef IORef EnabledBacktraceMechanisms
enabledBacktraceMechanismsRef

-- | Will the given 'BacktraceMechanism' be used when collecting
-- backtraces?
getBacktraceMechanismState :: BacktraceMechanism -> IO Bool
getBacktraceMechanismState :: BacktraceMechanism -> IO Bool
getBacktraceMechanismState BacktraceMechanism
bm =
    BacktraceMechanism -> EnabledBacktraceMechanisms -> Bool
backtraceMechanismEnabled BacktraceMechanism
bm (EnabledBacktraceMechanisms -> Bool)
-> IO EnabledBacktraceMechanisms -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO EnabledBacktraceMechanisms
getEnabledBacktraceMechanisms

-- | Set whether the given 'BacktraceMechanism' will be used when collecting
-- backtraces?
setBacktraceMechanismState :: BacktraceMechanism -> Bool -> IO ()
setBacktraceMechanismState :: BacktraceMechanism -> Bool -> IO ()
setBacktraceMechanismState BacktraceMechanism
bm Bool
enabled = do
    _ <- IORef EnabledBacktraceMechanisms
-> (EnabledBacktraceMechanisms -> EnabledBacktraceMechanisms)
-> IO (EnabledBacktraceMechanisms, EnabledBacktraceMechanisms)
forall a. IORef a -> (a -> a) -> IO (a, a)
atomicModifyIORef'_ IORef EnabledBacktraceMechanisms
enabledBacktraceMechanismsRef (BacktraceMechanism
-> Bool -> EnabledBacktraceMechanisms -> EnabledBacktraceMechanisms
setBacktraceMechanismEnabled BacktraceMechanism
bm Bool
enabled)
    return ()

-- | A collection of backtraces.
data Backtraces =
    Backtraces {
        Backtraces -> Maybe (Ptr CostCentreStack)
btrCostCentre :: Maybe (Ptr CCS.CostCentreStack),
        Backtraces -> Maybe CallStack
btrHasCallStack :: Maybe HCS.CallStack,
        Backtraces -> Maybe [Location]
btrExecutionStack :: Maybe [ExecStack.Location],
        Backtraces -> Maybe [StackEntry]
btrIpe :: Maybe [CloneStack.StackEntry]
    }

-- | Render a set of backtraces to a human-readable string.
displayBacktraces :: Backtraces -> String
displayBacktraces :: Backtraces -> String
displayBacktraces Backtraces
bts = [String] -> String
forall a. [[a]] -> [a]
concat
    [ String
-> (Backtraces -> Maybe (Ptr CostCentreStack))
-> (Ptr CostCentreStack -> String)
-> String
forall rep.
String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String
displayOne String
"Cost-centre stack backtrace" Backtraces -> Maybe (Ptr CostCentreStack)
btrCostCentre Ptr CostCentreStack -> String
displayCc
    , String
-> (Backtraces -> Maybe [Location])
-> ([Location] -> String)
-> String
forall rep.
String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String
displayOne String
"Native stack backtrace" Backtraces -> Maybe [Location]
btrExecutionStack [Location] -> String
displayExec
    , String
-> (Backtraces -> Maybe [StackEntry])
-> ([StackEntry] -> String)
-> String
forall rep.
String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String
displayOne String
"IPE backtrace" Backtraces -> Maybe [StackEntry]
btrIpe [StackEntry] -> String
displayIpe
    , String
-> (Backtraces -> Maybe CallStack)
-> (CallStack -> String)
-> String
forall rep.
String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String
displayOne String
"HasCallStack backtrace" Backtraces -> Maybe CallStack
btrHasCallStack CallStack -> String
displayHsc
    ]
  where
    indent :: Int -> String -> String
    indent :: Int -> String -> String
indent Int
n String
s  = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

    -- The unsafePerformIO here is safe as we don't currently unload cost-centres.
    displayCc :: Ptr CostCentreStack -> String
displayCc   = [String] -> String
unlines ([String] -> String)
-> (Ptr CostCentreStack -> [String])
-> Ptr CostCentreStack
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
indent Int
2) ([String] -> [String])
-> (Ptr CostCentreStack -> [String])
-> Ptr CostCentreStack
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [String] -> [String]
forall a. IO a -> a
unsafePerformIO (IO [String] -> [String])
-> (Ptr CostCentreStack -> IO [String])
-> Ptr CostCentreStack
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr CostCentreStack -> IO [String]
CCS.ccsToStrings
    displayExec :: [Location] -> String
displayExec = [String] -> String
unlines ([String] -> String)
-> ([Location] -> [String]) -> [Location] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location -> String) -> [Location] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
indent Int
2 (String -> String) -> (Location -> String) -> Location -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location -> String -> String) -> String -> Location -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Location -> String -> String
ExecStack.showLocation String
"")
    displayIpe :: [StackEntry] -> String
displayIpe  = [String] -> String
unlines ([String] -> String)
-> ([StackEntry] -> [String]) -> [StackEntry] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StackEntry -> String) -> [StackEntry] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
indent Int
2 (String -> String)
-> (StackEntry -> String) -> StackEntry -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackEntry -> String
CloneStack.prettyStackEntry)
    displayHsc :: CallStack -> String
displayHsc  = [String] -> String
unlines ([String] -> String)
-> (CallStack -> [String]) -> CallStack -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, SrcLoc) -> String) -> [(String, SrcLoc)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
indent Int
2 (String -> String)
-> ((String, SrcLoc) -> String) -> (String, SrcLoc) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> String
prettyCallSite) ([(String, SrcLoc)] -> [String])
-> (CallStack -> [(String, SrcLoc)]) -> CallStack -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> [(String, SrcLoc)]
HCS.getCallStack
      where prettyCallSite :: (String, SrcLoc) -> String
prettyCallSite (String
f, SrcLoc
loc) = String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", called at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
HCS.prettySrcLoc SrcLoc
loc

    displayOne :: String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String
    displayOne :: forall rep.
String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String
displayOne String
label Backtraces -> Maybe rep
getBt rep -> String
displ
      | Just rep
bt <- Backtraces -> Maybe rep
getBt Backtraces
bts = [String] -> String
forall a. [[a]] -> [a]
concat [String
label, String
":\n", rep -> String
displ rep
bt]
      | Bool
otherwise            = String
""

instance ExceptionAnnotation Backtraces where
    displayExceptionAnnotation :: Backtraces -> String
displayExceptionAnnotation = Backtraces -> String
displayBacktraces

-- | Collect a set of 'Backtraces'.
collectBacktraces :: (?callStack :: CallStack) => IO Backtraces
collectBacktraces :: (?callStack::CallStack) => IO Backtraces
collectBacktraces = ((?callStack::CallStack) => IO Backtraces) -> IO Backtraces
forall a.
(?callStack::CallStack) =>
((?callStack::CallStack) => a) -> a
HCS.withFrozenCallStack (((?callStack::CallStack) => IO Backtraces) -> IO Backtraces)
-> ((?callStack::CallStack) => IO Backtraces) -> IO Backtraces
forall a b. (a -> b) -> a -> b
$ do
    IO EnabledBacktraceMechanisms
getEnabledBacktraceMechanisms IO EnabledBacktraceMechanisms
-> (EnabledBacktraceMechanisms -> IO Backtraces) -> IO Backtraces
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (?callStack::CallStack) =>
EnabledBacktraceMechanisms -> IO Backtraces
EnabledBacktraceMechanisms -> IO Backtraces
collectBacktraces'

collectBacktraces'
    :: (?callStack :: CallStack)
    => EnabledBacktraceMechanisms -> IO Backtraces
collectBacktraces' :: (?callStack::CallStack) =>
EnabledBacktraceMechanisms -> IO Backtraces
collectBacktraces' EnabledBacktraceMechanisms
enabled = ((?callStack::CallStack) => IO Backtraces) -> IO Backtraces
forall a.
(?callStack::CallStack) =>
((?callStack::CallStack) => a) -> a
HCS.withFrozenCallStack (((?callStack::CallStack) => IO Backtraces) -> IO Backtraces)
-> ((?callStack::CallStack) => IO Backtraces) -> IO Backtraces
forall a b. (a -> b) -> a -> b
$ do
    let collect :: BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a)
        collect :: forall a. BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a)
collect BacktraceMechanism
mech IO (Maybe a)
f
          | BacktraceMechanism -> EnabledBacktraceMechanisms -> Bool
backtraceMechanismEnabled BacktraceMechanism
mech EnabledBacktraceMechanisms
enabled = IO (Maybe a)
f
          | Bool
otherwise = Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

    ccs <- BacktraceMechanism
-> IO (Maybe (Ptr CostCentreStack))
-> IO (Maybe (Ptr CostCentreStack))
forall a. BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a)
collect BacktraceMechanism
CostCentreBacktrace (IO (Maybe (Ptr CostCentreStack))
 -> IO (Maybe (Ptr CostCentreStack)))
-> IO (Maybe (Ptr CostCentreStack))
-> IO (Maybe (Ptr CostCentreStack))
forall a b. (a -> b) -> a -> b
$ do
        Ptr CostCentreStack -> Maybe (Ptr CostCentreStack)
forall a. a -> Maybe a
Just (Ptr CostCentreStack -> Maybe (Ptr CostCentreStack))
-> IO (Ptr CostCentreStack) -> IO (Maybe (Ptr CostCentreStack))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` () -> IO (Ptr CostCentreStack)
forall dummy. dummy -> IO (Ptr CostCentreStack)
CCS.getCurrentCCS ()

    exec <- collect ExecutionBacktrace $ do
        ExecStack.getStackTrace

    ipe <- collect IPEBacktrace $ do
        stack <- CloneStack.cloneMyStack
        stackEntries <- CloneStack.decode stack
        return (Just stackEntries)

    hcs <- collect HasCallStackBacktrace $ do
        return (Just ?callStack)

    return (Backtraces { btrCostCentre = ccs
                       , btrHasCallStack = hcs
                       , btrExecutionStack = exec
                       , btrIpe = ipe
                       })