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.

6 files changed, 76 insertions, 0 deletions

diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index 8389de098c..27b7f55132 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -3245,6 +3245,17 @@ primop  ClearCCSOp "clearCCS#" GenPrimOp
    out_of_line = True
 
 ------------------------------------------------------------------------
+section "Info Table Origin"
+------------------------------------------------------------------------
+primop WhereFromOp "whereFrom#" GenPrimOp
+   a -> State# s -> (# State# s, Addr# #)
+   { Returns the {\tt InfoProvEnt } for the info table of the given object
+     (value is {\tt NULL} if the table does not exist or there is no information
+     about the closure).}
+   with
+   out_of_line = True
+
+------------------------------------------------------------------------
 section "Etc"
         {Miscellaneous built-ins}
 ------------------------------------------------------------------------
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index b7fde9642c..a0acdf897a 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1616,6 +1616,7 @@ emitPrimOp dflags primop = case primop of
   NewBCOOp -> alwaysExternal
   UnpackClosureOp -> alwaysExternal
   ClosureSizeOp -> alwaysExternal
+  WhereFromOp   -> alwaysExternal
   GetApStackValOp -> alwaysExternal
   ClearCCSOp -> alwaysExternal
   TraceEventOp -> alwaysExternal
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index 66fe9663ba..43e099a0d6 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -480,6 +480,7 @@ RTS_FUN_DECL(stg_writeTVarzh);
 
 RTS_FUN_DECL(stg_unpackClosurezh);
 RTS_FUN_DECL(stg_closureSizzezh);
+RTS_FUN_DECL(stg_whereFromzh);
 RTS_FUN_DECL(stg_getApStackValzh);
 RTS_FUN_DECL(stg_getSparkzh);
 RTS_FUN_DECL(stg_numSparkszh);
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)
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 77296e20ae..9283ed79c8 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -2437,6 +2437,15 @@ stg_closureSizzezh (P_ clos)
     return (len);
 }
 
+stg_whereFromzh (P_ clos)
+{
+    P_ ipe;
+    W_ info;
+    info = GET_INFO(UNTAG(clos));
+    (ipe) = foreign "C" lookupIPE(info "ptr");
+    return (ipe);
+}
+
 /* -----------------------------------------------------------------------------
    Thread I/O blocking primitives
    -------------------------------------------------------------------------- */
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index f4c15e113b..50a3bae267 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -678,6 +678,7 @@
       SymI_HasProto(initLinker_)                                        \
       SymI_HasProto(stg_unpackClosurezh)                                \
       SymI_HasProto(stg_closureSizzezh)                                 \
+      SymI_HasProto(stg_whereFromzh)                                 \
       SymI_HasProto(stg_getApStackValzh)                                \
       SymI_HasProto(stg_getSparkzh)                                     \
       SymI_HasProto(stg_numSparkszh)                                    \