Movatterモバイル変換

{-# 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 #-}moduleGHC.Stack.CCS(-- * Call stackscurrentCallStack,whoCreated,-- * InternalsCostCentreStack,CostCentre,getCurrentCCS,getCCSOf,clearCCS,ccsCC,ccsParent,ccLabel,ccModule,ccSrcSpan,ccsToStrings,renderStack,)whereimportForeignimportForeign.CimportGHC.BaseimportGHC.PtrimportGHC.ForeignasGHCimportGHC.IO.EncodingimportGHC.List(concatMap,reverse)-- | A cost-centre stack from GHC's cost-center profiler.dataCostCentreStack-- | A cost-centre from GHC's cost-center profiler.dataCostCentre-- | 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(PtrCostCentreStack)getCurrentCCS :: forall dummy. dummy -> IO (Ptr CostCentreStack)getCurrentCCSdummydummy=(State# RealWorld -> (# State# RealWorld, Ptr CostCentreStack #))-> IO (Ptr CostCentreStack)forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO aIO((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# RealWorlds->casedummy -> State# RealWorld -> (# State# RealWorld, Addr# #)forall a d. a -> State# d -> (# State# d, Addr# #)getCurrentCCS#dummydummyState# RealWorldsof(#State# RealWorlds',Addr#addr#)->(#State# RealWorlds',Addr# -> Ptr CostCentreStackforall a. Addr# -> Ptr aPtrAddr#addr#)-- | Get the 'CostCentreStack' associated with the given value.getCCSOf::a->IO(PtrCostCentreStack)getCCSOf :: forall dummy. dummy -> IO (Ptr CostCentreStack)getCCSOfaobj=(State# RealWorld -> (# State# RealWorld, Ptr CostCentreStack #))-> IO (Ptr CostCentreStack)forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO aIO((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# RealWorlds->casea -> State# RealWorld -> (# State# RealWorld, Addr# #)forall a d. a -> State# d -> (# State# d, Addr# #)getCCSOf#aobjState# RealWorldsof(#State# RealWorlds',Addr#addr#)->(#State# RealWorlds',Addr# -> Ptr CostCentreStackforall a. Addr# -> Ptr aPtrAddr#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::IOa->IOaclearCCS :: forall a. IO a -> IO aclearCCS(IOState# RealWorld -> (# State# RealWorld, a #)m)=(State# RealWorld -> (# State# RealWorld, a #)) -> IO aforall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO aIO((State# RealWorld -> (# State# RealWorld, a #)) -> IO a)-> (State# RealWorld -> (# State# RealWorld, a #)) -> IO aforall a b. (a -> b) -> a -> b$\State# RealWorlds->(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 #)mState# RealWorlds-- | Get the 'CostCentre' at the head of a 'CostCentreStack'.{-# LINE 95 "libraries/base/GHC/Stack/CCS.hsc" #-}ccsCC::PtrCostCentreStack->IO(PtrCostCentre)ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)ccsCCPtr CostCentreStackp=((\Ptr CostCentreStackhsc_ptr->Ptr CostCentreStack -> Int -> IO (Ptr CostCentre)forall b. Ptr b -> Int -> IO (Ptr CostCentre)forall a b. Storable a => Ptr b -> Int -> IO apeekByteOffPtr CostCentreStackhsc_ptrInt8))Ptr CostCentreStackp{-# LINE 97 "libraries/base/GHC/Stack/CCS.hsc" #-}-- | Get the tail of a 'CostCentreStack'.ccsParent::PtrCostCentreStack->IO(PtrCostCentreStack)ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)ccsParentPtr CostCentreStackp=((\Ptr CostCentreStackhsc_ptr->Ptr CostCentreStack -> Int -> IO (Ptr CostCentreStack)forall b. Ptr b -> Int -> IO (Ptr CostCentreStack)forall a b. Storable a => Ptr b -> Int -> IO apeekByteOffPtr CostCentreStackhsc_ptrInt16))Ptr CostCentreStackp{-# LINE 101 "libraries/base/GHC/Stack/CCS.hsc" #-}-- | Get the label of a 'CostCentre'.ccLabel::PtrCostCentre->IOCStringccLabel :: Ptr CostCentre -> IO CStringccLabelPtr CostCentrep=((\Ptr CostCentrehsc_ptr->Ptr CostCentre -> Int -> IO CStringforall b. Ptr b -> Int -> IO CStringforall a b. Storable a => Ptr b -> Int -> IO apeekByteOffPtr CostCentrehsc_ptrInt8))Ptr CostCentrep{-# LINE 105 "libraries/base/GHC/Stack/CCS.hsc" #-}-- | Get the module of a 'CostCentre'.ccModule::PtrCostCentre->IOCStringccModule :: Ptr CostCentre -> IO CStringccModulePtr CostCentrep=((\Ptr CostCentrehsc_ptr->Ptr CostCentre -> Int -> IO CStringforall b. Ptr b -> Int -> IO CStringforall a b. Storable a => Ptr b -> Int -> IO apeekByteOffPtr CostCentrehsc_ptrInt16))Ptr CostCentrep{-# LINE 109 "libraries/base/GHC/Stack/CCS.hsc" #-}-- | Get the source span of a 'CostCentre'.ccSrcSpan::PtrCostCentre->IOCStringccSrcSpan :: Ptr CostCentre -> IO CStringccSrcSpanPtr CostCentrep=((\Ptr CostCentrehsc_ptr->Ptr CostCentre -> Int -> IO CStringforall b. Ptr b -> Int -> IO CStringforall a b. Storable a => Ptr b -> Int -> IO apeekByteOffPtr CostCentrehsc_ptrInt24))Ptr CostCentrep{-# LINE 113 "libraries/base/GHC/Stack/CCS.hsc" #-}{-# LINE 114 "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.0currentCallStack::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::PtrCostCentreStack->IO[String]ccsToStrings :: Ptr CostCentreStack -> IO [String]ccsToStringsPtr CostCentreStackccs0=Ptr CostCentreStack -> [String] -> IO [String]goPtr CostCentreStackccs0[]wherego :: Ptr CostCentreStack -> [String] -> IO [String]goPtr CostCentreStackccs[String]acc|Ptr CostCentreStackccsPtr CostCentreStack -> Ptr CostCentreStack -> Boolforall a. Eq a => a -> a -> Bool==Ptr CostCentreStackforall a. Ptr anullPtr=[String] -> IO [String]forall a. a -> IO aforall (m :: * -> *) a. Monad m => a -> m areturn[String]acc|Boolotherwise=doPtr CostCentrecc<-Ptr CostCentreStack -> IO (Ptr CostCentre)ccsCCPtr CostCentreStackccsStringlbl<-TextEncoding -> CString -> IO StringGHC.peekCStringTextEncodingutf8(CString -> IO String) -> IO CString -> IO Stringforall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b=<<Ptr CostCentre -> IO CStringccLabelPtr CostCentreccStringmdl<-TextEncoding -> CString -> IO StringGHC.peekCStringTextEncodingutf8(CString -> IO String) -> IO CString -> IO Stringforall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b=<<Ptr CostCentre -> IO CStringccModulePtr CostCentreccStringloc<-TextEncoding -> CString -> IO StringGHC.peekCStringTextEncodingutf8(CString -> IO String) -> IO CString -> IO Stringforall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b=<<Ptr CostCentre -> IO CStringccSrcSpanPtr CostCentreccPtr CostCentreStackparent<-Ptr CostCentreStack -> IO (Ptr CostCentreStack)ccsParentPtr CostCentreStackccsif(StringmdlString -> String -> Boolforall a. Eq a => a -> a -> Bool==String"MAIN"Bool -> Bool -> Bool&&StringlblString -> String -> Boolforall a. Eq a => a -> a -> Bool==String"MAIN")then[String] -> IO [String]forall a. a -> IO aforall (m :: * -> *) a. Monad m => a -> m areturn[String]accelsePtr CostCentreStack -> [String] -> IO [String]goPtr CostCentreStackparent((StringmdlString -> String -> Stringforall a. [a] -> [a] -> [a]++Char'.'Char -> String -> Stringforall a. a -> [a] -> [a]:StringlblString -> String -> Stringforall a. [a] -> [a] -> [a]++Char' 'Char -> String -> Stringforall a. a -> [a] -> [a]:Char'('Char -> String -> Stringforall a. a -> [a] -> [a]:StringlocString -> String -> Stringforall a. [a] -> [a] -> [a]++String")")String -> [String] -> [String]forall a. a -> [a] -> [a]:[String]acc)-- | Get the stack trace attached to an object.---- @since 4.5.0.0whoCreated::a->IO[String]whoCreated :: forall a. a -> IO [String]whoCreatedaobj=doPtr CostCentreStackccs<-a -> IO (Ptr CostCentreStack)forall dummy. dummy -> IO (Ptr CostCentreStack)getCCSOfaobjPtr CostCentreStack -> IO [String]ccsToStringsPtr CostCentreStackccsrenderStack::[String]->StringrenderStack :: [String] -> StringrenderStack[String]strs=String"CallStack (from -prof):"String -> String -> Stringforall a. [a] -> [a] -> [a]++(String -> String) -> [String] -> Stringforall a b. (a -> [b]) -> [a] -> [b]concatMap(String"\n  "String -> String -> Stringforall a. [a] -> [a] -> [a]++)([String] -> [String]forall a. [a] -> [a]reverse[String]strs)