base: Move IPE helpers to GHC.InfoProv

4 files changed, 106 insertions, 75 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