[Git][ghc/ghc][wip/T22077] 2 commits: base: Move IPE helpers to GHC.InfoProv
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri Aug 19 15:16:09 UTC 2022
Ben Gamari pushed to branch wip/T22077 at Glasgow Haskell Compiler / GHC
Commits:
a204fe0c by Ben Gamari at 2022-08-19T10:39:47-04:00
base: Move IPE helpers to GHC.InfoProv
- - - - -
4d840d56 by Ben Gamari at 2022-08-19T11:15:14-04:00
Separate IPE source file from span
The source file name can very often be shared across many IPE entries
whereas the source coordinates are generally unique. Separate the two to
exploit sharing of the former.
- - - - -
13 changed files:
- compiler/GHC/StgToCmm/InfoTableProv.hs
- + libraries/base/GHC/InfoProv.hsc
- libraries/base/GHC/Stack/CCS.hsc
- libraries/base/GHC/Stack/CloneStack.hs
- libraries/base/base.cabal
- rts/IPE.c
- rts/Trace.c
- rts/Trace.h
- rts/eventlog/EventLog.c
- rts/eventlog/EventLog.h
- rts/include/rts/IPE.h
- testsuite/tests/profiling/should_run/staticcallstack001.hs
- testsuite/tests/profiling/should_run/staticcallstack002.hs
Changes:
=====================================
compiler/GHC/StgToCmm/InfoTableProv.hs
=====================================
@@ -4,6 +4,8 @@ import GHC.Prelude
import GHC.Platform
import GHC.Unit.Module
import GHC.Utils.Outputable
+import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile)
+import GHC.Data.FastString (unpackFS)
import GHC.Cmm.CLabel
import GHC.Cmm.Expr
@@ -44,7 +46,8 @@ emitIpeBufferListNode this_mod ents = do
, strtab_offset (ipeTypeDesc cg_ipe)
, strtab_offset (ipeLabel cg_ipe)
, strtab_offset (ipeModuleName cg_ipe)
- , strtab_offset (ipeSrcLoc cg_ipe)
+ , strtab_offset (ipeSrcFile cg_ipe)
+ , strtab_offset (ipeSrcSpan cg_ipe)
]
int n = mkIntCLit platform n
@@ -63,16 +66,26 @@ toCgIPE platform ctx module_name ipe = do
table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform CStyle (infoTablePtr ipe))
closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe)
type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe
+ let label_str = maybe "" snd (infoTableProv ipe)
+ let (src_loc_file, src_loc_span) =
+ case infoTableProv ipe of
+ Nothing -> ("", "")
+ Just (span, _) ->
+ let file = unpackFS $ srcSpanFile span
+ coords = renderWithContext ctx (pprUserRealSpan False span)
+ in (file, coords)
let (src_loc_str, label_str) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ipe)
label <- lookupStringTable $ ST.pack label_str
- src_loc <- lookupStringTable $ ST.pack src_loc_str
+ src_file <- lookupStringTable $ ST.pack src_loc_file
+ src_span <- lookupStringTable $ ST.pack src_loc_span
return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe
, ipeTableName = table_name
, ipeClosureDesc = closure_desc
, ipeTypeDesc = type_desc
, ipeLabel = label
, ipeModuleName = module_name
- , ipeSrcLoc = src_loc
+ , ipeSrcFile = src_file
+ , ipeSrcSpan = src_span
}
data CgInfoProvEnt = CgInfoProvEnt
@@ -82,7 +95,8 @@ data CgInfoProvEnt = CgInfoProvEnt
, ipeTypeDesc :: !StrTabOffset
, ipeLabel :: !StrTabOffset
, ipeModuleName :: !StrTabOffset
- , ipeSrcLoc :: !StrTabOffset
+ , ipeSrcFile :: !StrTabOffset
+ , ipeSrcSpan :: !StrTabOffset
}
data StringTable = StringTable { stStrings :: DList ShortText
=====================================
libraries/base/GHC/InfoProv.hsc
=====================================
@@ -0,0 +1,113 @@
+{-# 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 at 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(..)
+ , ipLoc
+ , 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,
+ ipSrcFile :: String,
+ ipSrcSpan :: String
+} deriving (Eq, Show)
+
+data InfoProvEnt
+
+ipLoc :: InfoProv -> String
+ipLoc ip = ipSrcFile ip ++ ":" ++ ipSrcSpan ip
+
+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, peekIpSrcFile, peekIpSrcSpan, 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
+peekIpSrcFile p = (# peek InfoProv, src_file) p
+peekIpSrcSpan p = (# peek InfoProv, src_span) 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
+ file <- peekCString utf8 =<< peekIpSrcFile infop
+ span <- peekCString utf8 =<< peekIpSrcSpan infop
+ return InfoProv {
+ ipName = name,
+ ipDesc = desc,
+ ipTyDesc = tyDesc,
+ ipLabel = label,
+ ipMod = mod,
+ ipSrcFile = file,
+ ipSrcSpan = span
+ }
+
+-- | 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
=====================================
libraries/base/GHC/Stack/CCS.hsc
=====================================
@@ -142,71 +142,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
=====================================
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.
=====================================
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
=====================================
rts/IPE.c
=====================================
@@ -85,7 +85,7 @@ void traceIPEFromHashTable(void *data STG_UNUSED, StgWord key STG_UNUSED,
traceIPE(ipe->info, ipe->prov.table_name, ipe->prov.closure_desc,
ipe->prov.ty_desc, ipe->prov.label, ipe->prov.module,
- ipe->prov.srcloc);
+ ipe->prov.src_file, ipe->prov.src_span);
}
#endif
@@ -144,7 +144,8 @@ void updateIpeMap() {
ip_ents[i].prov.ty_desc = &strings[ent->ty_desc];
ip_ents[i].prov.label = &strings[ent->label];
ip_ents[i].prov.module = &strings[ent->module_name];
- ip_ents[i].prov.srcloc = &strings[ent->srcloc];
+ ip_ents[i].prov.src_file = &strings[ent->src_file];
+ ip_ents[i].prov.src_span = &strings[ent->src_span];
insertHashTable(ipeMap, (StgWord) ent->info, &ip_ents[i]);
}
=====================================
rts/Trace.c
=====================================
@@ -681,21 +681,22 @@ void traceIPE(const StgInfoTable * info,
const char *ty_desc,
const char *label,
const char *module,
- const char *srcloc )
+ const char *src_file,
+ const char *src_span)
{
#if defined(DEBUG)
if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
ACQUIRE_LOCK(&trace_utx);
tracePreface();
- debugBelch("IPE: table_name %s, closure_desc %s, ty_desc %s, label %s, module %s, srcloc %s\n",
- table_name, closure_desc, ty_desc, label, module, srcloc);
+ debugBelch("IPE: table_name %s, closure_desc %s, ty_desc %s, label %s, module %s, srcloc %s:%s\n",
+ table_name, closure_desc, ty_desc, label, module, src_file, src_span);
RELEASE_LOCK(&trace_utx);
} else
#endif
if (eventlog_enabled) {
- postIPE((W_) INFO_PTR_TO_STRUCT(info), table_name, closure_desc, ty_desc, label, module, srcloc);
+ postIPE((W_) INFO_PTR_TO_STRUCT(info), table_name, closure_desc, ty_desc, label, module, src_file, src_span);
}
}
=====================================
rts/Trace.h
=====================================
@@ -331,12 +331,13 @@ void traceNonmovingHeapCensus(uint32_t log_blk_size,
const struct NonmovingAllocCensus *census);
void traceIPE(const StgInfoTable *info,
- const char *table_name,
- const char *closure_desc,
- const char *ty_desc,
- const char *label,
- const char *module,
- const char *srcloc );
+ const char *table_name,
+ const char *closure_desc,
+ const char *ty_desc,
+ const char *label,
+ const char *module,
+ const char *src_file,
+ const char *src_span);
void flushTrace(void);
#else /* !TRACING */
@@ -373,7 +374,7 @@ void flushTrace(void);
#define traceTaskDelete_(taskID) /* nothing */
#define traceHeapProfBegin(profile_id) /* nothing */
#define traceHeapProfCostCentre(ccID, label, module, srcloc, is_caf) /* nothing */
-#define traceIPE(info, table_name, closure_desc, ty_desc, label, module, srcloc) /* nothing */
+#define traceIPE(info, table_name, closure_desc, ty_desc, label, module, src_file, src_span) /* nothing */
#define traceHeapProfSampleBegin(era) /* nothing */
#define traceHeapBioProfSampleBegin(era, time) /* nothing */
#define traceHeapProfSampleEnd(era) /* nothing */
=====================================
rts/eventlog/EventLog.c
=====================================
@@ -166,7 +166,7 @@ static inline void postWord64(EventsBuf *eb, StgWord64 i)
postWord32(eb, (StgWord32)i);
}
-static inline void postBuf(EventsBuf *eb, StgWord8 *buf, uint32_t size)
+static inline void postBuf(EventsBuf *eb, const StgWord8 *buf, uint32_t size)
{
memcpy(eb->pos, buf, size);
eb->pos += size;
@@ -1417,7 +1417,8 @@ void postIPE(StgWord64 info,
const char *ty_desc,
const char *label,
const char *module,
- const char *srcloc)
+ const char *src_file,
+ const char *src_span)
{
ACQUIRE_LOCK(&eventBufMutex);
StgWord table_name_len = strlen(table_name);
@@ -1425,10 +1426,11 @@ void postIPE(StgWord64 info,
StgWord ty_desc_len = strlen(ty_desc);
StgWord label_len = strlen(label);
StgWord module_len = strlen(module);
- StgWord srcloc_len = strlen(srcloc);
+ StgWord src_file_len = strlen(src_file);
+ StgWord src_span_len = strlen(src_span);
// 8 for the info word
// 6 for the number of strings in the payload as postString adds 1 to the length
- StgWord len = 8+table_name_len+closure_desc_len+ty_desc_len+label_len+module_len+srcloc_len+6;
+ StgWord len = 8+table_name_len+closure_desc_len+ty_desc_len+label_len+module_len+src_file_len+1+src_span_len+6;
ensureRoomForVariableEvent(&eventBuf, len);
postEventHeader(&eventBuf, EVENT_IPE);
postPayloadSize(&eventBuf, len);
@@ -1438,7 +1440,13 @@ void postIPE(StgWord64 info,
postString(&eventBuf, ty_desc);
postString(&eventBuf, label);
postString(&eventBuf, module);
- postString(&eventBuf, srcloc);
+
+ // Manually construct the string "<file>:<span>\0"
+ postBuf(&eventBuf, (const StgWord8*) src_file, src_file_len);
+ StgWord8 colon = ':';
+ postBuf(&eventBuf, &colon, 1);
+ postString(&eventBuf, src_span);
+
RELEASE_LOCK(&eventBufMutex);
}
=====================================
rts/eventlog/EventLog.h
=====================================
@@ -196,7 +196,8 @@ void postIPE(StgWord64 info,
const char *ty_desc,
const char *label,
const char *module,
- const char *srcloc);
+ const char *src_file,
+ const char *src_span);
void postConcUpdRemSetFlush(Capability *cap);
void postConcMarkEnd(StgWord32 marked_obj_count);
=====================================
rts/include/rts/IPE.h
=====================================
@@ -19,7 +19,8 @@ typedef struct InfoProv_ {
const char *ty_desc;
const char *label;
const char *module;
- const char *srcloc;
+ const char *src_file;
+ const char *src_span;
} InfoProv;
typedef struct InfoProvEnt_ {
@@ -51,7 +52,8 @@ typedef struct {
StringIdx ty_desc;
StringIdx label;
StringIdx module_name;
- StringIdx srcloc;
+ StringIdx src_file;
+ StringIdx src_span;
} IpeBufferEntry;
typedef struct IpeBufferListNode_ {
=====================================
testsuite/tests/profiling/should_run/staticcallstack001.hs
=====================================
@@ -1,6 +1,6 @@
module Main where
-import GHC.Stack.CCS
+import GHC.InfoProv
data D = D Int deriving Show
=====================================
testsuite/tests/profiling/should_run/staticcallstack002.hs
=====================================
@@ -1,7 +1,7 @@
{-# LANGUAGE UnboxedTuples #-}
module Main where
-import GHC.Stack.CCS
+import GHC.InfoProv
-- Unboxed data constructors don't have info tables so there is
-- a special case to not generate distinct info tables for unboxed
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3b3e42301b34cd12e511102a2e0a1e1545f36c78...4d840d56a66365149d7ca2578b0dcd1232c8790e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3b3e42301b34cd12e511102a2e0a1e1545f36c78...4d840d56a66365149d7ca2578b0dcd1232c8790e
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220819/1b1c3c3c/attachment-0001.html>
More information about the ghc-commits
mailing list