Add whereFrom# primop

6 files changed, 69 insertions, 0 deletions

diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index c292b9ecdc..248dc22c01 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -3013,6 +3013,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 099a3850dc..6ecca9f4e6 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1515,6 +1515,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 5ffdd5cd7b..df1bd48544 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -479,6 +479,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..783dedee56 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,48 @@ whoCreated obj = do
 renderStack :: [String] -> String
 renderStack strs =
   "CallStack (from -prof):" ++ concatMap ("\n  "++) (reverse strs)
+
+-- Static Closure Information
+
+data InfoProv
+data InfoProvEnt
+
+-- | Get the 'InfoProvEnv' associated with the given value.
+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
+
+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. Profiling 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 a13dae6774..deb7a5949c 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -2409,6 +2409,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 0497d9421d..9fcca369e3 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -679,6 +679,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)                                    \