June 2025 - ghc-commits

[Git][ghc/ghc][wip/spj-apporv-Oct24] 2 commits: accept the right test output
by Apoorv Ingle (＠ani) 24 Jun '25

24 Jun '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 0b60a5d1 by Apoorv Ingle at 2025-06-23T23:45:45-05:00 accept the right test output - - - - - e74f1260 by Apoorv Ingle at 2025-06-23T23:54:47-05:00 make make sure to set inGenerated code for RecordUpdate checks - - - - - 2 changed files: - compiler/GHC/Tc/Gen/Expr.hs - testsuite/tests/printer/T17697.stderr Changes: ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -650,20 +650,20 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr do { -- Expand the record update. See Note [Record Updates]. ; (ds_expr, ds_res_ty, err_ctxt) <- expandRecordUpd record_expr possible_parents rbnds res_ty - - -- Typecheck the expanded expression. - ; expr' <- addErrCtxt err_ctxt $ - setInGeneratedCode (OrigExpr expr) $ - tcExpr ds_expr (Check ds_res_ty) - -- NB: it's important to use ds_res_ty and not res_ty here. - -- Test case: T18802b. - - ; addErrCtxt err_ctxt $ tcWrapResultMono expr expr' ds_res_ty res_ty - -- We need to unify the result type of the expanded - -- expression with the expected result type. - -- - -- See Note [Unifying result types in tcRecordUpd]. - -- Test case: T10808. + ; addErrCtxt err_ctxt $ + setInGeneratedCode (OrigExpr expr) $ + do { -- Typecheck the expanded expression. + expr' <- tcExpr ds_expr (Check ds_res_ty) + -- NB: it's important to use ds_res_ty and not res_ty here. + -- Test case: T18802b. + + ; tcWrapResultMono expr expr' ds_res_ty res_ty + -- We need to unify the result type of the expanded + -- expression with the expected result type. + -- + -- See Note [Unifying result types in tcRecordUpd]. + -- Test case: T10808. + } } tcExpr e@(RecordUpd { rupd_flds = OverloadedRecUpdFields {}}) _ ===================================== testsuite/tests/printer/T17697.stderr ===================================== @@ -1,7 +1,3 @@ -T17697.hs:5:8: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] - A do-notation statement discarded a result of type - ‘GHC.Internal.Types.ZonkAny 1’ - Suggested fix: Suppress this warning by saying ‘_ <- threadDelay 1’ - T17697.hs:6:5: warning: [GHC-88464] [-Wdeferred-out-of-scope-variables (in -Wdefault)] Variable not in scope: threadDelay :: t0 -> IO a0 + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7282035491eb8210ccb78544a1d041… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7282035491eb8210ccb78544a1d041… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: configure: Don't force value of OTOOL, etc. if not present
by Marge Bot (＠marge-bot) 24 Jun '25

24 Jun '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 83bf9f4a by Ben Gamari at 2025-06-23T23:11:42-04:00 configure: Don't force value of OTOOL, etc. if not present Previously if `otool` and `install_name_tool` were not present they would be overridden by `fp_settings.m4`. This logic was introduced in 4ff93292243888545da452ea4d4c1987f2343591 without explanation. - - - - - 72e42f55 by Ben Gamari at 2025-06-23T23:11:42-04:00 ghc-toolchain: Add support for otool, install_name_tool Fixes part of ghc#23675. - - - - - 03c3a06f by Ben Gamari at 2025-06-23T23:11:42-04:00 ghc-toolchain: Add support for llc, opt, llvm-as Fixes #23675. - - - - - f1d3df62 by Rodrigo Mesquita at 2025-06-23T23:11:42-04:00 hadrian: Use settings-use-distro-mingw directly The type `ToolchainSetting` only made sense when we had more settings to fetch from the system config file. Even then "settings-use-distro-mingw" is arguably not a toolchain setting. With the fix for #23675, all toolchain tools were moved to the `ghc-toolchain` `Toolchain` format. Therefore, we can inline `settings-use-distro-mingw` accesses and delete `ToolchainSetting`. - - - - - d3ea8b38 by Rodrigo Mesquita at 2025-06-23T23:11:42-04:00 configure: Check LlvmTarget exists for LlvmAsFlags If LlvmTarget was empty, LlvmAsFlags would be just "--target=". If it is empty now, simply keep LlvmAsFlags empty. ghc-toolchain already does this right. This fix makes the two configurations match up. - - - - - 3de4061c by Ben Gamari at 2025-06-23T23:11:43-04:00 rts/linker/LoadArchive: Use bool Improve type precision by using `bool` instead of `int` and `StgBool`. - - - - - bbfc1f7d by Ben Gamari at 2025-06-23T23:11:43-04:00 rts/linker/LoadArchive: Don't rely on file extensions for identification Previously archive members would be identified via their file extension, as described in #13103. We now instead use a more principled approach, relying on the magic number in the member's header. As well, we refactor treatment of archive format detection to improve code clarity and error handling. Closes #13103. - - - - - 14 changed files: - distrib/configure.ac.in - hadrian/cfg/default.host.target.in - hadrian/cfg/default.target.in - hadrian/cfg/system.config.in - hadrian/src/Builder.hs - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/RunTest.hs - m4/fp_settings.m4 - m4/ghc_toolchain.m4 - m4/prep_target_file.m4 - rts/linker/LoadArchive.c - utils/ghc-toolchain/exe/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs Changes: ===================================== distrib/configure.ac.in ===================================== @@ -216,7 +216,7 @@ AC_SUBST([LlvmAsCmd]) dnl We know that `clang` supports `--target` and it is necessary to pass it dnl lest we see #25793. -if test -z "$LlvmAsFlags" ; then +if test -z "$LlvmAsFlags" && ! test -z "$LlvmTarget"; then LlvmAsFlags="--target=$LlvmTarget" fi AC_SUBST([LlvmAsFlags]) ===================================== hadrian/cfg/default.host.target.in ===================================== @@ -38,5 +38,10 @@ Target , tgtRanlib = Nothing , tgtNm = Nm {nmProgram = Program {prgPath = "", prgFlags = []}} , tgtMergeObjs = Just (MergeObjs {mergeObjsProgram = Program {prgPath = "@LD_STAGE0@", prgFlags = ["-r"]}, mergeObjsSupportsResponseFiles = False}) +, tgtLlc = Nothing +, tgtOpt = Nothing +, tgtLlvmAs = Nothing , tgtWindres = Nothing +, tgtOtool = Nothing +, tgtInstallNameTool = Nothing } ===================================== hadrian/cfg/default.target.in ===================================== @@ -38,5 +38,10 @@ Target , tgtRanlib = Just (Ranlib {ranlibProgram = Program {prgPath = "@RanlibCmd@", prgFlags = []}}) , tgtNm = Nm {nmProgram = Program {prgPath = "@NmCmd@", prgFlags = []}} , tgtMergeObjs = @MergeObjsCmdMaybe@ +, tgtLlc = @LlcCmdMaybeProg@ +, tgtOpt = @OptCmdMaybeProg@ +, tgtLlvmAs = @LlvmAsCmdMaybeProg@ , tgtWindres = @WindresCmdMaybeProg@ +, tgtOtool = @OtoolCmdMaybeProg@ +, tgtInstallNameTool = @InstallNameToolCmdMaybeProg@ } ===================================== hadrian/cfg/system.config.in ===================================== @@ -79,13 +79,6 @@ project-git-commit-id = @ProjectGitCommitId@ # generated by configure, to generated being by the build system. Many of these # might become redundant. # See Note [tooldir: How GHC finds mingw on Windows] - -settings-otool-command = @SettingsOtoolCommand@ -settings-install_name_tool-command = @SettingsInstallNameToolCommand@ -settings-llc-command = @SettingsLlcCommand@ -settings-opt-command = @SettingsOptCommand@ -settings-llvm-as-command = @SettingsLlvmAsCommand@ -settings-llvm-as-flags = @SettingsLlvmAsFlags@ settings-use-distro-mingw = @SettingsUseDistroMINGW@ target-has-libm = @TargetHasLibm@ ===================================== hadrian/src/Builder.hs ===================================== @@ -34,7 +34,6 @@ import Base import Context import Oracles.Flag import Oracles.Setting (setting, Setting(..)) -import Oracles.Setting (settingsFileSetting, ToolchainSetting(..)) import Packages import GHC.IO.Encoding (getFileSystemEncoding) @@ -240,7 +239,7 @@ instance H.Builder Builder where Ghc _ st -> do root <- buildRoot unlitPath <- builderPath Unlit - distro_mingw <- settingsFileSetting ToolchainSetting_DistroMinGW + distro_mingw <- lookupSystemConfig "settings-use-distro-mingw" libffi_adjustors <- useLibffiForAdjustors use_system_ffi <- flag UseSystemFfi ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -2,7 +2,6 @@ module Oracles.Setting ( configFile, -- * Settings Setting (..), setting, getSetting, - ToolchainSetting (..), settingsFileSetting, -- * Helpers ghcCanonVersion, cmdLineLengthLimit, targetSupportsRPaths, topDirectory, @@ -75,25 +74,6 @@ data Setting = CursesIncludeDir | BourneShell | EmsdkVersion --- TODO compute solely in Hadrian, removing these variables' definitions --- from aclocal.m4 whenever they can be calculated from other variables --- already fed into Hadrian. - --- | All 'ToolchainSetting's are computed by the ghc-toolchain utility for configuring toolchains. --- This used to be defined by 'FP_SETTINGS' in aclocal.m4. --- --- TODO: We should be able to drop this completely, after moving all the toolchain settings to ghc-toolchain --- Move to ghc-toolchain and to the Target files generated by configure and ghc-toolchain --- * First we will get rid of DistroMinGW when we fix the windows build -data ToolchainSetting - = ToolchainSetting_OtoolCommand - | ToolchainSetting_InstallNameToolCommand - | ToolchainSetting_LlcCommand - | ToolchainSetting_OptCommand - | ToolchainSetting_LlvmAsCommand - | ToolchainSetting_LlvmAsFlags - | ToolchainSetting_DistroMinGW - -- | Look up the value of a 'Setting' in @cfg/system.config@, tracking the -- result. setting :: Setting -> Action String @@ -134,20 +114,6 @@ setting key = lookupSystemConfig $ case key of BourneShell -> "bourne-shell" EmsdkVersion -> "emsdk-version" --- | Look up the value of a 'SettingList' in @cfg/system.config@, tracking the --- result. --- See Note [tooldir: How GHC finds mingw on Windows] --- ROMES:TODO: This should be queryTargetTargetConfig -settingsFileSetting :: ToolchainSetting -> Action String -settingsFileSetting key = lookupSystemConfig $ case key of - ToolchainSetting_OtoolCommand -> "settings-otool-command" - ToolchainSetting_InstallNameToolCommand -> "settings-install_name_tool-command" - ToolchainSetting_LlcCommand -> "settings-llc-command" - ToolchainSetting_OptCommand -> "settings-opt-command" - ToolchainSetting_LlvmAsCommand -> "settings-llvm-as-command" - ToolchainSetting_LlvmAsFlags -> "settings-llvm-as-flags" - ToolchainSetting_DistroMinGW -> "settings-use-distro-mingw" -- ROMES:TODO: This option doesn't seem to be in ghc-toolchain yet. It corresponds to EnableDistroToolchain - -- | An expression that looks up the value of a 'Setting' in @cfg/system.config@, -- tracking the result. getSetting :: Setting -> Expr c b String ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -424,7 +424,7 @@ bindistRules = do , interpolateSetting "LlvmMinVersion" LlvmMinVersion , interpolateVar "LlvmTarget" $ getTarget tgtLlvmTarget , interpolateSetting "ProjectVersion" ProjectVersion - , interpolateVar "SettingsUseDistroMINGW" $ settingsFileSetting ToolchainSetting_DistroMinGW + , interpolateVar "SettingsUseDistroMINGW" $ lookupSystemConfig "settings-use-distro-mingw" , interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode , interpolateVar "TargetHasLibm" $ lookupSystemConfig "target-has-libm" , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple @@ -508,9 +508,9 @@ generateSettings settingsFile = do , ("ar flags", queryTarget arFlags) , ("ar supports at file", queryTarget arSupportsAtFile') , ("ar supports -L", queryTarget arSupportsDashL') - , ("ranlib command", queryTarget ranlibPath) - , ("otool command", expr $ settingsFileSetting ToolchainSetting_OtoolCommand) - , ("install_name_tool command", expr $ settingsFileSetting ToolchainSetting_InstallNameToolCommand) + , ("ranlib command", queryTarget ranlibPath) + , ("otool command", queryTarget otoolPath) + , ("install_name_tool command", queryTarget installNameToolPath) , ("windres command", queryTarget (maybe "/bin/false" prgPath . tgtWindres)) -- TODO: /bin/false is not available on many distributions by default, but we keep it as it were before the ghc-toolchain patch. Fix-me. , ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) , ("cross compiling", expr $ yesNo <$> flag CrossCompiling) @@ -525,11 +525,11 @@ generateSettings settingsFile = do , ("target has libm", expr $ lookupSystemConfig "target-has-libm") , ("Unregisterised", queryTarget (yesNo . tgtUnregisterised)) , ("LLVM target", queryTarget tgtLlvmTarget) - , ("LLVM llc command", expr $ settingsFileSetting ToolchainSetting_LlcCommand) - , ("LLVM opt command", expr $ settingsFileSetting ToolchainSetting_OptCommand) - , ("LLVM llvm-as command", expr $ settingsFileSetting ToolchainSetting_LlvmAsCommand) - , ("LLVM llvm-as flags", expr $ settingsFileSetting ToolchainSetting_LlvmAsFlags) - , ("Use inplace MinGW toolchain", expr $ settingsFileSetting ToolchainSetting_DistroMinGW) + , ("LLVM llc command", queryTarget llcPath) + , ("LLVM opt command", queryTarget optPath) + , ("LLVM llvm-as command", queryTarget llvmAsPath) + , ("LLVM llvm-as flags", queryTarget llvmAsFlags) + , ("Use inplace MinGW toolchain", expr $ lookupSystemConfig "settings-use-distro-mingw") , ("target RTS linker only supports shared libraries", expr $ yesNo <$> targetRTSLinkerOnlySupportsSharedLibs) , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage)) @@ -571,10 +571,16 @@ generateSettings settingsFile = do linkSupportsFilelist = yesNo . ccLinkSupportsFilelist . tgtCCompilerLink linkSupportsCompactUnwind = yesNo . ccLinkSupportsCompactUnwind . tgtCCompilerLink linkIsGnu = yesNo . ccLinkIsGnu . tgtCCompilerLink + llcPath = maybe "" prgPath . tgtLlc + optPath = maybe "" prgPath . tgtOpt + llvmAsPath = maybe "" prgPath . tgtLlvmAs + llvmAsFlags = escapeArgs . maybe [] prgFlags . tgtLlvmAs arPath = prgPath . arMkArchive . tgtAr arFlags = escapeArgs . prgFlags . arMkArchive . tgtAr arSupportsAtFile' = yesNo . arSupportsAtFile . tgtAr arSupportsDashL' = yesNo . arSupportsDashL . tgtAr + otoolPath = maybe "" prgPath . tgtOtool + installNameToolPath = maybe "" prgPath . tgtInstallNameTool ranlibPath = maybe "" (prgPath . ranlibProgram) . tgtRanlib mergeObjsSupportsResponseFiles' = maybe "NO" (yesNo . mergeObjsSupportsResponseFiles) . tgtMergeObjs ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -127,9 +127,9 @@ inTreeCompilerArgs stg = do platform <- queryTargetTarget targetPlatformTriple wordsize <- show @Int . (*8) <$> queryTargetTarget (wordSize2Bytes . tgtWordSize) - llc_cmd <- settingsFileSetting ToolchainSetting_LlcCommand - llvm_as_cmd <- settingsFileSetting ToolchainSetting_LlvmAsCommand - have_llvm <- liftIO (all isJust <$> mapM findExecutable [llc_cmd, llvm_as_cmd]) + llc_cmd <- queryTargetTarget tgtLlc + llvm_as_cmd <- queryTargetTarget tgtLlvmAs + let have_llvm = all isJust [llc_cmd, llvm_as_cmd] top <- topDirectory ===================================== m4/fp_settings.m4 ===================================== @@ -136,14 +136,7 @@ AC_DEFUN([FP_SETTINGS], fi # Mac-only tools - if test -z "$OtoolCmd"; then - OtoolCmd="otool" - fi SettingsOtoolCommand="$OtoolCmd" - - if test -z "$InstallNameToolCmd"; then - InstallNameToolCmd="install_name_tool" - fi SettingsInstallNameToolCommand="$InstallNameToolCmd" SettingsCCompilerSupportsNoPie="$CONF_GCC_SUPPORTS_NO_PIE" ===================================== m4/ghc_toolchain.m4 ===================================== @@ -107,6 +107,9 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN], echo "--merge-objs=$MergeObjsCmd" >> acargs echo "--readelf=$READELF" >> acargs echo "--windres=$WindresCmd" >> acargs + echo "--llc=$LlcCmd" >> acargs + echo "--opt=$OptCmd" >> acargs + echo "--llvm-as=$LlvmAsCmd" >> acargs if test -n "$USER_LD"; then echo "--ld=$USER_LD" >> acargs ===================================== m4/prep_target_file.m4 ===================================== @@ -10,6 +10,38 @@ # This toolchain will additionally be used to validate the one generated by # ghc-toolchain. See Note [ghc-toolchain consistency checking]. +# PREP_LIST +# ============ +# +# Issue a substitution with ["list","of","args"] of [$1List] when $1 is a +# space-separated list of args +# i.e. +# "arg1 arg2 arg3" +# ==> +# ["arg1","arg2","arg3"] +# +# $1 = list variable to substitute +dnl In autoconf, '@<:@' stands for '[', and '@:>@' for ']'. +AC_DEFUN([PREP_LIST],[ + # shell array + set -- $$1 + $1List="@<:@" + if test "[$]#" -eq 0; then + # no arguments + true + else + $1List="${$1List}\"[$]1\"" + shift # drop first elem + for arg in "[$]@" + do + $1List="${$1List},\"$arg\"" + done + fi + $1List="${$1List}@:>@" + + AC_SUBST([$1List]) +]) + # PREP_MAYBE_SIMPLE_PROGRAM # ========================= # @@ -27,6 +59,25 @@ AC_DEFUN([PREP_MAYBE_SIMPLE_PROGRAM],[ AC_SUBST([$1MaybeProg]) ]) +# PREP_MAYBE_PROGRAM +# ========================= +# +# Introduce a substitution [$1MaybeProg] with +# * Nothing, if $$1 is empty +# * Just (Program {prgPath = "$$1", prgFlags = [elements of $$2]}), otherwise +# +# $1 = optional program path +# $2 = program arguments +AC_DEFUN([PREP_MAYBE_PROGRAM],[ + if test -z "$$1"; then + $1MaybeProg=Nothing + else + PREP_LIST([$2]) + $1MaybeProg="Just (Program {prgPath = \"$$1\", prgFlags = $$2List})" + fi + AC_SUBST([$1MaybeProg]) +]) + # PREP_MAYBE_STRING # ========================= # @@ -86,38 +137,6 @@ AC_DEFUN([PREP_NOT_BOOLEAN],[ AC_SUBST([Not$1Bool]) ]) -# PREP_LIST -# ============ -# -# Issue a substitution with ["list","of","args"] of [$1List] when $1 is a -# space-separated list of args -# i.e. -# "arg1 arg2 arg3" -# ==> -# ["arg1","arg2","arg3"] -# -# $1 = list variable to substitute -dnl In autoconf, '@<:@' stands for '[', and '@:>@' for ']'. -AC_DEFUN([PREP_LIST],[ - # shell array - set -- $$1 - $1List="@<:@" - if test "[$]#" -eq 0; then - # no arguments - true - else - $1List="${$1List}\"[$]1\"" - shift # drop first elem - for arg in "[$]@" - do - $1List="${$1List},\"$arg\"" - done - fi - $1List="${$1List}@:>@" - - AC_SUBST([$1List]) -]) - # Eventually: PREP_BUILD_TARGET_FILE, PREP_HOST_TARGET_FILE, PREP_TARGET_TARGET_FILE # Prepares required substitutions to generate the target file AC_DEFUN([PREP_TARGET_FILE],[ @@ -148,7 +167,12 @@ AC_DEFUN([PREP_TARGET_FILE],[ PREP_LIST([JavaScriptCPPArgs]) PREP_LIST([CmmCPPArgs]) PREP_LIST([CmmCPPArgs_STAGE0]) + PREP_MAYBE_SIMPLE_PROGRAM([LlcCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([OptCmd]) + PREP_MAYBE_PROGRAM([LlvmAsCmd], [LlvmAsFlags]) PREP_MAYBE_SIMPLE_PROGRAM([WindresCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([OtoolCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([InstallNameToolCmd]) PREP_MAYBE_STRING([TargetVendor_CPP]) PREP_MAYBE_STRING([HostVendor_CPP]) PREP_LIST([CONF_CPP_OPTS_STAGE2]) ===================================== rts/linker/LoadArchive.c ===================================== @@ -33,6 +33,7 @@ #define DEBUG_LOG(...) IF_DEBUG(linker, debugBelch("loadArchive: " __VA_ARGS__)) + #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) /* Read 4 bytes and convert to host byte order */ static uint32_t read4Bytes(const char buf[static 4]) @@ -40,7 +41,7 @@ static uint32_t read4Bytes(const char buf[static 4]) return ntohl(*(uint32_t*)buf); } -static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) +static bool loadFatArchive(char input[static 20], FILE* f, pathchar* path) { uint32_t nfat_arch, nfat_offset, cputype, cpusubtype; #if defined(i386_HOST_ARCH) @@ -58,8 +59,9 @@ static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) #error Unknown Darwin architecture #endif - nfat_arch = read4Bytes(tmp + 4); + nfat_arch = read4Bytes(input + 4); DEBUG_LOG("found a fat archive containing %d architectures\n", nfat_arch); + char tmp[20]; nfat_offset = 0; for (uint32_t i = 0; i < nfat_arch; i++) { /* search for the right arch */ @@ -90,6 +92,7 @@ static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) } /* Read the header */ + char tmp[20]; n = fread(tmp, 1, 8, f); if (n != 8) { errorBelch("Failed reading header from `%" PATH_FMT "'", path); @@ -107,10 +110,51 @@ static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) } #endif -static StgBool readThinArchiveMember(int n, int memberSize, pathchar* path, +enum ObjectFileFormat { + NotObject, + COFFAmd64, + COFFI386, + COFFAArch64, + ELF, + MachO32, + MachO64, +}; + +static enum ObjectFileFormat identifyObjectFile_(char* buf, size_t sz) +{ + if (sz > 2 && ((uint16_t*)buf)[0] == 0x8664) { + return COFFAmd64; + } + if (sz > 2 && ((uint16_t*)buf)[0] == 0x014c) { + return COFFI386; + } + if (sz > 2 && ((uint16_t*)buf)[0] == 0xaa64) { + return COFFAArch64; + } + if (sz > 4 && memcmp(buf, "\x7f" "ELF", 4) == 0) { + return ELF; + } + if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedface) { + return MachO32; + } + if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedfacf) { + return MachO64; + } + return NotObject; +} + +static enum ObjectFileFormat identifyObjectFile(FILE *f) +{ + char buf[32]; + ssize_t sz = fread(buf, 1, 32, f); + CHECK(fseek(f, -sz, SEEK_CUR) == 0); + return identifyObjectFile_(buf, sz); +} + +static bool readThinArchiveMember(int n, int memberSize, pathchar* path, char* fileName, char* image) { - StgBool has_succeeded = false; + bool has_succeeded = false; FILE* member = NULL; pathchar *pathCopy, *dirName, *memberPath, *objFileName; memberPath = NULL; @@ -148,10 +192,9 @@ inner_fail: return has_succeeded; } -static StgBool checkFatArchive(char magic[static 20], FILE* f, pathchar* path) +static bool checkFatArchive(char magic[static 4], FILE* f, pathchar* path) { - StgBool success; - success = false; + bool success = false; #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) /* Not a standard archive, look for a fat archive magic number: */ if (read4Bytes(magic) == FAT_MAGIC) @@ -175,7 +218,7 @@ static StgBool checkFatArchive(char magic[static 20], FILE* f, pathchar* path) * be reallocated on return; the old value is now _invalid_. * @param gnuFileIndexSize The size of the index. */ -static StgBool +static bool lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, char* gnuFileIndex, pathchar* path, size_t* thisFileNameSize, size_t* fileNameSize) @@ -241,47 +284,21 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, return true; } -HsInt loadArchive_ (pathchar *path) -{ - char *image = NULL; - HsInt retcode = 0; - int memberSize; - int memberIdx = 0; - FILE *f = NULL; - int n; - size_t thisFileNameSize = (size_t)-1; /* shut up bogus GCC warning */ - char *fileName; - size_t fileNameSize; - int isObject, isGnuIndex, isThin, isImportLib; - char tmp[20]; - char *gnuFileIndex; - int gnuFileIndexSize; - int misalignment = 0; - - DEBUG_LOG("start\n"); - DEBUG_LOG("Loading archive `%" PATH_FMT "'\n", path); +enum ArchiveFormat { + StandardArchive, + ThinArchive, + FatArchive, +}; - /* Check that we haven't already loaded this archive. - Ignore requests to load multiple times */ - if (isAlreadyLoaded(path)) { - IF_DEBUG(linker, - debugBelch("ignoring repeated load of %" PATH_FMT "\n", path)); - return 1; /* success */ +static bool identifyArchiveFormat(FILE *f, pathchar *path, enum ArchiveFormat *out) +{ + char tmp[8]; + size_t n = fread(tmp, 1, 8, f); + if (n != 8) { + errorBelch("loadArchive: Failed reading header from `%" PATH_FMT "'", path); \ + return false; } - gnuFileIndex = NULL; - gnuFileIndexSize = 0; - - fileNameSize = 32; - fileName = stgMallocBytes(fileNameSize, "loadArchive(fileName)"); - - isThin = 0; - isImportLib = 0; - - f = pathopen(path, WSTR("rb")); - if (!f) - FAIL("loadObj: can't read `%" PATH_FMT "'", path); - /* Check if this is an archive by looking for the magic "!<arch>\n" * string. Usually, if this fails, we belch an error and return. On * Darwin however, we may have a fat archive, which contains archives for @@ -300,12 +317,10 @@ HsInt loadArchive_ (pathchar *path) * its magic "!<arch>\n" string and continue processing just as if * we had a single architecture archive. */ - - n = fread ( tmp, 1, 8, f ); - if (n != 8) { - FAIL("Failed reading header from `%" PATH_FMT "'", path); + if (strncmp(tmp, "!<arch>\n", 8) == 0) { + *out = StandardArchive; + return true; } - if (strncmp(tmp, "!<arch>\n", 8) == 0) {} /* Check if this is a thin archive by looking for the magic string "!<thin>\n" * * ar thin libraries have the exact same format as normal archives except they @@ -322,16 +337,59 @@ HsInt loadArchive_ (pathchar *path) * */ else if (strncmp(tmp, "!<thin>\n", 8) == 0) { - isThin = 1; + *out = ThinArchive; + return true; } else { - StgBool success = checkFatArchive(tmp, f, path); - if (!success) - goto fail; + bool success = checkFatArchive(tmp, f, path); + if (!success) { + return false; + } + *out = FatArchive; + return true; } +} + +HsInt loadArchive_ (pathchar *path) +{ + char *image = NULL; + HsInt retcode = 0; + int memberIdx = 0; + FILE *f = NULL; + size_t thisFileNameSize = (size_t) -1; /* shut up bogus GCC warning */ + int misalignment = 0; + + DEBUG_LOG("start\n"); + DEBUG_LOG("Loading archive `%" PATH_FMT "'\n", path); + + /* Check that we haven't already loaded this archive. + Ignore requests to load multiple times */ + if (isAlreadyLoaded(path)) { + IF_DEBUG(linker, + debugBelch("ignoring repeated load of %" PATH_FMT "\n", path)); + return 1; /* success */ + } + + char *gnuFileIndex = NULL; + int gnuFileIndexSize = 0; + + size_t fileNameSize = 32; + char *fileName = stgMallocBytes(fileNameSize, "loadArchive(fileName)"); + + f = pathopen(path, WSTR("rb")); + if (!f) + FAIL("loadObj: can't read `%" PATH_FMT "'", path); + + enum ArchiveFormat archive_fmt; + if (!identifyArchiveFormat(f, path, &archive_fmt)) { + FAIL("failed to identify archive format of %" PATH_FMT ".", path); + } + bool isThin = archive_fmt == ThinArchive; + DEBUG_LOG("loading archive contents\n"); while (1) { + size_t n; DEBUG_LOG("reading at %ld\n", ftell(f)); n = fread ( fileName, 1, 16, f ); if (n != 16) { @@ -351,6 +409,7 @@ HsInt loadArchive_ (pathchar *path) } #endif + char tmp[32]; n = fread ( tmp, 1, 12, f ); if (n != 12) FAIL("Failed reading mod time from `%" PATH_FMT "'", path); @@ -369,9 +428,16 @@ HsInt loadArchive_ (pathchar *path) tmp[10] = '\0'; for (n = 0; isdigit(tmp[n]); n++); tmp[n] = '\0'; - memberSize = atoi(tmp); + size_t memberSize; + { + char *end; + memberSize = strtol(tmp, &end, 10); + if (tmp == end) { + FAIL("Failed to decode member size"); + } + } - DEBUG_LOG("size of this archive member is %d\n", memberSize); + DEBUG_LOG("size of this archive member is %zd\n", memberSize); n = fread ( tmp, 1, 2, f ); if (n != 2) FAIL("Failed reading magic from `%" PATH_FMT "'", path); @@ -379,7 +445,7 @@ HsInt loadArchive_ (pathchar *path) FAIL("Failed reading magic from `%" PATH_FMT "' at %ld. Got %c%c", path, ftell(f), tmp[0], tmp[1]); - isGnuIndex = 0; + bool isGnuIndex = false; /* Check for BSD-variant large filenames */ if (0 == strncmp(fileName, "#1/", 3)) { size_t n = 0; @@ -419,7 +485,7 @@ HsInt loadArchive_ (pathchar *path) else if (0 == strncmp(fileName, "//", 2)) { fileName[0] = '\0'; thisFileNameSize = 0; - isGnuIndex = 1; + isGnuIndex = true; } /* Check for a file in the GNU file index */ else if (fileName[0] == '/') { @@ -460,12 +526,8 @@ HsInt loadArchive_ (pathchar *path) DEBUG_LOG("Found member file `%s'\n", fileName); - /* TODO: Stop relying on file extensions to determine input formats. - Instead try to match file headers. See #13103. */ - isObject = (thisFileNameSize >= 2 && strncmp(fileName + thisFileNameSize - 2, ".o" , 2) == 0) - || (thisFileNameSize >= 3 && strncmp(fileName + thisFileNameSize - 3, ".lo" , 3) == 0) - || (thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".p_o", 4) == 0) - || (thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".obj", 4) == 0); + bool is_symbol_table = strcmp("", fileName) == 0; + enum ObjectFileFormat object_fmt = is_symbol_table ? NotObject : identifyObjectFile(f); #if defined(OBJFORMAT_PEi386) /* @@ -479,15 +541,15 @@ HsInt loadArchive_ (pathchar *path) * * Linker members (e.g. filename / are skipped since they are not needed) */ - isImportLib = thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".dll", 4) == 0; + bool isImportLib = thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".dll", 4) == 0; +#else + bool isImportLib = false; #endif // windows DEBUG_LOG("\tthisFileNameSize = %d\n", (int)thisFileNameSize); - DEBUG_LOG("\tisObject = %d\n", isObject); - - if (isObject) { - pathchar *archiveMemberName; + DEBUG_LOG("\tisObject = %d\n", object_fmt); + if ((!is_symbol_table && isThin) || object_fmt != NotObject) { DEBUG_LOG("Member is an object file...loading...\n"); #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) @@ -505,14 +567,13 @@ HsInt loadArchive_ (pathchar *path) image = stgMallocBytes(memberSize, "loadArchive(image)"); #endif if (isThin) { - if (!readThinArchiveMember(n, memberSize, path, - fileName, image)) { + if (!readThinArchiveMember(n, memberSize, path, fileName, image)) { goto fail; } } else { - n = fread ( image, 1, memberSize, f ); + size_t n = fread ( image, 1, memberSize, f ); if (n != memberSize) { FAIL("error whilst reading `%" PATH_FMT "'", path); } @@ -523,16 +584,18 @@ HsInt loadArchive_ (pathchar *path) // I don't understand why this extra +1 is needed here; pathprintf // should have given us the correct length but in practice it seems // to be one byte short on Win32. - archiveMemberName = stgMallocBytes((size+1+1) * sizeof(pathchar), "loadArchive(file)"); + pathchar *archiveMemberName = stgMallocBytes((size+1+1) * sizeof(pathchar), "loadArchive(file)"); pathprintf(archiveMemberName, size+1, WSTR("%" PATH_FMT "(#%d:%.*s)"), path, memberIdx, (int)thisFileNameSize, fileName); ObjectCode *oc = mkOc(STATIC_OBJECT, path, image, memberSize, false, archiveMemberName, misalignment); #if defined(OBJFORMAT_MACHO) + ASSERT(object_fmt == MachO32 || object_fmt == MachO64); ocInit_MachO( oc ); #endif #if defined(OBJFORMAT_ELF) + ASSERT(object_fmt == ELF); ocInit_ELF( oc ); #endif @@ -577,7 +640,7 @@ while reading filename from `%" PATH_FMT "'", path); "Skipping...\n"); n = fseek(f, memberSize, SEEK_CUR); if (n != 0) - FAIL("error whilst seeking by %d in `%" PATH_FMT "'", + FAIL("error whilst seeking by %zd in `%" PATH_FMT "'", memberSize, path); } #endif @@ -588,7 +651,7 @@ while reading filename from `%" PATH_FMT "'", path); if (!isThin || thisFileNameSize == 0) { n = fseek(f, memberSize, SEEK_CUR); if (n != 0) - FAIL("error whilst seeking by %d in `%" PATH_FMT "'", + FAIL("error whilst seeking by %zd in `%" PATH_FMT "'", memberSize, path); } } ===================================== utils/ghc-toolchain/exe/Main.hs ===================================== @@ -52,7 +52,12 @@ data Opts = Opts , optNm :: ProgOpt , optReadelf :: ProgOpt , optMergeObjs :: ProgOpt + , optLlc :: ProgOpt + , optOpt :: ProgOpt + , optLlvmAs :: ProgOpt , optWindres :: ProgOpt + , optOtool :: ProgOpt + , optInstallNameTool :: ProgOpt -- Note we don't actually configure LD into anything but -- see #23857 and #22550 for the very unfortunate story. , optLd :: ProgOpt @@ -99,8 +104,13 @@ emptyOpts = Opts , optNm = po0 , optReadelf = po0 , optMergeObjs = po0 + , optLlc = po0 + , optOpt = po0 + , optLlvmAs = po0 , optWindres = po0 , optLd = po0 + , optOtool = po0 + , optInstallNameTool = po0 , optUnregisterised = Nothing , optTablesNextToCode = Nothing , optUseLibFFIForAdjustors = Nothing @@ -112,7 +122,8 @@ emptyOpts = Opts po0 = emptyProgOpt _optCc, _optCxx, _optCpp, _optHsCpp, _optJsCpp, _optCmmCpp, _optCcLink, _optAr, - _optRanlib, _optNm, _optReadelf, _optMergeObjs, _optWindres, _optLd + _optRanlib, _optNm, _optReadelf, _optMergeObjs, _optLlc, _optOpt, _optLlvmAs, + _optWindres, _optLd, _optOtool, _optInstallNameTool :: Lens Opts ProgOpt _optCc = Lens optCc (\x o -> o {optCc=x}) _optCxx = Lens optCxx (\x o -> o {optCxx=x}) @@ -126,8 +137,13 @@ _optRanlib = Lens optRanlib (\x o -> o {optRanlib=x}) _optNm = Lens optNm (\x o -> o {optNm=x}) _optReadelf = Lens optReadelf (\x o -> o {optReadelf=x}) _optMergeObjs = Lens optMergeObjs (\x o -> o {optMergeObjs=x}) +_optLlc = Lens optLlc (\x o -> o {optLlc=x}) +_optOpt = Lens optOpt (\x o -> o {optOpt=x}) +_optLlvmAs = Lens optLlvmAs (\x o -> o {optLlvmAs=x}) _optWindres = Lens optWindres (\x o -> o {optWindres=x}) -_optLd = Lens optLd (\x o -> o {optLd= x}) +_optLd = Lens optLd (\x o -> o {optLd=x}) +_optOtool = Lens optOtool (\x o -> o {optOtool=x}) +_optInstallNameTool = Lens optInstallNameTool (\x o -> o {optInstallNameTool=x}) _optTriple :: Lens Opts (Maybe String) _optTriple = Lens optTriple (\x o -> o {optTriple=x}) @@ -183,8 +199,13 @@ options = , progOpts "nm" "nm archiver" _optNm , progOpts "readelf" "readelf utility" _optReadelf , progOpts "merge-objs" "linker for merging objects" _optMergeObjs + , progOpts "llc" "LLVM llc utility" _optLlc + , progOpts "opt" "LLVM opt utility" _optOpt + , progOpts "llvm-as" "Assembler used for LLVM backend (typically clang)" _optLlvmAs , progOpts "windres" "windres utility" _optWindres , progOpts "ld" "linker" _optLd + , progOpts "otool" "otool utility" _optOtool + , progOpts "install-name-tool" "install-name-tool utility" _optInstallNameTool ] where progOpts :: String -> String -> Lens Opts ProgOpt -> [OptDescr (Opts -> Opts)] @@ -436,6 +457,11 @@ mkTarget opts = do when (isNothing mergeObjs && not (arSupportsDashL ar)) $ throwE "Neither a object-merging tool (e.g. ld -r) nor an ar that supports -L is available" + -- LLVM toolchain + llc <- optional $ findProgram "llc" (optLlc opts) ["llc"] + opt <- optional $ findProgram "opt" (optOpt opts) ["opt"] + llvmAs <- optional $ findProgram "llvm assembler" (optLlvmAs opts) ["clang"] + -- Windows-specific utilities windres <- case archOS_OS archOs of @@ -444,6 +470,15 @@ mkTarget opts = do return (Just windres) _ -> return Nothing + -- Darwin-specific utilities + (otool, installNameTool) <- + case archOS_OS archOs of + OSDarwin -> do + otool <- findProgram "otool" (optOtool opts) ["otool"] + installNameTool <- findProgram "install_name_tool" (optInstallNameTool opts) ["install_name_tool"] + return (Just otool, Just installNameTool) + _ -> return (Nothing, Nothing) + -- various other properties of the platform tgtWordSize <- checkWordSize cc tgtEndianness <- checkEndianness cc @@ -480,7 +515,12 @@ mkTarget opts = do , tgtRanlib = ranlib , tgtNm = nm , tgtMergeObjs = mergeObjs + , tgtLlc = llc + , tgtOpt = opt + , tgtLlvmAs = llvmAs , tgtWindres = windres + , tgtOtool = otool + , tgtInstallNameTool = installNameTool , tgtWordSize , tgtEndianness , tgtUnregisterised ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Target.hs ===================================== @@ -22,15 +22,6 @@ data WordSize = WS4 | WS8 data Endianness = LittleEndian | BigEndian deriving (Show, Read, Eq, Ord) --- TODO(#23674): Move the remaining relevant `settings-xxx` to Target: --- * llc command --- * opt command --- * install_name_tool --- * otool command --- --- Those are all things that are put into GHC's settings, and that might be --- different across targets - -- | A 'Target' consists of: -- -- * a target architecture and operating system @@ -72,8 +63,18 @@ data Target = Target , tgtMergeObjs :: Maybe MergeObjs -- ^ We don't need a merge objects tool if we @Ar@ supports @-L@ + -- LLVM backend toolchain + , tgtLlc :: Maybe Program + , tgtOpt :: Maybe Program + , tgtLlvmAs :: Maybe Program + -- ^ assembler used to assemble LLVM backend output; typically @clang@ + -- Windows-specific tools , tgtWindres :: Maybe Program + + -- Darwin-specific tools + , tgtOtool :: Maybe Program + , tgtInstallNameTool :: Maybe Program } deriving (Read, Eq, Ord) @@ -121,6 +122,11 @@ instance Show Target where , ", tgtRanlib = " ++ show tgtRanlib , ", tgtNm = " ++ show tgtNm , ", tgtMergeObjs = " ++ show tgtMergeObjs + , ", tgtLlc = " ++ show tgtLlc + , ", tgtOpt = " ++ show tgtOpt + , ", tgtLlvmAs = " ++ show tgtLlvmAs , ", tgtWindres = " ++ show tgtWindres + , ", tgtOtool = " ++ show tgtOtool + , ", tgtInstallNameTool = " ++ show tgtInstallNameTool , "}" ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f09c251941ecbb870828fbb7763fe0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f09c251941ecbb870828fbb7763fe0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] 28 commits: Move ModuleGraph into UnitEnv
by Apoorv Ingle (＠ani) 23 Jun '25

23 Jun '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 0fb37893 by Matthew Pickering at 2025-06-23T13:55:10-04:00 Move ModuleGraph into UnitEnv The ModuleGraph is a piece of information associated with the ExternalPackageState and HomeUnitGraph. Therefore we should store it inside the HomeUnitEnv. - - - - - 3bf6720e by soulomoon at 2025-06-23T13:55:52-04:00 Remove hptAllFamInstances usage during upsweep Fixes #26118 This change eliminates the use of hptAllFamInstances during the upsweep phase, as it could access non-below modules from the home package table. The following updates were made: * Updated checkFamInstConsistency to accept an explicit ModuleEnv FamInstEnv parameter and removed the call to hptAllFamInstances. * Adjusted hugInstancesBelow so we can construct ModuleEnv FamInstEnv from its result, * hptAllFamInstances and allFamInstances functions are removed. - - - - - 4cd6429d by Apoorv Ingle at 2025-06-23T17:53:11-05:00 - Remove one `SrcSpan` field from `VAExpansion`. It is no longer needed. - Make `tcExpr` take a `Maybe HsThingRn` which will be passed on to tcApp and used by splitHsApps to determine a more accurate `AppCtx` - `tcXExpr` is less hacky now - do not look through HsExpansion applications - kill OrigPat and remove HsThingRn From VAExpansion - look through XExpr ExpandedThingRn while inferring type of head - always set in generated code after stepping inside a ExpandedThingRn - fixing record update error messages - remove special case of tcbody from tcLambdaMatches - wrap last stmt expansion in a HsPar so that the error messages are prettier - remove special case of dsExpr for ExpandedThingTc - make EExpand (HsExpr GhcRn) instead of EExpand HsThingRn - fixing error messages for rebindable - - - - - fe55834b by Apoorv Ingle at 2025-06-23T17:53:11-05:00 some progress on tick - - - - - a258d0e7 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 remove adhoc cases from ticks - - - - - a620300b by Apoorv Ingle at 2025-06-23T17:53:11-05:00 fix the case where head of the application chain is an expanded expression and the argument is a type application c.f. T19167.hs - - - - - 0eba8097 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 move setQLInstLevel inside tcInstFun - - - - - ab6d8ea9 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 ignore ds warnings originating from gen locations - - - - - bcfecf7e by Apoorv Ingle at 2025-06-23T17:53:11-05:00 filter expr stmts error msgs - - - - - 2f877d2f by Apoorv Ingle at 2025-06-23T17:53:11-05:00 exception for AppDo while making error ctxt - - - - - d8e66ef2 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 moving around things for locations and error ctxts - - - - - 001515a0 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 popErrCtxt doesn't push contexts and popErrCtxts in the first argument to bind and >> in do expansion statements - - - - - c3e320f3 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 accept test cases with changed error messages ------------------------- Metric Decrease: T9020 ------------------------- - - - - - 8a34d35f by Apoorv Ingle at 2025-06-23T17:53:11-05:00 look through PopErrCtxt while splitting exprs in application chains - - - - - 6a3fd9ce by Apoorv Ingle at 2025-06-23T17:53:11-05:00 remove special case for HsExpanded in Ticks - - - - - d7b17d49 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 check the right origin for record selector incomplete warnings - - - - - d5895136 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 kill VAExpansion - - - - - 84731698 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 pass CtOrigin to tcApp for instantiateSigma - - - - - 9a7dcbca by Apoorv Ingle at 2025-06-23T17:53:11-05:00 do not suppress pprArising - - - - - 8a6b5771 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 kill VACall - - - - - c538fa76 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 kill AppCtxt - - - - - 82fbc450 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 remove addHeadCtxt - - - - - 875ba420 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 fix pprArising for MonadFailErrors - - - - - 4b6cdbc9 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 rename ctxt to sloc - - - - - aa53551b by Apoorv Ingle at 2025-06-23T17:53:11-05:00 fix RepPolyDoBind error message herald - - - - - a347731a by Apoorv Ingle at 2025-06-23T17:53:11-05:00 SrcCodeCtxt more changes - - - - - ef425b46 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 make tcl_in_gen_code a SrcCodeCtxt and rename DoOrigin to DoStmtOrigin - - - - - 72820354 by Apoorv Ingle at 2025-06-23T17:53:11-05:00 make error messages for records saner - - - - - 58 changed files: - compiler/GHC.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - + compiler/GHC/Tc/Gen/App.hs-boot - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Home/Graph.hs - compiler/GHC/Unit/Home/PackageTable.hs - ghc/GHCi/UI.hs - testsuite/tests/deSugar/should_compile/T10662.stderr - testsuite/tests/deSugar/should_compile/T3263-1.stderr - testsuite/tests/deSugar/should_compile/T3263-2.stderr - testsuite/tests/default/default-fail05.stderr - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/indexed-types/should_fail/T5439.stderr - testsuite/tests/plugins/test-defaulting-plugin.stderr - testsuite/tests/polykinds/T13393.stderr - testsuite/tests/printer/T17697.stderr - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - testsuite/tests/typecheck/should_fail/T24064.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T3613.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/tcfail102.stderr - testsuite/tests/typecheck/should_fail/tcfail128.stderr - testsuite/tests/typecheck/should_fail/tcfail168.stderr - testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b61531f23e4885ff8065480f7672a0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b61531f23e4885ff8065480f7672a0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] make tcl_in_gen_code a SrcCodeCtxt and rename DoOrigin to DoStmtOrigin
by Apoorv Ingle (＠ani) 23 Jun '25

23 Jun '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: b61531f2 by Apoorv Ingle at 2025-06-23T17:42:30-05:00 make tcl_in_gen_code a SrcCodeCtxt and rename DoOrigin to DoStmtOrigin - - - - - 5 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/App.hs-boot - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Types/Origin.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -410,7 +410,6 @@ tcApp rn_expr exp_res_ty vcat [ text "rn_expr:" <+> ppr rn_expr , text "rn_fun:" <+> ppr rn_fun , text "fun_loc:" <+> ppr fun_loc - , text "orig:" <+> ppr fun_orig , text "rn_args:" <+> ppr rn_args ] -- Step 2: Infer the type of `fun`, the head of the application @@ -418,12 +417,13 @@ tcApp rn_expr exp_res_ty ; let tc_head = (tc_fun, fun_loc) -- Step 3: Instantiate the function type (taking a quick look at args) ; do_ql <- wantQuickLook rn_fun + ; code_ctxt <- getSrcCodeCtxt + ; let fun_orig = srcCodeCtxtCtOrigin rn_fun code_ctxt ; traceTc "tcApp:inferAppHead" $ vcat [ text "tc_fun:" <+> ppr tc_fun , text "fun_sigma:" <+> ppr fun_sigma + , text "fun_origin" <+> ppr fun_orig , text "do_ql:" <+> ppr do_ql] - ; code_ctxt <- getSrcCodeCtxt - ; let fun_orig = srcCodeCtxtCtOrigin rn_fun code_ctxt ; (inst_args, app_res_rho) <- tcInstFun do_ql True fun_orig (tc_fun, rn_fun, fun_loc) fun_sigma rn_args @@ -857,7 +857,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args -- Rule IARG from Fig 4 of the QL paper: go1 pos acc fun_ty (EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args) - = do { let herald | DoOrigin <- fun_orig = ExpectedFunTySyntaxOp fun_orig tc_fun -- cf. RepPolyDoBind.hs + = do { let herald | DoStmtOrigin <- fun_orig = ExpectedFunTySyntaxOp fun_orig tc_fun -- cf. RepPolyDoBind.hs | otherwise = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg) ; (wrap, arg_ty, res_ty) <- -- NB: matchActualFunTy does the rep-poly check. ===================================== compiler/GHC/Tc/Gen/App.hs-boot ===================================== @@ -2,10 +2,9 @@ module GHC.Tc.Gen.App where import GHC.Hs ( HsExpr ) import GHC.Tc.Types ( TcM ) -import GHC.Tc.Types.Origin ( CtOrigin ) import GHC.Tc.Utils.TcType ( TcSigmaType ) import GHC.Hs.Extension ( GhcRn, GhcTc ) import GHC.Prelude (Bool) -tcExprSigma :: Bool -> CtOrigin -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) \ No newline at end of file +tcExprSigma :: Bool -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) \ No newline at end of file ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -114,10 +114,9 @@ tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty) tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) -tcPolyLExpr e@(L loc expr) res_ty - = setUserCodeCtxt (ExprThing e) $ - -- setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad - -- addExprCtxt expr $ -- Note [Error contexts in generated code] +tcPolyLExpr (L loc expr) res_ty + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } @@ -747,7 +746,7 @@ tcXExpr (PopErrCtxt e) res_ty addExprCtxt e $ tcExpr e res_ty -tcXExpr xe@(ExpandedThingRn o e) res_ty +tcXExpr (ExpandedThingRn o e) res_ty = mkExpandedTc o <$> -- necessary for breakpoints do setInGeneratedCode o $ tcExpr e res_ty ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -980,7 +980,7 @@ tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside -- in full generality; see #1537 ((rhs_ty, rhs', pat_mult, pat', new_res_ty, thing), bind_op') - <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $ + <- tcSyntaxOp DoStmtOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $ \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult,fun_mult,pat_mult] -> do { rhs' <-tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $ @@ -1004,7 +1004,7 @@ tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside = do { -- Deal with rebindable syntax; -- (>>) :: rhs_ty -> new_res_ty -> res_ty ; ((rhs', rhs_ty, new_res_ty, thing), then_op') - <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $ + <- tcSyntaxOp DoStmtOrigin then_op [SynRho, SynRho] res_ty $ \ [rhs_ty, new_res_ty] [rhs_mult,fun_mult] -> do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty) @@ -1031,18 +1031,18 @@ tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names -- Unify the types of the "final" Ids (which may -- be polymorphic) with those of "knot-tied" Ids ; (_, ret_op') - <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty] + <- tcSyntaxOp DoStmtOrigin ret_op [synKnownType tup_ty] inner_res_ty $ \_ _ -> return () ; return (ret_op', tup_rets) } ; ((_, mfix_op'), mfix_res_ty) <- tcInfer $ \ exp_ty -> - tcSyntaxOp DoOrigin mfix_op + tcSyntaxOp DoStmtOrigin mfix_op [synKnownType (mkVisFunTyMany tup_ty stmts_ty)] exp_ty $ \ _ _ -> return () ; ((thing, new_res_ty), bind_op') - <- tcSyntaxOp DoOrigin bind_op + <- tcSyntaxOp DoStmtOrigin bind_op [ synKnownType mfix_res_ty , SynFun (synKnownType tup_ty) SynRho ] res_ty $ @@ -1071,7 +1071,7 @@ tcDoStmt ctxt (XStmtLR (ApplicativeStmt _ pairs mb_join)) res_ty thing_inside Nothing -> (, Nothing) <$> tc_app_stmts res_ty Just join_op -> second Just <$> - (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ + (tcSyntaxOp DoStmtOrigin join_op [SynRho] res_ty $ \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty)) ; return (XStmtLR $ ApplicativeStmt body_ty pairs' mb_join', thing) } @@ -1188,7 +1188,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside goOps _ [] = return [] goOps t_left ((op,t_i,exp_ty) : ops) = do { (_, op') - <- tcSyntaxOp DoOrigin op + <- tcSyntaxOp DoStmtOrigin op [synKnownType t_left, synKnownType exp_ty] t_i $ \ _ _ -> return () ; t_i <- readExpType t_i ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -588,7 +588,7 @@ data CtOrigin -- See Note [Inferring the instance context] -- in GHC.Tc.Deriv.Infer | DefaultOrigin -- Typechecking a default decl - | DoOrigin -- Arising from a do expression + | DoStmtOrigin -- Arising from a do expression | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in -- a do expression | MCompOrigin -- Arising from a monad comprehension @@ -746,7 +746,7 @@ exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches exprCtOrigin (HsIf {}) = IfThenElseOrigin exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e -exprCtOrigin (HsDo {}) = DoOrigin +exprCtOrigin (HsDo {}) = DoStmtOrigin exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" exprCtOrigin (RecordUpd {}) = RecordUpdOrigin exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin @@ -769,7 +769,7 @@ exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) hsThingCtOrigin :: HsThingRn -> CtOrigin hsThingCtOrigin (OrigExpr e) = exprCtOrigin e -hsThingCtOrigin (OrigStmt{}) = DoOrigin +hsThingCtOrigin (OrigStmt{}) = DoStmtOrigin hsThingCtOrigin (OrigPat p) = DoPatOrigin p srcCodeCtxtCtOrigin :: HsExpr GhcRn -> SrcCodeCtxt -> CtOrigin @@ -940,7 +940,7 @@ pprCtO (ScOrigin (IsQC {}) _) = text "the head of a quantified constraint" pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration" pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" pprCtO DefaultOrigin = text "a 'default' declaration" -pprCtO DoOrigin = text "a do statement" +pprCtO DoStmtOrigin = text "a do statement" pprCtO MCompOrigin = text "a statement in a monad comprehension" pprCtO ProcOrigin = text "a proc expression" pprCtO ArrowCmdOrigin = text "an arrow command" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b61531f23e4885ff8065480f7672a02… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b61531f23e4885ff8065480f7672a02… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26115] Wibbles [skip ci]
by Simon Peyton Jones (＠simonpj) 23 Jun '25

23 Jun '25

Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 73f3d1a9 by Simon Peyton Jones at 2025-06-23T23:40:01+01:00 Wibbles [skip ci] - - - - - 3 changed files: - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -481,9 +481,8 @@ can_eq_nc_forall ev eq_rel s1 s2 , ppr flags1, ppr flags2 ] ; canEqHardFailure ev s1 s2 } - else do { - traceTcS "Creating implication for polytype equality" (ppr ev) - ; let free_tvs = tyCoVarsOfTypes [s1,s2] + else + do { let free_tvs = tyCoVarsOfTypes [s1,s2] empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs skol_info_anon = UnifyForAllSkol phi1 ; skol_info <- mkSkolemInfo skol_info_anon @@ -525,12 +524,15 @@ can_eq_nc_forall ev eq_rel s1 s2 init_subst2 = mkEmptySubst (substInScopeSet subst1) + ; traceTcS "Generating wanteds" (ppr s1 $$ ppr s2) + -- Generate the constraints that live in the body of the implication -- See (SF5) in Note [Solving forall equalities] ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ unifyForAllBody ev (eqRelRole eq_rel) $ \uenv -> go uenv skol_tvs init_subst2 bndrs1 bndrs2 + ; traceTcS "Trying to solve the immplication" (ppr s1 $$ ppr s2 $$ ppr wanteds) ; ev_binds_var <- newNoTcEvBinds ; solved <- trySolveImplication $ (implicationPrototype (ctLocEnv loc)) ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -1363,7 +1363,10 @@ tryTcS (TcS thing_inside) , tcs_inerts = new_inert_var , tcs_worklist = new_wl_var } - ; TcM.traceTc "tryTcS {" (ppr old_inerts) + ; TcM.traceTc "tryTcS {" $ + vcat [ text "old_ev_binds:" <+> ppr old_ev_binds_var + , text "new_ev_binds:" <+> ppr new_ev_binds_var + , ppr old_inerts ] ; wc <- thing_inside nest_env ; TcM.traceTc "tryTcS }" (ppr wc) @@ -1371,8 +1374,7 @@ tryTcS (TcS thing_inside) then return False else do { -- Successfully solved -- Add the new bindings to the existing ones - new_ev_binds <- TcM.getTcEvBindsMap new_ev_binds_var - ; TcM.updTcEvBindsMap old_ev_binds_var (`unionEvBindMap` new_ev_binds) + ; TcM.updTcEvBinds old_ev_binds_var new_ev_binds_var -- Update the existing inert set ; new_inerts <- TcM.readTcRef new_inert_var ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -102,7 +102,7 @@ module GHC.Tc.Utils.Monad( -- * Type constraints newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar, addTcEvBind, addTcEvBinds, addTopEvBinds, - getTcEvBindsMap, setTcEvBindsMap, updTcEvBindsMap, + getTcEvBindsMap, setTcEvBindsMap, updTcEvBinds, getTcEvTyCoVars, chooseUniqueOccTc, getConstraintVar, setConstraintVar, emitConstraints, emitStaticConstraints, emitSimple, emitSimples, @@ -1811,11 +1811,24 @@ setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds | otherwise = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds) -updTcEvBindsMap :: EvBindsVar -> (EvBindMap -> EvBindMap) -> TcM () -updTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) upd - = updTcRef ev_ref upd -updTcEvBindsMap v@(CoEvBindsVar {}) _ - = pprPanic "updTcEvBindsMap" (ppr v) +updTcEvBinds :: EvBindsVar -> EvBindsVar -> TcM () +updTcEvBinds (EvBindsVar { ebv_binds = old_ebv_ref, ebv_tcvs = old_tcv_ref }) + (EvBindsVar { ebv_binds = new_ebv_ref, ebv_tcvs = new_tcv_ref }) + = do { new_ebvs <- readTcRef new_ebv_ref + ; updTcRef old_ebv_ref (`unionEvBindMap` new_ebvs) + ; new_tcvs <- readTcRef new_tcv_ref + ; updTcRef old_tcv_ref (`unionVarSet` new_tcvs) } +updTcEvBinds (EvBindsVar { ebv_tcvs = old_tcv_ref }) + (CoEvBindsVar { ebv_tcvs = new_tcv_ref }) + = do { new_tcvs <- readTcRef new_tcv_ref + ; updTcRef old_tcv_ref (`unionVarSet` new_tcvs) } +updTcEvBinds (CoEvBindsVar { ebv_tcvs = old_tcv_ref }) + (CoEvBindsVar { ebv_tcvs = new_tcv_ref }) + = do { new_tcvs <- readTcRef new_tcv_ref + ; updTcRef old_tcv_ref (`unionVarSet` new_tcvs) } +updTcEvBinds old_var new_var + = pprPanic "updTcEvBinds" (ppr old_var $$ ppr new_var) + -- Terms inside types, no good addTcEvBind :: EvBindsVar -> EvBind -> TcM () -- Add a binding to the TcEvBinds by side effect View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/73f3d1a93021137ec47e9f01522ba06… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/73f3d1a93021137ec47e9f01522ba06… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] 36 commits: MachRegs.h: Don't define NO_ARG_REGS when a XMM register is defined
by Apoorv Ingle (＠ani) 23 Jun '25

23 Jun '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: e64b3f16 by ARATA Mizuki at 2025-06-17T10:13:42+09:00 MachRegs.h: Don't define NO_ARG_REGS when a XMM register is defined On i386, MAX_REAL_VANILLA_REG is 1, but MAX_REAL_XMM_REG is 4. If we define NO_ARG_REGS on i386, programs that use SIMD vectors may segfault. Closes #25985 A couple of notes on the BROKEN_TESTS field: * This fixes the segfault from T25062_V16. * The failure from T22187_run was fixed in an earlier commit (see #25561), but BROKEN_TESTS was missed at that time. Now should be a good time to mark it fixed. - - - - - 3e7c6b4d by Matthew Pickering at 2025-06-18T15:34:04-04:00 Improve error messages when implicit lifting fails This patch concerns programs which automatically try to fix level errors by inserting `Lift`. For example: ``` foo x = [| x |] ~> foo x = [| $(lift x) |] ``` Before, there were two problems with the message. 1. (#26031), the location of the error was reported as the whole quotation. 2. (#26035), the message just mentions there is no Lift instance, but gives no indicate why the user program needed a Lift instance in the first place. This problem is especially bad when you disable `ImplicitStagePersistence`, so you just end up with a confusing "No instance for" message rather than an error message about levels This patch fixes both these issues. Firstly, `PendingRnSplice` differentiates between a user-written splice and an implicit lift. Then, the Lift instance is precisely requested with a specific origin in the typechecker. If the instance fails to be solved, the message is reported using the `TcRnBadlyLevelled` constructor (like a normal level error). Fixes #26031, #26035 - - - - - 44b8cee2 by Cheng Shao at 2025-06-18T15:34:46-04:00 testsuite: add T26120 marked as broken - - - - - 894a04f3 by Cheng Shao at 2025-06-18T15:34:46-04:00 compiler: fix GHC.SysTools.Ar archive member size writing logic This patch fixes a long-standing bug in `GHC.SysTools.Ar` that emits the wrong archive member size in each archive header. It should encode the exact length of the member payload, excluding any padding byte, otherwise malformed archive that extracts a broken object with an extra trailing byte could be created. Apart from the in-tree `T26120` test, I've also created an out-of-tree testsuite at https://github.com/TerrorJack/ghc-ar-quickcheck that contains QuickCheck roundtrip tests for `GHC.SysTools.Ar`. With this fix, simple roundtrip tests and `writeGNUAr`/GNU `ar` roundtrip test passes. There might be more bugs lurking in here, but this patch is still a critical bugfix already. Fixes #26120 #22586. Co-authored-by: Codex <codex(a)openai.com> - - - - - f677ab5f by Lauren Yim at 2025-06-18T15:35:37-04:00 fix some typos in the warnings page in the user guide - - - - - b968e1c1 by Rodrigo Mesquita at 2025-06-18T15:36:18-04:00 Add a frozen callstack to throwGhcException Fixes #25956 - - - - - a5e0c3a3 by fendor at 2025-06-18T15:36:59-04:00 Update using.rst to advertise full mhu support for GHCi - - - - - d3e60e97 by Ryan Scott at 2025-06-18T22:29:21-04:00 Deprecate -Wdata-kinds-tc, make DataKinds issues in typechecker become errors !11314 introduced the `-Wdata-kinds-tc` warning as part of a fix for #22141. This was a temporary stopgap measure to allow users who were accidentally relying on code which needed the `DataKinds` extension in order to typecheck without having to explicitly enable the extension. Now that some amount of time has passed, this patch deprecates `-Wdata-kinds-tc` and upgrades any `DataKinds`-related issues in the typechecker (which were previously warnings) into errors. - - - - - fd5b5177 by Ryan Hendrickson at 2025-06-18T22:30:06-04:00 haddock: Add redact-type-synonyms pragma `{-# OPTIONS_HADDOCK redact-type-synonyms #-}` pragma will hide the RHS of type synonyms, and display the result kind instead, if the RHS contains any unexported types. - - - - - fbc0b92a by Vladislav Zavialov at 2025-06-22T04:25:16+03:00 Visible forall in GADTs (#25127) Add support for visible dependent quantification `forall a -> t` in types of data constructors, e.g. data KindVal a where K :: forall k. forall (a::k) -> -- now allowed! k -> KindVal a For details, see docs/users_guide/exts/required_type_arguments.rst, which has gained a new subsection. DataCon in compiler/GHC/Core/DataCon.hs --------------------------------------- The main change in this patch is that DataCon, the Core representation of a data constructor, now uses a different type to store user-written type variable binders: - dcUserTyVarBinders :: [InvisTVBinder] + dcUserTyVarBinders :: [TyVarBinder] where type TyVarBinder = VarBndr TyVar ForAllTyFlag type InvisTVBinder = VarBndr TyVar Specificity and data Specificity = InferredSpec | SpecifiedSpec data ForAllTyFlag = Invisible Specificity | Required This change necessitates some boring, mechanical changes scattered throughout the diff: ... is now used in place of ... -----------------+--------------- TyVarBinder | InvisTVBinder IfaceForAllBndr | IfaceForAllSpecBndr Specified | SpecifiedSpec Inferred | InferredSpec mkForAllTys | mkInvisForAllTys additionally, tyVarSpecToBinders -- added or removed calls ifaceForAllSpecToBndrs -- removed calls Visibility casts in mkDataConRep -------------------------------- Type abstractions in Core (/\a. e) always have type (forall a. t) because coreTyLamForAllTyFlag = Specified. This is also true of data constructor workers. So we may be faced with the following: data con worker: (forall a. blah) data con wrapper: (forall a -> blah) In this case the wrapper must use a visibility cast (e |> ForAllCo ...) with appropriately set fco_vis{L,R}. Relevant functions: mkDataConRep in compiler/GHC/Types/Id/Make.hs dataConUserTyVarBindersNeedWrapper in compiler/GHC/Core/DataCon.hs mkForAllVisCos in compiler/GHC/Core/Coercion.hs mkCoreTyLams in compiler/GHC/Core/Make.hs mkWpForAllCast in compiler/GHC/Tc/Types/Evidence.hs More specifically: - dataConUserTyVarBindersNeedWrapper has been updated to answer "yes" if there are visible foralls in the type of the data constructor. - mkDataConRep now uses mkCoreTyLams to generate the big lambda abstractions (/\a b c. e) in the data con wrapper. - mkCoreTyLams is a variant of mkCoreLams that applies visibility casts as needed. It similar in purpose to the pre-existing mkWpForAllCast, so the common bits have been factored out into mkForAllVisCos. ConDecl in compiler/Language/Haskell/Syntax/Decls.hs ---------------------------------------------------- The surface syntax representation of a data constructor declaration is ConDecl. In accordance with the proposal, only GADT syntax is extended with support for visible forall, so we are interested in ConDeclGADT. ConDeclGADT's field con_bndrs has been renamed to con_outer_bndrs and is now accompanied by con_inner_bndrs: con_outer_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass) con_inner_bndrs :: [HsForAllTelescope pass] Visible foralls always end up in con_inner_bndrs. The outer binders are stored and processed separately to support implicit quantification and the forall-or-nothing rule, a design established by HsSigType. A side effect of this change is that even in absence of visible foralls, GHC now permits multiple invisible foralls, e.g. data T a where { MkT :: forall a b. forall c d. ... -> T a } But of course, this is done in service of making at least some of these foralls visible. The entire compiler front-end has been updated to deal with con_inner_bndrs. See the following modified or added functions: Parser: mkGadtDecl in compiler/GHC/Parser/PostProcess.hs splitLHsGadtTy in compiler/GHC/Hs/Type.hs Pretty-printer: pprConDecl in compiler/GHC/Hs/Decls.hs pprHsForAllTelescope in compiler/GHC/Hs/Type.hs Renamer: rnConDecl in compiler/GHC/Rename/Module.hs bindHsForAllTelescopes in compiler/GHC/Rename/HsType.hs extractHsForAllTelescopes in compiler/GHC/Rename/HsType.hs Type checker: tcConDecl in compiler/GHC/Tc/TyCl.hs tcGadtConTyVarBndrs in compiler/GHC/Tc/Gen/HsType.hs Template Haskell ---------------- The TH AST is left unchanged for the moment to avoid breakage. An attempt to quote or reify a data constructor declaration with visible forall in its type will result an error: data ThRejectionReason -- in GHC/HsToCore/Errors/Types.hs = ... | ThDataConVisibleForall -- new error constructor However, as noted in the previous section, GHC now permits multiple invisible foralls, and TH was updated accordingly. Updated code: repC in compiler/GHC/HsToCore/Quote.hs reifyDataCon in compiler/GHC/Tc/Gen/Splice.hs ppr @Con in libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs Pattern matching ---------------- Everything described above concerns data constructor declarations, but what about their use sites? Now it is trickier to type check a pattern match fn(Con a b c)=... because we can no longer assume that a,b,c are all value arguments. Indeed, some or all of them may very well turn out to be required type arguments. To that end, see the changes to: tcDataConPat in compiler/GHC/Tc/Gen/Pat.hs splitConTyArgs in compiler/GHC/Tc/Gen/Pat.hs and the new helpers split_con_ty_args, zip_pats_bndrs. This is also the reason the TcRnTooManyTyArgsInConPattern error constructor has been removed. The new code emits TcRnArityMismatch or TcRnIllegalInvisibleTypePattern. Summary ------- DataCon, ConDecl, as well as all related functions have been updated to support required type arguments in data constructors. Test cases: HieGadtConSigs GadtConSigs_th_dump1 GadtConSigs_th_pprint1 T25127_data T25127_data_inst T25127_infix T25127_newtype T25127_fail_th_quote T25127_fail_arity TyAppPat_Tricky Co-authored-by: mniip <mniip(a)mniip.com> - - - - - ae003a3a by Teo Camarasu at 2025-06-23T05:21:48-04:00 linters: lint-whitespace: bump upper-bound for containers The version of containers was bumped in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13989 - - - - - 1f1c2b63 by Apoorv Ingle at 2025-06-23T12:10:51-05:00 - Remove one `SrcSpan` field from `VAExpansion`. It is no longer needed. - Make `tcExpr` take a `Maybe HsThingRn` which will be passed on to tcApp and used by splitHsApps to determine a more accurate `AppCtx` - `tcXExpr` is less hacky now - do not look through HsExpansion applications - kill OrigPat and remove HsThingRn From VAExpansion - look through XExpr ExpandedThingRn while inferring type of head - always set in generated code after stepping inside a ExpandedThingRn - fixing record update error messages - remove special case of tcbody from tcLambdaMatches - wrap last stmt expansion in a HsPar so that the error messages are prettier - remove special case of dsExpr for ExpandedThingTc - make EExpand (HsExpr GhcRn) instead of EExpand HsThingRn - fixing error messages for rebindable - - - - - 1835148b by Apoorv Ingle at 2025-06-23T12:10:51-05:00 some progress on tick - - - - - 6b8722cb by Apoorv Ingle at 2025-06-23T12:10:51-05:00 remove adhoc cases from ticks - - - - - b55fcb1c by Apoorv Ingle at 2025-06-23T12:10:51-05:00 fix the case where head of the application chain is an expanded expression and the argument is a type application c.f. T19167.hs - - - - - c66ace87 by Apoorv Ingle at 2025-06-23T12:10:51-05:00 move setQLInstLevel inside tcInstFun - - - - - fd05047f by Apoorv Ingle at 2025-06-23T12:10:51-05:00 ignore ds warnings originating from gen locations - - - - - af54d265 by Apoorv Ingle at 2025-06-23T12:10:51-05:00 filter expr stmts error msgs - - - - - 2ee245fd by Apoorv Ingle at 2025-06-23T12:10:51-05:00 exception for AppDo while making error ctxt - - - - - d6f6f649 by Apoorv Ingle at 2025-06-23T12:10:51-05:00 moving around things for locations and error ctxts - - - - - 78f91709 by Apoorv Ingle at 2025-06-23T12:10:52-05:00 popErrCtxt doesn't push contexts and popErrCtxts in the first argument to bind and >> in do expansion statements - - - - - 76c62744 by Apoorv Ingle at 2025-06-23T12:10:52-05:00 accept test cases with changed error messages ------------------------- Metric Decrease: T9020 ------------------------- - - - - - 626865ed by Apoorv Ingle at 2025-06-23T12:10:52-05:00 look through PopErrCtxt while splitting exprs in application chains - - - - - a2eba186 by Apoorv Ingle at 2025-06-23T12:10:52-05:00 remove special case for HsExpanded in Ticks - - - - - 7bd577b8 by Apoorv Ingle at 2025-06-23T12:10:52-05:00 check the right origin for record selector incomplete warnings - - - - - c96743a8 by Apoorv Ingle at 2025-06-23T12:10:52-05:00 kill VAExpansion - - - - - f5cb1107 by Apoorv Ingle at 2025-06-23T12:10:52-05:00 pass CtOrigin to tcApp for instantiateSigma - - - - - 08e22fde by Apoorv Ingle at 2025-06-23T12:10:52-05:00 do not suppress pprArising - - - - - e0f457e1 by Apoorv Ingle at 2025-06-23T12:11:25-05:00 kill VACall - - - - - 441f13ca by Apoorv Ingle at 2025-06-23T12:11:29-05:00 kill AppCtxt - - - - - 9fb913b8 by Apoorv Ingle at 2025-06-23T12:11:29-05:00 remove addHeadCtxt - - - - - 1777e9d2 by Apoorv Ingle at 2025-06-23T12:11:29-05:00 fix pprArising for MonadFailErrors - - - - - 1ca5a81f by Apoorv Ingle at 2025-06-23T12:11:29-05:00 rename ctxt to sloc - - - - - a49006c0 by Apoorv Ingle at 2025-06-23T12:11:29-05:00 fix RepPolyDoBind error message herald - - - - - e83473b8 by Apoorv Ingle at 2025-06-23T12:11:29-05:00 SrcCodeCtxt more changes - - - - - 99488532 by Apoorv Ingle at 2025-06-23T17:03:41-05:00 make tcl_in_gen_code a SrcCodeCtxt and rename DoOrigin to DoStmtOrigin - - - - - 202 changed files: - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - compiler/GHC/Builtin/Types.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/ConLike.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/DataCon.hs-boot - compiler/GHC/Core/Make.hs - compiler/GHC/Core/PatSyn.hs - compiler/GHC/Core/TyCo/Ppr.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore/Errors/Ppr.hs - compiler/GHC/HsToCore/Errors/Types.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Decl.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/SysTools/Ar.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - + compiler/GHC/Tc/Gen/App.hs-boot - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Var.hs-boot - compiler/GHC/Utils/Panic.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Pat.hs - docs/users_guide/9.14.1-notes.rst - docs/users_guide/exts/gadt_syntax.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/using-warnings.rst - docs/users_guide/using.rst - libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs - linters/lint-whitespace/lint-whitespace.cabal - rts/include/stg/MachRegs.h - testsuite/tests/annotations/should_fail/annfail03.stderr - testsuite/tests/annotations/should_fail/annfail09.stderr - testsuite/tests/deSugar/should_compile/T10662.stderr - testsuite/tests/deSugar/should_compile/T3263-1.stderr - testsuite/tests/deSugar/should_compile/T3263-2.stderr - testsuite/tests/default/default-fail05.stderr - testsuite/tests/dependent/should_fail/T16326_Fail6.stderr - + testsuite/tests/ghc-api/T26120.hs - + testsuite/tests/ghc-api/T26120.stdout - testsuite/tests/ghc-api/all.T - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - + testsuite/tests/hiefile/should_run/HieGadtConSigs.hs - + testsuite/tests/hiefile/should_run/HieGadtConSigs.stdout - testsuite/tests/hiefile/should_run/all.T - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/indexed-types/should_fail/T5439.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/plugins/test-defaulting-plugin.stderr - testsuite/tests/polykinds/T13393.stderr - testsuite/tests/printer/T17697.stderr - testsuite/tests/printer/T18791.stderr - testsuite/tests/quasiquotation/qq001/qq001.stderr - testsuite/tests/quasiquotation/qq002/qq002.stderr - testsuite/tests/quasiquotation/qq003/qq003.stderr - testsuite/tests/quasiquotation/qq004/qq004.stderr - + testsuite/tests/quotes/LiftErrMsg.hs - + testsuite/tests/quotes/LiftErrMsg.stderr - + testsuite/tests/quotes/LiftErrMsgDefer.hs - + testsuite/tests/quotes/LiftErrMsgDefer.stderr - + testsuite/tests/quotes/LiftErrMsgTyped.hs - + testsuite/tests/quotes/LiftErrMsgTyped.stderr - testsuite/tests/quotes/T10384.stderr - testsuite/tests/quotes/TH_localname.stderr - testsuite/tests/quotes/all.T - testsuite/tests/splice-imports/SI03.stderr - testsuite/tests/splice-imports/SI05.stderr - testsuite/tests/splice-imports/SI16.stderr - testsuite/tests/splice-imports/SI18.stderr - testsuite/tests/splice-imports/SI20.stderr - testsuite/tests/splice-imports/SI25.stderr - testsuite/tests/splice-imports/SI28.stderr - testsuite/tests/splice-imports/SI31.stderr - + testsuite/tests/th/GadtConSigs_th_dump1.hs - + testsuite/tests/th/GadtConSigs_th_dump1.stderr - + testsuite/tests/th/GadtConSigs_th_pprint1.hs - + testsuite/tests/th/GadtConSigs_th_pprint1.stderr - testsuite/tests/th/T16976z.stderr - testsuite/tests/th/T17820a.stderr - testsuite/tests/th/T17820b.stderr - testsuite/tests/th/T17820c.stderr - testsuite/tests/th/T17820d.stderr - testsuite/tests/th/T17820e.stderr - testsuite/tests/th/T20868.stdout - testsuite/tests/th/T23829_hasty.stderr - testsuite/tests/th/T23829_hasty_b.stderr - testsuite/tests/th/T5795.stderr - testsuite/tests/th/all.T - testsuite/tests/typecheck/should_compile/T14590.stderr - + testsuite/tests/typecheck/should_compile/T20873c.hs - − testsuite/tests/typecheck/should_compile/T22141a.stderr - − testsuite/tests/typecheck/should_compile/T22141b.stderr - − testsuite/tests/typecheck/should_compile/T22141c.stderr - − testsuite/tests/typecheck/should_compile/T22141d.stderr - − testsuite/tests/typecheck/should_compile/T22141e.stderr - testsuite/tests/typecheck/should_compile/T23739a.hs - + testsuite/tests/typecheck/should_compile/TyAppPat_Tricky.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - testsuite/tests/typecheck/should_fail/T20443b.stderr - − testsuite/tests/typecheck/should_fail/T20873c.hs - − testsuite/tests/typecheck/should_fail/T20873c.stderr - testsuite/tests/typecheck/should_compile/T22141a.hs → testsuite/tests/typecheck/should_fail/T22141a.hs - testsuite/tests/typecheck/should_fail/T22141a.stderr - testsuite/tests/typecheck/should_compile/T22141b.hs → testsuite/tests/typecheck/should_fail/T22141b.hs - testsuite/tests/typecheck/should_fail/T22141b.stderr - testsuite/tests/typecheck/should_compile/T22141c.hs → testsuite/tests/typecheck/should_fail/T22141c.hs - testsuite/tests/typecheck/should_fail/T22141c.stderr - testsuite/tests/typecheck/should_compile/T22141d.hs → testsuite/tests/typecheck/should_fail/T22141d.hs - testsuite/tests/typecheck/should_fail/T22141d.stderr - testsuite/tests/typecheck/should_compile/T22141e.hs → testsuite/tests/typecheck/should_fail/T22141e.hs - testsuite/tests/typecheck/should_fail/T22141e.stderr - testsuite/tests/typecheck/should_compile/T22141e_Aux.hs → testsuite/tests/typecheck/should_fail/T22141e_Aux.hs - testsuite/tests/typecheck/should_fail/T24064.stderr - testsuite/tests/typecheck/should_fail/T3613.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/TyAppPat_TooMany.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/typecheck/should_fail/tcfail128.stderr - testsuite/tests/typecheck/should_fail/tcfail168.stderr - + testsuite/tests/vdq-rta/should_compile/T25127_data.hs - + testsuite/tests/vdq-rta/should_compile/T25127_data_inst.hs - + testsuite/tests/vdq-rta/should_compile/T25127_infix.hs - + testsuite/tests/vdq-rta/should_compile/T25127_newtype.hs - testsuite/tests/vdq-rta/should_compile/all.T - testsuite/tests/vdq-rta/should_fail/T23739_fail_case.hs - testsuite/tests/vdq-rta/should_fail/T23739_fail_case.stderr - testsuite/tests/vdq-rta/should_fail/T24159_type_syntax_th_fail.script - + testsuite/tests/vdq-rta/should_fail/T25127_fail_arity.hs - + testsuite/tests/vdq-rta/should_fail/T25127_fail_arity.stderr - + testsuite/tests/vdq-rta/should_fail/T25127_fail_th_quote.hs - + testsuite/tests/vdq-rta/should_fail/T25127_fail_th_quote.stderr - testsuite/tests/vdq-rta/should_fail/all.T - testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr - utils/check-exact/ExactPrint.hs - utils/haddock/CHANGES.md - utils/haddock/doc/cheatsheet/haddocks.md - utils/haddock/doc/markup.rst - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs - utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs - utils/haddock/haddock-api/src/Haddock/Types.hs - + utils/haddock/html-test/ref/RedactTypeSynonyms.html - + utils/haddock/html-test/src/RedactTypeSynonyms.hs - + utils/haddock/latex-test/ref/RedactTypeSynonyms/RedactTypeSynonyms.tex - + utils/haddock/latex-test/src/RedactTypeSynonyms/RedactTypeSynonyms.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7f418af96e46614c0dc2ff09935e5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7f418af96e46614c0dc2ff09935e5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: Move ModuleGraph into UnitEnv
by Marge Bot (＠marge-bot) 23 Jun '25

23 Jun '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 0fb37893 by Matthew Pickering at 2025-06-23T13:55:10-04:00 Move ModuleGraph into UnitEnv The ModuleGraph is a piece of information associated with the ExternalPackageState and HomeUnitGraph. Therefore we should store it inside the HomeUnitEnv. - - - - - 3bf6720e by soulomoon at 2025-06-23T13:55:52-04:00 Remove hptAllFamInstances usage during upsweep Fixes #26118 This change eliminates the use of hptAllFamInstances during the upsweep phase, as it could access non-below modules from the home package table. The following updates were made: * Updated checkFamInstConsistency to accept an explicit ModuleEnv FamInstEnv parameter and removed the call to hptAllFamInstances. * Adjusted hugInstancesBelow so we can construct ModuleEnv FamInstEnv from its result, * hptAllFamInstances and allFamInstances functions are removed. - - - - - bcd90cf5 by Ben Gamari at 2025-06-23T17:31:13-04:00 configure: Don't force value of OTOOL, etc. if not present Previously if `otool` and `install_name_tool` were not present they would be overridden by `fp_settings.m4`. This logic was introduced in 4ff93292243888545da452ea4d4c1987f2343591 without explanation. - - - - - 4e2069ea by Ben Gamari at 2025-06-23T17:31:13-04:00 ghc-toolchain: Add support for otool, install_name_tool Fixes part of ghc#23675. - - - - - 344d08fe by Ben Gamari at 2025-06-23T17:31:13-04:00 ghc-toolchain: Add support for llc, opt, llvm-as Fixes #23675. - - - - - 8fdbee83 by Rodrigo Mesquita at 2025-06-23T17:31:13-04:00 hadrian: Use settings-use-distro-mingw directly The type `ToolchainSetting` only made sense when we had more settings to fetch from the system config file. Even then "settings-use-distro-mingw" is arguably not a toolchain setting. With the fix for #23675, all toolchain tools were moved to the `ghc-toolchain` `Toolchain` format. Therefore, we can inline `settings-use-distro-mingw` accesses and delete `ToolchainSetting`. - - - - - 0a4d4abf by Rodrigo Mesquita at 2025-06-23T17:31:13-04:00 configure: Check LlvmTarget exists for LlvmAsFlags If LlvmTarget was empty, LlvmAsFlags would be just "--target=". If it is empty now, simply keep LlvmAsFlags empty. ghc-toolchain already does this right. This fix makes the two configurations match up. - - - - - e34b734d by Ben Gamari at 2025-06-23T17:31:14-04:00 rts/linker/LoadArchive: Use bool Improve type precision by using `bool` instead of `int` and `StgBool`. - - - - - f09c2519 by Ben Gamari at 2025-06-23T17:31:14-04:00 rts/linker/LoadArchive: Don't rely on file extensions for identification Previously archive members would be identified via their file extension, as described in #13103. We now instead use a more principled approach, relying on the magic number in the member's header. As well, we refactor treatment of archive format detection to improve code clarity and error handling. Closes #13103. - - - - - 29 changed files: - compiler/GHC.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Home/Graph.hs - compiler/GHC/Unit/Home/PackageTable.hs - distrib/configure.ac.in - ghc/GHCi/UI.hs - hadrian/cfg/default.host.target.in - hadrian/cfg/default.target.in - hadrian/cfg/system.config.in - hadrian/src/Builder.hs - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/RunTest.hs - m4/fp_settings.m4 - m4/ghc_toolchain.m4 - m4/prep_target_file.m4 - rts/linker/LoadArchive.c - utils/ghc-toolchain/exe/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -859,6 +859,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_namever = ghcNameVersion dflags1 , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit old_unit_env + , ue_module_graph = ue_module_graph old_unit_env , ue_eps = ue_eps old_unit_env } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } @@ -916,6 +917,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit unit_env0 , ue_eps = ue_eps unit_env0 + , ue_module_graph = ue_module_graph unit_env0 } modifySession $ \h -> -- hscSetFlags takes care of updating the logger as well. @@ -996,7 +998,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do -- invalidateModSummaryCache :: GhcMonad m => m () invalidateModSummaryCache = - modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) } + modifySession $ \hsc_env -> setModuleGraph (mapMG inval (hsc_mod_graph hsc_env)) hsc_env where inval ms = ms { ms_hs_hash = fingerprint0 } ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -97,10 +97,11 @@ core2core hsc_env guts@(ModGuts { mg_module = mod where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env + unit_env = hsc_unit_env hsc_env extra_vars = interactiveInScope (hsc_IC hsc_env) home_pkg_rules = hugRulesBelow hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod, gwib_isBoot = NotBoot }) - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env + name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env ptc = initPromotionTickContext dflags -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -457,6 +457,7 @@ addUnit u = do (homeUnitId home_unit) (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit)) , ue_eps = ue_eps old_unit_env + , ue_module_graph = ue_module_graph old_unit_env } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -2,6 +2,8 @@ module GHC.Driver.Env ( Hsc(..) , HscEnv (..) + , hsc_mod_graph + , setModuleGraph , hscUpdateFlags , hscSetFlags , hsc_home_unit @@ -130,6 +132,9 @@ hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env hsc_HUG :: HscEnv -> HomeUnitGraph hsc_HUG = ue_home_unit_graph . hsc_unit_env +hsc_mod_graph :: HscEnv -> ModuleGraph +hsc_mod_graph = ue_module_graph . hsc_unit_env + hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId hsc_all_home_unit_ids = HUG.allUnits . hsc_HUG @@ -139,6 +144,9 @@ hscInsertHPT hmi hsc_env = UnitEnv.insertHpt hmi (hsc_unit_env hsc_env) hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) } +setModuleGraph :: ModuleGraph -> HscEnv -> HscEnv +setModuleGraph mod_graph hsc_env = hsc_env { hsc_unit_env = (hsc_unit_env hsc_env) { ue_module_graph = mod_graph } } + {- Note [Target code interpreter] @@ -220,15 +228,15 @@ hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env))) -- | Find all rules in modules that are in the transitive closure of the given -- module. hugRulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO RuleBase -hugRulesBelow hsc uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$> - hugSomeThingsBelowUs (md_rules . hm_details) False hsc uid mn +hugRulesBelow hsc_env uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$> + hugSomeThingsBelowUs (md_rules . hm_details) False hsc_env uid mn -- | Get annotations from all modules "below" this one (in the dependency -- sense) within the home units. If the module is @Nothing@, returns /all/ -- annotations in the home units. hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv -hugAnnsBelow hsc uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> - hugSomeThingsBelowUs (md_anns . hm_details) False hsc uid mn +hugAnnsBelow hsc_env uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> + hugSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn -- | Find all COMPLETE pragmas in modules that are in the transitive closure of the -- given module. @@ -237,7 +245,7 @@ hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$> hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn -- | Find instances visible from the given set of imports -hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst]) +hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [(Module, FamInstEnv)]) hugInstancesBelow hsc_env uid mnwib = do let mn = gwib_mod mnwib (insts, famInsts) <- @@ -247,7 +255,7 @@ hugInstancesBelow hsc_env uid mnwib = do -- Don't include instances for the current module in if moduleName (mi_module (hm_iface mod_info)) == mn then [] - else [(md_insts details, md_fam_insts details)]) + else [(md_insts details, [(mi_module $ hm_iface mod_info, extendFamInstEnvList emptyFamInstEnv $ md_fam_insts details)])]) True -- Include -hi-boot hsc_env uid @@ -260,7 +268,8 @@ hugInstancesBelow hsc_env uid mnwib = do hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]] -- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk -- These things are currently stored in the EPS for home packages. (See #25795 for --- progress in removing these kind of checks) +-- progress in removing these kind of checks; and making these functions of +-- `UnitEnv` rather than `HscEnv`) -- See Note [Downsweep and the ModuleGraph] hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return [] hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn ===================================== compiler/GHC/Driver/Env/Types.hs ===================================== @@ -18,7 +18,6 @@ import GHC.Types.Name.Cache import GHC.Types.Target import GHC.Types.TypeEnv import GHC.Unit.Finder.Types -import GHC.Unit.Module.Graph import GHC.Unit.Env import GHC.Utils.Logger import GHC.Utils.TmpFs @@ -65,10 +64,6 @@ data HscEnv hsc_targets :: [Target], -- ^ The targets (or roots) of the current session - hsc_mod_graph :: ModuleGraph, - -- ^ The module graph of the current session - -- See Note [Downsweep and the ModuleGraph] for when this is constructed. - hsc_IC :: InteractiveContext, -- ^ The context for evaluating interactive statements @@ -113,3 +108,4 @@ data HscEnv , hsc_llvm_config :: !LlvmConfigCache -- ^ LLVM configuration cache. } + ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -332,7 +332,6 @@ newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do return HscEnv { hsc_dflags = top_dynflags , hsc_logger = setLogFlags logger (initLogFlags top_dynflags) , hsc_targets = [] - , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags , hsc_NC = nc_var , hsc_FC = fc_var ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -190,12 +190,12 @@ depanalE diag_wrapper msg excluded_mods allow_dup_roots = do all_errs <- liftIO $ HUG.unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env) logDiagnostics (GhcDriverMessage <$> all_errs) - setSession hsc_env { hsc_mod_graph = mod_graph } + setSession (setModuleGraph mod_graph hsc_env) pure (emptyMessages, mod_graph) else do -- We don't have a complete module dependency graph, -- The graph may be disconnected and is unusable. - setSession hsc_env { hsc_mod_graph = emptyMG } + setSession (setModuleGraph emptyMG hsc_env) pure (errs, emptyMG) @@ -616,7 +616,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- for any client who might interact with GHC via load'. -- See Note [Timing of plugin initialization] initializeSessionPlugins - modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } + modifySession (setModuleGraph mod_graph) guessOutputFile hsc_env <- getSession ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -768,8 +768,9 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv - let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) - , hsc_mod_graph = mg } + let hsc_env' = + setModuleGraph mg + hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -671,7 +671,7 @@ dontLeakTheHUG thing_inside = do -- oneshot mode does not support backpack -- and we want to avoid prodding the hsc_mod_graph thunk | isOneShot (ghcMode (hsc_dflags hsc_env)) = False - | mgHasHoles (hsc_mod_graph hsc_env) = True + | mgHasHoles (ue_module_graph old_unit_env) = True | otherwise = False pruneHomeUnitEnv hme = do -- NB: These are empty HPTs because Iface/Load first consults the HPT @@ -683,19 +683,19 @@ dontLeakTheHUG thing_inside = do | otherwise = do hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph old_unit_env) + let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss" + , mg_graph = panic "cleanTopEnv: mg_graph" + , mg_has_holes = keepFor20509 } return old_unit_env { ue_home_unit_graph = hug' + , ue_module_graph = new_mod_graph } in do !unit_env <- unit_env_io -- mg_has_holes will be checked again, but nothing else about the module graph - let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss" - , mg_graph = panic "cleanTopEnv: mg_graph" - , mg_has_holes = keepFor20509 } pure $ hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets" - , hsc_mod_graph = new_mod_graph , hsc_IC = panic "cleanTopEnv: hsc_IC" , hsc_type_env_vars = case maybe_type_vars of Just vars -> vars ===================================== compiler/GHC/Tc/Instance/Family.hs ===================================== @@ -286,8 +286,8 @@ why we still do redundant checks. -- We don't need to check the current module, this is done in -- tcExtendLocalFamInstEnv. -- See Note [The type family instance consistency story]. -checkFamInstConsistency :: [Module] -> TcM () -checkFamInstConsistency directlyImpMods +checkFamInstConsistency :: ModuleEnv FamInstEnv -> [Module] -> TcM () +checkFamInstConsistency hpt_fam_insts directlyImpMods = do { (eps, hug) <- getEpsAndHug ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) ; let { -- Fetch the iface of a given module. Must succeed as @@ -317,7 +317,6 @@ checkFamInstConsistency directlyImpMods -- See Note [Order of type family consistency checks] } - ; hpt_fam_insts <- liftIO $ HUG.allFamInstances hug ; debug_consistent_set <- mapM (\x -> (\y -> (x, length y)) <$> modConsistent x) directlyImpMods ; traceTc "init_consistent_set" (ppr debug_consistent_set) ; let init_consistent_set = map fst (reverse (sortOn snd debug_consistent_set)) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -120,7 +120,7 @@ import GHC.Core.TyCo.Ppr( debugPprType ) import GHC.Core.TyCo.Tidy( tidyTopType ) import GHC.Core.FamInstEnv ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst - , famInstEnvElts, extendFamInstEnvList, normaliseType ) + , famInstEnvElts, extendFamInstEnvList, normaliseType, emptyFamInstEnv, unionFamInstEnv ) import GHC.Parser.Header ( mkPrelImports ) @@ -467,8 +467,8 @@ tcRnImports hsc_env import_decls = do { (rn_imports, imp_user_spec, rdr_env, imports) <- rnImports import_decls -- Get the default declarations for the classes imported by this module -- and group them by class. - ; tc_defaults <-(NE.groupBy ((==) `on` cd_class) . (concatMap defaultList)) - <$> tcGetClsDefaults (M.keys $ imp_mods imports) + ; tc_defaults <- NE.groupBy ((==) `on` cd_class) . (concatMap defaultList) + <$> tcGetClsDefaults (M.keys $ imp_mods imports) ; this_mod <- getModule ; gbl_env <- getGblEnv ; let unitId = homeUnitId $ hsc_home_unit hsc_env @@ -480,8 +480,10 @@ tcRnImports hsc_env import_decls -- filtering also ensures that we don't see instances from -- modules batch (@--make@) compiled before this one, but -- which are not below this one. - ; (home_insts, home_fam_insts) <- liftIO $ + ; (home_insts, home_mod_fam_inst_env) <- liftIO $ hugInstancesBelow hsc_env unitId mnwib + ; let home_fam_inst_env = foldl' unionFamInstEnv emptyFamInstEnv $ snd <$> home_mod_fam_inst_env + ; let hpt_fam_insts = mkModuleEnv home_mod_fam_inst_env -- We use 'unsafeInterleaveIO' to avoid redundant memory allocations -- See Note [Lazily loading COMPLETE pragmas] from GHC.HsToCore.Monad @@ -507,8 +509,7 @@ tcRnImports hsc_env import_decls tcg_rn_imports = rn_imports, tcg_default = foldMap subsume tc_defaults, tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) - home_fam_insts + tcg_fam_inst_env = unionFamInstEnv (tcg_fam_inst_env gbl) home_fam_inst_env }) $ do { ; traceRn "rn1" (ppr (imp_direct_dep_mods imports)) @@ -538,7 +539,7 @@ tcRnImports hsc_env import_decls $ imports } ; logger <- getLogger ; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ()) - $ checkFamInstConsistency dir_imp_mods + $ checkFamInstConsistency hpt_fam_insts dir_imp_mods ; traceRn "rn1: } checking family instance consistency" empty ; gbl_env <- getGblEnv @@ -2109,7 +2110,7 @@ for the unit portion of the graph, if it's not already been performed. withInteractiveModuleNode :: HscEnv -> TcM a -> TcM a withInteractiveModuleNode hsc_env thing_inside = do mg <- liftIO $ downsweepInteractiveImports hsc_env (hsc_IC hsc_env) - updTopEnv (\env -> env { hsc_mod_graph = mg }) thing_inside + updTopEnv (setModuleGraph mg) thing_inside runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -23,21 +23,22 @@ -- ┌▽────────────┐ │ │ -- │HomeUnitGraph│ │ │ -- └┬────────────┘ │ │ --- ┌▽─────────────────▽┐ │ --- │UnitEnv │ │ --- └┬──────────────────┘ │ --- ┌▽───────────────────────────────────────▽┐ --- │HscEnv │ --- └─────────────────────────────────────────┘ +-- ┌▽─────────────────▽─────────────────────▽┐ +-- │UnitEnv │ +-- └┬─────────────-──────────────────────────┘ +-- │ +-- │ +-- ┌▽──────────────────────────────────────▽┐ +-- │HscEnv │ +-- └────────────────────────────────────────┘ -- @ -- --- The 'UnitEnv' references both the 'HomeUnitGraph' (with all the home unit --- modules) and the 'ExternalPackageState' (information about all --- non-home/external units). The 'HscEnv' references this 'UnitEnv' and the --- 'ModuleGraph' (which describes the relationship between the modules being --- compiled). The 'HomeUnitGraph' has one 'HomePackageTable' for every unit. --- --- TODO: Arguably, the 'ModuleGraph' should be part of 'UnitEnv' rather than being in the 'HscEnv'. +-- The 'UnitEnv' references the 'HomeUnitGraph' (with all the home unit +-- modules), the 'ExternalPackageState' (information about all +-- non-home/external units), and the 'ModuleGraph' (which describes the +-- relationship between the modules being compiled). +-- The 'HscEnv' references this 'UnitEnv'. +-- The 'HomeUnitGraph' has one 'HomePackageTable' for every unit. module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv @@ -119,6 +120,7 @@ import GHC.Unit.Home.ModInfo import GHC.Unit.Home.PackageTable import GHC.Unit.Home.Graph (HomeUnitGraph, HomeUnitEnv) import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Module.Graph import GHC.Platform import GHC.Settings @@ -163,6 +165,10 @@ data UnitEnv = UnitEnv , ue_current_unit :: UnitId + , ue_module_graph :: ModuleGraph + -- ^ The module graph of the current session + -- See Note [Downsweep and the ModuleGraph] for when this is constructed. + , ue_home_unit_graph :: !HomeUnitGraph -- See Note [Multiple Home Units] @@ -182,6 +188,7 @@ initUnitEnv cur_unit hug namever platform = do return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug + , ue_module_graph = emptyMG , ue_current_unit = cur_unit , ue_platform = platform , ue_namever = namever ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -43,7 +43,6 @@ module GHC.Unit.Home.Graph -- * Very important queries , allInstances - , allFamInstances , allAnns , allCompleteSigs @@ -110,10 +109,6 @@ allInstances hug = foldr go (pure (emptyInstEnv, [])) hug where go hue = liftA2 (\(a,b) (a',b') -> (a `unionInstEnv` a', b ++ b')) (hptAllInstances (homeUnitEnv_hpt hue)) -allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv) -allFamInstances hug = foldr go (pure emptyModuleEnv) hug where - go hue = liftA2 plusModuleEnv (hptAllFamInstances (homeUnitEnv_hpt hue)) - allAnns :: HomeUnitGraph -> IO AnnEnv allAnns hug = foldr go (pure emptyAnnEnv) hug where go hue = liftA2 plusAnnEnv (hptAllAnnotations (homeUnitEnv_hpt hue)) ===================================== compiler/GHC/Unit/Home/PackageTable.hs ===================================== @@ -41,7 +41,6 @@ module GHC.Unit.Home.PackageTable -- * Queries about home modules , hptCompleteSigs , hptAllInstances - , hptAllFamInstances , hptAllAnnotations -- ** More Traversal-based queries @@ -208,14 +207,6 @@ hptAllInstances hpt = do let (insts, famInsts) = unzip hits return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) --- | Find all the family instance declarations from the HPT -hptAllFamInstances :: HomePackageTable -> IO (ModuleEnv FamInstEnv) -hptAllFamInstances = fmap mkModuleEnv . concatHpt (\hmi -> [(hmiModule hmi, hmiFamInstEnv hmi)]) - where - hmiModule = mi_module . hm_iface - hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv - . md_fam_insts . hm_details - -- | All annotations from the HPT hptAllAnnotations :: HomePackageTable -> IO AnnEnv hptAllAnnotations = fmap mkAnnEnv . concatHpt (md_anns . hm_details) ===================================== distrib/configure.ac.in ===================================== @@ -216,7 +216,7 @@ AC_SUBST([LlvmAsCmd]) dnl We know that `clang` supports `--target` and it is necessary to pass it dnl lest we see #25793. -if test -z "$LlvmAsFlags" ; then +if test -z "$LlvmAsFlags" && ! test -z "$LlvmTarget"; then LlvmAsFlags="--target=$LlvmTarget" fi AC_SUBST([LlvmAsFlags]) ===================================== ghc/GHCi/UI.hs ===================================== @@ -4680,7 +4680,7 @@ clearHPTs = do let pruneHomeUnitEnv hme = liftIO $ do emptyHpt <- emptyHomePackageTable pure hme{ homeUnitEnv_hpt = emptyHpt } - discardMG hsc = hsc { hsc_mod_graph = GHC.emptyMG } + discardMG hsc = setModuleGraph GHC.emptyMG hsc modifySessionM $ \hsc_env -> do hug' <- traverse pruneHomeUnitEnv $ hsc_HUG hsc_env pure $ discardMG $ discardIC $ hscUpdateHUG (const hug') hsc_env ===================================== hadrian/cfg/default.host.target.in ===================================== @@ -38,5 +38,10 @@ Target , tgtRanlib = Nothing , tgtNm = Nm {nmProgram = Program {prgPath = "", prgFlags = []}} , tgtMergeObjs = Just (MergeObjs {mergeObjsProgram = Program {prgPath = "@LD_STAGE0@", prgFlags = ["-r"]}, mergeObjsSupportsResponseFiles = False}) +, tgtLlc = Nothing +, tgtOpt = Nothing +, tgtLlvmAs = Nothing , tgtWindres = Nothing +, tgtOtool = Nothing +, tgtInstallNameTool = Nothing } ===================================== hadrian/cfg/default.target.in ===================================== @@ -38,5 +38,10 @@ Target , tgtRanlib = Just (Ranlib {ranlibProgram = Program {prgPath = "@RanlibCmd@", prgFlags = []}}) , tgtNm = Nm {nmProgram = Program {prgPath = "@NmCmd@", prgFlags = []}} , tgtMergeObjs = @MergeObjsCmdMaybe@ +, tgtLlc = @LlcCmdMaybeProg@ +, tgtOpt = @OptCmdMaybeProg@ +, tgtLlvmAs = @LlvmAsCmdMaybeProg@ , tgtWindres = @WindresCmdMaybeProg@ +, tgtOtool = @OtoolCmdMaybeProg@ +, tgtInstallNameTool = @InstallNameToolCmdMaybeProg@ } ===================================== hadrian/cfg/system.config.in ===================================== @@ -79,13 +79,6 @@ project-git-commit-id = @ProjectGitCommitId@ # generated by configure, to generated being by the build system. Many of these # might become redundant. # See Note [tooldir: How GHC finds mingw on Windows] - -settings-otool-command = @SettingsOtoolCommand@ -settings-install_name_tool-command = @SettingsInstallNameToolCommand@ -settings-llc-command = @SettingsLlcCommand@ -settings-opt-command = @SettingsOptCommand@ -settings-llvm-as-command = @SettingsLlvmAsCommand@ -settings-llvm-as-flags = @SettingsLlvmAsFlags@ settings-use-distro-mingw = @SettingsUseDistroMINGW@ target-has-libm = @TargetHasLibm@ ===================================== hadrian/src/Builder.hs ===================================== @@ -34,7 +34,6 @@ import Base import Context import Oracles.Flag import Oracles.Setting (setting, Setting(..)) -import Oracles.Setting (settingsFileSetting, ToolchainSetting(..)) import Packages import GHC.IO.Encoding (getFileSystemEncoding) @@ -240,7 +239,7 @@ instance H.Builder Builder where Ghc _ st -> do root <- buildRoot unlitPath <- builderPath Unlit - distro_mingw <- settingsFileSetting ToolchainSetting_DistroMinGW + distro_mingw <- lookupSystemConfig "settings-use-distro-mingw" libffi_adjustors <- useLibffiForAdjustors use_system_ffi <- flag UseSystemFfi ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -2,7 +2,6 @@ module Oracles.Setting ( configFile, -- * Settings Setting (..), setting, getSetting, - ToolchainSetting (..), settingsFileSetting, -- * Helpers ghcCanonVersion, cmdLineLengthLimit, targetSupportsRPaths, topDirectory, @@ -75,25 +74,6 @@ data Setting = CursesIncludeDir | BourneShell | EmsdkVersion --- TODO compute solely in Hadrian, removing these variables' definitions --- from aclocal.m4 whenever they can be calculated from other variables --- already fed into Hadrian. - --- | All 'ToolchainSetting's are computed by the ghc-toolchain utility for configuring toolchains. --- This used to be defined by 'FP_SETTINGS' in aclocal.m4. --- --- TODO: We should be able to drop this completely, after moving all the toolchain settings to ghc-toolchain --- Move to ghc-toolchain and to the Target files generated by configure and ghc-toolchain --- * First we will get rid of DistroMinGW when we fix the windows build -data ToolchainSetting - = ToolchainSetting_OtoolCommand - | ToolchainSetting_InstallNameToolCommand - | ToolchainSetting_LlcCommand - | ToolchainSetting_OptCommand - | ToolchainSetting_LlvmAsCommand - | ToolchainSetting_LlvmAsFlags - | ToolchainSetting_DistroMinGW - -- | Look up the value of a 'Setting' in @cfg/system.config@, tracking the -- result. setting :: Setting -> Action String @@ -134,20 +114,6 @@ setting key = lookupSystemConfig $ case key of BourneShell -> "bourne-shell" EmsdkVersion -> "emsdk-version" --- | Look up the value of a 'SettingList' in @cfg/system.config@, tracking the --- result. --- See Note [tooldir: How GHC finds mingw on Windows] --- ROMES:TODO: This should be queryTargetTargetConfig -settingsFileSetting :: ToolchainSetting -> Action String -settingsFileSetting key = lookupSystemConfig $ case key of - ToolchainSetting_OtoolCommand -> "settings-otool-command" - ToolchainSetting_InstallNameToolCommand -> "settings-install_name_tool-command" - ToolchainSetting_LlcCommand -> "settings-llc-command" - ToolchainSetting_OptCommand -> "settings-opt-command" - ToolchainSetting_LlvmAsCommand -> "settings-llvm-as-command" - ToolchainSetting_LlvmAsFlags -> "settings-llvm-as-flags" - ToolchainSetting_DistroMinGW -> "settings-use-distro-mingw" -- ROMES:TODO: This option doesn't seem to be in ghc-toolchain yet. It corresponds to EnableDistroToolchain - -- | An expression that looks up the value of a 'Setting' in @cfg/system.config@, -- tracking the result. getSetting :: Setting -> Expr c b String ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -424,7 +424,7 @@ bindistRules = do , interpolateSetting "LlvmMinVersion" LlvmMinVersion , interpolateVar "LlvmTarget" $ getTarget tgtLlvmTarget , interpolateSetting "ProjectVersion" ProjectVersion - , interpolateVar "SettingsUseDistroMINGW" $ settingsFileSetting ToolchainSetting_DistroMinGW + , interpolateVar "SettingsUseDistroMINGW" $ lookupSystemConfig "settings-use-distro-mingw" , interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode , interpolateVar "TargetHasLibm" $ lookupSystemConfig "target-has-libm" , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple @@ -508,9 +508,9 @@ generateSettings settingsFile = do , ("ar flags", queryTarget arFlags) , ("ar supports at file", queryTarget arSupportsAtFile') , ("ar supports -L", queryTarget arSupportsDashL') - , ("ranlib command", queryTarget ranlibPath) - , ("otool command", expr $ settingsFileSetting ToolchainSetting_OtoolCommand) - , ("install_name_tool command", expr $ settingsFileSetting ToolchainSetting_InstallNameToolCommand) + , ("ranlib command", queryTarget ranlibPath) + , ("otool command", queryTarget otoolPath) + , ("install_name_tool command", queryTarget installNameToolPath) , ("windres command", queryTarget (maybe "/bin/false" prgPath . tgtWindres)) -- TODO: /bin/false is not available on many distributions by default, but we keep it as it were before the ghc-toolchain patch. Fix-me. , ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) , ("cross compiling", expr $ yesNo <$> flag CrossCompiling) @@ -525,11 +525,11 @@ generateSettings settingsFile = do , ("target has libm", expr $ lookupSystemConfig "target-has-libm") , ("Unregisterised", queryTarget (yesNo . tgtUnregisterised)) , ("LLVM target", queryTarget tgtLlvmTarget) - , ("LLVM llc command", expr $ settingsFileSetting ToolchainSetting_LlcCommand) - , ("LLVM opt command", expr $ settingsFileSetting ToolchainSetting_OptCommand) - , ("LLVM llvm-as command", expr $ settingsFileSetting ToolchainSetting_LlvmAsCommand) - , ("LLVM llvm-as flags", expr $ settingsFileSetting ToolchainSetting_LlvmAsFlags) - , ("Use inplace MinGW toolchain", expr $ settingsFileSetting ToolchainSetting_DistroMinGW) + , ("LLVM llc command", queryTarget llcPath) + , ("LLVM opt command", queryTarget optPath) + , ("LLVM llvm-as command", queryTarget llvmAsPath) + , ("LLVM llvm-as flags", queryTarget llvmAsFlags) + , ("Use inplace MinGW toolchain", expr $ lookupSystemConfig "settings-use-distro-mingw") , ("target RTS linker only supports shared libraries", expr $ yesNo <$> targetRTSLinkerOnlySupportsSharedLibs) , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage)) @@ -571,10 +571,16 @@ generateSettings settingsFile = do linkSupportsFilelist = yesNo . ccLinkSupportsFilelist . tgtCCompilerLink linkSupportsCompactUnwind = yesNo . ccLinkSupportsCompactUnwind . tgtCCompilerLink linkIsGnu = yesNo . ccLinkIsGnu . tgtCCompilerLink + llcPath = maybe "" prgPath . tgtLlc + optPath = maybe "" prgPath . tgtOpt + llvmAsPath = maybe "" prgPath . tgtLlvmAs + llvmAsFlags = escapeArgs . maybe [] prgFlags . tgtLlvmAs arPath = prgPath . arMkArchive . tgtAr arFlags = escapeArgs . prgFlags . arMkArchive . tgtAr arSupportsAtFile' = yesNo . arSupportsAtFile . tgtAr arSupportsDashL' = yesNo . arSupportsDashL . tgtAr + otoolPath = maybe "" prgPath . tgtOtool + installNameToolPath = maybe "" prgPath . tgtInstallNameTool ranlibPath = maybe "" (prgPath . ranlibProgram) . tgtRanlib mergeObjsSupportsResponseFiles' = maybe "NO" (yesNo . mergeObjsSupportsResponseFiles) . tgtMergeObjs ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -127,9 +127,9 @@ inTreeCompilerArgs stg = do platform <- queryTargetTarget targetPlatformTriple wordsize <- show @Int . (*8) <$> queryTargetTarget (wordSize2Bytes . tgtWordSize) - llc_cmd <- settingsFileSetting ToolchainSetting_LlcCommand - llvm_as_cmd <- settingsFileSetting ToolchainSetting_LlvmAsCommand - have_llvm <- liftIO (all isJust <$> mapM findExecutable [llc_cmd, llvm_as_cmd]) + llc_cmd <- queryTargetTarget tgtLlc + llvm_as_cmd <- queryTargetTarget tgtLlvmAs + let have_llvm = all isJust [llc_cmd, llvm_as_cmd] top <- topDirectory ===================================== m4/fp_settings.m4 ===================================== @@ -136,14 +136,7 @@ AC_DEFUN([FP_SETTINGS], fi # Mac-only tools - if test -z "$OtoolCmd"; then - OtoolCmd="otool" - fi SettingsOtoolCommand="$OtoolCmd" - - if test -z "$InstallNameToolCmd"; then - InstallNameToolCmd="install_name_tool" - fi SettingsInstallNameToolCommand="$InstallNameToolCmd" SettingsCCompilerSupportsNoPie="$CONF_GCC_SUPPORTS_NO_PIE" ===================================== m4/ghc_toolchain.m4 ===================================== @@ -107,6 +107,9 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN], echo "--merge-objs=$MergeObjsCmd" >> acargs echo "--readelf=$READELF" >> acargs echo "--windres=$WindresCmd" >> acargs + echo "--llc=$LlcCmd" >> acargs + echo "--opt=$OptCmd" >> acargs + echo "--llvm-as=$LlvmAsCmd" >> acargs if test -n "$USER_LD"; then echo "--ld=$USER_LD" >> acargs ===================================== m4/prep_target_file.m4 ===================================== @@ -10,6 +10,38 @@ # This toolchain will additionally be used to validate the one generated by # ghc-toolchain. See Note [ghc-toolchain consistency checking]. +# PREP_LIST +# ============ +# +# Issue a substitution with ["list","of","args"] of [$1List] when $1 is a +# space-separated list of args +# i.e. +# "arg1 arg2 arg3" +# ==> +# ["arg1","arg2","arg3"] +# +# $1 = list variable to substitute +dnl In autoconf, '@<:@' stands for '[', and '@:>@' for ']'. +AC_DEFUN([PREP_LIST],[ + # shell array + set -- $$1 + $1List="@<:@" + if test "[$]#" -eq 0; then + # no arguments + true + else + $1List="${$1List}\"[$]1\"" + shift # drop first elem + for arg in "[$]@" + do + $1List="${$1List},\"$arg\"" + done + fi + $1List="${$1List}@:>@" + + AC_SUBST([$1List]) +]) + # PREP_MAYBE_SIMPLE_PROGRAM # ========================= # @@ -27,6 +59,25 @@ AC_DEFUN([PREP_MAYBE_SIMPLE_PROGRAM],[ AC_SUBST([$1MaybeProg]) ]) +# PREP_MAYBE_PROGRAM +# ========================= +# +# Introduce a substitution [$1MaybeProg] with +# * Nothing, if $$1 is empty +# * Just (Program {prgPath = "$$1", prgFlags = [elements of $$2]}), otherwise +# +# $1 = optional program path +# $2 = program arguments +AC_DEFUN([PREP_MAYBE_PROGRAM],[ + if test -z "$$1"; then + $1MaybeProg=Nothing + else + PREP_LIST([$2]) + $1MaybeProg="Just (Program {prgPath = \"$$1\", prgFlags = $$2List})" + fi + AC_SUBST([$1MaybeProg]) +]) + # PREP_MAYBE_STRING # ========================= # @@ -86,38 +137,6 @@ AC_DEFUN([PREP_NOT_BOOLEAN],[ AC_SUBST([Not$1Bool]) ]) -# PREP_LIST -# ============ -# -# Issue a substitution with ["list","of","args"] of [$1List] when $1 is a -# space-separated list of args -# i.e. -# "arg1 arg2 arg3" -# ==> -# ["arg1","arg2","arg3"] -# -# $1 = list variable to substitute -dnl In autoconf, '@<:@' stands for '[', and '@:>@' for ']'. -AC_DEFUN([PREP_LIST],[ - # shell array - set -- $$1 - $1List="@<:@" - if test "[$]#" -eq 0; then - # no arguments - true - else - $1List="${$1List}\"[$]1\"" - shift # drop first elem - for arg in "[$]@" - do - $1List="${$1List},\"$arg\"" - done - fi - $1List="${$1List}@:>@" - - AC_SUBST([$1List]) -]) - # Eventually: PREP_BUILD_TARGET_FILE, PREP_HOST_TARGET_FILE, PREP_TARGET_TARGET_FILE # Prepares required substitutions to generate the target file AC_DEFUN([PREP_TARGET_FILE],[ @@ -148,7 +167,12 @@ AC_DEFUN([PREP_TARGET_FILE],[ PREP_LIST([JavaScriptCPPArgs]) PREP_LIST([CmmCPPArgs]) PREP_LIST([CmmCPPArgs_STAGE0]) + PREP_MAYBE_SIMPLE_PROGRAM([LlcCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([OptCmd]) + PREP_MAYBE_PROGRAM([LlvmAsCmd], [LlvmAsFlags]) PREP_MAYBE_SIMPLE_PROGRAM([WindresCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([OtoolCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([InstallNameToolCmd]) PREP_MAYBE_STRING([TargetVendor_CPP]) PREP_MAYBE_STRING([HostVendor_CPP]) PREP_LIST([CONF_CPP_OPTS_STAGE2]) ===================================== rts/linker/LoadArchive.c ===================================== @@ -33,6 +33,7 @@ #define DEBUG_LOG(...) IF_DEBUG(linker, debugBelch("loadArchive: " __VA_ARGS__)) + #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) /* Read 4 bytes and convert to host byte order */ static uint32_t read4Bytes(const char buf[static 4]) @@ -40,7 +41,7 @@ static uint32_t read4Bytes(const char buf[static 4]) return ntohl(*(uint32_t*)buf); } -static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) +static bool loadFatArchive(char input[static 20], FILE* f, pathchar* path) { uint32_t nfat_arch, nfat_offset, cputype, cpusubtype; #if defined(i386_HOST_ARCH) @@ -58,8 +59,9 @@ static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) #error Unknown Darwin architecture #endif - nfat_arch = read4Bytes(tmp + 4); + nfat_arch = read4Bytes(input + 4); DEBUG_LOG("found a fat archive containing %d architectures\n", nfat_arch); + char tmp[20]; nfat_offset = 0; for (uint32_t i = 0; i < nfat_arch; i++) { /* search for the right arch */ @@ -90,6 +92,7 @@ static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) } /* Read the header */ + char tmp[20]; n = fread(tmp, 1, 8, f); if (n != 8) { errorBelch("Failed reading header from `%" PATH_FMT "'", path); @@ -107,10 +110,51 @@ static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) } #endif -static StgBool readThinArchiveMember(int n, int memberSize, pathchar* path, +enum ObjectFileFormat { + NotObject, + COFFAmd64, + COFFI386, + COFFAArch64, + ELF, + MachO32, + MachO64, +}; + +static enum ObjectFileFormat identifyObjectFile_(char* buf, size_t sz) +{ + if (sz > 2 && ((uint16_t*)buf)[0] == 0x8664) { + return COFFAmd64; + } + if (sz > 2 && ((uint16_t*)buf)[0] == 0x014c) { + return COFFI386; + } + if (sz > 2 && ((uint16_t*)buf)[0] == 0xaa64) { + return COFFAArch64; + } + if (sz > 4 && memcmp(buf, "\x7f" "ELF", 4) == 0) { + return ELF; + } + if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedface) { + return MachO32; + } + if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedfacf) { + return MachO64; + } + return NotObject; +} + +static enum ObjectFileFormat identifyObjectFile(FILE *f) +{ + char buf[32]; + ssize_t sz = fread(buf, 1, 32, f); + CHECK(fseek(f, -sz, SEEK_CUR) == 0); + return identifyObjectFile_(buf, sz); +} + +static bool readThinArchiveMember(int n, int memberSize, pathchar* path, char* fileName, char* image) { - StgBool has_succeeded = false; + bool has_succeeded = false; FILE* member = NULL; pathchar *pathCopy, *dirName, *memberPath, *objFileName; memberPath = NULL; @@ -148,10 +192,9 @@ inner_fail: return has_succeeded; } -static StgBool checkFatArchive(char magic[static 20], FILE* f, pathchar* path) +static bool checkFatArchive(char magic[static 4], FILE* f, pathchar* path) { - StgBool success; - success = false; + bool success = false; #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) /* Not a standard archive, look for a fat archive magic number: */ if (read4Bytes(magic) == FAT_MAGIC) @@ -175,7 +218,7 @@ static StgBool checkFatArchive(char magic[static 20], FILE* f, pathchar* path) * be reallocated on return; the old value is now _invalid_. * @param gnuFileIndexSize The size of the index. */ -static StgBool +static bool lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, char* gnuFileIndex, pathchar* path, size_t* thisFileNameSize, size_t* fileNameSize) @@ -241,47 +284,21 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, return true; } -HsInt loadArchive_ (pathchar *path) -{ - char *image = NULL; - HsInt retcode = 0; - int memberSize; - int memberIdx = 0; - FILE *f = NULL; - int n; - size_t thisFileNameSize = (size_t)-1; /* shut up bogus GCC warning */ - char *fileName; - size_t fileNameSize; - int isObject, isGnuIndex, isThin, isImportLib; - char tmp[20]; - char *gnuFileIndex; - int gnuFileIndexSize; - int misalignment = 0; - - DEBUG_LOG("start\n"); - DEBUG_LOG("Loading archive `%" PATH_FMT "'\n", path); +enum ArchiveFormat { + StandardArchive, + ThinArchive, + FatArchive, +}; - /* Check that we haven't already loaded this archive. - Ignore requests to load multiple times */ - if (isAlreadyLoaded(path)) { - IF_DEBUG(linker, - debugBelch("ignoring repeated load of %" PATH_FMT "\n", path)); - return 1; /* success */ +static bool identifyArchiveFormat(FILE *f, pathchar *path, enum ArchiveFormat *out) +{ + char tmp[8]; + size_t n = fread(tmp, 1, 8, f); + if (n != 8) { + errorBelch("loadArchive: Failed reading header from `%" PATH_FMT "'", path); \ + return false; } - gnuFileIndex = NULL; - gnuFileIndexSize = 0; - - fileNameSize = 32; - fileName = stgMallocBytes(fileNameSize, "loadArchive(fileName)"); - - isThin = 0; - isImportLib = 0; - - f = pathopen(path, WSTR("rb")); - if (!f) - FAIL("loadObj: can't read `%" PATH_FMT "'", path); - /* Check if this is an archive by looking for the magic "!<arch>\n" * string. Usually, if this fails, we belch an error and return. On * Darwin however, we may have a fat archive, which contains archives for @@ -300,12 +317,10 @@ HsInt loadArchive_ (pathchar *path) * its magic "!<arch>\n" string and continue processing just as if * we had a single architecture archive. */ - - n = fread ( tmp, 1, 8, f ); - if (n != 8) { - FAIL("Failed reading header from `%" PATH_FMT "'", path); + if (strncmp(tmp, "!<arch>\n", 8) == 0) { + *out = StandardArchive; + return true; } - if (strncmp(tmp, "!<arch>\n", 8) == 0) {} /* Check if this is a thin archive by looking for the magic string "!<thin>\n" * * ar thin libraries have the exact same format as normal archives except they @@ -322,16 +337,59 @@ HsInt loadArchive_ (pathchar *path) * */ else if (strncmp(tmp, "!<thin>\n", 8) == 0) { - isThin = 1; + *out = ThinArchive; + return true; } else { - StgBool success = checkFatArchive(tmp, f, path); - if (!success) - goto fail; + bool success = checkFatArchive(tmp, f, path); + if (!success) { + return false; + } + *out = FatArchive; + return true; } +} + +HsInt loadArchive_ (pathchar *path) +{ + char *image = NULL; + HsInt retcode = 0; + int memberIdx = 0; + FILE *f = NULL; + size_t thisFileNameSize = (size_t) -1; /* shut up bogus GCC warning */ + int misalignment = 0; + + DEBUG_LOG("start\n"); + DEBUG_LOG("Loading archive `%" PATH_FMT "'\n", path); + + /* Check that we haven't already loaded this archive. + Ignore requests to load multiple times */ + if (isAlreadyLoaded(path)) { + IF_DEBUG(linker, + debugBelch("ignoring repeated load of %" PATH_FMT "\n", path)); + return 1; /* success */ + } + + char *gnuFileIndex = NULL; + int gnuFileIndexSize = 0; + + size_t fileNameSize = 32; + char *fileName = stgMallocBytes(fileNameSize, "loadArchive(fileName)"); + + f = pathopen(path, WSTR("rb")); + if (!f) + FAIL("loadObj: can't read `%" PATH_FMT "'", path); + + enum ArchiveFormat archive_fmt; + if (!identifyArchiveFormat(f, path, &archive_fmt)) { + FAIL("failed to identify archive format of %" PATH_FMT ".", path); + } + bool isThin = archive_fmt == ThinArchive; + DEBUG_LOG("loading archive contents\n"); while (1) { + size_t n; DEBUG_LOG("reading at %ld\n", ftell(f)); n = fread ( fileName, 1, 16, f ); if (n != 16) { @@ -351,6 +409,7 @@ HsInt loadArchive_ (pathchar *path) } #endif + char tmp[32]; n = fread ( tmp, 1, 12, f ); if (n != 12) FAIL("Failed reading mod time from `%" PATH_FMT "'", path); @@ -369,9 +428,16 @@ HsInt loadArchive_ (pathchar *path) tmp[10] = '\0'; for (n = 0; isdigit(tmp[n]); n++); tmp[n] = '\0'; - memberSize = atoi(tmp); + size_t memberSize; + { + char *end; + memberSize = strtol(tmp, &end, 10); + if (tmp == end) { + FAIL("Failed to decode member size"); + } + } - DEBUG_LOG("size of this archive member is %d\n", memberSize); + DEBUG_LOG("size of this archive member is %zd\n", memberSize); n = fread ( tmp, 1, 2, f ); if (n != 2) FAIL("Failed reading magic from `%" PATH_FMT "'", path); @@ -379,7 +445,7 @@ HsInt loadArchive_ (pathchar *path) FAIL("Failed reading magic from `%" PATH_FMT "' at %ld. Got %c%c", path, ftell(f), tmp[0], tmp[1]); - isGnuIndex = 0; + bool isGnuIndex = false; /* Check for BSD-variant large filenames */ if (0 == strncmp(fileName, "#1/", 3)) { size_t n = 0; @@ -419,7 +485,7 @@ HsInt loadArchive_ (pathchar *path) else if (0 == strncmp(fileName, "//", 2)) { fileName[0] = '\0'; thisFileNameSize = 0; - isGnuIndex = 1; + isGnuIndex = true; } /* Check for a file in the GNU file index */ else if (fileName[0] == '/') { @@ -460,12 +526,8 @@ HsInt loadArchive_ (pathchar *path) DEBUG_LOG("Found member file `%s'\n", fileName); - /* TODO: Stop relying on file extensions to determine input formats. - Instead try to match file headers. See #13103. */ - isObject = (thisFileNameSize >= 2 && strncmp(fileName + thisFileNameSize - 2, ".o" , 2) == 0) - || (thisFileNameSize >= 3 && strncmp(fileName + thisFileNameSize - 3, ".lo" , 3) == 0) - || (thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".p_o", 4) == 0) - || (thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".obj", 4) == 0); + bool is_symbol_table = strcmp("", fileName) == 0; + enum ObjectFileFormat object_fmt = is_symbol_table ? NotObject : identifyObjectFile(f); #if defined(OBJFORMAT_PEi386) /* @@ -479,15 +541,15 @@ HsInt loadArchive_ (pathchar *path) * * Linker members (e.g. filename / are skipped since they are not needed) */ - isImportLib = thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".dll", 4) == 0; + bool isImportLib = thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".dll", 4) == 0; +#else + bool isImportLib = false; #endif // windows DEBUG_LOG("\tthisFileNameSize = %d\n", (int)thisFileNameSize); - DEBUG_LOG("\tisObject = %d\n", isObject); - - if (isObject) { - pathchar *archiveMemberName; + DEBUG_LOG("\tisObject = %d\n", object_fmt); + if ((!is_symbol_table && isThin) || object_fmt != NotObject) { DEBUG_LOG("Member is an object file...loading...\n"); #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) @@ -505,14 +567,13 @@ HsInt loadArchive_ (pathchar *path) image = stgMallocBytes(memberSize, "loadArchive(image)"); #endif if (isThin) { - if (!readThinArchiveMember(n, memberSize, path, - fileName, image)) { + if (!readThinArchiveMember(n, memberSize, path, fileName, image)) { goto fail; } } else { - n = fread ( image, 1, memberSize, f ); + size_t n = fread ( image, 1, memberSize, f ); if (n != memberSize) { FAIL("error whilst reading `%" PATH_FMT "'", path); } @@ -523,16 +584,18 @@ HsInt loadArchive_ (pathchar *path) // I don't understand why this extra +1 is needed here; pathprintf // should have given us the correct length but in practice it seems // to be one byte short on Win32. - archiveMemberName = stgMallocBytes((size+1+1) * sizeof(pathchar), "loadArchive(file)"); + pathchar *archiveMemberName = stgMallocBytes((size+1+1) * sizeof(pathchar), "loadArchive(file)"); pathprintf(archiveMemberName, size+1, WSTR("%" PATH_FMT "(#%d:%.*s)"), path, memberIdx, (int)thisFileNameSize, fileName); ObjectCode *oc = mkOc(STATIC_OBJECT, path, image, memberSize, false, archiveMemberName, misalignment); #if defined(OBJFORMAT_MACHO) + ASSERT(object_fmt == MachO32 || object_fmt == MachO64); ocInit_MachO( oc ); #endif #if defined(OBJFORMAT_ELF) + ASSERT(object_fmt == ELF); ocInit_ELF( oc ); #endif @@ -577,7 +640,7 @@ while reading filename from `%" PATH_FMT "'", path); "Skipping...\n"); n = fseek(f, memberSize, SEEK_CUR); if (n != 0) - FAIL("error whilst seeking by %d in `%" PATH_FMT "'", + FAIL("error whilst seeking by %zd in `%" PATH_FMT "'", memberSize, path); } #endif @@ -588,7 +651,7 @@ while reading filename from `%" PATH_FMT "'", path); if (!isThin || thisFileNameSize == 0) { n = fseek(f, memberSize, SEEK_CUR); if (n != 0) - FAIL("error whilst seeking by %d in `%" PATH_FMT "'", + FAIL("error whilst seeking by %zd in `%" PATH_FMT "'", memberSize, path); } } ===================================== utils/ghc-toolchain/exe/Main.hs ===================================== @@ -52,7 +52,12 @@ data Opts = Opts , optNm :: ProgOpt , optReadelf :: ProgOpt , optMergeObjs :: ProgOpt + , optLlc :: ProgOpt + , optOpt :: ProgOpt + , optLlvmAs :: ProgOpt , optWindres :: ProgOpt + , optOtool :: ProgOpt + , optInstallNameTool :: ProgOpt -- Note we don't actually configure LD into anything but -- see #23857 and #22550 for the very unfortunate story. , optLd :: ProgOpt @@ -99,8 +104,13 @@ emptyOpts = Opts , optNm = po0 , optReadelf = po0 , optMergeObjs = po0 + , optLlc = po0 + , optOpt = po0 + , optLlvmAs = po0 , optWindres = po0 , optLd = po0 + , optOtool = po0 + , optInstallNameTool = po0 , optUnregisterised = Nothing , optTablesNextToCode = Nothing , optUseLibFFIForAdjustors = Nothing @@ -112,7 +122,8 @@ emptyOpts = Opts po0 = emptyProgOpt _optCc, _optCxx, _optCpp, _optHsCpp, _optJsCpp, _optCmmCpp, _optCcLink, _optAr, - _optRanlib, _optNm, _optReadelf, _optMergeObjs, _optWindres, _optLd + _optRanlib, _optNm, _optReadelf, _optMergeObjs, _optLlc, _optOpt, _optLlvmAs, + _optWindres, _optLd, _optOtool, _optInstallNameTool :: Lens Opts ProgOpt _optCc = Lens optCc (\x o -> o {optCc=x}) _optCxx = Lens optCxx (\x o -> o {optCxx=x}) @@ -126,8 +137,13 @@ _optRanlib = Lens optRanlib (\x o -> o {optRanlib=x}) _optNm = Lens optNm (\x o -> o {optNm=x}) _optReadelf = Lens optReadelf (\x o -> o {optReadelf=x}) _optMergeObjs = Lens optMergeObjs (\x o -> o {optMergeObjs=x}) +_optLlc = Lens optLlc (\x o -> o {optLlc=x}) +_optOpt = Lens optOpt (\x o -> o {optOpt=x}) +_optLlvmAs = Lens optLlvmAs (\x o -> o {optLlvmAs=x}) _optWindres = Lens optWindres (\x o -> o {optWindres=x}) -_optLd = Lens optLd (\x o -> o {optLd= x}) +_optLd = Lens optLd (\x o -> o {optLd=x}) +_optOtool = Lens optOtool (\x o -> o {optOtool=x}) +_optInstallNameTool = Lens optInstallNameTool (\x o -> o {optInstallNameTool=x}) _optTriple :: Lens Opts (Maybe String) _optTriple = Lens optTriple (\x o -> o {optTriple=x}) @@ -183,8 +199,13 @@ options = , progOpts "nm" "nm archiver" _optNm , progOpts "readelf" "readelf utility" _optReadelf , progOpts "merge-objs" "linker for merging objects" _optMergeObjs + , progOpts "llc" "LLVM llc utility" _optLlc + , progOpts "opt" "LLVM opt utility" _optOpt + , progOpts "llvm-as" "Assembler used for LLVM backend (typically clang)" _optLlvmAs , progOpts "windres" "windres utility" _optWindres , progOpts "ld" "linker" _optLd + , progOpts "otool" "otool utility" _optOtool + , progOpts "install-name-tool" "install-name-tool utility" _optInstallNameTool ] where progOpts :: String -> String -> Lens Opts ProgOpt -> [OptDescr (Opts -> Opts)] @@ -436,6 +457,11 @@ mkTarget opts = do when (isNothing mergeObjs && not (arSupportsDashL ar)) $ throwE "Neither a object-merging tool (e.g. ld -r) nor an ar that supports -L is available" + -- LLVM toolchain + llc <- optional $ findProgram "llc" (optLlc opts) ["llc"] + opt <- optional $ findProgram "opt" (optOpt opts) ["opt"] + llvmAs <- optional $ findProgram "llvm assembler" (optLlvmAs opts) ["clang"] + -- Windows-specific utilities windres <- case archOS_OS archOs of @@ -444,6 +470,15 @@ mkTarget opts = do return (Just windres) _ -> return Nothing + -- Darwin-specific utilities + (otool, installNameTool) <- + case archOS_OS archOs of + OSDarwin -> do + otool <- findProgram "otool" (optOtool opts) ["otool"] + installNameTool <- findProgram "install_name_tool" (optInstallNameTool opts) ["install_name_tool"] + return (Just otool, Just installNameTool) + _ -> return (Nothing, Nothing) + -- various other properties of the platform tgtWordSize <- checkWordSize cc tgtEndianness <- checkEndianness cc @@ -480,7 +515,12 @@ mkTarget opts = do , tgtRanlib = ranlib , tgtNm = nm , tgtMergeObjs = mergeObjs + , tgtLlc = llc + , tgtOpt = opt + , tgtLlvmAs = llvmAs , tgtWindres = windres + , tgtOtool = otool + , tgtInstallNameTool = installNameTool , tgtWordSize , tgtEndianness , tgtUnregisterised ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Target.hs ===================================== @@ -22,15 +22,6 @@ data WordSize = WS4 | WS8 data Endianness = LittleEndian | BigEndian deriving (Show, Read, Eq, Ord) --- TODO(#23674): Move the remaining relevant `settings-xxx` to Target: --- * llc command --- * opt command --- * install_name_tool --- * otool command --- --- Those are all things that are put into GHC's settings, and that might be --- different across targets - -- | A 'Target' consists of: -- -- * a target architecture and operating system @@ -72,8 +63,18 @@ data Target = Target , tgtMergeObjs :: Maybe MergeObjs -- ^ We don't need a merge objects tool if we @Ar@ supports @-L@ + -- LLVM backend toolchain + , tgtLlc :: Maybe Program + , tgtOpt :: Maybe Program + , tgtLlvmAs :: Maybe Program + -- ^ assembler used to assemble LLVM backend output; typically @clang@ + -- Windows-specific tools , tgtWindres :: Maybe Program + + -- Darwin-specific tools + , tgtOtool :: Maybe Program + , tgtInstallNameTool :: Maybe Program } deriving (Read, Eq, Ord) @@ -121,6 +122,11 @@ instance Show Target where , ", tgtRanlib = " ++ show tgtRanlib , ", tgtNm = " ++ show tgtNm , ", tgtMergeObjs = " ++ show tgtMergeObjs + , ", tgtLlc = " ++ show tgtLlc + , ", tgtOpt = " ++ show tgtOpt + , ", tgtLlvmAs = " ++ show tgtLlvmAs , ", tgtWindres = " ++ show tgtWindres + , ", tgtOtool = " ++ show tgtOtool + , ", tgtInstallNameTool = " ++ show tgtInstallNameTool , "}" ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ce82af2d765f2e6662f55f2f1190c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ce82af2d765f2e6662f55f2f1190c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/fix-reload-targets] Teach `:reload` about multiple home units
by Hannes Siebenhandl (＠fendor) 23 Jun '25

23 Jun '25

Hannes Siebenhandl pushed to branch wip/fendor/fix-reload-targets at Glasgow Haskell Compiler / GHC Commits: 929a2903 by fendor at 2025-06-23T20:22:11+02:00 Teach `:reload` about multiple home units `:reload` needs to lookup the `ModuleName` and must not assume the given `ModuleName` is in the current `HomeUnit`. We add a new utility function which allows us to find a `HomeUnitModule` instead of a `Module`. Further, we introduce the `GhciCommandError` type which can be used to abort the execution of a GHCi command. This error is caught and printed in a human readable fashion. - - - - - 15 changed files: - compiler/GHC/Driver/Make.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Exception.hs - ghc/GHCi/UI/Print.hs - testsuite/tests/ghc-e/should_fail/T18441fail5.stderr - testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr - testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr - + testsuite/tests/ghci/prog021/A.hs - + testsuite/tests/ghci/prog021/B.hs - + testsuite/tests/ghci/prog021/Makefile - + testsuite/tests/ghci/prog021/prog021.T - + testsuite/tests/ghci/prog021/prog021.script - + testsuite/tests/ghci/prog021/prog021.stderr - + testsuite/tests/ghci/prog021/prog021.stdout - testsuite/tests/ghci/scripts/ghci021.stderr Changes: ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -135,6 +135,7 @@ import qualified GHC.Data.Maybe as M import GHC.Data.Graph.Directed.Reachability import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable +import qualified Data.List as List -- ----------------------------------------------------------------------------- -- Loading the program @@ -520,13 +521,13 @@ countMods (UnresolvedCycle ns) = length ns createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan] createBuildPlan mod_graph maybe_top_mod = let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles - cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod - + cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod + cycle_mod_graph_with_boot_nodes = topSortModuleGraph False mod_graph maybe_top_mod -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles. build_plan :: [BuildPlan] build_plan -- Fast path, if there are no boot modules just do a normal toposort - | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod + | isEmptyModuleEnv boot_modules = collapseAcyclic cycle_mod_graph_with_boot_nodes | otherwise = toBuildPlan cycle_mod_graph [] toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan] @@ -599,13 +600,18 @@ createBuildPlan mod_graph maybe_top_mod = topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing + modGraphSize + | isEmptyModuleEnv boot_modules = lengthMGWithSCC cycle_mod_graph_with_boot_nodes + | otherwise = lengthMGWithSCC cycle_mod_graph in - - assertPpr (sum (map countMods build_plan) == lengthMG mod_graph) - (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMG mod_graph))]) + -- The assertion needs to operate on 'cycle_mod_graph' as we prune the module graph during 'topSortModuleGraph'. + assertPpr (sum (map countMods build_plan) == modGraphSize) + (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr modGraphSize)]) build_plan - + where + lengthMGWithSCC :: [SCC a] -> Int + lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0 -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally ===================================== ghc/GHCi/UI.hs ===================================== @@ -1302,7 +1302,8 @@ runOneCommand eh gCmd = do st <- getGHCiState ghciHandle (\e -> lift $ eh e >>= return . Just) $ handleSourceError printErrorAndFail $ - cmd_wrapper st $ doCommand c + handleGhciCommandError printErrorAndContinue $ + cmd_wrapper st $ doCommand c -- source error's are handled by runStmt -- is the handler necessary here? where @@ -1310,6 +1311,10 @@ runOneCommand eh gCmd = do printGhciException err return $ Just False -- Exit ghc -e, but not GHCi + printErrorAndContinue err = do + printGhciCommandException err + return $ Just False -- Exit ghc -e, but not GHCi + noSpace q = q >>= maybe (return Nothing) (\c -> case removeSpaces c of "" -> noSpace q @@ -2286,13 +2291,16 @@ unAddModule files = do -- | @:reload@ command reloadModule :: GhciMonad m => String -> m () reloadModule m = do - session <- GHC.getSession - let home_unit = homeUnitId (hsc_home_unit session) - ok <- doLoadAndCollectInfo Reload (loadTargets home_unit) + loadTarget <- findLoadTarget + ok <- doLoadAndCollectInfo Reload loadTarget when (failed ok) failIfExprEvalMode where - loadTargets hu | null m = LoadAllTargets - | otherwise = LoadUpTo (mkModule hu (GHC.mkModuleName m)) + findLoadTarget + | null m = + pure LoadAllTargets + | otherwise = do + mod' <- lookupHomeUnitModuleName (GHC.mkModuleName m) + pure $ LoadUpTo mod' reloadModuleDefer :: GhciMonad m => String -> m () reloadModuleDefer = wrapDeferTypeErrors . reloadModule @@ -4747,8 +4755,11 @@ showException se = Just other_ghc_ex -> putException (show other_ghc_ex) Nothing -> case fromException se of - Just UserInterrupt -> putException "Interrupted." - _ -> putException ("*** Exception: " ++ show se) + Just (GhciCommandError s) -> putException (show (GhciCommandError s)) + Nothing -> + case fromException se of + Just UserInterrupt -> putException "Interrupted." + _ -> putException ("*** Exception: " ++ show se) where putException = hPutStrLn stderr @@ -4798,15 +4809,22 @@ lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module lookupQualifiedModuleName qual modl = do GHC.lookupAllQualifiedModuleNames qual modl >>= \case - [] -> throwGhcException (CmdLineError ("module '" ++ str ++ "' could not be found.")) + [] -> throwGhciCommandError (GhciModuleError $ GhciModuleNameNotFound modl) [m] -> pure m - ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous:\n" ++ errorMsg ms)) + ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms) + +lookupHomeUnitModuleName :: GHC.GhcMonad m => ModuleName -> m HomeUnitModule +lookupHomeUnitModuleName modl = do + m <- GHC.lookupLoadedHomeModuleByModuleName modl >>= \case + Nothing -> throwGhciCommandError (GhciModuleError $ GhciNoLocalModuleName modl) + Just [m] -> pure m + Just ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms) + + if unitIsDefinite (moduleUnit m) + then pure (fmap toUnitId m) + else throwGhcException (CmdLineError ("module '" ++ str ++ "' is not from a definite unit")) where str = moduleNameString modl - errorMsg ms = intercalate "\n" - [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m) - | m <- ms - ] showModule :: Module -> String showModule = moduleNameString . moduleName ===================================== ghc/GHCi/UI/Exception.hs ===================================== @@ -5,7 +5,10 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} module GHCi.UI.Exception - ( GhciMessage(..) + ( GhciCommandError(..) + , throwGhciCommandError + , handleGhciCommandError + , GhciMessage(..) , GhciMessageOpts(..) , fromGhcOpts , toGhcHint @@ -29,19 +32,57 @@ import GHC.Tc.Errors.Ppr import GHC.Tc.Errors.Types import GHC.Types.Error.Codes +import GHC.Types.SrcLoc (interactiveSrcSpan) import GHC.TypeLits import GHC.Unit.State import GHC.Utils.Outputable +import GHC.Utils.Error import GHC.Generics import GHC.Types.Error import GHC.Types import qualified GHC +import Control.Exception +import Control.Monad.Catch as MC (MonadCatch, catch) +import Control.Monad.IO.Class import Data.List.NonEmpty (NonEmpty(..)) +-- | A 'GhciCommandError' are messages that caused the abortion of a GHCi command. +newtype GhciCommandError = GhciCommandError (Messages GhciMessage) + +instance Exception GhciCommandError + +instance Show GhciCommandError where + -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics + -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions. + -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'. + show (GhciCommandError msgs) = + renderWithContext defaultSDocContext + . vcat + . pprMsgEnvelopeBagWithLocDefault + . getMessages + $ msgs + +-- | Perform the given action and call the exception handler if the action +-- throws a 'SourceError'. See 'SourceError' for more information. +handleGhciCommandError :: (MonadCatch m) => + (GhciCommandError -> m a) -- ^ exception handler + -> m a -- ^ action to perform + -> m a +handleGhciCommandError handler act = + MC.catch act (\(e :: GhciCommandError) -> handler e) + +throwGhciCommandError :: MonadIO m => GhciCommandMessage -> m a +throwGhciCommandError errorMessage = + liftIO + . throwIO + . GhciCommandError + . singleMessage + $ mkPlainErrorMsgEnvelope interactiveSrcSpan (GhciCommandMessage errorMessage) + -- | The Options passed to 'diagnosticMessage' -- in the 'Diagnostic' instance of 'GhciMessage'. data GhciMessageOpts = GhciMessageOpts @@ -257,6 +298,9 @@ data GhciModuleError | GhciNoResolvedModules | GhciNoModuleForName GHC.Name | GhciNoMatchingModuleExport + | GhciNoLocalModuleName !GHC.ModuleName + | GhciModuleNameNotFound !GHC.ModuleName + | GhciAmbiguousModuleName !GHC.ModuleName ![GHC.Module] deriving Generic instance Diagnostic GhciModuleError where @@ -278,6 +322,16 @@ instance Diagnostic GhciModuleError where -> "No module for" <+> ppr name GhciNoMatchingModuleExport -> "No matching export in any local modules." + GhciNoLocalModuleName modl + -> "Module" <+> quotes (ppr modl) <+> "cannot be found locally" + GhciModuleNameNotFound modl + -> "module" <+> quotes (ppr modl) <+> "could not be found." + GhciAmbiguousModuleName modl candidates + -> "Module name" <+> quotes (ppr modl) <+> "is ambiguous" $+$ + vcat + [ text "-" <+> ppr (GHC.moduleName m) <> colon <> ppr (GHC.moduleUnit m) + | m <- candidates + ] diagnosticReason = \case GhciModuleNotFound{} -> @@ -294,6 +348,12 @@ instance Diagnostic GhciModuleError where ErrorWithoutFlag GhciNoMatchingModuleExport{} -> ErrorWithoutFlag + GhciNoLocalModuleName{} -> + ErrorWithoutFlag + GhciModuleNameNotFound{} -> + ErrorWithoutFlag + GhciAmbiguousModuleName{} -> + ErrorWithoutFlag diagnosticHints = \case GhciModuleNotFound{} -> @@ -310,7 +370,12 @@ instance Diagnostic GhciModuleError where [] GhciNoMatchingModuleExport{} -> [] - + GhciNoLocalModuleName{} -> + [] + GhciModuleNameNotFound{} -> + [] + GhciAmbiguousModuleName{} -> + [] diagnosticCode = constructorCode @GHCi -- | A Diagnostic emitted by GHCi while executing a command @@ -487,6 +552,9 @@ type family GhciDiagnosticCode c = n | n -> c where GhciDiagnosticCode "GhciNoModuleForName" = 21847 GhciDiagnosticCode "GhciNoMatchingModuleExport" = 59723 GhciDiagnosticCode "GhciArgumentParseError" = 35671 + GhciDiagnosticCode "GhciNoLocalModuleName" = 81235 + GhciDiagnosticCode "GhciModuleNameNotFound" = 40475 + GhciDiagnosticCode "GhciAmbiguousModuleName" = 59019 type GhciConRecursInto :: Symbol -> Maybe Type type family GhciConRecursInto con where ===================================== ghc/GHCi/UI/Print.hs ===================================== @@ -5,6 +5,7 @@ module GHCi.UI.Print , printForUserPartWay , printError , printGhciException + , printGhciCommandException ) where import qualified GHC @@ -64,7 +65,7 @@ printForUserPartWay doc = do -- | pretty-print a 'GhciCommandMessage' printError :: GhcMonad m => GhciCommandMessage -> m () printError err = - let errEnvelope = mkPlainErrorMsgEnvelope (UnhelpfulSpan UnhelpfulInteractive) err + let errEnvelope = mkPlainErrorMsgEnvelope interactiveSrcSpan err in printError' (const NoDiagnosticOpts) (singleMessage errEnvelope) -- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting @@ -72,6 +73,9 @@ printError err = printGhciException :: GhcMonad m => SourceError -> m () printGhciException err = printError' initGhciPrintConfig (GhciGhcMessage <$> (srcErrorMessages err)) +printGhciCommandException :: GhcMonad m => GhciCommandError -> m () +printGhciCommandException (GhciCommandError errs) = printError' initGhciPrintConfig errs + printError' :: (GhcMonad m, Diagnostic a) => (DynFlags -> DiagnosticOpts a) -> Messages a -> m () printError' get_config err = do dflags <- getDynFlags ===================================== testsuite/tests/ghc-e/should_fail/T18441fail5.stderr ===================================== @@ -1,4 +1,4 @@ -<no location info>: error: [GHC-82272] - module ‘Abcde’ cannot be found locally +<interactive>: error: [GHCi-81235] + Module ‘Abcde’ cannot be found locally 1 ===================================== testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr ===================================== @@ -1,9 +1,15 @@ -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + ===================================== testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr ===================================== @@ -1,9 +1,14 @@ -module name 'Foo' is ambiguous: -- a-0.0.0:Foo -- b-0.0.0:Foo -module name 'Foo' is ambiguous: -- a-0.0.0:Foo -- b-0.0.0:Foo -module name 'Foo' is ambiguous: -- a-0.0.0:Foo -- b-0.0.0:Foo +<interactive>: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:a-0.0.0 + - Foo:b-0.0.0 + +<interactive>: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:a-0.0.0 + - Foo:b-0.0.0 + +<interactive>: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:a-0.0.0 + - Foo:b-0.0.0 ===================================== testsuite/tests/ghci/prog021/A.hs ===================================== @@ -0,0 +1,5 @@ +module A (f) where + +f x = [x] + +g x = Just x ===================================== testsuite/tests/ghci/prog021/B.hs ===================================== @@ -0,0 +1,5 @@ +module B where + +import A + +h = f ===================================== testsuite/tests/ghci/prog021/Makefile ===================================== @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk ===================================== testsuite/tests/ghci/prog021/prog021.T ===================================== @@ -0,0 +1,6 @@ +test('prog021', + [req_interp, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + extra_files(['A.hs', 'B.hs', 'prog021.script']) + ], + ghci_script, ['prog021.script']) ===================================== testsuite/tests/ghci/prog021/prog021.script ===================================== @@ -0,0 +1,15 @@ +-- Loads all targets +:load A B +:m + A B +f 5 +g 5 +h 5 +-- Load only one target +:reload A +:m A +putStrLn "B is not loaded, we can't add it to the context" +:m + B +f 5 +putStrLn "`g` and `h` are not in scope" +g 5 +h 5 ===================================== testsuite/tests/ghci/prog021/prog021.stderr ===================================== @@ -0,0 +1,10 @@ +<no location info>: error: [GHC-35235] + Could not find module ‘B’. + It is not a module in the current program, or in any known package. + +<interactive>:14:1: error: [GHC-88464] + Variable not in scope: g :: t0 -> t + +<interactive>:15:1: error: [GHC-88464] + Variable not in scope: h :: t0 -> t + ===================================== testsuite/tests/ghci/prog021/prog021.stdout ===================================== @@ -0,0 +1,6 @@ +[5] +Just 5 +[5] +B is not loaded, we can't add it to the context +[5] +`g` and `h` are not in scope ===================================== testsuite/tests/ghci/scripts/ghci021.stderr ===================================== @@ -1,3 +1,3 @@ -<no location info>: error: [GHC-82272] - module ‘ThisDoesNotExist’ cannot be found locally +<interactive>: error: [GHCi-81235] + Module ‘ThisDoesNotExist’ cannot be found locally View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/929a2903b94d90225047fe9a3c69929… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/929a2903b94d90225047fe9a3c69929… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/bump-win32-tarballs
by Ben Gamari (＠bgamari) 23 Jun '25

23 Jun '25

Ben Gamari pushed new branch wip/bump-win32-tarballs at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/bump-win32-tarballs You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/bump-win32-tarballs
by Ben Gamari (＠bgamari) 23 Jun '25

23 Jun '25

Ben Gamari deleted branch wip/bump-win32-tarballs at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0