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

    -----------------------------------------------------------------------------
    -- |
    -- 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 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 )

    {-# LINE 51 "libraries/base/GHC/Stack.hsc" #-}

    {-# LINE 52 "libraries/base/GHC/Stack.hsc" #-}

    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 = ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
    {-# LINE 68 "libraries/base/GHC/Stack.hsc" #-}

    ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
    ccsParent p = ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
    {-# LINE 71 "libraries/base/GHC/Stack.hsc" #-}

    ccLabel :: Ptr CostCentre -> IO CString
    ccLabel p = ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
    {-# LINE 74 "libraries/base/GHC/Stack.hsc" #-}

    ccModule :: Ptr CostCentre -> IO CString
    ccModule p = ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
    {-# LINE 77 "libraries/base/GHC/Stack.hsc" #-}

    ccSrcSpan :: Ptr CostCentre -> IO CString
    ccSrcSpan p = ((\hsc_ptr -> peekByteOff hsc_ptr 12)) p
    {-# LINE 80 "libraries/base/GHC/Stack.hsc" #-}

    -- | 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))