May 2025 - ghc-commits

[Git][ghc/ghc][wip/T26009] 2 commits: rts: Correctly mark const arguments
by Ben Gamari (＠bgamari) 19 May '25

19 May '25

Ben Gamari pushed to branch wip/T26009 at Glasgow Haskell Compiler / GHC Commits: 320d7dd3 by Ben Gamari at 2025-05-19T18:40:02-04:00 rts: Correctly mark const arguments - - - - - e6b0067b by Ben Gamari at 2025-05-19T18:40:02-04:00 rts/linker/PEi386: Don't repeatedly load DLLs Previously every DLL-imported symbol would result in a call to `LoadLibraryEx`. This ended up constituting over 40% of the runtime of `ghc --interactive -e 42` on Windows. Avoid this by maintaining a hash-set of loaded DLL names, skipping the call if we have already loaded the requested DLL. Addresses #26009. - - - - - 4 changed files: - rts/PathUtils.c - rts/PathUtils.h - rts/linker/PEi386.c - rts/linker/PEi386.h Changes: ===================================== rts/PathUtils.c ===================================== @@ -13,7 +13,7 @@ #include <wchar.h> #endif -pathchar* pathdup(pathchar *path) +pathchar* pathdup(const pathchar *path) { pathchar *ret; #if defined(mingw32_HOST_OS) @@ -26,7 +26,7 @@ pathchar* pathdup(pathchar *path) return ret; } -pathchar* pathdir(pathchar *path) +pathchar* pathdir(const pathchar *path) { pathchar *ret; #if defined(mingw32_HOST_OS) @@ -40,7 +40,8 @@ pathchar* pathdir(pathchar *path) stgFree(drive); stgFree(dirName); #else - pathchar* dirName = dirname(path); + // N.B. cast is safe as we do not modify dirName + const pathchar* dirName = dirname((pathchar *) path); size_t memberLen = pathlen(dirName); ret = stgMallocBytes(pathsize * (memberLen + 2), "pathdir(path)"); strcpy(ret, dirName); @@ -50,7 +51,7 @@ pathchar* pathdir(pathchar *path) return ret; } -pathchar* mkPath(char* path) +pathchar* mkPath(const char* path) { #if defined(mingw32_HOST_OS) size_t required = mbstowcs(NULL, path, 0); @@ -66,7 +67,7 @@ pathchar* mkPath(char* path) #endif } -HsBool endsWithPath(pathchar* base, pathchar* str) { +HsBool endsWithPath(const pathchar* base, const pathchar* str) { int blen = pathlen(base); int slen = pathlen(str); return (blen >= slen) && (0 == pathcmp(base + blen - slen, str)); ===================================== rts/PathUtils.h ===================================== @@ -37,9 +37,9 @@ #include "BeginPrivate.h" -pathchar* pathdup(pathchar *path); -pathchar* pathdir(pathchar *path); -pathchar* mkPath(char* path); -HsBool endsWithPath(pathchar* base, pathchar* str); +pathchar* pathdup(const pathchar *path); +pathchar* pathdir(const pathchar *path); +pathchar* mkPath(const char* path); +HsBool endsWithPath(const pathchar* base, const pathchar* str); #include "EndPrivate.h" ===================================== rts/linker/PEi386.c ===================================== @@ -378,7 +378,7 @@ static size_t makeSymbolExtra_PEi386( #endif static void addDLLHandle( - pathchar* dll_name, + const pathchar* dll_name, HINSTANCE instance); static bool verifyCOFFHeader( @@ -427,8 +427,52 @@ const int default_alignment = 8; the pointer as a redirect. Essentially it's a DATA DLL reference. */ const void* __rts_iob_func = (void*)&__acrt_iob_func; +/* + * Note [Avoiding repeated DLL loading] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * As LoadLibraryEx tends to be expensive and addDLL_PEi386 is called on every + * DLL-imported symbol, we use a hash-map to keep track of which DLLs have + * already been loaded. This hash-map is keyed on the dll_name passed to + * addDLL_PEi386 and is mapped to its HINSTANCE. This serves as a quick check + * to avoid repeated calls to LoadLibraryEx for the identical DLL. See #26009. + */ + +typedef struct { + HashTable *hash; +} LoadedDllCache; + +LoadedDllCache loaded_dll_cache; + +static void initLoadedDllCache(LoadedDllCache *cache) { + cache->hash = allocHashTable(); +} + +static int hash_path(const HashTable *table, StgWord w) +{ + const pathchar *key = (pathchar*) w; + return hashBuffer(table, key, sizeof(pathchar) * wcslen(key)); +} + +static int compare_path(StgWord key1, StgWord key2) +{ + return wcscmp((pathchar*) key1, (pathchar*) key2) == 0; +} + +static void addLoadedDll(LoadedDllCache *cache, const pathchar *dll_name, HINSTANCE instance) +{ + insertHashTable_(cache->hash, (StgWord) dll_name, instance, hash_path); +} + +static HINSTANCE isDllLoaded(const LoadedDllCache *cache, const pathchar *dll_name) +{ + void *result = lookupHashTable_(cache->hash, (StgWord) dll_name, hash_path, compare_path); + return (HINSTANCE) result; +} + void initLinker_PEi386(void) { + initLoadedDllCache(&loaded_dll_cache); + if (!ghciInsertSymbolTable(WSTR("(GHCi/Ld special symbols)"), symhash, "__image_base__", GetModuleHandleW (NULL), HS_BOOL_TRUE, @@ -455,7 +499,7 @@ void exitLinker_PEi386(void) static OpenedDLL* opened_dlls = NULL; /* Adds a DLL instance to the list of DLLs in which to search for symbols. */ -static void addDLLHandle(pathchar* dll_name, HINSTANCE instance) { +static void addDLLHandle(const pathchar* dll_name, HINSTANCE instance) { IF_DEBUG(linker, debugBelch("addDLLHandle(%" PATH_FMT ")...\n", dll_name)); /* At this point, we actually know what was loaded. @@ -797,11 +841,20 @@ uint8_t* getSymShortName ( COFF_HEADER_INFO *info, COFF_symbol* sym ) } const char * -addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) +addDLL_PEi386( const pathchar *dll_name, HINSTANCE *loaded ) { /* ------------------- Win32 DLL loader ------------------- */ IF_DEBUG(linker, debugBelch("addDLL; dll_name = `%" PATH_FMT "'\n", dll_name)); + // See Note [Avoiding repeated DLL loading] + HINSTANCE instance = isDllLoaded(&loaded_dll_cache, dll_name); + if (instance) { + if (loaded) { + *loaded = instance; + } + return NULL; + } + /* The file name has no suffix (yet) so that we can try both foo.dll and foo.drv @@ -820,7 +873,6 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) const DWORD flags[] = { LOAD_LIBRARY_SEARCH_USER_DIRS | LOAD_LIBRARY_SEARCH_DEFAULT_DIRS, 0 }; /* Iterate through the possible flags and formats. */ - HINSTANCE instance; for (int cFlag = 0; cFlag < 2; cFlag++) { for (int cFormat = 0; cFormat < 4; cFormat++) { snwprintf(buf, bufsize, formats[cFormat], dll_name); @@ -839,6 +891,7 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) goto error; loaded: + addLoadedDll(&loaded_dll_cache, dll_name, instance); addDLLHandle(buf, instance); if (loaded) { *loaded = instance; ===================================== rts/linker/PEi386.h ===================================== @@ -45,7 +45,7 @@ typedef struct _COFF_HEADER_INFO { void initLinker_PEi386( void ); void exitLinker_PEi386( void ); -const char * addDLL_PEi386( pathchar *dll_name, HINSTANCE *instance ); +const char * addDLL_PEi386( const pathchar *dll_name, HINSTANCE *instance ); void freePreloadObjectFile_PEi386( ObjectCode *oc ); bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bbc9c637f94b403d62cf23df97d8cf… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bbc9c637f94b403d62cf23df97d8cf… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/improve-implicit-lifting-error] Refactor the treatment of nested Template Haskell splices
by Matthew Pickering (＠mpickering) 19 May '25

19 May '25

Matthew Pickering pushed to branch wip/improve-implicit-lifting-error at Glasgow Haskell Compiler / GHC Commits: cfe33e2b by Matthew Pickering at 2025-05-19T23:24:08+01:00 Refactor the treatment of nested Template Haskell splices * The difference between a normal splice, a quasiquoter and implicit splice caused by lifting is stored in the AST after renaming. * Information that the renamer learns about splices is stored in the relevant splice extension points (XUntypedSpliceExpr, XQuasiQuote). * Normal splices and quasi quotes record the flavour of splice (exp/pat/dec etc) * Implicit lifting stores information about why the lift was attempted, so if it fails, that can be reported to the user. * After renaming, the decision taken to attempt to implicitly lift a variable is stored in the `XXUntypedSplice` extension field in the `HsImplicitLiftSplice` constructor. * Since all the information is stored in the AST, in `HsUntypedSplice`, the type of `PendingRnSplice` now just stores a `HsUntypedSplice`. * Error messages since the original program can be easily printed, this is noticeable in the case of implicit lifting. * The user-written syntax is directly type-checked. Before, some desugaring took place in the * Fixes .hie files to work better with nested splices (nested splices are not indexed) * The location of the quoter in a quasiquote is now located, so error messages will precisely point to it (and again, it is indexed by hie files) In the future, the typechecked AST should also retain information about the splices and the specific desugaring being left to the desugarer. Also, `runRnSplice` should call `tcUntypedSplice`, otherwise the typechecking logic is duplicated (see the `QQError` and `QQTopError` tests for a difference caused by this). - - - - - 47 changed files: - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Expr.hs-boot - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Gen/Splice.hs-boot - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/TH.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Extension.hs - testsuite/tests/linear/should_fail/LinearTHFail.stderr - testsuite/tests/linters/notes.stdout - testsuite/tests/perf/compiler/hard_hole_fits.stderr - testsuite/tests/quasiquotation/T3953.stderr - testsuite/tests/quotes/LiftErrMsg.stderr - testsuite/tests/quotes/LiftErrMsgDefer.stderr - + testsuite/tests/quotes/LiftErrMsgTyped.hs - + testsuite/tests/quotes/LiftErrMsgTyped.stderr - + testsuite/tests/quotes/QQError.hs - + testsuite/tests/quotes/QQError.stderr - testsuite/tests/quotes/T10384.stderr - testsuite/tests/quotes/TH_localname.stderr - testsuite/tests/quotes/all.T - + testsuite/tests/th/QQInQuote.hs - + testsuite/tests/th/QQTopError.hs - + testsuite/tests/th/QQTopError.stderr - testsuite/tests/th/T10598_TH.stderr - testsuite/tests/th/T14681.stderr - testsuite/tests/th/T17804.stderr - testsuite/tests/th/T5508.stderr - testsuite/tests/th/TH_Lift.stderr - testsuite/tests/th/all.T - testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.stderr - utils/check-exact/ExactPrint.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cfe33e2b9a2e54653a9b6f96275e69a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cfe33e2b9a2e54653a9b6f96275e69a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Allow the 'data' keyword in import/export lists (#25899)
by Marge Bot (＠marge-bot) 19 May '25

19 May '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 77067c5c by Vladislav Zavialov at 2025-05-19T17:44:36-04:00 Allow the 'data' keyword in import/export lists (#25899) This patch introduces the 'data' namespace specifier in import and export lists. The intended use is to import data constructors without their parent type constructors, e.g. import Data.Proxy as D (data Proxy) type DP = D.Proxy -- promoted data constructor Additionally, it is possible to use 'data' to explicitly qualify any data constructors or terms, incl. operators and field selectors import Prelude (Semigroup(data (<>))) import Data.Function (data (&)) import Data.Monoid (data Dual, data getDual) x = Dual "Hello" <> Dual "World" & getDual The implementation mostly builds on top of the existing logic for the 'type' and 'pattern' namespace specifiers, plus there are a few tweaks to how we generate suggestions in error messages. - - - - - dae0ac85 by Ben Gamari at 2025-05-19T17:44:36-04:00 compiler: Use field selectors when creating BCOs This makes it easier to grep for these fields. - - - - - 487bc05e by Ben Gamari at 2025-05-19T17:44:36-04:00 compiler: Clarify BCO size Previously the semantics and size of StgBCO was a bit unclear. Specifically, the `size` field was documented to contain the size of the bitmap whereas it was actually the size of the closure *and* bitmap. Additionally, it was not as clear as it could be that the bitmap was a full StgLargeBitmap with its own `size` field. - - - - - 43 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - docs/users_guide/9.14.1-notes.rst - docs/users_guide/exts/explicit_namespaces.rst - docs/users_guide/exts/pattern_synonyms.rst - rts/PrimOps.cmm - rts/include/rts/storage/Closures.h - testsuite/tests/module/T21826.stderr - testsuite/tests/rename/should_compile/T22581d.stdout - + testsuite/tests/rename/should_compile/T25899a.hs - + testsuite/tests/rename/should_compile/T25899b.hs - + testsuite/tests/rename/should_compile/T25899c.hs - + testsuite/tests/rename/should_compile/T25899c_helper.hs - + testsuite/tests/rename/should_compile/T25899d.script - + testsuite/tests/rename/should_compile/T25899d.stdout - testsuite/tests/rename/should_compile/all.T - testsuite/tests/rename/should_fail/T22581a.stderr - testsuite/tests/rename/should_fail/T22581b.stderr - + testsuite/tests/rename/should_fail/T25899e1.hs - + testsuite/tests/rename/should_fail/T25899e1.stderr - + testsuite/tests/rename/should_fail/T25899e2.hs - + testsuite/tests/rename/should_fail/T25899e2.stderr - + testsuite/tests/rename/should_fail/T25899e3.hs - + testsuite/tests/rename/should_fail/T25899e3.stderr - + testsuite/tests/rename/should_fail/T25899e_helper.hs - + testsuite/tests/rename/should_fail/T25899f.hs - + testsuite/tests/rename/should_fail/T25899f.stderr - + testsuite/tests/rename/should_fail/T25899f_helper.hs - testsuite/tests/rename/should_fail/all.T - utils/check-exact/ExactPrint.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/777ff2e944ba70026b09146d8fd5f5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/777ff2e944ba70026b09146d8fd5f5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26009] 3 commits: rts/linker/PEi386: Fix incorrect use of break in nested for
by Ben Gamari (＠bgamari) 19 May '25

19 May '25

Ben Gamari pushed to branch wip/T26009 at Glasgow Haskell Compiler / GHC Commits: 6fbb05cf by Ben Gamari at 2025-05-19T17:10:35-04:00 rts/linker/PEi386: Fix incorrect use of break in nested for Previously the happy path of PEi386 used `break` in a double-`for` loop resulting in redundant calls to `LoadLibraryEx`. Fixes #26052. - - - - - d7c918eb by Ben Gamari at 2025-05-19T17:11:00-04:00 rts: Mark const arguments - - - - - bbc9c637 by Ben Gamari at 2025-05-19T17:11:26-04:00 rts/linker/PEi386: Don't repeatedly load DLLs Previously every DLL-imported symbol would result in a call to `LoadLibraryEx`. This ended up constituting over 40% of the runtime of `ghc --interactive -e 42` on Windows. Avoid this by maintaining a hash-set of loaded DLL names, skipping the call if we have already loaded the requested DLL. Addresses #26009. - - - - - 4 changed files: - rts/PathUtils.c - rts/PathUtils.h - rts/linker/PEi386.c - rts/linker/PEi386.h Changes: ===================================== rts/PathUtils.c ===================================== @@ -13,7 +13,7 @@ #include <wchar.h> #endif -pathchar* pathdup(pathchar *path) +pathchar* pathdup(const pathchar *path) { pathchar *ret; #if defined(mingw32_HOST_OS) @@ -26,7 +26,7 @@ pathchar* pathdup(pathchar *path) return ret; } -pathchar* pathdir(pathchar *path) +pathchar* pathdir(const pathchar *path) { pathchar *ret; #if defined(mingw32_HOST_OS) @@ -50,7 +50,7 @@ pathchar* pathdir(pathchar *path) return ret; } -pathchar* mkPath(char* path) +pathchar* mkPath(const char* path) { #if defined(mingw32_HOST_OS) size_t required = mbstowcs(NULL, path, 0); @@ -66,7 +66,7 @@ pathchar* mkPath(char* path) #endif } -HsBool endsWithPath(pathchar* base, pathchar* str) { +HsBool endsWithPath(const pathchar* base, const pathchar* str) { int blen = pathlen(base); int slen = pathlen(str); return (blen >= slen) && (0 == pathcmp(base + blen - slen, str)); ===================================== rts/PathUtils.h ===================================== @@ -37,9 +37,9 @@ #include "BeginPrivate.h" -pathchar* pathdup(pathchar *path); -pathchar* pathdir(pathchar *path); -pathchar* mkPath(char* path); -HsBool endsWithPath(pathchar* base, pathchar* str); +pathchar* pathdup(const pathchar *path); +pathchar* pathdir(const pathchar *path); +pathchar* mkPath(const char* path); +HsBool endsWithPath(const pathchar* base, const pathchar* str); #include "EndPrivate.h" ===================================== rts/linker/PEi386.c ===================================== @@ -378,7 +378,7 @@ static size_t makeSymbolExtra_PEi386( #endif static void addDLLHandle( - pathchar* dll_name, + const pathchar* dll_name, HINSTANCE instance); static bool verifyCOFFHeader( @@ -427,8 +427,52 @@ const int default_alignment = 8; the pointer as a redirect. Essentially it's a DATA DLL reference. */ const void* __rts_iob_func = (void*)&__acrt_iob_func; +/* + * Note [Avoiding repeated DLL loading] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * As LoadLibraryEx tends to be expensive and addDLL_PEi386 is called on every + * DLL-imported symbol, we use a hash-map to keep track of which DLLs have + * already been loaded. This hash-map is keyed on the dll_name passed to + * addDLL_PEi386 and is mapped to its HINSTANCE. This serves as a quick check + * to avoid repeated calls to LoadLibraryEx for the identical DLL. See #26009. + */ + +typedef struct { + HashTable *hash; +} LoadedDllCache; + +LoadedDllCache loaded_dll_cache; + +static void initLoadedDllCache(LoadedDllCache *cache) { + cache->hash = allocHashTable(); +} + +static int hash_path(const HashTable *table, StgWord w) +{ + const pathchar *key = (pathchar*) w; + return hashBuffer(table, key, sizeof(pathchar) * wcslen(key)); +} + +static int compare_path(StgWord key1, StgWord key2) +{ + return wcscmp((pathchar*) key1, (pathchar*) key2) == 0; +} + +static void addLoadedDll(LoadedDllCache *cache, const pathchar *dll_name, HINSTANCE instance) +{ + insertHashTable_(cache->hash, (StgWord) dll_name, instance, hash_path); +} + +static HINSTANCE isDllLoaded(const LoadedDllCache *cache, const pathchar *dll_name) +{ + void *result = lookupHashTable_(cache->hash, (StgWord) dll_name, hash_path, compare_path); + return (HINSTANCE) result; +} + void initLinker_PEi386(void) { + initLoadedDllCache(&loaded_dll_cache); + if (!ghciInsertSymbolTable(WSTR("(GHCi/Ld special symbols)"), symhash, "__image_base__", GetModuleHandleW (NULL), HS_BOOL_TRUE, @@ -455,7 +499,7 @@ void exitLinker_PEi386(void) static OpenedDLL* opened_dlls = NULL; /* Adds a DLL instance to the list of DLLs in which to search for symbols. */ -static void addDLLHandle(pathchar* dll_name, HINSTANCE instance) { +static void addDLLHandle(const pathchar* dll_name, HINSTANCE instance) { IF_DEBUG(linker, debugBelch("addDLLHandle(%" PATH_FMT ")...\n", dll_name)); /* At this point, we actually know what was loaded. @@ -797,11 +841,20 @@ uint8_t* getSymShortName ( COFF_HEADER_INFO *info, COFF_symbol* sym ) } const char * -addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) +addDLL_PEi386( const pathchar *dll_name, HINSTANCE *loaded ) { /* ------------------- Win32 DLL loader ------------------- */ IF_DEBUG(linker, debugBelch("addDLL; dll_name = `%" PATH_FMT "'\n", dll_name)); + // See Note [Avoiding repeated DLL loading] + HINSTANCE instance = isDllLoaded(&loaded_dll_cache, dll_name); + if (instance) { + if (loaded) { + *loaded = instance; + } + return NULL; + } + /* The file name has no suffix (yet) so that we can try both foo.dll and foo.drv @@ -820,7 +873,6 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) const DWORD flags[] = { LOAD_LIBRARY_SEARCH_USER_DIRS | LOAD_LIBRARY_SEARCH_DEFAULT_DIRS, 0 }; /* Iterate through the possible flags and formats. */ - HINSTANCE instance; for (int cFlag = 0; cFlag < 2; cFlag++) { for (int cFormat = 0; cFormat < 4; cFormat++) { snwprintf(buf, bufsize, formats[cFormat], dll_name); @@ -830,16 +882,16 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) goto error; } } else { - break; /* We're done. DLL has been loaded. */ + goto loaded; /* We're done. DLL has been loaded. */ } } } - /* Check if we managed to load the DLL. */ - if (instance == NULL) { - goto error; - } + // We failed to load + goto error; +loaded: + addLoadedDll(&loaded_dll_cache, dll_name, instance); addDLLHandle(buf, instance); if (loaded) { *loaded = instance; ===================================== rts/linker/PEi386.h ===================================== @@ -45,7 +45,7 @@ typedef struct _COFF_HEADER_INFO { void initLinker_PEi386( void ); void exitLinker_PEi386( void ); -const char * addDLL_PEi386( pathchar *dll_name, HINSTANCE *instance ); +const char * addDLL_PEi386( const pathchar *dll_name, HINSTANCE *instance ); void freePreloadObjectFile_PEi386( ObjectCode *oc ); bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a1cf6ffb6d6d6e60a5a6034fb0ad4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a1cf6ffb6d6d6e60a5a6034fb0ad4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T25974] Localize `$toolchain`, change `$PATH` only when `TOOLCHAIN_SOURCE=extracted`
by Serge S. Gulin (＠gulin.serge) 19 May '25

19 May '25

Serge S. Gulin pushed to branch wip/T25974 at Glasgow Haskell Compiler / GHC Commits: 44634f11 by Serge S. Gulin at 2025-05-20T00:07:19+03:00 Localize `$toolchain`, change `$PATH` only when `TOOLCHAIN_SOURCE=extracted` - - - - - 1 changed file: - .gitlab/ci.sh Changes: ===================================== .gitlab/ci.sh ===================================== @@ -22,16 +22,16 @@ CABAL_CACHE="$TOP/${CABAL_CACHE:-cabal-cache}" source "$TOP/.gitlab/common.sh" function time_it() { - local name="$1" + local -r name="$1" shift - local start=$(date +%s) + local -r start=$(date +%s) local res=0 set +e ( set -e ; $@ ) res=$? set -e - local end=$(date +%s) - local delta=$(expr $end - $start) + local -r end=$(date +%s) + local -r delta=$((end - start)) echo "$name took $delta seconds" printf "%15s | $delta" > ci-timings @@ -83,7 +83,8 @@ Environment variables affecting both build systems: - "extracted": Toolchains will be downloaded and extracted through the CI process. Default for other systems. Windows and FreeBSD - are included. + are included. PATH variable will be extended with a location + to which toolchains will be installed. Environment variables determining build configuration of Hadrian system: @@ -176,11 +177,6 @@ function mingw_init() { esac } -# This will contain GHC's local native toolchain -toolchain="$TOP/toolchain" -mkdir -p "$toolchain/bin" -PATH="$toolchain/bin:$PATH" - export METRICS_FILE="$TOP/performance-metrics.tsv" cores="$(mk/detect-cpu-count.sh)" @@ -198,6 +194,8 @@ function show_tool() { } function set_toolchain_paths() { + local -r toolchain_path="$1" + if [ -z "${TOOLCHAIN_SOURCE:-}" ] then # Fallback to automatic detection which could not work for cases @@ -214,11 +212,14 @@ function set_toolchain_paths() { case "$TOOLCHAIN_SOURCE" in extracted) + mkdir -p "$toolchain_path/bin" + PATH="$toolchain_path/bin:$PATH" + # These are populated by setup_toolchain - GHC="$toolchain/bin/ghc$exe" - CABAL="$toolchain/bin/cabal$exe" - HAPPY="$toolchain/bin/happy$exe" - ALEX="$toolchain/bin/alex$exe" + GHC="$toolchain_path/bin/ghc$exe" + CABAL="$toolchain_path/bin/cabal$exe" + HAPPY="$toolchain_path/bin/happy$exe" + ALEX="$toolchain_path/bin/alex$exe" if [ "$(uname)" = "FreeBSD" ]; then GHC=/usr/local/bin/ghc fi @@ -265,6 +266,8 @@ function cabal_update() { # Extract GHC toolchain function setup() { + local -r toolchain_path="$1" + echo "=== TIMINGS ===" > ci-timings if [ -d "$CABAL_CACHE" ]; then @@ -274,7 +277,7 @@ function setup() { fi case $TOOLCHAIN_SOURCE in - extracted) time_it "setup" setup_toolchain ;; + extracted) time_it "setup" setup_toolchain "${toolchain_path}" ;; *) ;; esac @@ -299,6 +302,8 @@ function setup() { } function fetch_ghc() { + local -r toolchain_path="$1" + local boot_triple_to_fetch case "$(uname)" in MSYS_*|MINGW*) @@ -324,31 +329,33 @@ function fetch_ghc() { readonly boot_triple_to_fetch local -r v="$GHC_VERSION" - if [[ -z "$v" ]]; then - fail "neither GHC nor GHC_VERSION are not set" - fi + if [[ -z "$v" ]]; then + fail "neither GHC nor GHC_VERSION are not set" + fi - start_section "fetch GHC" - url="https://downloads.haskell.org/~ghc/${GHC_VERSION}/ghc-${GHC_VERSION}-${boot…" - info "Fetching GHC binary distribution from $url..." - curl "$url" > ghc.tar.xz || fail "failed to fetch GHC binary distribution" - $TAR -xJf ghc.tar.xz || fail "failed to extract GHC binary distribution" - case "$(uname)" in - MSYS_*|MINGW*) - cp -r ghc-${GHC_VERSION}*/* "$toolchain" - ;; - *) - pushd ghc-${GHC_VERSION}* - ./configure --prefix="$toolchain" - "$MAKE" install - popd - ;; - esac - rm -Rf "ghc-${GHC_VERSION}" ghc.tar.xz - end_section "fetch GHC" + start_section "fetch GHC" + local -r url="https://downloads.haskell.org/~ghc/${GHC_VERSION}/ghc-${GHC_VERSION}-${boot…" + info "Fetching GHC binary distribution from $url..." + curl "$url" > ghc.tar.xz || fail "failed to fetch GHC binary distribution" + $TAR -xJf ghc.tar.xz || fail "failed to extract GHC binary distribution" + case "$(uname)" in + MSYS_*|MINGW*) + cp -r ghc-${GHC_VERSION}*/* "$toolchain_path" + ;; + *) + pushd ghc-${GHC_VERSION}* + ./configure --prefix="$toolchain_path" + "$MAKE" install + popd + ;; + esac + rm -Rf "ghc-${GHC_VERSION}" ghc.tar.xz + end_section "fetch GHC" } function fetch_cabal() { + local -r toolchain_path="$1" + local v="$CABAL_INSTALL_VERSION" if [[ -z "$v" ]]; then fail "neither CABAL nor CABAL_INSTALL_VERSION are not set" @@ -381,9 +388,9 @@ function fetch_cabal() { $TAR -xJf cabal.tar.xz # Check if the bindist has directory structure if [[ "$tmp" = "cabal" ]]; then - mv cabal "$toolchain/bin" + mv cabal "${toolchain_path}/bin" else - mv "$tmp/cabal" "$toolchain/bin" + mv "$tmp/cabal" "${toolchain_path}/bin" fi ;; esac @@ -394,12 +401,14 @@ function fetch_cabal() { # here. For Docker platforms this is done in the Docker image # build. function setup_toolchain() { + local -r toolchain_path="$1" + if [ ! -e "$GHC" ]; then - fetch_ghc + fetch_ghc "${toolchain_path}" fi if [ ! -e "$CABAL" ]; then - fetch_cabal + fetch_cabal "${toolchain_path}" fi cabal_update @@ -407,7 +416,7 @@ function setup_toolchain() { local cabal_install="$CABAL v2-install \ --with-compiler=$GHC \ --index-state=$HACKAGE_INDEX_STATE \ - --installdir=$toolchain/bin \ + --installdir=${toolchain_path}/bin \ --ignore-project \ --overwrite-policy=always" @@ -1081,11 +1090,13 @@ if [[ -z ${BIGNUM_BACKEND:-} ]]; then BIGNUM_BACKEND=gmp; fi determine_metric_baseline -set_toolchain_paths +# This will contain GHC's local native toolchain when TOOLCHAIN_SOURCE=extracted +toolchain="$TOP/toolchain" +set_toolchain_paths "${toolchain}" case ${1:-help} in help|usage) usage ;; - setup) setup && cleanup_submodules ;; + setup) setup "${toolchain}" && cleanup_submodules ;; configure) time_it "configure" configure ;; build_hadrian) time_it "build" build_hadrian ;; # N.B. Always push notes, even if the build fails. This is okay to do as the View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44634f113a58771500430c7f5d51fb4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44634f113a58771500430c7f5d51fb4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26009] fixup! rts/linker/PEi386: Mark const arguments
by Ben Gamari (＠bgamari) 19 May '25

19 May '25

Ben Gamari pushed to branch wip/T26009 at Glasgow Haskell Compiler / GHC Commits: 6a1cf6ff by Ben Gamari at 2025-05-19T16:49:06-04:00 fixup! rts/linker/PEi386: Mark const arguments - - - - - 2 changed files: - rts/PathUtils.c - rts/PathUtils.h Changes: ===================================== rts/PathUtils.c ===================================== @@ -13,7 +13,7 @@ #include <wchar.h> #endif -pathchar* pathdup(pathchar *path) +pathchar* pathdup(const pathchar *path) { pathchar *ret; #if defined(mingw32_HOST_OS) @@ -26,7 +26,7 @@ pathchar* pathdup(pathchar *path) return ret; } -pathchar* pathdir(pathchar *path) +pathchar* pathdir(const pathchar *path) { pathchar *ret; #if defined(mingw32_HOST_OS) @@ -50,7 +50,7 @@ pathchar* pathdir(pathchar *path) return ret; } -pathchar* mkPath(char* path) +pathchar* mkPath(const char* path) { #if defined(mingw32_HOST_OS) size_t required = mbstowcs(NULL, path, 0); @@ -66,7 +66,7 @@ pathchar* mkPath(char* path) #endif } -HsBool endsWithPath(pathchar* base, pathchar* str) { +HsBool endsWithPath(const pathchar* base, const pathchar* str) { int blen = pathlen(base); int slen = pathlen(str); return (blen >= slen) && (0 == pathcmp(base + blen - slen, str)); ===================================== rts/PathUtils.h ===================================== @@ -37,9 +37,9 @@ #include "BeginPrivate.h" -pathchar* pathdup(pathchar *path); -pathchar* pathdir(pathchar *path); -pathchar* mkPath(char* path); -HsBool endsWithPath(pathchar* base, pathchar* str); +p*athchar* pathdup(const pathchar *path); +pathchar* pathdir(const pathchar *path); +pathchar* mkPath(const char* path); +HsBool endsWithPath(const pathchar* base, const pathchar* str); #include "EndPrivate.h" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a1cf6ffb6d6d6e60a5a6034fb0ad4e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a1cf6ffb6d6d6e60a5a6034fb0ad4e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26009] 3 commits: rts/linker/PEi386: Don't double-load DLLs
by Ben Gamari (＠bgamari) 19 May '25

19 May '25

Ben Gamari pushed to branch wip/T26009 at Glasgow Haskell Compiler / GHC Commits: 79a58ed3 by Ben Gamari at 2025-05-19T16:31:37-04:00 rts/linker/PEi386: Don't double-load DLLs Previously the happy path of PEi386 used `break` in a double-`for` loop resulting in redundant calls to `LoadLibraryEx`. Fixes #26052. - - - - - 7c9d6e7d by Ben Gamari at 2025-05-19T16:46:22-04:00 rts/linker/PEi386: Mark const arguments - - - - - ecd20c03 by Ben Gamari at 2025-05-19T16:46:26-04:00 rts/linker/PEi386: Don't repeatedly load DLLs Previously every DLL-imported symbol would result in a call to `LoadLibraryEx`. This ended up constituting over 40% of the runtime of `ghc --interactive -e 42` on Windows. Avoid this by maintaining a hash-set of loaded DLL names, skipping the call if we have already loaded the requested DLL. Addresses #26009. - - - - - 2 changed files: - rts/linker/PEi386.c - rts/linker/PEi386.h Changes: ===================================== rts/linker/PEi386.c ===================================== @@ -378,7 +378,7 @@ static size_t makeSymbolExtra_PEi386( #endif static void addDLLHandle( - pathchar* dll_name, + const pathchar* dll_name, HINSTANCE instance); static bool verifyCOFFHeader( @@ -427,8 +427,52 @@ const int default_alignment = 8; the pointer as a redirect. Essentially it's a DATA DLL reference. */ const void* __rts_iob_func = (void*)&__acrt_iob_func; +/* + * Note [Avoiding repeated DLL loading] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * As LoadLibraryEx tends to be expensive and addDLL_PEi386 is called on every + * DLL-imported symbol, we use a hash-map to keep track of which DLLs have + * already been loaded. This hash-map is keyed on the dll_name passed to + * addDLL_PEi386 and is mapped to its HINSTANCE. This serves as a quick check + * to avoid repeated calls to LoadLibraryEx for the identical DLL. See #26009. + */ + +typedef struct { + HashTable *hash; +} LoadedDllCache; + +LoadedDllCache loaded_dll_cache; + +static void initLoadedDllCache(LoadedDllCache *cache) { + cache->hash = allocHashTable(); +} + +static int hash_path(const HashTable *table, StgWord w) +{ + const pathchar *key = (pathchar*) w; + return hashBuffer(table, key, sizeof(pathchar) * wcslen(key)); +} + +static int compare_path(StgWord key1, StgWord key2) +{ + return wcscmp((pathchar*) key1, (pathchar*) key2); +} + +static void addLoadedDll(LoadedDllCache *cache, const pathchar *dll_name, HINSTANCE instance) +{ + insertHashTable_(cache->hash, (StgWord) dll_name, instance, hash_path); +} + +static HINSTANCE isDllLoaded(const LoadedDllCache *cache, const pathchar *dll_name) +{ + void *result = lookupHashTable_(cache->hash, (StgWord) dll_name, hash_path, compare_path); + return (HINSTANCE) result; +} + void initLinker_PEi386(void) { + initLoadedDllCache(&loaded_dll_cache); + if (!ghciInsertSymbolTable(WSTR("(GHCi/Ld special symbols)"), symhash, "__image_base__", GetModuleHandleW (NULL), HS_BOOL_TRUE, @@ -455,7 +499,7 @@ void exitLinker_PEi386(void) static OpenedDLL* opened_dlls = NULL; /* Adds a DLL instance to the list of DLLs in which to search for symbols. */ -static void addDLLHandle(pathchar* dll_name, HINSTANCE instance) { +static void addDLLHandle(const pathchar* dll_name, HINSTANCE instance) { IF_DEBUG(linker, debugBelch("addDLLHandle(%" PATH_FMT ")...\n", dll_name)); /* At this point, we actually know what was loaded. @@ -797,11 +841,18 @@ uint8_t* getSymShortName ( COFF_HEADER_INFO *info, COFF_symbol* sym ) } const char * -addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) +addDLL_PEi386( const pathchar *dll_name, HINSTANCE *loaded ) { /* ------------------- Win32 DLL loader ------------------- */ IF_DEBUG(linker, debugBelch("addDLL; dll_name = `%" PATH_FMT "'\n", dll_name)); + // See Note [Avoiding repeated DLL loading] + HINSTANCE instance = isDllLoaded(&loaded_dll_cache, dll_name); + if (instance) { + *loaded = instance; + return NULL; + } + /* The file name has no suffix (yet) so that we can try both foo.dll and foo.drv @@ -820,7 +871,6 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) const DWORD flags[] = { LOAD_LIBRARY_SEARCH_USER_DIRS | LOAD_LIBRARY_SEARCH_DEFAULT_DIRS, 0 }; /* Iterate through the possible flags and formats. */ - HINSTANCE instance; for (int cFlag = 0; cFlag < 2; cFlag++) { for (int cFormat = 0; cFormat < 4; cFormat++) { snwprintf(buf, bufsize, formats[cFormat], dll_name); @@ -830,16 +880,18 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) goto error; } } else { - break; /* We're done. DLL has been loaded. */ + goto loaded; /* We're done. DLL has been loaded. */ } } } +loaded: /* Check if we managed to load the DLL. */ if (instance == NULL) { goto error; } + addLoadedDll(&loaded_dll_cache, dll_name, instance); addDLLHandle(buf, instance); if (loaded) { *loaded = instance; ===================================== rts/linker/PEi386.h ===================================== @@ -45,7 +45,7 @@ typedef struct _COFF_HEADER_INFO { void initLinker_PEi386( void ); void exitLinker_PEi386( void ); -const char * addDLL_PEi386( pathchar *dll_name, HINSTANCE *instance ); +const char * addDLL_PEi386( const pathchar *dll_name, HINSTANCE *instance ); void freePreloadObjectFile_PEi386( ObjectCode *oc ); bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/43e32a72c6308057d4f0511b339569… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/43e32a72c6308057d4f0511b339569… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26009] rts/linker/PEi386: Don't repeated load DLLs
by Ben Gamari (＠bgamari) 19 May '25

19 May '25

Ben Gamari pushed to branch wip/T26009 at Glasgow Haskell Compiler / GHC Commits: 43e32a72 by Ben Gamari at 2025-05-19T16:05:09-04:00 rts/linker/PEi386: Don't repeated load DLLs Previously every DLL-imported symbol would result in a call to `LoadLibraryEx`. This ended up constituting over 40% of the runtime of `ghc --interactive -e 42` on Windows. Avoid this by maintaining a hash-set of loaded DLL names, skipping the call if we have already loaded the requested DLL. Addresses #26009. - - - - - 1 changed file: - rts/linker/PEi386.c Changes: ===================================== rts/linker/PEi386.c ===================================== @@ -427,8 +427,52 @@ const int default_alignment = 8; the pointer as a redirect. Essentially it's a DATA DLL reference. */ const void* __rts_iob_func = (void*)&__acrt_iob_func; +/* + * Note [Avoiding repeated DLL loading] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * As LoadLibraryEx tends to be expensive and addDLL_PEi386 is called on every + * DLL-imported symbol, we use a hash-set to keep track of which DLLs have + * already been loaded. This hash-set is keyed on the dll_name passed to + * addDLL_PEi386 and serves as a quick check to avoid repeated calls to + * LoadLibraryEx for the identical DLL. See #26009. + */ + +typedef struct { + HashTable *hash; +} LoadedDllSet; + +LoadedDllSet loaded_dll_set; + +static void initLoadedDllSet(LoadedDllSet *set) { + set->hash = allocHashTable(); +} + +static int hash_path(const HashTable *table, StgWord w) +{ + const pathchar *key = (pathchar*) w; + return hashBuffer(table, key, sizeof(pathchar) * wcslen(key)); +} + +static int compare_path(StgWord key1, StgWord key2) +{ + return wcscmp((pathchar*) key1, (pathchar*) key2); +} + +static void addLoadedDll(LoadedDllSet *set, pathchar *dll_name) +{ + insertHashTable_(set->hash, (StgWord) dll_name, (void*) 1, hash_path); +} + +static bool isDllLoaded(LoadedDllSet *set, pathchar *dll_name) +{ + void * result = lookupHashTable_(set->hash, (StgWord) dll_name, hash_path, compare_path); + return result != NULL; +} + void initLinker_PEi386(void) { + initLoadedDllSet(&loaded_dll_set); + if (!ghciInsertSymbolTable(WSTR("(GHCi/Ld special symbols)"), symhash, "__image_base__", GetModuleHandleW (NULL), HS_BOOL_TRUE, @@ -802,6 +846,10 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) /* ------------------- Win32 DLL loader ------------------- */ IF_DEBUG(linker, debugBelch("addDLL; dll_name = `%" PATH_FMT "'\n", dll_name)); + if (isDllLoaded(&loaded_dll_set, dll_name)) { + return NULL; + } + /* The file name has no suffix (yet) so that we can try both foo.dll and foo.drv @@ -840,6 +888,7 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) goto error; } + addLoadedDll(&loaded_dll_set, dll_name); addDLLHandle(buf, instance); if (loaded) { *loaded = instance; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/43e32a72c6308057d4f0511b3395694… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/43e32a72c6308057d4f0511b3395694… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26009] 2 commits: rts/Hash: Factor out hashBuffer
by Ben Gamari (＠bgamari) 19 May '25

19 May '25

Ben Gamari pushed to branch wip/T26009 at Glasgow Haskell Compiler / GHC Commits: 827961b9 by Ben Gamari at 2025-05-19T16:01:12-04:00 rts/Hash: Factor out hashBuffer This is a useful helper which can be used for non-strings as well. - - - - - deadc2ef by Ben Gamari at 2025-05-19T16:01:24-04:00 rts/linker/PEi386: Don't repeated load DLLs Previously every DLL-imported symbol would result in a call to `LoadLibraryEx`. This ended up constituting over 40% of the runtime of `ghc --interactive -e 42` on Windows. Avoid this by maintaining a hash-set of loaded DLL names, skipping the call if we have already loaded the requested DLL. Addresses #26009. - - - - - 3 changed files: - rts/Hash.c - rts/Hash.h - rts/linker/PEi386.c Changes: ===================================== rts/Hash.c ===================================== @@ -94,13 +94,13 @@ hashWord(const HashTable *table, StgWord key) } int -hashStr(const HashTable *table, StgWord w) +hashBuffer(const HashTable *table, const void *buf, size_t len) { - const char *key = (char*) w; + const char *key = (char*) buf; #if WORD_SIZE_IN_BITS == 64 - StgWord h = XXH3_64bits_withSeed (key, strlen(key), 1048583); + StgWord h = XXH3_64bits_withSeed (key, len, 1048583); #else - StgWord h = XXH32 (key, strlen(key), 1048583); + StgWord h = XXH32 (key, len, 1048583); #endif /* Mod the size of the hash table (a power of 2) */ @@ -114,6 +114,13 @@ hashStr(const HashTable *table, StgWord w) return bucket; } +int +hashStr(const HashTable *table, StgWord w) +{ + const char *key = (char*) w; + return hashBuffer(table, key, strlen(key)); +} + STATIC_INLINE int compareWord(StgWord key1, StgWord key2) { ===================================== rts/Hash.h ===================================== @@ -69,6 +69,10 @@ void * removeStrHashTable ( StrHashTable *table, const char * key, */ typedef int HashFunction(const HashTable *table, StgWord key); typedef int CompareFunction(StgWord key1, StgWord key2); + +// Helper for implementing hash functions +int hashBuffer(const HashTable *table, const void *buf, size_t len); + int hashWord(const HashTable *table, StgWord key); int hashStr(const HashTable *table, StgWord w); void insertHashTable_ ( HashTable *table, StgWord key, @@ -79,6 +83,7 @@ void * removeHashTable_ ( HashTable *table, StgWord key, const void *data, HashFunction f, CompareFunction cmp ); + /* Freeing hash tables */ void freeHashTable ( HashTable *table, void (*freeDataFun)(void *) ); ===================================== rts/linker/PEi386.c ===================================== @@ -427,8 +427,53 @@ const int default_alignment = 8; the pointer as a redirect. Essentially it's a DATA DLL reference. */ const void* __rts_iob_func = (void*)&__acrt_iob_func; +/* + * Note [Avoiding repeated DLL loading] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * As LoadLibraryEx tends to be expensive and addDLL_PEi386 is called on every + * DLL-imported symbol, we use a hash-set to keep track of which DLLs have + * already been loaded. This hash-set is keyed on the dll_name passed to + * addDLL_PEi386 and serves as a quick check to avoid repeated calls to + * LoadLibraryEx for the identical DLL. See #26009. + */ + +typedef struct { + HashTable *hash; +} LoadedDllSet; + +LoadedDllSet loaded_dll_set; + +void initLoadedDllSet(LoadedDllSet *set) { + set->hash = allocHashTable(); +} + +int hash_path(const HashTable *table, StgWord w) +{ + const pathchar *key = (pathchar*) w; + return hashBuffer(table, key, sizeof(pathchar) * wcslen(key)); +} + +int compare_path(StgWord key1, StgWord key2) +{ + return wscmp((pathchar*) key1, (pathchar*) key2); +} + +void addLoadedDll(LoadedDllSet *set, pathchar *dll_name) +{ + insertHashTable_(set->hash, (StgWord) dll_name, (void*) 1, hash_path); +} + +bool isDllLoaded(LoadedDllSet *set, pathchar *dll_name) +{ + void * result = lookupHashTable_(set->hash, (StgWord) dll_name, hash_path, compare_path); + return result != NULL; +} + + void initLinker_PEi386(void) { + initLoadedDllSet(&loaded_dll_set); + if (!ghciInsertSymbolTable(WSTR("(GHCi/Ld special symbols)"), symhash, "__image_base__", GetModuleHandleW (NULL), HS_BOOL_TRUE, @@ -802,6 +847,10 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) /* ------------------- Win32 DLL loader ------------------- */ IF_DEBUG(linker, debugBelch("addDLL; dll_name = `%" PATH_FMT "'\n", dll_name)); + if (isDllLoaded(&loaded_dll_set, dll_name)) { + return NULL; + } + /* The file name has no suffix (yet) so that we can try both foo.dll and foo.drv @@ -840,6 +889,7 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) goto error; } + addLoadedDll(&loaded_dll_set, dll_name); addDLLHandle(buf, instance); if (loaded) { *loaded = instance; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5cfcf0f90ab2955401ebbd78f417d8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5cfcf0f90ab2955401ebbd78f417d8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26009] 7 commits: rts/linker: Factor out ProddableBlocks machinery
by Ben Gamari (＠bgamari) 19 May '25

19 May '25

Ben Gamari pushed to branch wip/T26009 at Glasgow Haskell Compiler / GHC Commits: 2921131c by Ben Gamari at 2025-05-19T15:55:32-04:00 rts/linker: Factor out ProddableBlocks machinery - - - - - e6e69dba by Ben Gamari at 2025-05-19T15:55:32-04:00 rts/linker: Improve efficiency of proddable blocks structure Previously the linker's "proddable blocks" check relied on a simple linked list of spans. This resulted in extremely poor complexity while linking objects with lots of small sections (e.g. objects built with split sections). Rework the mechanism to instead use a simple interval set implemented via binary search. Fixes #26009. - - - - - 915902fc by Ben Gamari at 2025-05-19T15:55:32-04:00 testsuite: Add simple functional test for ProddableBlockSet - - - - - 1f38e273 by Ben Gamari at 2025-05-19T15:55:32-04:00 rts/linker/PEi386: Drop check for LOAD_LIBRARY_SEARCH_*_DIRS The `LOAD_LIBRARY_SEARCH_USER_DIRS` and `LOAD_LIBRARY_SEARCH_DEFAULT_DIRS` were introduced in Windows Vista and have been available every since. As we no longer support Windows XP we can drop this check. Addresses #26009. - - - - - facf379b by Ben Gamari at 2025-05-19T15:55:33-04:00 rts/linker/PEi386: Clean up code style - - - - - 30a7dc99 by Ben Gamari at 2025-05-19T15:56:09-04:00 rts/Hash: Factor out hashBuffer This is a useful helper which can be used for non-strings as well. - - - - - 5cfcf0f9 by Ben Gamari at 2025-05-19T15:58:03-04:00 rts/linker/PEi386: Don't repeated load DLLs Previously every DLL-imported symbol would result in a call to `LoadLibraryEx`. This ended up constituting over 40% of the runtime of `ghc --interactive -e 42` on Windows. Avoid this by maintaining a hash-set of loaded DLL names, skipping the call if we have already loaded the requested DLL. Addresses #26009. - - - - - 13 changed files: - libffi-tarballs - rts/Hash.c - rts/Hash.h - rts/Linker.c - rts/LinkerInternals.h - rts/linker/Elf.c - rts/linker/MachO.c - rts/linker/PEi386.c - + rts/linker/ProddableBlocks.c - + rts/linker/ProddableBlocks.h - rts/rts.cabal - + testsuite/tests/rts/TestProddableBlockSet.c - testsuite/tests/rts/all.T Changes: ===================================== libffi-tarballs ===================================== @@ -1 +1 @@ -Subproject commit ac7fa3132d382056837cad297ab4c66418febb69 +Subproject commit cb280851187d7b509d341be7b50c9a239810feb0 ===================================== rts/Hash.c ===================================== @@ -94,13 +94,13 @@ hashWord(const HashTable *table, StgWord key) } int -hashStr(const HashTable *table, StgWord w) +hashBuffer(const HashTable *table, const void *buf, size_t len) { - const char *key = (char*) w; + const char *key = (char*) buf; #if WORD_SIZE_IN_BITS == 64 - StgWord h = XXH3_64bits_withSeed (key, strlen(key), 1048583); + StgWord h = XXH3_64bits_withSeed (key, len, 1048583); #else - StgWord h = XXH32 (key, strlen(key), 1048583); + StgWord h = XXH32 (key, len, 1048583); #endif /* Mod the size of the hash table (a power of 2) */ @@ -114,6 +114,13 @@ hashStr(const HashTable *table, StgWord w) return bucket; } +int +hashStr(const HashTable *table, StgWord w) +{ + const char *key = (char*) w; + return hashBuffer(table, key, strlen(key)); +} + STATIC_INLINE int compareWord(StgWord key1, StgWord key2) { ===================================== rts/Hash.h ===================================== @@ -69,6 +69,10 @@ void * removeStrHashTable ( StrHashTable *table, const char * key, */ typedef int HashFunction(const HashTable *table, StgWord key); typedef int CompareFunction(StgWord key1, StgWord key2); + +// Helper for implementing hash functions +int hashBuffer(const HashTable *table, const void *buf, size_t len); + int hashWord(const HashTable *table, StgWord key); int hashStr(const HashTable *table, StgWord w); void insertHashTable_ ( HashTable *table, StgWord key, @@ -79,6 +83,7 @@ void * removeHashTable_ ( HashTable *table, StgWord key, const void *data, HashFunction f, CompareFunction cmp ); + /* Freeing hash tables */ void freeHashTable ( HashTable *table, void (*freeDataFun)(void *) ); ===================================== rts/Linker.c ===================================== @@ -1194,7 +1194,7 @@ void freeObjectCode (ObjectCode *oc) stgFree(oc->sections); } - freeProddableBlocks(oc); + freeProddableBlocks(&oc->proddables); freeSegments(oc); /* Free symbol_extras. On x86_64 Windows, symbol_extras are allocated @@ -1279,7 +1279,7 @@ mkOc( ObjectType type, pathchar *path, char *image, int imageSize, oc->sections = NULL; oc->n_segments = 0; oc->segments = NULL; - oc->proddables = NULL; + initProddableBlockSet(&oc->proddables); oc->foreign_exports = NULL; #if defined(NEED_SYMBOL_EXTRAS) oc->symbol_extras = NULL; @@ -1834,50 +1834,6 @@ OStatus getObjectLoadStatus (pathchar *path) return r; } -/* ----------------------------------------------------------------------------- - * Sanity checking. For each ObjectCode, maintain a list of address ranges - * which may be prodded during relocation, and abort if we try and write - * outside any of these. - */ -void -addProddableBlock ( ObjectCode* oc, void* start, int size ) -{ - ProddableBlock* pb - = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock"); - - IF_DEBUG(linker, debugBelch("addProddableBlock: %p %p %d\n", oc, start, size)); - ASSERT(size > 0); - pb->start = start; - pb->size = size; - pb->next = oc->proddables; - oc->proddables = pb; -} - -void -checkProddableBlock (ObjectCode *oc, void *addr, size_t size ) -{ - ProddableBlock* pb; - - for (pb = oc->proddables; pb != NULL; pb = pb->next) { - char* s = (char*)(pb->start); - char* e = s + pb->size; - char* a = (char*)addr; - if (a >= s && (a+size) <= e) return; - } - barf("checkProddableBlock: invalid fixup in runtime linker: %p", addr); -} - -void freeProddableBlocks (ObjectCode *oc) -{ - ProddableBlock *pb, *next; - - for (pb = oc->proddables; pb != NULL; pb = next) { - next = pb->next; - stgFree(pb); - } - oc->proddables = NULL; -} - /* ----------------------------------------------------------------------------- * Section management. */ ===================================== rts/LinkerInternals.h ===================================== @@ -12,6 +12,7 @@ #include "RtsSymbols.h" #include "Hash.h" #include "linker/M32Alloc.h" +#include "linker/ProddableBlocks.h" #if RTS_LINKER_USE_MMAP #include <sys/mman.h> @@ -175,14 +176,6 @@ struct _Section { struct SectionFormatInfo* info; }; -typedef - struct _ProddableBlock { - void* start; - int size; - struct _ProddableBlock* next; - } - ProddableBlock; - typedef struct _Segment { void *start; /* page aligned start address of a segment */ size_t size; /* page rounded size of a segment */ @@ -328,7 +321,7 @@ struct _ObjectCode { /* SANITY CHECK ONLY: a list of the only memory regions which may safely be prodded during relocation. Any attempt to prod outside one of these is an error in the linker. */ - ProddableBlock* proddables; + ProddableBlockSet proddables; #if defined(NEED_SYMBOL_EXTRAS) SymbolExtra *symbol_extras; @@ -434,10 +427,6 @@ void exitLinker( void ); void freeObjectCode (ObjectCode *oc); SymbolAddr* loadSymbol(SymbolName *lbl, RtsSymbolInfo *pinfo); -void addProddableBlock ( ObjectCode* oc, void* start, int size ); -void checkProddableBlock (ObjectCode *oc, void *addr, size_t size ); -void freeProddableBlocks (ObjectCode *oc); - void addSection (Section *s, SectionKind kind, SectionAlloc alloc, void* start, StgWord size, StgWord mapped_offset, void* mapped_start, StgWord mapped_size); ===================================== rts/linker/Elf.c ===================================== @@ -924,7 +924,7 @@ ocGetNames_ELF ( ObjectCode* oc ) oc->sections[i].info->stubs = NULL; #endif - addProddableBlock(oc, start, size); + addProddableBlock(&oc->proddables, start, size); } else { addSection(&oc->sections[i], kind, alloc, oc->image+offset, size, 0, 0, 0); @@ -1272,7 +1272,7 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC, debugBelch("Reloc: P = %p S = %p A = %p type=%d\n", (void*)P, (void*)S, (void*)A, reloc_type )); #if defined(DEBUG) - checkProddableBlock ( oc, pP, sizeof(Elf_Word) ); + checkProddableBlock ( &oc->proddables, pP, sizeof(Elf_Word) ); #else (void) pP; /* suppress unused varialbe warning in non-debug build */ #endif @@ -1684,7 +1684,7 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC, #if defined(DEBUG) IF_DEBUG(linker_verbose,debugBelch("Reloc: P = %p S = %p A = %p\n", (void*)P, (void*)S, (void*)A )); - checkProddableBlock(oc, (void*)P, sizeof(Elf_Word)); + checkProddableBlock(&oc->proddables, (void*)P, sizeof(Elf_Word)); #endif #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH) ===================================== rts/linker/MachO.c ===================================== @@ -253,7 +253,7 @@ resolveImports( return 0; } - checkProddableBlock(oc, + checkProddableBlock(&oc->proddables, ((void**)(oc->image + sect->offset)) + i, sizeof(void *)); ((void**)(oc->image + sect->offset))[i] = addr; @@ -287,7 +287,7 @@ decodeAddend(ObjectCode * oc, Section * section, MachORelocationInfo * ri) { /* the instruction. It is 32bit wide */ uint32_t * p = (uint32_t*)((uint8_t*)section->start + ri->r_address); - checkProddableBlock(oc, (void*)p, 1 << ri->r_length); + checkProddableBlock(&oc->proddables, (void*)p, 1 << ri->r_length); switch(ri->r_type) { case ARM64_RELOC_UNSIGNED: { @@ -364,7 +364,7 @@ encodeAddend(ObjectCode * oc, Section * section, MachORelocationInfo * ri, int64_t addend) { uint32_t * p = (uint32_t*)((uint8_t*)section->start + ri->r_address); - checkProddableBlock(oc, (void*)p, 1 << ri->r_length); + checkProddableBlock(&oc->proddables, (void*)p, 1 << ri->r_length); switch (ri->r_type) { case ARM64_RELOC_UNSIGNED: { @@ -788,7 +788,7 @@ relocateSection(ObjectCode* oc, int curSection) default: barf("Unknown size."); } - checkProddableBlock(oc,thingPtr,relocLenBytes); + checkProddableBlock(&oc->proddables,thingPtr,relocLenBytes); /* * With SIGNED_N the relocation is not at the end of the @@ -1034,9 +1034,9 @@ relocateSection(ObjectCode* oc, int curSection) */ if (0 == reloc->r_extern) { if (reloc->r_pcrel) { - checkProddableBlock(oc, (void *)((char *)thing + baseValue), 1); + checkProddableBlock(&oc->proddables, (void *)((char *)thing + baseValue), 1); } else { - checkProddableBlock(oc, (void *)thing, 1); + checkProddableBlock(&oc->proddables, (void *)thing, 1); } } @@ -1343,7 +1343,7 @@ ocGetNames_MachO(ObjectCode* oc) secArray[sec_idx].info->stub_size = 0; secArray[sec_idx].info->stubs = NULL; #endif - addProddableBlock(oc, start, section->size); + addProddableBlock(&oc->proddables, start, section->size); } curMem = (char*) secMem + section->size; ===================================== rts/linker/PEi386.c ===================================== @@ -427,8 +427,53 @@ const int default_alignment = 8; the pointer as a redirect. Essentially it's a DATA DLL reference. */ const void* __rts_iob_func = (void*)&__acrt_iob_func; +/* + * Note [Avoiding repeated DLL loading] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * As LoadLibraryEx tends to be expensive and addDLL_PEi386 is called on every + * DLL-imported symbol, we use a hash-set to keep track of which DLLs have + * already been loaded. This hash-set is keyed on the dll_name passed to + * addDLL_PEi386 and serves as a quick check to avoid repeated calls to + * LoadLibraryEx for the identical DLL. See #26009. + */ + +typedef struct { + HashTable *hash; +} LoadedDllSet; + +LoadedDllSet loaded_dll_set; + +void initLoadedDllSet(LoadedDllSet *set) { + set->hash = allocHashTable(); +} + +int hash_path(const HashTable *table, StgWord w) +{ + const pathchar *key = (pathchar*) w; + return hashBuffer(table, key, sizeof(pathchar) * wcslen(key)); +} + +int compare_path(StgWord key1, StgWord key2) +{ + return wscmp((pathchar*) key1, (pathchar*) key2); +} + +void addLoadedDll(LoadedDllSet *set, pathchar *dll_name) +{ + insertHashTable_(set->hash, (StgWord) dll_name, (void*) 1, hash_path); +} + +bool isDllLoaded(LoadedDllSet *set, pathchar *dll_name) +{ + void * result = lookupHashTable_(set->hash, (StgWord) dll_name, hash_path, compare_path); + return result != NULL; +} + + void initLinker_PEi386(void) { + initLoadedDllSet(&loaded_dll_set); + if (!ghciInsertSymbolTable(WSTR("(GHCi/Ld special symbols)"), symhash, "__image_base__", GetModuleHandleW (NULL), HS_BOOL_TRUE, @@ -440,10 +485,11 @@ void initLinker_PEi386(void) addDLLHandle(WSTR("*.exe"), GetModuleHandle(NULL)); #endif - /* Register the cleanup routine as an exit handler, this gives other exit handlers - a chance to run which may need linker information. Exit handlers are ran in - reverse registration order so this needs to be before the linker loads anything. */ - atexit (exitLinker_PEi386); + /* Register the cleanup routine as an exit handler, this gives other exit handlers + * a chance to run which may need linker information. Exit handlers are ran in + * reverse registration order so this needs to be before the linker loads anything. + */ + atexit (exitLinker_PEi386); } void exitLinker_PEi386(void) @@ -798,12 +844,12 @@ uint8_t* getSymShortName ( COFF_HEADER_INFO *info, COFF_symbol* sym ) const char * addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) { - /* ------------------- Win32 DLL loader ------------------- */ - - pathchar* buf; - HINSTANCE instance; + /* ------------------- Win32 DLL loader ------------------- */ + IF_DEBUG(linker, debugBelch("addDLL; dll_name = `%" PATH_FMT "'\n", dll_name)); - IF_DEBUG(linker, debugBelch("addDLL; dll_name = `%" PATH_FMT "'\n", dll_name)); + if (isDllLoaded(&loaded_dll_set, dll_name)) { + return NULL; + } /* The file name has no suffix (yet) so that we can try both foo.dll and foo.drv @@ -816,35 +862,23 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) extension. */ size_t bufsize = pathlen(dll_name) + 10; - buf = stgMallocBytes(bufsize * sizeof(wchar_t), "addDLL"); + pathchar *buf = stgMallocBytes(bufsize * sizeof(wchar_t), "addDLL"); /* These are ordered by probability of success and order we'd like them. */ const wchar_t *formats[] = { L"%ls.DLL", L"%ls.DRV", L"lib%ls.DLL", L"%ls" }; const DWORD flags[] = { LOAD_LIBRARY_SEARCH_USER_DIRS | LOAD_LIBRARY_SEARCH_DEFAULT_DIRS, 0 }; - int cFormat, cFlag; - int flags_start = 1; /* Assume we don't support the new API. */ - - /* Detect if newer API are available, if not, skip the first flags entry. */ - if (GetProcAddress((HMODULE)LoadLibraryW(L"Kernel32.DLL"), "AddDllDirectory")) { - flags_start = 0; - } - /* Iterate through the possible flags and formats. */ - for (cFlag = flags_start; cFlag < 2; cFlag++) - { - for (cFormat = 0; cFormat < 4; cFormat++) - { + HINSTANCE instance; + for (int cFlag = 0; cFlag < 2; cFlag++) { + for (int cFormat = 0; cFormat < 4; cFormat++) { snwprintf(buf, bufsize, formats[cFormat], dll_name); instance = LoadLibraryExW(buf, NULL, flags[cFlag]); if (instance == NULL) { - if (GetLastError() != ERROR_MOD_NOT_FOUND) - { + if (GetLastError() != ERROR_MOD_NOT_FOUND) { goto error; } - } - else - { + } else { break; /* We're done. DLL has been loaded. */ } } @@ -855,6 +889,7 @@ addDLL_PEi386( pathchar *dll_name, HINSTANCE *loaded ) goto error; } + addLoadedDll(&loaded_dll_set, dll_name); addDLLHandle(buf, instance); if (loaded) { *loaded = instance; @@ -1658,7 +1693,7 @@ ocGetNames_PEi386 ( ObjectCode* oc ) } addSection(section, kind, SECTION_NOMEM, start, sz, 0, 0, 0); - addProddableBlock(oc, oc->sections[i].start, sz); + addProddableBlock(&oc->proddables, oc->sections[i].start, sz); } /* Copy exported symbols into the ObjectCode. */ @@ -1690,7 +1725,7 @@ ocGetNames_PEi386 ( ObjectCode* oc ) SECTIONKIND_RWDATA, SECTION_MALLOC, bss, globalBssSize, 0, 0, 0); IF_DEBUG(linker_verbose, debugBelch("bss @ %p %" FMT_Word "\n", bss, globalBssSize)); - addProddableBlock(oc, bss, globalBssSize); + addProddableBlock(&oc->proddables, bss, globalBssSize); } else { addSection(&oc->sections[oc->n_sections-1], SECTIONKIND_OTHER, SECTION_NOMEM, NULL, 0, 0, 0, 0); @@ -2067,13 +2102,13 @@ ocResolve_PEi386 ( ObjectCode* oc ) IF_DEBUG(linker_verbose, debugBelch("S=%zx\n", S)); /* All supported relocations write at least 4 bytes */ - checkProddableBlock(oc, pP, 4); + checkProddableBlock(&oc->proddables, pP, 4); switch (reloc->Type) { #if defined(x86_64_HOST_ARCH) case 1: /* R_X86_64_64 (ELF constant 1) - IMAGE_REL_AMD64_ADDR64 (PE constant 1) */ { uint64_t A; - checkProddableBlock(oc, pP, 8); + checkProddableBlock(&oc->proddables, pP, 8); A = *(uint64_t*)pP; *(uint64_t *)pP = S + A; break; @@ -2114,7 +2149,7 @@ ocResolve_PEi386 ( ObjectCode* oc ) { /* mingw will emit this for a pc-rel 64 relocation */ uint64_t A; - checkProddableBlock(oc, pP, 8); + checkProddableBlock(&oc->proddables, pP, 8); A = *(uint64_t*)pP; *(uint64_t *)pP = S + A - (intptr_t)pP; break; ===================================== rts/linker/ProddableBlocks.c ===================================== @@ -0,0 +1,130 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2025 + * + * RTS Object Linker + * + * ---------------------------------------------------------------------------*/ + + +/* + * Sanity checking. For each ObjectCode, maintain a list of address ranges + * which may be prodded during relocation, and abort if we try and write + * outside any of these. + */ + +#include "Rts.h" +#include "RtsUtils.h" +#include "linker/ProddableBlocks.h" + +#include <stdlib.h> +#include <string.h> + +typedef struct _ProddableBlock { + uintptr_t start; // inclusive + uintptr_t end; // inclusive +} ProddableBlock; + +void +initProddableBlockSet ( ProddableBlockSet* set ) +{ + set->data = NULL; + set->capacity = 0; + set->size = 0; +} + +void +freeProddableBlocks (ProddableBlockSet *set) +{ + stgFree(set->data); + set->data = NULL; + set->size = 0; + set->capacity = 0; +} + +// Binary search for the first interval with start >= value. Returns index or +// size if none. +static size_t +findLower(const ProddableBlockSet *set, uintptr_t value) +{ + size_t l = 0; + size_t r = set->size; + while (l < r) { + size_t mid = l + (r - l) / 2; + if (set->data[mid].start < value) { + l = mid + 1; + } else { + r = mid; + } + } + return l; +} + +// Check whether a given value is a member of the set. +bool +containsSpan ( const ProddableBlockSet *set, uintptr_t start, uintptr_t end ) +{ + size_t i = findLower(set, start+1); + return i > 0 + && set->data[i-1].start <= start + && end <= set->data[i-1].end; +} + +void +checkProddableBlock (const ProddableBlockSet *set, void *addr, size_t size ) +{ + if (! containsSpan(set, (uintptr_t) addr, (uintptr_t) addr+size)) { + barf("checkProddableBlock: invalid fixup in runtime linker: %p", addr); + } +} + +// Ensure capacity for at least new_capacity intervals +static void +ensureCapacity(ProddableBlockSet *set, size_t new_capacity) { + if (new_capacity > set->capacity) { + size_t cap = set->capacity ? set->capacity * 2 : 4; + if (cap < new_capacity) { + cap = new_capacity; + } + ProddableBlock *tmp = stgReallocBytes(set->data, cap * sizeof(ProddableBlock), "addProddableBlock"); + set->data = tmp; + set->capacity = cap; + } +} + +void +addProddableBlock ( ProddableBlockSet* set, void* start_ptr, size_t size ) +{ + const uintptr_t start = (uintptr_t) start_ptr; + const uintptr_t end = (uintptr_t) start + size; + size_t i = findLower(set, start); + + // check previous interval if it is overlapping or adjacent + if (i > 0 && start <= set->data[i-1].end + 1) { + // merge with left interval + i--; + if (end > set->data[i].end) { + set->data[i].end = end; + } + } else { + // insert new interval + ensureCapacity(set, set->size + 1); + memmove(&set->data[i+1], &set->data[i], sizeof(ProddableBlock) * (set->size - i)); + set->data[i].start = start; + set->data[i].end = end; + set->size++; + } + + // coalesce overlaps on right + size_t j = i; + while (j < set->size && set->data[j].start <= set->data[i].end + 1) { + set->data[i].end = set->data[j].end; + j++; + } + + if (j != i) { + memmove(&set->data[i+1], &set->data[j], sizeof(ProddableBlock) * (set->size - j)); + set->size -= j - i - 1; + } +} + ===================================== rts/linker/ProddableBlocks.h ===================================== @@ -0,0 +1,38 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2025 + * + * RTS Object Linker + * + * ---------------------------------------------------------------------------*/ + +#pragma once + +#include <stdbool.h> +#include <stddef.h> +#include <stdint.h> + +// An interval set on uintptr_t. +struct _ProddableBlock; + +typedef struct { + size_t size; + size_t capacity; + // sorted list of disjoint (start,end) pairs + struct _ProddableBlock *data; +} ProddableBlockSet; + +void initProddableBlockSet ( ProddableBlockSet* set ); + +// Insert an interval. +void addProddableBlock ( ProddableBlockSet* set, void* start, size_t size ); + +// Check that an address belongs to the set. +void checkProddableBlock (const ProddableBlockSet *set, void *addr, size_t size ); + + +// Free a set. +void freeProddableBlocks (ProddableBlockSet *set); + +// For testing. +bool containsSpan ( const ProddableBlockSet *set, uintptr_t start, uintptr_t end ); ===================================== rts/rts.cabal ===================================== @@ -491,6 +491,7 @@ library linker/MachO.c linker/macho/plt.c linker/macho/plt_aarch64.c + linker/ProddableBlocks.c linker/PEi386.c linker/SymbolExtras.c linker/elf_got.c ===================================== testsuite/tests/rts/TestProddableBlockSet.c ===================================== @@ -0,0 +1,33 @@ +#include <assert.h> +#include <stdbool.h> +#include <stdint.h> +#include <stddef.h> + +// Excerpted from ProddableBlocks.h +typedef struct { + size_t size; + size_t capacity; + // sorted list of disjoint (start,end) pairs + struct _ProddableBlock *data; +} ProddableBlockSet; + +void initProddableBlockSet ( ProddableBlockSet* set ); +void addProddableBlock ( ProddableBlockSet* set, void* start, size_t size ); +bool containsSpan ( const ProddableBlockSet *set, uintptr_t start, uintptr_t end ); + +int main () { + ProddableBlockSet set; + initProddableBlockSet(&set); + addProddableBlock(&set, (void*) 0x20, 0x10); + addProddableBlock(&set, (void*) 0x30, 0x10); + addProddableBlock(&set, (void*) 0x100, 0x10); + + assert( containsSpan(&set, 0x20, 0x30)); + assert( containsSpan(&set, 0x30, 0x29)); + assert(!containsSpan(&set, 0x30, 0x49)); + assert(!containsSpan(&set, 0x60, 0x70)); + assert(!containsSpan(&set, 0x90, 0x110)); + assert( containsSpan(&set, 0x100, 0x101)); + return 0; +} + ===================================== testsuite/tests/rts/all.T ===================================== @@ -641,3 +641,5 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru # N.B. This will likely issue a warning on stderr but we merely care that the # program doesn't crash. test('T25560', [req_c_rts, ignore_stderr], compile_and_run, ['']) + +test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/af7b73daab5d9c6b3064d3ae9d82c6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/af7b73daab5d9c6b3064d3ae9d82c6… You're receiving this email because of your account on gitlab.haskell.org.

1 0