- ghc-commits - Haskell.org

[Git][ghc/ghc][master] testsuite: Fix broken exec_signals_child.c
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: c1cdd265 by Moritz Angermann at 2025-09-10T10:48:35-04:00 testsuite: Fix broken exec_signals_child.c There is no signal 0. The signal mask is 1-32. - - - - - 1 changed file: - testsuite/tests/rts/exec_signals_child.c Changes: ===================================== testsuite/tests/rts/exec_signals_child.c ===================================== @@ -2,8 +2,11 @@ #include <stdio.h> #include <errno.h> -// Prints the state of the signal handlers to stdout -int main() +// Prints the state of the signal handlers to stdout. +// NOTE: We intentionally start at signal 1 (not 0). Signal number 0 is not a +// real signal; passing 0 to sigismember/sigaction is undefined behaviour and +// on Darwin was observed to yield memory corruption / junk bytes in output. +int main(void) { int open = 0, i; sigset_t blockedsigs; @@ -11,7 +14,7 @@ int main() printf("ChildInfo { masked = ["); sigprocmask(SIG_BLOCK, NULL, &blockedsigs); - for(i = 0; i < NSIG; ++i) + for(i = 1; i < NSIG; ++i) { int ret = sigismember(&blockedsigs, i); if(ret >= 0) @@ -26,7 +29,7 @@ int main() printf("], handlers = ["); open = 0; - for(i = 0; i < NSIG; ++i) + for(i = 1; i < NSIG; ++i) { struct sigaction old; if(sigaction(i, NULL, &old) >= 0) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1cdd26507fa0b7cb7585af5a7b2ec5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1cdd26507fa0b7cb7585af5a7b2ec5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] test.mk expect GhcLeadingUnderscore, not LeadingUnderscore (in line with the...
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 4e67855b by Moritz Angermann at 2025-09-10T10:47:54-04:00 test.mk expect GhcLeadingUnderscore, not LeadingUnderscore (in line with the other Ghc prefixed variables. - - - - - 2 changed files: - hadrian/src/Oracles/TestSettings.hs - testsuite/ghc-config/ghc-config.hs Changes: ===================================== hadrian/src/Oracles/TestSettings.hs ===================================== @@ -73,7 +73,7 @@ testSetting key = do TestLLC -> "LLC" TestTEST_CC -> "TEST_CC" TestTEST_CC_OPTS -> "TEST_CC_OPTS" - TestLeadingUnderscore -> "LeadingUnderscore" + TestLeadingUnderscore -> "GhcLeadingUnderscore" TestGhcPackageDb -> "GhcGlobalPackageDb" TestGhcLibDir -> "GhcLibdir" ===================================== testsuite/ghc-config/ghc-config.hs ===================================== @@ -43,7 +43,7 @@ main = do getGhcFieldOrDefault fields "TargetRTSLinkerOnlySupportsSharedLibs" "target RTS linker only supports shared libraries" "NO" getGhcFieldOrDefault fields "GhcDynamic" "GHC Dynamic" "NO" getGhcFieldOrDefault fields "GhcProfiled" "GHC Profiled" "NO" - getGhcFieldOrDefault fields "LeadingUnderscore" "Leading underscore" "NO" + getGhcFieldOrDefault fields "GhcLeadingUnderscore" "Leading underscore" "NO" getGhcFieldOrDefault fields "GhcTablesNextToCode" "Tables next to code" "NO" getGhcFieldProgWithDefault fields "AR" "ar command" "ar" getGhcFieldProgWithDefault fields "LLC" "LLVM llc command" "llc" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e67855b01853bc4a23810b361061ec… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e67855b01853bc4a23810b361061ec… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Improve mach-o relocation information
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 1537784b by Moritz Angermann at 2025-09-10T10:47:13-04:00 Improve mach-o relocation information This change adds more information about the symbol and addresses we try to relocate in the linker. This significantly helps when deubbging relocation issues reported by users. - - - - - 1 changed file: - rts/linker/MachO.c Changes: ===================================== rts/linker/MachO.c ===================================== @@ -64,7 +64,7 @@ static bool fitsBits(size_t bits, int64_t value); static int64_t decodeAddend(ObjectCode * oc, Section * section, MachORelocationInfo * ri); static void encodeAddend(ObjectCode * oc, Section * section, - MachORelocationInfo * ri, int64_t addend); + MachORelocationInfo * ri, int64_t addend, MachOSymbol * symbol); /* Global Offset Table logic */ static bool isGotLoad(MachORelocationInfo * ri); @@ -361,15 +361,21 @@ fitsBits(size_t bits, int64_t value) { static void encodeAddend(ObjectCode * oc, Section * section, - MachORelocationInfo * ri, int64_t addend) { + MachORelocationInfo * ri, int64_t addend, MachOSymbol * symbol) { uint32_t * p = (uint32_t*)((uint8_t*)section->start + ri->r_address); checkProddableBlock(&oc->proddables, (void*)p, 1 << ri->r_length); + const char *symbol_name = symbol && symbol->name ? (char*)symbol->name : "<unknown>"; + const char *file_name = oc->fileName ? (char*)oc->fileName : "<unknown>"; + switch (ri->r_type) { case ARM64_RELOC_UNSIGNED: { - if(!fitsBits(8 << ri->r_length, addend)) - barf("Relocation out of range for UNSIGNED"); + if(!fitsBits(8 << ri->r_length, addend)) { + const char *library_info = OC_INFORMATIVE_FILENAME(oc); + barf("Relocation out of range for UNSIGNED in %s: symbol '%s', addend 0x%llx, address 0x%llx, library: %s", + file_name, symbol_name, (long long)addend, (long long)ri->r_address, library_info ? (char*)library_info : "<unknown>"); + } switch (ri->r_length) { case 0: *(uint8_t*)p = (uint8_t)addend; break; case 1: *(uint16_t*)p = (uint16_t)addend; break; @@ -382,8 +388,11 @@ encodeAddend(ObjectCode * oc, Section * section, return; } case ARM64_RELOC_SUBTRACTOR: { - if(!fitsBits(8 << ri->r_length, addend)) - barf("Relocation out of range for SUBTRACTOR"); + if(!fitsBits(8 << ri->r_length, addend)) { + const char *library_info = OC_INFORMATIVE_FILENAME(oc); + barf("Relocation out of range for SUBTRACTOR in %s: symbol '%s', addend 0x%llx, address 0x%llx, library: %s", + file_name, symbol_name, (long long)addend, (long long)ri->r_address, library_info ? (char*)library_info : "<unknown>"); + } switch (ri->r_length) { case 0: *(uint8_t*)p = (uint8_t)addend; break; case 1: *(uint16_t*)p = (uint16_t)addend; break; @@ -400,8 +409,11 @@ encodeAddend(ObjectCode * oc, Section * section, * do not need the last two bits of the value. If the value >> 2 * still exceeds 26bits, we won't be able to reach it. */ - if(!fitsBits(26, addend >> 2)) - barf("Relocation target for BRACH26 out of range."); + if(!fitsBits(26, addend >> 2)) { + const char *library_info = OC_INFORMATIVE_FILENAME(oc); + barf("Relocation target for BRANCH26 out of range in %s: symbol '%s', addend 0x%llx (0x%llx >> 2), address 0x%llx, library: %s", + file_name, symbol_name, (long long)addend, (long long)(addend >> 2), (long long)ri->r_address, library_info ? (char*)library_info : "<unknown>"); + } *p = (*p & 0xFC000000) | ((uint32_t)(addend >> 2) & 0x03FFFFFF); return; } @@ -412,8 +424,12 @@ encodeAddend(ObjectCode * oc, Section * section, * with the PAGEOFF12 relocation allows to address a relative range * of +-4GB. */ - if(!fitsBits(21, addend >> 12)) - barf("Relocation target for PAGE21 out of range."); + if(!fitsBits(21, addend >> 12)) { + const char *reloc_type = (ri->r_type == ARM64_RELOC_PAGE21) ? "PAGE21" : "GOT_LOAD_PAGE21"; + const char *library_info = OC_INFORMATIVE_FILENAME(oc); + barf("Relocation target for %s out of range in %s: symbol '%s', addend 0x%llx (0x%llx >> 12), address 0x%llx, library: %s", + reloc_type, file_name, symbol_name, (long long)addend, (long long)(addend >> 12), (long long)ri->r_address, library_info ? (char*)library_info : "<unknown>"); + } *p = (*p & 0x9F00001F) | (uint32_t)((addend << 17) & 0x60000000) | (uint32_t)((addend >> 9) & 0x00FFFFE0); return; @@ -423,8 +439,11 @@ encodeAddend(ObjectCode * oc, Section * section, /* Store an offset into a page (4k). Depending on the instruction * the bits are stored at slightly different positions. */ - if(!fitsBits(12, addend)) - barf("Relocation target for PAGEOFF12 out or range."); + if(!fitsBits(12, addend)) { + const char *library_info = OC_INFORMATIVE_FILENAME(oc); + barf("Relocation target for PAGEOFF12 out of range in %s: symbol '%s', addend 0x%llx, address 0x%llx, library: %s", + file_name, symbol_name, (long long)addend, (long long)ri->r_address, library_info ? (char*)library_info : "<unknown>"); + } int shift = 0; if(isLoadStore(p)) { @@ -589,7 +608,7 @@ relocateSectionAarch64(ObjectCode * oc, Section * section) MachOSymbol* symbol = &oc->info->macho_symbols[ri->r_symbolnum]; int64_t addend = decodeAddend(oc, section, ri); uint64_t value = symbol_value(oc, symbol); - encodeAddend(oc, section, ri, value + addend); + encodeAddend(oc, section, ri, value + addend, symbol); break; } case ARM64_RELOC_SUBTRACTOR: @@ -623,7 +642,7 @@ relocateSectionAarch64(ObjectCode * oc, Section * section) // combine with addend and store int64_t addend = decodeAddend(oc, section, ri); - encodeAddend(oc, section, ri, addend - sub_value + add_value); + encodeAddend(oc, section, ri, addend - sub_value + add_value, symbol1); // skip next relocation: we've already handled it i += 1; @@ -664,7 +683,7 @@ relocateSectionAarch64(ObjectCode * oc, Section * section) } } } - encodeAddend(oc, section, ri, value - pc + addend); + encodeAddend(oc, section, ri, value - pc + addend, symbol); break; } case ARM64_RELOC_PAGE21: @@ -676,7 +695,7 @@ relocateSectionAarch64(ObjectCode * oc, Section * section) uint64_t pc = (uint64_t)section->start + ri->r_address; uint64_t value = (uint64_t)(isGotLoad(ri) ? symbol->got_addr : symbol->addr); ASSERT(!isGotLoad(ri) || (symbol->got_addr != 0)); - encodeAddend(oc, section, ri, ((value + addend + explicit_addend) & (-4096)) - (pc & (-4096))); + encodeAddend(oc, section, ri, ((value + addend + explicit_addend) & (-4096)) - (pc & (-4096)), symbol); // reset, just in case. explicit_addend = 0; @@ -690,7 +709,7 @@ relocateSectionAarch64(ObjectCode * oc, Section * section) barf("explicit_addend and addend can't be set at the same time."); uint64_t value = (uint64_t)(isGotLoad(ri) ? symbol->got_addr : symbol->addr); ASSERT(!isGotLoad(ri) || (symbol->got_addr != 0)); - encodeAddend(oc, section, ri, 0xFFF & (value + addend + explicit_addend)); + encodeAddend(oc, section, ri, 0xFFF & (value + addend + explicit_addend), symbol); // reset, just in case. explicit_addend = 0; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1537784bd4928f5ae60504e8ef46727… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1537784bd4928f5ae60504e8ef46727… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] gitlab-ci: Disable split sections on FreeBSD
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 56540775 by Ben Gamari at 2025-09-10T10:46:32-04:00 gitlab-ci: Disable split sections on FreeBSD Due to #26303. - - - - - 2 changed files: - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml Changes: ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -1235,7 +1235,7 @@ darwin = freebsd_jobs :: [JobGroup Job] freebsd_jobs = - [ addValidateRule FreeBSDLabel (standardBuilds Amd64 FreeBSD14) + [ addValidateRule FreeBSDLabel (standardBuildsWithConfig Amd64 FreeBSD14 (splitSectionsBroken vanilla)) ] alpine_x86 :: [JobGroup Job] ===================================== .gitlab/jobs.yaml ===================================== @@ -4296,7 +4296,7 @@ "ac_cv_func_utimensat": "no" } }, - "release-x86_64-freebsd14-release": { + "release-x86_64-freebsd14-release+no_split_sections": { "after_script": [ ".gitlab/ci.sh save_cache", ".gitlab/ci.sh save_test_output", @@ -4307,7 +4307,7 @@ "artifacts": { "expire_in": "1 year", "paths": [ - "ghc-x86_64-freebsd14-release.tar.xz", + "ghc-x86_64-freebsd14-release+no_split_sections.tar.xz", "junit.xml", "unexpected-test-output.tar.gz" ], @@ -4349,8 +4349,8 @@ ], "variables": { "BIGNUM_BACKEND": "gmp", - "BIN_DIST_NAME": "ghc-x86_64-freebsd14-release", - "BUILD_FLAVOUR": "release", + "BIN_DIST_NAME": "ghc-x86_64-freebsd14-release+no_split_sections", + "BUILD_FLAVOUR": "release+no_split_sections", "CABAL_INSTALL_VERSION": "3.10.3.0", "CC": "cc", "CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check", @@ -4359,7 +4359,7 @@ "IGNORE_PERF_FAILURES": "all", "INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check", "RUNTEST_ARGS": "", - "TEST_ENV": "x86_64-freebsd14-release", + "TEST_ENV": "x86_64-freebsd14-release+no_split_sections", "XZ_OPT": "-9" } }, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5654077509a5072ce0308d722bf72ee… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5654077509a5072ce0308d722bf72ee… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] lint-codes: fixup MSYS drive letter on Windows
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 4bfe2269 by sheaf at 2025-09-10T10:45:50-04:00 lint-codes: fixup MSYS drive letter on Windows This change ensures that System.Directory.listDirectory doesn't trip up on an MSYS-style path like '/c/Foo' when trying to list all testsuite stdout/stderr files as required for testing coverage of GHC diagnostic codes in the testsuite. Fixes #25178 - - - - - 1 changed file: - linters/lint-codes/LintCodes/Coverage.hs Changes: ===================================== linters/lint-codes/LintCodes/Coverage.hs ===================================== @@ -10,11 +10,13 @@ module LintCodes.Coverage -- base import Data.Char - ( isAlphaNum, isDigit, isSpace ) + ( isAlphaNum, isDigit, isSpace, toUpper ) import Data.Maybe ( mapMaybe ) import Data.List ( dropWhileEnd ) +import System.Info + ( os ) -- bytestring import qualified Data.ByteString as ByteString @@ -28,7 +30,7 @@ import qualified Data.Set as Set -- directory import System.Directory - ( doesDirectoryExist, listDirectory ) + ( doesDirectoryExist, listDirectory, makeAbsolute ) -- filepath import System.FilePath @@ -63,7 +65,12 @@ getCoveredCodes = do { top <- dropWhileEnd isSpace <$> readProcess "git" ["rev-parse", "--show-toplevel"] "" -- TODO: would be better to avoid using git entirely. - ; let testRoot = top </> "testsuite" </> "tests" + + -- When run inside an MSYS shell, git may return a Unix-style path + -- like /c/Blah. System.Directory doesn't like that, so we make sure + -- to turn that into C:/Blah. See #25178. + ; top' <- fixupMsysDrive top + ; let testRoot = top' </> "testsuite" </> "tests" ; traverseFilesFrom includeFile diagnosticCodesIn testRoot } @@ -158,3 +165,14 @@ traverseFilesFrom include_file parse_contents = go { Left _ -> mempty ; Right txt -> parse_contents txt } } } } + +-- | On Windows, change MSYS-style @/c/Blah@ to @C:/Blah@. See #25178. +fixupMsysDrive :: FilePath -> IO FilePath +fixupMsysDrive fp = do + fixedUp <- + if | os == "mingw32" || os == "win32" + , ('/':drv:'/':rest) <- fp + -> return $ toUpper drv : ':':'/':rest + | otherwise + -> return fp + makeAbsolute fixedUp View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4bfe226936f96b0c2b0bb0c80f3f8ca… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4bfe226936f96b0c2b0bb0c80f3f8ca… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Deep subsumption: unify mults without tcEqMult
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: dc79593d by sheaf at 2025-09-10T10:45:01-04:00 Deep subsumption: unify mults without tcEqMult As seen in #26332, we may well end up with a non-reflexive multiplicity coercion when doing deep subsumption. We should do the same thing that we do without deep subsumption: unify the multiplicities normally, without requiring that the coercion is reflexive (which is what 'tcEqMult' was doing). Fixes #26332 - - - - - 3 changed files: - compiler/GHC/Tc/Utils/Unify.hs - + testsuite/tests/linear/should_compile/T26332.hs - testsuite/tests/linear/should_compile/all.T Changes: ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -1853,8 +1853,8 @@ where we eta-expanded that (:). But now foldr expects an argument with ->{Many} and gets an argument with ->{m1} or ->{m2}, and Lint complains. -The easiest solution was to use tcEqMult in tc_sub_type_deep, and -insist on equality. This is only in the DeepSubsumption code anyway. +The easiest solution was to unify the multiplicities in tc_sub_type_deep, +insisting on equality. This is only in the DeepSubsumption code anyway. Note [FunTy vs non-FunTy case in tc_sub_type_deep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2047,10 +2047,7 @@ tc_sub_type_deep pos unify inst_orig ctxt ty_actual ty_expected -- GenSigCtxt: See Note [Setting the argument context] ; res_wrap <- tc_sub_type_deep (Result pos) unify inst_orig ctxt act_res exp_res - -- See Note [Multiplicity in deep subsumption] - ; tcEqMult inst_orig act_mult exp_mult - - ; mkWpFun_FRR pos + ; mkWpFun_FRR unify pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res arg_wrap res_wrap @@ -2058,20 +2055,32 @@ tc_sub_type_deep pos unify inst_orig ctxt ty_actual ty_expected where given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) --- | Like 'mkWpFun', except that it performs representation-polymorphism --- checks on the argument type. +-- | Like 'mkWpFun', except that it performs the necessary +-- representation-polymorphism checks on the argument type in the case that +-- we introduce a lambda abstraction. mkWpFun_FRR - :: Position p + :: (TcType -> TcType -> TcM TcCoercionN) -- ^ how to unify + -> Position p -> FunTyFlag -> Type -> TcType -> Type -- actual FunTy -> FunTyFlag -> Type -> TcType -> Type -- expected FunTy -> HsWrapper -- ^ exp_arg ~> act_arg -> HsWrapper -- ^ act_res ~> exp_res -> TcM HsWrapper -- ^ act_funTy ~> exp_funTy -mkWpFun_FRR pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res arg_wrap res_wrap - | needs_eta - -- See Wrinkle [Representation-polymorphism checking during subtyping] - = do { (exp_arg_co, exp_arg_frr) <- hasFixedRuntimeRep (FRRDeepSubsumption True pos) exp_arg - ; (act_arg_co, _act_arg_frr) <- hasFixedRuntimeRep (FRRDeepSubsumption False pos) act_arg +mkWpFun_FRR unify pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res arg_wrap res_wrap + = do { ((exp_arg_co, exp_arg_frr), (act_arg_co, _act_arg_frr)) <- + if needs_frr_checks + -- See Wrinkle [Representation-polymorphism checking during subtyping] + then do { exp_frr_wrap <- hasFixedRuntimeRep (frr_ctxt True ) exp_arg + ; act_frr_wrap <- hasFixedRuntimeRep (frr_ctxt False) act_arg + ; return (exp_frr_wrap, act_frr_wrap) } + else return ((mkNomReflCo exp_arg, exp_arg), (mkNomReflCo act_arg, act_arg)) + + -- Enforce equality of multiplicities (not the more natural sub-multiplicity). + -- See Note [Multiplicity in deep subsumption] + ; act_arg_mult_co <- unify act_mult exp_mult + -- NB: don't use tcEqMult: that would require the evidence for + -- equality to be Refl, but it might well not be (#26332). + ; let exp_arg_fun_co = mkFunCo Nominal exp_af @@ -2080,7 +2089,7 @@ mkWpFun_FRR pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res (mkReflCo Nominal exp_res) act_arg_fun_co = mkFunCo Nominal act_af - (mkReflCo Nominal act_mult) + act_arg_mult_co act_arg_co (mkReflCo Nominal act_res) arg_wrap_frr = @@ -2090,24 +2099,16 @@ mkWpFun_FRR pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res -- arg_wrap :: exp_arg ~> act_arg -- arg_wrap_frr :: exp_arg_frr ~> act_arg_frr - -- NB: because of the needs_eta guard, we know that mkWpFun will - -- return (WpFun ...); so we might as well just use the WpFun constructor. ; return $ mkWpCastN exp_arg_fun_co <.> - WpFun arg_wrap_frr res_wrap (Scaled exp_mult exp_arg_frr) + mkWpFun arg_wrap_frr res_wrap (Scaled exp_mult exp_arg_frr) exp_res <.> - mkWpCastN act_arg_fun_co } - | otherwise - = return $ - mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res - -- NB: because of 'needs_eta', this will never actually be a WpFun. - -- mkWpFun will turn it into a WpHole or WpCast, which is why - -- we can skip the hasFixedRuntimeRep checks in this case. - -- See Wrinkle [Representation-polymorphism checking during subtyping] + mkWpCastN act_arg_fun_co + } where - needs_eta :: Bool - needs_eta = + needs_frr_checks :: Bool + needs_frr_checks = not (hole_or_cast arg_wrap) || not (hole_or_cast res_wrap) @@ -2115,6 +2116,12 @@ mkWpFun_FRR pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res hole_or_cast WpHole = True hole_or_cast (WpCast {}) = True hole_or_cast _ = False + frr_ctxt :: Bool -> FixedRuntimeRepContext + frr_ctxt is_exp_ty = + FRRDeepSubsumption + { frrDSExpected = is_exp_ty + , frrDSPosition = pos + } ----------------------- deeplySkolemise :: SkolemInfo -> TcSigmaType ===================================== testsuite/tests/linear/should_compile/T26332.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE DeepSubsumption #-} +{-# LANGUAGE LinearTypes #-} + +module T26332 where + +import Unsafe.Coerce + +toLinear + :: forall a b p q. + (a %p-> b) %1-> (a %q-> b) +toLinear f = case unsafeEqualityProof @p @q of + UnsafeRefl -> f ===================================== testsuite/tests/linear/should_compile/all.T ===================================== @@ -41,6 +41,7 @@ test('T19400', unless(compiler_debugged(), skip), compile, ['']) test('T20023', normal, compile, ['']) test('T22546', normal, compile, ['']) test('T23025', normal, compile, ['-dlinear-core-lint']) +test('T26332', normal, compile, ['-O -dlinear-core-lint']) test('LinearRecUpd', normal, compile, ['']) test('T23814', normal, compile, ['']) test('LinearLet', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc79593d4606e5cea93e742a9f2def5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc79593d4606e5cea93e742a9f2def5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Add regression test for #26056
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0959d4bc by Andreas Klebinger at 2025-09-10T10:44:12-04:00 Add regression test for #26056 - - - - - 2 changed files: - + testsuite/tests/profiling/should_compile/T26056.hs - testsuite/tests/profiling/should_compile/all.T Changes: ===================================== testsuite/tests/profiling/should_compile/T26056.hs ===================================== @@ -0,0 +1,21 @@ +module M where + +import GHC.Exts ( Any ) +import Unsafe.Coerce ( unsafeCoerce ) + +data Sigma = MkT Any + +testSubList :: Maybe Bool -> Sigma -> Sigma +testSubList (Just x) final = {-# SCC "y" #-} ( + let x' = seq x () + in case testSubList Nothing final of + MkT w -> {-# SCC "x" #-} + (unsafeCoerce MkT (konst x' myHead (unsafeCoerce w)))) +testSubList Nothing final = final + +myHead :: [a] -> a +myHead (x:_) = x + +konst :: () -> ([a] -> a) -> [a] -> a +konst _ x = x +{-# OPAQUE konst #-} ===================================== testsuite/tests/profiling/should_compile/all.T ===================================== @@ -20,3 +20,4 @@ test('T14931', [test_opts, unless(have_dynamic(), skip)], test('T15108', [test_opts], compile, ['-O -prof -fprof-auto']) test('T19894', [test_opts, extra_files(['T19894'])], multimod_compile, ['Main', '-v0 -O2 -prof -fprof-auto -iT19894']) test('T20938', [test_opts], compile, ['-O -prof']) +test('T26056', [test_opts], compile, ['-O -prof']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0959d4bcdd0a52d270e5aced2cbdf3b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0959d4bcdd0a52d270e5aced2cbdf3b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Make rationalTo{Float,Double} inline in phase 0
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 45305ab8 by sheaf at 2025-09-10T10:43:29-04:00 Make rationalTo{Float,Double} inline in phase 0 We hold off on inlining these until phase 0 to allow constant-folding rules to fire. However, once we get to phase 0, we should inline them, e.g. to expose unboxing opportunities. See CLC proposal #356. - - - - - 2 changed files: - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Float.hs Changes: ===================================== libraries/base/changelog.md ===================================== @@ -4,6 +4,7 @@ * Remove deprecated, unstable heap representation details from `GHC.Exts` ([CLC proposal #212](https://github.com/haskell/core-libraries-committee/issues/212)) * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337)) * Fix issues with toRational for types capable to represent infinite and not-a-number values ([CLC proposal #338](https://github.com/haskell/core-libraries-committee/issues/338)) + * Ensure that `rationalToFloat` and `rationalToDouble` always inline in the end. ([CLC proposal #356](https://github.com/haskell/core-libraries-committee/issues/356)) * Modify the implementation of `Data.List.sortOn` to use `(>)` instead of `compare`. ([CLC proposal #332](https://github.com/haskell/core-libraries-committee/issues/332)) * `GHC.Exts.IOPort#` and its related operations have been removed ([CLC #213](https://github.com/haskell/core-libraries-committee/issues/213)) * Add `thenA` and `thenM`. ([CLC proposal #351](https://github.com/haskell/core-libraries-committee/issues/351)) ===================================== libraries/ghc-internal/src/GHC/Internal/Float.hs ===================================== @@ -466,8 +466,8 @@ instance Fractional Float where recip x = 1.0 / x rationalToFloat :: Integer -> Integer -> Float -{-# NOINLINE [0] rationalToFloat #-} --- Re NOINLINE pragma, see Note [realToFrac natural-to-float] +{-# INLINE [0] rationalToFloat #-} +-- Re INLINE pragma, see Note [realToFrac natural-to-float] rationalToFloat n 0 | n == 0 = 0/0 | n < 0 = (-1)/0 @@ -718,8 +718,8 @@ instance Fractional Double where recip x = 1.0 / x rationalToDouble :: Integer -> Integer -> Double -{-# NOINLINE [0] rationalToDouble #-} --- Re NOINLINE pragma, see Note [realToFrac natural-to-float] +{-# INLINE [0] rationalToDouble #-} +-- Re INLINE pragma, see Note [realToFrac natural-to-float] rationalToDouble n 0 | n == 0 = 0/0 | n < 0 = (-1)/0 @@ -1673,7 +1673,11 @@ Now we'd have a BUILTIN constant folding rule for rationalToFloat; but to allow that rule to fire reliably we should delay inlining rationalToFloat until stage 0. (It may get an inlining from CPR analysis.) -Hence the NOINLINE[0] rationalToFloat, and similarly rationalToDouble. +Hence the INLINE[0] rationalToFloat, and similarly for rationalToDouble. +This activation means: + + - we don't inline until phase 0 (solving the above) + - we do inline starting at phase 0 (because we do want it inlining in the end) -} -- Utils View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45305ab8bc002b0e9d482e43552b4f6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45305ab8bc002b0e9d482e43552b4f6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Fix a scoping error in Specialise
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b6249140 by Simon Peyton Jones at 2025-09-10T10:42:38-04:00 Fix a scoping error in Specialise This small patch fixes #26329, which triggered a scoping error. Test is in T21391, with -fpolymorphic-specialisation enabled - - - - - 1 changed file: - compiler/GHC/Core/Opt/Specialise.hs Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1205,14 +1205,21 @@ specExpr env (Tick tickish body) ---------------- Applications might generate a call instance -------------------- specExpr env expr@(App {}) = do { let (fun_in, args_in) = collectArgs expr + ; (fun_out, uds_fun) <- specExpr env fun_in ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in - ; let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_args - -- Some dicts may have floated out of args_in; - -- they should be in scope for fireRewriteRules (#21689) - (fun_in', args_out') = fireRewriteRules env_args fun_in args_out - ; (fun_out', uds_fun) <- specExpr env fun_in' + ; let uds_app = uds_fun `thenUDs` uds_args + env_args = zapSubst env `bringFloatedDictsIntoScope` ud_binds uds_app + -- zapSubst: we have now fully applied the substitution + -- bringFloatedDictsIntoScope: some dicts may have floated out of + -- args_in; they should be in scope for fireRewriteRules (#21689) + + -- Try firing rewrite rules + -- See Note [Fire rules in the specialiser] + ; let (fun_out', args_out') = fireRewriteRules env_args fun_out args_out + + -- Make a call record, and return ; let uds_call = mkCallUDs env fun_out' args_out' - ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) } + ; return (fun_out' `mkApps` args_out', uds_app `thenUDs` uds_call) } ---------------- Lambda/case require dumping of usage details -------------------- specExpr env e@(Lam {}) @@ -1246,17 +1253,18 @@ specExpr env (Let bind body) -- See Note [Specialisation modulo dictionary selectors] -- Note [ClassOp/DFun selection] -- Note [Fire rules in the specialiser] -fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr]) +fireRewriteRules :: SpecEnv -- Substitution is already zapped + -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr]) fireRewriteRules env (Var f) args | let rules = getRules (se_rules env) f , Just (rule, expr) <- specLookupRule env f args activeInInitialPhase rules , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target] - zapped_subst = Core.zapSubst (se_subst env) - expr' = simpleOptExprWith defaultSimpleOpts zapped_subst expr + zapped_subst = se_subst env -- Just needed for the InScopeSet + expr' = simpleOptExprWith defaultSimpleOpts zapped_subst (mkApps expr rest_args) -- simplOptExpr needed because lookupRule returns -- (\x y. rhs) arg1 arg2 , (fun', args') <- collectArgs expr' - = fireRewriteRules env fun' (args'++rest_args) + = fireRewriteRules env fun' args' fireRewriteRules _ fun args = (fun, args) -------------- @@ -1669,10 +1677,19 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs ; let all_rule_bndrs = poly_qvars ++ rule_bndrs env' = env { se_subst = subst'' } -{- - ; pprTrace "spec_call" (vcat + -- Check for (a) usefulness and (b) not already covered + -- See (SC1) in Note [Specialisations already covered] + ; let all_rules = rules_acc ++ existing_rules + -- all_rules: we look both in the rules_acc (generated by this invocation + -- of specCalls), and in existing_rules (passed in to specCalls) + already_covered = alreadyCovered env' all_rule_bndrs fn + rule_lhs_args is_active all_rules + +{- ; pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn , text "call info: " <+> ppr _ci + , text "useful: " <+> ppr useful + , text "already_covered:" <+> ppr already_covered , text "poly_qvars: " <+> ppr poly_qvars , text "useful: " <+> ppr useful , text "all_rule_bndrs:" <+> ppr all_rule_bndrs @@ -1681,17 +1698,13 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , text "dx_binds:" <+> ppr dx_binds , text "spec_args: " <+> ppr spec_args , text "rhs_bndrs" <+> ppr rhs_bndrs - , text "rhs_body" <+> ppr rhs_body ]) $ + , text "rhs_body" <+> ppr rhs_body + , text "subst''" <+> ppr subst'' ]) $ return () -} - -- Check for (a) usefulness and (b) not already covered - -- See (SC1) in Note [Specialisations already covered] - ; let all_rules = rules_acc ++ existing_rules - -- all_rules: we look both in the rules_acc (generated by this invocation - -- of specCalls), and in existing_rules (passed in to specCalls) - ; if not useful -- No useful specialisation - || alreadyCovered env' all_rule_bndrs fn rule_lhs_args is_active all_rules + ; if not useful -- No useful specialisation + || already_covered -- Useful, but done already then return spec_acc else @@ -1702,6 +1715,12 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- Run the specialiser on the specialised RHS ; (rhs_body', rhs_uds) <- specExpr env'' rhs_body +{- ; pprTrace "spec_call2" (vcat + [ text "fun:" <+> ppr fn + , text "rhs_body':" <+> ppr rhs_body' ]) $ + return () +-} + -- Make the RHS of the specialised function ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs' (rhs_uds1, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b62491405ae851ae514afe18d51f0fe… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b62491405ae851ae514afe18d51f0fe… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Report solid equality errors before custom errors
by Marge Bot (＠marge-bot) 10 Sep '25

10 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: ba210d98 by Simon Peyton Jones at 2025-09-08T16:26:36+01:00 Report solid equality errors before custom errors This MR fixes #26255 by * Reporting solid equality errors like Int ~ Bool before "custom type errors". See comments in `report1` in `reportWanteds` * Suppressing errors that arise from superclasses of Wanteds. See (SCE1) in Note [Suppressing confusing errors] More details in #26255. - - - - - 15 changed files: - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/HsToCore/Pmc/Solver.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/TcType.hs - testsuite/tests/typecheck/should_fail/T18851.hs - + testsuite/tests/typecheck/should_fail/T26255a.hs - + testsuite/tests/typecheck/should_fail/T26255a.stderr - + testsuite/tests/typecheck/should_fail/T26255b.hs - + testsuite/tests/typecheck/should_fail/T26255b.stderr - + testsuite/tests/typecheck/should_fail/T26255c.hs - + testsuite/tests/typecheck/should_fail/T26255c.stderr - testsuite/tests/typecheck/should_fail/UnliftedNewtypesFamilyKindFail2.stderr - testsuite/tests/typecheck/should_fail/all.T Changes: ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -132,7 +132,7 @@ module GHC.Core.Type ( kindBoxedRepLevity_maybe, mightBeLiftedType, mightBeUnliftedType, definitelyLiftedType, definitelyUnliftedType, - isAlgType, isDataFamilyAppType, + isAlgType, isDataFamilyApp, isSatTyFamApp, isPrimitiveType, isStrictType, isTerminatingType, isLevityTy, isLevityVar, isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, @@ -2292,6 +2292,21 @@ isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty isFamFreeTy (CastTy ty _) = isFamFreeTy ty isFamFreeTy (CoercionTy _) = False -- Not sure about this +-- | Check whether a type is a data family type +isDataFamilyApp :: Type -> Bool +isDataFamilyApp ty = case tyConAppTyCon_maybe ty of + Just tc -> isDataFamilyTyCon tc + _ -> False + +isSatTyFamApp :: Type -> Maybe (TyCon, [Type]) +-- Return the argument if we have a saturated type family application +-- Why saturated? See (ATF4) in Note [Apartness and type families] +isSatTyFamApp (TyConApp tc tys) + | isTypeFamilyTyCon tc + && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated + = Just (tc, tys) +isSatTyFamApp _ = Nothing + buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> KnotTied Type -> TyCon -- This function is here because here is where we have @@ -2459,12 +2474,6 @@ isAlgType ty isAlgTyCon tc _other -> False --- | Check whether a type is a data family type -isDataFamilyAppType :: Type -> Bool -isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of - Just tc -> isDataFamilyTyCon tc - _ -> False - -- | Computes whether an argument (or let right hand side) should -- be computed strictly or lazily, based only on its type. -- Currently, it's just 'isUnliftedType'. ===================================== compiler/GHC/Core/Unify.hs ===================================== @@ -1741,8 +1741,8 @@ unify_ty env ty1 ty2 kco where mb_tc_app1 = splitTyConApp_maybe ty1 mb_tc_app2 = splitTyConApp_maybe ty2 - mb_sat_fam_app1 = isSatFamApp ty1 - mb_sat_fam_app2 = isSatFamApp ty2 + mb_sat_fam_app1 = isSatTyFamApp ty1 + mb_sat_fam_app2 = isSatTyFamApp ty2 unify_ty _ _ _ _ = surelyApart @@ -1801,16 +1801,6 @@ unify_tys env orig_xs orig_ys -- Possibly different saturations of a polykinded tycon -- See Note [Polykinded tycon applications] ---------------------------------- -isSatFamApp :: Type -> Maybe (TyCon, [Type]) --- Return the argument if we have a saturated type family application --- Why saturated? See (ATF4) in Note [Apartness and type families] -isSatFamApp (TyConApp tc tys) - | isTypeFamilyTyCon tc - && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated - = Just (tc, tys) -isSatFamApp _ = Nothing - --------------------------------- uVarOrFam :: UMEnv -> CanEqLHS -> InType -> OutCoercion -> UM () -- Invariants: (a) If ty1 is a TyFamLHS, then ty2 is NOT a TyVarTy @@ -1927,7 +1917,7 @@ uVarOrFam env ty1 ty2 kco | otherwise -> maybeApart MARTypeFamily -- Check for equality F tys1 ~ F tys2 - | Just (tc2, tys2) <- isSatFamApp ty2 + | Just (tc2, tys2) <- isSatTyFamApp ty2 , tc1 == tc2 = go_fam_fam substs tc1 tys1 tys2 kco ===================================== compiler/GHC/HsToCore/Pmc/Solver.hs ===================================== @@ -363,7 +363,7 @@ pmTopNormaliseType (TySt _ inert) typ = {-# SCC "pmTopNormaliseType" #-} do eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys) is_closed_or_data_family :: Type -> Bool - is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty + is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyApp ty -- For efficiency, represent both lists as difference lists. -- comb performs the concatenation, for both lists. ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -439,10 +439,9 @@ reportBadTelescope _ _ skol_info skols -- See Note [Constraints to ignore]. ignoreConstraint :: Ct -> Bool ignoreConstraint ct - | AssocFamPatOrigin <- ctOrigin ct - = True - | otherwise - = False + = case ctOrigin ct of + AssocFamPatOrigin -> True -- See (CIG1) + _ -> False -- | Makes an error item from a constraint, calculating whether or not -- the item should be suppressed. See Note [Wanteds rewrite Wanteds] @@ -538,15 +537,15 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics ; when (null simples) $ reportMultiplicityCoercionErrs ctxt_for_insols mult_co_errs -- See Note [Suppressing confusing errors] - ; let (suppressed_items, items0) = partition suppress tidy_items + ; let (suppressed_items, reportable_items) = partition suppressItem tidy_items ; traceTc "reportWanteds suppressed:" (ppr suppressed_items) - ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0 + ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 reportable_items -- Now all the other constraints. We suppress errors here if -- any of the first batch failed, or if the enclosing context -- says to suppress ; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } - ; (ctxt3, leftovers) <- tryReporters ctxt2 report2 items1 + ; (_, leftovers) <- tryReporters ctxt2 report2 items1 ; massertPpr (null leftovers) (text "The following unsolved Wanted constraints \ \have not been reported to the user:" @@ -557,12 +556,16 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- wanted insoluble here; but do suppress inner insolubles -- if there's a *given* insoluble here (= inaccessible code) - -- Only now, if there are no errors, do we report suppressed ones - -- See Note [Suppressing confusing errors] - -- We don't need to update the context further because of the - -- whenNoErrs guard - ; whenNoErrs $ - do { (_, more_leftovers) <- tryReporters ctxt3 report3 suppressed_items + -- If there are no other errors to report, report suppressed errors. + -- See Note [Suppressing confusing errors]. NB: with -fdefer-type-errors + -- we might have reported warnings only from `reportable_items`, but we + -- still want to suppress the `suppressed_items`. + ; when (null reportable_items) $ + do { (_, more_leftovers) <- tryReporters ctxt_for_insols (report1++report2) + suppressed_items + -- ctxt_for_insols: the suppressed errors can be Int~Bool, which + -- will have made the incoming `ctxt` be True; don't make that + -- suppress the Int~Bool error! ; massertPpr (null more_leftovers) (ppr more_leftovers) } } where env = cec_tidy ctxt @@ -585,29 +588,42 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics DE_Multiplicity mult_co loc -> (es1, es2, es3, (mult_co, loc):es4) - -- See Note [Suppressing confusing errors] - suppress :: ErrorItem -> Bool - suppress item - | Wanted <- ei_flavour item - = is_ww_fundep_item item - | otherwise - = False - -- report1: ones that should *not* be suppressed by -- an insoluble somewhere else in the tree -- It's crucial that anything that is considered insoluble -- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise -- we might suppress its error message, and proceed on past -- type checking to get a Lint error later - report1 = [ ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) - -- (Handles TypeError and Unsatisfiable) + report1 = [ -- We put implicit lifting errors first, because are solid errors + -- See "Implicit lifting" in GHC.Tc.Gen.Splice + -- Note [Lifecycle of an untyped splice, and PendingRnSplice] + ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter) - , ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter) + -- Next, solid equality errors , given_eq_spec , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr) , ("skolem eq1", very_wrong, True, mkSkolReporter) , ("FixedRuntimeRep", is_FRR, True, mkGroupReporter mkFRRErr) , ("skolem eq2", skolem_eq, True, mkSkolReporter) + + -- Next, custom type errors + -- See Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint + -- + -- Put custom type errors /after/ solid equality errors. In #26255 we + -- had a custom error (T <= F alpha) which was suppressing a far more + -- informative (K Int ~ [K alpha]). That mismatch between K and [] is + -- definitely wrong; and if it was fixed we'd know alpha:=Int, and hence + -- perhaps be able to solve T <= F alpha, by reducing F Int. + -- + -- But put custom type errors /before/ "non-tv eq", because if we have + -- () ~ TypeError blah + -- we want to report it as a custom error, /not/ as a mis-match + -- between TypeError and ()! Also see the Assert example + -- in Note [Custom type errors in constraints] + , ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) + -- (Handles TypeError and Unsatisfiable) + + -- "non-tv-eq": equalities (ty1 ~ ty2) where ty1 is not a tyvar , ("non-tv eq", non_tv_eq, True, mkSkolReporter) -- The only remaining equalities are alpha ~ ty, @@ -617,6 +633,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- See Note [Equalities with heterogeneous kinds] in GHC.Tc.Solver.Equality , ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr) , ("Other eqs", is_equality, True, mkGroupReporter mkEqErr) + ] -- report2: we suppress these if there are insolubles elsewhere in the tree @@ -625,11 +642,6 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) , ("Quantified", is_qc, False, mkGroupReporter mkQCErr) ] - -- report3: suppressed errors should be reported as categorized by either report1 - -- or report2. Keep this in sync with the suppress function above - report3 = [ ("wanted/wanted fundeps", is_ww_fundep, True, mkGroupReporter mkEqErr) - ] - -- rigid_nom_eq, rigid_nom_tv_eq, is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool @@ -690,10 +702,6 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics is_qc _ (ForAllPred {}) = True is_qc _ _ = False - -- See situation (1) of Note [Suppressing confusing errors] - is_ww_fundep item _ = is_ww_fundep_item item - is_ww_fundep_item = isWantedWantedFunDepOrigin . errorItemOrigin - given_eq_spec -- See Note [Given errors] | has_gadt_match_here = ("insoluble1a", is_given_eq, True, mkGivenErrorReporter) @@ -719,6 +727,16 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics = has_gadt_match implics --------------- +suppressItem :: ErrorItem -> Bool + -- See Note [Suppressing confusing errors] +suppressItem item + | Wanted <- ei_flavour item + , let orig = errorItemOrigin item + = isWantedSuperclassOrigin orig -- See (SCE1) + || isWantedWantedFunDepOrigin orig -- See (SCE2) + | otherwise + = False + isSkolemTy :: TcLevel -> Type -> Bool -- The type is a skolem tyvar isSkolemTy tc_lvl ty @@ -741,9 +759,25 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of Certain errors we might encounter are potentially confusing to users. If there are any other errors to report, at all, we want to suppress these. -Which errors (only 1 case right now): - -1) Errors which arise from the interaction of two Wanted fun-dep constraints. +Which errors are suppressed? + +(SCE1) Superclasses of Wanteds. These are generated only in case they trigger functional + dependencies. If such a constraint is unsolved, then its "parent" constraint must + also be unsolved, and is much more informative to the user. Example (#26255): + class (MinVersion <= F era) => Era era where { ... } + f :: forall era. EraFamily era -> IO () + f = ..blah... -- [W] Era era + Here we have simply omitted "Era era =>" from f's type. But we'll end up with + /two/ Wanted constraints: + [W] d1 : Era era + [W] d2 : MinVersion <= F era -- Superclass of d1 + We definitely want to report d1 and not d2! Happily it's easy to filter out those + superclass-Wanteds, becuase their Origin betrays them. + + See test T18851 for an example of how it is (just, barely) possible for the /only/ + errors to be superclass-of-Wanted constraints. + +(SCE2) Errors which arise from the interaction of two Wanted fun-dep constraints. Example: class C a b | a -> b where @@ -786,7 +820,7 @@ they will remain unfilled, and might have been used to rewrite another constrain Currently, the constraints to ignore are: -1) Constraints generated in order to unify associated type instance parameters +(CIG1) Constraints generated in order to unify associated type instance parameters with class parameters. Here are two illustrative examples: class C (a :: k) where @@ -814,6 +848,9 @@ Currently, the constraints to ignore are: If there is any trouble, checkValidFamInst bleats, aborting compilation. +(Note: Aug 25: this seems a rather tricky corner; + c.f. Note [Suppressing confusing errors]) + Note [Implementation of Unsatisfiable constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Unsatisfiable constraint was introduced in GHC proposal #433 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-u…) ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -903,75 +903,6 @@ isWantedCt = isWanted . ctEvidence isGivenCt :: Ct -> Bool isGivenCt = isGiven . ctEvidence -{- Note [Custom type errors in constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When GHC reports a type-error about an unsolved-constraint, we check -to see if the constraint contains any custom-type errors, and if so -we report them. Here are some examples of constraints containing type -errors: - -TypeError msg -- The actual constraint is a type error - -TypError msg ~ Int -- Some type was supposed to be Int, but ended up - -- being a type error instead - -Eq (TypeError msg) -- A class constraint is stuck due to a type error - -F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err - -It is also possible to have constraints where the type error is nested deeper, -for example see #11990, and also: - -Eq (F (TypeError msg)) -- Here the type error is nested under a type-function - -- call, which failed to evaluate because of it, - -- and so the `Eq` constraint was unsolved. - -- This may happen when one function calls another - -- and the called function produced a custom type error. --} - --- | A constraint is considered to be a custom type error, if it contains --- custom type errors anywhere in it. --- See Note [Custom type errors in constraints] -getUserTypeErrorMsg :: PredType -> Maybe ErrorMsgType -getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred - : map getUserTypeErrorMsg (subTys pred) - where - -- Richard thinks this function is very broken. What is subTys - -- supposed to be doing? Why are exactly-saturated tyconapps special? - -- What stops this from accidentally ripping apart a call to TypeError? - subTys t = case splitAppTys t of - (t,[]) -> - case splitTyConApp_maybe t of - Nothing -> [] - Just (_,ts) -> ts - (t,ts) -> t : ts - --- | Is this an user error message type, i.e. either the form @TypeError err@ or --- @Unsatisfiable err@? -isTopLevelUserTypeError :: PredType -> Bool -isTopLevelUserTypeError pred = - isJust (userTypeError_maybe pred) || isJust (isUnsatisfiableCt_maybe pred) - --- | Does this constraint contain an user error message? --- --- That is, the type is either of the form @Unsatisfiable err@, or it contains --- a type of the form @TypeError msg@, either at the top level or nested inside --- the type. -containsUserTypeError :: PredType -> Bool -containsUserTypeError pred = - isJust (getUserTypeErrorMsg pred) || isJust (isUnsatisfiableCt_maybe pred) - --- | Is this type an unsatisfiable constraint? --- If so, return the error message. -isUnsatisfiableCt_maybe :: Type -> Maybe ErrorMsgType -isUnsatisfiableCt_maybe t - | Just (tc, [msg]) <- splitTyConApp_maybe t - , tc `hasKey` unsatisfiableClassNameKey - = Just msg - | otherwise - = Nothing - isPendingScDict :: Ct -> Bool isPendingScDict (CDictCan dict_ct) = isPendingScDictCt dict_ct isPendingScDict _ = False @@ -1413,6 +1344,93 @@ variable masquerading as expression holes IS treated as truly insoluble, so that it trumps other errors during error reporting. Yuk! +-} + +{- ********************************************************************* +* * + Custom type errors: Unsatisfiable and TypeError +* * +********************************************************************* -} + +{- Note [Custom type errors in constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When GHC reports a type-error about an unsolved-constraint, we check +to see if the constraint contains any custom-type errors, and if so +we report them. Here are some examples of constraints containing type +errors: + + TypeError msg -- The actual constraint is a type error + + TypError msg ~ Int -- Some type was supposed to be Int, but ended up + -- being a type error instead + + Eq (TypeError msg) -- A class constraint is stuck due to a type error + + F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err + +It is also possible to have constraints where the type error is nested deeper, +for example see #11990, and also: + + Eq (F (TypeError msg)) -- Here the type error is nested under a type-function + -- call, which failed to evaluate because of it, + -- and so the `Eq` constraint was unsolved. + -- This may happen when one function calls another + -- and the called function produced a custom type error. + +A good use-case is described in "Detecting the undetectable" + https://blog.csongor.co.uk/report-stuck-families/ +which features + type family Assert (err :: Constraint) (break :: Type -> Type) (a :: k) :: k where + Assert _ Dummy _ = Any + Assert _ _ k = k +and an unsolved constraint like + Assert (TypeError ...) (F ty1) ty1 ~ ty2 +that reports that (F ty1) remains stuck. +-} + +-- | A constraint is considered to be a custom type error, if it contains +-- custom type errors anywhere in it. +-- See Note [Custom type errors in constraints] +getUserTypeErrorMsg :: PredType -> Maybe ErrorMsgType +getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred + : map getUserTypeErrorMsg (subTys pred) + where + -- Richard thinks this function is very broken. What is subTys + -- supposed to be doing? Why are exactly-saturated tyconapps special? + -- What stops this from accidentally ripping apart a call to TypeError? + subTys t = case splitAppTys t of + (t,[]) -> + case splitTyConApp_maybe t of + Nothing -> [] + Just (_,ts) -> ts + (t,ts) -> t : ts + +-- | Is this an user error message type, i.e. either the form @TypeError err@ or +-- @Unsatisfiable err@? +isTopLevelUserTypeError :: PredType -> Bool +isTopLevelUserTypeError pred = + isJust (userTypeError_maybe pred) || isJust (isUnsatisfiableCt_maybe pred) + +-- | Does this constraint contain an user error message? +-- +-- That is, the type is either of the form @Unsatisfiable err@, or it contains +-- a type of the form @TypeError msg@, either at the top level or nested inside +-- the type. +containsUserTypeError :: PredType -> Bool +containsUserTypeError pred = + isJust (getUserTypeErrorMsg pred) || isJust (isUnsatisfiableCt_maybe pred) + +-- | Is this type an unsatisfiable constraint? +-- If so, return the error message. +isUnsatisfiableCt_maybe :: Type -> Maybe ErrorMsgType +isUnsatisfiableCt_maybe t + | Just (tc, [msg]) <- splitTyConApp_maybe t + , tc `hasKey` unsatisfiableClassNameKey + = Just msg + | otherwise + = Nothing + +{- ************************************************************************ * * Implication constraints ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -2090,6 +2090,7 @@ isRigidTy ty | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal | Just {} <- tcSplitAppTy_maybe ty = True | isForAllTy ty = True + | Just {} <- isLitTy ty = True | otherwise = False {- ===================================== testsuite/tests/typecheck/should_fail/T18851.hs ===================================== @@ -33,3 +33,14 @@ f = show (undefined :: c) -- blows up at run time once type checks g :: String g = f @A @B + +{- +[W] Show c, Num int, C int A, C int B, C int c +Superclasses + C_FD int ~ A + C_FD int ~ B + C_FD int ~ c +--> + C_FD int ~ B + B ~ A +-} ===================================== testsuite/tests/typecheck/should_fail/T26255a.hs ===================================== @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module T26255a where + +import Data.Proxy +import GHC.TypeLits + +type MinVersion = 1 + +class + ( KnownNat (ProtVerLow era) + , MinVersion <= ProtVerLow era + , KnownSymbol (EraName era) + ) => + Era era + where + type EraName era = (r :: Symbol) | r -> era + + type ProtVerLow era :: Nat + + eraName :: Proxy era -> String + eraName _ = symbolVal (Proxy :: Proxy (EraName era)) + +data FooEra + +instance Era FooEra where + type EraName FooEra = "Foo" + type ProtVerLow FooEra = 1 + +data BarEra + +instance Era BarEra where + type EraName BarEra = "Bar" + type ProtVerLow BarEra = 2 + +fromEraName :: (Era era, EraName era ~ name) => Proxy (name :: Symbol) -> Proxy era +fromEraName _ = Proxy + +noCompileErrorMessage :: IO () +noCompileErrorMessage = putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Bar") + +brokenCompileErrorMessage1 :: IO () +brokenCompileErrorMessage1 = putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Blah") + ===================================== testsuite/tests/typecheck/should_fail/T26255a.stderr ===================================== @@ -0,0 +1,10 @@ +T26255a.hs:46:51: error: [GHC-18872] + • Couldn't match type ‘EraName era0’ with ‘"Blah"’ + arising from a use of ‘fromEraName’ + The type variable ‘era0’ is ambiguous + • In the second argument of ‘($)’, namely + ‘fromEraName (Proxy :: Proxy "Blah")’ + In the second argument of ‘($)’, namely + ‘eraName $ fromEraName (Proxy :: Proxy "Blah")’ + In the expression: + putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Blah") ===================================== testsuite/tests/typecheck/should_fail/T26255b.hs ===================================== @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module T26255b where + +import Data.Proxy +import GHC.TypeLits + +type MinVersion = 1 + +class + ( KnownNat (ProtVerLow era) + , MinVersion <= ProtVerLow era + , KnownSymbol (EraName era) + ) => + Era era + where + type EraName era = (r :: Symbol) | r -> era + + type ProtVerLow era :: Nat + + eraName :: Proxy era -> String + eraName _ = symbolVal (Proxy :: Proxy (EraName era)) + +data FooEra + +instance Era FooEra where + type EraName FooEra = "Foo" + type ProtVerLow FooEra = 1 + +data BarEra + +instance Era BarEra where + type EraName BarEra = "Bar" + type ProtVerLow BarEra = 2 + +fromEraName :: (Era era, EraName era ~ name) => Proxy (name :: Symbol) -> Proxy era +fromEraName _ = Proxy + +noCompileErrorMessage :: IO () +noCompileErrorMessage = putStrLn $ eraName $ fromEraName (Proxy :: Proxy "Bar") + +brokenCompileErrorMessage2 :: IO () +brokenCompileErrorMessage2 = putStrLn $ eraName $ head $ fromEraName (Proxy :: Proxy "Bar") ===================================== testsuite/tests/typecheck/should_fail/T26255b.stderr ===================================== @@ -0,0 +1,9 @@ +T26255b.hs:46:58: error: [GHC-83865] + • Couldn't match expected type: [Proxy era0] + with actual type: Proxy BarEra + • In the second argument of ‘($)’, namely + ‘fromEraName (Proxy :: Proxy "Bar")’ + In the second argument of ‘($)’, namely + ‘head $ fromEraName (Proxy :: Proxy "Bar")’ + In the second argument of ‘($)’, namely + ‘eraName $ head $ fromEraName (Proxy :: Proxy "Bar")’ ===================================== testsuite/tests/typecheck/should_fail/T26255c.hs ===================================== @@ -0,0 +1,30 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module T26255c where + +import Data.Kind +import Data.Proxy +import GHC.TypeLits + +type MinVersion = 1 + +class + ( KnownNat (ProtVerLow era) + , MinVersion <= ProtVerLow era + ) => + Era era + where + type ProtVerLow era :: Nat + +newtype EraFamily era = EraFamily Int + +class Era era => NewEra era where + eraFamilySize :: EraFamily era -> Int + +printEraFamilySize :: EraFamily era -> IO () +printEraFamilySize = print . eraFamilySize ===================================== testsuite/tests/typecheck/should_fail/T26255c.stderr ===================================== @@ -0,0 +1,11 @@ +T26255c.hs:30:30: error: [GHC-39999] + • No instance for ‘NewEra era’ + arising from a use of ‘eraFamilySize’ + Possible fix: + add (NewEra era) to the context of + the type signature for: + printEraFamilySize :: forall {k} (era :: k). EraFamily era -> IO () + • In the second argument of ‘(.)’, namely ‘eraFamilySize’ + In the expression: print . eraFamilySize + In an equation for ‘printEraFamilySize’: + printEraFamilySize = print . eraFamilySize ===================================== testsuite/tests/typecheck/should_fail/UnliftedNewtypesFamilyKindFail2.stderr ===================================== @@ -1,3 +1,7 @@ +UnliftedNewtypesFamilyKindFail2.hs:12:1: error: [GHC-83865] + • Expected a type, but ‘F 5’ has kind ‘5’ + • In the newtype family instance declaration for ‘F’ + UnliftedNewtypesFamilyKindFail2.hs:12:20: error: [GHC-83865] • Expected a type, but ‘5’ has kind ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -742,3 +742,5 @@ test('T25004', normal, compile_fail, ['']) test('T25004k', normal, compile_fail, ['']) test('T26004', normal, compile_fail, ['']) test('T26318', normal, compile_fail, ['']) +test('T26255a', normal, compile_fail, ['']) +test('T26255b', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba210d981b0812aea604f884d3c0aad… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba210d981b0812aea604f884d3c0aad… You're receiving this email because of your account on gitlab.haskell.org.

1 0