(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](GHC.Stack.CCS.html#currentCallStack),
[whoCreated](GHC.Stack.CCS.html#whoCreated),
[whereFrom](GHC.Stack.CCS.html#whereFrom),


[CostCentreStack](GHC.Stack.CCS.html#CostCentreStack),
[CostCentre](GHC.Stack.CCS.html#CostCentre),
[getCurrentCCS](GHC.Stack.CCS.html#getCurrentCCS),
[getCCSOf](GHC.Stack.CCS.html#getCCSOf),
[clearCCS](GHC.Stack.CCS.html#clearCCS),
[ccsCC](GHC.Stack.CCS.html#ccsCC),
[ccsParent](GHC.Stack.CCS.html#ccsParent),
[ccLabel](GHC.Stack.CCS.html#ccLabel),
[ccModule](GHC.Stack.CCS.html#ccModule),
[ccSrcSpan](GHC.Stack.CCS.html#ccSrcSpan),
[ccsToStrings](GHC.Stack.CCS.html#ccsToStrings),
[renderStack](GHC.Stack.CCS.html#renderStack),
[ipeProv](GHC.Stack.CCS.html#ipeProv),
[peekInfoProv](GHC.Stack.CCS.html#peekInfoProv),
[InfoProv](GHC.Stack.CCS.html#InfoProv)(..),
[InfoProvEnt](GHC.Stack.CCS.html#InfoProvEnt),

) 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 ) import GHC.Show (Show)

data CostCentreStack

data CostCentre

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

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

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

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 87 "libraries/base/GHC/Stack/CCS.hsc" #-}

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 91 "libraries/base/GHC/Stack/CCS.hsc" #-}

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 95 "libraries/base/GHC/Stack/CCS.hsc" #-}

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 99 "libraries/base/GHC/Stack/CCS.hsc" #-}

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 103 "libraries/base/GHC/Stack/CCS.hsc" #-}

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

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 Ptr CostCentre cc <- Ptr CostCentreStack -> IO (Ptr CostCentre) ccsCC Ptr CostCentreStack ccs String lbl <- TextEncoding -> CString -> IO String GHC.peekCString TextEncoding utf8 (CString -> IO String) -> IO CString -> IO String 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 (CString -> IO String) -> IO CString -> IO String 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 (CString -> IO String) -> IO CString -> IO String 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 String -> String -> Bool forall a. Eq a => a -> a -> Bool == String "MAIN" Bool -> Bool -> Bool && String lbl String -> String -> Bool forall a. Eq a => a -> a -> Bool == String "MAIN") then [String] -> IO [String] forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return [String] acc else Ptr CostCentreStack -> [String] -> IO [String] go Ptr CostCentreStack parent ((String mdl String -> String -> String forall a. [a] -> [a] -> [a] ++ Char '.'Char -> String -> String forall a. a -> [a] -> [a] :String lbl String -> String -> String forall a. [a] -> [a] -> [a] ++ Char ' 'Char -> String -> String forall a. a -> [a] -> [a] :Char '('Char -> String -> String forall a. a -> [a] -> [a] :String loc String -> String -> String forall a. [a] -> [a] -> [a] ++ String ")") String -> [String] -> [String] forall a. a -> [a] -> [a] : [String] acc)

whoCreated :: a -> IO [String] whoCreated :: forall a. a -> IO [String] whoCreated a obj = do Ptr CostCentreStack ccs <- a -> IO (Ptr CostCentreStack) 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):" 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)

data InfoProv = InfoProv { InfoProv -> String ipName :: String, InfoProv -> String ipDesc :: String, InfoProv -> String ipTyDesc :: String, InfoProv -> String ipLabel :: String, InfoProv -> String ipMod :: String, InfoProv -> String ipLoc :: String } deriving (InfoProv -> InfoProv -> Bool (InfoProv -> InfoProv -> Bool) -> (InfoProv -> InfoProv -> Bool) -> Eq InfoProv forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: InfoProv -> InfoProv -> Bool == :: InfoProv -> InfoProv -> Bool $c/= :: InfoProv -> InfoProv -> Bool /= :: InfoProv -> InfoProv -> Bool Eq, Int -> InfoProv -> String -> String [InfoProv] -> String -> String InfoProv -> String (Int -> InfoProv -> String -> String) -> (InfoProv -> String) -> ([InfoProv] -> String -> String) -> Show InfoProv forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a $cshowsPrec :: Int -> InfoProv -> String -> String showsPrec :: Int -> InfoProv -> String -> String $cshow :: InfoProv -> String show :: InfoProv -> String $cshowList :: [InfoProv] -> String -> String showList :: [InfoProv] -> String -> String Show) data InfoProvEnt

getIPE :: a -> IO (Ptr InfoProvEnt) getIPE :: forall a. a -> IO (Ptr InfoProvEnt) getIPE a obj = (State# RealWorld -> (# State# RealWorld, Ptr InfoProvEnt #)) -> IO (Ptr InfoProvEnt) forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a IO ((State# RealWorld -> (# State# RealWorld, Ptr InfoProvEnt #)) -> IO (Ptr InfoProvEnt)) -> (State# RealWorld -> (# State# RealWorld, Ptr InfoProvEnt #)) -> IO (Ptr InfoProvEnt) 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# #) whereFrom# a obj State# RealWorld s of (# State# RealWorld s', Addr# addr #) -> (# State# RealWorld s', Addr# -> Ptr InfoProvEnt 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 Ptr InfoProvEnt -> Int -> Ptr InfoProv forall a b. Ptr a -> Int -> Ptr b plusPtr Int 8)) Ptr InfoProvEnt p {-# LINE 164 "libraries/base/GHC/Stack/CCS.hsc" #-}

peekIpName, peekIpDesc, peekIpLabel, peekIpModule, peekIpSrcLoc, peekIpTyDesc :: Ptr InfoProv -> IO CString peekIpName :: Ptr InfoProv -> IO CString peekIpName Ptr InfoProv p = ((\Ptr InfoProv hsc_ptr -> Ptr InfoProv -> Int -> IO CString forall b. Ptr b -> Int -> IO CString forall a b. Storable a => Ptr b -> Int -> IO a peekByteOff Ptr InfoProv hsc_ptr Int 0)) Ptr InfoProv p {-# LINE 167 "libraries/base/GHC/Stack/CCS.hsc" #-} peekIpDesc p = ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p {-# LINE 168 "libraries/base/GHC/Stack/CCS.hsc" #-} peekIpLabel p = ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p {-# LINE 169 "libraries/base/GHC/Stack/CCS.hsc" #-} peekIpModule p = ((\hsc_ptr -> peekByteOff hsc_ptr 32)) p {-# LINE 170 "libraries/base/GHC/Stack/CCS.hsc" #-} peekIpSrcLoc p = ((\hsc_ptr -> peekByteOff hsc_ptr 40)) p {-# LINE 171 "libraries/base/GHC/Stack/CCS.hsc" #-} peekIpTyDesc p = ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p {-# LINE 172 "libraries/base/GHC/Stack/CCS.hsc" #-}

peekInfoProv :: Ptr InfoProv -> IO InfoProv peekInfoProv :: Ptr InfoProv -> IO InfoProv peekInfoProv Ptr InfoProv infop = do String name <- TextEncoding -> CString -> IO String GHC.peekCString TextEncoding utf8 (CString -> IO String) -> IO CString -> IO String forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Ptr InfoProv -> IO CString peekIpName Ptr InfoProv infop String desc <- TextEncoding -> CString -> IO String GHC.peekCString TextEncoding utf8 (CString -> IO String) -> IO CString -> IO String forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Ptr InfoProv -> IO CString peekIpDesc Ptr InfoProv infop String tyDesc <- TextEncoding -> CString -> IO String GHC.peekCString TextEncoding utf8 (CString -> IO String) -> IO CString -> IO String forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Ptr InfoProv -> IO CString peekIpTyDesc Ptr InfoProv infop String label <- TextEncoding -> CString -> IO String GHC.peekCString TextEncoding utf8 (CString -> IO String) -> IO CString -> IO String forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Ptr InfoProv -> IO CString peekIpLabel Ptr InfoProv infop String mod <- TextEncoding -> CString -> IO String GHC.peekCString TextEncoding utf8 (CString -> IO String) -> IO CString -> IO String forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Ptr InfoProv -> IO CString peekIpModule Ptr InfoProv infop String loc <- TextEncoding -> CString -> IO String GHC.peekCString TextEncoding utf8 (CString -> IO String) -> IO CString -> IO String forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Ptr InfoProv -> IO CString peekIpSrcLoc Ptr InfoProv infop InfoProv -> IO InfoProv forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return InfoProv { ipName :: String ipName = String name, ipDesc :: String ipDesc = String desc, ipTyDesc :: String ipTyDesc = String tyDesc, ipLabel :: String ipLabel = String label, ipMod :: String ipMod = String mod, ipLoc :: String ipLoc = String loc }

whereFrom :: a -> IO (Maybe InfoProv) whereFrom :: forall a. a -> IO (Maybe InfoProv) whereFrom a obj = do Ptr InfoProvEnt ipe <- a -> IO (Ptr InfoProvEnt) forall a. a -> IO (Ptr InfoProvEnt) getIPE a obj

if Ptr InfoProvEnt ipe Ptr InfoProvEnt -> Ptr InfoProvEnt -> Bool forall a. Eq a => a -> a -> Bool == Ptr InfoProvEnt forall a. Ptr a nullPtr then Maybe InfoProv -> IO (Maybe InfoProv) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return Maybe InfoProv forall a. Maybe a Nothing else do InfoProv infoProv <- Ptr InfoProv -> IO InfoProv peekInfoProv (Ptr InfoProvEnt -> Ptr InfoProv ipeProv Ptr InfoProvEnt ipe) Maybe InfoProv -> IO (Maybe InfoProv) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (Maybe InfoProv -> IO (Maybe InfoProv)) -> Maybe InfoProv -> IO (Maybe InfoProv) forall a b. (a -> b) -> a -> b $ InfoProv -> Maybe InfoProv forall a. a -> Maybe a Just InfoProv infoProv