Add whereFrom and whereFrom# primop

The `whereFrom` function provides a Haskell interface for using the
information created by `-finfo-table-map`. Given a Haskell value, the
info table address will be passed to the `lookupIPE` function in order
to attempt to find the source location information for that particular closure.

At the moment it's not possible to distinguish the absense of the map
and a failed lookup.

1 files changed, 53 insertions, 0 deletions

diff --git a/libraries/base/GHC/Stack/CCS.hsc b/libraries/base/GHC/Stack/CCS.hsc
index ba384a13b4..67e50ae9a1 100644
--- a/libraries/base/GHC/Stack/CCS.hsc
+++ b/libraries/base/GHC/Stack/CCS.hsc
@@ -20,6 +20,7 @@ module GHC.Stack.CCS (
     -- * Call stacks
     currentCallStack,
     whoCreated,
+    whereFrom,
 
     -- * Internals
     CostCentreStack,
@@ -135,3 +136,55 @@ whoCreated obj = do
 renderStack :: [String] -> String
 renderStack strs =
   "CallStack (from -prof):" ++ concatMap ("\n  "++) (reverse strs)
+
+-- Static Closure Information
+
+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 = (#ptr InfoProvEnt, prov) p
+
+ipName, ipDesc, ipLabel, ipModule, ipSrcLoc, ipTyDesc :: Ptr InfoProv -> IO CString
+ipName p   =  (# peek InfoProv, table_name) p
+ipDesc p   =  (# peek InfoProv, closure_desc) p
+ipLabel p  =  (# peek InfoProv, label) p
+ipModule p =  (# peek InfoProv, module) p
+ipSrcLoc p =  (# peek InfoProv, srcloc) p
+ipTyDesc p =  (# peek InfoProv, ty_desc) p
+
+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]
+
+-- TODO: Add structured output of whereFrom
+-- | 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.
+whereFrom :: a -> IO [String]
+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 []
+    else infoProvToStrings (ipeProv ipe)