diff options
author | Ben Gamari <ben@smart-cactus.org> | 2022-08-17 14:37:05 -0400 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-10-11 23:45:10 -0400 |
commit | f6e8feb475cf421c408102c2abd531e380b67b00 (patch) | |
tree | 1fa56fcc63d6a047289d0bbfd19f9d1ae9099417 | |
parent | 69ccec2ce685fee3aeac66519645d568b169b592 (diff) | |
download | haskell-f6e8feb475cf421c408102c2abd531e380b67b00.tar.gz |
base: Move IPE helpers to GHC.InfoProv
-rw-r--r-- | libraries/base/GHC/InfoProv.hsc | 104 | ||||
-rw-r--r-- | libraries/base/GHC/Stack/CCS.hsc | 74 | ||||
-rw-r--r-- | libraries/base/GHC/Stack/CloneStack.hs | 2 | ||||
-rw-r--r-- | libraries/base/base.cabal | 1 | ||||
-rw-r--r-- | testsuite/tests/profiling/should_run/staticcallstack001.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/profiling/should_run/staticcallstack002.hs | 2 |
6 files changed, 108 insertions, 77 deletions
diff --git a/libraries/base/GHC/InfoProv.hsc b/libraries/base/GHC/InfoProv.hsc new file mode 100644 index 0000000000..4f23322a60 --- /dev/null +++ b/libraries/base/GHC/InfoProv.hsc @@ -0,0 +1,104 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.InfoProv +-- 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 info-table provenance metadata. +-- +-- @since 4.18.0.0 +----------------------------------------------------------------------------- + +module GHC.InfoProv + ( InfoProv(..) + , ipeProv + , whereFrom + -- * Internals + , InfoProvEnt + , peekInfoProv + ) where + +#include "Rts.h" + +import GHC.Base +import GHC.Show +import GHC.Ptr (Ptr(..), plusPtr, nullPtr) +import GHC.Foreign (CString, peekCString) +import GHC.IO.Encoding (utf8) +import Foreign.Storable (peekByteOff) + +data InfoProv = InfoProv { + ipName :: String, + ipDesc :: String, + ipTyDesc :: String, + ipLabel :: String, + ipMod :: String, + ipLoc :: String +} deriving (Eq, Show) +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 = (#ptr InfoProvEnt, prov) p + +peekIpName, peekIpDesc, peekIpLabel, peekIpModule, peekIpSrcLoc, peekIpTyDesc :: Ptr InfoProv -> IO CString +peekIpName p = (# peek InfoProv, table_name) p +peekIpDesc p = (# peek InfoProv, closure_desc) p +peekIpLabel p = (# peek InfoProv, label) p +peekIpModule p = (# peek InfoProv, module) p +peekIpSrcLoc p = (# peek InfoProv, srcloc) p +peekIpTyDesc p = (# peek InfoProv, ty_desc) p + +peekInfoProv :: Ptr InfoProv -> IO InfoProv +peekInfoProv infop = do + name <- peekCString utf8 =<< peekIpName infop + desc <- peekCString utf8 =<< peekIpDesc infop + tyDesc <- peekCString utf8 =<< peekIpTyDesc infop + label <- peekCString utf8 =<< peekIpLabel infop + mod <- peekCString utf8 =<< peekIpModule infop + loc <- peekCString utf8 =<< peekIpSrcLoc infop + return InfoProv { + ipName = name, + ipDesc = desc, + ipTyDesc = tyDesc, + ipLabel = label, + ipMod = mod, + ipLoc = loc + } + +-- | Get information about where a value originated from. +-- This information is stored statically in a binary when `-finfo-table-map` is +-- enabled. The source positions will be greatly improved by also enabled debug +-- information with `-g3`. Finally you can enable `-fdistinct-constructor-tables` to +-- get more precise information about data constructor allocations. +-- +-- The information is collect by looking at the info table address of a specific closure and +-- then consulting a specially generated map (by `-finfo-table-map`) to find out where we think +-- the best source position to describe that info table arose from. +-- +-- @since 4.16.0.0 +whereFrom :: a -> IO (Maybe InfoProv) +whereFrom obj = do + ipe <- getIPE obj + -- The primop returns the null pointer in two situations at the moment + -- 1. The lookup fails for whatever reason + -- 2. -finfo-table-map is not enabled. + -- It would be good to distinguish between these two cases somehow. + if ipe == nullPtr + then return Nothing + else do + infoProv <- peekInfoProv (ipeProv ipe) + return $ Just infoProv diff --git a/libraries/base/GHC/Stack/CCS.hsc b/libraries/base/GHC/Stack/CCS.hsc index 757acba114..fa85270012 100644 --- a/libraries/base/GHC/Stack/CCS.hsc +++ b/libraries/base/GHC/Stack/CCS.hsc @@ -20,7 +20,6 @@ module GHC.Stack.CCS ( -- * Call stacks currentCallStack, whoCreated, - whereFrom, -- * Internals CostCentreStack, @@ -35,10 +34,6 @@ module GHC.Stack.CCS ( ccSrcSpan, ccsToStrings, renderStack, - ipeProv, - peekInfoProv, - InfoProv(..), - InfoProvEnt, ) where import Foreign @@ -49,7 +44,6 @@ import GHC.Ptr import GHC.Foreign as GHC import GHC.IO.Encoding import GHC.List ( concatMap, reverse ) -import GHC.Show (Show) #define PROFILING #include "Rts.h" @@ -142,71 +136,3 @@ renderStack :: [String] -> String renderStack strs = "CallStack (from -prof):" ++ concatMap ("\n "++) (reverse strs) --- Static Closure Information - -data InfoProv = InfoProv { - ipName :: String, - ipDesc :: String, - ipTyDesc :: String, - ipLabel :: String, - ipMod :: String, - ipLoc :: String -} deriving (Eq, Show) -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 = (#ptr InfoProvEnt, prov) p - -peekIpName, peekIpDesc, peekIpLabel, peekIpModule, peekIpSrcLoc, peekIpTyDesc :: Ptr InfoProv -> IO CString -peekIpName p = (# peek InfoProv, table_name) p -peekIpDesc p = (# peek InfoProv, closure_desc) p -peekIpLabel p = (# peek InfoProv, label) p -peekIpModule p = (# peek InfoProv, module) p -peekIpSrcLoc p = (# peek InfoProv, srcloc) p -peekIpTyDesc p = (# peek InfoProv, ty_desc) p - -peekInfoProv :: Ptr InfoProv -> IO InfoProv -peekInfoProv infop = do - name <- GHC.peekCString utf8 =<< peekIpName infop - desc <- GHC.peekCString utf8 =<< peekIpDesc infop - tyDesc <- GHC.peekCString utf8 =<< peekIpTyDesc infop - label <- GHC.peekCString utf8 =<< peekIpLabel infop - mod <- GHC.peekCString utf8 =<< peekIpModule infop - loc <- GHC.peekCString utf8 =<< peekIpSrcLoc infop - return InfoProv { - ipName = name, - ipDesc = desc, - ipTyDesc = tyDesc, - ipLabel = label, - ipMod = mod, - ipLoc = loc - } - --- | Get information about where a value originated from. --- This information is stored statically in a binary when `-finfo-table-map` is --- enabled. The source positions will be greatly improved by also enabled debug --- information with `-g3`. Finally you can enable `-fdistinct-constructor-tables` to --- get more precise information about data constructor allocations. --- --- The information is collect by looking at the info table address of a specific closure and --- then consulting a specially generated map (by `-finfo-table-map`) to find out where we think --- the best source position to describe that info table arose from. --- --- @since 4.16.0.0 -whereFrom :: a -> IO (Maybe InfoProv) -whereFrom obj = do - ipe <- getIPE obj - -- The primop returns the null pointer in two situations at the moment - -- 1. The lookup fails for whatever reason - -- 2. -finfo-table-map is not enabled. - -- It would be good to distinguish between these two cases somehow. - if ipe == nullPtr - then return Nothing - else do - infoProv <- peekInfoProv (ipeProv ipe) - return $ Just infoProv diff --git a/libraries/base/GHC/Stack/CloneStack.hs b/libraries/base/GHC/Stack/CloneStack.hs index ecf2383d8d..bc2919218a 100644 --- a/libraries/base/GHC/Stack/CloneStack.hs +++ b/libraries/base/GHC/Stack/CloneStack.hs @@ -28,7 +28,7 @@ import Foreign import GHC.Conc.Sync import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofArray#, indexArray#, State#, StablePtr#) import GHC.IO (IO (..)) -import GHC.Stack.CCS (InfoProv (..), InfoProvEnt, ipeProv, peekInfoProv) +import GHC.InfoProv (InfoProv (..), InfoProvEnt, ipeProv, peekInfoProv) import GHC.Stable -- | A frozen snapshot of the state of an execution stack. diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 851c98792d..46b1413ba5 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -222,6 +222,7 @@ Library GHC.GHCi GHC.GHCi.Helpers GHC.Generics + GHC.InfoProv GHC.IO GHC.IO.Buffer GHC.IO.BufferedIO diff --git a/testsuite/tests/profiling/should_run/staticcallstack001.hs b/testsuite/tests/profiling/should_run/staticcallstack001.hs index e3e1407492..63892d98c3 100644 --- a/testsuite/tests/profiling/should_run/staticcallstack001.hs +++ b/testsuite/tests/profiling/should_run/staticcallstack001.hs @@ -1,6 +1,6 @@ module Main where -import GHC.Stack.CCS +import GHC.InfoProv data D = D Int deriving Show diff --git a/testsuite/tests/profiling/should_run/staticcallstack002.hs b/testsuite/tests/profiling/should_run/staticcallstack002.hs index da3d66efb2..5f986d1ff6 100644 --- a/testsuite/tests/profiling/should_run/staticcallstack002.hs +++ b/testsuite/tests/profiling/should_run/staticcallstack002.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UnboxedTuples #-} module Main where -import GHC.Stack.CCS +import GHC.InfoProv -- Unboxed data constructors don't have info tables so there is -- a special case to not generate distinct info tables for unboxed |