diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index 4a9f001fc073a6278acb7a6c5b4aaf2930d67510..790664d15eb44ef4ed0116f5a7eefaa5676f0232 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -3849,10 +3849,9 @@ primop ClearCCSOp "clearCCS#" GenPrimOp section "Info Table Origin" ------------------------------------------------------------------------ primop WhereFromOp "whereFrom#" GenPrimOp - a -> State# s -> (# State# s, Addr# #) - { Returns the @InfoProvEnt @ for the info table of the given object - (value is @NULL@ if the table does not exist or there is no information - about the closure).} + a -> Addr# -> State# s -> (# State# s, Int# #) + { Fills the given buffer with the @InfoProvEnt@ for the info table of the + given object. Returns @1#@ on success and @0#@ otherwise.} with out_of_line = True diff --git a/libraries/ghc-internal/src/GHC/Internal/InfoProv.hs b/libraries/ghc-internal/src/GHC/Internal/InfoProv.hs index 35c22b1341bbab126f782c1aed3d6b1e06ae0c78..018bdc6bda2037231ac57b3e2ae9cb655f19bd8c 100644 --- a/libraries/ghc-internal/src/GHC/Internal/InfoProv.hs +++ b/libraries/ghc-internal/src/GHC/Internal/InfoProv.hs @@ -35,7 +35,6 @@ module GHC.Internal.InfoProv ) where import GHC.Internal.Base -import GHC.Internal.Ptr (nullPtr) import GHC.Internal.InfoProv.Types -- | Get information about where a value originated from. @@ -50,14 +49,5 @@ import GHC.Internal.InfoProv.Types -- -- @since base-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 +whereFrom obj = getIPE obj Nothing $ \p -> + Just `fmap` peekInfoProv (ipeProv p) diff --git a/libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc b/libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc index 99652d2ea75b04eab91d36908a7bfd9c4fac1742..df189bbc9070e9352d1fe9afa97d56307e8586db 100644 --- a/libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc +++ b/libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc @@ -13,6 +13,8 @@ module GHC.Internal.InfoProv.Types , InfoProvEnt , peekInfoProv , getIPE + , StgInfoTable + , lookupIPE ) where import GHC.Internal.Base @@ -21,6 +23,8 @@ import GHC.Internal.Enum import GHC.Internal.Show (Show) import GHC.Internal.Ptr (Ptr(..), plusPtr) import GHC.Internal.Foreign.C.String.Encoding (CString, peekCString) +import GHC.Internal.Foreign.C.Types (CBool(..)) +import GHC.Internal.Foreign.Marshal.Alloc (allocaBytes) import GHC.Internal.IO.Encoding (utf8) import GHC.Internal.Foreign.Storable (peekByteOff) import GHC.Internal.ClosureTypes @@ -41,10 +45,24 @@ ipLoc ipe = ipSrcFile ipe ++ ":" ++ ipSrcSpan ipe data InfoProvEnt -getIPE :: a -> IO (Ptr InfoProvEnt) -getIPE obj = IO $ \s -> - case whereFrom## obj s of - (## s', addr ##) -> (## s', Ptr addr ##) +data StgInfoTable + +foreign import ccall "lookupIPE" c_lookupIPE :: Ptr StgInfoTable -> Ptr InfoProvEnt -> IO CBool + +lookupIPE :: Ptr StgInfoTable -> IO (Maybe InfoProv) +lookupIPE itbl = allocaBytes (#size InfoProvEnt) $ \p -> do + res <- c_lookupIPE itbl p + case res of + 1 -> Just `fmap` peekInfoProv (ipeProv p) + _ -> return Nothing + +getIPE :: a -> r -> (Ptr InfoProvEnt -> IO r) -> IO r +getIPE obj fail k = allocaBytes (#size InfoProvEnt) $ \p -> IO $ \s -> + case whereFrom## obj (unPtr p) s of + (## s', 1## ##) -> unIO (k p) s' + (## s', _ ##) -> (## s', fail ##) + where + unPtr (Ptr p) = p ipeProv :: Ptr InfoProvEnt -> Ptr InfoProv ipeProv p = (#ptr InfoProvEnt, prov) p diff --git a/libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs b/libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs index 5be7d396fd78e788f5b1fcc17016fed7b83f06c5..f87ae9f8f1318db484d0f2ce689ebcb2d1aec82d 100644 --- a/libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs +++ b/libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs @@ -26,20 +26,20 @@ import GHC.Internal.MVar import GHC.Internal.Data.Maybe (catMaybes) import GHC.Internal.Base import GHC.Internal.Conc.Sync -import GHC.Internal.Exts () -- (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofArray#, indexArray#, State#, StablePtr#) -import GHC.Internal.InfoProv.Types (InfoProv (..), InfoProvEnt, ipLoc, ipeProv, peekInfoProv) +import GHC.Internal.IO (unsafeInterleaveIO) +import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE, StgInfoTable) import GHC.Internal.Num import GHC.Internal.Stable import GHC.Internal.Text.Show import GHC.Internal.Ptr -import GHC.Internal.ClosureTypes ( ClosureType(..) ) +import GHC.Internal.ClosureTypes -- | A frozen snapshot of the state of an execution stack. -- -- @since base-4.17.0.0 data StackSnapshot = StackSnapshot !StackSnapshot# -foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Array# (Ptr InfoProvEnt) #) +foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Array# (Ptr StgInfoTable) #) foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #) @@ -231,37 +231,30 @@ data StackEntry = StackEntry -- -- @since base-4.17.0.0 decode :: StackSnapshot -> IO [StackEntry] -decode stackSnapshot = do - stackEntries <- getDecodedStackArray stackSnapshot - ipes <- mapM unmarshal stackEntries - return $ catMaybes ipes - - where - unmarshal :: Ptr InfoProvEnt -> IO (Maybe StackEntry) - unmarshal ipe = if ipe == nullPtr then - pure Nothing - else do - infoProv <- (peekInfoProv . ipeProv) ipe - pure $ Just (toStackEntry infoProv) - toStackEntry :: InfoProv -> StackEntry - toStackEntry infoProv = - StackEntry - { functionName = ipLabel infoProv, - moduleName = ipMod infoProv, - srcLoc = ipLoc infoProv, - closureType = ipDesc infoProv - } - -getDecodedStackArray :: StackSnapshot -> IO [Ptr InfoProvEnt] +decode stackSnapshot = catMaybes `fmap` getDecodedStackArray stackSnapshot + +toStackEntry :: InfoProv -> StackEntry +toStackEntry infoProv = + StackEntry + { functionName = ipLabel infoProv, + moduleName = ipMod infoProv, + srcLoc = ipLoc infoProv, + closureType = ipDesc infoProv + } + +getDecodedStackArray :: StackSnapshot -> IO [Maybe StackEntry] getDecodedStackArray (StackSnapshot s) = IO $ \s0 -> case decodeStack# s s0 of - (# s1, a #) -> (# s1, (go a ((I# (sizeofArray# a)) - 1)) #) + (# s1, arr #) -> unIO (go arr (I# (sizeofArray# arr) - 1)) s1 where - go :: Array# (Ptr InfoProvEnt) -> Int -> [Ptr InfoProvEnt] - go stack 0 = [stackEntryAt stack 0] - go stack i = (stackEntryAt stack i) : go stack (i - 1) - - stackEntryAt :: Array# (Ptr InfoProvEnt) -> Int -> Ptr InfoProvEnt + go :: Array# (Ptr StgInfoTable) -> Int -> IO [Maybe StackEntry] + go _stack (-1) = return [] + go stack i = do + infoProv <- lookupIPE (stackEntryAt stack i) + rest <- unsafeInterleaveIO $ go stack (i-1) + return ((toStackEntry `fmap` infoProv) : rest) + + stackEntryAt :: Array# (Ptr StgInfoTable) -> Int -> Ptr StgInfoTable stackEntryAt stack (I# i) = case indexArray# stack i of (# se #) -> se diff --git a/rts/CloneStack.c b/rts/CloneStack.c index 2db0bbf2f09aa91802f77041db2c7ba3b01b7470..d10bc21178c268e19c5e54e43a39c7cb2f46efa6 100644 --- a/rts/CloneStack.c +++ b/rts/CloneStack.c @@ -29,7 +29,7 @@ static StgWord getStackFrameCount(StgStack* stack); static StgWord getStackChunkClosureCount(StgStack* stack); static void copyPtrsToArray(Capability *cap, StgMutArrPtrs* arr, StgStack* stack); -static StgClosure* createPtrClosure(Capability* cap, InfoProvEnt* ipe); +static StgClosure* createPtrClosure(Capability* cap, const StgInfoTable* itbl); static StgMutArrPtrs* allocateMutableArray(StgWord size); static StgStack* cloneStackChunk(Capability* capability, const StgStack* stack) @@ -180,26 +180,8 @@ void copyPtrsToArray(Capability *cap, StgMutArrPtrs* arr, StgStack* stack) { StgPtr sp = last_stack->sp; StgPtr spBottom = last_stack->stack + last_stack->stack_size; for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) { - const StgInfoTable* infoTable = get_itbl((StgClosure *)sp); - - // Add the IPE that was looked up by lookupIPE() to the MutableArray#. - // The "Info Table Provernance Entry Map" (IPE) idea is to use a pointer - // (address) to the info table to lookup entries, this is fulfilled in - // non-"Tables Next to Code" builds. - // When "Tables Next to Code" is used, the assembly label of the info table - // is between the info table and it's code. There's no other label in the - // assembly code which could be used instead, thus lookupIPE() is actually - // called with the code pointer of the info table. - // (As long as it's used consistently, this doesn't really matter - IPE uses - // the pointer only to connect an info table to it's provenance entry in the - // IPE map.) -#if defined(TABLES_NEXT_TO_CODE) - InfoProvEnt* ipe = lookupIPE((StgInfoTable*) infoTable->code); -#else - InfoProvEnt* ipe = lookupIPE(infoTable); -#endif - arr->payload[index] = createPtrClosure(cap, ipe); - + const StgInfoTable* infoTable = ((StgClosure *)sp)->header.info; + arr->payload[index] = createPtrClosure(cap, infoTable); index++; } @@ -217,11 +199,11 @@ void copyPtrsToArray(Capability *cap, StgMutArrPtrs* arr, StgStack* stack) { } } -// Create a GHC.Ptr (Haskell constructor: `Ptr InfoProvEnt`) pointing to the -// IPE. -StgClosure* createPtrClosure(Capability *cap, InfoProvEnt* ipe) { +// Create a GHC.Ptr (Haskell constructor: `Ptr StgInfoTable`) pointing to the +// info table. +StgClosure* createPtrClosure(Capability *cap, const StgInfoTable* itbl) { StgClosure *p = (StgClosure *) allocate(cap, CONSTR_sizeW(0,1)); SET_HDR(p, &ghczminternal_GHCziInternalziPtr_Ptr_con_info, CCS_SYSTEM); - p->payload[0] = (StgClosure*) ipe; + p->payload[0] = (StgClosure*) itbl; return TAG_CLOSURE(1, p); } diff --git a/rts/IPE.c b/rts/IPE.c index b3e5edea88dcc88287479379173d0b7ef6640660..2e4088fee94e9ce0243f3d2416f9f71fd2f7cfe7 100644 --- a/rts/IPE.c +++ b/rts/IPE.c @@ -52,16 +52,23 @@ 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. +to deduplicate strings when generating the string table. 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. +This involves allocating a IpeMapEntry for each IPE entry, pointing to the +entry's containing IpeBufferListNode and its index in that node. + +When the user looks up an IPE entry, we convert it to the user-facing +InfoProvEnt representation. -After the content of a IpeBufferListNode has been inserted, it's freed. */ +typedef struct { + IpeBufferListNode *node; + uint32_t idx; +} IpeMapEntry; + #if defined(THREADED_RTS) static Mutex ipeMapLock; #endif @@ -71,6 +78,8 @@ static HashTable *ipeMap = NULL; // Accessed atomically static IpeBufferListNode *ipeBufferList = NULL; +static void decompressIPEBufferListNodeIfCompressed(IpeBufferListNode*); + #if defined(THREADED_RTS) void initIpe(void) { initMutex(&ipeMapLock); } @@ -85,18 +94,22 @@ void exitIpe(void) { } #endif // THREADED_RTS -static InfoProvEnt ipeBufferEntryToIpe(const char *strings, const StgInfoTable *tbl, const IpeBufferEntry ent) +static InfoProvEnt ipeBufferEntryToIpe(const IpeBufferListNode *node, uint32_t idx) { + CHECK(idx < node->count); + CHECK(!node->compressed); + const char *strings = node->string_table; + const IpeBufferEntry *ent = &node->entries[idx]; return (InfoProvEnt) { - .info = tbl, + .info = node->tables[idx], .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], - .src_file = &strings[ent.src_file], - .src_span = &strings[ent.src_span] + .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], + .src_file = &strings[ent->src_file], + .src_span = &strings[ent->src_span] } }; } @@ -105,29 +118,22 @@ static InfoProvEnt ipeBufferEntryToIpe(const char *strings, const StgInfoTable * #if defined(TRACING) static void traceIPEFromHashTable(void *data STG_UNUSED, StgWord key STG_UNUSED, const void *value) { - InfoProvEnt *ipe = (InfoProvEnt *)value; - traceIPE(ipe); + const IpeMapEntry *map_ent = (const IpeMapEntry *)value; + const InfoProvEnt ipe = ipeBufferEntryToIpe(map_ent->node, map_ent->idx); + traceIPE(&ipe); } void dumpIPEToEventLog(void) { // Dump pending entries - IpeBufferListNode *cursor = RELAXED_LOAD(&ipeBufferList); - while (cursor != NULL) { - IpeBufferEntry *entries; - const char *strings; + IpeBufferListNode *node = RELAXED_LOAD(&ipeBufferList); + while (node != NULL) { + decompressIPEBufferListNodeIfCompressed(node); - // Decompress if compressed - decompressIPEBufferListNodeIfCompressed(cursor, &entries, &strings); - - for (uint32_t i = 0; i < cursor->count; i++) { - const InfoProvEnt ent = ipeBufferEntryToIpe( - strings, - cursor->tables[i], - entries[i] - ); + for (uint32_t i = 0; i < node->count; i++) { + const InfoProvEnt ent = ipeBufferEntryToIpe(node, i); traceIPE(&ent); } - cursor = cursor->next; + node = node->next; } // Dump entries already in hashmap @@ -168,9 +174,15 @@ void registerInfoProvList(IpeBufferListNode *node) { } } -InfoProvEnt *lookupIPE(const StgInfoTable *info) { +bool lookupIPE(const StgInfoTable *info, InfoProvEnt *out) { updateIpeMap(); - return lookupHashTable(ipeMap, (StgWord)info); + IpeMapEntry *map_ent = (IpeMapEntry *) lookupHashTable(ipeMap, (StgWord)info); + if (map_ent) { + *out = ipeBufferEntryToIpe(map_ent->node, map_ent->idx); + return true; + } else { + return false; + } } void updateIpeMap(void) { @@ -188,47 +200,40 @@ void updateIpeMap(void) { } while (pending != NULL) { - IpeBufferListNode *current_node = pending; - IpeBufferEntry *entries; - const char *strings; + IpeBufferListNode *node = pending; // Decompress if compressed - decompressIPEBufferListNodeIfCompressed(current_node, &entries, &strings); - - // Convert the on-disk IPE buffer entry representation (IpeBufferEntry) - // into the runtime representation (InfoProvEnt) - InfoProvEnt *ip_ents = stgMallocBytes( - sizeof(InfoProvEnt) * current_node->count, - "updateIpeMap: ip_ents" - ); - for (uint32_t i = 0; i < current_node->count; i++) { - const IpeBufferEntry ent = entries[i]; - const StgInfoTable *tbl = current_node->tables[i]; - ip_ents[i] = ipeBufferEntryToIpe(strings, tbl, ent); - insertHashTable(ipeMap, (StgWord) tbl, &ip_ents[i]); + decompressIPEBufferListNodeIfCompressed(node); + + // Insert entries into ipeMap + IpeMapEntry *map_ents = stgMallocBytes(node->count * sizeof(IpeMapEntry), "updateIpeMap: ip_ents"); + for (uint32_t i = 0; i < node->count; i++) { + const StgInfoTable *tbl = node->tables[i]; + map_ents[i].node = node; + map_ents[i].idx = i; + insertHashTable(ipeMap, (StgWord) tbl, &map_ents[i]); } - pending = current_node->next; + pending = node->next; } RELEASE_LOCK(&ipeMapLock); } /* Decompress the IPE data and strings table referenced by an IPE buffer list -node if it is compressed. No matter whether the data is compressed, the pointers -referenced by the 'entries_dst' and 'string_table_dst' parameters will point at -the decompressed IPE data and string table for the given node, respectively, -upon return from this function. -*/ -void decompressIPEBufferListNodeIfCompressed(IpeBufferListNode *node, IpeBufferEntry **entries_dst, const char **string_table_dst) { + * node if it is compressed. After returning node->compressed with be 0 and the + * string_table and entries fields will have their uncompressed values. + */ +void decompressIPEBufferListNodeIfCompressed(IpeBufferListNode *node) { if (node->compressed == 1) { + node->compressed = 0; + // The IPE list buffer node indicates that the strings table and // entries list has been compressed. If zstd is not available, fail. // If zstd is available, decompress. #if HAVE_LIBZSTD == 0 barf("An IPE buffer list node has been compressed, but the " - "decompression library (zstd) is not available." -); + "decompression library (zstd) is not available."); #else size_t compressed_sz = ZSTD_findFrameCompressedSize( node->string_table, @@ -244,7 +249,7 @@ void decompressIPEBufferListNodeIfCompressed(IpeBufferListNode *node, IpeBufferE node->string_table, compressed_sz ); - *string_table_dst = decompressed_strings; + node->string_table = (const char *) decompressed_strings; // Decompress the IPE data compressed_sz = ZSTD_findFrameCompressedSize( @@ -261,12 +266,8 @@ void decompressIPEBufferListNodeIfCompressed(IpeBufferListNode *node, IpeBufferE node->entries, compressed_sz ); - *entries_dst = decompressed_entries; + node->entries = decompressed_entries; #endif // HAVE_LIBZSTD == 0 - } else { - // Not compressed, no need to decompress - *entries_dst = node->entries; - *string_table_dst = node->string_table; } } diff --git a/rts/IPE.h b/rts/IPE.h index 9dbb4f1636959be0a4187b20e8166ee53a5d7524..cc2d4eca504b93494c5f18bb39e1adba0616d29a 100644 --- a/rts/IPE.h +++ b/rts/IPE.h @@ -17,6 +17,5 @@ void dumpIPEToEventLog(void); void updateIpeMap(void); void initIpe(void); void exitIpe(void); -void decompressIPEBufferListNodeIfCompressed(IpeBufferListNode*, IpeBufferEntry**, const char**); #include "EndPrivate.h" diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 38aa4ea01d9da90eed2f7ebbed903b32453274e6..9f9bfdaf7a1302a88e705219baec1086d7322047 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -2533,13 +2533,13 @@ stg_closureSizzezh (P_ clos) return (len); } -stg_whereFromzh (P_ clos) +stg_whereFromzh (P_ clos, W_ buf) { - P_ ipe; + CBool success; W_ info; info = GET_INFO(UNTAG(clos)); - (ipe) = foreign "C" lookupIPE(info "ptr"); - return (ipe); + (success) = foreign "C" lookupIPE(info, buf); + return (TO_W_(success)); } /* ----------------------------------------------------------------------------- diff --git a/rts/include/rts/IPE.h b/rts/include/rts/IPE.h index ca87aa840a953ec807e5471adee611a4d63a0fd0..18640501b022fdbbc90be99354df21a65f591d11 100644 --- a/rts/include/rts/IPE.h +++ b/rts/include/rts/IPE.h @@ -86,4 +86,6 @@ typedef struct IpeBufferListNode_ { } IpeBufferListNode; void registerInfoProvList(IpeBufferListNode *node); -InfoProvEnt *lookupIPE(const StgInfoTable *info); + +// Returns true on success, initializes `out`. +bool lookupIPE(const StgInfoTable *info, InfoProvEnt *out); diff --git a/testsuite/tests/interface-stability/base-exports.stdout b/testsuite/tests/interface-stability/base-exports.stdout index c4e8c2042494667b33da340e95c89e572c0327a9..f5df15d3eb14216c4e61c3f9dec143fe4ebdc84e 100644 --- a/testsuite/tests/interface-stability/base-exports.stdout +++ b/testsuite/tests/interface-stability/base-exports.stdout @@ -4755,7 +4755,7 @@ module GHC.Base where waitRead# :: forall d. Int# -> State# d -> State# d waitWrite# :: forall d. Int# -> State# d -> State# d when :: forall (f :: * -> *). Applicative f => Bool -> f () -> f () - whereFrom# :: forall a d. a -> State# d -> (# State# d, Addr# #) + whereFrom# :: forall a d. a -> Addr# -> State# d -> (# State# d, Int# #) word16ToInt16# :: Word16# -> Int16# word16ToWord# :: Word16# -> Word# word2Double# :: Word# -> Double# @@ -6857,7 +6857,7 @@ module GHC.Exts where void# :: (# #) waitRead# :: forall d. Int# -> State# d -> State# d waitWrite# :: forall d. Int# -> State# d -> State# d - whereFrom# :: forall a d. a -> State# d -> (# State# d, Addr# #) + whereFrom# :: forall a d. a -> Addr# -> State# d -> (# State# d, Int# #) word16ToInt16# :: Word16# -> Int16# word16ToWord# :: Word16# -> Word# word2Double# :: Word# -> Double# diff --git a/testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs b/testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs index caa079721b338245de3ef5c3902796ad733b78d3..ac9c3ca676df00b6f1380ad10431a9e72750a3f1 100644 --- a/testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs +++ b/testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs @@ -4755,7 +4755,7 @@ module GHC.Base where waitRead# :: forall d. Int# -> State# d -> State# d waitWrite# :: forall d. Int# -> State# d -> State# d when :: forall (f :: * -> *). Applicative f => Bool -> f () -> f () - whereFrom# :: forall a d. a -> State# d -> (# State# d, Addr# #) + whereFrom# :: forall a d. a -> Addr# -> State# d -> (# State# d, Int# #) word16ToInt16# :: Word16# -> Int16# word16ToWord# :: Word16# -> Word# word2Double# :: Word# -> Double# @@ -6826,7 +6826,7 @@ module GHC.Exts where void# :: (# #) waitRead# :: forall d. Int# -> State# d -> State# d waitWrite# :: forall d. Int# -> State# d -> State# d - whereFrom# :: forall a d. a -> State# d -> (# State# d, Addr# #) + whereFrom# :: forall a d. a -> Addr# -> State# d -> (# State# d, Int# #) word16ToInt16# :: Word16# -> Int16# word16ToWord# :: Word16# -> Word# word2Double# :: Word# -> Double# diff --git a/testsuite/tests/interface-stability/base-exports.stdout-mingw32 b/testsuite/tests/interface-stability/base-exports.stdout-mingw32 index 3625e9ae31e4e617b948650a1071a57939fe7522..295e298a3bf694f2543c0aa2c6bc79b43ed505b5 100644 --- a/testsuite/tests/interface-stability/base-exports.stdout-mingw32 +++ b/testsuite/tests/interface-stability/base-exports.stdout-mingw32 @@ -4758,7 +4758,7 @@ module GHC.Base where waitRead# :: forall d. Int# -> State# d -> State# d waitWrite# :: forall d. Int# -> State# d -> State# d when :: forall (f :: * -> *). Applicative f => Bool -> f () -> f () - whereFrom# :: forall a d. a -> State# d -> (# State# d, Addr# #) + whereFrom# :: forall a d. a -> Addr# -> State# d -> (# State# d, Int# #) word16ToInt16# :: Word16# -> Int16# word16ToWord# :: Word16# -> Word# word2Double# :: Word# -> Double# @@ -7006,7 +7006,7 @@ module GHC.Exts where void# :: (# #) waitRead# :: forall d. Int# -> State# d -> State# d waitWrite# :: forall d. Int# -> State# d -> State# d - whereFrom# :: forall a d. a -> State# d -> (# State# d, Addr# #) + whereFrom# :: forall a d. a -> Addr# -> State# d -> (# State# d, Int# #) word16ToInt16# :: Word16# -> Int16# word16ToWord# :: Word16# -> Word# word2Double# :: Word# -> Double# diff --git a/testsuite/tests/interface-stability/base-exports.stdout-ws-32 b/testsuite/tests/interface-stability/base-exports.stdout-ws-32 index c4e8c2042494667b33da340e95c89e572c0327a9..f5df15d3eb14216c4e61c3f9dec143fe4ebdc84e 100644 --- a/testsuite/tests/interface-stability/base-exports.stdout-ws-32 +++ b/testsuite/tests/interface-stability/base-exports.stdout-ws-32 @@ -4755,7 +4755,7 @@ module GHC.Base where waitRead# :: forall d. Int# -> State# d -> State# d waitWrite# :: forall d. Int# -> State# d -> State# d when :: forall (f :: * -> *). Applicative f => Bool -> f () -> f () - whereFrom# :: forall a d. a -> State# d -> (# State# d, Addr# #) + whereFrom# :: forall a d. a -> Addr# -> State# d -> (# State# d, Int# #) word16ToInt16# :: Word16# -> Int16# word16ToWord# :: Word16# -> Word# word2Double# :: Word# -> Double# @@ -6857,7 +6857,7 @@ module GHC.Exts where void# :: (# #) waitRead# :: forall d. Int# -> State# d -> State# d waitWrite# :: forall d. Int# -> State# d -> State# d - whereFrom# :: forall a d. a -> State# d -> (# State# d, Addr# #) + whereFrom# :: forall a d. a -> Addr# -> State# d -> (# State# d, Int# #) word16ToInt16# :: Word16# -> Int16# word16ToWord# :: Word16# -> Word# word2Double# :: Word# -> Double# diff --git a/testsuite/tests/rts/ipe/ipeEventLog_fromMap.c b/testsuite/tests/rts/ipe/ipeEventLog_fromMap.c index d90b9a1442cb840389d62d55cc0f2c9840bc058f..56702f8bc296d9e5e6234411cacd51841e494c7e 100644 --- a/testsuite/tests/rts/ipe/ipeEventLog_fromMap.c +++ b/testsuite/tests/rts/ipe/ipeEventLog_fromMap.c @@ -19,7 +19,8 @@ int main(int argc, char *argv[]) { registerInfoProvList(list2); // Query an IPE to initialize the underlying hash map. - lookupIPE(list1->tables[0]); + InfoProvEnt ipe; + lookupIPE(list1->tables[0], &ipe); // Trace all IPE events. dumpIPEToEventLog(); diff --git a/testsuite/tests/rts/ipe/ipeMap.c b/testsuite/tests/rts/ipe/ipeMap.c index 69c259796ffafe93fed51e48a5ba6423e6b306c5..6d3ed1cfd2f8a7989ab9889a2dc0b8fe62239160 100644 --- a/testsuite/tests/rts/ipe/ipeMap.c +++ b/testsuite/tests/rts/ipe/ipeMap.c @@ -28,14 +28,19 @@ int main(int argc, char *argv[]) { hs_exit(); } +static InfoProvEnt lookupIPE_(const char *where, const StgInfoTable *itbl) { + InfoProvEnt ent; + if (!lookupIPE(itbl, &ent)) { + barf("%s: Expected to find IPE entry", where); + } + return ent; +} + 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); + InfoProvEnt ent; + if (lookupIPE(get_itbl(fortyTwo), &ent)) { + barf("Found entry in an empty IPE map!"); } } @@ -60,20 +65,15 @@ HaskellObj shouldFindOneIfItHasBeenRegistered(Capability *cap) { registerInfoProvList(node); - InfoProvEnt *result = lookupIPE(get_itbl(fortyTwo)); + InfoProvEnt result = lookupIPE_("shouldFindOneIfItHasBeenRegistered", 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.src_file, "src_file_042"); - assertStringsEqual(result->prov.src_span, "src_span_042"); + 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.src_file, "src_file_042"); + assertStringsEqual(result.prov.src_span, "src_span_042"); return fortyTwo; } @@ -100,22 +100,11 @@ void shouldFindTwoIfTwoHaveBeenRegistered(Capability *cap, registerInfoProvList(node); - InfoProvEnt *resultFortyTwo = - lookupIPE(get_itbl(fortyTwo)); - InfoProvEnt *resultTwentyThree = - lookupIPE(get_itbl(twentyThree)); + InfoProvEnt resultFortyTwo = lookupIPE_("shouldFindTwoIfTwoHaveBeenRegistered", get_itbl(fortyTwo)); + assertStringsEqual(resultFortyTwo.prov.table_name, "table_name_042"); - 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"); + InfoProvEnt resultTwentyThree = lookupIPE_("shouldFindTwoIfTwoHaveBeenRegistered", get_itbl(twentyThree)); + assertStringsEqual(resultTwentyThree.prov.table_name, "table_name_023"); } void shouldFindTwoFromTheSameList(Capability *cap) { @@ -142,20 +131,11 @@ void shouldFindTwoFromTheSameList(Capability *cap) { registerInfoProvList(node); - InfoProvEnt *resultOne = lookupIPE(get_itbl(one)); - InfoProvEnt *resultTwo = lookupIPE(get_itbl(two)); + InfoProvEnt resultOne = lookupIPE_("shouldFindTwoFromTheSameList", get_itbl(one)); + assertStringsEqual(resultOne.prov.table_name, "table_name_001"); - 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"); + InfoProvEnt resultTwo = lookupIPE_("shouldFindTwoFromTheSameList", get_itbl(two)); + assertStringsEqual(resultTwo.prov.table_name, "table_name_002"); } void shouldDealWithAnEmptyList(Capability *cap, HaskellObj fortyTwo) { @@ -166,15 +146,8 @@ void shouldDealWithAnEmptyList(Capability *cap, HaskellObj fortyTwo) { 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"); + InfoProvEnt resultFortyTwo = lookupIPE_("shouldDealWithAnEmptyList", get_itbl(fortyTwo)); + assertStringsEqual(resultFortyTwo.prov.table_name, "table_name_042"); } void assertStringsEqual(const char *s1, const char *s2) {