summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2020-11-18 11:56:30 +0000
committerMatthew Pickering <matthewtpickering@gmail.com>2021-03-03 19:09:34 +0000
commit9087899e36015bcc0142700a89c368bbc3da4b81 (patch)
treefeefe3a6b8326358543e4e053ad640919351da7a
parenta7aac008f69ca48e5ab3d4186fdcb3214c6e1463 (diff)
downloadhaskell-9087899e36015bcc0142700a89c368bbc3da4b81.tar.gz
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.
-rw-r--r--compiler/GHC/Builtin/primops.txt.pp11
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs1
-rw-r--r--includes/stg/MiscClosures.h1
-rw-r--r--libraries/base/GHC/Stack/CCS.hsc53
-rw-r--r--rts/PrimOps.cmm9
-rw-r--r--rts/RtsSymbols.c1
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) \