(original) (raw)

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

{-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-} module GHC.Stack.CCS (

currentCallStack,
whoCreated,
whereFrom,


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 )

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

clearCCS :: IO a -> IO a clearCCS (IO m) = IO $ \s -> clearCCS# m s

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

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

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

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

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

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)

whoCreated :: a -> IO [String] whoCreated obj = do ccs <- getCCSOf obj ccsToStrings ccs

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

data InfoProv data InfoProvEnt

getIPE :: a -> IO (Ptr InfoProvEnt) getIPE obj = IO $ \s -> case whereFrom# obj s of (# s', addr #) -> (# s', Ptr addr #)

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

ipName, ipDesc, ipLabel, ipModule, ipSrcLoc, ipTyDesc :: Ptr InfoProv -> IO CString ipName p = ((\hsc_ptr -> peekByteOff hsc_ptr 0)) 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 {-# LINE 157 "libraries/base/GHC/Stack/CCS.hsc" #-} ipModule p = ((\hsc_ptr -> peekByteOff hsc_ptr 32)) p {-# LINE 158 "libraries/base/GHC/Stack/CCS.hsc" #-} ipSrcLoc p = ((\hsc_ptr -> peekByteOff hsc_ptr 40)) p {-# 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 infop = do name <- GHC.peekCString utf8 =<< ipName infop desc <- GHC.peekCString utf8 =<< ipDesc infop ty_desc <- GHC.peekCString utf8 =<< ipTyDesc infop label <- GHC.peekCString utf8 =<< ipLabel infop mod <- GHC.peekCString utf8 =<< ipModule infop loc <- GHC.peekCString utf8 =<< ipSrcLoc infop return [name, desc, ty_desc, label, mod, loc]

whereFrom :: a -> IO [String] whereFrom obj = do ipe <- getIPE obj

if ipe == nullPtr then return [] else infoProvToStrings (ipeProv ipe)