summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2022-08-18 20:03:15 -0400
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-10-11 23:45:10 -0400
commit6b0d2022699d3d8b446d024ee837c0d07e2c1aa0 (patch)
tree3981c27bcbfd7ac99eb5c0b46cea5090d8a27ec9
parent866c736ef29a07c6f3aa68063ef98ee0ecea12f3 (diff)
downloadhaskell-6b0d2022699d3d8b446d024ee837c0d07e2c1aa0.tar.gz
Refactor IPE initialization
Here we refactor the representation of info table provenance information in object code to significantly reduce its size and link-time impact. Specifically, we deduplicate strings and represent them as 32-bit offsets into a common string table. In addition, we rework the registration logic to eliminate allocation from the registration path, which is run from a static initializer where things like allocation are technically undefined behavior (although it did previously seem to work). For similar reasons we eliminate lock usage from registration path, instead relying on atomic CAS. Closes #22077.
-rw-r--r--compiler/GHC/Cmm/CLabel.hs8
-rw-r--r--compiler/GHC/Cmm/Parser.y10
-rw-r--r--compiler/GHC/Driver/CodeOutput.hs27
-rw-r--r--compiler/GHC/Driver/Main.hs11
-rw-r--r--compiler/GHC/StgToCmm/InfoTableProv.hs131
-rw-r--r--compiler/GHC/StgToCmm/Prof.hs53
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--rts/IPE.c145
-rw-r--r--rts/IPE.h12
-rw-r--r--rts/RtsStartup.c4
-rw-r--r--rts/include/Cmm.h2
-rw-r--r--rts/include/Rts.h9
-rw-r--r--rts/include/rts/IPE.h57
-rw-r--r--rts/include/stg/SMP.h17
-rw-r--r--rts/sm/NonMoving.h11
-rw-r--r--testsuite/tests/rts/all.T33
-rw-r--r--testsuite/tests/rts/ipe/all.T33
-rw-r--r--testsuite/tests/rts/ipe/ipeEventLog.c24
-rw-r--r--testsuite/tests/rts/ipe/ipeEventLog.stderr (renamed from testsuite/tests/rts/ipeEventLog.stderr)0
-rw-r--r--testsuite/tests/rts/ipe/ipeEventLog_fromMap.c29
-rw-r--r--testsuite/tests/rts/ipe/ipeEventLog_fromMap.stderr20
-rw-r--r--testsuite/tests/rts/ipe/ipeMap.c159
-rw-r--r--testsuite/tests/rts/ipe/ipe_lib.c78
-rw-r--r--testsuite/tests/rts/ipe/ipe_lib.h17
-rw-r--r--testsuite/tests/rts/ipeEventLog.c60
-rw-r--r--testsuite/tests/rts/ipeEventLog_fromMap.c35
-rw-r--r--testsuite/tests/rts/ipeEventLog_fromMap.stderr2
-rw-r--r--testsuite/tests/rts/ipeEventLog_lib.c42
-rw-r--r--testsuite/tests/rts/ipeMap.c209
29 files changed, 683 insertions, 556 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index 5f2b0eca59..9edccdccf5 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -302,6 +302,7 @@ data ModuleLabelKind
| MLK_InitializerArray
| MLK_Finalizer String
| MLK_FinalizerArray
+ | MLK_IPEBuffer
deriving (Eq, Ord)
instance Outputable ModuleLabelKind where
@@ -309,6 +310,7 @@ instance Outputable ModuleLabelKind where
ppr (MLK_Initializer s) = text ("init__" ++ s)
ppr MLK_FinalizerArray = text "fini_arr"
ppr (MLK_Finalizer s) = text ("fini__" ++ s)
+ ppr MLK_IPEBuffer = text "ipe_buf"
isIdLabel :: CLabel -> Bool
isIdLabel IdLabel{} = True
@@ -839,10 +841,10 @@ instance OutputableP Platform InfoProvEnt where
-- Constructing Cost Center Labels
mkCCLabel :: CostCentre -> CLabel
mkCCSLabel :: CostCentreStack -> CLabel
-mkIPELabel :: InfoProvEnt -> CLabel
+mkIPELabel :: Module -> CLabel
mkCCLabel cc = CC_Label cc
mkCCSLabel ccs = CCS_Label ccs
-mkIPELabel ipe = IPE_Label ipe
+mkIPELabel mod = ModuleLabel mod MLK_IPEBuffer
mkRtsApFastLabel :: FastString -> CLabel
mkRtsApFastLabel str = RtsLabel (RtsApFast (NonDetFastString str))
@@ -1020,6 +1022,7 @@ modLabelNeedsCDecl :: ModuleLabelKind -> Bool
-- Code for finalizers and initializers are emitted in stub objects
modLabelNeedsCDecl (MLK_Initializer _) = True
modLabelNeedsCDecl (MLK_Finalizer _) = True
+modLabelNeedsCDecl MLK_IPEBuffer = True
-- The finalizer and initializer arrays are emitted in the code of the module
modLabelNeedsCDecl MLK_InitializerArray = False
modLabelNeedsCDecl MLK_FinalizerArray = False
@@ -1217,6 +1220,7 @@ moduleLabelKindType kind =
MLK_InitializerArray -> DataLabel
MLK_Finalizer _ -> CodeLabel
MLK_FinalizerArray -> DataLabel
+ MLK_IPEBuffer -> DataLabel
idInfoLabelType :: IdLabelInfo -> CLabelType
idInfoLabelType info =
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index ed47fa7a7f..ae6e126b68 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -224,6 +224,7 @@ import GHC.StgToCmm.Layout hiding (ArgRep(..))
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Prof
import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame )
+import GHC.StgToCmm.InfoTableProv
import GHC.Cmm.Opt
import GHC.Cmm.Graph
@@ -1517,9 +1518,12 @@ parseCmmFile cmmpConfig this_mod home_unit filename = do
let fcode = do
((), cmm) <- getCmm $ unEC code "global" (initEnv (pdProfile pdConfig)) [] >> return ()
-- See Note [Mapping Info Tables to Source Positions] (IPE Maps)
- let used_info = map (cmmInfoTableToInfoProvEnt this_mod)
- (mapMaybe topInfoTable cmm)
- ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info
+ let used_info
+ | do_ipe = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTable cmm)
+ | otherwise = []
+ where
+ do_ipe = stgToCmmInfoTableMap $ cmmpStgToCmmConfig cmmpConfig
+ ((), cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info
return (cmm ++ cmm2, used_info)
(cmm, _) = runC (cmmpStgToCmmConfig cmmpConfig) fstate st fcode
(warnings,errors) = getPsMessages pst
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index e07c0af91f..09315c4f05 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -369,24 +369,17 @@ ipInitCode
:: Bool -- is Opt_InfoTableMap enabled or not
-> Platform
-> Module
- -> [InfoProvEnt]
-> CStub
-ipInitCode do_info_table platform this_mod ents
+ipInitCode do_info_table platform this_mod
| not do_info_table = mempty
- | otherwise = initializerCStub platform fn_nm decls body
+ | otherwise = initializerCStub platform fn_nm ipe_buffer_decl body
where
fn_nm = mkInitializerStubLabel this_mod "ip_init"
- decls = vcat
- $ map emit_ipe_decl ents
- ++ [emit_ipe_list ents]
- body = text "registerInfoProvList" <> parens local_ipe_list_label <> semi
- emit_ipe_decl ipe =
- text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"
- where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe)
- local_ipe_list_label = text "local_ipe_" <> ppr this_mod
- emit_ipe_list ipes =
- text "static InfoProvEnt *" <> local_ipe_list_label <> text "[] ="
- <+> braces (vcat $ [ pprCLabel platform CStyle (mkIPELabel ipe) <> comma
- | ipe <- ipes
- ] ++ [text "NULL"])
- <> semi
+
+ body = text "registerInfoProvList" <> parens (text "&" <> ipe_buffer_label) <> semi
+
+ ipe_buffer_label = pprCLabel platform CStyle (mkIPELabel this_mod)
+
+ ipe_buffer_decl =
+ text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";"
+
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 175a78962e..5f22840395 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1970,7 +1970,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
mod_name = mkModuleName $ "Cmm$" ++ original_filename
cmm_mod = mkHomeModule home_unit mod_name
cmmpConfig = initCmmParserConfig dflags
- (cmm, ents) <- ioMsgMaybe
+ (cmm, ipe_ents) <- ioMsgMaybe
$ do
(warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
$ parseCmmFile cmmpConfig cmm_mod home_unit filename
@@ -1996,10 +1996,11 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup)
Just h -> h dflags Nothing (Stream.yield cmmgroup)
- let foreign_stubs _ =
- let ip_init = ipInitCode do_info_table platform cmm_mod ents
- in NoStubs `appendStubC` ip_init
-
+ let foreign_stubs _
+ | not $ null ipe_ents =
+ let ip_init = ipInitCode do_info_table platform cmm_mod
+ in NoStubs `appendStubC` ip_init
+ | otherwise = NoStubs
(_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)
<- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty
rawCmms
diff --git a/compiler/GHC/StgToCmm/InfoTableProv.hs b/compiler/GHC/StgToCmm/InfoTableProv.hs
new file mode 100644
index 0000000000..f0bc0f12c6
--- /dev/null
+++ b/compiler/GHC/StgToCmm/InfoTableProv.hs
@@ -0,0 +1,131 @@
+module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where
+
+import GHC.Prelude
+import GHC.Platform
+import GHC.Unit.Module
+import GHC.Utils.Outputable
+
+import GHC.Cmm.CLabel
+import GHC.Cmm.Expr
+import GHC.Cmm.Utils
+import GHC.StgToCmm.Config
+import GHC.StgToCmm.Lit (newByteStringCLit)
+import GHC.StgToCmm.Monad
+import GHC.StgToCmm.Utils
+
+import GHC.Data.ShortText (ShortText)
+import qualified GHC.Data.ShortText as ST
+
+import Data.Bifunctor (first)
+import qualified Data.Map.Strict as M
+import Control.Monad.Trans.State.Strict
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as BSB
+import qualified Data.ByteString.Lazy as BSL
+
+emitIpeBufferListNode :: Module
+ -> [InfoProvEnt]
+ -> FCode ()
+emitIpeBufferListNode _ [] = return ()
+emitIpeBufferListNode this_mod ents = do
+ cfg <- getStgToCmmConfig
+ let ctx = stgToCmmContext cfg
+ platform = stgToCmmPlatform cfg
+
+ let (cg_ipes, strtab) = flip runState emptyStringTable $ do
+ module_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr this_mod)
+ mapM (toCgIPE platform ctx module_name) ents
+
+ let -- Emit the fields of an IpeBufferEntry struct.
+ toIpeBufferEntry :: CgInfoProvEnt -> [CmmLit]
+ toIpeBufferEntry cg_ipe =
+ [ CmmLabel (ipeInfoTablePtr cg_ipe)
+ , strtab_offset (ipeTableName cg_ipe)
+ , strtab_offset (ipeClosureDesc cg_ipe)
+ , strtab_offset (ipeTypeDesc cg_ipe)
+ , strtab_offset (ipeLabel cg_ipe)
+ , strtab_offset (ipeModuleName cg_ipe)
+ , strtab_offset (ipeSrcLoc cg_ipe)
+ ]
+
+ int n = mkIntCLit platform n
+ int32 n = CmmInt n W32
+ strtab_offset (StrTabOffset n) = int32 (fromIntegral n)
+
+ strings <- newByteStringCLit (getStringTableStrings strtab)
+ let lits = [ zeroCLit platform -- 'next' field
+ , strings -- 'strings' field
+ , int $ length cg_ipes -- 'count' field
+ ] ++ concatMap toIpeBufferEntry cg_ipes
+ emitDataLits (mkIPELabel this_mod) lits
+
+toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt
+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 (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
+ return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe
+ , ipeTableName = table_name
+ , ipeClosureDesc = closure_desc
+ , ipeTypeDesc = type_desc
+ , ipeLabel = label
+ , ipeModuleName = module_name
+ , ipeSrcLoc = src_loc
+ }
+
+data CgInfoProvEnt = CgInfoProvEnt
+ { ipeInfoTablePtr :: !CLabel
+ , ipeTableName :: !StrTabOffset
+ , ipeClosureDesc :: !StrTabOffset
+ , ipeTypeDesc :: !StrTabOffset
+ , ipeLabel :: !StrTabOffset
+ , ipeModuleName :: !StrTabOffset
+ , ipeSrcLoc :: !StrTabOffset
+ }
+
+data StringTable = StringTable { stStrings :: DList ShortText
+ , stLength :: !Int
+ , stLookup :: !(M.Map ShortText StrTabOffset)
+ }
+
+newtype StrTabOffset = StrTabOffset Int
+
+emptyStringTable :: StringTable
+emptyStringTable =
+ StringTable { stStrings = emptyDList
+ , stLength = 0
+ , stLookup = M.empty
+ }
+
+getStringTableStrings :: StringTable -> BS.ByteString
+getStringTableStrings st =
+ BSL.toStrict $ BSB.toLazyByteString
+ $ foldMap f $ dlistToList (stStrings st)
+ where
+ f x = BSB.shortByteString (ST.contents x) `mappend` BSB.word8 0
+
+lookupStringTable :: ShortText -> State StringTable StrTabOffset
+lookupStringTable str = state $ \st ->
+ case M.lookup str (stLookup st) of
+ Just off -> (off, st)
+ Nothing ->
+ let !st' = st { stStrings = stStrings st `snoc` str
+ , stLength = stLength st + ST.byteLength str + 1
+ , stLookup = M.insert str res (stLookup st)
+ }
+ res = StrTabOffset (stLength st)
+ in (res, st')
+
+newtype DList a = DList ([a] -> [a])
+
+emptyDList :: DList a
+emptyDList = DList id
+
+snoc :: DList a -> a -> DList a
+snoc (DList f) x = DList (f . (x:))
+
+dlistToList :: DList a -> [a]
+dlistToList (DList f) = f []
diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs
index 8c8f89dbe9..e07ee0a272 100644
--- a/compiler/GHC/StgToCmm/Prof.hs
+++ b/compiler/GHC/StgToCmm/Prof.hs
@@ -11,7 +11,7 @@ module GHC.StgToCmm.Prof (
mkCCostCentre, mkCCostCentreStack,
-- infoTablePRov
- initInfoTableProv, emitInfoTableProv,
+ initInfoTableProv,
-- Cost-centre Profiling
dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
@@ -32,6 +32,7 @@ import GHC.Platform
import GHC.Platform.Profile
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Config
+import GHC.StgToCmm.InfoTableProv
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Lit
@@ -55,7 +56,6 @@ import GHC.Utils.Encoding
import Control.Monad
import Data.Char (ord)
-import Data.Bifunctor (first)
import GHC.Utils.Monad (whenM)
-----------------------------------------------------------------------------
@@ -274,9 +274,8 @@ sizeof_ccs_words platform
where
(ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform
-
+-- | Emit info-table provenance declarations
initInfoTableProv :: [CmmInfoTable] -> InfoTableProvMap -> FCode CStub
--- Emit the declarations
initInfoTableProv infos itmap
= do
cfg <- getStgToCmmConfig
@@ -284,42 +283,16 @@ initInfoTableProv infos itmap
info_table = stgToCmmInfoTableMap cfg
platform = stgToCmmPlatform cfg
this_mod = stgToCmmThisModule cfg
- -- Output the actual IPE data
- mapM_ emitInfoTableProv ents
- -- Create the C stub which initialises the IPE map
- return (ipInitCode info_table platform this_mod ents)
-
---- Info Table Prov stuff
-emitInfoTableProv :: InfoProvEnt -> FCode ()
-emitInfoTableProv ip = do
- { cfg <- getStgToCmmConfig
- ; let mod = infoProvModule ip
- ctx = stgToCmmContext cfg
- platform = stgToCmmPlatform cfg
- ; let (src, label) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ip)
- mk_string = newByteStringCLit . utf8EncodeByteString
- ; label <- mk_string label
- ; modl <- newByteStringCLit (bytesFS $ moduleNameFS
- $ moduleName mod)
-
- ; ty_string <- mk_string (infoTableType ip)
- ; loc <- mk_string src
- ; table_name <- mk_string (renderWithContext ctx
- (pprCLabel platform CStyle (infoTablePtr ip)))
- ; closure_type <- mk_string (renderWithContext ctx
- (text $ show $ infoProvEntClosureType ip))
- ; let
- lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer
- table_name, -- char *table_name
- closure_type, -- char *closure_desc -- Filled in from the InfoTable
- ty_string, -- char *ty_string
- label, -- char *label,
- modl, -- char *module,
- loc, -- char *srcloc,
- zero platform -- struct _InfoProvEnt *link
- ]
- ; emitDataLits (mkIPELabel ip) lits
- }
+
+ case ents of
+ [] -> return mempty
+ _ -> do
+ -- Emit IPE buffer
+ emitIpeBufferListNode this_mod ents
+
+ -- Create the C stub which initialises the IPE map
+ return (ipInitCode info_table platform this_mod)
+
-- ---------------------------------------------------------------------------
-- Set the current cost centre stack
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 7ae5a9b48a..39e5e5f1ea 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -616,6 +616,7 @@ Library
GHC.StgToCmm.Foreign
GHC.StgToCmm.Heap
GHC.StgToCmm.Hpc
+ GHC.StgToCmm.InfoTableProv
GHC.StgToCmm.Layout
GHC.StgToCmm.Lit
GHC.StgToCmm.Monad
diff --git a/rts/IPE.c b/rts/IPE.c
index 10ddee435b..82b5f50ab4 100644
--- a/rts/IPE.c
+++ b/rts/IPE.c
@@ -34,17 +34,22 @@ Unfortunately, inserting into the hash map is relatively expensive. To keep
startup times low, there's a temporary data structure that is optimized for
collecting IPE lists on registration.
-It's a singly linked list of IPE list buffers. Each buffer contains space for
-126 IPE lists. This number is a bit arbitrary, but leaves a few bytes so that
-the whole structure might fit into 1024 bytes.
-
-On registering a new IPE list, there are three cases:
-
-- It's the first entry at all: Allocate a new IpeBufferListNode and make it the
- buffer's first entry.
-- The current IpeBufferListNode has space in it's buffer: Add it to the buffer.
-- The current IpeBufferListNode's buffer is full: Allocate a new one and link it
-to the previous one, making this one the new current.
+It's a singly linked list of IPE list buffers (IpeBufferListNode). These are
+emitted by the code generator, with generally one produced per module. Each
+contains an array of IPE entries and a link field (which is used to link
+buffers onto the pending list.
+
+For reasons of space efficiency, IPE entries are represented slightly
+differently in the object file than the InfoProvEnt which we ultimately expose
+to the user. Specifically, the IPEs in IpeBufferListNode are represented by
+IpeBufferEntrys, along with a corresponding string table. The string fields
+of InfoProvEnt are represented in IpeBufferEntry as 32-bit offsets into the
+string table. This allows us to halve the size of the buffer entries on
+64-bit machines while significantly reducing the number of needed
+relocations, reducing linking cost. Moreover, the code generator takes care
+to deduplicate strings when generating the string table. When we insert a
+set of IpeBufferEntrys into the IPE hash-map we convert them to InfoProvEnts,
+which contain proper string pointers.
Building the hash map is done lazily, i.e. on first lookup or traversal. For
this all IPE lists of all IpeBufferListNode are traversed to insert all IPEs.
@@ -52,43 +57,55 @@ this all IPE lists of all IpeBufferListNode are traversed to insert all IPEs.
After the content of a IpeBufferListNode has been inserted, it's freed.
*/
+static Mutex ipeMapLock;
static HashTable *ipeMap = NULL;
+// Accessed atomically
static IpeBufferListNode *ipeBufferList = NULL;
-static Mutex ipeMapLock;
-
-void initIpeMapLock(void) { initMutex(&ipeMapLock); }
-
-void closeIpeMapLock(void) { closeMutex(&ipeMapLock); }
+void initIpe(void) { initMutex(&ipeMapLock); }
+
+void exitIpe(void) { closeMutex(&ipeMapLock); }
+
+static InfoProvEnt ipeBufferEntryToIpe(const IpeBufferListNode *node, const IpeBufferEntry *ent)
+{
+ const char *strings = node->string_table;
+ return (InfoProvEnt) {
+ .info = ent->info,
+ .prov = {
+ .table_name = &strings[ent->table_name],
+ .closure_desc = &strings[ent->closure_desc],
+ .ty_desc = &strings[ent->ty_desc],
+ .label = &strings[ent->label],
+ .module = &strings[ent->module_name],
+ .srcloc = &strings[ent->srcloc]
+ }
+ };
+}
#if defined(TRACING)
-static void traceIPEFromHashTable(void *data STG_UNUSED,
- StgWord key STG_UNUSED,
+static void traceIPEFromHashTable(void *data STG_UNUSED, StgWord key STG_UNUSED,
const void *value) {
InfoProvEnt *ipe = (InfoProvEnt *)value;
traceIPE(ipe);
}
void dumpIPEToEventLog(void) {
- ACQUIRE_LOCK(&ipeMapLock);
-
- IpeBufferListNode *cursor = ipeBufferList;
+ // Dump pending entries
+ IpeBufferListNode *cursor = RELAXED_LOAD(&ipeBufferList);
while (cursor != NULL) {
- for (int i = 0; i < cursor->count; i++) {
- for (InfoProvEnt **ipeList = cursor->buffer[i]; *ipeList != NULL; ipeList++) {
- InfoProvEnt *ipe = *ipeList;
- traceIPE(ipe);
- }
+ for (uint32_t i = 0; i < cursor->count; i++) {
+ const InfoProvEnt ent = ipeBufferEntryToIpe(cursor, &cursor->entries[i]);
+ traceIPE(&ent);
}
-
cursor = cursor->next;
}
+ // Dump entries already in hashmap
+ ACQUIRE_LOCK(&ipeMapLock);
if (ipeMap != NULL) {
mapHashTable(ipeMap, NULL, &traceIPEFromHashTable);
}
-
RELEASE_LOCK(&ipeMapLock);
}
@@ -105,50 +122,20 @@ Note [The Info Table Provenance Entry (IPE) Map].
Statically initialized IPE lists are registered at startup by a C constructor
function generated by the compiler (CodeOutput.hs) in a *.c file for each
-module.
+module. Since this is called in a static initializer we cannot rely on
+ipeMapLock; we instead use atomic CAS operations to add to the list.
A performance test for IPE registration and lookup can be found here:
https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5724#note_370806
*/
-void registerInfoProvList(InfoProvEnt **ent_list) {
- // The list must be dereferenceable.
- ASSERT(ent_list[0] == NULL || ent_list[0] != NULL);
-
- // Ignore empty lists
- if (ent_list[0] == NULL) {
- return;
- }
-
- ACQUIRE_LOCK(&ipeMapLock);
-
- if (ipeBufferList == NULL) {
- ASSERT(ipeBufferList == NULL);
-
- ipeBufferList = stgMallocBytes(sizeof(IpeBufferListNode),
- "registerInfoProvList-firstNode");
- ipeBufferList->buffer[0] = ent_list;
- ipeBufferList->count = 1;
- ipeBufferList->next = NULL;
- } else {
- if (ipeBufferList->count < IPE_LIST_NODE_BUFFER_SIZE) {
- ipeBufferList->buffer[ipeBufferList->count] = ent_list;
- ipeBufferList->count = ipeBufferList->count + 1;
-
- ASSERT(ipeBufferList->next == NULL ||
- ipeBufferList->next->count == IPE_LIST_NODE_BUFFER_SIZE);
- } else {
- IpeBufferListNode *newNode = stgMallocBytes(
- sizeof(IpeBufferListNode), "registerInfoProvList-nextNode");
- newNode->buffer[0] = ent_list;
- newNode->count = 1;
- newNode->next = ipeBufferList;
- ipeBufferList = newNode;
-
- ASSERT(ipeBufferList->next->count == IPE_LIST_NODE_BUFFER_SIZE);
+void registerInfoProvList(IpeBufferListNode *node) {
+ while (true) {
+ IpeBufferListNode *old = RELAXED_LOAD(&ipeBufferList);
+ node->next = old;
+ if (cas_ptr((volatile void **) &ipeBufferList, old, node) == (void *) old) {
+ return;
}
}
-
- RELEASE_LOCK(&ipeMapLock);
}
InfoProvEnt *lookupIPE(const StgInfoTable *info) {
@@ -159,7 +146,8 @@ InfoProvEnt *lookupIPE(const StgInfoTable *info) {
void updateIpeMap() {
// Check if there's any work at all. If not so, we can circumvent locking,
// which decreases performance.
- if (ipeMap != NULL && ipeBufferList == NULL) {
+ IpeBufferListNode *pending = xchg_ptr((void **) &ipeBufferList, NULL);
+ if (ipeMap != NULL && pending == NULL) {
return;
}
@@ -169,23 +157,16 @@ void updateIpeMap() {
ipeMap = allocHashTable();
}
- while (ipeBufferList != NULL) {
- ASSERT(ipeBufferList->next == NULL ||
- ipeBufferList->next->count == IPE_LIST_NODE_BUFFER_SIZE);
- ASSERT(ipeBufferList->count > 0 &&
- ipeBufferList->count <= IPE_LIST_NODE_BUFFER_SIZE);
-
- IpeBufferListNode *currentNode = ipeBufferList;
-
- for (int i = 0; i < currentNode->count; i++) {
- for (InfoProvEnt **ipeList = currentNode->buffer[i];
- *ipeList != NULL; ipeList++) {
- insertHashTable(ipeMap, (StgWord)(*ipeList)->info, *ipeList);
- }
+ while (pending != NULL) {
+ IpeBufferListNode *currentNode = pending;
+ InfoProvEnt *ip_ents = stgMallocBytes(sizeof(InfoProvEnt) * currentNode->count, "updateIpeMap");
+ for (uint32_t i = 0; i < currentNode->count; i++) {
+ const IpeBufferEntry *ent = &currentNode->entries[i];
+ ip_ents[i] = ipeBufferEntryToIpe(currentNode, ent);
+ insertHashTable(ipeMap, (StgWord) ent->info, &ip_ents[i]);
}
- ipeBufferList = currentNode->next;
- stgFree(currentNode);
+ pending = currentNode->next;
}
RELEASE_LOCK(&ipeMapLock);
diff --git a/rts/IPE.h b/rts/IPE.h
index 267e386f00..cc2d4eca50 100644
--- a/rts/IPE.h
+++ b/rts/IPE.h
@@ -13,17 +13,9 @@
#include "BeginPrivate.h"
-#define IPE_LIST_NODE_BUFFER_SIZE 126
-
-typedef struct IpeBufferListNode_ {
- InfoProvEnt **buffer[IPE_LIST_NODE_BUFFER_SIZE];
- StgWord8 count;
- struct IpeBufferListNode_ *next;
-} IpeBufferListNode;
-
void dumpIPEToEventLog(void);
void updateIpeMap(void);
-void initIpeMapLock(void);
-void closeIpeMapLock(void);
+void initIpe(void);
+void exitIpe(void);
#include "EndPrivate.h"
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index 5a2c616a73..8ec69f84ab 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -386,7 +386,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
#if defined(PROFILING)
initProfiling();
#endif
- initIpeMapLock();
+ initIpe();
traceInitEvent(dumpIPEToEventLog);
initHeapProfiling();
@@ -611,7 +611,7 @@ hs_exit_(bool wait_foreign)
// Free threading resources
freeThreadingResources();
- closeIpeMapLock();
+ exitIpe();
}
// Flush stdout and stderr. We do this during shutdown so that it
diff --git a/rts/include/Cmm.h b/rts/include/Cmm.h
index 07301bf602..932bfb903a 100644
--- a/rts/include/Cmm.h
+++ b/rts/include/Cmm.h
@@ -249,6 +249,8 @@
#define IF_DEBUG(c,s) /* nothing */
#endif
+#define GHC_STATIC_ASSERT(x) static_assert(x)
+
/* -----------------------------------------------------------------------------
Entering
diff --git a/rts/include/Rts.h b/rts/include/Rts.h
index 2399f8ce7f..b9874721ce 100644
--- a/rts/include/Rts.h
+++ b/rts/include/Rts.h
@@ -29,6 +29,9 @@ extern "C" {
#include <windows.h>
#endif
+/* For _Static_assert */
+#include <assert.h>
+
#if !defined(IN_STG_CODE)
#define IN_STG_CODE 0
#endif
@@ -163,6 +166,12 @@ void _warnFail(const char *filename, unsigned int linenum);
do { (void) sizeof(predicate); } while(0)
#endif /* DEBUG */
+#if __STDC_VERSION__ >= 201112L
+#define GHC_STATIC_ASSERT(x, msg) static_assert((x), msg)
+#else
+#define GHC_STATIC_ASSERT(x, msg)
+#endif
+
/*
* Use this on the RHS of macros which expand to nothing
* to make sure that the macro can be used in a context which
diff --git a/rts/include/rts/IPE.h b/rts/include/rts/IPE.h
index 0cfe3e2fb3..f8495cd30e 100644
--- a/rts/include/rts/IPE.h
+++ b/rts/include/rts/IPE.h
@@ -14,18 +14,59 @@
#pragma once
typedef struct InfoProv_ {
- char *table_name;
- char *closure_desc;
- char *ty_desc;
- char *label;
- char *module;
- char *srcloc;
+ const char *table_name;
+ const char *closure_desc;
+ const char *ty_desc;
+ const char *label;
+ const char *module;
+ const char *srcloc;
} InfoProv;
typedef struct InfoProvEnt_ {
- StgInfoTable *info;
+ const StgInfoTable *info;
InfoProv prov;
} InfoProvEnt;
-void registerInfoProvList(InfoProvEnt **cc_list);
+
+/*
+ * On-disk representation
+ */
+
+/*
+ * A byte offset into the string table.
+ * We use offsets rather than pointers as:
+ *
+ * a. they are smaller than pointers on 64-bit platforms
+ * b. they are easier on the linker since they do not need
+ * to be relocated
+ */
+typedef uint32_t StringIdx;
+
+// This is the provenance representation that we emit to
+// object code (see
+// GHC.GHC.StgToCmm.InfoTableProv.emitIpeBufferListNode).
+//
+// The size of this must be a multiple of the word size
+// to ensure correct packing.
+typedef struct {
+ const StgInfoTable *info;
+ StringIdx table_name;
+ StringIdx closure_desc;
+ StringIdx ty_desc;
+ StringIdx label;
+ StringIdx module_name;
+ StringIdx srcloc;
+} IpeBufferEntry;
+
+GHC_STATIC_ASSERT(sizeof(IpeBufferEntry) % (WORD_SIZE_IN_BITS / 8) == 0, "sizeof(IpeBufferEntry) must be a multiple of the word size");
+
+typedef struct IpeBufferListNode_ {
+ struct IpeBufferListNode_ *next;
+ // Everything below is read-only and generated by the codegen
+ const char *string_table;
+ StgWord count;
+ IpeBufferEntry entries[];
+} IpeBufferListNode;
+
+void registerInfoProvList(IpeBufferListNode *node);
InfoProvEnt *lookupIPE(const StgInfoTable *info);
diff --git a/rts/include/stg/SMP.h b/rts/include/stg/SMP.h
index 1bb6ca06a0..b8f72a1248 100644
--- a/rts/include/stg/SMP.h
+++ b/rts/include/stg/SMP.h
@@ -568,3 +568,20 @@ atomic_dec(StgVolatilePtr p)
#define VOLATILE_LOAD(p) ((StgWord)*((StgWord*)(p)))
#endif /* !THREADED_RTS */
+
+/* Helpers implemented in terms of the above */
+#if !IN_STG_CODE || IN_STGCRUN
+
+INLINE_HEADER void *
+xchg_ptr(void **p, void *w)
+{
+ return (void *) xchg((StgPtr) p, (StgWord) w);
+}
+
+INLINE_HEADER void *
+cas_ptr(volatile void **p, void *o, void *n)
+{
+ return (void *) cas((StgVolatilePtr) p, (StgWord) o, (StgWord) n);
+}
+
+#endif
diff --git a/rts/sm/NonMoving.h b/rts/sm/NonMoving.h
index 0886215de8..12fb9ddaab 100644
--- a/rts/sm/NonMoving.h
+++ b/rts/sm/NonMoving.h
@@ -17,18 +17,17 @@
#include "BeginPrivate.h"
// Segments
-#define NONMOVING_SEGMENT_BITS 15 // 2^15 = 32kByte
+#define NONMOVING_SEGMENT_BITS 15UL // 2^15 = 32kByte
// Mask to find base of segment
-#define NONMOVING_SEGMENT_MASK ((1 << NONMOVING_SEGMENT_BITS) - 1)
+#define NONMOVING_SEGMENT_MASK ((1UL << NONMOVING_SEGMENT_BITS) - 1)
// In bytes
-#define NONMOVING_SEGMENT_SIZE (1 << NONMOVING_SEGMENT_BITS)
+#define NONMOVING_SEGMENT_SIZE (1UL << NONMOVING_SEGMENT_BITS)
// In words
-#define NONMOVING_SEGMENT_SIZE_W ((1 << NONMOVING_SEGMENT_BITS) / SIZEOF_VOID_P)
+#define NONMOVING_SEGMENT_SIZE_W ((1UL << NONMOVING_SEGMENT_BITS) / SIZEOF_VOID_P)
// In blocks
#define NONMOVING_SEGMENT_BLOCKS (NONMOVING_SEGMENT_SIZE / BLOCK_SIZE)
-_Static_assert(NONMOVING_SEGMENT_SIZE % BLOCK_SIZE == 0,
- "non-moving segment size must be multiple of block size");
+GHC_STATIC_ASSERT(NONMOVING_SEGMENT_SIZE % BLOCK_SIZE == 0, "non-moving segment size must be multiple of block size");
// The index of a block within a segment
typedef uint16_t nonmoving_block_idx;
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index 955289b91f..c361e87b2f 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -196,37 +196,6 @@ test('EventlogOutput_IPE',
def noCapabilityOutputFilter(s):
return re.sub(r'[a-f0-9]+: IPE:', 'IPE:', s)
-# Manually create IPE entries and dump them to event log (stderr).
-test('ipeEventLog',
- [ c_src,
- extra_files(['ipeEventLog_lib.c']),
- extra_run_opts('+RTS -va -RTS'),
- grep_errmsg('IPE:'),
- only_ways(debug_ways),
- normalise_errmsg_fun(noCapabilityOutputFilter),
- ignore_stdout,
- # Due to issues on Darwin CI runners that couldn't be tracked down.
- # In general this test should work on Darwin - Just not on our CI.
- when(opsys('darwin'), fragile(0))
- ],
- compile_and_run, ['ipeEventLog_lib.c'])
-
-# Manually create IPE entries, force the initialization of the underlying hash map
-# and dump them to event log (stderr).
-test('ipeEventLog_fromMap',
- [ c_src,
- extra_files(['ipeEventLog_lib.c']),
- extra_run_opts('+RTS -va -RTS'),
- grep_errmsg('IPE:'),
- only_ways(debug_ways),
- normalise_errmsg_fun(noCapabilityOutputFilter),
- ignore_stdout,
- # Due to issues on Darwin CI runners that couldn't be tracked down.
- # In general this test should work on Darwin - Just not on our CI.
- when(opsys('darwin'), fragile(0))
- ],
- compile_and_run, ['ipeEventLog_lib.c'])
-
test('T4059', [], makefile_test, ['T4059'])
# Test for #4274
@@ -509,8 +478,6 @@ test('T19381',
test('T20199', [ grep_errmsg('Hello') ]
, makefile_test, [])
-test('ipeMap', [c_src], compile_and_run, [''])
-
test('cloneMyStack', [extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c'])
test('cloneMyStack2', ignore_stdout, compile_and_run, [''])
test('cloneMyStack_retBigStackFrame', [extra_files(['cloneStackLib.c']), ignore_stdout], compile_and_run, ['cloneStackLib.c'])
diff --git a/testsuite/tests/rts/ipe/all.T b/testsuite/tests/rts/ipe/all.T
new file mode 100644
index 0000000000..15af42f588
--- /dev/null
+++ b/testsuite/tests/rts/ipe/all.T
@@ -0,0 +1,33 @@
+test('ipeMap', [extra_files(['ipe_lib.c', 'ipe_lib.h']), c_src], compile_and_run, ['ipe_lib.c'])
+
+# Manually create IPE entries and dump them to event log (stderr).
+test('ipeEventLog',
+ [ c_src,
+ extra_files(['ipe_lib.c', 'ipe_lib.h']),
+ extra_run_opts('+RTS -va -RTS'),
+ grep_errmsg('table_name_'),
+ only_ways(debug_ways),
+ normalise_errmsg_fun(noCapabilityOutputFilter),
+ ignore_stdout,
+ # Due to issues on Darwin CI runners that couldn't be tracked down.
+ # In general this test should work on Darwin - Just not on our CI.
+ when(opsys('darwin'), fragile(0))
+ ],
+ compile_and_run, ['ipe_lib.c'])
+
+# Manually create IPE entries, force the initialization of the underlying hash map
+# and dump them to event log (stderr).
+test('ipeEventLog_fromMap',
+ [ c_src,
+ extra_files(['ipe_lib.c', 'ipe_lib.h']),
+ extra_run_opts('+RTS -va -RTS'),
+ grep_errmsg('table_name_'),
+ only_ways(debug_ways),
+ normalise_errmsg_fun(noCapabilityOutputFilter),
+ ignore_stdout,
+ # Due to issues on Darwin CI runners that couldn't be tracked down.
+ # In general this test should work on Darwin - Just not on our CI.
+ when(opsys('darwin'), fragile(0))
+ ],
+ compile_and_run, ['ipe_lib.c'])
+
diff --git a/testsuite/tests/rts/ipe/ipeEventLog.c b/testsuite/tests/rts/ipe/ipeEventLog.c
new file mode 100644
index 0000000000..b59642fc5b
--- /dev/null
+++ b/testsuite/tests/rts/ipe/ipeEventLog.c
@@ -0,0 +1,24 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "rts/IPE.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "ipe_lib.h"
+
+int main(int argc, char *argv[]) {
+ hs_init(&argc, &argv);
+ Capability *cap = rts_lock();
+
+ IpeBufferListNode *list1 = makeAnyProvEntries(cap, 0, 10);
+ IpeBufferListNode *list2 = makeAnyProvEntries(cap, 0, 10);
+
+ registerInfoProvList(list1);
+ registerInfoProvList(list2);
+
+ // Trace all IPE events. Expected count (see Makefile): 381 + 2 = 383
+ dumpIPEToEventLog();
+
+ rts_unlock(cap);
+ hs_exit();
+}
diff --git a/testsuite/tests/rts/ipeEventLog.stderr b/testsuite/tests/rts/ipe/ipeEventLog.stderr
index 95e012c710..95e012c710 100644
--- a/testsuite/tests/rts/ipeEventLog.stderr
+++ b/testsuite/tests/rts/ipe/ipeEventLog.stderr
diff --git a/testsuite/tests/rts/ipe/ipeEventLog_fromMap.c b/testsuite/tests/rts/ipe/ipeEventLog_fromMap.c
new file mode 100644
index 0000000000..631ba8298f
--- /dev/null
+++ b/testsuite/tests/rts/ipe/ipeEventLog_fromMap.c
@@ -0,0 +1,29 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "rts/IPE.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "ipe_lib.h"
+
+int main(int argc, char *argv[]) {
+ hs_init(&argc, &argv);
+ Capability *cap = rts_lock();
+
+ HaskellObj one = rts_mkInt(cap, 1);
+
+ IpeBufferListNode *list1 = makeAnyProvEntries(cap, 0, 10);
+ IpeBufferListNode *list2 = makeAnyProvEntries(cap, 0, 10);
+
+ registerInfoProvList(list1);
+ registerInfoProvList(list2);
+
+ // Query an IPE to initialize the underlying hash map.
+ lookupIPE(list1->entries[0].info);
+
+ // Trace all IPE events.
+ dumpIPEToEventLog();
+
+ rts_unlock(cap);
+ hs_exit();
+}
diff --git a/testsuite/tests/rts/ipe/ipeEventLog_fromMap.stderr b/testsuite/tests/rts/ipe/ipeEventLog_fromMap.stderr
new file mode 100644
index 0000000000..606de64766
--- /dev/null
+++ b/testsuite/tests/rts/ipe/ipeEventLog_fromMap.stderr
@@ -0,0 +1,20 @@
+7f8f9c139740: IPE: table_name table_name_000, closure_desc closure_desc_000, ty_desc ty_desc_000, label label_000, module module_000, srcloc srcloc_000
+7f8f9c139740: IPE: table_name table_name_001, closure_desc closure_desc_001, ty_desc ty_desc_001, label label_001, module module_001, srcloc srcloc_001
+7f8f9c139740: IPE: table_name table_name_002, closure_desc closure_desc_002, ty_desc ty_desc_002, label label_002, module module_002, srcloc srcloc_002
+7f8f9c139740: IPE: table_name table_name_003, closure_desc closure_desc_003, ty_desc ty_desc_003, label label_003, module module_003, srcloc srcloc_003
+7f8f9c139740: IPE: table_name table_name_004, closure_desc closure_desc_004, ty_desc ty_desc_004, label label_004, module module_004, srcloc srcloc_004
+7f8f9c139740: IPE: table_name table_name_005, closure_desc closure_desc_005, ty_desc ty_desc_005, label label_005, module module_005, srcloc srcloc_005
+7f8f9c139740: IPE: table_name table_name_006, closure_desc closure_desc_006, ty_desc ty_desc_006, label label_006, module module_006, srcloc srcloc_006
+7f8f9c139740: IPE: table_name table_name_007, closure_desc closure_desc_007, ty_desc ty_desc_007, label label_007, module module_007, srcloc srcloc_007
+7f8f9c139740: IPE: table_name table_name_008, closure_desc closure_desc_008, ty_desc ty_desc_008, label label_008, module module_008, srcloc srcloc_008
+7f8f9c139740: IPE: table_name table_name_009, closure_desc closure_desc_009, ty_desc ty_desc_009, label label_009, module module_009, srcloc srcloc_009
+7f8f9c139740: IPE: table_name table_name_000, closure_desc closure_desc_000, ty_desc ty_desc_000, label label_000, module module_000, srcloc srcloc_000
+7f8f9c139740: IPE: table_name table_name_001, closure_desc closure_desc_001, ty_desc ty_desc_001, label label_001, module module_001, srcloc srcloc_001
+7f8f9c139740: IPE: table_name table_name_002, closure_desc closure_desc_002, ty_desc ty_desc_002, label label_002, module module_002, srcloc srcloc_002
+7f8f9c139740: IPE: table_name table_name_003, closure_desc closure_desc_003, ty_desc ty_desc_003, label label_003, module module_003, srcloc srcloc_003
+7f8f9c139740: IPE: table_name table_name_004, closure_desc closure_desc_004, ty_desc ty_desc_004, label label_004, module module_004, srcloc srcloc_004
+7f8f9c139740: IPE: table_name table_name_005, closure_desc closure_desc_005, ty_desc ty_desc_005, label label_005, module module_005, srcloc srcloc_005
+7f8f9c139740: IPE: table_name table_name_006, closure_desc closure_desc_006, ty_desc ty_desc_006, label label_006, module module_006, srcloc srcloc_006
+7f8f9c139740: IPE: table_name table_name_007, closure_desc closure_desc_007, ty_desc ty_desc_007, label label_007, module module_007, srcloc srcloc_007
+7f8f9c139740: IPE: table_name table_name_008, closure_desc closure_desc_008, ty_desc ty_desc_008, label label_008, module module_008, srcloc srcloc_008
+7f8f9c139740: IPE: table_name table_name_009, closure_desc closure_desc_009, ty_desc ty_desc_009, label label_009, module module_009, srcloc srcloc_009
diff --git a/testsuite/tests/rts/ipe/ipeMap.c b/testsuite/tests/rts/ipe/ipeMap.c
new file mode 100644
index 0000000000..f69ac75508
--- /dev/null
+++ b/testsuite/tests/rts/ipe/ipeMap.c
@@ -0,0 +1,159 @@
+#include <stdlib.h>
+#include <string.h>
+
+#include "Rts.h"
+#include "ipe_lib.h"
+
+void assertStringsEqual(const char *s1, const char *s2);
+void shouldFindNothingInAnEmptyIPEMap(Capability *cap);
+HaskellObj shouldFindOneIfItHasBeenRegistered(Capability *cap);
+void shouldFindTwoIfTwoHaveBeenRegistered(Capability *cap, HaskellObj fortyTwo);
+void shouldFindTwoFromTheSameList(Capability *cap);
+void shouldDealWithAnEmptyList(Capability *cap, HaskellObj);
+
+// This is a unit test for IPE.c, the IPE map.
+// Due to the nature of IPE having static state, the test cases are not
+// independent of each other!
+int main(int argc, char *argv[]) {
+ hs_init(&argc, &argv);
+ Capability *cap = rts_lock();
+
+ shouldFindNothingInAnEmptyIPEMap(cap);
+ HaskellObj fortyTwo = shouldFindOneIfItHasBeenRegistered(cap);
+ shouldFindTwoIfTwoHaveBeenRegistered(cap, fortyTwo);
+ shouldFindTwoFromTheSameList(cap);
+ shouldDealWithAnEmptyList(cap, fortyTwo);
+
+ rts_unlock(cap);
+ hs_exit();
+}
+
+void shouldFindNothingInAnEmptyIPEMap(Capability *cap) {
+ HaskellObj fortyTwo = UNTAG_CLOSURE(rts_mkInt(cap, 42));
+
+ InfoProvEnt *result = lookupIPE(get_itbl(fortyTwo));
+
+ if (result != NULL) {
+ errorBelch("Found entry in an empty IPE map!");
+ exit(1);
+ }
+}
+
+HaskellObj shouldFindOneIfItHasBeenRegistered(Capability *cap) {
+ IpeBufferListNode *node = malloc(sizeof(IpeBufferListNode) + sizeof(IpeBufferEntry));
+ StringTable st;
+ init_string_table(&st);
+
+ HaskellObj fortyTwo = UNTAG_CLOSURE(rts_mkInt(cap, 42));
+ node->entries[0] = makeAnyProvEntry(cap, &st, fortyTwo, 42);
+ node->count = 1;
+ node->next = NULL;
+ node->string_table = st.buffer;
+
+ registerInfoProvList(node);
+
+ InfoProvEnt *result = lookupIPE(get_itbl(fortyTwo));
+
+ if (result == NULL) {
+ errorBelch("shouldFindOneIfItHasBeenRegistered: Found no entry in IPE map!");
+ exit(1);
+ }
+
+ assertStringsEqual(result->prov.table_name, "table_name_042");
+ assertStringsEqual(result->prov.closure_desc, "closure_desc_042");
+ assertStringsEqual(result->prov.ty_desc, "ty_desc_042");
+ assertStringsEqual(result->prov.label, "label_042");
+ assertStringsEqual(result->prov.module, "module_042");
+ assertStringsEqual(result->prov.srcloc, "srcloc_042");
+
+ return fortyTwo;
+}
+
+void shouldFindTwoIfTwoHaveBeenRegistered(Capability *cap,
+ HaskellObj fortyTwo) {
+ IpeBufferListNode *node = malloc(sizeof(IpeBufferListNode) + sizeof(IpeBufferEntry));
+ StringTable st;
+ init_string_table(&st);
+
+ HaskellObj twentyThree = UNTAG_CLOSURE(rts_mkInt8(cap, 23));
+ node->entries[0] = makeAnyProvEntry(cap, &st, twentyThree, 23);
+ node->count = 1;
+ node->next = NULL;
+ node->string_table = st.buffer;
+
+ registerInfoProvList(node);
+
+ InfoProvEnt *resultFortyTwo =
+ lookupIPE(get_itbl(fortyTwo));
+ InfoProvEnt *resultTwentyThree =
+ lookupIPE(get_itbl(twentyThree));
+
+ if (resultFortyTwo == NULL) {
+ errorBelch("shouldFindTwoIfTwoHaveBeenRegistered(42): Found no entry in IPE map!");
+ exit(1);
+ }
+ if (resultTwentyThree == NULL) {
+ errorBelch("shouldFindTwoIfTwoHaveBeenRegistered(23): Found no entry in IPE map!");
+ exit(1);
+ }
+
+ assertStringsEqual(resultFortyTwo->prov.table_name, "table_name_042");
+ assertStringsEqual(resultTwentyThree->prov.table_name, "table_name_023");
+}
+
+void shouldFindTwoFromTheSameList(Capability *cap) {
+ IpeBufferListNode *node = malloc(sizeof(IpeBufferListNode) + 2 * sizeof(IpeBufferEntry));
+ StringTable st;
+ init_string_table(&st);
+
+ HaskellObj one = UNTAG_CLOSURE(rts_mkInt16(cap, 1));
+ HaskellObj two = UNTAG_CLOSURE(rts_mkInt32(cap, 2));
+ node->entries[0] = makeAnyProvEntry(cap, &st, one, 1);
+ node->entries[1] = makeAnyProvEntry(cap, &st, two, 2);
+ node->count = 2;
+ node->next = NULL;
+ node->string_table = st.buffer;
+
+ registerInfoProvList(node);
+
+ InfoProvEnt *resultOne = lookupIPE(get_itbl(one));
+ InfoProvEnt *resultTwo = lookupIPE(get_itbl(two));
+
+ if (resultOne == NULL) {
+ errorBelch("shouldFindTwoFromTheSameList(1): Found no entry in IPE map!");
+ exit(1);
+ }
+ if (resultTwo == NULL) {
+ errorBelch("shouldFindTwoFromTheSameList(2): Found no entry in IPE map!");
+ exit(1);
+ }
+
+ assertStringsEqual(resultOne->prov.table_name, "table_name_001");
+ assertStringsEqual(resultTwo->prov.table_name, "table_name_002");
+}
+
+void shouldDealWithAnEmptyList(Capability *cap, HaskellObj fortyTwo) {
+ IpeBufferListNode *node = malloc(sizeof(IpeBufferListNode));
+ node->count = 0;
+ node->next = NULL;
+ node->string_table = "";
+
+ registerInfoProvList(node);
+
+ InfoProvEnt *resultFortyTwo =
+ lookupIPE(get_itbl(fortyTwo));
+
+ if (resultFortyTwo == NULL) {
+ errorBelch("shouldDealWithAnEmptyList: Found no entry in IPE map!");
+ exit(1);
+ }
+
+ assertStringsEqual(resultFortyTwo->prov.table_name, "table_name_042");
+}
+
+void assertStringsEqual(const char *s1, const char *s2) {
+ if (strcmp(s1, s2) != 0) {
+ errorBelch("%s != %s", s1, s2);
+ exit(1);
+ }
+}
diff --git a/testsuite/tests/rts/ipe/ipe_lib.c b/testsuite/tests/rts/ipe/ipe_lib.c
new file mode 100644
index 0000000000..37bb20c738
--- /dev/null
+++ b/testsuite/tests/rts/ipe/ipe_lib.c
@@ -0,0 +1,78 @@
+#include "Rts.h"
+#include "rts/IPE.h"
+#include <string.h>
+#include "ipe_lib.h"
+
+void init_string_table(StringTable *st) {
+ st->size = 128;
+ st->n = 0;
+ st->buffer = malloc(st->size);
+}
+
+uint32_t add_string(StringTable *st, const char *s) {
+ const size_t len = strlen(s);
+ const uint32_t n = st->n;
+ if (st->n + len + 1 > st->size) {
+ const size_t new_size = 2*st->size + len;
+ st->buffer = realloc(st->buffer, new_size);
+ st->size = new_size;
+ }
+
+ memcpy(&st->buffer[st->n], s, len);
+ st->n += len;
+ st->buffer[st->n] = '\0';
+ st->n += 1;
+ return n;
+}
+
+IpeBufferEntry makeAnyProvEntry(Capability *cap, StringTable *st, HaskellObj closure, int i) {
+ IpeBufferEntry provEnt;
+ provEnt.info = get_itbl(closure);
+
+ unsigned int tableNameLength = strlen("table_name_") + 3 /* digits */ + 1 /* null character */;
+ char *tableName = malloc(sizeof(char) * tableNameLength);
+ snprintf(tableName, tableNameLength, "table_name_%03i", i);
+ provEnt.table_name = add_string(st, tableName);
+
+ unsigned int closureDescLength = strlen("closure_desc_") + 3 /* digits */ + 1 /* null character */;
+ char *closureDesc = malloc(sizeof(char) * closureDescLength);
+ snprintf(closureDesc, closureDescLength, "closure_desc_%03i", i);
+ provEnt.closure_desc = add_string(st, closureDesc);
+
+ unsigned int tyDescLength = strlen("ty_desc_") + 3 /* digits */ + 1 /* null character */;
+ char *tyDesc = malloc(sizeof(char) * tyDescLength);
+ snprintf(tyDesc, tyDescLength, "ty_desc_%03i", i);
+ provEnt.ty_desc = add_string(st, tyDesc);
+
+ unsigned int labelLength = strlen("label_") + 3 /* digits */ + 1 /* null character */;
+ char *label = malloc(sizeof(char) * labelLength);
+ snprintf(label, labelLength, "label_%03i", i);
+ provEnt.label = add_string(st, label);
+
+ unsigned int moduleLength = strlen("module_") + 3 /* digits */ + 1 /* null character */;
+ char *module = malloc(sizeof(char) * moduleLength);
+ snprintf(module, moduleLength, "module_%03i", i);
+ provEnt.module_name = add_string(st, module);
+
+ unsigned int srcLocLength = strlen("srcloc_") + 3 /* digits */ + 1 /* null character */;
+ char *srcLoc = malloc(sizeof(char) * srcLocLength);
+ snprintf(srcLoc, srcLocLength, "srcloc_%03i", i);
+ provEnt.srcloc = add_string(st, srcLoc);
+
+ return provEnt;
+}
+
+IpeBufferListNode *makeAnyProvEntries(Capability *cap, int start, int end) {
+ const int n = end - start;
+ IpeBufferListNode *node = malloc(sizeof(IpeBufferListNode) + n * sizeof(IpeBufferEntry));
+ StringTable st;
+ init_string_table(&st);
+ for (int i=start; i < end; i++) {
+ HaskellObj closure = rts_mkInt(cap, 42);
+ node->entries[i] = makeAnyProvEntry(cap, &st, closure, i);
+ }
+ node->next = NULL;
+ node->count = n;
+ node->string_table = st.buffer;
+ return node;
+}
diff --git a/testsuite/tests/rts/ipe/ipe_lib.h b/testsuite/tests/rts/ipe/ipe_lib.h
new file mode 100644
index 0000000000..8aaa1c361e
--- /dev/null
+++ b/testsuite/tests/rts/ipe/ipe_lib.h
@@ -0,0 +1,17 @@
+#pragma once
+
+#include "Rts.h"
+
+typedef struct {
+ char *buffer;
+ size_t n;
+ size_t size;
+} StringTable;
+
+void init_string_table(StringTable *st);
+uint32_t add_string(StringTable *st, const char *s);
+
+IpeBufferListNode *makeAnyProvEntries(Capability *cap, int start, int end);
+IpeBufferEntry makeAnyProvEntry(Capability *cap, StringTable *st, HaskellObj closure, int i);
+void dumpIPEToEventLog(void);
+
diff --git a/testsuite/tests/rts/ipeEventLog.c b/testsuite/tests/rts/ipeEventLog.c
deleted file mode 100644
index 9260269f5a..0000000000
--- a/testsuite/tests/rts/ipeEventLog.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "Rts.h"
-#include "RtsAPI.h"
-#include "rts/IPE.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-
-extern void dumpIPEToEventLog(void);
-InfoProvEnt *makeAnyProvEntry(Capability *cap, int i);
-
-int main(int argc, char *argv[]) {
- hs_init(&argc, &argv);
- Capability *cap = rts_lock();
-
- // Force the creation of 4 IpeBufferListNodes (381 IPEs)
- for (int i = 0; i < 381; i++) {
-
- InfoProvEnt **ipeList_1 = malloc(sizeof(InfoProvEnt *) * 2);
- ipeList_1[0] = makeAnyProvEntry(cap, i);
- ipeList_1[1] = NULL;
-
- registerInfoProvList(ipeList_1);
- }
-
- // Register an IPE list with two elements
- HaskellObj one = rts_mkInt(cap, 1);
-
- InfoProvEnt *provEntA = malloc(sizeof(InfoProvEnt));
- provEntA->info = (StgInfoTable *)one->header.info;
- provEntA->prov.table_name = "table_name_a";
- provEntA->prov.closure_desc = "closure_desc_a";
- provEntA->prov.ty_desc = "ty_desc_a";
- provEntA->prov.label = "label_a";
- provEntA->prov.module = "module_a";
- provEntA->prov.srcloc = "srcloc_a";
-
- HaskellObj two = rts_mkInt(cap, 2);
-
- InfoProvEnt *provEntB = malloc(sizeof(InfoProvEnt));
- provEntB->info = (StgInfoTable *)two->header.info;
- provEntB->prov.table_name = "table_name_b";
- provEntB->prov.closure_desc = "closure_desc_b";
- provEntB->prov.ty_desc = "ty_desc_b";
- provEntB->prov.label = "label_b";
- provEntB->prov.module = "module_b";
- provEntB->prov.srcloc = "srcloc_b";
-
- InfoProvEnt **ipeList_2 = malloc(sizeof(InfoProvEnt *) * 3);
- ipeList_2[0] = provEntA;
- ipeList_2[1] = provEntB;
- ipeList_2[2] = NULL;
-
- registerInfoProvList(ipeList_2);
-
- // Trace all IPE events. Expected count (see Makefile): 381 + 2 = 383
- dumpIPEToEventLog();
-
- rts_unlock(cap);
- hs_exit();
-}
diff --git a/testsuite/tests/rts/ipeEventLog_fromMap.c b/testsuite/tests/rts/ipeEventLog_fromMap.c
deleted file mode 100644
index 5bd9e4d034..0000000000
--- a/testsuite/tests/rts/ipeEventLog_fromMap.c
+++ /dev/null
@@ -1,35 +0,0 @@
-#include "Rts.h"
-#include "RtsAPI.h"
-#include "rts/IPE.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-
-extern void dumpIPEToEventLog(void);
-InfoProvEnt *makeAnyProvEntry(Capability *cap, int i);
-
-int main(int argc, char *argv[]) {
- hs_init(&argc, &argv);
- Capability *cap = rts_lock();
-
- HaskellObj one = rts_mkInt(cap, 1);
-
- InfoProvEnt *provEnt_0 = makeAnyProvEntry(cap, 0);
- InfoProvEnt *provEnt_1 = makeAnyProvEntry(cap, 1);
-
- InfoProvEnt **ipeList_1 = malloc(sizeof(InfoProvEnt *) * 3);
- ipeList_1[0] = provEnt_0;
- ipeList_1[1] = provEnt_1;
- ipeList_1[2] = NULL;
-
- registerInfoProvList(ipeList_1);
-
- // Query an IPE to initialize the underlying hash map.
- lookupIPE(ipeList_1[0]->info);
-
- // Trace all IPE events.
- dumpIPEToEventLog();
-
- rts_unlock(cap);
- hs_exit();
-}
diff --git a/testsuite/tests/rts/ipeEventLog_fromMap.stderr b/testsuite/tests/rts/ipeEventLog_fromMap.stderr
deleted file mode 100644
index 7ad1fb998a..0000000000
--- a/testsuite/tests/rts/ipeEventLog_fromMap.stderr
+++ /dev/null
@@ -1,2 +0,0 @@
-IPE: table_name table_name_001, closure_desc closure_desc_001, ty_desc ty_desc_001, label label_001, module module_001, srcloc srcloc_001
-IPE: table_name table_name_000, closure_desc closure_desc_000, ty_desc ty_desc_000, label label_000, module module_000, srcloc srcloc_000
diff --git a/testsuite/tests/rts/ipeEventLog_lib.c b/testsuite/tests/rts/ipeEventLog_lib.c
deleted file mode 100644
index df54231fa7..0000000000
--- a/testsuite/tests/rts/ipeEventLog_lib.c
+++ /dev/null
@@ -1,42 +0,0 @@
-#include "Rts.h"
-#include "rts/IPE.h"
-#include <string.h>
-
-InfoProvEnt *makeAnyProvEntry(Capability *cap, int i) {
- HaskellObj fourtyTwo = rts_mkInt(cap, 42);
-
- InfoProvEnt *provEnt = malloc(sizeof(InfoProvEnt));
- provEnt->info = (StgInfoTable *)fourtyTwo->header.info;
-
- unsigned int tableNameLength = strlen("table_name_") + 3 /* digits */ + 1 /* null character */;
- char *tableName = malloc(sizeof(char) * tableNameLength);
- snprintf(tableName, tableNameLength, "table_name_%03i", i);
- provEnt->prov.table_name = tableName;
-
- unsigned int closureDescLength = strlen("closure_desc_") + 3 /* digits */ + 1 /* null character */;
- char *closureDesc = malloc(sizeof(char) * closureDescLength);
- snprintf(closureDesc, closureDescLength, "closure_desc_%03i", i);
- provEnt->prov.closure_desc = closureDesc;
-
- unsigned int tyDescLength = strlen("ty_desc_") + 3 /* digits */ + 1 /* null character */;
- char *tyDesc = malloc(sizeof(char) * tyDescLength);
- snprintf(tyDesc, tyDescLength, "ty_desc_%03i", i);
- provEnt->prov.ty_desc = tyDesc;
-
- unsigned int labelLength = strlen("label_") + 3 /* digits */ + 1 /* null character */;
- char *label = malloc(sizeof(char) * labelLength);
- snprintf(label, labelLength, "label_%03i", i);
- provEnt->prov.label = label;
-
- unsigned int moduleLength = strlen("module_") + 3 /* digits */ + 1 /* null character */;
- char *module = malloc(sizeof(char) * labelLength);
- snprintf(module, moduleLength, "module_%03i", i);
- provEnt->prov.module = module;
-
- unsigned int srcLocLength = strlen("srcloc_") + 3 /* digits */ + 1 /* null character */;
- char *srcLoc = malloc(sizeof(char) * srcLocLength);
- snprintf(srcLoc, srcLocLength, "srcloc_%03i", i);
- provEnt->prov.srcloc = srcLoc;
-
- return provEnt;
-}
diff --git a/testsuite/tests/rts/ipeMap.c b/testsuite/tests/rts/ipeMap.c
deleted file mode 100644
index 41e7e9fb89..0000000000
--- a/testsuite/tests/rts/ipeMap.c
+++ /dev/null
@@ -1,209 +0,0 @@
-#include <stdlib.h>
-#include <string.h>
-
-#include "Rts.h"
-
-void assertStringsEqual(char *s1, char *s2);
-void shouldFindNothingInAnEmptyIPEMap(Capability *cap);
-HaskellObj shouldFindOneIfItHasBeenRegistered(Capability *cap);
-void shouldFindTwoIfTwoHaveBeenRegistered(Capability *cap, HaskellObj fortyTwo);
-void shouldFindTwoFromTheSameList(Capability *cap);
-void shouldFindTheLastEntryOfManyLists(Capability *cap);
-void shouldDealWithAnEmptyList(Capability *cap, HaskellObj);
-
-// This is a unit test for IPE.c, the IPE map.
-// Due to the nature of IPE having static state, the test cases are not
-// independent of each other!
-int main(int argc, char *argv[]) {
- hs_init(&argc, &argv);
- Capability *cap = rts_lock();
-
- shouldFindNothingInAnEmptyIPEMap(cap);
- HaskellObj fortyTwo = shouldFindOneIfItHasBeenRegistered(cap);
- shouldFindTwoIfTwoHaveBeenRegistered(cap, fortyTwo);
- shouldFindTwoFromTheSameList(cap);
- shouldFindTheLastEntryOfManyLists(cap);
- shouldDealWithAnEmptyList(cap, fortyTwo);
-
- rts_unlock(cap);
- hs_exit();
-}
-
-void shouldFindNothingInAnEmptyIPEMap(Capability *cap) {
- HaskellObj fortyTwo = UNTAG_CLOSURE(rts_mkInt(cap, 42));
-
- InfoProvEnt *result = lookupIPE(get_itbl(fortyTwo));
-
- if (result != NULL) {
- errorBelch("Found entry in an empty IPE map!");
- exit(1);
- }
-}
-
-HaskellObj shouldFindOneIfItHasBeenRegistered(Capability *cap) {
- HaskellObj fortyTwo = UNTAG_CLOSURE(rts_mkInt(cap, 42));
-
- InfoProvEnt *provEnt = malloc(sizeof(InfoProvEnt));
- provEnt->info = get_itbl(fortyTwo);
- provEnt->prov.table_name = "table_name_42";
- provEnt->prov.closure_desc = "closure_desc_42";
- provEnt->prov.ty_desc = "ty_desc_42";
- provEnt->prov.label = "label_42";
- provEnt->prov.module = "module_42";
- provEnt->prov.srcloc = "srcloc_42";
-
- InfoProvEnt *ipeList[] = {provEnt, NULL};
-
- registerInfoProvList(ipeList);
- InfoProvEnt *result = lookupIPE(get_itbl(fortyTwo));
-
- if (result == NULL) {
- errorBelch("Found no entry in IPE map!");
- exit(1);
- }
-
- assertStringsEqual(result->prov.table_name, "table_name_42");
- assertStringsEqual(result->prov.closure_desc, "closure_desc_42");
- assertStringsEqual(result->prov.ty_desc, "ty_desc_42");
- assertStringsEqual(result->prov.label, "label_42");
- assertStringsEqual(result->prov.module, "module_42");
- assertStringsEqual(result->prov.srcloc, "srcloc_42");
-
- return fortyTwo;
-}
-
-void shouldFindTwoIfTwoHaveBeenRegistered(Capability *cap,
- HaskellObj fortyTwo) {
- HaskellObj twentyThree = UNTAG_CLOSURE(rts_mkInt8(cap, 23));
-
- InfoProvEnt *provEnt = malloc(sizeof(InfoProvEnt));
- provEnt->info = get_itbl(twentyThree);
- provEnt->prov.table_name = "table_name_23";
- provEnt->prov.closure_desc = "closure_desc_23";
- provEnt->prov.ty_desc = "ty_desc_23";
- provEnt->prov.label = "label_23";
- provEnt->prov.module = "module_23";
- provEnt->prov.srcloc = "srcloc_23";
-
- InfoProvEnt *ipeList[] = {provEnt, NULL};
-
- registerInfoProvList(ipeList);
-
- InfoProvEnt *resultFortyTwo =
- lookupIPE(get_itbl(fortyTwo));
- InfoProvEnt *resultTwentyThree =
- lookupIPE(get_itbl(twentyThree));
-
- if (resultFortyTwo == NULL || resultTwentyThree == NULL) {
- errorBelch("Found no entry in IPE map!");
- exit(1);
- }
-
- assertStringsEqual(resultFortyTwo->prov.table_name, "table_name_42");
- assertStringsEqual(resultTwentyThree->prov.table_name, "table_name_23");
-}
-
-void shouldFindTwoFromTheSameList(Capability *cap) {
- HaskellObj one = UNTAG_CLOSURE(rts_mkInt16(cap, 1));
-
- InfoProvEnt *provEntOne = malloc(sizeof(InfoProvEnt));
- provEntOne->info = get_itbl(one);
- provEntOne->prov.table_name = "table_name_1";
- provEntOne->prov.closure_desc = "closure_desc_1";
- provEntOne->prov.ty_desc = "ty_desc_1";
- provEntOne->prov.label = "label_1";
- provEntOne->prov.module = "module_1";
- provEntOne->prov.srcloc = "srcloc_1";
-
- HaskellObj two = UNTAG_CLOSURE(rts_mkInt32(cap, 2));
-
- InfoProvEnt *provEntTwo = malloc(sizeof(InfoProvEnt));
- provEntTwo->info = get_itbl(two);
- provEntTwo->prov.table_name = "table_name_2";
- provEntTwo->prov.closure_desc = "closure_desc_2";
- provEntTwo->prov.ty_desc = "ty_desc_2";
- provEntTwo->prov.label = "label_2";
- provEntTwo->prov.module = "module_2";
- provEntTwo->prov.srcloc = "srcloc_2";
-
- InfoProvEnt *ipeList[] = {provEntOne, provEntTwo, NULL};
-
- registerInfoProvList(ipeList);
-
- InfoProvEnt *resultOne = lookupIPE(get_itbl(one));
- InfoProvEnt *resultTwo = lookupIPE(get_itbl(two));
-
- if (resultOne == NULL || resultOne == NULL) {
- errorBelch("Found no entry in IPE map!");
- exit(1);
- }
-
- assertStringsEqual(resultOne->prov.table_name, "table_name_1");
- assertStringsEqual(resultTwo->prov.table_name, "table_name_2");
-}
-
-void shouldFindTheLastEntryOfManyLists(Capability *cap) {
- HaskellObj three = UNTAG_CLOSURE(rts_mkInt64(cap, 3));
-
- InfoProvEnt *provEntThree = malloc(sizeof(InfoProvEnt));
- provEntThree->info = get_itbl(three);
- provEntThree->prov.table_name = "table_name_3";
- provEntThree->prov.closure_desc = "closure_desc_3";
- provEntThree->prov.ty_desc = "ty_desc_3";
- provEntThree->prov.label = "label_3";
- provEntThree->prov.module = "module_3";
- provEntThree->prov.srcloc = "srcloc_3";
-
- HaskellObj four = UNTAG_CLOSURE(rts_mkWord8(cap, 4));
-
- InfoProvEnt *provEntFour = malloc(sizeof(InfoProvEnt));
- provEntFour->info = get_itbl(four);
- provEntFour->prov.table_name = "table_name_4";
- provEntFour->prov.closure_desc = "closure_desc_4";
- provEntFour->prov.ty_desc = "ty_desc_4";
- provEntFour->prov.label = "label_4";
- provEntFour->prov.module = "module_4";
- provEntFour->prov.srcloc = "srcloc_4";
-
- InfoProvEnt *ipeListThree[] = {provEntThree, NULL};
- InfoProvEnt *ipeListFour[] = {provEntFour, NULL};
-
- // Force the creation of 4 IpeBufferListNodes
- for (int i = 0; i <= 126 * 3 + 1; i++) {
- registerInfoProvList(ipeListThree);
- }
-
- registerInfoProvList(ipeListFour);
-
- InfoProvEnt *resultFour = lookupIPE(get_itbl(four));
-
- if (resultFour == NULL) {
- errorBelch("Found no entry in IPE map!");
- exit(1);
- }
-
- assertStringsEqual(resultFour->prov.table_name, "table_name_4");
-}
-
-void shouldDealWithAnEmptyList(Capability *cap, HaskellObj fortyTwo) {
- InfoProvEnt *emptyIpeList[] = {NULL};
-
- registerInfoProvList(emptyIpeList);
-
- InfoProvEnt *resultFortyTwo =
- lookupIPE(get_itbl(fortyTwo));
-
- if (resultFortyTwo == NULL) {
- errorBelch("Found no entry in IPE map!");
- exit(1);
- }
-
- assertStringsEqual(resultFortyTwo->prov.table_name, "table_name_42");
-}
-
-void assertStringsEqual(char *s1, char *s2) {
- if (strcmp(s1, s2) != 0) {
- errorBelch("%s != %s", s1, s2);
- exit(1);
- }
-}