    {-# OPTIONS_GHC -optc-DPROFILING #-}
    {-# LINE 1 "libraries/ghc-internal/src/GHC/Internal/Stack/CCS.hsc" #-}
    {-# LANGUAGE Trustworthy #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  GHC.Internal.Stack.CCS
    -- Copyright   :  (c) The University of Glasgow 2011
    -- License     :  see libraries/base/LICENSE
    --
    -- Maintainer  :  ghc-devs@haskell.org
    -- Stability   :  internal
    -- Portability :  non-portable (GHC Extensions)
    --
    -- Access to GHC's call-stack simulation
    --
    -- @since base-4.5.0.0
    -----------------------------------------------------------------------------

    {-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}
    module GHC.Internal.Stack.CCS (
        -- * Call stacks
        currentCallStack,
        whoCreated,

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

    import GHC.Internal.Foreign.C.String
    import GHC.Internal.Foreign.C.String.Encoding as GHC
    import GHC.Internal.Foreign.Storable

    import GHC.Internal.Base
    import GHC.Internal.Ptr
    import GHC.Internal.IO.Encoding
    import GHC.Internal.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 = (State# RealWorld -> (# State# RealWorld, Ptr CostCentreStack #))
    -> IO (Ptr CostCentreStack)
    forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
    IO ((State# RealWorld -> (# State# RealWorld, Ptr CostCentreStack #))
     -> IO (Ptr CostCentreStack))
    -> (State# RealWorld
        -> (# State# RealWorld, Ptr CostCentreStack #))
    -> IO (Ptr CostCentreStack)
    forall a b. (a -> b) -> a -> b
    $ \State# RealWorld
    s ->
       case dummy -> State# RealWorld -> (# State# RealWorld, Addr# #)
    forall a d. a -> State# d -> (# State# d, Addr# #)
    getCurrentCCS# dummy
    dummy State# RealWorld
    s of
         (# State# RealWorld
    s', Addr#
    addr #) -> (# State# RealWorld
    s', Addr# -> Ptr CostCentreStack
    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 = (State# RealWorld -> (# State# RealWorld, Ptr CostCentreStack #))
    -> IO (Ptr CostCentreStack)
    forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
    IO ((State# RealWorld -> (# State# RealWorld, Ptr CostCentreStack #))
     -> IO (Ptr CostCentreStack))
    -> (State# RealWorld
        -> (# State# RealWorld, Ptr CostCentreStack #))
    -> IO (Ptr CostCentreStack)
    forall a b. (a -> b) -> a -> b
    $ \State# RealWorld
    s ->
       case a -> State# RealWorld -> (# State# RealWorld, Addr# #)
    forall a d. a -> State# d -> (# State# d, Addr# #)
    getCCSOf# a
    obj State# RealWorld
    s of
         (# State# RealWorld
    s', Addr#
    addr #) -> (# State# RealWorld
    s', Addr# -> Ptr CostCentreStack
    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) = (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
    forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
    IO ((State# RealWorld -> (# State# RealWorld, a #)) -> IO a)
    -> (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \State# RealWorld
    s -> (State# RealWorld -> (# State# RealWorld, a #))
    -> State# RealWorld -> (# State# RealWorld, a #)
    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'.

    {-# LINE 95 "libraries/ghc-internal/src/GHC/Internal/Stack/CCS.hsc" #-}
    ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)
    ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)
    ccsCC Ptr CostCentreStack
    p = ((\Ptr CostCentreStack
    hsc_ptr -> Ptr CostCentreStack -> Int -> IO (Ptr CostCentre)
    forall b. Ptr b -> Int -> IO (Ptr CostCentre)
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr CostCentreStack
    hsc_ptr Int
    8)) Ptr CostCentreStack
    p
    {-# LINE 97 "libraries/ghc-internal/src/GHC/Internal/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 -> Ptr CostCentreStack -> Int -> IO (Ptr CostCentreStack)
    forall b. Ptr b -> Int -> IO (Ptr CostCentreStack)
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr CostCentreStack
    hsc_ptr Int
    16)) Ptr CostCentreStack
    p
    {-# LINE 101 "libraries/ghc-internal/src/GHC/Internal/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 -> Ptr CostCentre -> Int -> IO CString
    forall b. Ptr b -> Int -> IO CString
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr CostCentre
    hsc_ptr Int
    8)) Ptr CostCentre
    p
    {-# LINE 105 "libraries/ghc-internal/src/GHC/Internal/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 -> Ptr CostCentre -> Int -> IO CString
    forall b. Ptr b -> Int -> IO CString
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr CostCentre
    hsc_ptr Int
    16)) Ptr CostCentre
    p
    {-# LINE 109 "libraries/ghc-internal/src/GHC/Internal/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 -> Ptr CostCentre -> Int -> IO CString
    forall b. Ptr b -> Int -> IO CString
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr CostCentre
    hsc_ptr Int
    24)) Ptr CostCentre
    p
    {-# LINE 113 "libraries/ghc-internal/src/GHC/Internal/Stack/CCS.hsc" #-}

    {-# LINE 114 "libraries/ghc-internal/src/GHC/Internal/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 base-4.5.0.0
    currentCallStack :: IO [String]
    currentCallStack :: IO [String]
    currentCallStack = Ptr CostCentreStack -> IO [String]
    ccsToStrings (Ptr CostCentreStack -> IO [String])
    -> IO (Ptr CostCentreStack) -> IO [String]
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< () -> IO (Ptr CostCentreStack)
    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 Ptr CostCentreStack -> Ptr CostCentreStack -> Bool
    forall a. Eq a => a -> a -> Bool
    == Ptr CostCentreStack
    forall a. Ptr a
    nullPtr = [String] -> IO [String]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [String]
    acc
         | Bool
    otherwise = do
            cc  <- Ptr CostCentreStack -> IO (Ptr CostCentre)
    ccsCC Ptr CostCentreStack
    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 base-4.5.0.0
    whoCreated :: a -> IO [String]
    whoCreated :: forall a. a -> IO [String]
    whoCreated a
    obj = do
      ccs <- a -> IO (Ptr CostCentreStack)
    forall dummy. dummy -> IO (Ptr CostCentreStack)
    getCCSOf a
    obj
      ccsToStrings ccs

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