{-# OPTIONS_GHC -optc-DPROFILING #-}
{-# LINE 1 "libraries/base/GHC/Stack/CCS.hsc" #-}
{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Stack.CCS
-- 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.CCS (
    -- * Call stacks
    currentCallStack,
    whoCreated,
    whereFrom,

    -- * Internals
    CostCentreStack,
    CostCentre,
    getCurrentCCS,
    getCCSOf,
    clearCCS,
    ccsCC,
    ccsParent,
    ccLabel,
    ccModule,
    ccSrcSpan,
    ccsToStrings,
    renderStack
  ) where

import Foreign
import Foreign.C

import GHC.Base
import GHC.Ptr
import GHC.Foreign as GHC
import GHC.IO.Encoding
import GHC.List ( concatMap, reverse )




-- | A cost-centre stack from GHC's cost-center profiler.
data CostCentreStack

-- | A cost-centre from GHC's cost-center profiler.
data CostCentre

-- | Returns the current 'CostCentreStack' (value is @nullPtr@ if the current
-- program was not compiled with profiling support). Takes a dummy argument
-- which can be used to avoid the call to @getCurrentCCS@ being floated out by
-- the simplifier, which would result in an uninformative stack ("CAF").
getCurrentCCS :: dummy -> IO (Ptr CostCentreStack)
getCurrentCCS :: forall dummy. dummy -> IO (Ptr CostCentreStack)
getCurrentCCS dummy
dummy = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
   case forall a d. a -> State# d -> (# State# d, Addr# #)
getCurrentCCS# dummy
dummy State# RealWorld
s of
     (# State# RealWorld
s', Addr#
addr #) -> (# State# RealWorld
s', forall a. Addr# -> Ptr a
Ptr Addr#
addr #)

-- | Get the 'CostCentreStack' associated with the given value.
getCCSOf :: a -> IO (Ptr CostCentreStack)
getCCSOf :: forall dummy. dummy -> IO (Ptr CostCentreStack)
getCCSOf a
obj = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
   case forall a d. a -> State# d -> (# State# d, Addr# #)
getCCSOf# a
obj State# RealWorld
s of
     (# State# RealWorld
s', Addr#
addr #) -> (# State# RealWorld
s', forall a. Addr# -> Ptr a
Ptr Addr#
addr #)

-- | Run a computation with an empty cost-center stack. For example, this is
-- used by the interpreter to run an interpreted computation without the call
-- stack showing that it was invoked from GHC.
clearCCS :: IO a -> IO a
clearCCS :: forall a. IO a -> IO a
clearCCS (IO State# RealWorld -> (# State# RealWorld, a #)
m) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> forall d a.
(State# d -> (# State# d, a #)) -> State# d -> (# State# d, a #)
clearCCS# State# RealWorld -> (# State# RealWorld, a #)
m State# RealWorld
s

-- | Get the 'CostCentre' at the head of a 'CostCentreStack'.
ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)
ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)
ccsCC Ptr CostCentreStack
p = ((\Ptr CostCentreStack
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CostCentreStack
hsc_ptr Int
8)) Ptr CostCentreStack
p
{-# LINE 82 "libraries/base/GHC/Stack/CCS.hsc" #-}

-- | Get the tail of a 'CostCentreStack'.
ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
ccsParent Ptr CostCentreStack
p = ((\Ptr CostCentreStack
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CostCentreStack
hsc_ptr Int
16)) Ptr CostCentreStack
p
{-# LINE 86 "libraries/base/GHC/Stack/CCS.hsc" #-}

-- | Get the label of a 'CostCentre'.
ccLabel :: Ptr CostCentre -> IO CString
ccLabel :: Ptr CostCentre -> IO CString
ccLabel Ptr CostCentre
p = ((\Ptr CostCentre
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CostCentre
hsc_ptr Int
8)) Ptr CostCentre
p
{-# LINE 90 "libraries/base/GHC/Stack/CCS.hsc" #-}

-- | Get the module of a 'CostCentre'.
ccModule :: Ptr CostCentre -> IO CString
ccModule :: Ptr CostCentre -> IO CString
ccModule Ptr CostCentre
p = ((\Ptr CostCentre
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CostCentre
hsc_ptr Int
16)) Ptr CostCentre
p
{-# LINE 94 "libraries/base/GHC/Stack/CCS.hsc" #-}

-- | Get the source span of a 'CostCentre'.
ccSrcSpan :: Ptr CostCentre -> IO CString
ccSrcSpan :: Ptr CostCentre -> IO CString
ccSrcSpan Ptr CostCentre
p = ((\Ptr CostCentre
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CostCentre
hsc_ptr Int
24)) Ptr CostCentre
p
{-# LINE 98 "libraries/base/GHC/Stack/CCS.hsc" #-}

-- | Returns a @[String]@ representing the current call stack.  This
-- can be useful for debugging.
--
-- The implementation uses the call-stack simulation maintained 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 :: IO [String]
currentCallStack = Ptr CostCentreStack -> IO [String]
ccsToStrings forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall dummy. dummy -> IO (Ptr CostCentreStack)
getCurrentCCS ()

-- | Format a 'CostCentreStack' as a list of lines.
ccsToStrings :: Ptr CostCentreStack -> IO [String]
ccsToStrings :: Ptr CostCentreStack -> IO [String]
ccsToStrings Ptr CostCentreStack
ccs0 = Ptr CostCentreStack -> [String] -> IO [String]
go Ptr CostCentreStack
ccs0 []
  where
    go :: Ptr CostCentreStack -> [String] -> IO [String]
go Ptr CostCentreStack
ccs [String]
acc
     | Ptr CostCentreStack
ccs forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr = forall (m :: * -> *) a. Monad m => a -> m a
return [String]
acc
     | Bool
otherwise = do
        Ptr CostCentre
cc  <- Ptr CostCentreStack -> IO (Ptr CostCentre)
ccsCC Ptr CostCentreStack
ccs
        String
lbl <- TextEncoding -> CString -> IO String
GHC.peekCString TextEncoding
utf8 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr CostCentre -> IO CString
ccLabel Ptr CostCentre
cc
        String
mdl <- TextEncoding -> CString -> IO String
GHC.peekCString TextEncoding
utf8 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr CostCentre -> IO CString
ccModule Ptr CostCentre
cc
        String
loc <- TextEncoding -> CString -> IO String
GHC.peekCString TextEncoding
utf8 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr CostCentre -> IO CString
ccSrcSpan Ptr CostCentre
cc
        Ptr CostCentreStack
parent <- Ptr CostCentreStack -> IO (Ptr CostCentreStack)
ccsParent Ptr CostCentreStack
ccs
        if (String
mdl forall a. Eq a => a -> a -> Bool
== String
"MAIN" Bool -> Bool -> Bool
&& String
lbl forall a. Eq a => a -> a -> Bool
== String
"MAIN")
           then forall (m :: * -> *) a. Monad m => a -> m a
return [String]
acc
           else Ptr CostCentreStack -> [String] -> IO [String]
go Ptr CostCentreStack
parent ((String
mdl forall a. [a] -> [a] -> [a]
++ Char
'.'forall a. a -> [a] -> [a]
:String
lbl forall a. [a] -> [a] -> [a]
++ Char
' 'forall a. a -> [a] -> [a]
:Char
'('forall a. a -> [a] -> [a]
:String
loc forall a. [a] -> [a] -> [a]
++ String
")") forall a. a -> [a] -> [a]
: [String]
acc)

-- | Get the stack trace attached to an object.
--
-- @since 4.5.0.0
whoCreated :: a -> IO [String]
whoCreated :: forall a. a -> IO [String]
whoCreated a
obj = do
  Ptr CostCentreStack
ccs <- forall dummy. dummy -> IO (Ptr CostCentreStack)
getCCSOf a
obj
  Ptr CostCentreStack -> IO [String]
ccsToStrings Ptr CostCentreStack
ccs

renderStack :: [String] -> String
renderStack :: [String] -> String
renderStack [String]
strs =
  String
"CallStack (from -prof):" forall a. [a] -> [a] -> [a]
++ forall a b. (a -> [b]) -> [a] -> [b]
concatMap (String
"\n  "forall a. [a] -> [a] -> [a]
++) (forall a. [a] -> [a]
reverse [String]
strs)

-- Static Closure Information

data InfoProv
data InfoProvEnt

getIPE :: a -> IO (Ptr InfoProvEnt)
getIPE :: forall a. a -> IO (Ptr InfoProvEnt)
getIPE a
obj = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
   case forall a d. a -> State# d -> (# State# d, Addr# #)
whereFrom# a
obj State# RealWorld
s of
     (# State# RealWorld
s', Addr#
addr #) -> (# State# RealWorld
s', forall a. Addr# -> Ptr a
Ptr Addr#
addr #)

ipeProv :: Ptr InfoProvEnt -> Ptr InfoProv
ipeProv :: Ptr InfoProvEnt -> Ptr InfoProv
ipeProv Ptr InfoProvEnt
p = ((\Ptr InfoProvEnt
hsc_ptr -> Ptr InfoProvEnt
hsc_ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
8)) Ptr InfoProvEnt
p
{-# LINE 152 "libraries/base/GHC/Stack/CCS.hsc" #-}

ipName, ipDesc, ipLabel, ipModule, ipSrcLoc, ipTyDesc :: Ptr InfoProv -> IO CString
ipName :: Ptr InfoProv -> IO CString
ipName Ptr InfoProv
p   =  ((\Ptr InfoProv
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr InfoProv
hsc_ptr Int
0)) Ptr InfoProv
p
{-# LINE 155 "libraries/base/GHC/Stack/CCS.hsc" #-}
ipDesc p   =  ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
{-# LINE 156 "libraries/base/GHC/Stack/CCS.hsc" #-}
ipLabel p  =  ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p
ipModule :: Ptr InfoProv -> IO CString
{-# LINE 157 "libraries/base/GHC/Stack/CCS.hsc" #-}
ipModule p =  ((\hsc_ptr -> peekByteOff hsc_ptr 32)) p
ipSrcLoc :: Ptr InfoProv -> IO CString
{-# LINE 158 "libraries/base/GHC/Stack/CCS.hsc" #-}
ipSrcLoc p =  ((\hsc_ptr -> peekByteOff hsc_ptr 40)) p
ipTyDesc :: Ptr InfoProv -> IO CString
{-# LINE 159 "libraries/base/GHC/Stack/CCS.hsc" #-}
ipTyDesc p =  ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
{-# LINE 160 "libraries/base/GHC/Stack/CCS.hsc" #-}

infoProvToStrings :: Ptr InfoProv -> IO [String]
infoProvToStrings :: Ptr InfoProv -> IO [String]
infoProvToStrings Ptr InfoProv
infop = do
  String
name <- TextEncoding -> CString -> IO String
GHC.peekCString TextEncoding
utf8 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr InfoProv -> IO CString
ipName Ptr InfoProv
infop
  String
desc <- TextEncoding -> CString -> IO String
GHC.peekCString TextEncoding
utf8 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr InfoProv -> IO CString
ipDesc Ptr InfoProv
infop
  String
ty_desc <- TextEncoding -> CString -> IO String
GHC.peekCString TextEncoding
utf8 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr InfoProv -> IO CString
ipTyDesc Ptr InfoProv
infop
  String
label <- TextEncoding -> CString -> IO String
GHC.peekCString TextEncoding
utf8 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr InfoProv -> IO CString
ipLabel Ptr InfoProv
infop
  String
mod <- TextEncoding -> CString -> IO String
GHC.peekCString TextEncoding
utf8 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr InfoProv -> IO CString
ipModule Ptr InfoProv
infop
  String
loc <- TextEncoding -> CString -> IO String
GHC.peekCString TextEncoding
utf8 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr InfoProv -> IO CString
ipSrcLoc Ptr InfoProv
infop
  forall (m :: * -> *) a. Monad m => a -> m a
return [String
name, String
desc, String
ty_desc, String
label, String
mod, String
loc]

-- TODO: Add structured output of whereFrom
-- | Get information about where a value originated from.
-- This information is stored statically in a binary when `-finfo-table-map` is
-- enabled.  The source positions will be greatly improved by also enabled debug
-- information with `-g3`. Finally you can enable `-fdistinct-constructor-tables` to
-- get more precise information about data constructor allocations.
--
-- The information is collect by looking at the info table address of a specific closure and
-- then consulting a specially generated map (by `-finfo-table-map`) to find out where we think
-- the best source position to describe that info table arose from.
whereFrom :: a -> IO [String]
whereFrom :: forall a. a -> IO [String]
whereFrom a
obj = do
  Ptr InfoProvEnt
ipe <- forall a. a -> IO (Ptr InfoProvEnt)
getIPE a
obj
  -- The primop returns the null pointer in two situations at the moment
  -- 1. The lookup fails for whatever reason
  -- 2. -finfo-table-map is not enabled.
  -- It would be good to distinguish between these two cases somehow.
  if Ptr InfoProvEnt
ipe forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr
    then forall (m :: * -> *) a. Monad m => a -> m a
return []
    else Ptr InfoProv -> IO [String]
infoProvToStrings (Ptr InfoProvEnt -> Ptr InfoProv
ipeProv Ptr InfoProvEnt
ipe)